Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
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
FOSDEM 2015 - any news on the party?
No replies — Read more | Post response
by polettix
on Jun 29, 2015 at 17:52
    Hi,

    since when it happened, I'm regularly checking the FOSDEM website for the video of the talk from Larry Wall "get ready to party". It's a bit depressing that so far nothing appeared, and that of all the "main tracks" the one on languages - where the talk should appear - is still empty. I'm using this link: https://video.fosdem.org/2015/.

    Does anyone know if there is some not-so-evident reason that is preventing the release of those videos? Is it just that I need to have some little more patience?

    Thanks, Flavio.

    perl -ple'$_=reverse' <<<ti.xittelop@oivalf

    Io ho capito... ma tu che hai detto?
Restricting access to Perl sacripts based on PKI certs
1 direct reply — Read more / Contribute
by rgwest61
on Jun 29, 2015 at 16:42
    I have a security requirement to limit access to developed Perl scripts within a Linux environment based on a user's PKI certificates. Does something already exist to do such, or is this more of a system security acti
Type::Library messages lost when used with named parameters in Type::Params
1 direct reply — Read more / Contribute
by 1nickt
on Jun 29, 2015 at 15:05

    Hello monks,

    I've noticed that when I use Types that I make with Type::Library, to validate named incoming arguments, with Type::Params, using a slurpy Dict, per the docs, I lose the custom error message set in the library.

    # in package MyModule::Types declare DBPrefix, as Optional[StrMatch[ qr/ \w+_ /x ]], message { 'The table prefix must end in an underscore. ' }; # in package MyModule use Type::Params qw/ compile /; use My::Types qw/ DBPrefix /; state $validate = compile( DBPrefix ); my ($param) = $validate->( @_ ); # in foo.pl $obj->method( 'bar' ); # output: # The table prefix must end in an underscore. (in $_[0]) at ./foo.pl +line 11 # "DBPrefix" is a subtype of "Optional[StrMatch[(?^x: \w+_ )]]" # Value "bar" did not pass type constraint "Optional[StrMatch[(?^x: + \w+_ )]]" (in $_[0]) # $_[0] exists # "Optional[StrMatch[(?^x: \w+_ )]]" constrains $_[0] with "StrMatc +h[(?^x: \w+_ )]" if it exists # Value "bar" did not pass type constraint "StrMatch[(?^x: \w+_ )]" + (in $_[0]) # "StrMatch[(?^x: \w+_ )]" is defined as: do { !ref($_) and $_ =~ $ +Types::Standard::_StrMatch{"(?^x: \\w+_ )"} }

    That's a little more than I really need, but it gives me my custom message at the beginning.

    Now, when I want to go to named arguments, I follow the manual:

    state $validate = compile(slurpy Dict[ prefix => DBPrefix ]); #per the + docs for named args my ($param) = $validate->( @_ ); # in foo.pl $obj->method( 'bar' ); # output : # Reference {"prefix" => "bar"} did not pass type constraint "Dict[pre +fix=>DBPrefix]" (in $SLURPY) at ./foo.pl line 11

    I need to use named args because some of them are completely optional. But I want to be able to return an error that tells the user how to fix the error!

    Has anyone figured a way around this? Thanks ...

Child Net::SSH2 object trouble
2 direct replies — Read more / Contribute
by VinsWorldcom
on Jun 29, 2015 at 15:01

    I'm trying to write my own child class of Net::SSH2, call it 'Net::SSH2::Mine'. I thought I had a pretty good grasp of OO-programming until I encountered the object Net::SSH2 produces - I think it's called 'inside-out'?

    Essentially, I'm trying to open a Net::SSH2 connection but take in a bunch of other parameters specific to the device so I was just going to store them in the returned object, but the 'inside-out object' (and I hope I'm using the right terminology) is boggling my brain.

    Some Google-ing helped me write the following example code which "works", but I don't know what I may be doing right / wrong / breaking / whatever.

    #!perl use strict; use warnings; package Net::SSH2::Mine; use Net::SSH2; our @ISA = qw( Net::SSH2 ); my %NSM; sub new { my $class = shift; my $self = $class->SUPER::new(); $NSM{$self} = { prompt => '#', host => 'host' }; return bless $self, $class; } sub prompt { my $self = shift; return $NSM{[keys %NSM]->[0]}->{prompt} } sub host { my $self = shift; return $NSM{[keys %NSM]->[0]}->{host} } 1; package main; my $ssh = Net::SSH2::Mine->new(); use Data::Dumper; print Dumper \$ssh; print $ssh->prompt . "\n"; print $ssh->host . "\n"; exit;

    And running (on Windows 7 x64 / Strawberry Perl 5.18.1 64-bit - Net::SSH2 0.51 comes in vendor\lib) produces:

    VinsWorldcom@C:\Users\VinsWorldcom\tmp> test.pl $VAR1 = \bless( do{\(my $o = 5182840)}, 'Net::SSH2::Mine' ); # host

    So many questions:

    1. From the Data::Dumper output, is what I'm dealing with from Net::SSH2 an "inside-out object"?
    2. In my new(), should I be re-blessing to my class (Net::SSH2::Mine) - seems the only way to get the ->prompt and ->host accessors in main to work?
    3. Should I be storing parameters (e.g., prompt, host) a different way given this type of object?
    4. Any existing example code you could point me to?

    Lastly, in an earlier version of non-working code, I was getting AUTOLOAD and DESTROY errors when calling the accessors and 'exit' in main respectively. I did read that inside-out-objects require DESTROY, do I need to do something in my Net::SSH2::Mine (sub DESTROY) to facilitate this especially since I'm adding parameters to the object?

A dispatch table to match named params of a sub
4 direct replies — Read more / Contribute
by neilwatson
on Jun 29, 2015 at 12:29

    Greetings,

    I'm trying to craft a dispatch table that will feed a sub that uses named parameters ( my %args = @_ ). I've tried a few combinations, but nothing seems to come out right. What can I do?

    #!/usr/bin/perl use strict; use warnings; use Data::Dumper; use Test::More; my %sub = ( t01 => { name => \&mine, arg => [ qw/one first two second/ ] } ); $sub{t01}->{name}->( $sub{t01}->{arg} ); sub mine { my %args = @_; ok( $args{one} eq 'first', 'arg one' ); ok( $args{two} eq 'second', 'arg two' ); done_testing; }

    Neil Watson
    watson-wilson.ca

What's wrong with this code? PERL HELP!
6 direct replies — Read more / Contribute
by adamadamson
on Jun 29, 2015 at 12:06
    1: sub supercede { 2: 3: my $self = shift; 4: my $records = shift; 5: my $supercede = shift; 6: my $ignore = shift; 7: 8: my (%added, $field, $found, $key, $record, @records, @results, $returned, %superceded, $originalid, $value); 9: 10: foreach $returned (@{$records}) { 11: foreach $field (keys %$supercede) { 12: if ($returned->{$supercede->{$field}}) { 13: foreach $key (keys %{$records}) { 14: if (!grep(/^$key/, @{$ignore})) { 15: $superceded{$returned->{$supercede->{$field}}}->{$key} = $retruned->{$key}; 16: } else { 17: if (!$superceded{$returned->{$field}}) { 18: $found = 0; 19: foreach $record (@{$records}) { 20: if ($record->{$field} == $returned->{$supercede->{$field}}) { 21: $found = 1 22: last; 23: } 24: } 25: 26: if ($found == 0) { 27: $superceded{$returned->{$supercede->{$field}}}->{$key} = $returned->{$key}; 28: } 29: } 30: } 31: } 32: } else { 33: if (!$superceded{$returned->{$field}}) { 34: $superceded{$returned{$field}} = $returned; 35: } 36: } 37: } 38: } 39: 40: foreach $value (values $superceded) { 41: if (!$added{$value}) { 42: push @results, $value; 43: $added{$value} = 1; 44: } 45: } 46: 47: return @result; 48:} I would be very happy if you could correct this files. There are lots of errors on this file. HELP PLEASE
Regex with variables
5 direct replies — Read more / Contribute
by cormanaz
on Jun 29, 2015 at 09:51
    Howdy bros. This is bound to wind up being a stupid question, but why doesn't the following regex work? $test is a substring of $targets, so...
    #!/usr/bin/perl -w use strict; my $targets = '1689 9679 6978 2792 2514 5472 1520 9342 5544 1268 0165 +1979 7314 2101 7221 9539 3882 1812'; my $test = "2101"; if ($test =~ /$targets/) { print "OK"; } else { print "Not there"; }
getting a utc value from julian date
2 direct replies — Read more / Contribute
by Datz_cozee75
on Jun 29, 2015 at 05:43

    Hello Monks,

    I finally have output from the script I've been kicking around to determine when Jupiter and Venus conjoin. The midpoint of the conjunction is at 2015-07-01 14:18:26, although I've been unable to create this value from page output (see question below). The script is long, with 3 different controls, the first to determine a point during the intersection, the second to determine the upper bound, and the third to determine the lower bound. I was unable to use readmore tags, but I'm happy to update this as per suggestion:

    #! /usr/bin/perl use warnings; use strict; use 5.010; use WWW::Mechanize::GZip; use HTML::TableExtract; use HTML::TableExtract qw(tree); use open ':std', OUT => ':utf8'; use Prompt::Timeout; use constant TIMEOUT => 3; use constant MAXTRIES => 16; my $site = 'http://www.fourmilab.ch/yoursky/cities.html'; my $mech = 'WWW::Mechanize::GZip'->new; $mech->get($site); $mech->follow_link( text => 'Portland OR' ); my $lub = 2457204.63659; #least upper bound my $glb = 2457207.63659; #greatest lower bound my @right; my @left; my @julian; $mech->set_fields(qw'date 2'); my ( $vstr, $jstr ) = ( 5, 3 ); <readmore> my $upper = $lub; my $lower = $glb; my $equal; my $equal_sec; my $now_string = localtime; my $filename = 'planet5.txt'; open( my $jh, '>>', $filename ) or die "Could not open file '$filename +' $!"; say $jh "Script executed at $now_string"; say $jh join "\t", "venus", "jupiter", "julian date"; my $attempts = 1; while ( ( $jstr != $vstr ) ) { my $default = ( ( $attempts >= MAXTRIES ) ) ? 'N' : 'Y'; my $answer = prompt( "Make query number $attempts?", $default, TIMEO +UT ); exit if $answer =~ /^N/i; my $guess = median( $upper, $lower ); say "guess is $guess"; push @julian, $guess; $mech->set_fields( jd => $guess ); $mech->click_button( value => "Update" ); my $te = 'HTML::TableExtract'->new; $te->parse( $mech->content ); my $table = ( $te->tables )[3]; my $table_tree = $table->tree; my $venus = $table_tree->cell( 4, 1 )->as_text; my $jupiter = $table_tree->cell( 7, 1 )->as_text; $vstr = string_to_second($venus); say "vstr is $vstr"; push @right, $vstr; $jstr = string_to_second($jupiter); say "jstr is $jstr"; push @left, $jstr; say $jh join "\t", $vstr, $jstr, $guess; if ( $jstr > $vstr ) { $upper = $guess; } elsif ( $vstr > $jstr ) { $lower = $guess; } else { $equal = $guess; say "equal, while condition should fail $equal"; $equal_sec = $vstr; } $te->delete; $attempts++; } my $equal_ra = second_to_string($equal_sec); say "equal_ra is $equal_ra"; say $jh "equal seconds is $equal_sec and equal ra is $equal_ra"; say "right is @right"; say "left is @left"; say "julian is @julian"; ## Determine last best guess that was unequal my $ind1 = get_index( \@right ); say "ind is $ind1"; say "v is $right[$ind1] and jul is $julian[$ind1]"; if ( $ind1 >= 0 ) { $upper = $julian[$ind1]; } else { $upper = $lub; } say "upper is $upper"; $lower = $julian[-1]; say "lower is $lower"; ## find upper bound of convergence range $attempts = 1; while ( ( abs( $upper - $lower ) > .000005 ) ) { my $default = ( ( $attempts >= MAXTRIES ) ) ? 'N' : 'Y'; my $answer = prompt( "Make query number $attempts?", $default, TIMEO +UT ); exit if $answer =~ /^N/i; my $guess = median( $upper, $lower ); say "guess is $guess"; $mech->set_fields( jd => $guess ); $mech->click_button( value => "Update" ); my $te = 'HTML::TableExtract'->new; $te->parse( $mech->content ); my $table = ( $te->tables )[3]; my $table_tree = $table->tree; my $venus = $table_tree->cell( 4, 1 )->as_text; my $jupiter = $table_tree->cell( 7, 1 )->as_text; $vstr = string_to_second($venus); say "vstr is $vstr"; $jstr = string_to_second($jupiter); say "jstr is $jstr"; say $jh join "\t", $vstr, $jstr, $guess; if ( $vstr > $jstr ) { $upper = $guess; } elsif ( $vstr == $jstr ) { $lower = $guess; } else { die "retrograde motion or bad data"; } $te->delete; $attempts++; } say "after upper contraction, upper is $upper"; say "after upper contraction, lower is $lower"; my $end_time = $lower; say $jh join "\t", $upper, $end_time; ## Determine last best guess that was unequal $ind1 = low_index( \@left ); say "ind is $ind1"; say "v is $left[$ind1] and jul is $julian[$ind1]"; if ( $ind1 >= 0 ) { $upper = $julian[$ind1]; } else { $upper = $glb; } $lower = $julian[-1]; say "lower is $lower"; ## find beginning bound of convergence range $attempts = 1; while ( ( abs( $upper - $lower ) > .000005 ) ) { my $default = ( ( $attempts >= MAXTRIES ) ) ? 'N' : 'Y'; my $answer = prompt( "Make query number $attempts?", $default, TIMEO +UT ); exit if $answer =~ /^N/i; my $guess = median( $upper, $lower ); say "guess is $guess"; $mech->set_fields( jd => $guess ); $mech->click_button( value => "Update" ); my $te = 'HTML::TableExtract'->new; $te->parse( $mech->content ); my $table = ( $te->tables )[3]; my $table_tree = $table->tree; my $venus = $table_tree->cell( 4, 1 )->as_text; my $jupiter = $table_tree->cell( 7, 1 )->as_text; $vstr = string_to_second($venus); say "vstr is $vstr"; $jstr = string_to_second($jupiter); say "jstr is $jstr"; say $jh join "\t", $vstr, $jstr, $guess; if ( $vstr < $jstr ) { $upper = $guess; } elsif ( $vstr == $jstr ) { $lower = $guess; } else { die "retrograde motion or bad data"; } $te->delete; $attempts++; } say "after begin contraction, upper is $upper"; say "after begin contraction, lower is $lower"; my $begin_time = $upper; say $jh join "\t", $lower, $begin_time; my $middle = median( $begin_time, $end_time ); say "middle is $middle"; my $duration = $end_time - $begin_time; say "duration is $duration"; say $jh "middle: $middle\t duration: $duration"; # get final disposition $mech->set_fields( jd => $middle ); $mech->set_fields(qw'lat 35 ns North'); $mech->set_fields(qw'lon 80 ew East'); my $te = 'HTML::TableExtract'->new; $te->parse( $mech->content ); my $table = ( $te->tables )[3]; my $table_tree = $table->tree; my $vdistance = $table_tree->cell( 4, 3 )->as_text; my $jdistance = $table_tree->cell( 7, 3 )->as_text; say $jh "vdistance is $vdistance"; say $jh "jdistance is $jdistance"; my $table2 = ( $te->tables )[1]; my $table_tree2 = $table2->tree; my $table_text2 = $table_tree2->as_text; say "table text2 is $table_text2"; my $utc1 = $table_tree->cell( 1, 1 )->as_text; say $jh "utc1 is $utc1"; my $utc2 = $table_tree->cell( 1, 0 )->as_text; say $jh "utc2 is $utc2"; #my $utc = $mech->value(utc); #say "utc is $utc"; sub median { my ( $up, $low ) = @_; my $return = ( $up + $low ) / 2.0; return $return; } sub string_to_second { my $string = shift; my $return = 9000; if ( my $success = $string =~ /^(\d*)h\s+(\d*)m\s+(\d*)s$/ ) { $return = 3600 * $1 + 60 * $2 + $3; } else { say "string was misformed"; } return $return; } sub second_to_string { my $seconds = shift; my $hours = int( $seconds / 3600 ); my $remainder = $seconds % 3600; my $minutes = int( $remainder / 60 ); my $sec = $remainder % 60; my $return = join '', $hours, 'h ', $minutes, 'm ', $sec, 's'; return $return; } sub get_index { my ($ref_right) = shift; my @right = @$ref_right; my $return = -1; my $eq = $right[-1]; say "right is @right"; say "eq is $eq"; for my $i ( 0 .. $#right ) { if ( $right[$i] <= $eq ) { next; } else { $return = $i; say "i is $i"; } } say "right is @right"; return $return; } sub low_index { my ($ref_right) = shift; my @right = @$ref_right; my $return = -1; my $eq = $right[-1]; say "right is @right"; say "eq is $eq"; for my $i ( 0 .. $#right ) { if ( $right[$i] >= $eq ) { next; } else { $return = $i; say "i is $i"; } } say "right is @right"; return $return; } </readmore>

    Output to planet5.txt:

    Script executed at Mon Jun 29 02:10:13 2015 venus jupiter julian date 34790 34686 2457206.13659 34682 34653 2457205.38659 34628 34636 2457205.01159 34655 34644 2457205.19909 34641 34640 2457205.10534 34634 34638 2457205.058465 34638 34639 2457205.0819025 34640 34640 2457205.09362125 equal seconds is 34640 and equal ra is 9h 37m 20s 34640 34640 2457205.09948062 34641 34640 2457205.10241031 34641 34640 2457205.10094547 34641 34640 2457205.10021305 34641 34640 2457205.09984684 34641 34640 2457205.09966373 34641 34640 2457205.09957218 34640 34640 2457205.0995264 34641 34640 2457205.09954929 34640 34640 2457205.09953785 34640 34640 2457205.09954357 34640 34640 2457205.09954643 2457205.09954929 2457205.09954643 34639 34640 2457205.08776187 34639 34640 2457205.09069156 34639 34640 2457205.09215641 34640 34640 2457205.09288883 34639 34640 2457205.09252262 34639 34640 2457205.09270572 34640 34640 2457205.09279728 34640 34640 2457205.0927515 34640 34640 2457205.09272861 34639 34640 2457205.09271717 34639 34640 2457205.09272289 34639 34640 2457205.09272575 2457205.09272861 2457205.09272575 middle: 2457205.09613609 duration: 0.0068206787109375 vdistance is 0.512 jdistance is 6.083 utc1 is utc2 is

    The site deals with julian times, which are good for being continuous, but they're unrecognizable as modern dates without a computation. I seem unable to get the value of the utc that I'm looking at by the end of this exercise. I've commented out a $mech->value call that I just can't wrap my head around, so I'm fishing for tips there

    Alternatively, I'd be happy with creating a DateTime object from julian, but I don't see that as one of the options (one can go the other direction).

    I have a bunch of other questions about the perl of this, and frankly, the physics of it, too, but I just wanted to get this up and posted before the actual event occurs.

find a substring of unknow lenght if it is in a hash
4 direct replies — Read more / Contribute
by perlynewby
on Jun 29, 2015 at 04:33

    Ok, I need a bit of advice on how to attack this problem. I will construct the loop but need a little bit of help with proper syntax

    assume, I got a substring and, a part of that str (like maybe 2 letters to 9 letters) can match an already existing key in a hash.

    1. what I am unsure about is how to check each character in the string (substring) against the key in hash. proper syntax

    2. what is the key if not provided to me yet , how to check this...

    #implement learnings: #substring matching ~~ #incremental substring match against a key that may not be given yet. +return 0 learning... #maybe add counter of the times the substring match a key use strict; use warnings; use diagnostics; my %match: my @char; my $str = 'abcdefghjki'; #substr could match a 2 letter key or 10 letter to a hash key... my @char = split //, $str; #assigned string into array to check foreach my $key (keys %match){ if($match->[0] ~~ @char) # i don't know how to check an incremental t +est for the substring against the key in hash.don't know proper synta +x. { #do something } } #return num of times sub finds in for my $keys ($keys){ $match{$keys}++; print "this is the number of times we see for $keys :",$match{$k +ey},"\n"; }
Convert strings with unknown encodings to html
4 direct replies — Read more / Contribute
by Pascal666
on Jun 29, 2015 at 02:54

    I need to pull strings out of a database and format them for display on a web page. Individually this is not a problem, but the strings are in various formats in the database and I'm having trouble figuring out a sequence of conversions that will handle all inputs. The strings are mostly ascii, but some of them have special characters embedded.

    The below program creates a sample array of characters from the database, then converts them to html. I manually figured out what needs to be done to each character. I need to replace the noted two lines with something that can automatically handle the various formats.

    #!/usr/bin/perl -W use strict; use warnings; use feature 'say'; use Encode qw(decode encode); use HTML::Entities; my @in = (chr(226).chr(152).chr(134), chr(195).chr(161), chr(150), chr +(153), '&reg;', '&', '&AElig;', chr(63743), chr(991), chr(9760)); decode_entities($_) for @in; #The below two lines need to be replaced $in[$_] = decode ('utf8', $in[$_]) for 0..1; $in[$_] = decode ('cp1252', $in[$_]) for 2..3; say encode_entities($_) for @in;
    output: &#x2606; &aacute; &ndash; &trade; &reg; &amp; &AElig; &#xF8FF; &#x3DF; &#x2620;

    Thank you for any assistance you can render.


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!
  • 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 the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others wandering the Monastery: (6)
    As of 2015-06-30 03:32 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      What kind of chocolate gives you the most pleasure?















      Results (775 votes), past polls