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

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
Output problems
3 direct replies — Read more / Contribute
by shingster08
on Dec 07, 2016 at 09:51

    So i moved to the Ubuntu operating system recently to see how it was like and i came across the syslog which proves to be quite interesting. So i decided to create a script that will run through the syslog and search for key terms with a regex and output this to another text file. this is what i got so far

    #!/usr/bin/perl use strict; use warnings; my @array=(); open(my $keyword,'<', "keyword.txt") or die "Couldn't open file file.t +xt, $!"; open(my $sys,'<', "syslog") or die "Couldn't open file file.txt, $!"; #open($keyword,'>' "keyword.txt") || die "Couldn't open file file.txt, + $!"; #open my $keyword, '>' , $file_location3 or die "can't open Keywords:" + $!; # gives keywords.txt the file handle keyword and shows + #error message if it fails to open #open my $sys, '>' , $file_location2 or die $!; # same as above open(my $fh, '>', 'output.txt'); #my $file_location2 = "syslog"; #my $file_location3 = "keyword.txt"; #arraylisy goes here my $Keyword_or = join '|' , map {chomp;qr/\Q$_\E/} <$keyword>; # lists + all lines in indicated file and joins the list in 1 string #regex +here removes new line from each line and uses literal regex #which +matches even those words with dots my $regex = qr|\b($Keyword_or)\b|; # this regex will match #all the keywords stored in keyword +s txt file #@array = $Keyword_or; foreach $regex(@array) { #while (/regex/g) #{ #print $NEW "$.: $1"; print $fh $regex; #} #return $keyword; #return $sys; #return $NEW; #print $fh $NEW; close $fh; }

    While this code does compile with no errors it doesn't actually output anything and i also realized that my array is also empty. As im still new to perl Can anyone tell me how i would push the results of the regex to an arraylist and output it ?

Some issues using Thread::Queue
No replies — Read more | Post response
by leostereo
on Dec 07, 2016 at 08:39

    Hi guys , I will try to sumarize my problem

    After getting the monks wisdom, I got working a beatifull piece of code (my first time) working with threds. The script will read an ip list from a text file and will asign each ip to a thread, then each thread will will do snmp query to this ip and store the result on a mysql db.
    THE PROBLEM: The script works great but it stops working after a random number of lines, sometimes it do 100 , 300 , 800 from a total of 16k ips.
    After insert some prints lines on the code I noticed that the the workers are not dequeueing the ips from the ips queue.
    I tryed modifing the queue size and the thread numbers but got same result.
    I would like to know if is there some way to trigger a reset on the script clearing the queue or reseting the threads after some blocking condition ... or --- do someting to force the script to continue working. Ok , following the code:

    #!/usr/bin/perl -slw use strict; use threads; use Thread::Queue; use Net::Ping; use DBI; $|=1; our $T = 10; ## 10 walkers; adjust to suit. my $community='public'; my $snmp_sinr; my $snmp_rsrp; my $snmp_rsrq; my $snmp_rssi; my $snmp_imsi; my $snmp_bsid; my $cpe; my $snmp_brand; my $snmp_dl; my $snmp_ul; my $output; my $brand; my $error = 'none'; my @result; my $ulrate; my $orig_bsid; my $dlrate; my $firmware; my $model; my $line; my $dbh; my $sth0; my $sth; my $query0; my $query; my $fh; my $qsize = 10; my $imsi; open ($fh,'>>','/opt/cpe_history_test/dates'); my $date=localtime(); print $fh "started at ",$date,"\n"; close $fh; sub listener { open(my $fh1, '<:encoding(UTF-8)', '/opt/cpe_history_test/connected') or die "Could not open file 'connected' $!"; my( $Qout ) = @_; while(<$fh1>){ $Qout->enqueue($_); } sleep(30); open ($fh,'>>','/opt/cpe_history_test/dates'); my $date=localtime(); print $fh "finished at ",$date,"\n"; close $fh; close $fh1; exit(0); } sub walker { my( $Qin, $Qout ) = @_; # while( $Qin->dequeue ) { ## receive work from listener while (defined(my $line = $Qin->dequeue())) { ## receive work from + listener my $ip = $line; chomp($ip); my $pending_jobs=$Qin->pending; my $ping_result = 0; my $p = new Net::Ping('icmp',1); for(my $a=0 ; $a < 3 ; $a++){ # print "attempt $a for $ip\n"; if ($p->ping($ip)){ $ping_result = 1; last; } } if ($ping_result){ #print "$ip is ALIVE\n"; ####snmp my $snmp_fver = '.1.3.6.1.4.1.2700.1.1.8.0'; $output=qx(snmpwalk -v2c -t1 -c $community $ip $snmp_fver 2>&1); chomp($output); if( $output eq "Timeout: No Response from $ip" ) { return; } else{ my @result=split(/:/,$output); if ($result[3]){ $firmware=$result[3]; $firmware=~s/ //g; $firmware=~s/"//g; $firmware=~s/\n//g; if(($firmware=~/SPC630/)||($firmware=~/DBG0521/)||($firmwa +re=~/SPC610/)||($firmware=~/SP006/)){ $snmp_sinr = '.1.3.6.1.4.1.2700.1.1.7.0'; $snmp_rsrp = '.1.3.6.1.4.1.2700.1.1.4.0'; $snmp_rsrq = '.1.3.6.1.4.1.2700.1.1.5.0'; $snmp_rssi = '.1.3.6.1.4.1.2700.1.1.6.0'; $snmp_imsi = '.1.3.6.1.4.1.2700.1.1.2.0'; $snmp_bsid = '.1.3.6.1.4.1.2700.1.1.3.0'; }elsif(($firmware=~/SPC914/)||($firmware=~/SPC892/)||($fir +mware=~/SPC927/)){ $snmp_sinr = '.1.3.6.1.4.1.2700.1.1.7.0'; $snmp_rsrp = '.1.3.6.1.4.1.2700.1.1.4.0'; $snmp_rsrq = '.1.3.6.1.4.1.2700.1.1.5.0'; $snmp_rssi = '.1.3.6.1.4.1.2700.1.1.6.0'; $snmp_imsi = '.1.3.6.1.4.1.2700.1.1.2.0'; $snmp_bsid = '.1.3.6.1.4.1.2700.1.1.11.0'; }else{ $snmp_fver = '.1.3.6.1.4.1.2700.1.1.21.0'; $output=qx(snmpwalk -v2c -t1 -c $community $ip $snmp_fver +2>&1); if ($result[3]){ $firmware=$result[3]; $firmware=~s/ //g; $firmware=~s/"//g; $firmware=~s/\n//g; if(($firmware=~/R15-ARG-P/)||($firmware=~/QCI4NU/) +||($firmware=~/C00SPC040w/)){ print $firmware." corresponde al set 3\n"; + } } print "firmware $firmware could not be resolved\n" +; next; } ############# $Qout->enqueue(join(',',$imsi,$ip,$firmware)); ##snmp_ok }else{ print "retornando\n"; next; return } } ####snmp ##ping_result_ok }else{ print "$ip is dead \n"; next; } } } use enum qw[ IN DBI_ENUM ]; my @Qs = map Thread::Queue->new(), 1 .. 2; # set up two Qs $Qs[0]->limit = $qsize; ## start the listener thread my $tListener = threads->create( \&listener, $Qs[ IN ] ); ## One for t +he listener to send work to the walkers ## start 10 walkers my @walkers = map{ threads->create( \&walker, @Qs[ IN, DBI_ENUM ] ) } +1 .. $T; ## And one for the walkers to forward data for adding to the + db require DBI; ## Avoid loading DBI into threads $dbh = DBI->connect("DBI:mysql:database=cdba_cpe_history;host=172.31.1 +60.207;port=3306","history_process","neTing321!" ); #$sth = $dbh->prepare("INSERT INTO ? (ip,bsid,firmware) VALUES (?, ?, +?)"); while (defined(my $item = $Qs[DBI_ENUM]->dequeue())) { ## receive +work from listener my($imsi, $ip, $bsid, $firmware) = split(',', $item); #Retrieve in +dividual data if (($rssi <= 0) && ($rssi >= -100) && ($sinr >= 0) && ($sinr +<= 120) && ($rsrp <= 0) && ($rsrp >= -100) ){ print "in db task item is $imsi -> $ip"; $query0 = "CREATE TABLE IF NOT EXISTS `rf_$imsi` ( `date` timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP ON UPDATE CURREN +T_TIMESTAMP, `ip` varchar(16) DEFAULT NULL, `bsid` varchar(15) DEFAULT NULL, `firmware` varchar(25) DEFAULT NULL )"; #print $query0,"\n"; $sth0 = $dbh->prepare($query0); $sth0->execute(); $query = "INSERT INTO rf_$imsi (ip,bsid,firmware) VALUES ('$ip', '$bsi +d', '$firmware')"; # print $query,"\n"; $sth = $dbh->prepare($query); $sth->execute(); ## bind and execute } } $dbh->disconnect();

    Any ideas would be weelcome. Regards, Leo.

resampling an image using GD not working on Linux
2 direct replies — Read more / Contribute
by Discipulus
on Dec 07, 2016 at 04:36
    Hello estimated monks!

    I recently released picwoodpecker which latest version with a minor fix is on github.

    It seems the program does not run well on Linux (it was developped and tested on win7 only).

    With a bit of pain i'v set up a Linux Ubuntu 16.04 LTS 32 bit as a virtual machine using virtualbox.

    The problem arise when the application try to use the copyResampled GD method:

    GD Warning: one parameter to a memory allocation multiplication is neg +ative or zero, failing operation gracefully line 618

    The Ubuntu machine has perl 5.22 and GD version is 2.53

    I've tryed to reduce the problem to the simplest one and I ended with the following:

    use strict; use warnings; use GD; #UPDATE: need the following line to have a real 'smooth' resampling GD::Image->trueColor(1); my $file = $ARGV[0]; die "Please feed a jpg file.." unless -e $file; my $orig_gd = GD::Image->new($file); my $photo_ratio = 0.3; my $small_w = int($orig_gd->width * $photo_ratio); my $small_h = int($orig_gd->height * $photo_ratio); draw_photo ($file); ###################################################################### +########## sub draw_photo { my $file_path = shift; # create the resized but still empty GD image my $resized = GD::Image->new($small_w,$small_h); # copy from source into resized on $resized->copyResampled($orig_gd,0,0,0,0, $small_w, $small_h, $orig_gd->width, $orig_gd->height); # save open my $out, '>', time.'.jpg' or die "unable to open for write"; binmode $out; print $out $resized->jpeg or die "unable to write jpg data!"; close $out; }

    The above runs fine on my win7 machine (perl 5.14 GD 2.46) and creates a resampled image.

    It also creates a resampled image on Ubuntu so it does not complains about the zeros! So i'm stucked and seek for your wisdom.

    The relevant part of the original code that fails on Linux is the following:

    # @files is ArrayOfArray # each element contains pic data as follow: # 0 path # 1 x # 2 y # 3 orientation # 4 datetime joined with underscores # 5 GD object of THUMB # 6 [ GD object of PHOTO] # the last field [6] will be filled only for current file ( which inde +x is hold in $ph_index) # and for elelments to be preloaded: from ($ph_index - $preload) to ( +$ph_index + $preload) # thumb data [5] will be empty if $nothumbs is defined via -nothumbs c +ommandline switch ###################################################################### +########## sub draw_photo { my $ph_index = shift; print "\tdraw_photo got:\n\t",(join '|',map{defined $_ ? $_ : 'undef +'} (@{$files[$ph_index]}[0..4], $files[$ph_index]->[5]?'THUMB':'NO DATA', $files[$ph_index]->[6]?'PHOTO':'NO DATA', )),"\n" if $debug; $tk_ph_image->delete if $tk_ph_image->blank; # some tk stuff removed my $small_w = int($files[$ph_index]->[1] * $ph_ratio); my $small_h = int($files[$ph_index]->[2] * $ph_ratio); # create the resized but still empty GD image my $resized = GD::Image->new($small_w,$small_h); # copy from source into resized on # NOTE $files[$ph_index]->[6] containf the GD object $resized->copyResampled($files[$ph_index]->[6],0,0,0,0, $small_w, $small_h, $files[$ph_index]->[6]->width, $files[$ph_index]->[6]->height); $tk_ph_image->configure( -file => undef, -data => MIME::Base64::encode($resized->jpe +g()) ); # configure the Tk::Label to use the Tk::Photo as image $photo_label->configure(-image => $tk_ph_image ); # some display and tk stuff removed } ###################################################################### +##########

    Thanks for your patience

    L*

    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
Can not Dance on Windows
1 direct reply — Read more / Contribute
by FreeBeerReekingMonk
on Dec 07, 2016 at 02:55
    I developed a web application in Dancer2. As plackup does not https, I wanted an Apache 2.4 frontend to do the securing. Then it went downhill. ApacheLounge does not provide a mod_proxy_psgi, compiling it with the same (MSVC14) as Apache, it goes quickly down a INC dependency hole that made me install cygwin with all the dev headers libs... but I was not able to compile it. I then tried mod_proxy_fcgi (and mod_fcgi), but that requires Dancer to be served by Starman or similar. Unfortunately, Starman does not work on Windows. I then went for the regular cgi, which is still there. Here is where it gets weird:

    I found an apache rule to execute the cgi if it does not contain a dot in the name , everything with a dot is served directly by Apache, so it is not that slow... As I wanted to capture the name, instead of !\. I have ^(/^\.*)$ and the H= means that it treats this rewrite as a cgi script, the E adds a new variable to %ENV

    RewriteRule ^(/[^\.]*)$ "C:/myapp/public/dispatch.cgi" [E=MYPATH_INFO:$1,H=cgi-script]

    However, in app.pm, request->dispatch_path, a constant which can not be modified is always "/" while $ENV{PATH_INFO} and request->path do contain the right path. This means get "/" => sub{} is always running, even if we want to go to other pages.

    By doing a get '/mypage' => $SUBROUTINE{'/mypage'} = sub {....} we can keep the plackup version working, and have the sub in a hash, to serve at / when this anomaly is detected. However, it has other problems, like the browser getting recursively redirected to /login/login/login...etc.. (code snippet will follow as soon as I have time to make a small selfcontained example).

    So my question: Any monks successfully implemented Dancer2 applications under Apache on Windows?

Perl DBI update tables
2 direct replies — Read more / Contribute
by cbtshare
on Dec 06, 2016 at 18:24

    I am copying data from table 1 and insert into table 2, the issue is I don't want to insert all the data I received from table 1 value for value, I want to update some fields and leave other fields to auto increment

    Table structure is id int(11) source_code varchar(20) stream_code char(100) client_id int(11) stream_oauth_id int(11) name varchar(200) url varchar(2500) status_code char(10) stream_data longtext feed_db varchar(500) feed_table varchar(200) last_update datetime report_db varchar(500) sla smallint(5) unsigned exclude_request varchar(200) owned tinyint(1) push tinyint(1) unsigned

    The table information is

    id: 447 source_code: FACEBOOK stream_code: 281434322dd4734 client_id: 53 stream_oauth_id: 422 name: Seer url: Old Beer status_code: DISABLED stream_data: NULL feed_db: production_feed002 feed_table: FACEBOOK_28111aa734 last_update: 2015-02-05 13:23:19 report_db: production_report002 sla: 0 exclude_request: CONVERSATIONS owned: 1 push: 0

    My insert statement is below so I am not updating all the values, is this a problem? The error I am getting is below, I am not sure why are there 12 values needed
    DBD::mysql::st execute failed: called with 15 bind variables when 12 are needed at /home/rdscopy.pl line 131. DBD::mysql::st execute failed: called with 15 bind variables when 12 are needed at /home/rdscopy.pl line 131.

    $activate_stream =$dbh4->prepare("INSERT INTO stream (source_code, str +eam_code, client_id, name, url, status_code, stream_data, feed_db, fe +ed_table, last_update, report_db, sla, exclude_request, owned, push) +VALUES(?, ?, 10, ?, ?, DISABLED, ?, production_feed002, ?, ?, ?, ?, ? +, ?, ?)"); while (my @activate_results = $activate_info >fetchrow_array() ) + { + $activate_stream->execute(@activate_results) or die $activate_strea +m->errstr; + } } $activate_stream->finish();

    id is an auto-increment so we let MySQL assign a value
    I want to make client id = 10.
    Skip the stream_oauth_id for now. That should get created if/when we refresh access tokens on the stream. It may not be necessary in most test cases.
    feed_db will be also assigned in the insert statement

Dynamic Config
3 direct replies — Read more / Contribute
by mikkoi
on Dec 06, 2016 at 16:57
    cfg4j is a implementation of dynamic config, i.e. config can be changed while the program is running, and new values will replace the old values on-the-fly. Do we have anything like that? Should we? :-)
Most efficient way to remove some text from a string
6 direct replies — Read more / Contribute
by adamZ88
on Dec 06, 2016 at 15:24

    I have three potential scenarios. A String could either represent an artist, an album or a song. Unfortunately each string is going to be preceded by a path. Here is an example of each of the scenarios.

    /Volumes/WD/Not Migrating/Music/Ana Tijoux (An Artist)

    /Volumes/WD/Not Migrating/Music/Eminem/Ana Tijoux/Luchin (An Album)

    /Volumes/WD/Not Migrating/Music/Eminem/Ana Tijoux/Luchin/Luchin.m4a (A Song)

    I the most efficient regular expression to trim "/Volumes/WD/Not Migrating/Music/" from my original string. Once this is complete, this will be assigned to a variable. I then need a regular expression to determine the number of "/". This will help me determine if the that variable contains an Artist (0 "/"), an Album (1 "/") , A song (2 "/")

    Lastly, is there a way to print bullet points in Perl? Depending on the number of "/" is how many indents i will print the variable with.

pp and setting Windows LegalCopyright in executable header
5 direct replies — Read more / Contribute
by mpmcgill
on Dec 06, 2016 at 14:25
    Monks,

    I am using pp (with the latest version of Strawberry perl 5.24 64bit on Windows) to build an executable out of my code. There are various references to the ability to set the Windows executable header with 10 specific resource tags including LegalCopyright and ProductVersion. One of the references is here: http://search.cpan.org/~autrijus/PAR-0.85_01/script/pp I have installed the latest version of pp and this feature which the docs say is invoked using --info does not exist in my pp.

    pp itself works well and produces functional executable for systems without perl installed, but my employer wants the LegalCopyright and ProductVersion to be set. I have tried various external tools like "Resource Hacker", but they seem to mess up the generated executable and I get many of the following messages:

    at -e line 631. format error: bad signature: 0x08000000 at offset 11057307 in file my-executable.exe

    I suspect the errors have to to with the compressed nature of a pp generated executable, but the bottom line is I need a way of setting these Windows executable resource tags.

    Thanks in advance,

    Michael McGill
Interactive openssl raw
1 direct reply — Read more / Contribute
by Guntherssl
on Dec 06, 2016 at 06:39
    Hello Monks,

    I'm having an issue that has cost me hours of testing. Please help. What I am trying to do; Connect raw to a site using openssl like this: openssl s_client -connect site:sslport That works great. When it connects, I can see the exchange and I am left with a blank STDIN. I type <ping> and receive a <pong> back. I have tried to reproduce this in perl and have been unable to do so. I faced this issue before and used IO::S::SSL to get me by. However, I'd really like to watch each part manually and interact with it live. In perl, I am able to use something like:

    #!/usr/bin/perl $r = exec("openssl s_client -connect site:sslport"); print $r;
    or
    #!/usr/bin/perl open(FH,"-|","openssl s_client -connect site:sslport"); while(<FH>){ print $_; } close(FH);
    However, whenever I try to add
    print FH "<ping>";
    or
    print(FH, "<ping>");
    Nothing happens. It stays at the regular STDIN as if I executed it on terminal and accepts ping the same way. I would love some help to achieve sending the ping programmatically while openssl is open and staying open. As I would like to then capture the PONG and do other interactive send and captures. Someone, please guide me. Thank you. PS: I am using perl5 and I'm able to install any module. Sorry for any typing mistakes, my phone works as good as my perl. Thanks again, Gunther
Pragma clash across modules: bignum and Math::BigFloat
3 direct replies — Read more / Contribute
by Athanasius
on Dec 06, 2016 at 02:04

    Hi,

    Background.

    The problem. I’ve reduced the problem to a minimal case as follows: Create 3 files in the same directory:

    # 1725_Pragma.pl use strict; use warnings; use First; use Second;
    # First.pm package First; use strict; use warnings; #use bignum; print "First\n"; 1;
    # Second.pm package Second; use strict; use warnings; use Math::BigFloat; print "Second\n"; my $f = Math::BigFloat->new(2); $f->bsqrt(); print "$f\n"; 1;

    With use bignum commented out as shown above, the output is as expected:

    16:38 >perl 1725_Pragma.pl First Second 1.41421356237309504880168872420969807857 16:38 >

    <Update> And I get the same value for the square root of 2 if I just run perl Second.pm on its own. </Update>

    But with use bignum uncommented, the result is simply wrong:

    16:38 >perl 1725_Pragma.pl First Second 2 16:40 >

    So, my questions are:

    1. Is this a bug?
    2. How can a pragma declared in one namespace affect the behaviour of code in a different (and supposedly separate) namespace?
    3. Is there a workaround that will allow me to keep the current implementations of my two solutions and run them together in the same test script?

    In relation to question 3, note that I’ve tried adding no bignum to the end of First.pm or to the beginning of Second.pm, but this had no effect. :-(

    Setup.

    Thanks,

    Athanasius <°(((><contra mundum Iustus alius egestas vitae, eros Piratica,


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":


  • 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?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others rifling through the Monastery: (11)
    As of 2016-12-07 15:30 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      On a regular basis, I'm most likely to spy upon:













      Results (130 votes). Check out past polls.