Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister

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
Debugging objects
No replies — Read more | Post response
by geoffleach
on Aug 23, 2017 at 00:30
    IO::All (among others) creates objects which the standard debugger does not understand.

    DB<1> x @files 0 IO::All::File=GLOB(0x2e0c038)
    How can I see inside?

transferring a large file with STOMP over Artemis AMQ
1 direct reply — Read more / Contribute
by Paul.Unix
on Aug 22, 2017 at 09:01
    Hi We want to transfer files over AMQ and once I wrote a Perl script that uses an external tool Spazio and IBM MQ to do the same. Perl has a STOMP module to interface with AMQ but how can I send a large file without reading it into a variable? I made a test script that can put a small file on an Artemis queue which can be read by a Camel route. But what if the file does not fit in memory?
    #!/home/mqm/perl5/bin/perl use strict; use warnings; use File::stat; use Net::STOMP::Client; my $mypath = "/home/mqm/perl2amq"; my $myfile = "pauls_what.bin"; my $stomp = Net::STOMP::Client->new( host => 'artemis', port => '61613 +' ); my $peer = $stomp->peer(); printf("connected to broker %s (IP %s), port %d\n", $peer->host(), $peer->addr(), $peer->port()); $stomp->connect( login => 'jboss', passcode => 'notyourstoknow' ); printf("speaking STOMP %s with server %s\n", $stomp->version(), $stomp->server() || "UNKNOWN"); my $content; open(my $fh, '<', $myfile) or die "cannot open file $myfile"; { local $/; $content = <$fh>; } close($fh); my $stat = stat($myfile); my $mylength = $stat->size; # content-length => $mylength, my $dashhost = "amqclient-source-com"; my $five = "12345"; my $stime = time(); my $my_id = "ID-$dashhost-$five-$stime-2-3"; $stomp->send( destination => "testqueue", CamelFileAbsolutePath => "$mypath/$myfile", CamelFileName => $myfile, CamelFileNameConsumed => $myfile, CamelFileNameOnly => $myfile, CamelFileParent => $mypath, CamelFilePath => "$mypath/$myfile", CamelFileRelativePath => $myfile, breadcrumbId => $my_id, "content-type" => "application/octet-stream", body => $content, ); $stomp->disconnect;
one liner automagic strftime()
2 direct replies — Read more / Contribute
by seki
on Aug 22, 2017 at 08:33

    Hi Monks!

    I use often the localtime() / strftime() couple, but while looking at my collection of one-liners tools, I am puzzled by an epoch translator that displays local time without specifying a format.

    If I eval the following code,

    perl -le'print localtime 1503403724'

    the result is not surprisingly


    but the following command line filter

    echo 1503403724 | perl -pe's/([\d.]+)/localtime $1/e;'

    displays the formated

    Tue Aug 22 14:08:44 2017

    Is there some untold magic with the inline loop parameter, or with the executable regex?

    For the record, the onle-liner is originaly used to translate some log files with a time-stamp on each line in the form of an epoch date instead of a readable date format. Example:

    cat var/nagios.log | perl -pe's/([\d.]+)/localtime $1/e;' | less
    The best programs are the ones written when the programmer is supposed to be working on something else. - Melinda Varian
Tkx and clear a textbox content
3 direct replies — Read more / Contribute
by jasonwolf
on Aug 21, 2017 at 11:02


    I am creating a small lite weight gui to enter data into a text file. This is more of a learning experience then anything. I currently have Perl/tk books on route; however, I am using the Tkx library in Activestate. I have found a number Tk examples to clear the content of a textbox; however, I really cannot find what I am looking for for Tkx - to be honest not sure what I need to look for.

    I need some help with my clear sub

    #!/usr/bin/perl use Tkx; Tkx::wm_title(".", "CSV Book Entry"); Tkx::ttk__frame(".c", -padding => "3 3 12 12"); Tkx::grid( ".c", -column => 0, -row => 0, -sticky => "nwes"); Tkx::grid_columnconfigure( ".", 0, -weight => 1); Tkx::grid_rowconfigure(".", 0, -weight => 1); #Tkx::ttk__entry(".c.feet", -width => 7, -textvariable => \$feet); #Tkx::grid(".c.feet", -column => 2, -row => 1, -sticky => "we"); #Tkx::ttk__label(".c.meters", -textvariable => \$meters); #Tkx::grid(".c.meters", -column => 2, -row => 2, -sticky => "we"); #Tkx::ttk__button(".c.calc", -text => "Calculate", -command => sub {ca +lculate();}); #Tkx::grid(".c.calc", -column => 3, -row => 3, -sticky => "w"); Tkx::ttk__entry(".c.txtbox_file_name", -width => 25, -textvariable => +\$txtbox_file_name); Tkx::grid(".c.txtbox_file_name", -column => 2, -row => 1, -sticky => " +e"); Tkx::ttk__entry(".c.txtbox_title", -width => 25, -textvariable => \$tx +tbox_title); Tkx::grid(".c.txtbox_title", -column => 2, -row => 2, -sticky => "e"); Tkx::ttk__entry(".c.txtbox_author", -width => 25, -textvariable => \$t +xtbox_author); Tkx::grid(".c.txtbox_author", -column => 2, -row => 3, -sticky => "e") +; Tkx::ttk__entry(".c.txtbox_series", -width => 25, -textvariable => \$t +xtbox_series); Tkx::grid(".c.txtbox_series", -column => 2, -row => 4, -sticky => "e") +; Tkx::ttk__entry(".c.txtbox_isbn", -width => 25, -textvariable => \$txt +box_isbn); Tkx::grid(".c.txtbox_isbn", -column => 2, -row => 5, -sticky => "e"); Tkx::ttk__button(".c.enter", -text => "Enter", -command => sub {enter( +);}); Tkx::grid(".c.enter", -column => 1, -row => 6, -sticky => "w"); Tkx::ttk__button(".c.clear", -text => "Clear", -command => sub {clear( +);}); Tkx::grid(".c.clear", -column => 2, -row => 6, -sticky => "we"); Tkx::grid( Tkx::ttk__label(".c.flbl", -text => "FILENAME:"), -column = +> 1, -row => 1, -sticky => "w"); Tkx::grid( Tkx::ttk__label(".c.islbl", -text => "TITLE:"), -column => +1, -row => 2, -sticky => "W"); Tkx::grid( Tkx::ttk__label(".c.mlbl", -text => "AUTHOR:"), -column => +1, -row => 3, -sticky => "w"); Tkx::grid( Tkx::ttk__label(".c.slbl", -text => "SERIES:"), -column => + 1, -row => 4, -sticky => "W"); Tkx::grid( Tkx::ttk__label(".c.isbnlbl", -text => "ISBN:"), -column => + 1, -row => 5, -sticky => "W"); sub enter { $filename = 'bookdb.txt'; open($WRITEFILE, '>>', $filename) or die; #Maybe add values into array??? #@data = qw($txtbox_file_name $txtbox_title $txtbox_author $txtbox_s +eries $txtbox_isbn); $data = "$txtbox_file_name,$txtbox_title,$txtbox_author,$txtbox_seri +es,$txtbox_isbn\n"; print $WRITEFILE "$data"; close $WRITEFILE; } # sub clear { # delete our $txtbox_file_name; # } Tkx::MainLoop();

    Thank you much appreciated

[SOLVED] same utf8 string is different in console and in browser (Sybase)
3 direct replies — Read more / Contribute
by alexander_lunev
on Aug 19, 2017 at 10:45

    Hello, monks! I'm seeking for your wisdom!

    I'm getting strings from various SQL servers via DBI, and those are suppose to be utf8 russian strings. Getting utf8 strings from PgSQL is OK, but with Sybase strings in console looks ok, but when printed to browser via CGI, they're turns into ??????.

    The core of the program is this:

    my $dbh = DBI->connect($db{$dsn}{dsn},$db{$dsn}{user},$db{$dsn}{pa +ssword},$db{$dsn}{opts}); if (!defined($dbh)) { print "Error creating dbh: " . $DBI::errstr . "\n"; exit; } my $sth; $sth = $dbh->prepare($query); if (!$sth) { print "Error: " . $dbh->errstr . "\n"; exit; } if (!$sth->execute) { print "Error: " . $sth->errstr . "\n"; exit; } print "Content-Type: text/html; charset=utf-8\n\n"; my $ref = $sth->fetchrow_arrayref; my $str = $$ref[0]; print $db{$dsn}{driver}." ".$str ." > ".join(" ",map {sprintf("0x% +X",$_)} unpack("C*",$str))."\n";

    In console all strings and bytes are the same:

    # ./sql_test Content-Type: text/html; charset=utf-8 Sybase &#1096;&#1082;&#1086;&#1083;&#1099;#&#1050;&#1072;&#1089;&#1089 +;&#1072; > 0xD1 0x88 0xD0 0xBA 0xD0 0xBE 0xD0 0xBB 0xD1 0x8B 0x23 0xD +0 0x9A 0xD0 0xB0 0xD1 0x81 0xD1 0x81 0xD0 0xB0
    # ./sql_test Content-Type: text/html; charset=utf-8 Pg &#1096;&#1082;&#1086;&#1083;&#1099;#&#1050;&#1072;&#1089;&#1089;&#1 +072; > 0xD1 0x88 0xD0 0xBA 0xD0 0xBE 0xD0 0xBB 0xD1 0x8B 0x23 0xD0 0x +9A 0xD0 0xB0 0xD1 0x81 0xD1 0x81 0xD0 0xB0

    But in browser:

    Sybase ?????#????? > 0x3F 0x3F 0x3F 0x3F 0x3F 0x23 0x3F 0x3F 0x3F 0x3F + 0x3F
    Pg &#1096;&#1082;&#1086;&#1083;&#1099;#&#1050;&#1072;&#1089;&#1089;&#1 +072; > 0xD1 0x88 0xD0 0xBA 0xD0 0xBE 0xD0 0xBB 0xD1 0x8B 0x23 0xD0 0x +9A 0xD0 0xB0 0xD1 0x81 0xD1 0x81 0xD0 0xB0

    So, it's not just browser glitch with encoding, but the very $str is changed!


    UPD: Solution is here 1197669.
Cpanel::JSON::XS crash under Perl 5.26.0
2 direct replies — Read more / Contribute
by Athanasius
on Aug 19, 2017 at 02:52

    I’m trying to install MongoDB for Strawberry Perl 5.26.0:

    This is perl 5, version 26, subversion 0 (v5.26.0) built for MSWin32-x +64-multi-thread-ld

    under Windows 8.1 64-bit. One of MongoDB’s dependencies is BSON. which not only fails to install but actually crashes the Perl interpreter while doing so.

    After some debugging I eventually reduced the problem code to the following SSCCE:

    use strict; use warnings; use JSON::MaybeXS; my $json_codec = JSON::MaybeXS->new; print ref $json_codec, "\n"; print $json_codec->encode( { d => 1.0 } ), "\n";

    Note that I have the following modules installed:

    16:27 >mversion -f JSON::MaybeXS Cpanel::JSON::XS JSON::XS JSON::PP JSON::MaybeXS 1.003009 Cpanel::JSON::XS 3.0233 JSON::XS 3.04 JSON::PP 2.94 16:27 >

    Now to the point: when I run the SSCCE, I get the following output:

    19:26 >perl Cpanel::JSON::XS

    and the Perl interpreter crashes. But if I change the JSON module:

    19:26 >perl -MJSON::XS JSON::XS {"d":1} 19:27 >

    the code completes successfully. I have also tested the SSCCE on Strawberry Perl 5.24.1, and it runs without a problem:

    16:37 >perl Cpanel::JSON::XS {"d":1.0} 16:38 >

    So, I have two sets of questions:

    (1) Can other monks confirm this behaviour under Perl 5.26.0? If so, is it confined to Windows or does it occur on other platforms as well? And does anyone know of a change from 5.24 to 5.26 which could account for this? Should I report it as a bug under Cpanel::JSON::XS?

    (2) Until the bug is fixed, what’s the best way to prevent JSON::MaybeXS from defaulting to Cpanel::JSON::XS? I can add -MJSON::XS to the command line when invoking a Perl script directly, but how can I get cpanm to do this? Or will I need to uninstall Cpanel::JSON::XS from my system?


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

Generic/Variable/Dynamic Subroutines? (Not a redefine)
3 direct replies — Read more / Contribute
by mlewando
on Aug 18, 2017 at 14:50
    I am working on some code for Nagios automations and was curious if there is a way to generalize the following:
    sub WriteLine { my $self = shift; my $it = $self->OStream->WriteLine($_[0]); $self->Trace(_CallerStr($it)); return $it; }; sub Select { my $self = shift; my $it = $self->OStream->Select($_[0]); $self->Trace(_CallerStr($it)); return $it; }; sub Add { my $self = shift; my $it = $self->OStream->Add($_[0]); $self->Trace(_CallerStr($it)); return $it; };
    To something along the line of:
    sub <Call> { my $self = shift; my $it = $self->OStream-><Call>($_[0]); $self->Trace(_CallerStr($it)); return $it; };

    Such that, I can use $Wrapper->Remove($item) and the function '<Call>' is executed and <Call> is substituted with 'Remove'. I can only think of using callbacks and a dispatcher but it seems like I would still have to generate all of the callback subs which I kind of want to avoid. Don't get me wrong it's not like copy/pasting is the end of the world, but why copy paste redundancy if there exists a method where I can almost template it? I would also like the simplicity in $X->Y->Z($item) and not have to work a dispatch and sub-call, which I have done before by passing a dispatch function a 'function name' like:

     if(defined $dev_desc{$tcp_data->Dispatch((USF::Modbus::Modbus::CB_NUMBERS))})

    But then I end up checking function name and data followed by execution, whereas I want something like (kind of a bad example but the point is there):

     if(defined $dev_desc{$tcp_data->Dispatch->Numbers($tcp_data->Value)})

    Maybe an overload? But then I would still have to have overload functions where all I really want to do is have it intuitively fill in the blacks since all of the functions will be doing the same thing since it is essentially a proxy class with subroutine tracing built-in for logging/debugging traceability. If it's not possible then oh well I guess, I just feel like there should be a better solution to excessive redundancy (especially when I am already using a proxy). I also feel it isn't entirely a thing since it would be a nightmare for the interpreter.


Trickery with Getopt::Long (flag option, with optional integer arg)
1 direct reply — Read more / Contribute
by stevieb
on Aug 18, 2017 at 11:03

    I'm in a position with Getopt::Long where I need to allow an option to operate as a flag, but also accept an argument to itself (an integer), and it also must set 0 as the flag value if no integer is passed along with it.

    The only way so far I've found to do it involves a bit of workaround, and I'm just wondering if I'm over thinking this. I haven't found another way to do this, so perhaps I'm overlooking something...

    use warnings; use strict; use Getopt::Long; my $arg = -1; { local $SIG{__WARN__} = sub { $_[0] =~ /^Option arg/ ? $arg = 0 : warn $_[0]; }; GetOptions( 'arg=i' => \$arg ); } print "$arg\n";

    So what that does is sets the argument variable to -1 as a default. If --arg|-a is sent in without an integer value along side it, I catch the warning and if it references the option properly, I set it to 0. If an integer is supplied to the option, things just work as normal.

    I'm happy with the code as it works very well, so I'm just looking to find out if there are built-in or other alternatives for this type of situation.



Nested loops?
5 direct replies — Read more / Contribute
by Speed_Freak
on Aug 17, 2017 at 15:18

    I am working with existing code, and trying to add a "filter" to it. Currently the code pulls an id number and a sequence from a table in the database.(sql1) A foreach loop then permutes each sequence and searches the list to find out if any of the alternates exists. This leads to way more matches than I need because the loop eventually gets to the existing alternates, permutes them, and finds all of the matches again, just with a different primary sequence. I created a second database pull that creates another list with the same id-sequence layout that contains only the primary keys that I want to evaluate. (sql2) I want to use this secondary list as the filter for which sequences are evaluated from the primary list, but I need each key identified in the secondary list to be evaluated against all of the primary list.

    #currently have strict turned off #code snippet foreach my $sql1 (@{$sql1}) { $table1{$sql1->[1]}{$sql1->[0]}=undef; #rearranges the sql pull } foreach my $sql2 (@{$sql2}) { $table2{$sql2->[1]}{$sql2->[0]}=undef; #rearranges the sql pull } my %hash = (); my @array = (); my @bases = ('A','C','G','T'); foreach my $tar1 (keys %table1){ foreach my $tar2 (keys %table2) { if ($tar1 eq $tar2) { #a bunch of follow on code that works if the second foreach and if sta +tements are removed

    I'm just not sure which direction I should go with trying to limit the list it chooses to evaluate, without limiting the list of sequences it uses to evaluate against. I have tried several combinations of foreach/if/where statements and the closest I have gotten lead me to loop through the entire first table, but only using one sequence from the second table. I couldn't get it to iterate through the "filter" table. I'm sure my explanation is lacking severely.

match digit, followed by hyphen, followed again by digit - then add whitespaces and replace in file
4 direct replies — Read more / Contribute
by fasoli
on Aug 17, 2017 at 08:48

    Hi Wise Monks!

    I've been really confused about a problem I'm having with a file. It's a text file, with 4 columns, and with a few thousand lines. The contents are numbers that look like this

    1.234 5.6789 -1.235

    Those files occur as outputs from a software. The problem is that in some cases the contents look like this

    1.234 5.6789-12.235

    *notice the number of the last column: because now there are 2 numbers before the decimal point, the number gets stuck on the second column.

    Naturally now I'm having trouble plotting this file. So I'm trying to match strings where there is a digit, followed by a hyphen, followed by another digit, and then I want to replace this -hopefully correctly- with an added whitespace so that the numbers are correct.

    I'm trying this and the regex match works, it does print the problematic bits:.

    #!/usr/bin/perl use warnings; use strict; my $test; open my $INPUT, '<', "file.txt" or die $!; while (<$INPUT>) { chomp $_; if ($_=~/(\d)(-)(\d)/) { print "$1$2$3 \n"; } }

    But now I'm stuck: how do I complete the replace action? And how do I print the new contents of the file? I haven't succeeded in anything more than compilation errors. In terms of replacing, I've tried this

       if ($_=~s/(\d)(-)(\d)/(\d)    (-)(\d)/) {  

    (supposedly telling the script to add spaces between the digit before the hyphen and the hyphen itself)

    but I get this error

    Unrecognized escape \d passed through

    Then I tried it with the $1$2$3 but again it was wrong. Can you give me any hints about how to make the replace function work?? Thank you so much!

Error 500 in LWP
1 direct reply — Read more / Contribute
by YarNik
on Aug 17, 2017 at 06:25
    Hello! I'm trying to get a https page, half of the domains is OK. But with the other half I get the error:

    500 Can not connect to domen: 443 (connect: Network is unreachable); Client-Warning: Internal response

    The script is standard, I tried to change the agent and different versions of ssl_opts:
    use LWP::UserAgent; $ua = LWP::UserAgent->new( # agent => 'Mozilla/5.0 (X11; U; Linux i686 +; en-US; rv: Gecko/2008120121 Firefox/3.0.5', # ssl_opts => { verify_hostname => 0, SSL_verify_mode => 0, + SSL_verifycn_scheme => 'none' }, ); $response = $ua->head("$get_url"); print $response->dump();
    P.s. domain example, ( bing - it is OK. )
New Cool Uses for Perl
Math::Base - arithmetics with baseX integers
2 direct replies — Read more / Contribute
by shmem
on Aug 22, 2017 at 08:19

    Another "Silly use for Perl" entry.

    Anonymous Monk asked for a method for incrementing mixed letters and numbers recently, which particular need is satisfyed with Math::Base36. Can we do better? I guess, yes.

    use 5.10.0; use Math::Base; my $begin = Math::Base->new(36, 1009, 1); # base, number, is_encoded my $end = Math::Base->new(36, 1020, 1); say $c->encode($_) for $begin .. $end; __END__ 1009 100A 100B 100C ... 101X 101Y 101Z 1020 # Arithmetics with different encodings: $p = Math::Base->new(8,777,1); # decimal 511 $z = Math::Base->new(36, 35); # 'Z' as base36 say $z * $p; # 42735 (octal) say $p * $z; # 'DST' (base36) # Changing the string representation: $s = Math::Base->new(16,18); say $s; # 12 $s->rebase(18); say $s; # 10 $s += 3; # 13 $s->rebase(2); say $s; # 10101 # Get decimal value: $xyz = Math::Base->new(64, 'XYZabc', 1); say $xyz->num; # 36013230438

    Far from complete, but fun enough yet. For me, that is... ;-)

    perl -le'print map{pack c,($-++?1:13)+ord}split//,ESEL'
moon illumination and eclipses
2 direct replies — Read more / Contribute
by no_slogan
on Aug 20, 2017 at 16:00
    Here's a relatively short program that calculates the fraction of illumination of the moon at a given time. This is relevant right now because it's a function of the angle between the sun and the moon. When the angle is small enough, there's a solar eclipse, as we will get a chance to see tomorrow. Unfortunately, the moon wobbles around in the sky too much for a simple program like this to cope with, so it can't produce high-accuracy eclipse predictions, but it might be interesting to some people. Visit JPL for more information.
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 rifling through the Monastery: (4)
As of 2017-08-23 05:29 GMT
Find Nodes?
    Voting Booth?
    Who is your favorite scientist and why?

    Results (347 votes). Check out past polls.