Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"

The Monastery Gates

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

Donations gladly accepted

If you're new here please read PerlMonks FAQ
and Create a new user.

New Questions
How to strip comments and whitespace from a regex defined with /x?
3 direct replies — Read more / Contribute
by jh
on Jan 19, 2018 at 14:27

    I would like to print out some previously-defined regular expressions in a compact format. The main thing I want to do is strip out the whitespace and comments from those defined with the /x modifier. So if I have two functionally identical regexes:

    our $rgx_plain = qr/^([a-z]+)\d*$/; our $rgx_fancy = qr/ ^ # beginning of string ( # begin cap $1 [a-z]+ # one or more letters ) # end cap $1 \d* # optional digits $ # end of string /x;

    then I'd like to make a function clean_regex such that

    say $rgx_plain; say clean_regex($rgx_fancy);

    both print the same thing. Ideally clean_regex is a no-op on regexes defined without the /x modifier, such that

    say clean_regex($rgx_plain);

    also prints the same thing. I have hacked together something gross and terrible but I was hoping for something better, presumably asking the Regexp compiler what it has once it's done throwing away comments and whitespace.


Send an email attachment
2 direct replies — Read more / Contribute
by AmyB
on Jan 19, 2018 at 12:35
    I'm attempting to modify an existing mailsend program to be able to send a file attachment and need some new ideas. I'm not proficient in PERL at all, so please reply in detail.
    #!/usr/bin/perl -w use strict; # for stronger code my $numargs = $#ARGV + 1; if (($numargs > 3) || ($numargs < 1)) { print "usage : <logfile> [subject] -t\n"; print "syntax : <logfile> is required. [subject] is optional. [-t] specifies to send a copy to maileater\n"; print "example: /tmp/test.log\n"; print "example: /tmp/test.log Test!\n"; print "example: /tmp/test.log Test! -t\n"; exit; } use Net::SMTP; # net SMTP module my($smtp) = Net::SMTP->new('inesg2.alliance.lan',Debug => 1); $smtp->mail(''); my $host = `uname -a | cut -d " " -f2`; # my $emseater = ''; my $emseater = ''; my $sendto = ''; my $subject; chomp ($host); my $logfile = $ARGV[0]; chomp ($logfile); if ($numargs > 1) { $subject = $ARGV[1]; } else { $subject = join ": ", $host, $logfile; } my $message = `cat $ARGV[0]`; $smtp->data(); $smtp->datasend("Subject: ". $subject . "\n\n"); $smtp->datasend($message); if ((($numargs == 3) | ($numargs == 4)) && ($ARGV[2] eq "-t")) { $smtp->to($emseater); my $emsfile= '/home/unixadmin/emsmksysb.txt'; # $smtp->datasend("MIME-Version: 1.0\n"); # $smtp->datasend("Content-Type: application/text; name=$emsfile +\n"); $smtp->datasend("Content-Disposition: attachment; filename=\"$ +emsfile\"\n"); # print $smtp ; ## system("ls -l"); ## $smtp->datasend("Content-type: text/plain; name=\"$emsfile\"\+ +n"); } else { $smtp->to($sendto); } $smtp->dataend(); $smtp->quit; The basic part of the PERL that is changing is the if ((($numargs == 3 +) section. I've done basic debugging to know it's getting into that + section. My current debug output is the following:>perl '/home/unixadmin/emsmks +ysb.txt' 'junk' -t Net::SMTP>>> Net::SMTP(2.29) Net::SMTP>>> Net::Cmd(2.26) Net::SMTP>>> Exporter(5.58) Net::SMTP>>> IO::Socket::INET(1.29) Net::SMTP>>> IO::Socket(1.29) Net::SMTP>>> IO::Handle(1.25) Net::SMTP=GLOB(0x201fd5d8)<<< 220 ESMTP Pro +xy Server Ready Net::SMTP=GLOB(0x201fd5d8)>>> EHLO localhost.localdomain Net::SMTP=GLOB(0x201fd5d8)<<< Hello x1a [], pleased to meet you Net::SMTP=GLOB(0x201fd5d8)<<< 250-ENHANCEDSTATUSCODES Net::SMTP=GLOB(0x201fd5d8)<<< 250-PIPELINING Net::SMTP=GLOB(0x201fd5d8)<<< 250-8BITMIME Net::SMTP=GLOB(0x201fd5d8)<<< 250 STARTTLS Net::SMTP=GLOB(0x201fd5d8)>>> MAIL FROM:< +m> Net::SMTP=GLOB(0x201fd5d8)<<< 250 2.1.0 Sender ok Net::SMTP=GLOB(0x201fd5d8)>>> DATA Net::SMTP=GLOB(0x201fd5d8)<<< 503 5.5.1 Need RCPT (recipient) Net::SMTP=GLOB(0x201fd5d8)>>> Subject: junk Net::SMTP=GLOB(0x201fd5d8)>>> this is a test of the attachment system +under EMS. Net::SMTP=GLOB(0x201fd5d8)>>> . Net::SMTP=GLOB(0x201fd5d8)<<< 500 5.5.1 Command unrecognized: "Subject +: junk" Net::SMTP=GLOB(0x201fd5d8)>>> RCPT TO:<> Net::SMTP=GLOB(0x201fd5d8)<<< 500 5.5.1 Command unrecognized: "" Net::SMTP=GLOB(0x201fd5d8)>>> Content-Disposition: attachment; filenam +e="/home/unixadmin/emsmksysb.txt" Net::SMTP=GLOB(0x201fd5d8)>>> . Net::SMTP=GLOB(0x201fd5d8)<<< 500 5.5.1 Command unrecognized: "this is + a test of the attachment system under EMS. " Net::SMTP=GLOB(0x201fd5d8)>>> QUIT Net::SMTP=GLOB(0x201fd5d8)<<< 500 5.5.1 Command unrecognized: "."
    Any help would be great?
Returning columns with SQL::Statement error
3 direct replies — Read more / Contribute
by LalakisOeisagwmenos
on Jan 19, 2018 at 10:28

    Hello, I am sorry for bothering you but trying to execute the paradigm of SQL::Statement::Structure on a Strawberry perl v5.21.1 I had the following error.

    Can't call method "name" on unblessed reference
    The code is the following:
    use SQL::Statement; use Data::Dumper; my $sql = "SELECT a,aa FROM b JOIN c WHERE c=? AND e=7 ORDER BY f D +ESC LIMIT 5,2"; my $parser = SQL::Parser->new(); $parser->{RaiseError}=1; $parser->{PrintError}=0; # $parser->parse("LOAD 'MyLib::MySyntax' "); my $stmt = SQL::Statement->new($sql,$parser); printf "Command %s\n",$stmt->command; printf "Num of Placeholders %s\n",scalar $stmt->params; printf "Tables %s\n",join( ',', map {$_->name} $stmt->tab +les() ); printf "Where operator %s\n",join( ',', $stmt->where->op() ); printf "Limit %s\n",$stmt->limit(); printf "Offset %s\n",$stmt->offset(); printf "Columns %s\n",join( ',', map {$_->name} $stmt->col +umn_defs() );

    Can't call method "name" on unblessed reference at c:\Users\PasvantidisR\Documents\scripts\perl\ line 17.

    Command SELECT
    Num of Placeholders 1
    Tables b,c
    Where operator AND
    Limit 2
    Offset 5

    Can you please help? Thank you Lalakis Oeisagwmenos
Data extraction with specific keywords
5 direct replies — Read more / Contribute
by neeraj_kr
on Jan 19, 2018 at 01:31

    I am trying to write a Perl code to extract specific keywords from a large data file. I have created an array where those specific keywords were stored. I was trying to read that large file line by line and extract matching keywords and want to store them in a new file. I am pasting my code here as it's not working properly. Help will be appreciated. Thank you.

    $a=`head -1 $ARGV[0]`; @arr=split(/\t/,$a); $col=$#arr; $c=0; @arr1 = ("91:", "86:", "184:", "430:", "391:", "254:", "121:", "192:", + "404:", "12:", "87:", "638:", "417:", "129:", "549:", "548:", "122:" +, "443:", "378:", "365:", "665:", "148:", "185:", "88:", "629:", "6 +37:", "149:", "625:", "635:", "627:", "650:", "468:", "92:", "618:", +"212:", "85:", "628:", "171:", "649:", "15:", "61:", "169:", "104:", +"202:", "523:", "60:", "672:", "291:", "658:", "59:", "547:", "491:", + "234:", "411:", "620:", "581:", "414:", "14:", "412:", "416:", "345: +", "626:", "457:", "72:", "384:", "371:", "9:", "580:", "436:", "356: +", "385:", "58:", "669:", "388:", "386:", "390:", "636:", "619:", "16 +:", "413:", "17:", "524:", "579:", "624:", "90:", "471:", "410:", "55 +1:", "289:", "387:", "531:", "64:", "166:", "211:", "467:", "415:", " +232:", "550:", "362:", "375:", "401:", "359:", "372:", "398:", "360:" +, "364:", "399:", "403:", "373:", "377:", "18:", "118:", "585:", "427 +:", "424:", "586:", "469:", "425:", "429:", "13:", "423:", "500:", "6 +2:", "109:", "19:", "539:", "499:", "532:", "400:", "63:", "361:", "3 +74:", "73:", "449:", "175:", "426:", "89:", "507:", "397:", "389:", " +582:", "475:", "20:", "22:", "541:", "492:", "503:", "555:", "595:", +"596:", "450:", "23:", "611:", "509:", "3:", "485:", "24:", "438:", " +442:", "440:", "484:", "117:", "32:", "437:", "31:", "663:", "339:", +"535:", "21:", "470:", "439:", "525:", "172:", "40:", "65:", "487:", +"50:", "517:", "597:", "545:", "516:", "402:", "347:", "614:", "540:" +, "613:", "346:", "67:", "363:", "583:", "376:", "428:", "71:", "615: +", "332:", "271:", "5:", "508:", "74:"); #print "$m\n"; print $arr[2],"\n"; for($i=1;$i<=$#arr+1;$i++) { foreach $ar(@arr1) { if ($arr[$i] == $ar) { $c[$j]=$i; $j++; # print $j; } #print $arr[1],"\n"; } } open(fh,"$ARGV[0]"); while(<fh>) { chomp $_; @arr2=split(/\,/,$_); foreach $ar(@c) { # print $arr2[$ar],"\t"; } #print "\n"; } close(fh);
apply_all_roles method clobbering MooseX::Log::Log4perl
1 direct reply — Read more / Contribute
by nysus
on Jan 18, 2018 at 10:16

    I have the following:

    { package MyApp; use Moose; use Moose::Util qw( apply_all_roles ); with 'MooseX::Log::Log4perl'; sub BUILD { my $s = shift; # apply_all_roles($s, 'BarCollector'); # if you uncomment this li +ne, logging doesn't work anymore } sub print_something { my $self = shift; $self->log->info('This does not print when apply_all_roles is used +.'); } } { package BarCollector; use Moose::Role # does nothing } #! /usr/bin/env perl use File::HomeDir; use Log::Log4perl; BEGIN { Log::Log4perl->init_once(File::HomeDir->my_home . '/test.cfg') + }; use MyApp; my $app = MyApp->new(); $app->print_something; __END__ # test.cfg config file: log4perl.logger.MyApp=TRACE, LOG log4perl.appender.LOG=Log::Log4perl::Appender::ScreenColoredLevels log4perl.appender.LOG.layout=PatternLayout log4perl.appender.LOG.layout.ConversionPattern=%c - %m%n

    As noted in the comment, when the line that contains apply_all_roles is uncommented, log messages no longer work. There are no errors.

    Update: One other clue is that when I change the first line of the config file to: log4perl.rootLogger=TRACE, LOG

    I get output, though the category looks something like this: Moose.Meta.Class.__ANON__.SERIAL.1

    Any workaround to this?

    Update 2: Possible workaround?

    I discovered if I slap $s->log->trace('print this'); before the apply_all_roles method is called, everything works as expected. Is there a better way?

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

Getting attachments from request in perl
2 direct replies — Read more / Contribute
by Stetec
on Jan 18, 2018 at 09:36
    I want to use a form to submit fields of email so server can send it. I use Perl and Mason to handle this. I want a user to be able to add multiple attachments, however I am encountering a problem that I can not solve. This is my code simplified as much as possible and with added check for the attachments. ( After submit I want to stay at the same page, that is why there is a hidden check-box and condition in Init section, so that it does nothing when I visit the page for the first time. )
    <!DOCTYPE html> <html> %foreach (@messages) { <div class="alert"> <% $_ | h %> </div> %} <body> <form action="/Tools/SendEmail.html" name="form" enctype="multi +part/form-data" method=post> <input type="checkbox" id="submited_chck" name="submited" +checked hidden> <input type="file" name="attached_files" id="file_upload_b +tn" multiple> <input type="submit" value="Submit"> </form> </body> </html> <%args> @messages => () $submited => '' </%args> <%init> use strict; use warnings; use CGI; if($submited eq 'on') { my $req = new CGI; my @attachments = $req->param('attached_files'); unless (@attachments) { push @messages, "Attachments do not exist"; } } </%init>
    The problem is that if I do any request before submit and add any number of attachments it does not get the attachment from request and the error message is pushed into array and displayed. It does not push the error message only if I restart apache service and submit the form right after it. Any ideas what can cause this? I posted this also on stack overflow but no-one is able to help. Here is a link to it
Problem with SOAP call using SOAP::Lite and wsdl
1 direct reply — Read more / Contribute
by Anonymous Monk
on Jan 18, 2018 at 04:15

    I'm trying to do a SOAP call to

    My code as follows :

    use SOAP::Lite; my $client = SOAP::Lite->new; $client = $client->service( " +d.asmx?wsdl" ); my $soapResp = $client->call( "ConvertSpeed", 100, "kilometersPerhour" +, "milesPerhour" ); if ( $soapResp->fault ) { print $soapResp->faultstring; } else { print $soapResp->result; }

    This gives me the following error :

    A service address has not been specified either by using SOAP::Lite->proxy() or a service description)

    As far as I understand it the service address is obtained from the WSDL. I did however try using
    $client->proxy(""), but then I got the following error :

    Server did not recognize the value of HTTP Header SOAPAction: #ConvertSpeed

    Since the WSDL is supposed to handle the service address I removed the $client->proxy() bit and tried
    other stuff. I have been struggling with this for 2 days now so I can't recall everything I tried, but
    I did reduce method chaining a lot from my initial code to what I posted above. I also tried using
    $client->ConvertSpeed(100, "kilometersPerhour", "milesPerhour") directly as I have seen it done this way
    elsewhere, but it seems to not return anything.

    This is running on Perl 5.10 and version 0.714 of SOAP::Lite.
    I have also tested on Perl 5.22.1 and version 1.19.

    I have also confirmed that this SOAP call works in other languages.

3 direct replies — Read more / Contribute
by BillB
on Jan 17, 2018 at 16:48
    I installed the Perl build from active state on my 64 bit windows 7 machine. However I have to be able to connect to an Oracle 8I database using a 10g client. The 10g client can connect to the database with no problems, but when I try to use DBI it says that that version is no longer supported. I looked up the newest version that will support my database and it is version 1.20 I was able to download the 1.20 version for DBD::Oracle from CPAN but following the instructions I can't get it to replace the version used by my 64 bit version of Perl. Does anyone know how to do this. It is very frustrating. By the way version 1.20 will talk to all versions of the database, it just doesn't support the newest bells and whistles.
Memory utilization and hashes
9 direct replies — Read more / Contribute
by bfdi533
on Jan 17, 2018 at 15:53

    I have some code which reads from a file (sometimes 100+ GB) and has to combine rows to create a consolidated output. I used to process the entire file into a hash and then dump the hash at the end of the program.

    The problem with that was, of course, with the very large files, the hash would grow humongous and the program would consume all memory in the system causing it to crash.

    So, trying to solve this problem, I changed the code to output the data as it went, doing my best to make sure that I got all of the row data for consolidation and the did a delete on the hash, thinking I was clearing up memory. But, this does not appear to be the case. Example code:

    my $l; my @vals; my $json; while (<>) { $l = $_; chomp $l; @vals = split /;/, $l; if ($vals[0] =~ /Query/) { $pairs{$vals[1]}{$vals[2]} = $vals[3]; } elsif {$vals[0] =~ /Answer/) { $pairs{$vals[1}{$vals[2]} = $vals[3]; $json = encode_json $pairs{$vals[1]}; print $json."\n"; delete $pairs{$vals[1]}; } }
    Example data:
    Query;1;host; Answer;1;ip; Query;2;host; Query;3;host; Answer;2;ip; Answer;3;ip;

    Does delete actually remove the storage from the hash?

    Does the memory the hash is using actually get reduced after delete?

    Is there a better way to do this?

    Code updated above per the first reply.

Attaching a balloon message to text on the Text widget
1 direct reply — Read more / Contribute
by Anonymous Monk
on Jan 17, 2018 at 05:22

    Hi Monks

    I am trying to attach a Balloon to a text (word) in a Text widget. I am not quite sure this is possible, as it seems to me that it is possible to attach it only to a widget. I am able to highlight the word (in this example in red), but how can I attach a Balloon to it? Any idea?

    use strict; use warnings; use Tk; use Tk::Text; use Tk::Balloon; my $mw = tkinit(); my $text = $mw->Text()->pack(); $text->insert('end',"This is a red text\n"); $text->tagAdd('red_text',"1.10","1.13"); $text->insert('end',"This is a black text\n"); $text->tagConfigure('red_text', -foreground => 'red'); my $balloon = $text->Balloon(); $balloon ->attach($text , -balloonmsg => "hello", -initwait=>10); $mw->MainLoop();
2 direct replies — Read more / Contribute
by 3dbc
on Jan 16, 2018 at 16:18
    Hi perl Monks,

    Unfortunately we all don't have the privilege of working on linux or solaris all the time but still love to use perl to do everything! personally I hate powershell especially when window$ people tell me to use it instead of perl, vbscript is cumbersome, and batch files just plain suck most of the time because they aren't very extendable, robust or creative. There's a lot of published powershell scripts on this topic which read from a csv file that has hostnames and user id / passwords, which I could easily build into this, but just wanted to get something out there because a google search on "perl windows reboot" script returns nothing...

    I wrote a quick and dirty reboot script, planning to expand it a bit more to parse log files, make net service calls, ping ip address to confirm each server is up before moving to the next depending on the underlying software dependencies which created the need for this in the first place, but trying to build in some basic error handling, which will help me expand this further. On my first go, I received a hickup from one of the servers complaining about:

    The handle is invalid. Error communicating with PsExec service on Blah.Blah.Blah
    When I logged onto the server I saw a whole bunch of dll errors, which usually happens after windows patches have been deployed but the server wasn't rebooted, so therefore psexec call didn't work...

    I want to be able to process this output and if I don't get the response:

    cmd started on Blah.Blah.Blah with process ID 4428.

    then I want to terminate the program. I'm calling the command with a
    print for qx|$externalExe 2>&1|;
    How do I process this output within the perl script to exit gracefully (or try alternative methods) when an error is encountered? Perhaps I'm not totally understanding this 2>&1 part of my qx, can I read this output within the script?

    Sample Code:
    #!/usr/bin/perl use strict; use warnings; my @servers = qw( Blah.Blah.Blah Blah1.Blah.Blah Blah2.Blah.Blah Blah3.Blah.Blah Blah4.Blah.Blah ); foreach (@servers){ my $externalExe = qq(psexec.exe \\\\$_ ); $externalExe .= q(-u BLAH\foo -p secret -i -d cmd /c shutdown /r /f /t + 0); print "\n\nStarting external program...\n"; print for qx|$externalExe 2>&1|; # Executes the program, and prints it +'s output print "Program $externalExe run completed.\n"; sleep 360; }
    - 3dbc
Recognizing pattern in 2D grid
3 direct replies — Read more / Contribute
by pwagyi
on Jan 15, 2018 at 21:42
    Greeting monks!

    I am facing a problem in recognizing a pattern in 2 dimensional grid. 2D grid is represented by hash of hash (X,Y coordinate as key, and value). I need to recognize some patterns like (horizontal, vertical, or diagonal) example data (x,y coordinate and value (a,b,c,..))

    recognize( pattern => 'horizontal', min => 3); # recognize 3 or more +consecutive horizontal pattern recognize( pattern => 'vertical', min => 5); |a|a|b|a|c| |a|a|c|e|f| |e|f|a|1|b|

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 exploiting the Monastery: (3)
As of 2018-01-20 11:37 GMT
Find Nodes?
    Voting Booth?
    How did you see in the new year?

    Results (226 votes). Check out past polls.