http://www.perlmonks.org?node_id=479

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.

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.

Post a new question!

User Questions
Any security holes?
4 direct replies — Read more / Contribute
by Limbomusic
on Jun 26, 2022 at 09:49
    I have a simple html form which uses POST to append text to a html-file and I was wondering if there are any security concerns in my .pl file? My .pl-file:
    #!C:\Perl64\site\bin\perl.exe use CGI; my $cgi = CGI->new(); # create new CGI object # Split information into name/value pairs @pairs = split(/&/, $buffer); foreach $pair (@pairs) { ($name, $value) = split(/=/, $pair); $value =~ tr/+/ /; $value =~ s/%(..)/pack("C", hex($1))/eg; $FORM{$name} = $value; } my $nick = $cgi->param('nick'); my $pic = $cgi->param('pic'); my $say = $cgi->param('say'); my $likes = $cgi->param('likes'); my $fav = $cgi->param('fav'); my $car = $cgi->param('car'); my $age = $cgi->param('age'); my $town = $cgi->param('town'); my $drink = $cgi->param('drink'); my $wpage = $cgi->param('wpage'); open(my $fh, '>>', 'drivers.html'); print "Content-type:text/html\r\n\r\n"; print $fh "<b>$nick</b><br><img src='$pic' width='250' height='auto' b +order='2'><br><br>Says <b>$say</b><br>Likes <b>$likes</b><br>Favorite + vehicle <b>$fav</b><br> Real life car/vehicle <b>$car</b><br>Age <b> +$age</b><br>Hometown <b>$town</b><br>Favorite drink <b>$drink</b><br> +<b><a href='$wpage'>$wpage</a></b><HR color=#008000 SIZE=2>\n"; print "<html><head><meta http-equiv = 'refresh' content = '0; url = dr +ivers.html' /></head>"; close $fh;
    My webserver runs on windows 10 (with perl strawberry or something) - using hiawatha webserver. And I'm also wondering - when using POST - its possible to paste in whatever in the form - if someone was trying to hack or just mess things up - could that be done and how? And if so, are there any preventive measures I could take?
HTTP::Tiny losing headers for Stripe
3 direct replies — Read more / Contribute
by Bod
on Jun 25, 2022 at 16:32

    I'm trying to update a subscription in Stripe.

    This involves calling an API with an authorisation header using POST. If the payload is empty, the API returns a JSON object representing the existing subscription. If there is subscription data in the payload, Stripe attempts to update the subscription and returns the complete subscription object. Pretty straightforward and it all works fine. Until I need to read the existing subscription object and then update it.

    I have hit a problem and I can't think of how to debug it further!
    Here is the minimum code to demonstrate the problem:

    #!/usr/bin/perl -T use CGI::Carp qw(fatalsToBrowser); use FindBin qw($RealBin); my $safepath; BEGIN { if ($RealBin =~ m!^(/home/...path.../(test|uk)/www)!) { $safepath = "$1/../lib"; } else { die "Illegal use of software - visit www.way-finder.uk to use +this site"; } } use lib "$safepath"; use Site::Variables; use HTTP::Tiny; use JSON; use Data::Dumper; use strict; use warnings; my $http = HTTP::Tiny->new; my $headers = { 'headers' => { 'Authorization' => 'Bearer ' . $Site::Variables::stripe_secret +, }, 'agent' => 'Wayfinder/v3.0', }; my $sub_id = 'sub_xxxxxxxxxxx'; # This line is the culprit... my $res = $http->post_form("https://api.stripe.com/v1/subscriptions/$s +ub_id", {}, $headers); my $payload = decode_json($res->{'content'}); my $subscription = { 'items[0][id]' => 'x', 'items[0][price]' => 'some price', }; my $response = $http->post_form("https://api.stripe.com/v1/subscriptio +ns/$sub_id", $subscription, $headers); print "Content-type: text/plain\n\n"; print Dumper $response;
    With the code as it is, I get an error from Stripe that I have not supplied an API key. The key is in the $headers variable. If I take out the first call to Stripe, the one with the empty payload, then the second one succeeds * so the API key is working fine in this case. But as soon as I make two calls, it fails.

    Things I've tried but haven't helped:

    • Turning off taint mode
    • Creating two instances of HTTP::Tiny and making each call with a different instance
    • Creating a copy of $headers to use in the second call
    • Adding a 5 second delay between calls to Stripe
    Any ideas what I can try to solve this problem?

    It is as if HTTP::Tiny doesn't like making consecutive POSTs but I cannot find anything in the documentation about this.


    * - Without the first call, the second call to Stripe gives an error because I haven't got the parameters right. But it doesn't complain about there not not being an API key

Deferring variables
7 direct replies — Read more / Contribute
by Chuma
on Jun 25, 2022 at 09:27

    I have in my program a number of parameters that can be set by the user, which I store in a hash %par. Now the thing is, some of these parameters come in more and less specific versions.

    An example: We have a parameter "margin-left". In some cases, the user hasn't set a specific value for it; it then defers to the more general "margin-horizontal". If the user hasn't set a specific value for that, it in turn defers to the more general "margin".

    In my current program, those "unspecified" parameters are set to "a" (for "automatic"). So when the time comes to actually draw the left margin, the program does something like

    if($par{'margin-left'} ne 'a'){ $actual = $par{'margin-left'} }elsif($par{'margin-horizontal'} ne 'a'){ $actual = $par{'margin-horizontal'} } else{$actual = $par{'margin'}}

    As you can see, it's a bit of a bunch every time I just need to read the margin-left value. I could of course pack all that into a "get" sub, that would save on typing, but it still seems like a slow and clumsy method.

    There is a "set" sub, so in principle I could use that to track and update everything, checking whenever a parameter is set whether it has any parent / dependant parameters, but that's also quite a lot of code, and it's redundant for all the parameters that don't have any such behaviour.

    Is there a better way? Maybe something with referencing / aliasing? Ideally keeping all the inner working in the "set" sub, so I can just use $par{'margin-left'} and get the right thing.

inconsistent module access
1 direct reply — Read more / Contribute
by geoffleach
on Jun 24, 2022 at 17:46
    I have two modules which are structurally identical. At one point, they access IO::All::io. In one case, it goes without a hitch. In the other,
    DanBongino::_get(/home/geoff/Perl/newmod/DanBongino.pm:54): 54: my $data = io( $url )->slurp; DB<10> s Undefined subroutine &DanBongino::io called at /home/geoff/Perl/newmod +/DanBongino.pm line 54. at /home/geoff/Perl/newmod/DanBongino.pm line 54. DanBongino::_get("https://feeds.megaphone.fm/WWO3519750118/") call +ed at /home/geoff/Perl/newmod/DanBongino.pm line 71 DanBongino::Get() called at NewFetchPodcast.pl line 92 Getopt::Auto::CODE(0x55a5417cc5e0)(/usr/local/lib64/perl5/5.34/Getopt/ +Auto.pm:120):
    Fiddling around in the debuggger
    DanBongino::_get(/home/geoff/Perl/newmod/DanBongino.pm:54): 54: my $data = io( $url )->slurp; DB<12> io('foo') Undefined subroutine &DanBongino::io called at (eval 30)[/usr/share/pe +rl5/perl5db.pl:741] line 2. DB<13> IO::All::io('foo') Can't locate object method "_package" via package "foo" (perhaps you f +orgot to load "foo"?) at /usr/share/perl5/vendor_perl/IO/All.pm line +63.
    In both cases the modules are executed with this code in a given-when
    { require DanBongino; $shows = DanBongino::Get() };
    use IO::All; is present in both cases.

    Assistance most greatfully received.

Reconfiguration of classes in an "inheritable" manner
4 direct replies — Read more / Contribute
by Amblikai
on Jun 23, 2022 at 16:03

    Hi Monks! I'm looking for a bit of help, as someone who codes perl in isolation. Prefacing this with the fact i'm no programmer.

    I've somewhat organically arrived upon my own little OO framework which i use for most things. It has grown in complexity a bit over the years and i'm now wondering if i'm just re-inventing the wheel, especially since i'm starting to get confused by my own code!

    I can't use Moose or any of the more advanced frameworks, i'm stuck with pretty basic perl unfortunately

    Essentially i have a structure of classes which allows me to dictate the way attributes are handled when creating downstream objects. I can explicitly define which attributes are allowed, what are valid values, and the behaviour around unknown/undefined attributes (drop the attribute, give a warning, error out etc

    The way i'm doing this is starting to seem a bit messy, and i'm sure there's a better way. In the base class i maintain a configuration singleton. The singleton keeps a map of the derived class hierarchy, and when i set configuration options on a particular "level" of the hierarchy, it only affects from that point down, rather than reconfiguring the base class and hence the whole derived tree.

    I'm probably going to struggle to illustrate it but here's a pseudocode example:

    my::base # base class my::extended_trunk # extends base my::branch_A # extends "extended_trunk" my::branch_B # Also extends "extended_trunk" my::base->configure(options); # Options change in all Classe +s my::extended_trunk->configure(options); # Options only change in exten +ded_trunk and both branches my::branch_A->configure(options); # Options only change in branc +h_A

    In essence, i'm doing all this to replicate a sort of "inheritable class variable". Is that something thats natively possible?

    In other words, if my::extended_trunk has a class variable, can i change the value of it in my::branch_A, without it affecting the value in my::branch_B?

    As always, i appreciate any help or guidance! Thanks!

IO::Socket::SSL / Net::SSLeay inefficient in non-blocking mode ?
3 direct replies — Read more / Contribute
by Yaribz
on Jun 23, 2022 at 12:22
    Hello,

    I'm using the IO::Socket::SSL module in non-blocking mode and I noticed high CPU usages during data transfers (much higher than when using blocking mode, with similar speeds). After some investigations, I think this is due to a very high proportion of failed/empty sysreads due to SSL_WANT_READ.

    I have based my code on following links which explain the usage of SSL sockets in non-blocking mode and how to handle SSL_WANT_READ / SSL_WANT_WRITE:

    According to this documentation, it can happen that a read operation performed on a SSL socket returns nothing, even if the socket was flagged as "readable" by select just before. This happens when the data that were available in the socket buffer were just SSL transport layer data, not actual application data. And in this case, one just needs to select the socket again and retry the read operation. This makes perfect sense, and as I understand it these empty reads should only represent a small part of all the read operations performed on the SSL socket during large data transfers.

    However, in my case (when performing large transfers between two hosts on a 1 Gbps network), these "empty" reads due to SSL_WANT_READ represent about 80% of all the read operations performed on the socket, which likely explains the high CPU usage. So I guess I'm doing something wrong in my application...

    I managed to reproduce the problem with these two small scripts:

    Here is the server code, which runs in blocking mode and sends data continuously to any client connecting to it (only one client at a time). It works fine, with low CPU usage, and is only provided to help reproduce the problem when using non-blocking socket at client side:

    use warnings; use strict; use IO::Socket::SSL; use constant { BUFSIZE => 16384 }; die 'Invalid BUFSIZE value (must be a multiple of 16)' if(BUFSIZE%16); my $LOCAL_ADDR='0.0.0.0'; my $LOCAL_PORT=1234; my $BUFFER = '0123456789ABCDEF' x (BUFSIZE/16); my $srvSock; $srvSock=IO::Socket::SSL->new( LocalHost => $LOCAL_ADDR, LocalPort => $LOCAL_PORT, ReuseAddr => 1, Listen => 1, SSL_cert_file => 'cert.pem', SSL_key_file => 'key.pem', ) or die "Failed to create listening SSL socket: $!"; print "SSL server listening on $LOCAL_ADDR:$LOCAL_PORT\n"; while() { print "Waiting for client to connect...\n"; my $clientSock = $srvSock->accept() or die "Failed to accept SSL client connection: $!, $SSL_ERROR\n"; print "Client connected, sending data.\n"; while() { my $writeLength=syswrite($clientSock,$BUFFER) or do { print " Failed to write to client: $!, $SSL_ERROR\n"; last; }; if($writeLength != BUFSIZE) { print " Unexpected write length: $writeLength\n"; last; } } }

    And here is the client code, which runs in non-blocking mode and reports every second the transfer speed and the proportion of the read operations which "failed" due to SSL_WANT_READ and SSL_WANT_WRITE:

    use warnings; use strict; use IO::Socket::SSL; use Time::HiRes qw'time'; use constant { BUFSIZE => 16384, INTERVAL => 1, }; my $PEER_ADDR='192.168.1.10'; my $PEER_PORT=1234; print "Connecting to SSL server ($PEER_ADDR:$PEER_PORT)\n"; my $clientSock = IO::Socket::SSL->new( PeerHost => $PEER_ADDR, PeerPort => $PEER_PORT, Proto => 'tcp', SSL_verify_mode => SSL_VERIFY_NONE, ) or die "Failed to connect to SSL server: $!, $SSL_ERROR"; print "Connected, switching to non-blocking mode.\n"; $clientSock->blocking(0); my $sockVec=''; vec($sockVec,fileno($clientSock),1)=1; my ($nbRead,$nbSslWantRead,$nbSslWantWrite,$transferred)=(0,0,0,0); print "Downloading data from server...\n"; my $currentTime=time(); my ($intvlStart,$intvlEnd)=($currentTime,$currentTime+INTERVAL); while() { # There should be no pending data when BUFSIZE = max SSL frame size die 'Unexpected pending data in SSL socket' if($clientSock->pending()); $!=0; select(my $readyVec=$sockVec,undef,undef,undef) > 0 or die "Error in select for read: $!"; my $readLength=sysread($clientSock,my $readData,BUFSIZE); $nbRead++; if(defined $readLength) { die "Connection closed by peer" unless($readLength); die "Unexpected read length: $readLength" unless($readLength == BUFSIZE); }else{ die "Failed to read from SSL socket: $!" unless($!{EWOULDBLOCK} || $!{EAGAIN}); if($SSL_ERROR == SSL_WANT_READ) { $nbSslWantRead++; next; } if($SSL_ERROR == SSL_WANT_WRITE) { $nbSslWantWrite++; select(undef,my $readyVec=$sockVec,undef,undef) > 0 or die "Error in select for write: $!"; next; } die 'Unexpected WOULDBLOCK/EAGAIN status when trying to read'; } $transferred+=BUFSIZE; $currentTime=time(); if($currentTime >= $intvlEnd) { printReport(); initNewInterval(); } } sub printReport { my $speed=formatSize($transferred/($currentTime-$intvlStart)); my $pctSslWantRead=sprintf('%.2f',$nbSslWantRead*100/$nbRead); my $pctSslWantWrite=sprintf('%.2f',$nbSslWantWrite*100/$nbRead); print "Transfer speed: $speed/s\n"; print " Read failure due to SSL_WANT_READ: $pctSslWantRead%\n"; print " Read failure due to SSL_WANT_WRITE: $pctSslWantWrite%\n"; } sub formatSize { my $size=shift; my @UNITS=('',qw'K M G T'); my $unitIdx=0; while($size >= 1000 && $unitIdx < $#UNITS) { $size/=1000; $unitIdx++; } $size=sprintf('%.2f',$size) if(index($size,'.') != -1); return $size.' '.$UNITS[$unitIdx].'B'; } sub initNewInterval { ($nbRead,$nbSslWantRead,$nbSslWantWrite,$transferred)=(0,0,0,0); $intvlStart=$currentTime; $intvlEnd+=INTERVAL while($intvlEnd < $intvlStart+INTERVAL/2); }

    To use these scripts a SSL certificate must be placed in current server directory (files "cert.pem" and "key.pem"), and the $PEER_ADDR variable must be set to the server address in the client script. Default port is 1234 and can be changed by editing the $LOCAL_PORT / $PEER_PORT variables.

    Initially I tried to reproduce the problem by running both scripts (server and client) on same system, using localhost, but the problem doesn't appear in this case (the proportion of failed reads due to SSL_WANT_READ is 0.00%).

    Here are the results when I run the client and the server parts on distinct systems, for 10 seconds:

    $ perl sslclinb.pl Connecting to SSL server (192.168.1.10:1234) Connected, switching to non-blocking mode. Downloading data from server... Transfer speed: 117.55 MB/s Read failure due to SSL_WANT_READ: 87.46% Read failure due to SSL_WANT_WRITE: 0.00% Transfer speed: 117.61 MB/s Read failure due to SSL_WANT_READ: 90.84% Read failure due to SSL_WANT_WRITE: 0.00% Transfer speed: 117.61 MB/s Read failure due to SSL_WANT_READ: 90.84% Read failure due to SSL_WANT_WRITE: 0.00% Transfer speed: 117.61 MB/s Read failure due to SSL_WANT_READ: 90.88% Read failure due to SSL_WANT_WRITE: 0.00% Transfer speed: 117.61 MB/s Read failure due to SSL_WANT_READ: 90.50% Read failure due to SSL_WANT_WRITE: 0.00% Transfer speed: 117.61 MB/s Read failure due to SSL_WANT_READ: 82.52% Read failure due to SSL_WANT_WRITE: 0.00% Transfer speed: 117.61 MB/s Read failure due to SSL_WANT_READ: 82.63% Read failure due to SSL_WANT_WRITE: 0.00% Transfer speed: 117.61 MB/s Read failure due to SSL_WANT_READ: 82.58% Read failure due to SSL_WANT_WRITE: 0.00% Transfer speed: 117.61 MB/s Read failure due to SSL_WANT_READ: 82.58% Read failure due to SSL_WANT_WRITE: 0.00% Transfer speed: 117.61 MB/s Read failure due to SSL_WANT_READ: 82.57% Read failure due to SSL_WANT_WRITE: 0.00% ^C

    I get similar results on 2 different systems (i.e. when exchanging server and client), on Windows and Linux.
    I would be very interested to know if anyone reproduces the same behavior, and if anyone has an idea on what is going on?

    Thanks !

Perlsecret - plus no-ops
1 direct reply — Read more / Contribute
by Anonymous Monk
on Jun 23, 2022 at 11:29
    In perlsecret - perl secret operators, there's
    # remove empty array refs @arrays = ( [], [1], [ 1, 2 ], [], [ 5 .. 9 ] ); # @filled = ( [1], [ 1, 2 ], [ 5 .. 9 ] ); @filled = grep +()= @$_, @arrays;
    with a note of:
    (The + is in the above line is a no-op, used to tell grep that the parentheses are not enclosing its arguments.)
    what does that note actually mean?
Converting to sub signatures
2 direct replies — Read more / Contribute
by cavac
on Jun 23, 2022 at 08:58

    In 5.36 sub signatures are finally standard, so i started converting some of my code to use them. A lot of code, actually. So i've written a script that helps me with the conversion process.

    It's quite tied to my own coding style and it won't spare you the work of handling optional arguments. And you need to test your software after the conversion. A lot. But it still saves a lot of manual editing.

    Posting this mostly to ask on how you would have done this differently or how it could be improved. Don't spare the criticism (i can take it), i know this is substandard code done in a hurry.

    Code in readmore tags, because of length.

    PerlMonks XP is useless? Not anymore: XPD - Do more with your PerlMonks XP
'perl Makefile.PL' warning for v5.20 to v5.24
1 direct reply — Read more / Contribute
by kcott
on Jun 23, 2022 at 08:31

    G'day All,

    I encountered a warning when running 'perl Makefile.PL' on Perl versions between 5.20 and 5.24 inclusive. Versions 5.16, 5.18 and all stable versions from 5.26 to 5.36 did not have this problem.

    WARNING: ABSTRACT contains control character(s), they will be removed

    I identified the problem as being DOS-style line endings (i.e. CRNL) in the *.pm file. When I converted these to Unix-style line endings (i.e. just NL) the warnings stopped.

    $ perl -pi -e 's/\r$//' path_to_pm_file

    I checked perl5200delta and "ExtUtils::MakeMaker for v5.20.0" for any documentation regarding the introduction of this warning: none found.

    So, my questions:

    • Have others encountered the same warning message?
    • Does anyone have any links to information regarding this warning?
    • The warning seems to be completely harmless. Is it?
    • Are there better ways to handle this (e.g. perhaps some flag in Makefile.PL) beyond converting the line endings of the *.pm file?

    For anyone wondering why I'm testing with so many versions, see "Perl images for GitLab CI" for some background information.

    — Ken

Net::OpenSSH fails with CyberArk
2 direct replies — Read more / Contribute
by jhuijsing
on Jun 22, 2022 at 20:12
    Has anyone successfully used use Net::OpenSSH with CyberArk to ssh into cyberark the format of the command line is ark_user@rem_user@remote-host@cyberark-jump-host I am passing the ark_user and password in %opts
    my $ssh = Net::OpenSSH->new( $node, %opts, master_opts => [ -o => "StrictHostKeyChecking=no" ] );
    Net::OpenSSH barfs Invalid or bad combination of options ('user') at ./ark-config.pl line 138. Running it through the debugger I can see its failing in the parse_connection_opts

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