Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

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
Tk::LabEntry - how to reach the configuration of label via callback?
1 direct reply — Read more / Contribute
by vagabonding electron
on Feb 07, 2016 at 08:28
    Hi All,

    I try to validate the content of entry in Tk::LabEntry widget. I would like to change the configuration of the label part if the content is not a number (simply to color it red). I can do this with the background of the entry (code below), however an attempt to reach the option -labelBackground produces an error message "unknown option".

    I know that Tk::LabEntry is a Mega-Widget. I cannot find a way to reach its configuration (that is, the label part) via callback. It would work if I call the widget by name (that is,  $le->configure(-labelBackground => 'red'); would do the job in the code below). I would like to stick with callback however since I have several such widgets in the real application.

    Please give me an advice. Thank you!

    #!/perl use strict; use warnings FATAL => qw(all); use Tk; use Tk::LabEntry; use List::Util qw(first); use Scalar::Util qw(looks_like_number); my $mw = MainWindow->new(); $mw->title("Test"); my $test = 8; my $width = 250; my $length = 125; $mw->minsize($width, $length); my $FONT = $mw->fontCreate(-family => 'verdana', -size => 14, -weight => 'normal'); my $le = $mw->LabEntry(-label => 'Value', -labelPack => [qw/-side left -anchor w/], -labelFont => '9x15bold', -font => $FONT, -relief => 'ridge', -textvariable => \$test, -width => 2, )->pack(); $le->bind('<Key>' => sub { labelCheck($_[0]);}); MainLoop; sub labelCheck { my $x = $_[0]->get(); if ( !(looks_like_number($x)) or ($x < 0) ) { $_[0]->delete(0, 'end'); $_[0]->configure( -background => 'red'); # $_[0]->configure( -labelBackground => 'red'); } else { $_[0]->configure( -background => '#f0f0f0',); # $_[0]->configure( -labelBackground => '#f0f0f0'); do_something(); } return 1; } sub do_something { print $test, $/; }
Getting stranger values in subtraction
5 direct replies — Read more / Contribute
by Anonymous Monk
on Feb 06, 2016 at 02:50

    Dear Monks,

    I am at my wits' end over the values "-3.5527136788005e-015" and "-1.4210854715202e-014" when 0 is expected in each case. I'm on Windows Perl 5.14.

    Essentially, what I am doing is to subtract a total amount (a session value) from each item's amount. Sometimes I get the expected 0 but sometimes I get strange values even though last amount to be subtracted from the total amount is equal to that total amount:

    foreach my $key (sort keys %$cart_info) { my $qty = $cart_info->{$key}->{qty}; my $amount = $cart_info->{$key}->{amount}; $session->param('CART')->{total_amount} -= $amount; $session->param('CART')->{total_qty} -= $qty;; } # First sample Before: session_total_amt: 585.86 After: key: 116, amount: 112.09, session_total_amt: 473.77 Before: session_total_amt: 473.77 After: key: 117, amount: 69.75, session_total_amt: 404.02 Before: session_total_amt: 404.02 After: key: 118, amount: 113.57, session_total_amt: 290.45 Before: session_total_amt: 290.45 After: key: 123, amount: 113.57, session_total_amt: 176.88 Before: session_total_amt: 176.88 After: key: 124, amount: 69.75, session_total_amt: 107.13 Before: session_total_amt: 107.13 After: key: 125, amount: 80.89, session_total_amt: 26.24 Before: session_total_amt: 26.24 After: key: 50, amount: 26.24, session_total_amt: -3.5527136788005e-01 +5 # Notice that both the session_total_amt and the amount to be subtract +ed are 26.24. How did I end up with -3.5527136788005e-015? # Second sample Before: session_total_amt: 319.02 After: key: 116, amount: 112.09, session_total_amt: 206.93 Before: session_total_amt: 206.93 After: key: 117, amount: 69.75, session_total_amt: 137.18 Before: session_total_amt: 137.18 After: key: 118, amount: 113.57, session_total_amt: 23.61 Before: session_total_amt: 23.61 After: key: 56, amount: 23.61, session_total_amt: -1.4210854715202e-01 +4 # Same thing here. The session_total_amt and the amount to be subtract +ed are both 23.61.

    What am I missing here? (scratch head)?

OpenSSL and Crypt::CBC don't give the same ciphertext
3 direct replies — Read more / Contribute
by LonelyPilgrim
on Feb 05, 2016 at 18:36

    Greetings, Wise Monks. I am a wayfarer returned from many travels.

    I'm taking a Network Security course and am pretty much a novice when it comes to encryption. My assignment asks me to encrypt and decrypt a 1024-byte plaintext (which happens to be a transcript from the opening of Zork) by calling the OpenSSL binary -- but that's kind of slow, I suspect owing in part to the latency of launching new processes and file I/O, so I had (what I thought to be) the bright idea of doing the decryption separately in Perl (using Crypt::CBC) and timing the difference.

    That's all well and good; doing it the Perl way appears to be considerably faster; but here's my problem: I can't get OpenSSL and Crypt::CBC to give me the same ciphertext. Can anybody help me figure out what I am doing wrong?

    My code:

    #!/usr/bin/env perl use strict; use warnings 'all'; my $test_in = 'test.txt'; my $test_out = 'test.bin'; my $cipher = 'des-cbc'; my $iv = '0123456789ABCDEF'; my $fixed_key = '0123456789ABCDEF'; open (my $infile, '<', $test_in) or die "Couldn't open $test_in for input: $!"; undef $/; my $plaintext = <$infile>; close ($infile); # OpenSSL my $enc = "openssl enc -$cipher -iv $iv -nosalt -out $test_out -K $fix +ed_key"; print "$enc\n"; open (my $pipe, "|-", $enc); print $pipe $plaintext; close $pipe; # Crypt::CBC require Crypt::CBC; require Crypt::Cipher::DES; $iv = pack("h*", $iv); $fixed_key = pack("h*", $fixed_key); my $crypt = Crypt::CBC->new( -cipher => 'Cipher::DES', -iv => $iv, -key => $fixed_key, -literal_key => 1, -header => 'none', ); my $ciphertext = $crypt->encrypt($plaintext); open (my $cipherout, '>', 'cryptx.bin') or die "Couldn't open cryptx.bin for output: $!"; binmode($cipherout); print $cipherout $ciphertext; close $cipherout;

    Comparing test.bin (the output from OpenSSL) and cryptx.bin (the output from Perl) shows that the two are completely different from the first byte. The files are the same length (1032 bytes) and do not change with each run.

    UPDATE: I fixed it. Oh, I'm an idiot. Endianness: so simple and yet so important. It should have been H* instead of h* in my pack statements. Fix that, and it gives the right result.

How to not send TLS 1.0 on https soap call
1 direct reply — Read more / Contribute
by davew
on Feb 05, 2016 at 13:29

    I had a perl app to query some data via SOAP, and it was working up until yesterday. Now I just get the error:

    LWP::Protocol::https::Socket: SSL connect attempt failed at /usr/lib/perl5/site_perl/5.8.8/LWP/Protocol/http.pm line 47.

    Someone from the server team told me they just upgraded to no longer support TLS 1.0. I've tried a few things (including upgrading my openssl library from 0.9.8 to 1.0.1), and still can't get it working.

    Here is the snippet of what was working before:

    #!/usr/bin/perl use strict; use LWP::UserAgent; use HTTP::Request; use HTTP::Response; my $ua = LWP::UserAgent->new(); $ua->ssl_opts( SSL_ca_file => '/var/www/cgi-bin/sz/api/apisb-fullrootchain.crt', SSL_verifycn_scheme => 'http', SSL_verifycn_name => 'apisandbox.zuora.com' ); my $req = HTTP::Request->new(POST => 'https://apisandbox.zuora.com/app +s/services/a/68.0'); $req->header( 'Content-Type' => 'text/xml; charset=utf-8', 'SOAPAction' => 'login' ); $req->content($xml_content); my $resp = $ua->request($req);

    In addition to upgrading openssl library, I also tried adding the SSL_version param to ssl_opts call (trying all kinds of permutations of the version string such as tlsv1_1, tlsv11, etc).

    $ua->ssl_opts( SSL_version => '!TLSv1', SSL_ca_file => '/var/www/cgi-bin/sz/api/apisb-fullrootchain.crt', SSL_verifycn_scheme => 'http', SSL_verifycn_name => 'apisandbox.zuora.com' );

    Also, I tried this with similar permutations:

    my $context = new IO::Socket::SSL::SSL_Context( SSL_version => '!tlsv1', ); IO::Socket::SSL::set_default_context($context);

    Here are my specifics:

    [root@one-commerce-vm.cs.qai install]# perl -MIO::Socket::SSL -e 'prin +t "$IO::Socket::SSL::VERSION\n"' 2.023 [root@one-commerce-vm.cs.qai install]# perl -MNet::SSLeay -e 'print "$ +Net::SSLeay::VERSION\n"' 1.72 [root@one-commerce-vm.cs.qai install]# perl -MNet::HTTP -e 'print "$Ne +t::HTTP::VERSION\n"' 6.09 [root@one-commerce-vm.cs.qai install]# perl -MLWP::UserAgent -e 'print + "$LWP::UserAgent::VERSION\n"' 6.15 [root@one-commerce-vm.cs.qai install]# openssl version -a OpenSSL 1.0.1g 7 Apr 2014 built on: Fri Feb 5 09:19:23 PST 2016 platform: linux-x86_64 options: bn(64,64) rc4(16x,int) des(idx,cisc,16,int) idea(int) blowfi +sh(idx) compiler: gcc -DOPENSSL_THREADS -D_REENTRANT -DDSO_DLFCN -DHAVE_DLFCN_ +H -Wa,--noexecstack -m64 -DL_ENDIAN -DTERMIO -O3 -Wall -DOPENSSL_IA32 +_SSE2 -DOPENSSL_BN_ASM_MONT -DOPENSSL_BN_ASM_MONT5 -DOPENSSL_BN_ASM_G +F2m -DSHA1_ASM -DSHA256_ASM -DSHA512_ASM -DMD5_ASM -DAES_ASM -DVPAES_ +ASM -DBSAES_ASM -DWHIRLPOOL_ASM -DGHASH_ASM OPENSSLDIR: "/usr/local/ssl"

    Any suggestions appreciated!

Need help to remove AutoLoader in Tx::Text::SuperText
2 direct replies — Read more / Contribute
by capfan
on Feb 05, 2016 at 13:06

    Hi all!

    I just got co-maint on Tk::Text::SuperText. I wanted to make it look better, like having a lib folder and tests.

    There is also some issues in this module and I would like to investigate. However, the module does use AutoLoader, which makes it harder for me to understand the module.

    So I tried to remove AutoLoader. Simply remove the use AutoLoader statement, remove the __END__ block and move all method inside the module.

    But then it happens: suddently, stuff that worked before does not work anymore. To be precise: With the current state of the module (v0.9.5), typing a < works fine. With the new state, with the adjustments as described above, it crashes immediately.

    How can this be? Any ideas welcome.

File::Find traversing a link into a mounted flash drive
1 direct reply — Read more / Contribute
by swampyankee
on Feb 05, 2016 at 12:40

    I did a quick search, but didn't quite find anything that was sufficiently close to be an answer

    I'm trying to use File::Find to find image files, so I can randomly change my wallpaper. I know; it's a silly task ⌣. My problem is that I have a bunch of image files on a flash drive, and File::Find won't follow a symbolic link to the contents of the flash drive. I suspect it's because File::Find, even when $File::Find::follow is set won't recurse into a different file system.

    I'm using Fedora 21, Perl v5.18.4, File::Find version 1.23.

    sub image_search { my $name = $File::Find::name; my $dir = $File::Find::dir; my @globbed; my @temp; my $images = '(png$)|(jpg$)|(gif$)|(jpeg$)'; if (-l $name) { print "processing link named $name\n"; @globbed = glob("$name/*"); } else { print "processing directory named $dir\n"; @globbed = glob("$dir/*"); } if (@globbed) { @globbed = grep {m/$images/i} @globbed; $image_list{$dir} = [@globbed]; } } ## end sub image_search
    Sorry for the a) less-than-optimal code design and b) absence of comments.

    Information about American English usage here and here. Floating point issues? Please read this before posting. — emc

Appending Text of One XML Node to that of the Other
4 direct replies — Read more / Contribute
by thomasd
on Feb 04, 2016 at 17:47

    I am having difficulties trying to figure out how to append the text from one Child Node to that of another before moving to the next parent.

    I have tried using a few different XML libraries and am currently testing XPath. That is before I decide to just write my own parser which I would rather not do right now.

    The following is a sample of the XML page

    <xdoc> <MsgSigs> <MsgSig> <Description>TSC1 - Torque/Speed Cntrl 1</Description> <Key>ln1</Key> <XtdFrame>True</XtdFrame> <NetworkKey>net0</NetworkKey> <MsgSignals> </MsgSignals> </MsgSig> <MsgSig> <Description>TSC1 - Torque/Speed Cntrl 1</Description> <Key>ln2</Key> <XtdFrame>True</XtdFrame> <NetworkKey>net0</NetworkKey> <MsgSignals> <Signal> <Description>0_SPN695 Eng. Override </Description> <Key>sig695</Key> <ValueType>1</ValueType> </Signal> </MsgSignals> </MsgSig> </xdoc>

    What I am trying to do is loop through the MsgSig nodes and take the key (eg, ln1, ln2) and append this key to the Description. Note: I am not wanting to go into the Signal Node (why I ruled out DOM). The result would look something like this

    <xdoc> <MsgSigs> <MsgSig> <Description>TSC1 - Torque/Speed Cntrl 1 (ln1)</Description> <Key>ln1</Key> <XtdFrame>True</XtdFrame> <NetworkKey>net0</NetworkKey> <MsgSignals> </MsgSignals> </MsgSig> <MsgSig> <Description>TSC1 - Torque/Speed Cntrl 1 (ln2)</Description> <Key>ln2</Key> <XtdFrame>True</XtdFrame> <NetworkKey>net0</NetworkKey> <MsgSignals> <Signal> <Description>0_SPN695 Eng. Override </Description> <Key>sig695</Key> <ValueType>1</ValueType> </Signal> </MsgSignals> </MsgSig> </xdoc>

    As I mentioned I am currently using XPath and as a test have made it to here and here is where I sit.

    #!/usr/bin/perl -w use XML::XPath; use Data::Dumper; $file = "test.xml"; $xp = XML::XPath->new(filename => $file); @nodes = $xp->findnodes("/xdoc/MsgSigs/MsgSig"); foreach (@nodes) { $key = $_->findvalue('Key'); $descr = $_->findvalue('Description'); $text = $descr . "(" . $key . ")"; # A setValue would be awesome right about now or an # appendtext $_-> print $_->findvalue('Description'), "\n"; } #print out to xml file

    Any help would be very much appreciated.

    D. Thomas

Invalid value for shared scalar
3 direct replies — Read more / Contribute
by SwaJime
on Feb 03, 2016 at 14:31

    Hello again :-)

    Hopefully this is a simple problem ... I'd like some help getting this second method to work.

    I am working with a class that contains the following method:

    # Adds fields to a shared object sub set { my ($self, $tag, $value) = @_; lock($self); $self->{$tag} = shared_clone($value); }

    I'm trying to add a second method similar to the first:

    # Adds sub fields to a shared object sub set_alwd_info { my ($self, $tag, $value) = @_; lock($self); 43: $self->{ALWD_INFO}{$tag} = shared_clone($value); }

    But I'm getting this error when I try to run it:

    Invalid value for shared scalar at ./thread line 32.

    Full sample code:

    #!/usr/bin/perl # package ALWD::Cows; use strict; use warnings; use threads; use threads::shared qw(share is_shared shared_clone); # Constructor sub new { my $class = shift; share(my %self); # $self{ALWD_INFO} = {}; # ... ... ... my $self = bless(\%self, $class); return $self; } # Adds fields to a shared object sub set { my ($self, $tag, $value) = @_; lock($self); $self->{$tag} = shared_clone($value); } # Adds sub fields to a shared object sub set_alwd_info { my ($self, $tag, $value) = @_; lock($self); $self->{ALWD_INFO}{$tag} = shared_clone($value); } package main; my $sample = ALWD::Cows->new(); $sample->set("Key1", "Value1"); $sample->set_alwd_info("Key2", "Value2");
Getting IO::Compress::Zip to include directory entries (on Windows)
3 direct replies — Read more / Contribute
by hilitai
on Feb 02, 2016 at 17:16

    My task is: take a zip file (really a .war file, but I assume that's neither here nor there), uncompress it into a directory structure, manipulate a few files, and rezip it into a new zip file.

    I think I'm about 99% there. I've got a small script that uses IO::Uncompress::Unzip and IO::Compress::Zip to extract the files and then recompress them. However, when I do the recompression, I can't get the zip method of IO::Compress::Zip to include directory entities, as the original war file did. For example, the original file contains an entry for the directory WEB-INF/. My output file contains entries for all the files within WEB-INF/, but nothing for the directory itself.

    Here's some sample code. Assume two files, tc.html and tc.html.gz, and a directory, WEB-INF. The following code will compress the two files into a zip:

    #!/usr/bin/perl use strict; use warnings; use IO::Compress::Zip qw(:all); my $outfile = "test.zip"; my @dirs = ("tc.html", "tc.html.gz"); zip \@dirs => "$outfile", BinModeIn => 0 or die "$!"; print "Done\n";

    But I can find no variant of that zip invocation that will include the directory without dying, e.g.:

    my @dirs = ("tc.html", "tc.html.gz", "WEB-INF");

    Running with this modification gets me:

    Died at C:\Temp\zipSnip.pl line 10.

    Am I missing some option? Or am I stuck?

    Note that I am using IO::Compress and IO::Uncompress because I am trying to use *only* core modules. I don't think Archive::Zip counts.

Text::CSV and getline_hr_all
2 direct replies — Read more / Contribute
by neilwatson
on Feb 01, 2016 at 15:47

    Greetings, I'm trying to get Text::CSV's getline_hr_all to slurp an entire CSV into a data structure, but the structure appears empty. What is my mistake?

    UPDATE: Allow_loose_quotes is the winner.

    #!/usr/bin/perl use strict; use warnings; use Data::Dumper; use Text::CSV; my $file = $ARGV[0]; my $csv = Text::CSV->new ({ sep_char => '|', allow_whitespace => 1, binary => 1, eol => "|$/", allow_loose_quotes => 1, ## <--added for the win }); open my $csv_file, "<", $file or die "Cannot open [$file] [$!]"; my $headers_ref = $csv->getline($csv_file) or die "no header"; $csv->column_names($headers_ref); my $table_ref = $csv->getline_hr_all($csv_file); close $csv_file; print "headers: ".Dumper( $headers_ref ); print "table: ".Dumper( $table_ref );

    A Some lines of the csv:

    job_execution_id | job_status | step_name | job_params | job_instance +_id | read_count | write_count | exit_message | 625 | FAILED | parseSchemaStep | {"dataFeedURI":"\/storage\/D1200. +txt","metadataID":"meta.xml","Date":"2015-07-31","Id":"146"} | 625 | + 0 |0 | org.springframework.integration.transformer.MessageTransforma +tionException: ; nested exception is org.springframework.messaging.Me +ssageHandlingException: ; nested exception is java.io.IOException: IO +Exception encountered while retrieving metadata. at org.springframework.integration.transformer.MessageTransformingHand +ler.handleRequestMessage(MessageTransformingHandler.java:74) |

    Now run it:

    $ ./readjoblog.pl failedjob.csv headers: $VAR1 = [ 'job_execution_id', 'job_status', 'step_name', 'job_params', 'job_instance_id', 'read_count', 'write_count', 'exit_message' ]; table: $VAR1 = [];

    Neil Watson
    watson-wilson.ca

New Meditations
Role Composition versus Inheritance
No replies — Read more | Post response
by choroba
on Feb 07, 2016 at 15:37
    I use Moo in my latest toy project. When experimenting with Moo::Role, I discovered the rules of interaction of role composition and inheritance are not specified in detail, and the current behaviour surprised me a bit.

    In the examples below, I'll use Role::Tiny, as that's what Moo::Role uses under the hood, and it also contains all the important documentation.

    The basic rule of role composition is the following:

    If a method is already defined on a class, that method will not be composed in from the role.

    Let's see an example:

    #! /usr/bin/perl use warnings; use strict; use feature qw{ say }; { package MyRole; use Role::Tiny; sub where { 'Role' } sub role { 'yes' } } { package MyClass; sub new { bless {}, shift } sub where { 'Class' } } { package MyComposed; use Role::Tiny::With; with 'MyRole'; sub new { bless {}, shift } sub where { 'Composed' } } my $c = 'MyComposed'->new; say $c->$_ for qw( where role );

    Output:

    Composed yes

    The "yes" shows the role was composed into the class, but the "where" method still comes from the original class. So far, so good.

    What do you think should happen, if the class doesn't implement the method, but inherits it from a parent?

    { package MyHeir; use parent -norequire => 'MyClass'; use Role::Tiny::With; with 'MyRole'; } my $h = 'MyHeir'->new; say $h->$_ for qw( where role );

    For me, the output was surprising:

    Role yes

    The same happens when you apply the role to an instance of a class:

    my $o = 'MyClass'->new; 'Role::Tiny'->apply_roles_to_object($o, 'MyRole'); say $o->$_ for qw( where role );

    We started with an object of a class that implemented the where method, but the resulting object uses the role's method. Maybe because a new class is created for the object inheriting from the original one, and the role is then applied to it, as with MyHeir above?

    In fact, I needed that behaviour. As it's not documented explicitely, though, I decided to program defensively, require the where method, and use the around modifier for better readability and clearer specification of the intent:

    { package MyAround; use Role::Tiny; requires 'where'; around where => sub { 'Around' }; sub role { 'yes' } } my $o2 = 'MyClass'->new; 'Role::Tiny'->apply_roles_to_object($o2, 'MyAround'); say $o2->$_ for qw( where role );

    Even if the composition rules changed, my object would still get the where method from the role.

    ($q=q:Sq=~/;[c](.)(.)/;chr(-||-|5+lengthSq)`"S|oS2"`map{chr |+ord }map{substrSq`S_+|`|}3E|-|`7**2-3:)=~y+S|`+$1,++print+eval$q,q,a,
Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others romping around the Monastery: (9)
As of 2016-02-08 11:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How many photographs, souvenirs, artworks, trophies or other decorative objects are displayed in your home?





    Results (274 votes), past polls