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

Seekers of Perl Wisdom

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

If you have a question on how to do something in Perl, or you need a Perl solution to an actual real-life problem, or you're unsure why something you've tried just isn't working... then this section is the place to ask. Post a new question!

However, you might consider asking in the chatterbox first (if you're a registered user). The response time tends to be quicker, and if it turns out that the problem/solutions are too much for the cb to handle, the kind monks will be sure to direct you here.

User Questions
Niche programming
5 direct replies — Read more / Contribute
by maurocavendish
on Apr 05, 2020 at 11:31

    Hi, fellow monks!

    I'm a returning Perl programmer, stuck in a vortex of bad management and poor quality code at my regular job in modern IT sweatshops in Italy.

    At the start of my career, I worked few years doing software/hardware monitoring in Perl, and I loved it. I am a self-taught 42-years-old programmer, with no CS/maths education. I'd like to take some time to explore my possibilities in my spare time, for fun and growth. A lot of the sexier technologies are out of my reach, because I cannot afford years of mentally and financially taxing college level studies. Also, I have a very practical mindset, more keen on simple, concise solutions to well-defined problems. I'm thinking on the lines of things like Domain Specific Languages, APIs, focused libraries.

    Could you provide some insights into niche but deep domains I can tackle with Perl, without having to resort to learn advanced college stuff or crazy architectural patterns? I'm aware I can do couple Web projects, but it would feel like being at work again, and I've also become weary of Web Development/CRUD apps/Scrum gimmicks/you name it. I'd love to find concrete domains that I can tackle with a somewhat scripting mindset for my leisure and enrichment in the next couple years. I hope I make sense, and I wait to be enlightened by your comments!
COVID-19 data analytics, cryptography, and some things you should know
5 direct replies — Read more / Contribute
by tachyon-II
on Apr 04, 2020 at 21:15

    Hi All,

    It's been a decade or so but my love of Perl continues.

    The background of the Why? for this question can be found at which I recommend you read, particularly if you take any medication. It might just save your life.

    The data collection tool to which it applies can be found at We are gathering this data because the US, Chinese and Canadian CDC's are not and when the Italians partially gathered this medication data it showed 73% of all COVID-19 deaths occurred in the ~3% of people taking two specific classes of medication. The Turkish data release a few days later found similarly - 68.8% of deaths occurred in this really small group.

    The problem to be solved is the safe, deidentified release of IP addresses and Browser strings to fulfil the requirements of HIPAA, GDPR and CCPA. We simply do not gather any other PII (personally identifiable information) so it is impossible for this to leak. Age range, sex, disease severity and outcome and medications are the other data points.

    These 2 identifiers will assist researchers in assessing if the crowdsourced data we are gathering is "gamed" or "believable". We have taken steps to make automated submission difficult, but as we hackers know, virtually nothing is impossible if you really put your mind to it...

    So the task to hand is to convert an IP and Browser String into a cryptographically secure hash that can not be reversed or revealed with a rainbow table. IP addresses and Browser strings both exist in a small finite search space.

    Given this data will be released publicly and is timestamped it is trivial for an attacker to correlate a known IP address and Browser string to these hashes. Given the secret packing data I don't believe this would allow any quantity of computational power to elucidate the packing data and thus create a lookup table, but if that is incorrect I would be good to know now and fix it before our impending first data release.

    While I am expert in the field of medicine my knowledge of crypto and how you attack it is less. SHA3 was chosen for its resistance to length extension attacks and the packing data size to give enough random data for the resultant hash to spread evenly across that space. Maybe that's good enough, maybe it can/should/must be done better.

    Here is a draft version of those hashing functions. Expert commentary appreciated, particularly from cryptographers.

    #!/usr/bin/env perl package SHA3; use strict; use warnings; use Digest::SHA3 qw(sha3_256_hex); use Digest::MD5 qw(md5_hex); use Socket qw( inet_pton AF_INET AF_INET6 ); my @packing = qw( fa13a941b76466850c2558d9ae5d969f e71ab0d8bb54c75b37ad23a449050121 6736564ec6bc9bbc8ba42df565317443 c3e088a5cf247ec0df971c5cb9ee6eec 6cf20d548878cdd82b8f207192f58c80 660a311b8d75d5fb28c73f7e2ec5d25e 377f92899b81ad7c5e1d08b81ccc8904 8e1f27dee8ae3374ae5c462adf37bba5 ccd558ff6b9de48ca22023ead2dbd7a2 ff228ef28ae8544155323180ba070d1b ); print SHA3::sha3_ip(''), "\n"; print SHA3::sha3_ip(''), "\n"; print SHA3::sha3_ip('2001:0db8:0000:0000:0000:8a2e:0370:7334'), "\n"; print SHA3::sha3_ip('2001:0db8:0000:0000:0000:8a2e:0370:7335'), "\n"; print SHA3::sha3_bs('Mozilla'), "\n"; print SHA3::sha3_bs('Win32'), "\n"; =head 2 sha3_ip { Expects a dot quad or an IPv6 address and returns a SHA3_256_hex string or null string for invalid input =cut sub sha3_ip { my $ip = shift; my $pack_format; if ( $ip =~ m/^\d+\.\d+\.\d+\.\d+$/ ) { my $bytes = pack("H32 a4 H32", $packing[0], inet_pton( AF_INET +, $ip ), $packing[7]); my $hash = sha3_256_hex($bytes); return $hash; } elsif ( $ip =~ /^([0-9a-f]{0,4}:){0,7}([0-9a-f]{0,4})$/i ) { my $bytes = pack("H32 a16 H32", $packing[0], inet_pton( AF_INE +T6, $ip ), $packing[7]); my $hash = sha3_256_hex($bytes); return $hash; } warn "Invalid IP:$ip\n"; return ''; } =head 2 sha3_bs { Expects a browser string and returns a SHA3_256_hex string or a null string for invalid input =cut sub sha3_bs { my $bs = shift; unless (length $bs > 4 ) { warn "Insufficient data in browser string $bs"; return ''; } my $bytes = pack("H32 H32 H32", $packing[1], md5_hex($bs), $packin +g[8]); my $hash = sha3_256_hex($bytes); return $hash; }
[solved] Passing a sub reference which uses Parallel::ForkManager
2 direct replies — Read more / Contribute
by minor_wazoo
on Apr 04, 2020 at 15:37
    Greetings all,

    Update: After flushing out the code to a full working example as per AnonomousMonk's remark, the problem does not reproduce.

    I have to get back to my original code and find the error now that I have a working example.

    The original question, updated to fit the updated (and working) code:

issue with Encode::Guess
2 direct replies — Read more / Contribute
by toohoo
on Apr 04, 2020 at 14:11

    Hello everybody

    I have an issue with Encode::Guess. I don't know what I'm doing wrong.

    I want to guess the encoding of a file.

    #!/usr/bin/perl use strict; use warnings; print "\n"; use Encode; use Encode::Guess; #my @encs = Encode->encodings(":all"); #print join("--",@encs); push( @INC, '.'); #use sniver; our $data; if( $ARGV[0] eq '') { print "no ARGV[0]?: $ARGV[0]\n"; usage(); } elsif ($ARGV[0] ne '') { print "IS ARGV[0]: $ARGV[0]\n"; $data = getfile($ARGV[0]); if($data){ print length($data),"--\n"; print "length(data)>0\n"; }else{ print "lenght(data)<=0\n"; #my EIN; abor("getfile no success"); } } else { print "no ARGV[0]?: $ARGV[0]\n"; } my $encodings_test = 'ascii cp1252 cp437 cp850 iso-8859-1 utf-8-strict + utf8'; my $decoder = guess_encoding($data, qw/$encodings_test/); print "decoder: $decoder\n"; sub usage { print " - thomas hofmann (c) Apr 2020\nUSAGE: perl 2utf8.p +l (file)\n"; } sub mes { my $mes = shift; if($mes){ print "$mes"; if($mes !~ m/\n$/){print "\n";} } } sub abor { my $mes = shift; if($mes){ mes( "Error: $mes" ); if($mes !~ m/\n$/){print "\n";} } usage(); exit(1); } sub getfile { my ($filepath, @rest) = @_; my $content = undef; my $orgein = $/; local (*GETFILEDAT); if (!open(GETFILEDAT, $filepath)) { return ($content); } undef ($/); binmode(GETFILEDAT); $content = <GETFILEDAT>; close (GETFILEDAT); $/ = $orgein; return ($content); }

    The used file is the following ABC.dcm file

    * Datensatz: XXX * Erzeugt von: Hofmann, Thomas * Datum: 24.05.2019 08:06:27 * * ASE DCEnv ComponentV2.6.0.2243 KONSERVIERUNG_FORMAT 2.0 FESTWERT AAA LANGNAME "Querbeschleunigunge" EINHEIT_W "-" WERT 0.8000000119 END FESTWERT BBB LANGNAME "Rollzentrumshoehe" EINHEIT_W "m" WERT 0.4600000083 END FESTWERT CCC LANGNAME "Sportmodus" EINHEIT_W "m" WERT 0.4699999988 END FESTWERT DDD LANGNAME "Aufbaumasse" EINHEIT_W "kg" WERT 1850.000000 END FESTWERT EEE LANGNAME "Federsteifigkeit" EINHEIT_W "N/mm" WERT 25 END FESTWERT FFF LANGNAME "Vorderachse" EINHEIT_W "N/mm" WERT 22 END FESTWERT GGG LANGNAME "Momentenverteilung abhängig" EINHEIT_W "m/s^2" WERT 0.5 END FESTWERT HHH LANGNAME "abhängig der Querbeschleunigung" EINHEIT_W "-" WERT 0.25 END

    Thanks in advance

nytprof Profiler gives diverse results
3 direct replies — Read more / Contribute
by boleary
on Apr 04, 2020 at 11:46

    I am running nytprof to profile some test code on a recent windows 10 laptop
    It has been very helpful to fix some subroutines to make it all run faster

    The strange thing is with the test I am running it can finish in 11 seconds or sometimes 30 seconds...
    But the test is exactly the same.
    When I look at the profile, it looks the same except the time for each event just doubles
    I'm wondering if my laptop is going into a reduced power mode?
    I can hear the fan changing speeds as I run....

    Would anyone care to weigh in?

    Fast 12.4 seconds

    190697 1 1 3.05s 3.98s main::equals_contains_or_m +atches 190697 4 3 1.86s 6.93s main::extended_string_matc +h_check 480 1 1 1.41s 8.57s main::assignSymSecToPins 707333 159 20 1.41s 1.41s main::CORE:match (opcod +e) 480293 45 10 1.04s 1.04s main::CORE:regcomp (opco +de) 23425 1 1 672ms 986ms main::newStripLeadingZeros 2953 6 2 294ms 687ms main::stringContainsMatchFro +mCset 279247 53 11 247ms 247ms main::CORE:subst (opcode +) 762 5 2 236ms 252ms main::simple_dpair_find 10251 1 1 130ms 216ms main::isValidRegex 6372 1 1 123ms 162ms YAML::Tiny::_load_scalar 516 1 1 119ms 321ms YAML::Tiny::_load_hash 6 1 1 109ms 601ms main::sortSectionSignalList 647 1 1 86.4ms 124ms main::sortAtomsNumerically 10251 1 1 71.0ms 290ms main::fixLonelyQuantCharsI +nRegEx

    Medium 16 seconds

    190697 1 1 3.73s 4.92s main::equals_contains_or_m +atches 190697 4 3 2.36s 8.78s main::extended_string_matc +h_check 707336 159 20 1.88s 1.88s main::CORE:match (opcod +e) 480 1 1 1.77s 11.2s main::assignSymSecToPins 480293 45 10 1.38s 1.38s main::CORE:regcomp (opco +de) 23425 1 1 950ms 1.36s main::newStripLeadingZeros 762 5 2 672ms 713ms main::simple_dpair_find 2953 6 2 375ms 987ms main::stringContainsMatchFro +mCset 279247 53 11 314ms 314ms main::CORE:subst (opcode +) 10251 1 1 168ms 456ms main::fixLonelyQuantCharsIn +RegEx 10251 1 1 154ms 283ms main::isValidRegex 6372 1 1 130ms 169ms YAML::Tiny::_load_scalar 516 1 1 119ms 328ms YAML::Tiny::_load_hash 647 1 1 80.6ms 123ms main::sortAtomsNumerically 117 3 2 68.8ms 68.8ms Clone::clone (xsub)

    SLOW 26.7 seconds

    190697 1 1 7.06s 9.38s main::equals_contains_or_m +atches 190697 4 3 4.17s 17.0s main::extended_string_matc +h_check 480 1 1 3.40s 21.6s main::assignSymSecToPins 707335 159 20 3.08s 3.08s main::CORE:match (opcod +e) 480293 45 10 2.60s 2.60s main::CORE:regcomp (opco +de) 23425 1 1 2.15s 3.22s main::newStripLeadingZeros 279247 53 11 625ms 625ms main::CORE:subst (opcode +) 2953 6 2 489ms 1.21s main::stringContainsMatchFro +mCset 762 5 2 453ms 480ms main::simple_dpair_find 10251 1 1 244ms 397ms main::isValidRegex 6 1 1 172ms 899ms main::sortSectionSignalList 10251 1 1 130ms 533ms main::fixLonelyQuantCharsIn +RegEx 6372 1 1 128ms 166ms YAML::Tiny::_load_scalar 68724 10 3 120ms 120ms main::CORE:substcont (opco +de) 516 1 1 115ms 320ms YAML::Tiny::_load_hash
DBIx::Class die on warning
2 direct replies — Read more / Contribute
by bliako
on Apr 04, 2020 at 09:29

    I am reading unclean data and inserting to DB. At this stage, I need DB insert() statements to die if something dodgy happens, even a warning, for example I get this Non-integer value supplied for column. I use db-connection parameters these: {RaiseError=>1,PrintError=>1} and wrap my insert() around an eval to catch any die(), like my $rc = eval { $obj->insert(); 1 }; if( $@ || ! $rc ){ die "error for this object: $obj" }

    But it does not work. The warning stays a warning and does not elevate to a die as I had hoped.

    This works but isn't it too heavy in a loop of thousands of inserts?

    for my $obj (@objstoinsert){ local $SIG{__WARN__} = sub { die "died with $_[0], the object was $o +bj" } $obj->insert() }

    Isn't there a simple flag to ask to elevate all warnings to errors and die?

    p.s. I could localise __WARN__ to an outer scope but messes up other warn()'s.

pre-texted <STDIN>
5 direct replies — Read more / Contribute
by ShainEdge
on Apr 04, 2020 at 06:18
    I'm trying to make a simple perl based notebook (for my own learning experience). Other then Adding new notes, and Deleting them, I would like to edit current notes.

    Is there a way to insert a note text into the <STDIN> block, as if the person had typed it in, so that it can be edited before (entering) the new edit of the note?

    So, for example:
    The note "grocery list" already has "milk, butter, bread and eggs" stored.

    Choosing the "E)dit note" and selecting the "grocery list" would print out the stored text in an editable format so that the user can make a change such as move to add ", peanut butter" after "bread" then enter the new text as the edited note.

    It might be easier in Perl/Tk, but I was wondering if there is a solution in a command line version.
AnyEvent tcp_server not working
2 direct replies — Read more / Contribute
by navalned
on Apr 03, 2020 at 17:34
    I have the following code that I believe should function as an echo server.
    #!/usr/bin/env perl use strict ; use warnings ; use AnyEvent ; use AnyEvent::Handle ; use AnyEvent::Socket ; my $main = AnyEvent->condvar(); tcp_server undef, undef, sub { my ($fh, $host, $port) = @_; my $handle; $handle = AnyEvent::Handle->new( fh => $fh, on_error => sub { my ($hdl, $fatal, $msg) = @_; AE::log error => $msg; $hdl->destroy(); }, on_eof => sub { my ($hdl) = @_; $hdl->destroy(); }, on_read => sub { my ($hdl) = @_; $hdl->push_read(line => sub { my ($hdl, $line) = @_; if ($line =~ m/quit/i) { $hdl->push_write("goodbye\n"); $hdl->destroy(); } $hdl->push_write($line); }); } ); $handle->push_write("Hello $host:$port\n"); }, sub { my ($fh, $thishost, $thisport) = @_; print STDERR "$thishost:$thisport\n"; }; $main->recv();
    However, when I netcat into the server. I see the greeting and the server immediately closes the connection. I'm probably missing something simple, but not sure what. Thanks!
DateTime issues
2 direct replies — Read more / Contribute
by htmanning
on Apr 03, 2020 at 16:49
    Monks, I'm using the following to check for things happening one year from now and one week from now.
    use DateTime::Duration (); my $one_year_from_now = $now->add( years=>1 ); if ($reservation_date > $one_year_from_now) { do something } and then use DateTime::Duration (); my $one_week_from_now = $now->add( weeks=>1 ); if ($reservation_date > $one_week_from_now) { do something }
    If the one year from now routine happens before the one week from now routine, it cancels out the one week from now routine. It is as if it is resetting NOW and I don't understand why.
If unsuccessful action
2 direct replies — Read more / Contribute
by fasteddye
on Apr 03, 2020 at 14:53

    When this script is triggered to run, its function is to login to our Cisco dialup router, make a dial up call to a remote router modem, login to the remote router, run some Cisco commands, and then send an XML formatted email to our ticketing system including the output from the commands it runs. Problem we are running into is if the Cisco dialup router does not make a successful connection to the far end router modem, the script does not send the email to our ticketing system. It seems the script must hang or just not complete at that point. If a success modem connection is made with the far end modem the script completes and the email is sent to ticketing system. This inherieted perl code and the original author is no longer reachable. This is section that makes the connection to the dialer and then makes the call to the far end modem. It seems that if it hits the timeout value in the if eval statement it does not proceed.

    if ( $intcount>0 && $circid[0] ne "Not Defined" && $modemnumber ne "No +t Defined" && $modemdown eq "0") { #Create the connection to the NAS $session = Net::Telnet::Cisco->new(Host => $nashost, Port => $nasp +ort, Input_log => $logfile, Dump_Log => $dumpfile); # Login to the NAS and dial the OOB modem $session->waitfor('/Username:.*$/'); $session->print($nasuser); $session->waitfor('/Password:.*$/'); $session->print($naspass); $session->waitfor('/^$/'); $session->print("ATZ"); dial: if ($session->waitfor('/OK$/')) { $session->print("ATDT 91".$modemnumber); # Check for a connected status if (eval { $session->Net::Telnet::waitfor(Match => '/Username: +.*$/', Timeout => '60', Errmode => 'die'); 1 }) { if ($session->login(Name => $nasuser, Password => $naspass +)) { @command1 = "Interface Commands Output"; my $i = 0; while ($ifname[$i]) { push(@command1,("\n\n$caption>sh int $ifname[$i]\n +")); push(@command1,$session->cmd("sh int $ifname[$i]") +); $i++; } @command2 = "Routing Commands Output"; if ($wan eq "PIP") { push(@command2,("\n\n$caption>sh ip route\n")); push(@command2,$session->cmd("sh ip route")); push(@command2,("\n\n$caption>sh bgp summary\n")); push(@command2,$session->cmd("sh bgp summary")); push(@command2,("\n\n$caption>sh bgp\n")); push(@command2,$session->cmd("sh bgp")); } else { push(@command2,("\n\n$caption>sh ip route\n")); push(@command2,$session->cmd("sh ip route")); push(@command2,("\n\n$caption>sh ip ospf\n")); push(@command2,$session->cmd("sh ip ospf")); push(@command2,("\n\n$caption>sh ip ospf neigh\n") +); push(@command2,$session->cmd("sh ip ospf neigh")); } $session->close; $dialfailed = 0; } } } }

    I can include more of the script if helpful, I just did not want to assume and paste the entire script (about 350 lines). Thanks in advance.

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

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

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

    How do I use this? | Other CB clients
    Other Users?
    Others chilling in the Monastery: (3)
    As of 2020-04-08 05:35 GMT
    Find Nodes?
      Voting Booth?
      The most amusing oxymoron is:

      Results (43 votes). Check out past polls.