Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid

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
Matching hash keys from different hashes and utilizing in new hash
2 direct replies — Read more / Contribute
by FIJI42
on Oct 21, 2017 at 16:22

    New to Perl and was wondering if anyone could provide suggestions, relevant examples or resources regarding a coding problem I'm having below. So I have two data files with tab-delineated columns, similar to the example below.

    File#1: GeneID ColA ColB Gene01 5 15 Gene02 4 8 Gene03 25 5 File#2: GeneID ColA ColC Gene01 12 3 Gene03 5 20 Gene05 22 40 Gene06 88 2

    The actual files I'm using have >50 columns and rows, but are similar to what's above. First, I want to input the files, establish variables holding the column names for each file, and establish hashes using the column 1 genes as keys and the concatenated values of the other 2 columns per key. This way there is one key per one value in each row of the hash. My trouble is the third hash %commongenes. I need to find the keys that are the same in both hashes and use just those keys, and their associated values in both files, in the third hash. In the above example, this would be the following key value pairs:

    File1: File2: Gene01 5 15 Gene01 12 3 Gene03 25 5 Gene03 5 20

    I know the following if loop is incorrect, yet concatenation of columns from both files (similar to below) is similar in form to what I'd like to have.

    if ($tmpArray1[0] eq $tmpArray2[0]){ $commongenes{$tmpArray2[0]} = $tmpArray1[1].':'.$tmpArray1[2].':'.$tmpArray2[1].':'.$tmpArray2[2 +]; }

    Here is the main body of the code below:

    #!/usr/bin/perl -w use strict; my $file1=$ARGV[0]; my $file2=$ARGV[1]; open (FILE1, "<$file1") or die "Cannot open $file1 for processing!\n" +; open (FILE2, "<$file2") or die "Cannot opent $file2 for processing!\n +"; my @fileLine1=<FILE1>; my @fileLine2=<FILE2>; my %file1_allgenes=(); my %file2_allgenes=(); my %commongenes =(); my ($file1_group0name, $file1_group1name, $file1_group2name)=('','',' +',''); my ($file2_group0name, $file2_group1name, $file2_group2name)=('','',' +',''); for (my $i=0; $i<=$#fileLine1 && $i<=$#fileLine2; $i++) { chomp($fileLine1[$i]); chomp($fileLine2[$i]); my @tmpArray1=split('\t',$fileLine1[$i]); my @tmpArray2=split('\t',$fileLine2[$i]); if ($i==0) { ## Column Names and/or Letters $file1_group0name=substr($tmpArray1[0],0,6); $file1_group1name=substr($tmpArray1[1],0,4); $file1_group2name=substr($tmpArray1[2],0,4); $file2_group0name=substr($tmpArray2[0],0,6); $file2_group1name=substr($tmpArray2[1],0,4); $file2_group2name=substr($tmpArray2[2],0,4); } if ($i!=0) { ## Concatenated values in 3 separate hashes + if (! defined $file1_allgenes{$tmpArray1[0]}) { $file1_allgenes{$tmpArray1[0]}=$tmpArray1[1].':'.$tmpArray1[2] +; } if (! defined $file2_allgenes{$tmpArray2[0]}) { $file2_allgenes{$tmpArray2[0]}=$tmpArray2[1].':'.$tmpArray2[2] +; } if ($tmpArray1[0] eq $tmpArray2[0]){ $commongenes{$tmpArray2[0]} = $tmpArray1[1].':'.$tmpArray1[2].':'.$tmpArray2[1].':'.$tmpArray2[2 +]; } } my @commongenes = %commongenes; print "@commongenes\n\n"; }
Scaling an image with Gtk2::Gdk::Pixbuf->scale
No replies — Read more | Post response
by Anonymous Monk
on Oct 21, 2017 at 11:12

    The spec requires me to display an image inside a Gtk2::Textview.

    Sometimes the image must be displayed its original size. Sometimes it must be its original size, but surrounded by some empty 'padding'.

    The script below is the closest I've been able to get so far. It uses Gtk2::Gdk::Pixbuf->scale to create the 'padding'.

    However, the 'padding' is not empty space, as I'd hoped, but a blur of pixels from the edges of the original image.

    Is there a simple way to remove the blur, or does this call for a different approach entirely?

    #!/usr/bin/perl package scaleme; use strict; use diagnostics; use warnings; use Gtk2 '-init'; use Glib qw(TRUE FALSE); # Display this image my $path = 'change_this_directory/cat.bmp'; # Open a Gtk2 window with a Gtk2::TextView my $window = Gtk2::Window->new('toplevel'); $window->set_title('scaleme'); $window->set_position('center'); $window->set_default_size(800, 600); $window->signal_connect('delete-event' => sub { Gtk2->main_quit(); exit; }); my $frame = Gtk2::Frame->new(); $window->add($frame); my $scrollWin = Gtk2::ScrolledWindow->new(undef, undef); $frame->add($scrollWin); $scrollWin->set_policy('automatic', 'automatic'); $scrollWin->set_border_width(0); my $textView = Gtk2::TextView->new; $scrollWin->add_with_viewport($textView); if (-e $path) { # Display a photo of a cat face my $pixbuf = Gtk2::Gdk::Pixbuf->new_from_file($path); my $buffer = $textView->get_buffer(); $buffer->insert_pixbuf( $buffer->get_end_iter(), $pixbuf, ); # Make the overall image 20% bigger, but the cat's face is its # original size (and centred in the middle) my $factor = 0.2; my $w = $pixbuf->get_width(); my $h = $pixbuf->get_height(); my $pixbuf2 = Gtk2::Gdk::Pixbuf->new( 'GDK_COLORSPACE_RGB', FALSE, $pixbuf->get_bits_per_sample(), ($w * (1 + $factor)), ($h * (1 + $factor)), ); $pixbuf->scale( # $dest $pixbuf2, # $destx, $desty 0, 0, # $dest_width, $dest_height ($w * (1 + $factor)), ($h * (1 + $factor)), # $offset_x, $offset_y ($w * ($factor / 2)), ($h * ($factor / 2)), # $scale_x, $scale_y 1, 1, # $interp_type 'GDK_INTERP_NEAREST', ); $buffer->insert_pixbuf( $buffer->get_end_iter(), $pixbuf2, ); } $window->show_all(); Gtk2->main();
More effective way of doing this
6 direct replies — Read more / Contribute
by bisimen
on Oct 21, 2017 at 10:29

    I was trying to write a code that generates all possible combination of a word with X length and with any string of number/letters

    This is what I came up with. So, this will work for any array of numbers or letters. But it will only do all possible combinations of them within a word length of 3. If say, I wanted a word length of 5, I would need to go an add more counts into the while loop, following the same pattern. I could do a while loop for a word length of 3, one for 4, one for 5... etc, but this will get messy and ugly in the end...

    Any way to improve it? Or, is it hopeless and this is something I should be doing very differently? Thanks

    use warnings; @array = qw(A T C G); $word_length = 3; $max = ($#array+1)**$word_length; $mainc = 0; $count1 = 0; $count2 = 0; $count3 = 0; while ($mainc != $max){ print $array[$count1]; print $array[$count2]; print $array[$count3]; $count1++; if ($count1 == $#array){ $count1 = 0; $count2++; } if ($count2 == $#array){ $count2 = 0; $count3++; } if ($count3 == $#array){ $count3 = 0; } print "\n"; $mainc++; }
Regex: matching character which happens exactly once
2 direct replies — Read more / Contribute
by LanX
on Oct 21, 2017 at 09:46

    ( DISCLAIMER this is a theoretical question about pure regexes, I know how to solve this in Perl, it's a follow up to this thread)

    I'm banging my head at this problem, how do I match strings where at least one character happens exactly once, with a pure regex?

    (i.e. without additional Perl code, especially embedded one, and without manipulating the input)

    Finding all characters which aren't repeated afterwards is easy with a lookahead assertion

    DB<200> p bab DB<200> x / (.) (?! .* \1 ) /gx 0 'a' 1 'b'

    but combining with a lookbehind fails, b/c variable length is not permitted

    DB<211> x / (.) (?<! \1 .* ) /gx Variable length lookbehind not implemented in regex m/ (.) (?<! \1 .* +) / at (eval 261)[C:/Perl_64/lib/] l ine 2.

    (actually already using the backreference \1 fails, since the placeholder has variable length)

    So it boils down to the question:

    • How can I match all characters which appear for the first time?

    All workarounds I found so far only work with ugly cheats, like hardcoding all cases for a fixed length string only.

    I think it might be possible with recursive regexes and relative backreferences, but still ...

    Cheers Rolf
    (addicted to the Perl Programming Language and ☆☆☆☆ :)
    Je suis Charlie!

Accessing values outside subroutine
1 direct reply — Read more / Contribute
by Anonymous Monk
on Oct 21, 2017 at 04:08

    I am trying to access the values which is defined inside a subroutine . Here is the code flow

    Sub a { my @array = (1, 2, 3); } Sub b { foreach $value (@array) }

    I tried to define array as "our " keyword in Sub a. But, it is not retaining the values when it is accessesed inside Sub b . Is there a way to make it work

Moose arrayref addition: noob
2 direct replies — Read more / Contribute
by jorba
on Oct 20, 2017 at 17:09
    Trying to get my head around moose and running into a problem. Cut down version of code
    package AXRecord; # Our libraries use lib 'C:\Users\Jay\Desktop\SBS DEV\CODE\perl\Utilities'; use AXControl; use AXSQL; use Moose; use DBI; # Attributes has 'Keys' => (is => 'rw', isa=>'ArrayRef'); # Contains a single record sub BUILD # Constructor { } sub Select { #Get the primary key fields $self->Keys (()); $sql = AXSQL->new(ControlObject => $self->ControlObject, SQLString + => "SELECT column_name FROM information_schema.`key_column_usage` WH +ERE table_name = '" . $self->Name . "' order by ordinal_position"); $i = 1; while (($Col) = $sql->Fetch()) { $self->Keys()->[$i] = $Col; $i++; } $Cnt = scalar $self->Fields; $self->FieldCount = $Cnt; $self->Changed = -1; } 1;
    Problem is in the select method where I try to build the keys array. Specifically where I'm adding elements with the statements
    $self->Keys()->[$i] = $Col;
    The error message I'm getting is
    Can't use an undefined value as an ARRAY reference at C:\Users\Jay\Des +ktop\SBS DEV\CODE\perl\Utilities/ line 106. C:\Users\Jay\Desktop\SBS DEV\CODE\perl>
Advice: Async Options for fire-and-forget subroutine
3 direct replies — Read more / Contribute
by mwb613
on Oct 20, 2017 at 14:51

    Thanks in advance for looking.

    I took a look back through earlier questions and saw some helpful results but some of them were older and some didn't quite match my use case. I am writing a Perl module for a piece of software called OpenSIPs (a SIP server), the module itself does some message de-construction and re-construction that's not easy to do in the OpenSIPs config file itself. I have also been extended it to logging certain messages and statistics and right now my solution for that is Redis PUB/SUB. This is working fine but it is adding some latency that is not really necessary considering it is a non-essential function of the SIP transaction.

    What I would like to do is, rather than wait for the Redis transaction to complete (sometimes in the range of 20-30 ms depending on where the Redis server is), just run the Redis PUB/SUB command asynchronously and not worry about the reply or even wait to get the acknowledgment in my main script. I've seen a few modules mentioned in earlier conversations here: threads, AnyEvent, Async, etc and also some non modular solutions like backticks, etc. What I'm looking for is the simplest, most lightweight way to call a Perl subroutine (passing it some info -- a JSON encoded string) and not worry about the response or whether it is successful. I'd appreciate any advice anyone is willing to give.


Escaping Apostrophe
4 direct replies — Read more / Contribute
by perl_gvenk
on Oct 20, 2017 at 09:42

    I have a situation where I'm looping through to generate a SQL statement to update a table. Wha'ts happening though is The site name has an apostrophe in the value and the perl script throws an error at that point.

    Here is the piece of code that generates the SQL
    for $idx (0..$#hdr) { if ($row[$idx] ne "") { if ($found ne "N") { $updstmt .= ", "; $insstmt .= ", "; $valstmt .= ", "; } $found = "Y"; $updstmt .= $hdr[$idx]." = '".$row[$idx]."' \ +r\n";

    The values for the update are generated by the $row$idx.How do I put that $row$idx within double quotes or how do i make the perl interpreter escape any apostrophes in that field. Can some one suggest a solution?

Exception handling
2 direct replies — Read more / Contribute
by Anonymous Monk
on Oct 20, 2017 at 03:33

    my script logs in to console of router and clear all the user (console) lines. When it encounters the current line, it comes out of the script. Is there a way to handle this situation, more precisely, when it encounters current line, it should not clear and it should go to the next line which is used by somebody else

    ######################### sub clear_line { ######################### print "router name? "; my $r = <STDIN>; chomp($r); print "term? "; my $terms = <STDIN>; chomp($terms); my $values; my @test_array; my @data_set = ( JT->new( host => $r ), ); foreach my $rh (@data_set) { for (my $term = $terms; $term <=40; $term++) { $rh->cmd("request system logout terminal pts/$term"); } } }

    Logs below

    [shell]$ ./ router name? abc term? 1 Oct 20 00:21:07 [INFO ] [abc] JT::Device::connect: abc is connected vi +a /volume/labtools/bin/nicetelnet pid 16210 Oct 20 00:21:09 [INFO ] [abc] [cmd] cat /usr/share/cevo/cevo_version Oct 20 00:21:10 [INFO ] [abc] [cmd] request system logout terminal pts +/1 Oct 20 00:21:12 [INFO ] [abc] [cmd] request system logout terminal pts +/2 Oct 20 00:21:14 [INFO ] [abc] [cmd] request system logout terminal pts +/3 Oct 20 00:21:16 [INFO ] [abc] [cmd] request system logout terminal pts +/4 Oct 20 00:21:17 [INFO ] [abc] [cmd] request system logout terminal pts +/5 Oct 20 00:21:17 [INFO ] [abc] [cmd] request system logout terminal pts +/6 Oct 20 00:21:18 [INFO ] [abc] [cmd] request system logout terminal pts +/7 Oct 20 00:21:18 [INFO ] [abc] [cmd] request system logout terminal pts +/8 Oct 20 00:21:19 [INFO ] [abc] [cmd] request system logout terminal pts +/9 Oct 20 00:21:20 [INFO ] [abc] [cmd] request system logout terminal pts +/10 Oct 20 00:21:21 [INFO ] [abc] [cmd] request system logout terminal pts +/11 Oct 20 00:21:22 [INFO ] [abc] [cmd] request system logout terminal pts +/12 Oct 20 00:21:23 [INFO ] [abc] [cmd] request system logout terminal pts +/13 Oct 20 00:21:24 [INFO ] [abc] [cmd] request system logout terminal pts +/14 Oct 20 00:21:25 [INFO ] [abc] [cmd] request system logout terminal pts +/15 Oct 20 00:21:26 [INFO ] [abc] [cmd] request system logout terminal pts +/16 Oct 20 00:21:27 [INFO ] [abc] [cmd] request system logout terminal pts +/17 Oct 20 00:21:28 [INFO ] [abc] [cmd] request system logout terminal pts +/18 Oct 20 00:21:29 [WARN ] [abc] Device response :Connection closed by fo +reign host. Oct 20 00:21:29 [ERROR] [abc] JT::Device::_send: Expect rep +orted 3:Child PID 16210 exited with status 256 JT::error_handler HARD at /volume/labtools/lib/JT/ li +ne 2867, <STDIN> line 2. JT::Device::_send('JT::JUNOS=HASH(0xf0867c4)', 'cmd', 'request + system logout terminal pts/18', 'timeout', 60, 'timeout_ok', 0, 'slo +w', 0, ...) called at /volume/labtools/lib/JT/ line 2106 JT::JUNOS::cmd('CMD', 'request system logout terminal pts/18') + called at ./ line 1912 ft_generic_tc::clear_line() called at ./ line +2417 JT: die ./ with exit code 18 CONNECT_LOST

    Line 18 is used by my script and it disconnects and i should avoid it. Is there a way to avoid my line and go to the next line ?

How can one extract a name using perl?
1 direct reply — Read more / Contribute
by supriyoch_2008
on Oct 20, 2017 at 01:06

    Hi Perlmonks,

    I am interested in extracting the name of genes from a NCBI Genbank file using accession number. Say, the accession number is NC_025572. When the accession number is used as a query in Nucleotide database of NCBI (, it opens up a Genbank file with the title "Petrolisthes haswelli complete mitochondrial genome, isolate Mar55". In this file, the word CDS is repeated several times with a link and followed by information like <1..1534 /gene="COX1" or 1605..2289 /gene="COX2" or 2423..2773 /gene="ND3" etc. I have come across some perl codes from google search to extract the name from Genbank file. I have given the script below. It gives only the main title i.e. "Petrolisthes haswelli complete mitochondrial genome, isolate Mar55" and not the individual gene name like COX1 or COX2 or ND3. The digits prior to each gene name indicate position of sequence like 1..1534 or 1605..2289 or 2423..2773, respectively. I seek suggestions from perlmonks how to extract the gene name and its corresponding sequence for each gene. The output may look like:


    Here goes the code:

    #!/usr/bin/perl use warnings; use strict; use Bio::DB::GenBank; use Bio::SeqIO; use Text::Wrap; my $gb= new Bio::DB::GenBank; my $acc="NC_025572"; my $seq1 = $gb->get_Seq_by_acc($acc); my $desc=$seq1->desc(); print "\n $desc\n"; exit;

    I have got the following output from the script. It does not show name of individual gene.

    Microsoft Windows [Version 6.1.7600] Copyright (c) 2009 Microsoft Corporation. All rights reserved. C:\Users\x>cd d* C:\Users\x\Desktop> Petrolisthes haswelli complete mitochondrial genome, isolate Mar55. C:\Users\x\Desktop>

    I welcome suggestions from perlmonks to sort out this problem.

Add your question
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?

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

    How do I use this? | Other CB clients
    Other Users?
    Others examining the Monastery: (9)
    As of 2017-10-21 22:40 GMT
    Find Nodes?
      Voting Booth?
      My fridge is mostly full of:

      Results (271 votes). Check out past polls.