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

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
No replies — Read more | Post response
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):

    pre { font-size: 1.000em; white-space: pre-wrap; } pre.syntax-highlight { color: #666666; background-color: #000000; font-weight: normal; margin: 1.000em; border-color: #888888 #444444 #222222 #666666; border-width: 1px; border-style: solid; border-radius: 0.500em 0.500em; padding: 1.000em; } /* comment olive #808000 pragma orange #ff9900 string lime #00ff00 float mauve #9966ff integer copper #cc9966 datatype yellow #ffff00 statement mid blue #6699ff operator white #ffffff constant sea green #33cc99 variable cyan #00ffff function light red #ff6666 */ pre.syntax-highlight > span.comment { color: #808000; background-color: inherit; } pre.syntax-highlight > span.pragma { color: #ff9900; background-color: inherit; } pre.syntax-highlight > span.string { color: #00ff00; background-color: inherit; } pre.syntax-highlight > span.float { color: #9966ff; background-color: inherit; } pre.syntax-highlight > span.integer { color: #cc9966; background-color: inherit; } pre.syntax-highlight > span.constant { color: #33cc99; background-color: inherit; } pre.syntax-highlight > span.datatype { color: #ffff00; background-color: inherit; } pre.syntax-highlight > span.statement { color: #6699ff; background-color: inherit; } pre.syntax-highlight > span.function { color: #ff6666; background-color: inherit; } pre.syntax-highlight > span.variable { color: #00ffff; background-color: inherit; } pre.syntax-highlight > span.operator { color: #ffffff; background-color: inherit; }

    -- 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
1 direct reply — 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!
Create json from command line args
2 direct replies — Read more / Contribute
by teamster_jr
on May 20, 2015 at 10:39
    Not hilariously useful, but quite fun to write ntl.
    #!/usr/bin/perl use strict; use warnings; use Data::Dumper; @ARGV = qw{ --keyed_array_from_multiple_arguments a b --keyed_array_from_multiple_arguments c --keyed_array_from_multiple_arguments 1 --keyed_with_equals=1 --switch --multi.level a --funny_numbers -99.999 --switchable_switch --noswitchable_switch } unless @ARGV; use JSON::XS; use Scalar::Util qw{looks_like_number}; my ( $arguments, $data ); $arguments = join $", @ARGV; $arguments =~ s{ \s* # some space --([\.\w]+) # an argument \s*?=?\s* # some space or = (.*?) # some values \s*(?=--|$) # followed by another argument or end of line }{ my ($opt_name, $values)=($1,$2); for my $opt_value ( $values ? ( split /\s+/, $values ) : $opt_name +=~s/^no// ? JSON::XS::false : JSON::XS::true ) { my $pointer = \$data; for my $opt_key ( split /\./, $opt_name ) { $pointer = \$$poin +ter->{$opt_key} }; $opt_value = ( ref($opt_value) || !looks_like_number($opt_valu +e) ) ? $opt_value : 0 + $opt_value; $$pointer = $$pointer && ! (ref($opt_value) =~/Bool/) ? [ ( re +f($$pointer) eq 'ARRAY' ? @$$pointer : $$pointer ), $opt_value ] : $o +pt_value; } }xeg; print JSON::XS->new->pretty->encode($data)
Get DoB Bounds from Age Range
3 direct replies — Read more / Contribute
by over2sd
on May 07, 2015 at 12:18

    Here's a function I wrote to turn a range of ages into a pair of date-of-birth boundaries for use in database queries (or wherever else a date-of-birth boundary is more useful than an age range). Comments and suggestions for improvement are welcome.

    Updated: prettier variable names, better error handling.

    Updated: Removing use of now()

    =item DoBrangefromAges REFERENCEDATE MINAGE MAXAGE Given a REFERENCEDATE from which to calculate, minimum age MINAGE, and an optional maximum age MAXAGE, this function returns two strings in YYYY-MM-DD format, suitable for use in SQL queries, e.g., 'WHERE ?<dob AND dob<?', using the return values in order as parameters. If no MAXAGE is given, date range is for the year spanning MINAGE only. =cut sub DoBrangefromAges { my ($querydate,$agemin,$agemax,$inclusive) = @_; die "[E] Minimum age omitted in DoBrangefromAges" unless (defined +$agemin and $agemin ne ''); $agemin = int($agemin); $agemax = int($agemin) unless defined $agemax; $agemax = int($agemax); $inclusive = ($inclusive ? $inclusive : 0); my ($maxdob,$mindob) = ($querydate,$querydate); $maxdob->subtract(years => $agemin); $mindob->subtract(years => $agemax + 1); return $mindob->ymd('-'),$maxdob->ymd('-'); }
File Similarity Concept (re [id://1123881])
1 direct reply — Read more / Contribute
by ww
on Apr 21, 2015 at 12:41

    Proof of concept -- sparked by the discussion in Similarity measurement. NB that this is NOT PRODUCTION GRADE CODE nor does it resolve all issues with the loose (aka 'incomplete') spec in the OP)

    #! /usr/bin/perl -w use 5.018; # (cf [id=1123881]) # $file1 is used in place of OP's text file1; DATA stands in for text +file 2 # perl 5, version 18, subversion 4 (v5.18.4) built for MSWin32-x86-mul +ti-thread-64int # ... # Binary build 1804 [298913] provided by ActiveState http://www.Active # Built Mar 19 2015 17:49:00 my (@F1, %F1, @F2, %F2); my $file1 = "Now is the time for the quick red fox to jump over the la +zy brown dog's spooon while all good men run away with the fork and c +ome to the aid of their country"; chomp $file1; @F1 = split / /, $file1; # individual words my $file2 = <DATA>; chomp $file2; @F2 = split / /, $file2; $F1{$_}++ for @F1; # produces hash with key::value p +airs word => count for each word $F2{$_}++ for @F2; say "\n\t --- Ln 25 Printing keys and values for the HASHES, \%F1 and +\%F2\n\t\t ...and creating ARRAYS \@F1combined and \@F2combined."; my (@F1combined, @F2combined); # while ( my ($key, $value) = each(%F1) ) { print "$key => $value\n"; push @F1combined, ($key . ' => ' . $value); } say "\n\t --- \%F2, next: ---"; while ( my ($key, $value) = each(%F2) ) { print "$key => $value\n"; push @F2combined, ($key . ' => ' . $value); } my @sort_arr1 = sort {fc($a) cmp fc($b)} @F1combined; # fc to norma +lize my @sort_arr2 = sort {fc($a) cmp fc($b)} @F2combined; my $entry; # a complete element of an array, @sor +t_arr1 in this case. See Ln 54 my $counter = qr/ => \d+/; # the part of of the element we'll exc +lude in Ln 22-23 (so can match words w/variant counts) my $word; # search term for the word only, less +the fat arrow and counter; see Ln 22-23 my $match_count = 0; my $mismatch=0; my $len1 = $#sort_arr1; # used to determine the terminal state + of the loop at Ln 50 my $len2 = $#sort_arr2; my $item_count = ($len1 > $len2) ? ($len1+1) : ($len2+1); # Longer o +f the two arrays (files) ... say "\t\t \$item_count: $item_count"; # which ca +uses "uninit" warnings at Ln 55 et seq. my $i; for ( $i=0; $i<($item_count); $i++) { my $entry = $sort_arr1[$i]; chomp $entry; say ">> Ln 56 \$i: $i |$entry| "; # can be used for DEBUG if ( $entry =~ /(\w+)$counter/i ) { $word = $1; } else { next; } if ( grep {/$word/} @sort_arr2 ) { say "\t found |$word| in both arrays (files) \n"; $match_count++; } else { say "\t didn't match entry, |$entry| \n"; $mismatch++; } } say "\n\t \$match_count: $match_count"; say "\t \$mismatch: $mismatch"; my $element_total = $match_count+$mismatch; say "\n\t SLOPPY SPEC: among other issues, does not treat cases where +the number of instances of a word in one file \t is different than the number of instances in the second file as a m +ismatch (eg. if the word is in both, even \t though in differing quanties, it's treated as a match."; say "\t No allowance made for use with arrays having different numbers + of elements (variance produces 'uninitialized' warnings).\n"; say "\n\t Here's one measure of SIMILARITY (using matchs/total element +s evaled): " . $match_count/$item_count; say "\n\t Another uses the total of matches and mismatches as the divi +sor: " . $match_count/$element_total; say "\n\t Magnitude of DIS-similarty (using the ratio of mismatches/ma +tches) : " . $mismatch/$match_count; say "\n\t By the same sloppy spec, but using mismatch/elements_in_firs +t_array): ". $mismatch/($#sort_arr1 + 1); __DATA__ now is the time for all good men to come to the aid of their country w +hile the quick red fox jumps over the lazy brown dog's back and the f +ork runs away with the spoon

    Output for review is in the readmore

    Hope you find this interesting.

    Spirit of the Monastery

    ++$anecdote ne $data

file age in seconds using M file test
2 direct replies — Read more / Contribute
by FreeBeerReekingMonk
on Apr 15, 2015 at 19:17

    Sometimes you just want to know the age of a file in seconds:

    perl -e 'print (int((-M shift)*60*60*24)||1)' script_file

    The ||1 is to ensure a positive number. You can leave it out. To get the file age in minutes:
    perl -e 'print (int((-M shift)*60*24))' script_file

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!
  • 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.