http://www.perlmonks.org?node_id=479

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
Integer regex, different results in windows and mac - I just need regex help
3 direct replies — Read more / Contribute
by hiyesthanks
on Oct 18, 2017 at 22:42
    When I test the code in windows, I get the results im looking for (https://imgur.com/a/59SKl). But when I test it on mac, I get different results (https://imgur.com/a/ZJMEg) in the positive and negative integers. Whats wrong with my regex?
    #!/usr/bin/perl # The program calculates the total zeros and positive intergers from t +he data using regex use strict; use warnings; my ( $ctrP, $ctrN, $ctrZ ) = ( 0, 0, 0 ); while( my $num = <DATA> ) { chomp($num); ## print "num=[$num]\n"; if ( $num =~ /^[0].{0}/ ) { $ctrZ++; } elsif ( $num =~ /^\d[0-9]{1,3}$/ ) { $ctrP++; } else { $ctrN++; } } printf("freq(Z+):%8s\n", $ctrP ); printf("freq(Z-):%8s\n", $ctrN ); printf("freq(0):%9s\n", $ctrZ ); printf("Total:%11s\n", ($ctrP+$ctrN+$ctrZ) ); exit; __DATA__ 19 -22 498 512 15 -932 0 22 808 17 -32
Using negative lookahead
2 direct replies — Read more / Contribute
by ibm1620
on Oct 18, 2017 at 21:14
    I want to create a regex that will identify a string surrounded by quotes, and remove the quotes. If the quote symbol appears within the string, the match should fail. The quotes can be either ' or ". Eventually they might be multi-character strings (e.g. ''). I'm not concerned at this point about recognizing escaped embedded quotes. This is slightly contrived .. I mostly want to understand why a negative lookahead isn't working the way I thought it would.

    I sure would appreciate being shown what I'm misunderstanding.

    #!/usr/bin/env perl use warnings; use strict; my @cases = ( q{'abc"def'}, q{'abc'}, q{"abc"}, q{''}, q{'abc'def'}, # Want this to fail matching q{'This shouldn't match'}, # Want this to fail matching q{"This isn't a problem"}, q{"abc}, q{abc"}, q{abc}, q{'abc"}, q{'ab''}, # Want this to fail matching ); strip_quotes($_) for @cases; # If we can remove a matching pair of single or double quotes from # a string, without the quote symbol also appearing within the string, # do so. Otherwise don't change the string. sub strip_quotes { my $line = shift; print "\n$line\n"; # NO NEGATIVE LOOKAHEAD # This works except it allows an embedded delimiter if ( $line =~ m{^ # anchor ( # capture delimiter in pos 1 ["'] # delim is single or double quote ) (.*) # anything \g1$}x # finally, the delim ) { print " 1- Got a match: delimiter was {$1}, body was {$2}\n"; } else { print " 1- No match.\n"; } # ATTEMPTING NEGATIVE LOOKAHEAD # This should fail if the delimiter is found in non-terminal pos. if ( $line =~ m{^ # anchor ( # capture delimiter in pos 1 ["'] # delim is single or double quote ) (.*(?!\g1)) # neg lookahead for delim \g1$}x # finally, the delim ) { print " 2- Got a match: delimiter was {$1}, body was {$2}\n"; } else { print " 2- No match.\n"; } }
    Result:
    'abc"def' 1- Got a match: delimiter was {'}, body was {abc"def} 2- No match. 'abc' 1- Got a match: delimiter was {'}, body was {abc} 2- No match. "abc" 1- Got a match: delimiter was {"}, body was {abc} 2- No match. '' 1- Got a match: delimiter was {'}, body was {} 2- No match. 'abc'def' 1- Got a match: delimiter was {'}, body was {abc'def} 2- No match. 'This shouldn't match' 1- Got a match: delimiter was {'}, body was {This shouldn't match} 2- No match. "This isn't a problem" 1- Got a match: delimiter was {"}, body was {This isn't a problem} 2- No match. "abc 1- No match. 2- No match. abc" 1- No match. 2- No match. abc 1- No match. 2- No match. 'abc" 1- No match. 2- No match. 'ab'' 1- Got a match: delimiter was {'}, body was {ab'} 2- No match.
Help with Web Scraping Script
1 direct reply — Read more / Contribute
by EagerforPerl
on Oct 18, 2017 at 20:44
    use strict; use warnings; use LWP::Simple; use File::Compare; use File::Copy; $| = 1; sub main { #Create a file with current content, compare with all present file +s in directory if same, delete, if not, keep. unless(-e('filesaves') or mkdir('filesaves')) { die("Directory Couldn't Be Created.\n"); } #create directory if it does not already exist my $fileName; print("Enter Site Directory: "); #Test input: http://caveofprogram +ming.com #Gather site URL with directory my $siteDirectory = <STDIN>; print("Number of Times to Run: "); #Test input: 10 my $runAmount = <STDIN>; #Gather the number of times to check the web address unless(opendir(my $directory, 'C:\\Program Files\\OSNE')) { die("Unable to open directory 'C:\\Program Files\\OSNE'\n"); } for(my $i = 0; $i <= $runAmount; $i++) { my $file = readdir($directory); closedir($directory); $file = grep(/\.txt$/i, $file); #Filter as to only look for .t +xt files my $searchTable = get($siteDirectory); #Get HTML code from web +site if(defined($searchTable)) { $fileName = localtime() . '.txt'; #Set file name to the ti +me it will be created $fileName =~ s/:/-/g; #remove the disallowed characters an +d replace them so that it can be the file name open(my $outputFile, '>', $fileName) or die("Couldn't Crea +te File.\n"); while($searchTable =~ m|<\s*a\s+[^>]*href\s*=\s*['"]([^>"' +]+)['"][^>]*>\s*([^<>]*)</|sig) { #HTML code title filter regex print OUTPUT ("$2: $1\n"); #print the titles to the te +xt file } if(compare($fileName, $file) == 0) { close($outputFile); #close output unlink($fileName); #delete file } else { close($outputFile); move("C:\\Program Files\\OSNE\\'$file'","C:\\Program F +iles\\OSNE\\filesaves\\'$file'"); #Move the old file to filesave folder +and keep the new file in the same directory as the script print("Change Detected.\n"); } } else { print("URL Unaccessible: $siteDirectory\n"); } } } main();

    I'm new to Perl, and I am trying to make a program that reads a sites html(specifically the titles) continuously as long as the user has specified and compares it with the other scan of the website by comparing files. If the file is the same as the other, delete the newer file. If the file is different, move the old file into the filesaves folder and keep the newer file in the same directory as the script. Console Log: readdir() attempted on invalid dirhandle INPUTDIR at C:\Program Files\OSNE\OSNE.pl line 23, <STDIN> line 2. closedir() attempted on invalid dirhandle INPUTDIR at C:\Program Files\OSNE\CPMonitor.pl line 23, <STDIN> line 2. Use of uninitialized value $_ in pattern match (m//) at C:\Program Files\OSNE\CPMonitor.pl line 24, <STDIN> line 2. Change Detected.

Clearing a hash reference
2 direct replies — Read more / Contribute
by jorba
on Oct 18, 2017 at 19:22
    so, creating a moose class to represent a single record from a db table. The class has a property "Fields" which is a hash which stores the name of each field along with the value of the field in the record being represented.

    When the class loads the record, it needs to clear this hash reference, so it can load the "new" record. Being a "property" of the moose class, Fields is a hash ref, not a hash. Getting an error when I try to clear the hash reference before repopulating.

    specific line with the problem is

    $self->Fields = 0;

    in the select method.

    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 'Name' => (is => 'rw', isa => 'Str', required => 1); has 'Fields' => (is => 'rw', isa => 'HashRef'); has 'FieldCount' => (is => 'rw', isa => 'Num'); has 'Changed' => (is=>'rw', isa => 'Boolean'); has 'Where' => (is => 'rw', isa => 'Str'); has 'ControlObject' => (is => 'rw', isa => 'Object', required => 1); has 'Keys' => (is => 'rw', isa=>'Array'); has 'Populated' => (is => 'rw', isa => 'Boolean'); # Contains a single record sub BUILD # Constructor { my $self; $self = shift; if (defined $self->Where) { $self->Select(); } else { $self->Populated = 0; } } # Insert the record sub Insert { } #Delete using the keys in the record sub Delete { } #Update using the keys and values in the record sub Update { } #Save the record sub Save { } sub Select { my ($SQLStr, $Cnt, $sql, @Values, $self, $Col, @Flds, $i); $self = shift; $SQLStr = "SELECT * FROM " . $self->Name . ' ' . $self->Where; print "Record.pm \t $SQLStr\n"; $sql = AXSQL->new(ControlObject => $self->ControlObject, SQLString + => $SQLStr); #construct a hash using the metadata and the data from the actual +table $self->Fields = 0; @Values = $sql->Fetch(); if ($sql->Rowcount >= 1) { $self->Populated = 1; } else { $self->Populated = 0; } #Get field Names $sql = AXSQL->new(ControlObject => $self->ControlObject, SQLString + => "show fields from '" . $self->Name . "'"); @Flds = $sql->fetch(); # Construct the hash for ($i..$#Flds) { if ($self->Populate == 0) { $self->Fields->{$Flds[$i]} = $Values[$i]; } Else { $self->Fields->{$Flds[$i]} = ' '; } } #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"); while (($Col) = $sql.fetch()) { push $self->Keys, $Col; } $Cnt = $self->Fields; $self->FieldCount = $Cnt; $self->Changed = -1; } 1;
    Error message is

    C:\Users\Jay\Desktop\SBS DEV\CODE\perl>perl -w CollectEmail.pl Record.pm SELECT * FROM customer WHERE NAME = 'Testing' RowCount 1 Can't modify non-lvalue subroutine call at C:\Users\Jay\Desktop\SBS DEV\CODE\per l\Utilities/AXRecord.pm line 73. C:\Users\Jay\Desktop\SBS DEV\CODE\perl>

Net::SFTP::Foreign Password Authentication Hangs
1 direct reply — Read more / Contribute
by dano63
on Oct 18, 2017 at 16:42
    Greetings Monks,

    I'm using Net::SFTP::Foreign (which I've used elsewhere for years) as part of a new on-prem file movement service and am running into a problem where it's simply hanging when it gets to password authentication. Doing a manual sftp works so this is something else. I have even stripped down my code to only the relevant lines and it's doing the same thing.

    My OS is Fedora 25, the perl is "(v5.26.1) built for x86_64-linux-thread-multi" and Net::SFTP::Foreign is 1.87 and everything is patched and up to date. Thanks for any help you can provide!

    Dano.

    $Net::SFTP::Foreign::debug = 1; my $sftp = Net::SFTP::Foreign->new( $Server, user => $User, password => $Pass, more => '-vvv' );
    With the results:
    debug1: Authentications that can continue: password,keyboard-interacti +ve,publickey debug3: start over, passed a different list password,keyboard-interact +ive,publickey debug3: preferred keyboard-interactive,password debug3: authmethod_lookup keyboard-interactive debug3: remaining preferred: password debug3: authmethod_is_enabled keyboard-interactive debug1: Next authentication method: keyboard-interactive debug2: userauth_kbdint debug3: send packet: type 50 debug2: we sent a keyboard-interactive packet, wait for reply debug3: receive packet: type 60 debug2: input_userauth_info_req Password authentication debug2: input_userauth_info_req: num_prompts 1 # queueing msg len: 5, code:1, id:3 ... [1] # waiting for message... [1] debug3: send packet: type 61 debug3: receive packet: type 51 debug1: Authentications that can continue: password,keyboard-interacti +ve,publickey debug2: we did not send a packet, disable method debug3: authmethod_lookup password debug3: remaining preferred: debug3: authmethod_is_enabled password debug1: Next authentication method: password
    The hang is after the last line above. Perhaps not helpful but I also did an strace and got (at the end of much more output):
    Password authentication debug2: input_userauth_info_req: num_prompts 1 ) = 1 (in [3], left {tv_sec=0, tv_usec=780618}) read(3, "Password: ", 4096) = 10 write(3, "AintTellin\n", 10) = 10 wait4(21851, 0x7ffe1ea64784, WNOHANG, NULL) = 0 select(8, [3], NULL, NULL, {tv_sec=1, tv_usec=0}) = 1 (in [3], left {t +v_sec=0, tv_usec=999989}) read(3, "\r\n", 4096) = 2 close(4) = 0 close(3) = 0 fcntl(5, F_GETFL) = 0 (flags O_RDONLY) fcntl(5, F_SETFL, O_RDONLY|O_NONBLOCK) = 0 fcntl(8, F_GETFL) = 0x1 (flags O_WRONLY) fcntl(8, F_SETFL, O_WRONLY|O_NONBLOCK) = 0 write(2, "# queueing msg len: 5, code:1, "..., 45# queueing msg len: + 5, code:1, id:3 ... [1] ) = 45 write(2, "# waiting for message... [1]\n", 30# waiting for message.. +. [1] ) = 30 rt_sigaction(SIGPIPE, NULL, {sa_handler=SIG_DFL, sa_mask=[], sa_flags= +0}, 8) = 0 rt_sigprocmask(SIG_BLOCK, [PIPE], [], 8) = 0 rt_sigaction(SIGPIPE, {sa_handler=SIG_IGN, sa_mask=[], sa_flags=SA_RES +TORER, sa_restorer=0x7f688564a5d0}, {sa_handler=SIG_DFL, sa_mask=[], +sa_flags=0}, 8) = 0 rt_sigprocmask(SIG_SETMASK, [], NULL, 8) = 0 select(16, [5], [8], NULL, NULL) = 1 (out [8]) write(8, "\0\0\0\5\1\0\0\0\3", 9) = 9 select(8, [5], NULL, NULL, NULLdebug3: send packet: type 61 debug3: receive packet: type 51 debug1: Authentications that can continue: password,keyboard-interacti +ve,publickey debug2: we did not send a packet, disable method debug3: authmethod_lookup password debug3: remaining preferred: debug3: authmethod_is_enabled password debug1: Next authentication method: password
    Again with the hang at the last line.
Why doesn't this die with "Can't use an undefined value as an ARRAY reference"?"
1 direct reply — Read more / Contribute
by kikuchiyo
on Oct 18, 2017 at 13:49

    Consider the following script:

    #!/usr/bin/perl use strict; use warnings; use Test::More; use Data::Dumper; my $hash = { '50' => [ 1 ] }; print Dumper $hash; is(keys %{$hash}, 1, q/keys %{$hash} is 1/); is(scalar @{$hash->{'50'}}, 1, q/$hash->{'50'} is 1/); is(scalar @{$hash->{'100'}}, 0, q/$hash->{'100'} is 0/); print Dumper $hash; done_testing();

    With Perl 5.24.3 it runs to the end and all tests pass, even though I would expect that it dies with an "Can't use an undefined value as an ARRAY reference" error when it tries to dereference $hash->{'100'} which indeed does not exist.

    Compare with

    #!/usr/bin/perl use strict; use warnings; my $hash = { '50' => [ 1 ] }; print scalar @{$hash->{'100'}};

    which dies with the expected error.

    Under Perl 5.16 the first program also dies with the expected error. (This is how we initially noticed the problem: a program that was developed on 5.22+ needed to be ported to Centos 7 which has 5.16, and the tests began to fail there.)

    What is going on here?

    (Errata: Now I've ran with more Perl versions (perversions), and it doesn't die under perl 5.22 and above, but dies as expected under perl 5.20 and below)

Storing output of a subroutine into an hash and then printing hash
3 direct replies — Read more / Contribute
by Maire
on Oct 18, 2017 at 10:09

    Hi Monks!

    I have a subroutine that essentially stores all of the text from files held in a specific folder into a hash (%corpus). The idea is that you specify the folder when you call the subroutine. This subroutine has been written and used by someone with a lot more coding experience than me, so I can be sure that it is not the problem.

    What I want to do is 1) call the subroutine (getCorpus); 2) specify the folder that I want it to work on; 3) instruct it to store its output into a new hash (%mycorpus), and then I want to print out the contents of this hash.

    Iíve been browsing the PerlMonk archives for any similar situations to see if I could solve the problem myself, and Iíve managed to cobble together the code below from various places (notably Re: easiest way to print the content of a hash?), but I am quite obviously making some big mistakes that I don't have the skills, as of yet, to spot (as evidenced by the various error messages it returns (reproduced below the code)

    I haven't uploaded the original subroutine here because I'm not sure about the etiquette of making someone else's code available without their consent. But essentially the subroutine comes first and then I write:

    %mycorpus = getCorpus("C:\Users\li\test") #line 1 foreach (sort keys %mycorpus) { print "$_ : $mycorpus{$_}\n"; }

    In line 1, I am trying to call the subroutine (named getCorpus), tell getCorpus what folder I want it to operate on, and store the output of the subroutine into a new hash named %mycorpus. Then in lines 2 and 3, I attempt to print the contents of %mycorpus. The error messages returned for this particular attempt are as follows:

    Operator or semicolon missing before %mycorpus at get_corpus.pl line + 51. Ambiguous use of % resolved as operator % at get_corpus.pl line 51. Can't modify modulus (%) in scalar assignment at get_corpus.pl line 52 +, near ") foreach " syntax error at get_corpus.pl line 52, near ") {" Execution of get_corpus.pl aborted due to compilation errors.
    Any guidance on this would be greatly appreciated.
Double check for positions
5 direct replies — Read more / Contribute
by bisimen
on Oct 18, 2017 at 08:30

    This sub works, but say this is my DNA: AGCTTCTTGCGCTTCTT and this is what i'm looking for: GCTTCTTGC

    It will return 2. Which it correct, but since the next match blends into the first one, it dosen't detect it.

    So it should return: 2 9

    I guess I need to change the regular expression somehow...

    sub match_positions { my ($regexp, $sequence) = @_; use strict; my @positions = ( ); while ( $sequence =~ m/$regexp/ig ) { push ( @positions, pos($sequence) - length($&) + 1 ); } return "@positions "; }

    Thanks for any answers!

Issues with pp and Tk
6 direct replies — Read more / Contribute
by Chuma
on Oct 18, 2017 at 06:40

    Hello!

    I'm trying to teach myself Tk, by making a little game. Now I'd like to send it to my sister, so my little nephews can play it, but she doesn't have Perl installed, so I'd like to compile it to an executable (we both have macs). I use the pp tool, and it seems to work just fine on little example programs, but for this one I get errors. I worked out most of the problems, but the last error has me at a loss.

    >>> pp -c hopgame SYSTEM ERROR in compiling hopgame: 11 at /System/Library/Perl/Extras/5 +.18/Module/ScanDeps.pm line 1351. >>> pp hopgame /usr/bin/pp5.18: Failed to extract a parl from 'PAR::StrippedPARL::Sta +tic' to file '/var/folders/y8/p9hddj4d1l7fryf24cz0cd3m0000gn/T/parlpo +XAzmu' at /System/Library/Perl/Extras/5.18/PAR/Packer.pm line 1152, < +DATA> line 1.

    I guess it's something to do with importing the Tk modules? I don't know what else to do about it. Of course, if there's an easier way to compile to an executable, I'd welcome that too. I have ActivePerl 5.20, Mac OS 10.12.6.

A question a Tree::Trie
1 direct reply — Read more / Contribute
by jhuijsing
on Oct 18, 2017 at 01:08

    I have Tree:Trie created when I do a prefix search I am not getting the response I expect

    here is the trie

    0 Tree::Trie=HASH(0x600d98df8) '_DEEPSEARCH' => 3 '_END' => '' '_FREEZE_END' => 0 '_MAINHASHREF' => HASH(0x600d99050) '+' => HASH(0x600d9cfa8) 6 => HASH(0x600d9d0c8) 1 => HASH(0x600d9d008) '' => 'Term' 1 => HASH(0x600d9d2d8) 4 => HASH(0x600d9d188) 1 => HASH(0x600d9cea0) 1 => HASH(0x600d9d200) '' => 'Outleg_1' 0 => HASH(0x600d9d170) '' => 'Outleg_2' 5 => HASH(0x600d9d458) '' => 'Term_Ref' 'd' => HASH(0x600d9d0b0) 'e' => HASH(0x600d9d260) 'f' => HASH(0x600d98f78) 'a' => HASH(0x600d9d578) 'u' => HASH(0x600d983d8) 'l' => HASH(0x600d9d5a8) 't' => HASH(0x600d9d5d8) '' => 'Unknown'
  • do a search for +6114110
  • x $trie->lookup( "+6114110" )

    0 '+6114110'

  • do a search for +61141102
  • x $trie->lookup( "+61141102" )

    empty array

    I was expecting to get the same result, As it is the best prefix that matches

    Or I have got it wrong?


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.