Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery

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
A question of fork efficiency
4 direct replies — Read more / Contribute
by synless
on Aug 05, 2019 at 13:06

    I've been modernizing an old tool used to run commands on multiple servers at once. We have a port check function that forks on an array of servers to perform a port check and then returns passed and failed nodes. I'm not sure if the way the functions are written are the most efficient way to perform this task and am seeking advice from all of you. The while statement used also adds an empty key and value to the results hash. Also please assume I have no access to install anything from CPAN.

    my $SELECT = IO::Select->new(); my $forks = 100; sub portcheck { my ( $checknodes, $port, $forks, $longest, $verbose ) = @_; # Hashes to store results and good/bad arrays my ( %threads, %results, $pid, $node ); my ( @goodnodes, @badnodes ); # Set default port to 22 if ( !$port ) { $port = '22'; } # Destroyable copy of the list of nodes. my @checks = @{$checknodes}; # Set forks properly if ( !$forks ) { $forks = $fanout; } $forks = ( $forks > scalar @checks ) ? scalar @checks : $forks; # Fork initial threads for ( 1 .. $forks ) { forkportcheck( shift @checks, \%threads, $po +rt ); } # Prepare to display results in order my $resindex = 0; # Wait for a process to complete while ( ( $pid = wait ) > 0 ) { # store result of the port check $results{ $threads{$pid} } = ( $CHILD_ERROR == 0 ); # delete the completed thread delete $threads{$pid}; # Fork a new thread if there are still nodes to run if ( scalar @checks ) { forkportcheck( shift @checks, \%threads, $port ); } no warnings 'uninitialized'; #store and print the results for completed threads while ( defined $results{ $checknodes->[$resindex] } ) { $node = $checknodes->[ $resindex++ ]; if ( $results{$node} ) { push @goodnodes, $node; if ($verbose) { printf {*STDERR} "%-${longest}s: ssh port check pa +ssed\n", $node; } } else { push @badnodes, $node; if ($verbose) { printf {*STDERR} "%-${longest}s: ssh port check fa +iled\n", $node; } } } } if ($verbose) { say {*STDERR} q{}; } return ( \@goodnodes, \@badnodes ); } sub forkportcheck { my ( $node, $threads, $port ) = @_; # Ensure node is defined if ( !$node ) { return 0; } # Fork the process -- we just need the return code. my $pid = fork; if ( !defined $pid ) { croak "Fork didn't work $ERRNO"; } # is this the child if ( $pid == 0 ) { # Perform socket connection my $sock = IO::Socket::INET->new( PeerAddr => $node, Timeout => 1, PeerPort => $port, Proto => 'tcp', ); # Exit 0 if get a socket. Else exit 1 if ($sock) { close $sock or carp $ERRNO; exit 0; } exit 1; } # store the node name for the pid in the threads $threads->{$pid} = $node; return $pid; }
What is a good, straightforward Perl with Mysql development environment?
6 direct replies — Read more / Contribute
by jfrm
on Aug 05, 2019 at 12:46

    My situation is unusual. I started a company around 15 or so years ago and it's grown now so there are 4 employees, probably soon more. The website, order system, stock tracking system, product database and a heck of a lot more was and continues to be all written by me in Perl - quite badly in places. This collection of scripts is more than central to the company - it runs everything.

    This is not sustainable so I'm hoping to hire a Perl developer to assist me with bug fixing and new development work (email me if you're interested, btw...!). The job can probably be done remotely but regardless I will need to set up a suitable development environment. I'm ashamed to say that I work directly on our local system (although never the live website), sometimes while people are using it. I do appreciate that this is extremely bad and I must be chastised strongly for being very naughty. Still, it works for me.

    But it won't work for someone else - so I need to set up a suitable development environment for a proper developer to code, test and then when ready move it to the live environment. And I have absolutely no experience of this; I've just learned Perl on the fly as I needed to. So that's my problem - what does a good (but simple and straightforward) development environment consist of that will keep a Perl developer in good spirits?

    The environment is Windows with MySQL 5.15 and Apache 2 with ActiveState Perl 5.16. I use a variety of libraries but a lot is done in Rose::DB. Currently I just code in Komodo Editor and search using a file scanner to find what I need. There is no development studio or anything. I presume the developer will need a development server to play with on top of the machine that he/she uses and then we would need a way of migrating new code to the local live server. But beyond that hazy conjecture, I really haven't got a clue where to start. Is source control a requirement? Can I use Visual Studio? How do I keep the development MySQL schema in synch with the live one?

    So, having bared my soul - is there any monk who can advise how I can ascend from the dark side to the light and repair the sad situation that I have created? Any tips would be much appreciated...

Script using Tk and LibXML crashing
1 direct reply — Read more / Contribute
by misczol
on Aug 05, 2019 at 12:37

    Hello Perl Monks, I'm trying to load a 290MB XML file using Tk and LibXML. I'm on Windows 7 64bit with 8GB of RAM using strawberry 'perl 5, version 30, subversion 0 (v5.30.0) built for MSWin32-x64-multi-thread'

    This is the stripped down version of the script that's been crashing:

    use strict; use XML::LibXML; use Tk; my $filename; my $xpc; my $mw = MainWindow->new( -title => 'GUI' ); $mw->Button( -text => 'Load XML', -command => \&tk_Load_Export )->grid +(-column => '0', -row => '0', -sticky => 'e'); MainLoop; sub tk_Load_Export { $filename = $mw->getOpenFile( -title => 'Load XML', -defaultextensio +n => '.xml', -initialdir => '.' ) or return; import_XML($filename); } sub import_XML { print "Reading the XML file $filename\n\n"; my $dom = XML::LibXML->load_xml(location => $filename, huge => 1); $xpc = XML::LibXML::XPathContext->new($dom); print "XML imported\n"; }

    After I get 'XML imported' output the script crashes with these 'Perl interpreter stopped working' Windows messages

    Problem signature: Problem Event Name: APPCRASH Application Name: perl.exe Application Version: Application Timestamp: 5ce675b5 Fault Module Name: Tk.xs.dll Fault Module Version: Fault Module Timestamp: 5d48325f Exception Code: c0000005 Exception Offset: 000000000006b197 OS Version: 6.1.7601. Locale ID: 1033 Additional Information 1: 0922 Additional Information 2: 09222532a50de2713b0e459db9ce5206 Additional Information 3: 1a6d Additional Information 4: 1a6d675851be0305a03f72c1d1fc7bfd -- Problem signature: Problem Event Name: APPCRASH Application Name: perl.exe Application Version: Application Timestamp: 5ce675b5 Fault Module Name: Tk.xs.dll Fault Module Version: Fault Module Timestamp: 5d48325f Exception Code: c000041d Exception Offset: 000000000006b197 OS Version: 6.1.7601. Locale ID: 1033 Additional Information 1: 0561 Additional Information 2: 056116c4c04c02ca22cbeb428d55467a Additional Information 3: dab2 Additional Information 4: dab22cdd161f9720b851e7ce36d909c8

    Sometimes but not always I also get this message after 'XML imported' output:

    Free to wrong pool 46af30 not 645b4f4a at C:/Strawberry/perl/site/lib/ line 424.

    Is this because of the file size? The script doesn't crash on smaller XML files (~200MB).

    Can someone help me understand why this is happening and how do I mitigate this?

HTML::TreeBuilder::XPath finding attribute values
2 direct replies — Read more / Contribute
by mldvx4
on Aug 05, 2019 at 12:35

    I'm trying to extract the values of specific attributes from various HTML elements using XPaths and HTML::TreeBuilder::XPath. Say I have an anchor, <a href="foobar.html">One Link</a>, and I would like to extract the value of the attribute "href" from it. That would be "foobar.html". Or if I have meta data, <meta name="description" content="foobar" />, then I would like to find the value of the attribute "content", which is "foobar", and where the attribute "name" has the value "description". I think I have the right XPath, as it works in other tools, but instead of giving me the value of the attribute "content" it gives me this error:

    Can't locate object method "as_text" via package "HTML::TreeBuilder::XPath::Attribute" at ./ line 15.

    What have I missed in the code below and how to tweak it?

    #!/usr/bin/perl use HTML::TreeBuilder::XPath; use strict; use warnings; my $root = HTML::TreeBuilder::XPath->new; $root->parse_file(\*DATA); $root->eof(); for my $d ($root->findnodes('//html/head/meta[@name="description"]/@co +ntent')) { print qq(D=\n); print $d->as_text; } $root->delete; exit(0); __DATA__ <html> <head> <meta name="description" content="foobar" /> </head> <body> <h1>FOO</h1> <p>Bar</p> </body> </html>
matching first paragraph satisfying condition
2 direct replies — Read more / Contribute
by mnshptl32
on Aug 05, 2019 at 12:14

    Greetings! I just registered here and hope this is an appropriate venue for my question.

    I'm new to perl and am trying to write a perl one-liner that returns everything from the first non-indented line of a file up until the end of that paragraph, terminated by a blank line. I can do this using awk with the command:

    awk -v RS='' -v ORS='\n\n' '/^[^ ].*$/' file.txt | awk -v RS='' 'NR==1 +{print $0}'
    My problem translating this to perl is that the first non-indented line of the file may or may not be the first line of the file. In the former case, this works:
    perl -0pe 's/.*?\n*?([^ \n].*?)\n\n.*/$1/gs' file.txt
    as does this:
    perl -0pe 's/([^ \n].*?)\n\n.*/$1/gs' file.txt
    In the latter case, this works:
    perl -0pe 's/.*?\n([^ \n].*?)\n\n.*/$1/gs' file.txt
    But is there a simple perl one-liner that works in both cases? I've tried writing a semicolon-separated perl command intended to prepend a blank line to the file before the search in the event that the first line is not indented, using something like
    if ( $. == 1 and /^[^ ].*$/ ) {...}
    but I can't get the syntax right. Obviously I could string together a sequence of commands like
    echo '' > tempfile.txt ; cat file.txt >> tempfile.txt ; perl ...
    or use some bash conditional like
    if [[ $(egrep -n -m1 -e '^[^ ]' file.txt | sed 's/^\([0-9]\+\):.*/\1/g +') -eq 1 ]] ; then perl ... ; else perl ... ; fi
    however, I'd like to know if there's some more elegant "pure perl" solution I'm overlooking.

    Best regards,


A bizarre way to get a list of filenames
7 direct replies — Read more / Contribute
by kiz
on Aug 05, 2019 at 10:52

    So a colleague asked to to help with a wee perl problem, and his code has the following line:

    my @xml_files = <*.xml>

    He says it gives him a list of XML files .... say what?

    Can someone explain this to me? This is a whole new use of the diamond operator I've not come across before!

    (His question was "how do I add text files to this list?"... answer: make 2 lists & join them.. )

    -- Ian Stuart
    A man depriving some poor village, somewhere, of a first-class idiot.
File Upload Size Check
1 direct reply — Read more / Contribute
by coolsaurabh
on Aug 05, 2019 at 08:00

    Hello all, I am facing strange issue in cgi script. Requirement is to upload the file and to print log message in case file size is more than 5 MB. Script is throwing error in case file size is bigger than 5 MB. However it is working fine case if the file size is less than 5 MB. Any suggestions.Pls advice.

    #!/usr/bin/perl use CGI qw(:standard); use CGI::Carp qw( fatalsToBrowser ); use File::Basename; use Net::OpenSSH; use Net::SSH::Expect; use Data::Dumper; use Exporter qw(import); our @EXPORT = qw(copyToTarget); sub print_page() { print ("Content-type: text/html\n\n"); print <<__HTML__; <form name=f1 style="margin:20px 0" action="Maintenance_Framew +ork.cgi" method="post" enctype="multipart/form-data"> <p> <h3 align='center'> Maintenance File Upload </h3> <br> <p style="margin-left:16.5em;font-size:20px">Customer:<select +name="Customer" > <option value="Telenor_PK">Telenor_PK</option> <option value="Vodacom_TZ">Vodacom_TZ</option> </select> &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&n +bsp;&nbsp;&nbsp;&nbsp; Technology : <select name="Techno" > <option value="Core">Core</option> <option value="RAN">RAN</option> </select> </p> <br> <p>File to Upload: <input type="file" name="filecsv" /></p> <p><input type="submit" name="Submit" value="Upload"></p>&nbsp +&nbsp&nbsp </body> </html> </form> __HTML__ } sub main() { $CGI::POST_MAX = 1024 *1024 ; my $safe_filename_characters = "a-zA-Z0-9_.-"; my $upload_dir = "/opt/IBM/Maintenance/tmp"; my $query = new CGI; print_page(); my $filename = $query->param("filecsv"); my $ctext = $query->param("Customer"); my $ttechno = $query->param("Techno"); my $content_length = $ENV{'CONTENT_LENGTH'}; if ( !$filename ) { print<<END_HTML2; <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//E +N" "DTD/xhtml1-strict.dtd"> <html xmlns="" xml:lang="e +n" lang="en"> <head> <meta http-equiv="Content-Type" content="text/html; ch +arset=utf-8" /> <title>Thanks!</title> <style type="text/css"> img {border: none;} </style> </head> <body> <p>File is too big for upload! $content_length</p> </body> </html> END_HTML2 exit; } else { print<<END_HTML3; <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//E +N" "DTD/xhtml1-strict.dtd"> <html xmlns="" xml:lang="e +n" lang="en"> <head> <meta http-equiv="Content-Type" content="text/html; ch +arset=utf-8" /> <title>Thanks!</title> <style type="text/css"> img {border: none;} </style> </head> <body> <p>File is in relevant size to upload! $content_length +</p> </body> </html> END_HTML3 } }
How get PV address?
1 direct reply — Read more / Contribute
by xiaoyafeng
on Aug 05, 2019 at 05:39

    Hi Monks

    Is there a way to get PV address like Devel::Peek do?

    use Devel::Peek; my $dd = "hello world\n"; Dump $dd; #output: SV = PV(0x55608d816050) at 0x55608d83a0a8 REFCNT = 1 FLAGS = (POK,IsCOW,pPOK) PV = 0x55608d8b8e90 "hello world\n"\0 CUR = 12 LEN = 14 COW_REFCNT = 1
    I found the above PV address from D::P output is 0x55608d8b8e90, but how can I get this address? I tried SvPVX:
    my $dd = "hello world\n"; printf("the dd string address is %x \n", cc($dd)); use Inline 'C' => <<'CODE'; unsigned int cc(SV* a){ 40 return SvPVX(a); 41 } 42 CODE # just print the dd string address is 8d8b8e90, the upper 4bytes of th +e address was truncated.
    So Is there a way to get pv address as an INT value like Peek does? Do I need to create a struct to save address? TIA.


    I am trying to improve my English skills, if you see a mistake please feel free to reply or /msg me a correction

Outputting input prompt with prove
4 direct replies — Read more / Contribute
by nysus
on Aug 04, 2019 at 21:28

    I have this test program:

    #! /usr/bin/env perl $| = 1; print "test"; print "\n"; print 'Enter: '; <STDIN>
    It outputs this when run with prove -lvm: .. test

    Notice that the Enter: prompt doesn't appear and is getting buffered. I tried various tricks with IO::Handle and other suggestions I googled but none of them worked. I'm on a Mac, Perl ver. 5.24.

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

Finding files recursively
5 direct replies — Read more / Contribute
by ovedpo15
on Aug 04, 2019 at 13:14
    I would like to find all directories which contain a specific file. Until now, we used the following idea:
    find( sub { get_dirs( \@list_of_dirs, $_ ) }, $root_path); sub get_dirs { my ($dirs_aref, $current_path) = @_; my $abs_path = abs_path($current_path); my $file = $abs_path."/"."secret.file"; my $ignore_file = $abs_path."/".".ignore"; push (@{$dirs_aref},$abs_path) if((-e $file) && !(-e $ignore_file) +); }
    The problem is that finding over a large directory could take hours. I'm trying the reduce the waiting time.
    My first idea was to split the directories into the process so they will perform a parallel search but I'm not sure if that a good idea.
    Is it possible to suggest a better idea?

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 examining the Monastery: (8)
    As of 2019-09-23 11:01 GMT
    Find Nodes?
      Voting Booth?
      The room is dark, and your next move is ...

      Results (279 votes). Check out past polls.