Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling

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
File::Tail can not get output
2 direct replies — Read more / Contribute
by leostereo
on Oct 08, 2015 at 16:27

    Hello monks: I was tryng to feed a file with last ip granted by my dhcp server. Trying to inspect dhcpd.log file using tail, I tryed a simple code from documentation.

    #!/usr/bin/perl use File::Tail; $file=File::Tail->new("/var/log/dhcpd.log"); while (defined($line=$file->read)) { print "$line"; }

    Here dont get any output nor error so, then I tryed other piece of code that works ok.

    #!/usr/bin/perl -w use File::Tail; sub find_aaa_name { return '/var/log/dhcpd.log'; } my $file = File::Tail->new( name =>'/opt/dhcp_tail/dummy.txt', interval => 1, maxinterval => 1, resetafter=> 5, name_changes=> \&find_aaa_name, ignore_nonexistant => 1 ); while (defined($line = $file->read)) { print $line,"\n"; } 1;
    Can someone give me a clue? What is the difference ; why test1 dont work and dont print even an error message and test2 works ok ? I hope it can be usefull to someone. Regards, Leo.
Abstracting DBI
No replies — Read more | Post response
by linxdev
on Oct 08, 2015 at 16:07
    I've been doing some tests write a Perl Module to interface with a MySQL DB running SugarCRM. I've been doing DBI to Sugar for at least 10 years to simply support our CRM system. Whenever I can squeeze in some time I update the API I hacked out. Sometimes a sales person gives me a Excel file and I import those as leads. Sometimes I run reports, etc.

    As I made some changes today I started to notice that I've had abstracted so much within the object itself that it may be possible to remove any reference to any Sugar items. If so, I'm thinking there are already DBI modules that do similar type distractions.

    The first method that is not Sugar hard coded would be r2h (row2hash). I wrote this method for a Pi2 projects wher eI needed to get rows from a DB fast without writing a bunch of code.

    It looks like this
    # Pass these items # DBI object # table name # id column name # and id looking for # Example to get a row with id from user table # my $data = $r2h->($db, 'users', 'id', 10); my $r2h = sub { my $db = shift; my $table_name = shift; my $key_name = shift; my $id = shift; my $data = undef; eval { my $res = $db->prepare( "select * from `$table_name` where `$key_name`=? limit 1") or die $db->errstr(); $res->execute($id) or die $res->errstr(); my $name = $res->{'NAME'}; while(my @c = $res->fetchrow_array()) { my $x = 0; foreach my $n (@{$name}) { $data->{$n} = $c[$x]; $x++; } $data->{'HEADERS'} = $name; } $res->finish(); }; if($@) { $data = undef; } return $data; }; # r2h's in other modules return an array instead # ($data, $err) so that caller can distinguish between no # entry in the table and a real error.

    I saw the pattern when I started creating notes to enter into Sugar.

    The more I use that data format with the col names as an array the more my scripts stop calling Sugar->prepare() (Like DBI).

    Here is an example where I created a simply method to create a lead with the r2h data structure.

    sub create_lead { my $self = shift; my $uuid = undef; my $data = undef; eval { $uuid = $self->gen_uuid(); # This is where I saw the abstraction. # I built $get_factory off of the table descriptions $data = $get_factory->('leads'); $data->{'id'} = $uuid; $data->{'first_name'} = $uuid; $data->{'last_name'} = $uuid; $data->{'date_entered'} = $get_now->(); $data->{'date_modified'} = $get_now->(); $data->{'created_by'} = 1; $data->{'modified_user_id'} = 1; $data->{'description'} = 'Sugar::create_lead()'; }; if($@) { $self->{'ERRSTR'} = $@; $uuid = undef; $data = undef; } return $data; }
    The script can now update the hash items and then call Sugar->save_lead()
    sub save_lead { my $self = shift; my $data = shift; my $t_name = $self->get_table_name('leads'); eval { my $count = 0; die "No id in data!\n" unless $data->{'id'}; # Get our database handle; my $dbh = $self->get_db(); if(not $dbh) { $dbh = $self->connect() or die $self->errstr(); } # Validate this id does exist my $res = $dbh->prepare( "select count(*) from `$t_name` where id=?") or die $dbh->errstr(); $res->execute($data->{'id'}) or die $res->errstr(); $res->bind_columns(\$count) or die $res->errstr(); while($res->fetchrow()) { } $res->finish(); # We need to create one! if(not $count) { $res = $dbh->prepare( "insert into `$t_name` (id,description,date_entered,date_mod +ified,created_by,modified_user_id) values (?,?,?,?,?,?) ") or die $dbh->errstr(); $res->execute($data->{'id'}, 'Sugar::save_lead()', $get_now->(), +$get_now->(), 1,1) or die $res->errstr(); } $data->{'date_modified'} = $get_now->(); # Build our SQL statement and add values to array my $sql = "update `$t_name` set \n"; my @v; foreach my $header (@{$data->{'HEADERS'}}) { next if $header eq 'id'; $sql .= " `$header`=?,\n"; push @v, $data->{$header}; } chop($sql); chop($sql); $sql .= "\n where id=?;\n"; # Do update my $res = $dbh->prepare($sql) or die $dbh->errstr(); $res->execute(@v, $data->{'id'}) or die $res->errstr(); }; if($@) { $self->{'ERRSTR'} = $@; return 0; } return 1; }

    I originally was doing updates on each values, but my database is remote and it was too slow. Instead I build the SQL. Does DBI provide a better method than I chose to build $sql?

    What I've written to assist me on data imports and reports I am beginning to see how it can be agnostic. save_lead() can become save('leads', $lead_data); That is not specific to any database app.

    r2h can use any column to grab a row. The only problem I've ran into is that sometimes I need to do conditionals (where). For now I'll simple pass the conditionals as a string and then an array to satisfy those.

    r2h(..) { my $dbh = shift; my $table_name = shift; my $col_name = shift; my $v = shift; my $where = shift; my @w_conds = @_; my $sql = ... if($where) { $sql .= "($where) and `$col_name`= ?". } else { $sql .= "where `$col_name` = ?"; } ... }

    These are just some ideas I had and I'm thinking this work has been done. Possibly where I create a document that defines the database and the module uses that document.

    When I do imports I import into tmp tables then on mysql cli I do import everything placed in the tmp to the real table. In my Sugar object I allowed the script to specify that it wants to use a temp table for a real table. The module then generates a random name, does a 'create X like Y' and then places the new table name in a hash value to the key of the original name.

    create_tmp_table('leads'); .. creates leads_XXXXX in MySQL DB .. methods like save_lead() will create the row or update the row in t +hat table instead.
Why is this comparison failing?
3 direct replies — Read more / Contribute
by johnrcomeau
on Oct 08, 2015 at 14:29
    My code is doing something I really can't understand. I'm performing some linear interpolation, and test the result against the number 75. I can get two different results depending on where the &adjust_hue subroutine is called. Here's the code
    use strict; use constant HUE_RANGE => 255; my @HUES = ( 0, 25, 50, 75, 120, 168, 195, 240, + 268, 315); # 0.0 0.1 0.2 0.3 0.4 0.5 + 0.6 0.7 0.8 0.9 1.0 &adjust_hue(0.3); my @hues = (0 .. 4); $_ *= 0.1 for @hues; for (@hues) { &adjust_hue($_); } sub adjust_hue { my ($scale) = @_; my @hues = @HUES; push @hues, HUE_RANGE unless $hues[-1] == HUE_RANGE; # warn 'hues ', Dumper \@hues; # warn "n hues ", (scalar @hues), "\n"; my $n_unique_hues = -1 + scalar @hues; my $scaled_index = $scale*$n_unique_hues; my $index = int $scaled_index; my $adjusted_hue = $hues[$index] + ($scaled_index - $index)*($hues +[$index + 1] - $hues[$index]); # $adjusted_hue = eval $adjusted_hue; # This shouldn't be necessary +. Somehow this sub was producing strings instead of numbers. Later, t +his strings would fail comparisons. if ($adjusted_hue == 75) { warn " adjusted_hue ($adjusted_hue) equals 75\n"; } else { warn " adjusted_hue ($adjusted_hue) does not equal 75\n"; } warn "scale $scale, scaled_index $scaled_index, index $index, adju +sted_hue $adjusted_hue\n\n"; $adjusted_hue; }
    The output is the following for me:
    adjusted_hue (75) equals 75 scale 0.3, scaled_index 3, index 3, adjusted_hue 75 adjusted_hue (0) does not equal 75 scale 0, scaled_index 0, index 0, adjusted_hue 0 adjusted_hue (25) does not equal 75 scale 0.1, scaled_index 1, index 1, adjusted_hue 25 adjusted_hue (50) does not equal 75 scale 0.2, scaled_index 2, index 2, adjusted_hue 50 adjusted_hue (75) does not equal 75 scale 0.3, scaled_index 3, index 3, adjusted_hue 75 adjusted_hue (120) does not equal 75 scale 0.4, scaled_index 4, index 4, adjusted_hue 120
    I really don't understand why the comparison to 75 is true in one case with the parameter 0.3 and false also with the parameter 0.3 Thanks, John
Help tracking changes in array
4 direct replies — Read more / Contribute
by reebee3
on Oct 08, 2015 at 13:52

    Hello! I am trying to write a script that detects SNPs and their position in DNA sequences. Simply put, A SNP is when there is a change in A, T, C, or G between sequences, therefore...

    A could change to T, C, to G

    T could change to C, G, or A

    G could change to C, T or A

    C could change to G, T or A

    For Example:

    Sequence 1: ATGGAT

    Sequence 2: ACGGAG

    There are 2 SNPs here.

    SNP 1 is the T --> C is position 2 of the sequence. SNP 2 is the T -->G in position 6 of the sequence.

    Criteria for the script:

    Only 2 sequences can be entered on the command line The 2 sequences must be equal length Find the SNP and the position of the SNP (starting from position 1 not 0) Print out data- for example using the sample above

    Pos 2: T => C

    Pos 6: T =>G

    Found 2 SNPs.

    This is what I have so far, but I am not sure how to proceed...

    #!/usr/bin/env perl # file: use strict; use warnings; use autodie; my $number_seqs = scalar @ARGV; if($number_seqs != 2){ print "Please provide two sequences \n"; } for (my $i=0; $i<$number_seqs; $i++){ if(length($ARGV[$i]) != length($ARGV[0])){ print "Please ensure the sequences are the same length \n"; } } my $var = $ARGV[0]; print $var,"\n"; my $var2 = my $var[0]; print $var2,"\n";
Perl modifying output of an array to remove blank lines
2 direct replies — Read more / Contribute
by namelessjoe
on Oct 08, 2015 at 12:57

    I am trying to use perl to login to a piece of network equipment and pull some information. I then want to parse out the information i am interested in. Needless to say i am a perl hack and have absolutely no experience. I have a piece of code i have modified but am stuck on what to do next. Any help in the right direction would be greatly appreciated. I am getting the information i want out of the device fine, but parsing it is where i am having trouble. I am using Net::Telnet to query the device as you will see in the code. I hope this makes sense i would like to get rid of the extra lines that are blank.

    use strict; #################### # Required Modules # # # #################### use Net::Telnet; ######## # Main # ######## my $telnet; my $ip = $ARGV[0]; my $uname = $ARGV[1]; my $passwd = $ARGV[2]; my $slot = $ARGV [3]; if (!$ARGV[0]) { print "no hostname/IP supplied\n"; die "usage:\n\n./ IP USERNAME PASSWORD slot#\n"; } elsif ((!$ARGV[1]) || (!$ARGV[2])) { print "a telnet username and password must be supplied\n"; die "usage:\n\n./ IP USERNAME PASSWORD slot#\n"; } if (!$ARGV[3]) { die "usage:\n./ IP USERNAME PASSWORD slot#\n"; } # elsif ($ARGV[3] eq "index") elsif ($ARGV[3]) { &Show_Optic; } ########################## # open a Telnet session: # # # ########################## sub Open_Telnet { $telnet = new Net::Telnet ( Host => $ip, Timeout => 5, Prompt => '/# ?$/i', Input_log=>"input.log", Dump_log=>"dump.log", Output_log=>"output.log"); $telnet->waitfor('/Username: $/i'); $telnet->print($uname); $telnet->waitfor('/Password: $/i'); $telnet->print($passwd); # print "Logged into the system \n"; $telnet->waitfor('/>/i'); $telnet->print('en'); $telnet->waitfor('/Password:$/i'); $telnet->print($passwd); $telnet->waitfor('/#/i'); } ######################## # Close telnet session # # # ######################## sub Close_Telnet { $telnet->close; } ########################### # Login and Do show # # Optic # ########################### #### OUTPUT ROUTER WILL GIVE BACK from show optic Command #### when this is inputted into the telnet@LAB_MLX16#show optic 7 # Port Temperature Tx Power Rx Power Tx Bias Current #+----+-----------+-------------+------------+----------------+ #7/1 N/A N/A N/A N/A #7/2 40.6250 C -002.9277 dBm -040.0000 dBm 5.820 mA # Normal Normal Low-Alarm Normal #7/3 35.5000 C -002.5219 dBm -002.7992 dBm 7.588 mA # Normal Normal Normal Normal #7/4 32.0000 C -036.9897 dBm -003.5085 dBm 0.004 mA # Normal Low-Alarm Normal Low-Alarm sub Show_Optic { &Open_Telnet; my @RawIndexInts = ($telnet->cmd("sh optic $slot")); pop @RawIndexInts; # print "@RawIndexInts\n"; #results in the same unmodified + output of the Router #Port Temperature Tx Power Rx Power Tx Bias Current # +----+-----------+-------------+------------+----------------+ # 7/1 N/A N/A N/A N/A # 7/2 37.9375 C -002.9311 dBm -040.0000 dBm 5.754 mA # Normal Normal Low-Alarm Normal # 7/3 33.5000 C -002.4048 dBm -002.7959 dBm 7.556 mA # Normal Normal Normal Normal # 7/4 30.2500 C -036.9897 dBm -003.4998 dBm 0.004 mA # Normal Low-Alarm Normal Low-Alarm my $token = 0; foreach my $line (@RawIndexInts) { if ($token eq 0) { $line =~ s/^\s+//; $line =~ s/\s+$//; # print "$line\n"; #results in output of Router with +leading and trailing whitespaces of line gone #Port Temperature Tx Power Rx Power Tx Bias Cur +rent #+----+-----------+-------------+------------+------------ +----+ #7/1 N/A N/A N/A N/A #7/2 40.6875 C -002.9208 dBm -214.3647 dBm 5.828 mA #Normal Normal Low-Alarm Normal #7/3 36.0000 C -002.4305 dBm -002.8100 dBm 7.546 mA #Normal Normal Normal Normal #7/4 32.5000 C -036.9897 dBm -003.4920 dBm 0.004 mA #Normal Low-Alarm Normal Low-Alarm + my @Goodlines = $line =~ m/(^\S{1}\/\S{1})\s+\S{7}\s+\S{1} +\s+(\-\S{3}\.\S{4}\sdBm)\s(\-\S{3}\.\S{4}\sdBm)/g; #this string filt +ers the for values i want # print "@Goodlines\n"; #results in interesting lines with + blank lines # # # #7/2 -002.9242 dBm -036.9897 dBm # #7/3 -002.4764 dBm -002.8075 dBm # #7/4 -036.9897 dBm -003.4901 dBm # print "Port: $Goodlines[0] Tx Power: $Goodlines[1] Rx Powe +r: $Goodlines[2]\n"; #Port: Tx Power: Rx Power: #Port: Tx Power: Rx Power: #Port: Tx Power: Rx Power: #Port: 7/2 Tx Power: -002.9208 dBm Rx Power: -036.9897 dBm #Port: Tx Power: Rx Power: #Port: 7/3 Tx Power: -002.3972 dBm Rx Power: -002.7959 dBm #Port: Tx Power: Rx Power: #Port: 7/4 Tx Power: -036.9897 dBm Rx Power: -003.4998 dBm #Port: Tx Power: Rx Power: } } &Close_Telnet; }
A Database Connection Question
3 direct replies — Read more / Contribute
by ChiloUK
on Oct 08, 2015 at 11:55
    Hi, I'm using DBI to connect to my database, like this "$oDbc = DBI->connect("dbi:Informix:$sDatabase",...). What I am having difficulties with is finding out what is stored in $oDbc. When I use the debug I get DBI::db=HASH(...) which I expect. But I can't figure out how to see what is stored in the hash. The reason I require it is I am thinking of putting this call in a loop, instead of bombing out if it doesn't connect, I sleep a while and give it another go. I therefore need to see the two instances of connected and not. from this I can make a decision on whether it is connected or will need retried. I will also put a counter within the loop so it only fails so many times. I've been searching and can't find how to do it. Please can someone enlighten me. Many thanks.
When the only tool you have is a screwdriver...
3 direct replies — Read more / Contribute
by ExReg
on Oct 08, 2015 at 11:10

    I am trying to extend a tool that looks at files, searching for certain patterns. The tool is in perl and makes copious use of regular expressions. I came across a new pattern that has me scratching my head. I am trying to match a certain expression e that can have more than one definition ( shown in much simplified form ):

    1. e =~ u 2. e =~ uae 3. e =~ edefe 4. e =~ ebe 5. e =~ ec

    As you can see, all but the first are recursive matches. I could write the above as

    e =~ u|uae|edefe|ebe|ec

    Here is what I have so far: if I had only 1 and 2 from above, I could write the combination of 1 and 2 as

    e =~ u(?:au)*

    Likewise, for 1 and 3, I could write

    e =~ udufu

    For 1 and 4, I would have

    e =~ ubu

    and for 1 and 5, I would have

    e =~ uc

    To go further, I would have to combine more than two together, and I think it could get horrifyingly complex. Is there a way to tackle a problem like this with dynamic regexes, or is there a method for substituting the above together?

    I have perl 5.6, so I am slightly limited on what I can do. I do not know dynamic regexes well enough to frame the above with those. I cannot use CPAN or anything other than the screwdriver I have.

how to remove empty pipe delimiters in a line which doesn't contain any data
8 direct replies — Read more / Contribute
by rpinnam
on Oct 08, 2015 at 10:04
    I have a input pipe delimiter file as:

    IFB Northpole||| Alaska||| 907-555-5555

    Walmart||| Fairbanks||| Alaska

    Chicken||| Anchorage||| Alaska||| 907-555-5555

    Beef||| Somewhere|||||Over the Rainbow|||907-555-5555

    I want my output to be :

    IFB Northpole| Alaska| 907-555-5555|

    Walmart| Fairbanks| Alaska

    Chicken| Anchorage| Alaska| 907-555-5555

    Beef| Somewhere|Over the Rainbow|907-555-5555

    Here is my code :
    #!/usr/bin/perl @FILES = glob("*.txt"); foreach my $file (@FILES) { open my $fh, '<', $file; (my $fileName = $file) =~ s/\.[^.]+$//; open(my $output, '>', $fileName.".csv") or die "Could not open fil +e '$fileName' $!"; my @category; my @Detail; print $output ""; while (my $line = <$fh>) { chomp $line; @tokens = split /\|/, $line; chomp(@tokens); $objectName=$tokens[0]; if($objectName ne ""){ my @objectFields; $size = scalar(@tokens); @tokens = @tokens[1..$size]; foreach my $token (@tokens){ $token =~ s/\r|\n//g; push @objectFields,$token; } if($objectName eq "IFB Northpole"){ @Detail=@objectFields; }elsif($objectName eq "Walmart"){ @category=@objectFields; }elsif($objectName eq "Chicken"){ @category=@objectFields; }elsif($objectName eq "Beef"){ my @item = (@Detail,@category,@objectFields); print $output join("|", @item,@removeemptylines)."\n"; } } } close $output; close $fh; }
    How can i achieve this in perl? Any help would be appreciated.
PGP encryption command not working thru Perl Backticks
3 direct replies — Read more / Contribute
by newperlmonkey
on Oct 08, 2015 at 09:06
    Hello, I have spent considerable amount of time to make the PGP encryption work and thinking that I must be missing something. Here is the back ground.

    Perl Version - Default version 5.8.4 on Solaris 10
    PGP : PGP Command line freeware 6.5.8 installed on solairs

    When I run the pgp encrytion command directly on the Solaris, its working like a charm and doing everything that I ask it to do, but the problem comes when I invoke thru a perl script. Its just creating a empty asc file but not writing anything to that file and cursor is just stuck there.

    $dataFile = '/opt/ExportedPGPKeys/SampleData.txt'; $isEncrypted = `pgp -ea +batchmode $dataFile @sys`; print " The output value is $isEncrypted \n";

    If I run another command like  ls instead of the PGP command thru the perl script then its working.

    Did anyone come across this situation or any pointers will be grateful.

CPAN won't work with Busybox gzip
1 direct reply — Read more / Contribute
by imho
on Oct 08, 2015 at 08:46
    Hello everyone,

    I am on a Linux machine with Busybox where gzip is a symlinked command to Busybox, and not the full gzip utility. Perl-cpan fails to unpack CPAN modules saying:
    Giving up parsing your /home/nemo/.cpan/sources/modules/02packages.det +ails.txt.gz, too many errors/usr/bin/gzip: invalid option -- 'q' BusyBox v1.21.1 (2015-08-24 08:58:18 UTC) multi-call binary. Usage: gzip [-cfd] [FILE]... Compress FILEs (or stdin) -d Decompress -c Write to stdout -f Force /usr/bin/gzip: invalid option -- 'q'

    How can I solve this problem? How can I fix my cpan installation?

    Best regards

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

    How do I use this? | Other CB clients
    Other Users?
    Others rifling through the Monastery: (7)
    As of 2015-10-08 21:31 GMT
    Find Nodes?
      Voting Booth?

      Does Humor Belong in Programming?

      Results (228 votes), past polls