Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses

Cool Uses for Perl

( #1044=superdoc: print w/ replies, xml ) Need Help??

This section is the place to post your general code offerings -- everything from one-liners to full-blown frameworks and apps.

1 direct reply — Read more / Contribute
by QuillMeantTen
on Sep 20, 2015 at 07:42

    After a first try that contained some (at least for me) hard to track bugs in the function used to preserve the max heap property of trees and then some much needed refactoring and variable renaming to make the code less cryptic (both thanks to the hints given to me by Athanasius, praised may be his name) I can now give here a working perl implementation of smoothsort.
    If anyone can give me hints to make it even more understandable and readable I will update it

    Update :@Athanasius: got rid of line 110 and its error leftover from my print debug statements

    @ww: Got rid of 2 to make it proper for CUFP, since it seems that saying that improvements suggestions are welcome make this post unfit for CUFP

    Link to SoPW post

Automatically inject trace code into Perl files
No replies — Read more | Post response
by stevieb
on Sep 13, 2015 at 17:01

    About 10 years ago, I wrote a project that contained a dozen modules and a couple of hundred subs. Following the flow was a nightmare until I added trace code to each sub. I then set out on a journey to develop a module that will automatically inject this tracing, and after 10 years of off-and-on Perl programming, these objectives are now a reality in my new Devel::Trace::Subs module.

    This module will install the appropriate use statement, along with the appropriate tracing call to all subs (functions or methods) within a file, within all files in a directory (selective by file extension) or within production modules live-time by using a Module::Name. Of course, you can back this automation out simply with a different call.

    The typical SYNOPSIS will work, using the traditional use Devel::Trace::Subs qw(trace); and then adding the trace(); call to every single sub you want to support, but automation is what programming is for.

    We'll start with the most basic example, a single script file with multiple subs:

    use warnings; use strict; one(); exit(0); sub one { my $str = 'hello, world!'; two($str); } sub two { my $str = shift; $str =~ s/hello/goodbye/; three($str); } sub three { my $str = shift; print "$str\n"; }

    Which does this when run...

    goodbye, world!

    Now we'll install tracing into it (easiest from the command line, but you can of course script it as well):

    perl -wMstrict -MDevel::Trace::Subs=install_trace -e 'install_trace(fi +le => "");'

    Let's check to see what happened to our original file:

    use Devel::Trace::Subs qw(trace trace_dump); # injected by Devel::Trac +e::Subs use warnings; use strict; one(); exit(0); sub one { trace() if $ENV{DTS_ENABLE}; # injected by Devel::Trace::Subs my $str = 'hello, world!'; two($str); } sub two { trace() if $ENV{DTS_ENABLE}; # injected by Devel::Trace::Subs my $str = shift; $str =~ s/hello/goodbye/; three($str); } sub three { trace() if $ENV{DTS_ENABLE}; # injected by Devel::Trace::Subs my $str = shift; print "$str\n"; }

    We have to add a couple of lines of code to the calling script manually (in this case, the calling script is the same file that contains the subs we're tracing, so we add them there).

    $ENV{DTS_ENABLE} = 1; # add this line before the first sub call trace_dump(); # add this line after the last sub call

    NOTE: To disable all tracing ability globally, simply set the single environment variable to a false value (or comment it out, etc).

    Now let's see what the output is:

    goodbye, world! Code flow: 1: main::one 2: main::two 3: main::three Stack trace: in: main::one sub: - file: ./ line: 8 package: main in: main::two sub: main::one file: ./ line: 19 package: main in: main::three sub: main::two file: ./ line: 27 package: main

    To remove all traces of the auto install feature, simply:

    perl -wMstrict -MDevel::Trace::Subs=remove_trace -e 'remove_trace(file + => "");'

    ...and then manually remove the $ENV{DTS_ENABLE} = 1; and trace_dump(); lines from the calling script (again, in this case, it was all done in a single file).

    This was the most basic example. I have tested it on my projects that have numerous modules/packages, as well as live files by specifying a directory or Module::Name to the 'file' parameter in the install_trace() CLI call.

    install_trace() parameters (only file is mandatory):

    • file => 'filename' or dir, or Module::Name
    • extensions => [qw(pl pm)] which is the default for dirs

    trace_dump() parameters (all are optional):

    • want => 'string' where 'string' is either 'flow' or 'stack', which will dump only that portion. Default is both
    • type => 'html' dumps the output in HTML table format instead of plain text table format
    • file => 'file.ext' the dump output will be placed in this file, regardless of format


    Ever wanted to see what a module you use frequently does internally? Let's take Data::Dump:

    sudo perl -MDevel::Trace::Subs=install_trace -e 'install_trace(file=>" +Data::Dump");'
    perl -MData::Dump -MDevel::Trace::Subs=trace_dump -e '$ENV{DTS_ENABLE} +=1; dd {a => 1}; trace_dump' { a => 1 } Code flow: 1: Data::Dump::dd 2: Data::Dump::dump 3: Data::Dump::_dump 4: Data::Dump::tied_str 5: Data::Dump::_dump 6: Data::Dump::format_list Stack trace: in: Data::Dump::dd sub: - file: -e line: 1 package: main in: Data::Dump::dump sub: Data::Dump::dd file: /usr/lib/perl5/site_perl/5.22.0/Data/ line: 84 package: Data::Dump in: Data::Dump::_dump sub: Data::Dump::dump file: /usr/lib/perl5/site_perl/5.22.0/Data/ line: 36 package: Data::Dump in: Data::Dump::tied_str sub: Data::Dump::_dump file: /usr/lib/perl5/site_perl/5.22.0/Data/ line: 292 package: Data::Dump in: Data::Dump::_dump sub: Data::Dump::_dump file: /usr/lib/perl5/site_perl/5.22.0/Data/ line: 331 package: Data::Dump in: Data::Dump::format_list sub: Data::Dump::dump file: /usr/lib/perl5/site_perl/5.22.0/Data/ line: 65 package: Data::Dump
    sudo perl -MDevel::Trace::Subs=remove_trace -e 'remove_trace(file=>"Da +ta::Dump");'


    • does not yet catch subs that have an opening brace that is after a newline on the line a sub is defined fixed in v0.06
    • this module places a Storable file inside of the directory the base calling script is called from. I'm still trying to figure out a way to make this non-root and cross-platform for scripts that are in root-only writable dirs
    • although it does inject into AnonySubs, if the anon sub is a one-liner, it will currently be overlooked (due to not having implemented PPI insertion here yet... next version)
    • I'm sure there are other subtle bugs as this is pretty well first version

    There are too many todo's to list here as this is first incarnation. I'm hoping some others will find interest and do some real-world testing and tell me how bad the code is, so I can fix those issues while I continue to try to better my coding practice. That said, my biggest two are encompassing more within my PPI regime, and related to that, fixing the insertions/deletions to *all* subs that use all declarative structures, and the removal of such, including newlines added.


    There are quite a few. The most important are Devel::Examine::Subs v1.43+, Template, HTML::Template, and dependencies on those modules: PPI, Data::Compare and a couple of other small ones.


Recursively list all files on a network shared drive on windows
No replies — Read more | Post response
by ambrus
on Sep 11, 2015 at 11:03

    Use this script on a windows system to recursively list all files on a network shared drive (or a local directory if you wish). Change the value of $outfname and @startpath before you run it.

    The files are listed with meta-data. First column contains the file size, or total size of files conained in a directory, followed by an indicator of the file type: "/" for a directory, "@" for a symlink, "~" for a symlink to directory, "?" for error in lstat, "!" for error in opendir. The latter two markers could show up when files are deleted while you are producing the listing. Second column is creation date, third column is modification date, last is filename and, for symlinks, link target.

    #!perl use warnings; use 5.016; use Time::HiRes (); use Encode; use Win32::LongPath (); use Unicode::Collate (); our $outfname = q(C:\somedir\list.txt); our @startpath = ( "\\\\HOSTNAME\\sharename", ); open our$outf, ">:encoding(utf8)", $outfname or die; our $pro_count = 0; our $pro_time = Time::HiRes::time(); our $pro_gran = 1251; our $coll = Unicode::Collate->new; sub visit { my($path, $addto_ref) = @_; my$stat = Win32::LongPath::lstatL($path); my$isdir = $stat && 0 != (0x10 & $$stat{attribs}); my$islink = $stat && 0 != (0x400 & $$stat{attribs}); my$typestr = !$stat ? "?" : $islink ? ($isdir ? "~" : "@") : $isdi +r ? "/" : " "; my$mdatestr = "?"; my$cdatestr = "?"; if ($stat) { my($ms,$mm,$mh,$md,$mb,$my) = gmtime($$stat{ctime}); $mdatestr = sprintf "%04d-%02d-%02d", 1900+$my, 1+$mb, $md; my($cs,$cm,$ch,$cd,$cb,$cy) = gmtime($$stat{mtime}); $cdatestr = sprintf "%04d-%02d-%02d", 1900+$cy, 1+$cb, $cd; } my$readlink = $islink ? Win32::LongPath::readlinkL($path) : undef( +); my$linkstr = defined($readlink) ? "\t>" . $readlink : ""; my$size = $stat ? 0 + $$stat{size} : 0; if (!$islink && $isdir) { my$dh = Win32::LongPath->new; my$ok = $dh->opendirL($path); if ($ok) { $^E = 0; my@n = $dh->readdirL; if (18 != $^E) { warn qq(warning: readdir "$path" $^E ), 0 ++$^E; } @n = $coll->sort(@n); $dh->closedirL; for my$n (@n) { "." eq $n || ".." eq $n and next; if (!length($n) || $n =~ y|/\\||) { warn qq(wtf strange name in directory: "$path" "$n +"); next; } my$p = $path . "\\" . $n; my$a = \$size; visit($p, $a); } } else { $typestr = "!"; } } $$addto_ref += $size; printf $outf "%12d%1s %10s %10s %s%s\n", $size, $typestr, $mdatestr, $cdatestr, $path, $linkstr; $outf->flush; if (0 == ++$pro_count % $pro_gran) { my$n = Time::HiRes::time(); my$d = $n - $pro_time; printf STDERR qq(progress %9d %.2f "%s"), $pro_count, $d, enco +de_utf8($path); Time::HiRes::sleep(0.9 + 2.2 * abs($d)); printf STDERR qq(;\n); $pro_time = Time::HiRes::time(); } } for my$p (@startpath) { warn qq(starting from "$p"); my$total_sz = 0; visit($p, \$total_sz) } warn qq(lsrecursive all done.); __END__

    Update: changed text to describe ascended bug in the program where the ctime and mtime were swapped.

create_c_project with tap harness
1 direct reply — Read more / Contribute
by QuillMeantTen
on Sep 11, 2015 at 06:34

    Greetings fellow monks,
    Too sick to be able to crawl to my classes I sat at my workbench and started hammering away at my latest obsession After devouring calcote fine autotools book I finally got it to work as I wanted it to (the obsession, not the book).
    Alas as many of you may know trial and error is a bitch especially if your mind is deprived from his usual clarity by the wicked veils of sickness.

    Pretty sure that by the end of my exhaustion induced nap with my cat I would have completely forgotten how I did it (and thanks to said veils I have not versionned correctly each trial) I set up to write the following script :

    Given a path to your newly created c project folder and one to your c-tap-harness folder it will create a new project with the set of files needed by autotools.
    Fellow monks that dabble in the Deep and Dark arts of C programming I give you those tools so you can use them or discard them as you see fit.

    As always I am eager for ways to get better at perling so if you spot errors or ways to improve that script I am all electronic ears and shall follow up on your suggestions

    Yours, still relatively coherent,

    and now :
    Update: thanks for the good idea about filepath, I have updated the code and got rid of a silly bug related to the placement of AUTOMAKE_INIT and such things inside

    Yet Another update : fixed some issues and made the resulting project folder easier to work with (mainly by sprinkling it with symlinks and moving object files around)

    And now the last update, I got everything working so make dist really distribute everything important

    And the last update, promised, this time the template makefile works for distclean type commands

C test suite management with perl
1 direct reply — Read more / Contribute
by QuillMeantTen
on Sep 09, 2015 at 12:46

    Greetings fellow monks,
    for my studies at the university I recently endeavored with a friend to prepare the best infrastructure for the long term projects we are to be given later this year.
    Amongst other things we set up a continuous integration environment, an xmpp server for team communications and that kind of things.
    Since we both are big fans of test driven development and I fell in love with the TAP protocol as I started writing my own modules I decided to give this library a shot. After some manipulations I got it to work and started writing on scripts that would allow us to easily build and centralize test logs.

    Thing is in previous projects we did that kind of thing in big and unwieldy bash scripts. I decided to do it in perl but hit quite the roadblock : my friend does not know perl and has no intention to learn it in the foreseeable future.

    I prepared the following solution :

    One makefile that calls the script (with whatever parameter are needed) and a script that goes through all the files in the tests directory, run all tests, log results, if some tests fail it creates two files, one for all failed test for the file tested and another with all the tests for the file tested to give it some context.

    here is

    here is :

    and the main project makefile :

    The unchecked target is used to build the project without running the test scripts.
    It is important to take into account that inside the tests folder each subfolder contains its own makefile to build the test executable and then clean after tests have been run.

    As always I post here hungry for ways to make that code better, more efficient or solve overlooked issues or design problems.
    Also I hope that someone might have a use for it ^^
    Kind Regards.

Doomsday algorithm
3 direct replies — Read more / Contribute
by QuillMeantTen
on Sep 06, 2015 at 10:06

    Thanks to this piece on wired I learnt about conway's doomsday algorithm to get the day of the week of any date.
    Trying to wrap my head around the algorithm I decided to implement it as a learning exercise.
    Here is the code, enjoy :D

    Update, now with use strict!

Amazon S3 Etag calculator
No replies — Read more | Post response
by jellisii2
on Sep 04, 2015 at 08:02

    With a bit of research (here and here primarily), I sorted out a pure perl way to calculate the etag for an object on S3.

    My motivation was that I'm having to sync data from an S3 bucket for $work so a user can do work on the files that are put there by a third party. I wanted to ensure that the files I had were complete and hadn't changed.

    The only external requirement to actually use the calculator is to know the chunk size of the multi-part upload. I was able to guess this by running some rough math, but the person who uploaded the file (or you, if you're uploading the file) can provide this value to you.

    use strict; use warnings; use Digest::MD5 qw(md5 md5_hex); # needs a file name and a value for the multi-part chunk size in MB. print "etag for $ARGV[0] = " . calculate_etag(@ARGV) . "\n"; sub calculate_etag { my ($file, $chunk_size) = @_; print "Calculating etag of $file...\n"; my $string; my $count = 0; open(my $FILE, '<', $file); binmode $FILE; while (read($FILE, my $data, 1048576 * $chunk_size) { my $chunk_md5 = md5($data); $string .= $chunk_md5; $count++; } close($FILE); return(md5_hex($string) . "-$count"); }
Fetch 'netstat' session status counts
1 direct reply — Read more / Contribute
by stevieb
on Sep 03, 2015 at 20:56

    Cross-platform netstat status count script. Displays some or all of the statuses. Using the -a flag with an integer as an argument to it, will loop every integer seconds and display the updated stats.

    Use --help or -h to see a list of all statuses available.

    Thanks to Discipulus for adding much of the new functionality.

    Here's the original version I had posted here.

    #!/usr/bin/perl use strict; use warnings; use Getopt::Long; # my $VERSION = 0.04; # originally posted at # thanks to Discipulus from over at PerlMonks who # added the original usage output, added the remaining statuses # and added the Getopt::Long functionality my $platform = $^O; my @wanted = qw( ESTABLISHED SYN_SENT SYN_RECV FIN_WAIT1 FIN_WAIT2 TIME_WAIT CLOSE CLOSE_WAIT LAST_ACK LISTEN CLOSING UNKNOWN ); my %statuses = map { $_=> undef } @wanted; # platform specific status munging... my $listen; if ($platform eq 'MSWin32'){ $listen = 'LISTENING'; delete $statuses{LISTEN}; $statuses{$listen} = undef; } else { $listen = 'LISTEN'; } my $given_args = scalar @ARGV; my $auto = 0; if (grep {$_ =~ /-a|--auto/ } @ARGV){ $given_args -= 2; } unless ( GetOptions ( "ESTABLISHED|E" => \$statuses{ESTABLISHED}, "SYN_SENT|SS" => \$statuses{SYN_SENT}, "SYN_RECV|SR" => \$statuses{SYN_RECV}, "FIN_WAIT1|F1" => \$statuses{FIN_WAIT1}, "FIN_WAIT2|F2" => \$statuses{FIN_WAIT2}, "TIME_WAIT|TW" => \$statuses{TIME_WAIT}, "CLOSE|C" => \$statuses{CLOSE}, "CLOSE_WAIT|CW" => \$statuses{CLOSE_WAIT}, "LAST_ACK|LA" => \$statuses{LAST_ACK}, "LISTEN|L" => \$statuses{$listen}, "CLOSING|CG" => \$statuses{CLOSING}, "UNKNOWN|U" => \$statuses{UNKNOWN}, "auto|a=i" => \$auto, "help" => \&help, )) { help(); } if ($auto){ my $clear = $platform eq 'MSWin32' ? 'cls' : 'clear'; while (1){ system($clear); netstat(); sleep($auto); } } else { netstat(); } sub netstat { my @stat = split '\n', `netstat -nat`; if ($given_args == 0){map {$statuses{$_}=1} keys %statuses} my %data = map {$_ => 0} keys %statuses; for (@stat){ s/^\s+//; my $status; if ($platform eq 'MSWin32'){ $status = (split)[3]; } else { $status = (split)[5]; } next if ! $status; $data{$status}++ if defined $data{$status}; } map { printf "%10s\t$data{$_}\n ",$_} sort grep {defined $statuses{$_}} keys %statuses; } sub help { print "\nUSAGE $0:\n"; print <<EOF; OPTIONS: Options specifies which status will be reported in the output. Name of status can be given in upper or lower case. If no options are given all statuses will be printed. You can use the following option abbreviations: -e for --ESTABLISHED -ss for --SYN_SENT -sr for --SYN_RECV -f1 for --FIN_WAIT1 -f2 for --FIN_WAIT2 -tw for --Time_WAIT -c for --CLOSE -cw for --CLOSE_WAIT -la for --LAST_ACK -l for --LISTEN -cg for --CLOSING -u for --UNKNOWN -a for --auto -h for --help The special -a or --auto parameter takes an integer. This will cause the program to refresh the screen and output every integer secon +ds. Here a brief description of status meanings: ESTABLISHED The socket has an established connection. SYN_SENT The socket is actively attempting to establish a connection. SYN_RECV A connection request has been received from the network. FIN_WAIT1 The socket is closed, and the connection is shutting down. FIN_WAIT2 Connection is closed, and the socket is waiting for a shut +down from the remote end. TIME_WAIT The socket is waiting after close to handle packets still in + the network. CLOSE The socket is not being used. CLOSE_WAIT The remote end has shut down, waiting for the socket to clos +e. LAST_ACK The remote end has shut down, and the socket is closed. Wai +ting for acknowledgement. LISTEN The socket is listening for incoming connections. Such soc +kets are not included in the output unless you specify + the --listening (-l) or --all (-a) option. CLOSING Both sockets are shut down but we still don't have all our +data sent. UNKNOWN The state of the socket is unknown. You can get further information by calling "perldoc". EOF exit 1; }


Messenger Daemon summoner
1 direct reply — Read more / Contribute
by QuillMeantTen
on Aug 27, 2015 at 04:32


    Update : This can be used to make interprocess communication transparent : with the appropriate setup it should allow communication between process that might be on different machines as if they were on the same

    next thing up, change the way the summoner works so he can return file handles to his callers, also make it so he can have any number of callers and treat their requests one after another

    To do that I was thinking about having a "call me back" file handle inside the parameter hash passed to him so he can send a reply with the needed file handle

    After much nagging, harassing this community with questions regarding IPC I finally have some code to show you.

    Even better, This time it's code that works!
    Please keep in mind that I have not yet gotten rid of my eye-gouging coding style (I made some effort on that one to provide with a coherent synopsis, description and a better documentation

    so, here is the archidaemon, sitting upon his throne of undelivered messages, I give you Messaging!

    now the class he uses to summon his little slaves, the messenger daemons (each summoned has his TrueName-ie his pid) in the archi daemon Great Book Of Names (ie his %children hash)so he can be sent back whence he came if need arises

    And now, ladies and gentlemen, have a look at this beast, this entity summoned from the deepest pits of madness as it goes about jumping through those poorly cobbled together testing hoops and does (hopefully) not crash and burn with an otherwordly Croak of despair!

    *Cracks his whip

    Those slaves will happily pass around simple text messages, but what about more complicated serialized data with newline characters?

    I am still looking for advice on how to handle those cases, thank you for reading this far :)

Generic Parsing class with callback
1 direct reply — Read more / Contribute
by QuillMeantTen
on Aug 25, 2015 at 04:03

    I'm not sure if this is a real cool use, but with this class you can specify any regex for a standard parser tool as well as any callback in string form (pretty useful if you want to do all of that in a configuration file under version management)

    I have some serious doubts about the way I used eval in this code so I would welcome feedback on how to do it better. I looked over the forum for ways to handle the storing of substitution regex and back references but what I found I felt I did not understand enough to re use properly so if you feel like engraving it into my forehead so I can get it feel free to do so (I'm refering to this node and that one

    now here is the code :

    And, as usual, the tests, iirc its almost 100% cover

    Thank you for your feedback :)
Markov Chain automata class
1 direct reply — Read more / Contribute
by QuillMeantTen
on Aug 24, 2015 at 13:51

    The Following code provides a class to create Markov chain based automata which role is to tell you, after reading a dictionary, whether words you give them are likely to be part of the language they studied.

    I wrote it so I can use it to comb through dns queries logs to find anything that looks like an algorithmicaly generated domain name. have fun :D

    And here is the test file : 100% testcover :) - Diff directory trees across machines
2 direct replies — Read more / Contribute
by Corion
on Aug 20, 2015 at 04:30

    This program creates a recursive diff between two directory trees. The directory trees can be local or reachable by ssh. The diff lists added and removed files and for changed files, it lists the differences in diff style. This makes it convenient to review the differences between two machines that should be identical, or to find the steps that are needed to bring one directory tree to another.

    After a hint by salva that Net::SSH2 comes included with Strawberry Perl, I was motivated to rip out some system-specific ties to plink.exe and post this. Unfortunately, Net::SSH::Any doesn't seem to have a way to talk to the ssh agent for quick authentification, so this relies on Net::SSH2 instead of Net::SSH::Any.

    #!perl -w use strict; use Algorithm::Diff; use Getopt::Long; use File::Find; use File::stat; use Net::SSH2; =head1 NAME =head1 ABSTRACT Generate a diff between two directory trees. The directory trees must +be local or reachable via ssh. Only the ssh2 protocol is supported. =head1 SYNOPSIS perl -w corion@production:/opt/mychat corion@staging +:/tmp/deploy-0.025 --ignore .bak --ignore .gpg --ignore .pgp --ignore + random_seed Quick diff, showing only added/missing files without comparing their c +ontent perl -w c:\mychat\old-versions\0.025 corion@staging: +/tmp/deploy-0.025 -q =head1 OPTIONS =over 4 =item B<--ignore> Regexp of directory entries to ignore =item B<--no-mode> Don't compare the file mode. =item B<--no-owner> Don't compare the file owner. =item B<--quick> Don't compare file contents =item B<--verbose> Be somewhat more verbose =back =head1 PREREQUISITES Currently, the script expects C<find> and C<perl> to be available on t +he remote side. The dependency on C<find> could be eliminated by implementing th +e functionality in Perl. The dependency on C<perl> on the remote side could be elimina +ted by using the SFTP protocol for retrieving the directory tree, at an added compl +exity. =cut GetOptions( 'verbose|v' => \my $verbose, 'ignore|i:s' => \my @ignore, 'no-owner|o' => \my $ignore_owner, 'no-mode|m' => \my $ignore_mode, 'quick|q' => \my $skip_contents, ); use vars qw(%connections); sub run_remote { my( $server, $command )= @_; my $user; if( $server =~ /(.*)\@(.*)/ ) { $user = $1; $server = $2; }; if( ! $connections{ $server }) { my $ssh2 = Net::SSH2->new(); $ssh2->connect($server) or die "Couldn't connect to '$server': + $!"; if ($ssh2->auth( username => $user, interact => 1 )) { $connections{ $server } = $ssh2; } else { die "No auth to $server."; }; }; my $fh = $connections{ $server }->channel; warn "[$command]" if $verbose; $fh->exec($command) or die; my @lines = map {s/\s+$//; $_ } <$fh>; #warn "$server:[$_]" for @lines; return @lines } sub get_local { my( $file )= @_; open my $fh, '<', $file or warn "Couldn't read '$file': $!"; binmode $fh; my @lines = map {s/\s+$//; $_ } <$fh>; return @lines } sub split_serverpath { my( $serverpath ) = @_; if( $serverpath =~ /((?:\w+\@)[\w.]+):(.*)/ ) { return ("$1","$2"); } else { # Must be local return (undef, $serverpath); } }; use Data::Dumper; sub filelist { my( $serverpath ) = @_; my( $host, $dir ) = split_serverpath( $serverpath ); if( $host ) { # Outputs a line per file # mode user group type filename my $uid_gid_file = q!perl -Mstrict -MFile::stat -nle 'next if +/^\s*$/;my $s=stat($_);my($p,$u,$g,$t)=(0,q(-),q(-),q(f)); if($s and +not -l) {$p=$s->mode;$u=(getpwuid($s->uid))[0];$g=(getgrgid($s->gid)) +[0] } else { $t=q(l)}; print sprintf qq(%08o %s %s %s %s), $p, $u,$g, +$t,$_'!; # Read all directory entries my @remote_entries = map { my( $mode,$u,$g,$t,$name ) = split +/ +/, $_, 6 ; $name =~ s!^\Q$dir!!; { user => $u, group => $g, type => +$t, name => $name, mode => $mode }; } run_remote( $host, qq{find '$dir' - +type f -o -type l| $uid_gid_file } ); return @remote_entries; } else{ my @files; find({ wanted => sub { return if -d $_; my $s = stat($_) or warn "Couldn't stat [$_]: $!", return; my $name = $_; my $u='-'; my $g='-'; my $t='f'; my $mode = $s->mode; $name =~ s!^\Q$dir!!; push @files, { user => $u, group => $g, type => $t, name = +> $name, mode => $mode }; }, no_chdir => 1 }, $dir ); #warn "local: $_" for @files; return @files; }; } sub wanted_file { my( $fileinfo )= @_; my $file = $fileinfo->{name}; if( my @why = grep { $file =~ /\Q$_/ } @ignore ) { #warn "Ignoring $file (@why)"; } else { #warn "Allowing [$file] ..."; } ! grep { $file =~ /\Q$_/ } @ignore; } sub diff { my( $name, $server1, $server2 )= @_; my($host1, $path1) = split_serverpath( $server1 ); my($host2, $path2) = split_serverpath( $server2 ); my @left = $host1 ? run_remote( $host1, qq{cat '$path1$name'} ) : + get_local( "$server1$name" ); my @right = $host2 ? run_remote( $host2, qq{cat '$path2$name'} ) : + get_local( "$server2$name" ); my $diff = Algorithm::Diff->new( \@left, \@right ); $diff->Base( 1 ); # Return line numbers, not indices my $has_diff; while( $diff->Next() ) { next if $diff->Same(); if( ! $has_diff ) { $has_diff = 1; print "$name\n"; }; my $sep = ''; if( ! $diff->Items(2) ) { printf "%d,%dd%d\n", $diff->Get(qw( Min1 Max1 Max2 )); } elsif( ! $diff->Items(1) ) { printf "%da%d,%d\n", $diff->Get(qw( Max1 Min2 Max2 )); } else { $sep = "---\n"; printf "%d,%dc%d,%d\n", $diff->Get(qw( Min1 Max1 Min2 Max2 )); } print "< $_\n" for $diff->Items(1); print $sep; print "> $_\n" for $diff->Items(2); } $has_diff }; my( $server1, $server2 )= @ARGV; #warn "Old: $server1"; #warn "New: $server2"; my %left_info = map { $_->{name} => $_ } grep { wanted_file($_) } file +list( $server1 ); my %right_info = map { $_->{name} => $_ } grep { wanted_file($_) } fil +elist( $server2 ); my @left_names = sort keys %left_info; my @right_names = sort keys %right_info; my $filediff = Algorithm::Diff->new( \@left_names, \@right_names ); my @samelist; $filediff->Base( 1 ); # Return line numbers, not indices while( $filediff->Next() ) { if( $filediff->Same() ) { # entry exists in both trees push @samelist, $filediff->Items(1); } else { # Entries only on tree 2, but no symlink my @new_items = grep { ! $right_info{ $_ }->{type} ne 'l' } $f +ilediff->Items(2); print "new: $_\n" for @new_items; # Entries only on tree 1, but no symlink my @old_items = grep { ! $left_info{ $_ }->{type} ne 'l' } $fi +lediff->Items(1); print "del: $_\n" for @old_items; }; } for my $same (@samelist) { my $linfo = $left_info{ $same }; my $rinfo = $right_info{ $same }; #warn "File: $same"; #warn Dumper $linfo; #warn Dumper $rinfo; if( $linfo->{type} ne $rinfo->{type} ) { print "$same: Link vs. file: $linfo->{type} => $rinfo->{type}\ +n"; }; next if $linfo->{type} eq 'l' or $rinfo->{type} eq 'l'; if( ! $ignore_owner ) { if( $left_info{ $same }->{user} ne $right_info{ $same }->{ +user} or $left_info{ $same }->{group} ne $right_info{ $same }->{ +group} ) { print "$same: Ownership different: $left_info{ $same }->{use +r}:$left_info{$same}->{group} ne $right_info{ $same }->{user}:$right_ +info{$same}->{group}\n"; }; }; if( ! $ignore_mode ) { if( $left_info{ $same }->{mode} ne $right_info{ $same }->{m +ode} ) { print "$same: Mode different: $left_info{ $same }->{mode} $r +ight_info{$same}->{mode}\n"; }; }; if( ! $skip_contents ) { diff( $same, $server1, $server2 ); }; };
Size-limited, fitness-based lists
3 direct replies — Read more / Contribute
by AppleFritter
on Aug 08, 2015 at 19:05

    Monks and monkettes! I recently found myself wondering, what's the longest words in the dictionary (/usr/share/dict, anyway)?

    This is easily found out, but it's natural to be interested not just in the longest word but (say) the top ten. And when your dictionary contains (say) eight words of length fifteen and six words of length fourteen, it's also natural to not want to arbitrarily select two of the latter, but list them all.

    I quickly decided I needed a type of list that would have a concept of the fitness of an item (not necessarily the length of a word), and try not to exceed a maximum size if possible (while retaining some flexibility). My CPAN search-fu is non-existent, but since it sounded like fun, I just rolled my own. Here's the first stab at what is right now called List::LimitedSize::Fitness (if anyone's got a better idea for a name, please let me know):

    This features both "flexible" and "strict" policies. With the former, fitness classes are guaranteed to never lose items, but the list as a whole might grow beyond the specified maximum size. With the latter, the list is guaranteed to never grow beyond the specified maximum size, but fitness classes might lose items. (Obviously you cannot have it both ways, not in general.)

    Here's an example of the whole thing in action:

    This might output (depending on your dictionary):

    $ perl wordsEn.txt .......... length 21 antienvironmentalists antiinstitutionalists counterclassification electroencephalograms electroencephalograph electrotheraputically gastroenterologically internationalizations mechanotheraputically microminiaturizations microradiographically length 22 counterclassifications counterrevolutionaries electroencephalographs electroencephalography length 23 disestablismentarianism electroencephalographic length 25 antidisestablishmentarian length 28 antidisestablishmentarianism 19 words total (10 requested). $

    If you've got any thoughts, tips, comments, rotten tomatoes etc., send them my way! (...actually, forget about the rotten tomatoes.)

    Also, does anyone think this module would be useful to have on CPAN, in principle if not in its current state?

Free Space Usage Report
No replies — Read more | Post response
by GotToBTru
on Aug 04, 2015 at 09:22

    The following is the latest incarnation of something I wrote a few years back, and have refined as I have learned new tricks. The output of the df -k command is filtered for a list of directories. If the free space has changed since I last ran the command, it is stored. I also store a timestamp along with it, in case I want to look at historical trends. Right now, it keeps only the latest 8 reports.

    #!/usr/bin/perl # List free space left use strict; use warnings; use Storable; my $storable_file = '/home/edi/howard/dfk.storable'; my (@reports); @reports = @{retrieve($storable_file)} if ( -e $storable_file); my %new = map {(split /\s+/,$_)[6,3]} grep {/home|archive|edi_store/} +`df -k`; $new{'timestamp'} = time; unshift @reports, \%new; if (print_report(@reports[0,1])) { pop @reports if (scalar @reports > 7); store(\@reports,$storable_file); } sub print_report { my ($nhr,$ohr) = @_; my $change_flag = defined $ohr ? 0 : 1; foreach my $key ( keys %{$nhr}) { next if $key eq 'timestamp'; if (defined $ohr->{$key} && $ohr->{$key} ne $nhr->{$key}) { printf "%-17s was: %3s now: %3s\n", $key, $ohr->{$key}, $nhr->{$ +key}; $change_flag = 1; } else { printf "%-17s: %3s\n",$key,$nhr->{$key} } } return $change_flag; }
    Dum Spiro Spero
Subs: search/replace code, inject new code and get information
No replies — Read more | Post response
by stevieb
on Jul 24, 2015 at 17:40

    I've updated my Devel::Examine::Subs module, and I thought I'd give a bit of a demo of a few of the tasks it can now perform.

    EDIT: I just noticed a significant issue with cache. Please don't use it while this notice is posted.

    Initialize a DES object, setting some global parameters...

    use Devel::Examine::Subs; my $dir = '/home/steve/devel/repos/project'; my $des = Devel::Examine::Subs->new({ file => $dir, regex => 1, });

    Notes: The cache parameter should always be used in the new() call, except for doing write operations which we're doing below.

    Search for 'template.tpl' in all subs in .pm files and replace it with '', except in any subs named one or three. By default, it processes .pm and .pl files...

    $des->search_replace({ exclude => ['one', 'three'], search => '(\W)template.tpl(\W)', replace => 'new_template.tpl', extensions => ['pm'], });

    Notes: exclude and extensions need to be set back to some form of non-true value for further calls under the same object, if they are not needed any further. In the next release, I'll have added the ability to change this behaviour.

    Look for any variant of $self = shift in all subs of all .pm and .pl files, and inject new code after it (like all other methods, this one obeys include and exclude).

    my @code = <DATA>; $des->inject_after({ search => '\$self\s+=\s+shift', code => \@code, }); __DATA__ $self->{thing} = some_function(); my $debug = 1 if $self->{thing}; if ($debug){ print Dumper $self; exit; }

    Notes: copy => 'some_file.ext; can be sent in, and it'll make all the changes to that file in the local directory for review before removing it and editing the live file. The injects param informs when to stop searching and injecting. The default is stop after the first search term (1). DES honours the indenting found on the line the search term was on. Set no_indent if you don't want this behaviour.

    Let's create a new object for read-only operations, and set up caching.

    my $des = Devel::Examine::Subs->new({ file => '', cache => 1, });

    Get all subs from the file and put them into objects...

    my $objects_aref = $des->objects();

    Print out some info...

    for my $sub (@$objects_aref){ say "name: " . $sub->name; say "first line num: " . $sub->start; say "last line num: " . $sub->end; say "line count: " . $sub->line_count; say "sub code: "; say "\t$_" for @{$sub->code}; print "\n"; if ($sub->lines->[0]){ say "Lines that match: "; for my $line (@{$sub->lines}){ say "\t$line"; } print "\n"; } }

    Notes: $sub->lines() contains an array ref of strings that contain the line number and text (separated by a :) of the lines that contain a search term, if a search term was passed in.

    End notes: Everything above performed on a single file can be run in directory mode as well. To present output after a call, wrap it in one level deeper:

    # dir search returns an href. key is the filename of # the file the subs were found in, and the values are the # same return you'd get from the same call on an individual # file my $files = $des->objects(); for my $file (keys %$files){ for my $sub (@{$files->{$file}}){ say $sub->name; ... } }

    Get all sub names in a file...

    my $aref = $des->all();

    All subs that contain or don't contain a search term...

    my $aref = $des->has({search => 'this'}); my $aref = $des->missing({search => 'this'});

    All subs in all files...

    my $files = $des->all({file => 'dir'}); for my $file (keys %$files){ say $file; for my $sub (@{$files->{$file}}){ say "\t$sub"; } print "\n"; }

    It can do much more than this, so please feel free to read through the documentation specified in the README and play around. I urge you to provide feedback if any bugs are found or to see if something is available (or if its on the roadmap) and/or if you have any suggestions whatsoever.

    Thanks for reading!



    The long story behind this module is that years ago, I was writing a multi-module ISP accounting/billing/tracking system, and wanted a way for every single method in every single sub to call out to a tracing function in order to store all stack information. This module is how I envisioned at the time injecting such code.

    After I add a few more methods to this module add_sub(), add_use() etc, I'll be rewriting my Devel::Trace::Method to do just this.

    Next additions (above and beyond those stated in my last comment), is to allow editing any live module file by specifying the module name as in Data::Dumper (already half implemented in the add_functionality() method, add the creating and storing of diffs with the ability to apply them back if something breaks, clean up the configuration parameter infrastructure and a few other small tasks, such as adding POD for the sub-modules.

Add your CUFP
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":

  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?

    What's my password?
    Create A New User
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others romping around the Monastery: (15)
    As of 2016-06-29 13:46 GMT
    Find Nodes?
      Voting Booth?
      My preferred method of making French fries (chips) is in a ...

      Results (380 votes). Check out past polls.