Beefy Boxes and Bandwidth Generously Provided by pair Networks
Come for the quick hacks, stay for the epiphanies.


by GotToBTru (Prior)
on Jun 15, 2010 at 13:25 UTC ( [id://844862] : user . print w/replies, xml ) Need Help??

Learned Perl

around 2001 when an EDI trading partner insisted on using FTP instead of a VAN. I needed a quick way to send and receive that could be embedded in a scheduler, and I knew "Perl does that." 4 hours later, we were up and running.

I use Perl to examine data files and system logs, to produce automated emails and database updates, to perform file transformations, and to perform automated file transfers (moves and/or ftp).

The name GotToBTru is from the title of a song by Christian singer/songwriter Steven Curtis Chapman, and marked his first foray into something approximating rap music. He uses the lyrics to poke fun at himself (and also his listeners). Two things I like: despite his "superstar" status he doesn't take himself too seriously, and the reminder in the lyrics ("gotta be livin' what I say I believe") that nobody will believe my words unless my behavior backs them up.

That Signature...

"But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us." Romans 5:8 (NASB)

This verse is intended to grab your attention because God acted unlike how people think he would act, how they think they should act. Most people think that to please God, to get him to care about you, you have to clean up your act first. You have to stop doing all that wrong stuff, start doing things right. And we think that about other people, too: I won't forgive them until they show me they're sorry.

But God didn't do it that way. He didn't wait for you to become good before he acted. And good thing, too; none of us would have sought him out on our own. The link below is an excellent explanation of why we are how we are, why we know we should be better but somehow can't make ourselves be, and the solution to that problem.

The Gospel

Or see this for a shorter version.

Or read this for an excellent treatise on the rationality of the Christian world view.


Do not look at laser with remaining eye - warning sign in physics lab

An educated man has been defined as one who can entertain himself, one who can entertain another, and one who can entertain a new idea. - Commander Edward Whitehead

Do not regard what you do only as preparation for doing the same thing more fully or better at some later time. Nothing is ever done twice. There is no next time. - General George Patton

The plural of 'anecdote' is not 'data'.

Social Media

LinkedIn Profile

Other interests:

Amateur (ham) radio (callsign AE0Z), Toastmasters(ACB,ALB), vocal and instrumental music, Christian apologetics, Torah observance for Christians


is a Yaesu FT-101ZD ham radio transceiver. This was the last of several models of this radio made in the 1970s and 80s. Note the stylish LCD display.

Well, that about sums it up for evolution:

Life has never been observed to come from non-life.

There is no known observable process by which new genetic information can be added to the genetic code of an organism.

And, some of the reasons to investigate Intelligent Design seriously:

Three Scientific Evidences that point to a designed universe by Dr. Walter L. Bradley


Des‎crip‎tionStringLooks Like

Useful Links:

PerlMonks:Last Hour of CBFullpage ChatLinking Shortcuts
Approval LogMarkup in the MonasteryWriteup Formatting Tips
Levels of MonksKeyboard ShortcutsHow do I post a question effectively?
Better Programming:DBI RecipesBasic Debugging ChecklistReal Life Perl Exercises
Regex TesterData Structures CookbookReferences quick reference
Module StyleExcellent Hash Referenceunary file test operators
More on references

Posts I'm proud of:

Although, if I take too much (any really) pride in my posts here, I need only notice that there is a strong inverse correlation between rating and how much I type!


679th Saint in the Book December 10th, 2014.

Fun Milestones

  • 08/31/15 - You have 1248 points until level 16 - Parson.
  • 03/22/16 - You have 1277 points until level 17 - Prior. (digits total 17)
  • 12/20/16 - You have 2646 points until level 18 - Monsignor.
  • 12/20/16 - You have 2637 points until level 18 - Monsignor. (twice in one day)
  • 03/07/17 - You have 2277 points until level 18 - Monsignor.
  • 06/14/17 - You have 1908 points until level 18 - Monsignor.
  • 07/20/17 - You have 1881 points until level 18 - Monsignor. (coolest so far)
  • 09/20/17 - You have 1800 points until level 18 - Monsignor.
  • 05/19/22 - You have 1269 points until level 18 - Monsignor.
  • 08/05/22 - You have 1179 points until level 18 - Monsignor.


Version: 3.1
GCS d-- s:+ a+ C++$ ULA$ P++$ L++>$ !E--- W++ !N !o !K--
w+ !O !M V+>$ PS- PE !Y PGP>$ t+ !5 !X !R tv b++ DI++++ D+
G-- e++ h---- r+++ y?

Style Code
I2Osi0S<+>++<gt>B0L1C2P0N>R1vl(en)c1a1p(0)r1d0Hsw main-sub

Posts by GotToBTru
Grep Pattern in Seekers of Perl Wisdom
5 direct replies — Read more / Contribute
by GotToBTru
on Dec 12, 2018 at 09:29

    I want to apply a F T T F repeating pattern as a filter to an array or list. Here is what I came up with:

    $i = 0; @result = grep { $i = 0 unless ($i<4); $i++%3 ? 1 : 0; } 0..12

    @result = 1,2,5,6,9,10

    It works but looks clunky. Any more elegant options?

    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

Clean Up Empty Directories in Cool Uses for Perl
4 direct replies — Read more / Contribute
by GotToBTru
on Feb 16, 2018 at 16:50
    The code somebody else wrote cleans out old files, but leaves the directories behind. This cleans up the directories.

    #!/usr/bin/perl use strict; use warnings; chomp(my @list = `du -kh /mnt/edi/si51/documents`); my $dltd = 0; foreach my $line (@list) { my ($size,$path) = split /\t/, $line; $size =~ s/\D//g; if ($size == 0) { rmdir $path && $dltd++ } } printf "%d directories deleted.\n",$dltd;

    UPDATE: There are several things that were in an earlier version of this script that didn't make the second cut, but only because I got lazy. My original got deleted somehow, and I had foolishly not kept a copy, so I wrote the above quickly.

    The directory structure is documents/4digityear/abbreviatedcardinalmonth/2digitday/hour/minute. At first I restricted deletions to directories above some number of days old, but rmdir updates the directory time information, meaning a directory that was now empty because all its empty constituent directories were gone looked like it was brand new. This made it useless to run consecutively. I came up with a calculation that used the directory tree to come up with the age, and that worked. I just didn't bother with it when I rewrote the script this time. Some of the alternate solutions don't have that limitation.

    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

Adding without Addition in Cool Uses for Perl
1 direct reply — Read more / Contribute
by GotToBTru
on Feb 15, 2017 at 13:06

    Wasn't sure if this belongs here, or in Obfuscations.

    Having once run:

    use strict; use warnings; use Storable; my (%table); foreach my $i (0..9) { foreach my $j ($i..9) { $table{$i}{$j} = $table{$j}{$i} = $i + $j } } store \%table, 'addition_table';

    I present to you: addition!

    use strict; use warnings; use Storable; my %table = %{retrieve('addition_table')}; my @problem = @ARGV; my (%matrix); foreach my $number (@problem) { my $log = 0; push @{$matrix{$log++}}, $_ for reverse (split //, $number); } my $col = 0; while (exists $matrix{$col}) { my @column = @{$matrix{$col}}; my $first = shift @column; while(scalar @column > 0) { my $second = shift @column; $first = $table{$first}{$second}; if (length($first) > 1) { $first = substr($first,-1,1); push @{$matrix{$col + 1}}, 1; } } $matrix{$col++} = $first; } printf "%s",$matrix{$col - $_} for (1..$col); print "\n";
    H:\perl>perl 1 1 H:\perl>perl 21 14 99 6 12 152 H:\perl>perl 999999999999999999999999999999999999999999 1 1000000000000000000000000000000000000000000

    Addition tables for other number systems are left as an exercise for the (extremely bored) reader. Vaguely apropos of Multiply Hex values. I started to write a program to do multiplication and realized I needed to figure out how to add first.

    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

Does hash contain minimum keys? in Cool Uses for Perl
2 direct replies — Read more / Contribute
by GotToBTru
on Nov 11, 2016 at 12:17

    Testing a hash to see if it has values for all required keys. Extraneous keys are okay.

    use strict; use warnings; use Test::More tests => 3; my (%required,%over,%under,%partial); $required{$_} = 1 for qw/header detail trailer/; $over{$_} = $_ for qw/title header subject detail trailer postscript/; $under{$_} = $_ for qw/header trailer/; $partial{$_} = $_ for qw/header trailer/; $partial{detail} = undef; ok(test_it(%over),'checking %over for required keys'); ok(test_it(%under),'checking %under for required keys'); ok(test_it(%partial),'checking %partial for required keys'); sub test_it { my %h = @_; # return (grep {$required{$_} && $h{$_}} keys %h) == (keys %required) +; return (grep {$required{$_} && defined $h{$_}} keys %h) == (keys %r +equired); }

    Update: use of defined suggested by choroba. I would have run into this because 0 is a value I would encounter.

    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

EDI File Parsing Helps in Cool Uses for Perl
No replies — Read more | Post response
by GotToBTru
on Sep 21, 2016 at 13:13

    Decompose ANSI X12 transmission into individual documents.

    use strict; use warnings; use Data::Dumper; my $ediFile = shift; my ($contents,$delim,$term,$txnCount,@transactions); { $/ = undef; open my $ifh,'<',$ediFile; $contents = <$ifh>; } ($delim,$term) = $contents =~ m/^ISA(.).{101}(.)/; $delim = quotemeta($delim); @transactions = $contents =~ m/(ST$delim.+?SE$delim\d+$delim\d+$term)/ +gs; ($txnCount) = $contents =~ m/${term}GE$delim(\d+)/; die "Parse error - transaction counts wrong" if ($txnCount != scalar @transactions); foreach my $transaction (@transactions) { # put into useful form for processing my @segments = split /$term/,$transaction; my ($segCount) = $transaction =~ m/${term}SE$delim(\d+)/; die "Parse error - segment counts wrong" if ($segCount != scalar @segments); my ($process_this); map { push @$process_this, [split /$delim/,$_] } @segments; print Dumper(\$process_this); }

    EDI File:

    ISA*00* *00* *02*AAAA *01*123456789 * +160921*075 1*U*00401*000099836*0*P*:~GS*FA*AAAA*123456789*20160921*0751*99836*X*0 +04010~ST*9 97*998360001~AK1*SM*7311~AK9*A*1*1*1~SE*4*998360001~ST*997*998360002~A +K1*SM*7312 ~AK9*A*1*1*1~SE*4*998360002~GE*2*99836~IEA*1*000099836~


    $VAR1 = \[ [ 'ST', '997', '998360001' ], [ 'AK1', 'SM', '7311' ], [ 'AK9', 'A', '1', '1', '1' ], [ 'SE', '4', '998360001' ] ]; $VAR1 = \[ [ 'ST', '997', '998360002' ], [ 'AK1', 'SM', '7312' ], [ 'AK9', 'A', '1', '1', '1' ], [ 'SE', '4', '998360002' ] ];
    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

XML::Parser Namespace example in Cool Uses for Perl
No replies — Read more | Post response
by GotToBTru
on Aug 31, 2016 at 11:57

    We use an application at $work that uses XML internally for everything. The applications that feed it often wrap the files into a single line, which is a nuisance. vi won't display them, and grep will return the entire file on any match. I've created the code below, based almost entirely on sample code from others, to extract some key information from files.

    The first interation (everything below except line 13) worked great until I encountered the namespace prefixes. It didn't take long to find out the solution, but I did not see it implemented in actual code. I guess everybody else thought it was obvious! The Namespaces => 1 in the constructor tells the parser to pull the namespace prefixes from the tag names (they are stored elsewhere), and for my simple example, that's all I need.

    Program notes: %interesting is the list of tags the parser will store as it parses the file. The values are stored in the hash %message with the tag as key. In my end handler, I choose a subset of tags based on the document type to display.

    #!/home/edi/perl/perl use strict; use warnings; use XML::Parser; my $parser = new XML::Parser( Handlers => { Start => \&hdl_start, End => \&hdl_end, Char => \&hdl_char, Default => \&hdl_def, }, Namespaces => 1); my (%message,$element); my %interesting = map { $_, 1 } qw/shipmentStatus responseToLoadTender customerIdentifier proNum lo +adTenderId eventType eventDate eventTime city seqnum customerId segme +ntId action date/; my $file = shift; $message{file} = $file; $parser->parsefile($file); #print "Placeholder\n"; sub hdl_start { my ($p,$elt,%attr) = @_; $element = $elt; } sub hdl_end { my ($p, $elt) = @_; return unless $interesting{$elt}; if ($elt eq 'shipmentStatus') { if ($message{eventType} !~ m/X6/ ) { printf "%-20s: %s\n", $_, $message{$_} for qw/file proNum loadTenderId city seqnum eventType eventDate + eventTime/; print "\n"; } } if ($elt eq 'responseToLoadTender') { printf "%-20s: %s\n", $_, $message{$_} for qw/file segmentId loadTenderId action date/; print "\n"; } } sub hdl_char { my ($p, $str) = @_; return unless $interesting{$element}; $message{$element} .= $str; } sub hdl_def {}
    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

Searching over multiple directories using unusual logic in Seekers of Perl Wisdom
1 direct reply — Read more / Contribute
by GotToBTru
on Oct 27, 2015 at 13:24

    I am looking for either suggestions for improvement, or ways to use existing modules like File::Find::*.

    I wrote a utility to search through file archives organized according to a direction/date/topic structure. I usually know which direction and topic to search, but the transaction may have been archived on a range of days. I wrote my own very limited File::Find (code below) in order to implement this search.

    For instance, I am looking for a transaction we sent containing the string "12345678", I know it's for CustomerD, and I'm pretty sure we sent it this week, so it could be in:

    outbound/20151027/CustomerD outbound/20151026/CustomerD ... outbound/20151021/CustomerD

    outbound/2015nnnn/ will have many subdirectories, and some of them will have hundreds of files. As a result, if I can't supply the topic, I run the search in the background and work on something else. But if I can, the response is quick enough.

    So why explore modules if I have a working solution? Learning what's in CPAN, and how to better use it, is to my benefit.

    Source code:

    Dum Spiro Spero
Free Space Usage Report in Cool Uses for Perl
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
Distribute the leftovers in Cool Uses for Perl
No replies — Read more | Post response
by GotToBTru
on Mar 20, 2015 at 12:46

    We get the quantity of a product shipped from the database, and a list of individual carton labels from an external file. The actual contents of each carton are unknown. Working assumption would be qty per carton = shipped qty / carton count. Easy enough. But what if the division doesn't come out clean?

    use POSIX qw/ceil/; ... $sq = $shipped_quantity; $cc = $carton_count; foreach $label(@label_list) { if ($cc == 0) { print "Qty per carton math error"; next OUTER; } $per_container = ceil($sq/$cc); $sq -= $per_container; $cc -= 1; ... }

    If shipped quantity is 8 and carton count is 5, first 3 cartons will have 2 each, last 2 have 1.

    Yeah, almost too simple to mention. But this came up today, and I remember little code bits like this better when I write them down somewhere.

    Update: s/box/carton/

    Dum Spiro Spero
Archive by month and extension in Cool Uses for Perl
No replies — Read more | Post response
by GotToBTru
on Nov 24, 2014 at 16:01

    Created the following to archive data from our applications. We archive by month, and by file extension, so those are built in assumptions in this program.

    Source Code:


    1 Peter 4:10