Beefy Boxes and Bandwidth Generously Provided by pair Networks
good chemistry is complicated,
and a little bit messy -LW
 
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
error in POE::Component::Client::Telnet manpage?
1 direct reply — Read more / Contribute
by Anonymous Monk
on Feb 16, 2020 at 20:01
    In the POE::Component::Client::Telnet manpage it has a "sub result" with a typo in it.
    print STDERR join(' ', @{ $ref->{error} ) . "\n";
    should that be:
    print STDERR join(' ', @{ $ref->{error} } ) . "\n";
Find element in array
7 direct replies — Read more / Contribute
by Sofie
on Feb 16, 2020 at 07:36
    Hi I am very new to perl and struggling with simple things... I am trying to check if an input DNA sequence only contains nucleotides. And if it doesn't I want to print out the position in the sequence where an invalid character was entered. This is as far as I have come:
    #!/usr/bin/perl -w $DNA = <STDIN>; chomp ($DNA); @DNA = split ("", $DNA); $lengthseq = scalar @DNA; print "The length of the sequence is:\n", $lengthseq, "\n"; @nucleotideDNA = ""; #check if each element in array is nucleotide foreach $nucleotide (@DNA){ if ($nucleotide =~ /^[ATCG]+$/){ push @nucleotideDNA, $nucleotide; } else { push @nonvalid, $nucleotide; } }
    But how can I print the position of the non valid character? Not sure if this makes any sense.. Thanks
Match something that does not match
1 direct reply — Read more / Contribute
by jo37
on Feb 15, 2020 at 12:42
    Hi,

    every now and then I stumble upon the question of how to match something that doesn't match something else. I.e. some expression in the sense of [^...]* for a general given regex $match. The best I got so far is:

    my $does_not_match = qr{((?:.*?(?=$match))|(?:(?:.(?!$match))*))};

    The first branch matches a substring up to the given regex $match if there is a match and the second branch matches the whole string if there is no match. Both fail in the opposite case. (The second branch by missing the last character.)

    Does anybody know something simpler? Or do you see any issues with the given regex?

    Here is a small example:

    #!/usr/bin/perl use Test2::V0; sub do_not_match { my $pat = shift; return qr{(?:.*?(?=$pat))|(?:(?:.(?!$pat))*)}; } my $re = do_not_match(qr{\b[aeiou][a-z]*ion\b}); is [/($re)/], ['stimulated '], 'matches prefix' for 'stimulated emission of radiation'; is [/($re)/], ['electron transition'],'no match' for 'electron transition'; is [/($re)/], [''], 'matches empty prefix' for 'absorbtion of photons'; is [/($re)/], ['light '], 'matches not greedy' for 'light amplification by stimulated emission of radiation'; is [/($re)\bimpact/], ['electron '], 'gives characters back' for 'electron impact ionization'; done_testing;

    I might put this into an extension module for Regexp::Common, but I'm not sure if this makes sense at all. And what would a proper naming be? Maybe something like:

    use Regexp::Common 'do_not_match'; my $re = $RE{do_not}{-match => 'something'}

    Your opinions?

    -jo

wiki regex reprocessing replacement
4 direct replies — Read more / Contribute
by LanX
on Feb 15, 2020 at 09:39
    Hi

    Task

    I need a regex to transform wiki markup surrounding words to html, * to <b> etc.

    my problem is that */_ could be combined at word boundaries, see the following example

    DB<66> $_=$wiki; tf();tf();tf() ; print "'$wiki' \n=>\n'$_'" '_*one /two/*_ _*three /four/*_ _*five /six/*_' => '<u><b>one <i>two</i></b></u> <u><b>three /four/</b></u> <u><b>five <i +>six</i></b></u>' DB<67>
    '_*one /two/*_ _*three /four/*_ _*five /six/*_'
    =>
    'one two three /four/ five six'
    

    as you can see I have to run the tf() transformation thrice

    DB<40> %h = ( '*'=>'b', '/' => 'i' , '_' => 'u' ) DB<59> sub tf { s{ $pre ([_*/]) (.*?) \2 $post}{$1<$h{$2}>$3</$h{$2} +>$4}xg } DB<62> $pre = qr/(^|\s|>)/ DB<63> $post = qr/($|\s|<)/ DB<65> $wiki='_*one /two/*_ _*three /four/*_ _*five /six/*_'

    Question

    Is there a way to make it a one-run transformation?

    Trouble is that /g continues after the inserted replacement, here underline

    I was experimenting with lookaround-assertions and \G and couldn't get it done.

    Approaches

    The only ways I can (theoretically) think of so far are

    • to loop over /g in scalar context while (s///g) { ... } and to manipulate pos
    • or to manipulate pos in an embedded Perl code (?{...})
    • to call tf() recursively in the /e evaled replacement part
    NB: It's a more theoretical question because running tf() three times doesn't pose problems.

    UPDATE:

    I just noticed a bug, since four wasn't expanded.

    &tf has to be better written with a lookbehind which doesn't consume the next whitespace

    DB<90> sub tf { s{ $pre ([_*/]) (.*?) \2 (?=$post)}{$1<$h{$2}>$3</$h +{$2}>}xg }

    I'll update an SSCCE soon.

    Cheers Rolf
    (addicted to the Perl Programming Language :)
    Wikisyntax for the Monastery

DBI, DBD::Oracle, Inconsistent Fetch Failures
1 direct reply — Read more / Contribute
by perldigious
on Feb 14, 2020 at 17:54

    Hi Monks,

    So I'm still having major issues with inconsistent/intermittent data fetch failures from my company's Oracle DB. I've been digging, a lot, and I may have narrowed down the issue further based on some earlier suggestions from the Monastery... but I still don't have a solid solution. I think this is an Oracle DB datatype issue, where there is a mismatch between what the DB has and DBD::Oracle is expecting, but being a newbie I'm not sure that's correct. Here is the relevant portion of the script I'm currently trying and using tracing options on to try and debug further.

    use strict; use warnings; use DBI; use DBD::Oracle qw(:ora_types); print "Establishing DWASAS connection...\n"; # establish database connection and enable tracing option with dump to + 'tracelog.txt'. my $dsn = 'dbi:Oracle:DWASAS'; my @connection = ($dsn, $user, $pass, {InactiveDestroy => 1, PrintErro +r => 0, RaiseError => 1}); my $dbh = DBI->connect(@connection) or die; open(my $tracelog_fh, '>', 'tracelog.txt') or die "Cannot open \"trace +log.txt\": $!."; $dbh->trace(4, $tracelog_fh); # pepare and execute 'prepack_candidates.sql' print "Preparing 'prepack_candidates.sql'...\n"; my $sth1 = $dbh->prepare($candidates_sql) or die; print "Executing 'prepack_candidates.sql'...\n"; $sth1->execute() or die; print "Fetching 'prepack_candidates.sql' returned data...\n"; print "\n----------\n"; my $print_format = '%7s '. '%-50s '. '%11s '. '%12s' ; printf("$print_format\n", 'ROW_NBR', 'REPORT_PART_NBR', 'SHIPPED_QYT', 'COUNT_AT_QTY' ); my $row_counter = 1; while(my $row = $sth1->fetchrow_hashref) { foreach (keys(%$row)) {$row->{$_} = '' if (!defined($row->{$_}))}; + # change all NULLs to empty strings printf("$print_format\n", $row_counter, $row->{'REPORT_PART_NBR'}, $row->{'SHIPPED_QTY'}, $row->{'COUNT_AT_QTY'} ); $row_counter++; } print "----------\n";

    And here is the basic SQL query it's running. And yes, it is successfully running, I can run this same query in 3 other tools: SQL Developer, Alation, and SAS (SAS modified for proc sql))

    The failure happens during the $sth1->fetchrow_hashref loop. If I try various CASTs in the SQL it will tend to get hung up on different rows of data, but at this point rarely finishes successfully. But here's where things get interesting. The trace file, when it fails the fetch, just looks like this.

    But, way back up at the top, when it's doing the prepare statement, the datatypes don't match what I would expect. When I look at them in the DB tables shown in Alation, Alation says one is a VARCHAR2(50) and the other is a NUMBER(10). I'm not sure what the COUNT I'm doing would become, but I was guessing NUMBER of some size as well.

    So, for those Monks that know DBI and especially DBD::Oracle well, or any Monk who has an opinion really... thoughts that may help me?

    Just another Perl hooker - My clients appreciate that I keep my code clean but my comments dirty.
Emergency: Need an assistance on this scenario
2 direct replies — Read more / Contribute
by darunk90
on Feb 14, 2020 at 08:25
    Hello Friends, I am new to perl program. Actually, I have an use case like, every hour we are running a script in Unix server to get some information from the server. So, every time we are sending a mail about that information. But, once the particular process has been completed, I don't want to send a mail for the day. This process will run on daily basis and every hour of the day. I am not sure, how can I do that. Anyone can guide me on this? Thanks, Arun Kumar Durairaj.
How to export hash references
1 direct reply — Read more / Contribute
by Anonymous Monk
on Feb 14, 2020 at 06:03
    I'm trying to export a reference to a hash but can only access it with a fully-qualified name. What am I doing wrong? Thanks

    Package Foo; use strict; use warnings; use Exporter 'import'; our @ISA = qw[Exporter]; our @EXPORT_OK = qw[%env $env]; our %env = %ENV; our $env = \%ENV; 1;
    
    perl -I. -MFoo=%env -le 'print scalar keys %env'
    38
    
    perl -I. -MFoo=$env -le 'print scalar keys %$env'
    0
    
    perl -I. -MFoo=$env -le 'print scalar keys %$Foo::env'
    38
    
Additional headers
4 direct replies — Read more / Contribute
by pragovnj
on Feb 13, 2020 at 11:48

    I have inherited this perl code and have an issue of additional headers. Not sure where from the code, these headers without data are coming from

    This is the code

    #!/usr/bin/perl require 'ConvertDates.pl'; use DBI; use Date::Manip ; use CGI; $parms = CGI->new; #parse parameters $start_date = $parms->param("sd"); $end_date = $parms->param("ed"); $separator= $parms->param("sep"); $HOME="/export/home/pmdss"; $CONFIG="${HOME}/config"; #$row=0; $rows=0; $NumOfRts=1500; $CntOfRts=0; print "Content-type: text/plain\n\n" ; chomp($ds_mach=`cat ${CONFIG}/BigIron`); chomp($dr_mach=`cat ${CONFIG}/BigIronDR`); system("/usr/sbin/ping $ds_mach >/dev/null 2>/dev/null"); if ( ($? >> 8) eq 0 ) { $id = "pmdss\@$ds_mach"; } else { system("/usr/sbin/ping $dr_mach >/dev/null 2>/dev/null"); chomp($ds_mach=`cat ${CONFIG}/BigIron`); chomp($dr_mach=`cat ${CONFIG}/BigIronDR`); system("/usr/sbin/ping $ds_mach >/dev/null 2>/dev/null"); if ( ($? >> 8) eq 0 ) { $id = "pmdss\@$ds_mach"; } else { system("/usr/sbin/ping $dr_mach >/dev/null 2>/dev/null"); if ( ($? >> 8) eq 0 ) { $id = "pmdss\@$dr_mach"; } else { print "A serious error has occurred, please contact pr +oduction support or try again later...\n" ; exit 0; } } $cmd = "ssh $id '. ~/q; \$Q/AgnEthernetList3-1.X -s $start_date -e $en +d_date' 2>/dev/null |"; #print "$cmd\n"; open (input , $cmd); while ($INPUT_LINE = <input>) { chomp($INPUT_LINE); ($dat{l_node}, $dat{l_slot}, $dat{l_ifNum}, $dat{r_node}, $dat +{r_slot}, $dat{r_line}, $dat{r_port}, $dat{kbps}, $dat{subnetwork }, $dat{subnetwork2}, $dat{r_domain_id}, $dat{icore_domid}, $dat{cust +_port}, $dat{track_port}, $dat{vlan_stacking_inv}, $dat{cos_level }) = split(/ /, $INPUT_LINE); $KEY = $dat{l_node} . "." . $dat{l_slot} . "." . $dat{l_ifNum +}; $key2 = int($CntOfRts++/$NumOfRts); $cmd = "ssh $id '. ~/q; \$Q/AgnEthernetList3-1.X -s $start_date -e $en +d_date' 2>/dev/null |"; #print "$cmd\n"; open (input , $cmd); while ($INPUT_LINE = <input>) { chomp($INPUT_LINE); ($dat{l_node}, $dat{l_slot}, $dat{l_ifNum}, $dat{r_node}, $dat +{r_slot}, $dat{r_line}, $dat{r_port}, $dat{kbps}, $dat{subnetwork }, $dat{subnetwork2}, $dat{r_domain_id}, $dat{icore_domid}, $dat{cust +_port}, $dat{track_port}, $dat{vlan_stacking_inv}, $dat{cos_level }) = split(/ /, $INPUT_LINE); $KEY = $dat{l_node} . "." . $dat{l_slot} . "." . $dat{l_ifNum +}; $key2 = int($CntOfRts++/$NumOfRts); ($nspString{$key2} = $nspString{$key2} . ":") if ($nspString{$ +key2} ne ""); $nspString{$key2} = $nspString{$key2} . "$dat{l_node},$dat{l_s +lot},$dat{l_ifNum}"; $arraykey{$KEY} = $KEY; $r_node{$KEY} = $dat{r_node}; $r_slot{$KEY} = $dat{r_slot}; $r_port{$KEY} = $dat{r_port}; $kbps{$KEY} = $dat{kbps}; $subnetwork{$KEY} = $dat{subnetwork}; $subnetwork2{$KEY} = $dat{subnetwork2}; $r_domain_id{$KEY} = $dat{r_domain_id}; ($r_domain_id{$KEY} = $dat{icore_domid}) if ($r_domain_id{$KEY +} eq ""); $cust_port{$KEY} = $dat{cust_port}; $track_port{$KEY} = $dat{track_port}; $vlan_stacking_inv{$KEY} = $dat{vlan_stacking_inv}; $cos_level{$KEY} = $dat{cos_level}; $rows = $rows + 1; } close (input); if ($rows > 0) { print "l_node\t" . "l_slot\t" . "l_port\t" . "r_node\t" . "r_slot\t" . "r_line\t" . "r_port\t" . "kbps\t" . "subnetwork\t" . "toNetwork\t" . #"pvcs\t" . #"lcir\t" . #"rcir\t" . "domain\t" . "icore_domid\t" . "cust_port\t" . "track_port\t" . "vlan_stacking_inv\t" . "cos_level\t" . "PvcCount"; # "placeholder"; foreach $key (keys arraykey) { ($l_node,$l_slot,$l_ifNum) = split(/\./, $key); if (substr($l_node,10,3) eq "ME2") { if ($l_slot >= 10000) { if ( substr($l_slot,1,1) eq "0" ) { $L_SLOT = substr($l_slot,2,1) +. "-" . substr($l_slot,4,1) ; } else { $L_SLOT = substr($l_slot,1,2) +. "-" . substr($l_slot,4,1) ; } } else { $L_SLOT = $l_slot ; } } else { $L_SLOT = $l_slot ; } if (TRIM($toNetwork{$r_domain_id{$key}}) ne "") { $_2Network = $toNetwork{$r_domain_id{$key}}; } else { $_2Network = $subnetwork2{$key}; } print "\n" . $l_node . "\t" . $L_SLOT . "\t" . $l_ifNum . "\t" . $r_node{$key} . "\t" . $r_slot{$key} . "\t" . $r_line{$key} . "\t" . $r_port{$key} . "\t" . $kbps{$key} . "\t" . $subnetwork{$key} . "\t" . $_2Network . "\t" . #$pvcs{$key} . "\t" . #$lcir{$key} . "\t" . #$rcir{$key} . "\t" . $domain{$r_domain_id{$key}} . "\t" . $icore_domid{$key} . "\t" . $cust_port{$key} . "\t" . $track_port{$key} . "\t" . $vlan_stacking_inv{$key} . "\t" . $cos_level{$key} . "\t" . $PvcCount{$key}; } } else { print `cat nodata`; } sub TRIM { $A = shift; $_ = $A; s/^ +//; s/ +$//; $A = $_; return $A; }

    I get data correctly for the 17 fields with headers but then I see additional columns from R to AG with no data. Where is it picking the additional columns and how to prevent it?

Pipe delimiter
3 direct replies — Read more / Contribute
by pragovnj
on Feb 12, 2020 at 15:54

    I have a CGI which outputs to plain text. How to have this as Pipe delimiter?

     print "Content-type: text/plain\n\n" ; Thanks, Pragov
Include custon location for dylib
2 direct replies — Read more / Contribute
by IB2017
on Feb 12, 2020 at 05:21

    Hello

    I am messing around with libraries on macOS, and I am having the following problems: when you install a new module, their dependences, for example dylib, get installed in standard locations. The module then call the dynlib from there. I want to use at RUNTIME other locations where I want to put such dylib.

    Let's say I want to use Image::PNG::QRCode; which requires "libpng". Let's say I put the "libpng16.16.dylib" library in a custom directory on my Desktop and I delete any other copy of this library from its standard location. I tried to add the path like following

    use lib '/Users/xx/Desktop/lib/libpng16.16.dylib'; #or use lib '/Users/xx/Desktop/lib';

    I also tried to add the path to the env with in a begin block $ENV{'LD_LIBRARY_PATH'} = '/Users/xx/Desktop/lib'; with no success.

    When I run my script, I get an error saying "Library not loaded: /usr/local/opt/libpng/lib/libpng16.16.dylib" which is the standard location (and I removed the dynlib!)

    How can I force my script to look in another location for my libraries? I hope it makes sense.


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

    How do I use this? | Other CB clients
    Other Users?
    Others scrutinizing the Monastery: (4)
    As of 2020-02-17 04:39 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      What numbers are you going to focus on primarily in 2020?










      Results (70 votes). Check out past polls.

      Notices?