Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid

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
Working around limit to number of connections with Net::OpenSSH
3 direct replies — Read more / Contribute
by nysus
on Mar 27, 2017 at 15:47

    I have the following method:

    sub get_file { my $self = shift; my $file_path = shift; my $file = RemoteFile->new({ path => $file_path, ssh => $self->ssh } ); my $content = $file->read_and_delete; # attempt to destroy the object $file = ''; return $content; }

    The RemoteFile object relies on Net::OpenSSH to make the needed connection to download a file through a wrapper role I've written, MyOpenSSH:

    package RemoteFile; use Carp; use Moose; use Modern::Perl; use File::Basename; use File::Slurper qw(read_text write_text); use Params::Validate; with 'MyOpenSSH', 'MyLogger2', 'DownloadDir'; use namespace::autoclean;

    The get_file function is called repeatedly. However, about the 250th time the function is called, the program crashes, I'm guessing because some limit is hit on the number of SSH connection needed by the RemoteFile objects. Increasing the MaxSessions on sshd didn't help. So I tried to resolve this problem by setting the $file scalar to an empty string to try to destroy the object and hopefully its associated Net::OpenSSH object but that didn't work either. I'm not sure what else I can try to resolve this.

    $PM = "Perl Monk's";
    $MCF = "Most Clueless Friar Abbot Bishop Pontiff Deacon Curate";
    $nysus = $PM . ' ' . $MCF;
    Click here if you love Perl Monks

Hash vs constant vs package vs other for data structure
6 direct replies — Read more / Contribute
by oldtechaa
on Mar 27, 2017 at 14:38

    I'm using an AoAoA currently for a data structure. An example of its use would be like this: $notes[$x][$y][0] = ... As you can see, the first two dimensions refer to the location of an object and the third refers to properties of that object such as flags and other data. My problem is that although the indices always refer to the same data member, it's not very readable or maintainable if you forget the index number for the data you want.

    A couple solutions I've thought of are below:

    • Use an AoAoH instead, and refer to each data member by name
    • Use constant declarations to name each index
    • Use upper-case variables to show their status as constant names for indices
    • Use a package with setter and getter functions or public data members and use an AoA with the package objects as the contents
    • Get other ideas from PM

    What do you think? I don't want to use any external CPAN distributions and I'd like the solution to not require too much boilerplate. Thanks for your time.

Filtering rows with Parse::CSV
3 direct replies — Read more / Contribute
by Anonymous Monk
on Mar 27, 2017 at 14:02
    Hello, and thanks in advance for your help.

    I'm attempting to get all rows from a CSV file where a specific column is not null. Unfortunately, I'm only getting 1 row back.

    For example, I'd like only rows 5, 7, and 9 to be printed.

    row 1-4 : myColumn is null
    row 5 : myColumn = 'ABC'
    row 6 : myColumn is null
    row 7 : myColumn = 'CDE'
    row 8 : myColumn is null
    row 9 : myColumn is 'EFG'

    My expected results are:

    Instead, my results are:

    Here's the code I am using:

    my $parser = Parse::CSV->new( file => $CSV_File, sep_char => ',', names => 1, filter => sub { $_->{myColumn} ? $_ : undef } ); while ( my $row = $parser->fetch ) { my $myColumn_value = $row->{'myColumn'}; print ("$myColumn_value"); }
Convert string to hash
2 direct replies — Read more / Contribute
by gabrielsousa
on Mar 27, 2017 at 13:18
    i have this code
    foreach my $value (values $jsonhash{results} ) { print Dumper $value; }
    the output
    $VAR1 = { 'subnet_id' => undef, 'sp_name' => undef, 'image_name' => undef, 'ptable_name' => undef, 'global_status_label' => 'OK', 'uuid' => undef, 'model_name' => 'VMware Virtual Platform', 'provision_method' => 'build', 'configuration_status' => 0, 'operatingsystem_id' => 12, 'capabilities' => [ 'build' ], 'id' => 265, 'mac' => '00:50:56:91:c2:c1', 'enabled' => bless( do{\(my $o = 1)}, 'JSON::backportPP::Boo +lean' ), 'image_file' => '', 'environment_name' => 'production', 'use_image' => undef, 'name' => '', 'sp_mac' => undef, 'architecture_id' => 1, 'operatingsystem_name' => 'RedHat 7.2', 'medium_name' => undef, 'configuration_status_label' => 'No changes', 'updated_at' => '2017-03-27 17:14:42 UTC', 'compute_resource_id' => undef, 'installed_at' => undef, 'puppet_ca_proxy_id' => 1, 'realm_id' => undef, 'disk' => undef, 'ip' => '', 'model_id' => 1, 'owner_type' => 'User', 'subnet_name' => undef, 'certname' => '', 'hostgroup_id' => 45, 'created_at' => '2016-11-21 15:54:36 UTC', 'compute_profile_id' => undef, 'compute_resource_name' => undef, 'environment_id' => 1, 'global_status' => 0, 'image_id' => undef, 'domain_id' => 1, 'ptable_id' => undef, 'last_report' => '2017-03-27 17:14:29 UTC', 'sp_ip' => undef, 'architecture_name' => 'x86_64', 'sp_subnet_id' => undef, 'puppet_status' => 0, 'build' => bless( do{\(my $o = 0)}, 'JSON::backportPP::Boole +an' ), 'managed' => $VAR1->{'build'}, 'domain_name' => '', 'medium_id' => undef, 'comment' => '', 'last_compile' => '2017-03-27 17:14:36 UTC', 'hostgroup_name' => 'base/barman', 'compute_profile_name' => undef, 'owner_id' => 8, 'puppet_proxy_id' => 1, 'realm_name' => undef };
    how i convert the $value to an hash ?
AnyEvent:WebSocket produces 'No such device or address' error
2 direct replies — Read more / Contribute
by meep
on Mar 27, 2017 at 10:48

    First time poster. Learning Perl and have made good progress but I'm stumped by a problem I've encountered when attempting to implement WebSockets....

    I have a WebSocket server application built in Node-Red sitting behind an Apache reverse-proxy configuration. (The server is very simple, responding only to 'Ping' commands with an 'OK' response.)

    Using the 'Simple Websocket Client' extension for Google Chrome, I can successfully open the server URL, send the 'Ping' request and receive the 'OK' response, so I know that the server setup works.

    However, attempting to implement the same in PERL via AnyEvent:Socket, I consistently receive a 'No such device or address' error.p>

    The relevant section of my PERL code looks like this;

    sub sockInit{ use AnyEvent::WebSocket::Client 0.12; use URI my $client = AnyEvent::WebSocket::Client->new( ); my $uri = URI->new('ws://'); $client->connect($uri)->cb(sub { our $connection = eval { shift->recv }; if($@) { # handle error... myDebug($@); return; } # send a message through the websocket... # $connection->send('ping'); }); }

    Ultimately, this fails in this section of AnyEvent/WebSocket/ (around line 90);

    #AnyEvent::Socket::tcp_connect $uri->host, $uri->port, sub { AnyEvent::Socket::tcp_connect $uri->as_string, 80, sub { my $fh = shift; unless($fh) { $done->croak("unable to connect to ".$uri->as_string." $!"); return; }

    (I've made some small edits there to get around issues with $uri->host and $uri->port not existing for URI::_generic which is what ws protocol comes through as. I've also extened the croak message to include the uri)

    Here's what it typically generates;

    unable to connect to ws:// No such device or addr +ess at /usr/share/squeezeboxserver/Plugins/Alexa/ line 201 +.

    (This code runs inside a plugin I'm writing for the Logitech SqueezeServer platform)

    The relevant part of my Apache hosts config includes these libes in <VirtualHost *.80>

    ProxyPass /ws ws:// ProxyPassReverse /ws ws://

    As noted, I know this to be working. Ultimately, I need this to work with user authentication in Apache against a DB and with WSS: but I've simplified extensively here to see if I can track down why my Perl implementation might be failing but it works fine in other clients.

    I've learned a lot from this site so far, hopefully someone can help me out with my first problem for which my Google Fu cannot product an answer.

How to connect multiple databases with single sub routine connection using perl?
4 direct replies — Read more / Contribute
by finddata
on Mar 27, 2017 at 07:05
    my %site_map = ( Bang => [ qw(rate_bang_current) ], Nor => [ qw(rate_nor_current) ], Wilming => [ qw(rate_wilming_current) ], Lime => [ qw(rate_lime_current) ], ); sub connect { $host = ""; $database = "rate_bang_current" ; $user = "senthom" ; $pw = "ask123"; my $dsn = "DBI:mysql:host=$host"; my $dbh = DBI->connect($dsn, $user, $pw) || die "ERROR: can't connect to database server\n"; return $dbh; $host = ""; $database = "rate_nor_current" ; $user = "senthom" ; $pw = "ask123"; my $dsn = "DBI:mysql:host=$host"; my $dbh = DBI->connect($dsn, $user, $pw) || die "ERROR: can't connect to database server\n"; return $dbh; $host = ""; $database = "rate_wilming_current" ; $user = "senthom" ; $pw = "ask123"; my $dsn = "DBI:mysql:host=$host"; my $dbh = DBI->connect($dsn, $user, $pw) || die "ERROR: can't connect to database server\n"; return $dbh; $host = ""; $database = "rate_lime_current" ; $user = "senthom" ; $pw = "ask123"; my $dsn = "DBI:mysql:host=$host"; my $dbh = DBI->connect($dsn, $user, $pw) || die "ERROR: can't connect to database server\n"; return $dbh; }
    In the above sub routine i had tried to connect mapped database inside the subroutine.But i hardcoded manually each database.Now those databases are not fetching the contents properly because it is displaying only the rate_bang_current database contents for all other four DATABASES.How can i automatically select the database using perl without hard coding the database names and connection manually.
Memory has been increasing, unable to release memory.
2 direct replies — Read more / Contribute
by Perl_Love
on Mar 27, 2017 at 05:28

    I wrote a few programs, do not know why the memory has been increased from 20M has been added to xxG.

    The number of processes to keep about 100.

    Please help me, thank you!

    My environment:


    Perl 5.20.3

    #!/usr/bin/perl -w # $SIG{INT}=\&INT_EXIT; use IO::Socket::SSL; use Mojo::Asset; use Mojo::Asset::File; use Mojo::Asset::Memory; use Mojo::Base; use Mojo::Content; use Mojo::Content::MultiPart; use Mojo::Content::Single; use Mojo::Cookie; use Mojo::Cookie::Request; use Mojo::EventEmitter; use Mojo::Exception; use Mojo::IOLoop; use Mojo::IOLoop::Client; use Mojo::IOLoop::Delay; use Mojo::IOLoop::Server; use Mojo::IOLoop::Stream; use Mojo::JSON; use Mojo::Loader; use Mojo::Message; use Mojo::Parameters; use Mojo::Path; use Mojo::Reactor; use Mojo::Reactor::Poll; use Mojo::Server; use Mojo::Server::Daemon; use Mojo::Transaction; use Mojo::Transaction::HTTP; use Mojo::Transaction::WebSocket; use Mojo::URL; use Mojo::UserAgent; use Mojo::UserAgent::CookieJar; use Mojo::UserAgent::Proxy; use Mojo::UserAgent::Server; use Mojo::UserAgent::Transactor; use Mojo::Util; use Mojo::WebSocket; use File::Find; use Parallel::ForkManager; $|=1; my %ID; my $dir='/home/root/Perl/zhubo/AccountID'; my $fork; my %Header; my $ua; &Config; &Header; &Mojo_UA; my $pm=new Parallel::ForkManager($fork); sub Config{ open(F,"conf.json") or die; my @conf=<F>; close F; chomp @conf; my $json=join('',@conf); $json_conf=Mojo::JSON::decode_json($json); $fork=$json_conf->{'fork'}; } sub Header{ my @header=<headers/*>; foreach my $H(@header){ next unless($H=~m/\.header$/); my $hn; $hn=$1 if($H=~m/.*\/(.*?)\.header$/); open(H,$H) or die; while(my $h=<H>){ chomp $h; my @H=split('=>',$h); $Header{$hn}{'header'}{$H[0]}=$H[1]; } close H; } } sub Mojo_UA{ $ua=Mojo::UserAgent->new; $ua=$ua->connect_timeout($json_conf->{'connect_timeout'}); $ua=$ua->inactivity_timeout($json_conf->{'inactivity_timeout'}); $ua=$ua->max_redirects($json_conf->{'max_redirects'}); } while(1){ File::Find::find(\&wanted,$dir); } $pm->wait_all_children; sub wanted { if(-f $File::Find::name){ if($File::Find::name=~m/\.next$/){ if(exists $ID{$_}){ my $o=$File::Find::name; $o=~s/\.next$/.bak/; unlink($o); $o=~s/\.bak$//; unlink($o); delete $ID{$_}; } } if($File::Find::name=~m/\.bak$/){ my $gh=$_; my $e=$gh; $gh=~s/\.bak$//; my $f=$_; $f=~s/\.bak$//; unless(exists $ID{$f}){ my $fuck=&AccountID($f); if($fuck ne 'NULL'){ $ID{$f}=1; my $pid=$pm->start and next; system("/home/root/Perl/zhubo/ $f"); delete $ID{$f}; rename($e,$gh); $pm->finish; } undef $fuck; } } else{ my $r=$File::Find::name.'.bak'; rename($File::Find::name,$r); unless(exists $ID{$_}){ my $fuck=&AccountID($_); if($fuck ne 'NULL'){ $ID{$_}=1; my $pid=$pm->start and next; system("/home/root/Perl/zhubo/ $_"); my $e=$r; $e=~s/\.bak$//; delete $ID{$_}; rename($r,$e); $pm->finish; } undef $fuck; } } } } sub AccountID{ my $accountId=shift; my $url=''.$acco +untId; my $res; while(1){ my $eval=eval{ $res=$ua->get($url=>{%{$Header{'item_list'}{'header'}}})->result +; }; last if($eval); } if($res->is_success){ my $body=$res->body; if($body=~m/var liveDetail \= (.*?) \|\| \{\}\;/s){ my $liveDetail=$1; unless($liveDetail=~m/\}$/){ undef $res; undef $body; undef $liveDetail; return 'NULL'; } my $json_hash=Mojo::JSON::decode_json($liveDetail); if(exists $json_hash->{'liveId'}){ if($json_hash->{'liveId'} ne '0'){ my $liveId=$json_hash->{'liveId'}; undef $json_hash; undef $res; undef $body; undef $liveDetail; return $liveId; } else{ undef $json_hash; undef $res; undef $body; undef $liveDetail; return 'NULL'; } } else{ undef $json_hash; undef $res; undef $body; undef $liveDetail; return 'NULL'; } } else{ &AccountID($accountId); } } else{ &AccountID($accountId); } } sub INT_EXIT{ exit; }
Redistributable Apache Web Server with Strawberry Perl - Practical?
3 direct replies — Read more / Contribute
by whiteperl051
on Mar 27, 2017 at 05:03
    I'm looking into creating a Windows Desktop App/server with Apache for Windows and Strawberry Perl.

    The way it would work is that I redistribute Apache with Strawberry Perl with my Perl scripts which are the app. When installing my App on a Windows PC it acts like a web server serving up web pages. My app will be working like a web site. I'm planning on creating a media server. Users install it on their PC's and media is served through a web browser to their PC's or other devices.

    If I understand the Apache license correctly then I can redistribute Apache in this manner? My application will be free.

    I've tried other solutions like Mojolicious but Apache + Strawberry Perl seems to be the most stable and practical solution. Can anybody see any major issues in going this route? (Apache + Strawberry Perl) I would hate to put in many hours on this just to find it is not practical.

Howto convert Image::Grab jpg object to Image::Magick object???
2 direct replies — Read more / Contribute
by dazz
on Mar 27, 2017 at 04:24

    I have grabbed a jpg image from an IP camera with Image::Grab. So I have a valid image object.

    I want to pass the image to a subroutine. Within the subroutine, I want to use an Image::Magick method to do a read test on the image. </p)

    Back in the main code, I want to use the grabbed image object and annotate/composite using Image::Magick methods.

    So how do I pass a Image::Grab object to a sub-routine, then apply a read-only Image::Magick method to it? How do I take a Image::Grab object and apply a write Image::Magick method to it?

    The questions are similar but different. At present, I am achieving this by saving the Image::Grab jpg to hard drive, then reading it into a Image::Magick object. It is slow and inefficient.


Read the directories from file
4 direct replies — Read more / Contribute
by finddata
on Mar 27, 2017 at 03:10
    inputfile: base { LOCATION:../set/projects/all/files }
    My code: my $fn="inputfile"; open ( my $fh, '<', $fn ) or die "Could not open file '$fn': $!"; while ( <$fh> ) { chomp; if (/^LOCATION:\s*(\S+)/) { $input_dir = $1; print $input_dir; } My output is as follows: ../set/projects/all/files expected one: /set/projects/all/files
    In the above code the location line has directory location.These directory location starts with .. How can i remove the .. from the directory line and read only the location of the directory

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 all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others wandering the Monastery: (8)
    As of 2017-03-28 14:46 GMT
    Find Nodes?
      Voting Booth?
      Should Pluto Get Its Planethood Back?

      Results (333 votes). Check out past polls.