Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options
 
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
Moose boolean type values: Noob
2 direct replies — Read more / Contribute
by jorba
on Oct 22, 2017 at 16:54
    I have a moose class with a boolean attribute. When I create a new instance of that class I try to pass either a 0 or 1 (perl boolean vals I thought) I get an error stating this is not a valid value. Either that or I'm misunderstanding the error message.

    Here's the package.

    package AXField; # Our libraries use lib 'C:\Users\Jay\Desktop\SBS DEV\CODE\perl\Utilities'; use Moose; # Attributes has 'Name' => (is => 'rw', isa => 'Str', required => 1); has 'Value' => (is => 'rw', isa => 'Str', reader => 'Value', writer => + 'SetValue'); has 'isKey' => (is => 'rw', isa => 'Boolean'); has 'Len' => (is=>'rw', isa => 'Num'); has 'DecimalPos' => (is => 'rw', isa => 'Num'); has 'Type' => (is => 'rw', isa => 'Str'); has 'OriginalValue' => (is => 'rw', isa => 'Str'); has 'ParentRec' => (is => 'rw', isa => 'Str', required => 1); has 'Populated' => (is => 'rw', isa => 'Str'); # Contains a single field sub BUILD # Constructor { my $self; $self = shift; $self->Populated(0); $self->OriginalValue(' '); $self->SetValue(' '); } sub Value { my $self; $self = shift; return $self->Value; } sub SetValue { my $self; $self = shift; $self->Value = shift; if ($self=>Populated() eq 'N') { $self=>Populated() eq 'Y'; } } 1;
    Here's the line that creates a new "Field"
    &Fld = AXField->new(Name => $Prop[0], Value => ' ', isKey => 1, Len => + $Length, DecimalPos => $prec, Type => $Prop[4], ParentRec => $self-> +Name);
    We're interested in the isKey attribute.

    Here's the error message

    Attribute (isKey) does not pass the type constraint because: Validatio +n failed f or 'Boolean' with value 1 (not isa Boolean) at C:\Perl64\lib\Moose\Obj +ect.pm lin e 24
    What am I missing
porting C code to Perl
1 direct reply — Read more / Contribute
by Discipulus
on Oct 22, 2017 at 15:27
    Hello nuns and monks,

    if you know me or not, I'm completely unaware of other programming languages; I just know a little Perl but I found myself in the rare situation where I need to translate a little code from C to Perl.

    Infact I rapidly (*) understood that is a task to be done by hand, and I've been told many times that these two languages share a lot in their syntax.

    My attempt is below and does not produces the output I expected (**).

    I looked a bit to some description of the C syntax to try to understand if there were some difference between the C operator and the correspective Perl's one. For example for ++ autoincrement or arithmentics ones. I found nothing relevant: many operators seems to act the same. Doubts remain about the C array syntax ( int A[len] ?? that I read as the elelment len of the array A is an int but..).

    Here below my attempt: can someone be so kind to point me where I lost in the translation? After a plain translation, when I possibly end with some working Perl code I'll arrange it into a more perlish version.

    use strict; use warnings; # #include <math.h> # #include <stdio.h> # #define N 100 my $n=100; # int len = floor(10 * N/3) + 1; my $len = 1 + int (10 * $n / 3); # int A[len]; my @a; $#a=$len-1; #? -1 ???? # for(int i = 0; i < len; ++i) {A[i] = 2;} for (my $i = 0; $i < $len; $i++){ $a[$i]= 2; } # int nines = 0; my $nines = 0; # int predigit = 0; my $predigit = 0; # for(int j = 1; j < N + 1; ++j) { for (my $j = 1; $j < $n + 1; ++$j){ # int q = 0; my $q = 0; # for(int i = len; i > 0; --i) { for(my $i = $len; $i > 0; $i--){ # int x = 10 * A[i-1] + q*i; my $x = 10 * $a[$i-1] + $q * $i; # A[i-1] = x % (2*i - 1); $a[$i-1] = $x % (2 * $i - 1); # q = x / (2*i - 1); } $q = $x / (2 * $i - 1); } # A[0] = q%10; $a[0]=$q%10; # q = q/10; $q=$q/10; # if (9 == q) { ++nines;} if (9 == $q){ ++$nines; } # else if (10 == q) { elsif(10 == $q){ # printf("%d", predigit + 1); printf("%d", $predigit + 1); # for (int k = 0; k < nines; ++k) { printf("%d", 0); } for (my $k = 0; $k < $nines; $k++){ printf("%d", 0);} # predigit, nines = 0; $predigit = $nines = 0; # } } # else { else{ # printf("%d", predigit); printf("%d", $predigit); # predigit = q; $predigit = $q; # if (0 != nines) { if(0 != $nines){ # for (int k = 0; k < nines; ++k) { for (my $k = 0; $k < $nines; $k++) { # printf("%d", 9); printf("%d", 9); # } } # nines = 0; $nines = 0; } } } # printf("%d", predigit); printf("%d", $predigit);

    (*) Not so rapid: I found a thread here at PM with a link to a C to perl translator, but I missed the <ironic> tags and my hands called rapidly gcc -P -E file.c > file.pl using the compiler I have shipped within strawberry perl. Was not useful and the next line gcc -Larry -Wall file.c > file.pl revealed me it was an humoristic faq or well a iaq..

    (**) Well i wanted to verify that the C code printed what I expected and I tried blindly using gcc to compile it (??) and using Inline::C but I had no success to not even install it on my strawberry perl.

    If you need my C source you can, obviously perl -lne 'print if s/\s?#\s//' my_post.pl

    Thanks

    L*

    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
How do tell Perl to break only on undef?
1 direct reply — Read more / Contribute
by myuserid7
on Oct 22, 2017 at 05:18

    Hello, while working on a package I ran into a problem for which I could not find a pretty solution. I broke things down to come up with the example code below to demonstrate my issue. When this script is executed, it will print only "12568", because 0 is considered as false and this breaks the while loop. Now I could use while(1) and add some more lines to check $i for undef and then do a "last", but the package is supposed to be used by others so I want to keep it as simple as possible. What would be a pretty/easy way to make while only treat undef as a breaking argument?

    #!/usr/bin/perl -w use strict; use warnings; my $t = test->new(); while (my $i = $t->get) { print $i; }; package test; use strict; use warnings; my @list; sub new { my $self = shift; my $this = {}; @list = ( 1, 2, 5, 6, 8, 0, 9 ); bless($this, $self); return($this); }; sub get { return(shift(@list)); }; 1;
Printing out matches for two regular expressions
1 direct reply — Read more / Contribute
by Maire
on Oct 22, 2017 at 04:29

    Hi Monks,

    I am trying to get a very basic script to print out the matches from two regular expressions at once. Specifically, I am trying to print out all of the numbers (digits) and all of the words in between a "#" and the word "fin" in .txt files which take the following format:

    The 2 cats and the dog. The 8 cats and the 6 dogs. The 3 pigs and the 2 sheep. #story fin #cats and dogs fin #sheep fin

    So, for example, from the above file, I would expect the output to be:

    2 8 6 3 2 story cats and dogs sheep

Matching hash keys from different hashes and utilizing in new hash
4 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
1 direct reply — Read more / Contribute
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
3 direct replies — Read more / Contribute
by LanX
on Oct 21, 2017 at 09:46
    Hi

    ( 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/perl5db.pl:646] 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/AXRecord.pm line 106. C:\Users\Jay\Desktop\SBS DEV\CODE\perl>

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 all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others studying the Monastery: (6)
    As of 2017-10-22 23:22 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      My fridge is mostly full of:

















      Results (275 votes). Check out past polls.

      Notices?