Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris

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.

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
Colorapt for Ubuntu/Debian
3 direct replies — Read more / Contribute
by jeffythedragonslayer
on Jul 30, 2015 at 15:43
    Hello there Perl Monks. I wrote colorapt to learn Perl for my Unix class, and so am posting it here on the off chance that someone thinks it's cool. If anyone has any suggestions on coding style, feature requests, or bug reports, that would be a great help for getting me up to speed on this language. Thanks!

    Seeing as Larry Wall says Perl 6 will be officially out in December, should I just use that for new projects?
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.

Syntax-highlight Non-Perl Code for HTML
1 direct reply — Read more / Contribute
by kcott
on Jun 29, 2015 at 01:19

    G'day All,

    I use a scripting language, called NWScript, for some CRPG development that I do from time to time.

    I wrote the following Perl script to syntax-highlight NWScript code for HTML rendering:

    #!/usr/bin/env perl use 5.014; use warnings; { my %entity_for = qw{& &amp; < &lt; > &gt;}; sub chars_to_ents { $_[0] =~ s/([&<>])/$entity_for{$1}/gr } } my @plain_captures = qw{white_space remainder}; my @highlight_captures = qw{operator variable function constant statem +ent datatype comment string integer float prag +ma}; my $re = qr{ (?> (?<white_space> \s+ ) | (?<comment> (?> \/\* (?: . (?! \*\/ ) )*+ (?: . (?= \*\/ ) )?+ \*\/ | \/\/ [^\n]* $ ) ) | (?<pragma> (?> [#]include \s+ " \w+ " \s* $ | [#]define \s+ \w+ \s+ \w+ \s* $ ) ) | (?<string> " (?: [^"\\]++ | \\. )*+ " ) | (?<float> \b \d+ \. \d+ f? \b ) | (?<integer> \b \d+ \b ) | (?<constant> \b [A-Z0-9_]+ \b ) | (?<datatype> \b (?> action | const | effect | event | float | int | itemproperty | location | object | string | struct \s+ \w+ | talent | vector | void ) \b ) | (?<statement> \b (?> break | continue | do | for | if | else | return | switch | case | default | while ) \b ) | (?<function> \b [A-Za-z_] \w* (?= \s*\( ) ) | (?<variable> \b [A-Za-z_] \w* \b ) | (?<operator> (?> \>\>\>\= | \>\>\> | \>\>\= | \<\<\= | \>\> | \<\< | \+ +\+ | \-\- | \&\= | \|\= | \^\= | \*\= | \/\= | \%\= | \+\= | \-\ += | \=\= | \!\= | \<\= | \>\= | \&\& | \|\| | \< | \> | \! | \& | \| | \^ | \~ | \* | \/ | \% | \+ + | \- | \= | \? | \: | \; | \. | \{ | \} | \( | \) | \, | \@ ) ) | (?<remainder> .*? ) ) }msx; my $init_code = do { local $/; <> }; say '<pre class="syntax-highlight">'; MATCH: while ($init_code =~ /$re/g) { for my $plain_capture (@plain_captures) { if (exists $+{$plain_capture}) { print $+{$plain_capture}; next MATCH; } } for my $highlight_capture (@highlight_captures) { if (exists $+{$highlight_capture}) { print '<span class="', $highlight_capture, '">', chars_to_ents($+{$highlight_capture}), '</span>'; next MATCH; } } } say '</pre>'; exit;

    NWScript uses a C-like syntax. I'm aware that a few monks use NWScript; however, I'd guess most don't and have probably never heard of it. So, purely to provide an example that's looks a little more familiar to most, here's a slightly fudged (just the #include pragma) hello.c:

    /* hello.c */ #include "stdio" main() { printf("hello, world\n"); }

    And here's the output after running that through my script:

    <pre class="syntax-highlight"> <span class="comment">/* hello.c */</span> <span class="pragma">#include "stdio" </span> <span class="function">main</span><span class="operator">(</span><span + class="operator">)</span> <span class="operator">{</span> <span class="function">printf</span><span class="operator">(</span +><span class="string">"hello, world\n"</span><span class="operator">) +</span><span class="operator">;</span> <span class="operator">}</span> </pre>

    For anyone wishing to use this script, here's the CSS I use (in the Spoiler):

    -- Ken Self extracting (and auto installing) perl script.
No replies — Read more | Post response
by FreeBeerReekingMonk
on Jun 06, 2015 at 10:05

    1. create a directory, put your datafiles there
    2. create an file (can be perl, make sure it is executable)
    3. tar your files, optionally compress the tar with gz, bzip2 or xz.
    4. use ./ -a <file> to add files
    5. Now you can use -u to unpack, and -p to repack the files into the
    6. Test with -i and -t to a clean directory

    It used to be lots smaller. In fact, you can delete big portions of the perl code, once you have a final installation package, because you will not need all those options. (and can add them easily back, or use oneliners) Why not try testing the functionality with: ./ -i -t /tmp
    As I embellished it just now, without much testing, I am not sure everything is 100%, so if you find bugs... or add features let me know.

    #!/usr/bin/perl # 2013 Nilton Castillo Dual licensed: LGPL or Artistic2 (http://dev # inspired by the self extracting shell script. Added help, and posted + on perlmonks in 2015 use strict; use warnings; use Getopt::Long; use File::Basename; use Cwd; # Only used if you use --todir (you can delete all cwd() and +chdir() if unused) my $TODIR = "."; my ($help, $verbose, $f, $fn, $list, @add, @replace, @extract, @delete +, $run, $unpack, $pack) = !@ARGV; GetOptions ( "help|?" => \$help, "list" => \$list, "add=s@" => \@add, "replace=s@" => \@replace, "x|extract=s@" => \@extract, "delete=s@" => \@delete, "install" => \$run, "unpack" => \$unpack, "pack" => \$pack, "verbose" => \$verbose, "todir=s" => \$TODIR, ); $help && die <<ENDHELP; $0 - self extracting perl v1.0 --help | -? print help --list list all embedded files --add <file> Append uuencoded data to script --replace <file> Append/replace update uuencoded data to script --extract <regexp> Extract a file from the script (alternative: -x + <file>) --delete <regexp> delete a file from the script --install unpack and autorun --unpack unpack all files (so tarred files are untarred automa +tically) --pack repack all files/directories into the script. --verbose verbose --todir <directory> Change destination directory (default is curre +nt directory) You can also use the first letter notation: -l instead of --list. Unpack supports: tar, gz, bz2 and xz. But you need full names: myfile +.tar.bz2 Thus, do not use .tbz or .tgz extensions Examples: $0 -e . -t /tmp Extract all files (as-is) to /tmp/ $0 -i -t /tmp unpack all files to /tmp/, then run all files with "install" in the name $0 -d txt Delete all files that contain txt in their name Case sensitive. use this to delete all .xz or .XZ files: '(?i)\\.XZ\$' You can easily modify your files by unpacking them to the local direc +tory. Then use pack to update them into the file. Note that files in +side a tar subdirectory are automatically added into the tar. ENDHELP my $MATCH = qr/^begin ([0-7]+) ([^\n ]+)$/s; # used for functions: lis +t, extract, delete $TODIR =~s#/*$#/#; # ensure trailing slash my @SELF; # will hold the entire program in RAM $unpack = 1 if($run); @delete = qw(.) if($pack); # List all attachments: --list | -l # grep ^begin if($list){ while(<DATA>){ print " $2\n" if(m/$MATCH/); } } # Replace file: --replace <filename> | -r <filename> # no simple oneliner. for $f (@replace){ push(@delete, @replace); push(@add, @replace); } # Generating a clean and empty self extracting file (then add back wha +t you need) # Delete: --delete . | -d . # perl -pe 'print && exit if(/__END__/)' > if(@delete){ open(INPUT,"<", $0) or die "Unable to read $0\n"; @SELF = <INPUT>; # just in case, we can put it all back. close INPUT; open(OUTPUT,">",$0) or die "Unable to write $0\n"; my $skip = 0; for $f (@SELF){ if($skip){ next unless($f=~/^end$/); $skip = 0; next; } if($f=~m/$MATCH/){ $fn = $2; for $_ (@delete){ $_ = basename($_); $skip = 1 if($fn=~m/$_/); } print OUTPUT $f unless($skip); print "- $fn\n" if($skip && $verbose); push(@add, ";".$fn) if($pack); }else{ print OUTPUT $f; } } close OUTPUT; } # helper function to pipe files sub piper{ my $x = shift; my $fn = shift; my %Z = ( "xz" => [ "|xz -d", "|xz -9" ], "gz" => [ "|gunzip", "|gzip -9" ], "bz2" => [ "|bunzip2", "|bzip2 -9" ], "tar" => [ "|tar xvf -", "|tar cvf -" ], ); my $F=""; my $z; @_ = reverse split(/\.(?=(?:tar|gz|bz2|xz))/, $fn); while (@_){ $z =shift; next unless defined $Z{$z}; #print " z=$z;x=$x"; $F .= ${$Z{$z}}[$x]; } #print "Piper($x,$fn) z=$z F=$F\n"; return $x? ($F? join("|", reverse split(/\|/,$F." ".$z) ) : "$fn") + : $F.($fn=~/tar/?'':">$z")||">$fn"; } # Add attachments: --add "./myfile.tar.gz" | -a "./myfile.tar.gz" # cat ./myfile.tar.gz | uuencode myfile.tar.gz >> for $f (@add){ my $fh =$f=~s/^;// ? piper(1,$f):$f; print "+ '$fh'\n" if($verbose); open INPUT, $fh or die "$0: can't read $f: $fh\n"; open OUTPUT, ">>",$0 or die "$0: can't open self\n"; my @stat = stat INPUT; my $mode = @stat? ($stat[2] eq 4096?0644:$stat[2]): 0644; print "mode=$mode\n"; my $omode = sprintf "%03o", $mode; my $pmode = substr $omode, -3; print "begin $pmode ".basename($f)."\n"; print OUTPUT "begin $pmode ".basename($f)."\n"; my ($inbytes, $instring); while ($inbytes = read INPUT, $instring, 45) { print OUTPUT pack "u", $instring; } print OUTPUT " \nend\n"; close(INPUT); close(OUTPUT); } # Extracting all attachments # perl -ne 'print if($GO || /__END__/ && $GO++)' | uudecode @extract = qw(.) if(($run||$unpack) && !@extract); my @RUN; for $f (@extract){ my $mod; my $pwd = cwd(); # only if --todir is used while(<DATA>){ if(m/$MATCH/ && ($mod=$1) && ($fn=$2) && ($fn=~m/$f/)){ my $FE = piper(0,$fn); if( $unpack && (index($FE, "|")>-1) ){ chdir($TODIR) if $TODIR; open (OUTPUT, $FE) || die "Can not open pipe to $FE fo +r $fn\n"; print "x $fn...\n" if($verbose); print "".(substr($FE,0,1)) ." $fn ...\n" if($verbose & +& $fn); }else{ $fn = $TODIR . $fn; open(OUTPUT, ">",$fn) or die "$0: Unable to write to $ +fn ($f)\n"; print "w $fn...\n" if($verbose); } push(@RUN, $fn) if($run && $fn=~/install/); # we will run +this later binmode OUTPUT; my $block; while(<DATA>){ last if /^end$/; $block = unpack ("u", $_); print OUTPUT $block; } close OUTPUT; chmod oct($mod), $fn if(-f $fn); chdir($pwd) if $TODIR; } } } # run if we extracted a program called .*install.* for $f (@RUN){ print "Running $f\n" if($verbose); my $pwd = cwd(); chdir($TODIR) if $TODIR; print `$f`; my $errorcode = $?>>8; print "ERROR: $f failed with errorcode $errorcode\n" if($errorcode +); chdir($pwd) if $TODIR; } __END__ begin 644 hello.txt -2&5L;&\@5V]R;&0A"@`` end begin 600 data.tar.bz2 M0EIH.3%!62936>O7O?H``)M[A,*0`P!``?^`(`AG)YY@``(`""``E(2A-*?J M1H>D##48@T"J5-#TAIM1IZ@#0&U*XOEV%^AIB!KMA$0G*1A92E)R:C!F1!8F MR2-1BID/:$`F&,"2#FPP4HT*SG>4Q04)LVZERO;OA4,5BSA*=@Z#S4+@J8;: A&QH5#5&,OI<]-IV9*K%4S\R6JMB(/XNY(IPH2'7KWOT` end begin 740 M96-H;R`B2&5L;&\@5V]R;&0A('9E<G-I;VX@,2XP(&ES(&)E:6YG(&EN<W1A M;&QE9"XN+B(*96-H;R`B3W5R(&-U<G)E;G0@9&ER96-T;W)Y(&ES.B(@8'!W M9&`*96-H;R`B=VEL;"!N;W<@<G5N.B!C870@:&5L;&\N='AT(@IC870@:&5L :;&\N='AT"G-L965P(#$*96-H;R!D;VYE+@H` end
converting 'ps' running times
2 direct replies — Read more / Contribute
by Random_Walk
on Jun 01, 2015 at 11:42

    Monitoring is my bread an butter. I had cause to re-write a script here that parses process running time from ps output.

    ps -ef "%t %c" 29:23 swdmgr 3-09:32:03 RIM_Oracle_prog 07:13:13 ksh

    That running time is days-hours:minutes:seconds. Where days and hours will only be there if non-zero. The existing code parsed it like this:

    my ($days, $hours, $min, $secs); if ($time=~/(\d+)-(\d{2}):(\d{2}):(\d{2})/){ $days=$1; $hours=$2; $mins=$3; $secs=$4; }elsif($time=~/(\d{2}):(\d{2}):(\d{2})/){ $hours=$1; $mins=$2; $secs=$3; }else{ ($mins,$secs)=split/:/,$time; } my $day_sec=$days*86400; my $hour_sec=$hours*3600; my $min_sec=$mins*60; my $secs_running=$day_sec+$hour_sec+$min_sec+$secs;

    But I thought this was much more fun...

    my $age; # age in seconds $age = $1 * 86400 if $time =~ s/(\d+)-//; # add days if there my ($hours,$min,$sec) = split /:/, $time; my @mult = (1, 60, 3600); for (reverse split /:/, $time) { # fun way to convert to seconds $age += $_ * shift @mult; # he he he :-) }


    Pereant, qui ante nos nostra dixerunt!

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 perusing the Monastery: (3)
    As of 2015-11-29 06:02 GMT
    Find Nodes?
      Voting Booth?

      What would be the most significant thing to happen if a rope (or wire) tied the Earth and the Moon together?

      Results (747 votes), past polls