Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked

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.

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

510 Concurrent/Simultaneous SQL Processes running on Windows O/S Laptop
3 direct replies — Read more / Contribute
by erichansen1836
on Apr 15, 2015 at 11:29

    This script launches 510 simultaneous/concurrent MS-Access database SQL queries, which the database Jet Engine

    can handle just fine with increased Threads configured to 510, default is 3. The calling script launches

    the 510 instances, then immediately exits without waiting for them to complete. If you run this from a command

    prompt, and open Windows Task Manager, you can watch the concurrent processing occuring since I have prints to the

    screen going on. CPU usage will hit 100%, and my RAM memory usage hit a high of 83% for a split second, then fell

    back down rapidly. I have a single Intel Celeron processor 2.2GHz, and 3-GIG RAM on my WIndows 7 Home Premium

    Laptop. The database hit, contains a table of Bible book names: Genesis thru Revelation (66 books).

    510 output files are created witht the SQL report output. I used a File Compare routine to verify all the same output.

    This reporting process produces reliable SQL output every time. Way to go Jet Engine!


    use Win32; use Win32::Process; $PWD=Win32::GetCwd(); for ($i=1; $i<=510; $i++) { Win32::Process::Create($POBJ,"$PWD\\RptUtl.exe","RptUtl $i",0,DETACH +ED_PROCESS,"."); } exit;


    CALLED SCRIPT i.e. RptUtl.exe <-- compiled

    use Win32::ODBC; use Win32; use IO::Handle; $i=$ARGV[0]; #-- called from another Perl script that launches 1 to +510 Windows O/S "detached" background processes. $PWD=Win32::GetCwd(); $outfile="$PWD\\BibleBooks_$i.txt"; open(OUT,"> $outfile"); OUT->autoflush(1); $USR=Win32::LoginName(); $NODE=Win32::NodeName(); print OUT "Working Directory=\n $PWD\n User=$USR Node=$NODE\n\n"; $FILEDSN="FILEDSN=$PWD\\Bible.dsn; PWD=xYz"; $db = new Win32::ODBC($FILEDSN); if (! $db) { $error = Win32::ODBC::Error(); print OUT "$error\n"; die; } $ret=$db->Sql("SELECT * FROM BibleBook"); if ($ret) { $error = Win32::ODBC::Error(); print OUT "$error\n"; die; } while ($db->FetchRow()) { my(%data) = $db->DataHash(); print OUT $data{'bk'} . " " . $data{'name'} . " " . $data{'shor +t_name'} . "\n"; print $data{'bk'} . " " . $data{'name'} . " " . $data{'short_na +me'} . "\n"; } print OUT "\nGood bye.\n"; exit; END { if ($db) { $db->Close(); undef $db; } close(OUT); }

    CONTENTS of ODBC FILEDSN Bible.dsn which is referenced in the above code



    Driver=Microsoft Access Driver (*.mdb)


    Update: Goodbye

Non-Formula based Text Encoding - with Compression
3 direct replies — Read more / Contribute
by erichansen1836
on Apr 15, 2015 at 10:15


    #-- ENCODING with COMPRESSION (non-FORMULA based).


    #-- Create 242,234 unique codes, 1-3 characters in length, from the characters {a-zA-Z0-9}.

    #-- 62 (1 char codes) + 3844 (2 char codes) + 238,328 (3 char codes) = 242,234 unique codes.

    #-- (Somewhat like MIMEbase64 encoding, but my encoding is non-formula based.)


    #-- The unique codes can be mapped to a unique list of words(+ punctuation) occuring between

    #-- whitespace within a text document. The text document can be rewritten in encoded/compressed

    #-- fashion this way, by mapping words to codes, then decoded at a later time using a persistent Perl SDBM database tied hash

    #-- table holding the word-to-code mappings for a particular text document.

    #-- There are a number of ways to do the word-to-code mappings, to add randomness to the

    #-- assignments. That fact makes this encoding scheme undecipherable.

    #-- There are just too many combinations of how 242,234 codes can be

    #-- mapped to the infinite number of words(+ punctuation) occuring between whitespace within

    #-- a text document (or database table), no 2 text documents having the same words(+punctuation) mapped to the same

    #-- codes, after random assignment of codes is introduced.

    #-- Seeding is the word for introducing randomness into the word-to-code assignment.


    #-- That said, there really is no need for secrecy when discussing this encoding strategy,

    #-- in general terms, like I have done here, since this is not formula based encoding/decoding.

    #-- BELOW:

    #-- Perl code example to create an output file of the 242,234 unique codes, 1-3 chars long.

    #-- These codes can be read into a program hash table (of key/value pairs) to assign unique

    #-- words in a text document to unique codes 1-3 chars long. Random seeding can be introduced,

    #-- plus sorting of the unique codes and/or unique words, to create an infinite number of

    #-- possible word-to-code mapping combinations each time a different text document is encoded.

    #-- The unique words in any 2 text documents never being mapped to the same codes.



    #-- Secretly tell your boss just what you think of him/her. @#%%*@!@#

    #-- Tell that person you admire from afar, what you think of him/her. X0X0X0X

    #-- Freak out your high school English teacher or college professor by turning in your essay

    #-- in encoded form, and act like it's a normal thing he/she should be able to read. Duh! You're a teacher, can't you decode that?

    #-- Tell them you didn't want another student copying your work (a borrowed work at that).

    #-- Do the work of a monk and encode the Bible for posterity safe keeping.

    #-- Send the IRS your annual Income Tax Filing encoded (don't cheat !!!).

    #-- Become an informant for the FBI or CIA. Become a private investigator. etc.


    use IO::Handle;

    open(OUT,"> $outfile");

    @array1=split(/ */,'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789');

    @array2=@array1;    @array3=@array1;

    foreach $i (@array1) {
       print OUT "$i\n";
       foreach $j (@array2) {
           print OUT "$i$j\n";  
           foreach $k (@array3) {
              print OUT "$i$j$k\n";
simple Perl script template
3 direct replies — Read more / Contribute
by Dumu
on Apr 09, 2015 at 06:47

    I wrote this script because I just wanted to automate typing two lines of Perl every time I wrote a small test-case script.

    This is dead simple and doesn't really count as 'cool'. However, in the words of the Greek poet Callimachus and E.F. Shumacher, "small is beautiful".

    The script simply prints its own top two lines into every new file specified on the command line, unless the file already exists.

    Any and all feedback will be welcomed.

    #!/usr/bin/env perl use Modern::Perl; while (<@ARGV>) { my $fname = $_; unless (-e $fname) { open my $fh, '>', $fname; say $fh "#!/usr/bin/env perl"; say $fh "use Modern::Perl;\n\n"; say STDOUT "created $fname"; } else { say STDOUT "*** didn't overwrite $fname"; } }
Number functions I have lying around
2 direct replies — Read more / Contribute
by Lady_Aleena
on Mar 30, 2015 at 20:30

    I was going through old scripts I had lying around and decided to clean them up a bit. I don't remember why I wrote them or what I am going to do with them. I think they are lukewarm uses for perl, and I probably reinvented the wheel on some of them. Instead of them just lying around my hard drive collecting dust, I share them with you, kind reader. Do with them what you will.

    The first function lists primes, the second two functions list fractions, the last few are about Roman numerals. I lumped them together in a module called Numbers because I ran out of imagination.

    Welcome to my sandbox.

    If you want to see a Roman numeral (MDCCCMVCXXVII) with the overline, go to your display settings and set up the overline class in your style sheet as follows...

    .overline { text-decoration: overline; }
    No matter how hysterical I get, my problems are not time sensitive. So, relax, have a cookie, and a very nice day!
    Lady Aleena
Binary DeBruijn sequences.
No replies — Read more | Post response
by BrowserUk
on Mar 30, 2015 at 13:55

    I needed a binary (alphabet 0|1) DeBruijn sequence, and found a simple rule for producing one (see the comments).

    I first coded it using strings of '0' and '1' characters and a hash to detect words already included.

    Very quick to code, but using one byte per bit, and a hash, the size rapidly chewed through gobs of memory, long before I reached my target of 31-bit words.

    #! perl -slw use strict; ### Prefer Ones: ### Write n zeros. ### Then, always write a one unless it would cause the repetition of a +n n-length string; ### In which case, write a zero. our $N //= 4; my $seq = '0' x $N; my %seen = ( $seq => 1 ); for( $N .. 2**$N ) { $seq .= ( not exists $seen{ substr( $seq, -( $N-1 ) ) . '1' } ) ? +'1' : '0'; ++$seen{ substr( $seq, -$N ) }; } $seq .= substr $seq, 0, $N-1; print length $seq; <STDIN>; my $re = '(.)(?=(' . '.'x($N-1) . '))'; print $1 . $2 while $seq =~ m[$re]g;

    So then I coded another version that used vec to produce the sequence directly into bits; and another bitvector to track the words seen.

    This was much tricker to code -- despite the apparent simplicity of the code -- and goes much higher, using a mere faction of the memory, but unfortunately stops before my target because vec (as of the version of Perl I'm using) still treats its second argument as a signed, 32-bit integer despite that a) negative offsets make no sense; b) I'm using a 64-bit version of Perl :(

    (If you try it with -N=7 or greater, I strongly recommend redirecting the output, or disabling it, because watching 100s or 1000s of 0s & 1s scroll up the screen is a very boring occupation :)

    #! perl -slw use strict; ### Prefer Ones: ### Write n zeros. ### Then, always write a one unless it would cause the repetition of a +n n-length string; ### In which case, write a zero. our $N //= 4; my $t1 = "b${ \(2**$N+$N-1) }"; my $seen = ''; my $mask1 = ( 1<<$N )-1; my $seq = pack 'Q*', (0) x 100; my $val = 0; for( $N .. 2**$N+$N-1 ) { ## if N=5; 5 .. 36; if N=6 +, 6 .. 64+6-1 = 69; $val = ( $val << 1 ) & $mask1; vec( $seen, $val | 1, 1 ) or do{ $val |= 1; vec( $seq, $_, 1 ) = 1 +; }; vec( $seen, $val , 1 ) = 1; } print unpack $t1, $seq;

    Note: both the above versions produce the 2N+N-1 bit complete sequence, rather than the 2N sequence that is shown in the Wikipedia page which only become complete once you 'wrap them around'.

    Ultimately, I ended up moving to C to achieve my target, which even more tricky (damn, I miss vec in C), but it eventually allowed me to produce the 1/4GB binary sequence I was after.

    With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority". I'm with torvalds on this
    In the absence of evidence, opinion is indistinguishable from prejudice. Agile (and TDD) debunked
"Spritz" crypto algorithm
No replies — Read more | Post response
by RonW
on Mar 24, 2015 at 16:41

    For testing purposes, I implemented Rivist's new crypto algorithm in Perl. It is a proposed replacement for his (once very popular) RC4 algorithm. Thought there might be some curiosity value to it.

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.
  • 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 imbibing at the Monastery: (3)
    As of 2015-10-10 14:57 GMT
    Find Nodes?
      Voting Booth?

      Does Humor Belong in Programming?

      Results (257 votes), past polls