Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

The Monastery Gates

( #131=superdoc: print w/replies, xml ) Need Help??

Donations gladly accepted

If you're new here please read PerlMonks FAQ
and Create a new user.

New Questions
Data::Dumper and Data::Printer continual output
1 direct reply — Read more / Contribute
by opaltoot
on Oct 22, 2018 at 09:19

    the dowhile goes into a continual loop when Data::Dumper or Data::Printer are called

    originally took this to be a Data::Dumper issue, found it also in Data::Printer, so must be this code...

    use strict; use warnings; use Data::Dumper; use Data::Printer; # perl v5.22.1 # Linux 4.4.0-137-generic #163-Ubuntu SMP x86_64 x86_64 x86_64 GNU/Lin +ux # print $Data::Dumper::VERSION ."\n"; # v2.172 # print $Data::Printer::VERSION ."\n"; # 0.40 my $hash = {}; my $self = {}; $self->{a} = { b => $hash }; $self->{b} = $hash; dowhile($self); # comment this line to prevent continual output dofor($self); sub dowhile { my $self = shift; while (my ($k, $v) = each %{$self->{a}}) { # print Dumper $self->{a}; # uncomment line for continual output p $self->{a}; # uncomment line for continual output } } sub dofor { my $self = shift; for my $k (keys %{$self->{a}}) { p $self->{a}; } }
Security Checks for CPAN Module Authors
1 direct reply — Read more / Contribute
by localshop
on Oct 22, 2018 at 05:44
    As part of trying to work with CPAN I noticed the CPAN::Audit module in the recently updated list and it looks kinda useful as a general maintenance tool - going through the modules installed on my laptop and updating any that have security issues.

    It occurred to me that I should probably ensure that any CPAN modules do not include dependencies with known security issues. Even though these are often pretty trivial, it would seem to make the module more robust if any dependencies have minimum versions specified that resolve the know issues.

    Does anybody have advice on whether this is standard practice or whether there are any issues that I may find if I start putting in these minimum version requirements?

Extracting a bald host name
3 direct replies — Read more / Contribute
by eyepopslikeamosquito
on Oct 22, 2018 at 02:55

    I want to strip trailing stuff from a host name. To clarify, running this test program t1.pl:

    use strict; use warnings; use Test::More; my @expected = ( [ 'abc', 'abc' ], [ 'abc.bill.com', 'abc' ], [ 'abc.bill.com.au', 'abc' ], [ 'xy42.com', 'xy42' ], [ 'x_y.com', 'x_y' ], [ 'x-y.com', 'x-y' ], [ '', '' ], [ '.', '' ], [ 'a.', 'a' ], [ '-.', '-' ], [ '_.', '_' ], [ '.a', '' ], [ 'f', 'f' ], [ 'f.1', 'f' ], [ 'f.1.2', 'f' ], [ 'f.1.2.3', 'f' ], [ 'f.1.2.3.4', 'f' ], [ 'f.1.2.3.4.5', 'f' ], [ 'f.1.2.3.4.5.67', 'f' ], [ 'ABC.123.456', 'ABC' ], ); plan tests => scalar(@expected); for my $e (@expected) { my ( $got, $exp ) = @{$e}; $got =~ s/\..*$//; is( $got, $exp, "'$e->[0]'" . ' -> ' . "'$got'" ); }

    produces:

    1..20 ok 1 - 'abc' -> 'abc' ok 2 - 'abc.bill.com' -> 'abc' ok 3 - 'abc.bill.com.au' -> 'abc' ok 4 - 'xy42.com' -> 'xy42' ok 5 - 'x_y.com' -> 'x_y' ok 6 - 'x-y.com' -> 'x-y' ok 7 - '' -> '' ok 8 - '.' -> '' ok 9 - 'a.' -> 'a' ok 10 - '-.' -> '-' ok 11 - '_.' -> '_' ok 12 - '.a' -> '' ok 13 - 'f' -> 'f' ok 14 - 'f.1' -> 'f' ok 15 - 'f.1.2' -> 'f' ok 16 - 'f.1.2.3' -> 'f' ok 17 - 'f.1.2.3.4' -> 'f' ok 18 - 'f.1.2.3.4.5' -> 'f' ok 19 - 'f.1.2.3.4.5.67' -> 'f' ok 20 - 'ABC.123.456' -> 'ABC'

    I'm pretty sure I can assume my input is just an alphanumeric host name, for example fred42 or fred.com but not 192.0.2.16 say. I further doubt I need to deal with ports :80 or ?query or other guff. Though the above crude hack will probably be adequate for my needs, I'm interested to learn how other folks might tackle this sort of problem.

Brace in the replacement part of a regular expression substitution
3 direct replies — Read more / Contribute
by luc.bouge
on Oct 22, 2018 at 02:42

    Dear monks

    I have tried the following replacement script, which does not work.

    $ more replace.pl #!/usr/bin/perl -w -pi.orig s/(a)(b)/$1{$2}/g; $ more test.txt ab $ ./replace.pl test.txt Use of uninitialized value within %1 in substitution iterator at ./rep +lace.pl line 3, <> line 1. $ more test.txt (an empty line)
    However, it works fine with an additional escaping backslash before the left brace: s/(a)(b)/$1\{$2}/g;. I suspect that $1{$2} is recognized as addressing an associative array, but I could not find any mention in the documentation about such an expansion in the substitution part of a RE. Could somebody tell me? Regards, Luc.
Website for small perl scripts
6 direct replies — Read more / Contribute
by harangzsolt33
on Oct 22, 2018 at 02:05

    Is there a website where Perl programmers share their scripts that actually do something useful? For example, I began learning Perl a couple of years ago, and right now I am writing a script for myself that looks at all the JPG files on my hard drive and removes duplicates. But I think others have probably written scripts like that before. Right? Is there a website where people share their scripts for free? I can find tons of websites that teach Perl. But I want to download programs that actually do something. If I look for other source codes such as C or C++, the internet is literally full of source codes. I can find the C source code for almost anything! But so far I haven't found a lot of Perl scripts. Are people not into sharing too much? Here is the script I am working on right now. This is stage 1 :

    http://wzsn.net/perl/findjpg.txt

    This script just scans for JPG files. Then I am going to write another script that sorts the big list by file size. And then I am going to write another script that finds JPG files which have the exact same size. If two JPG files have the exact same size, then we shall open both files for reading and we'll compare the first 70000 bytes. And if they are an exact match, then I assume that the two photos are the same. So, the program will ask the user which one to delete.

Win32::OLE and Task Scheduling - Invalid Query
2 direct replies — Read more / Contribute
by kambe
on Oct 20, 2018 at 18:21

    I am trying to use Win32::OLE to create a task on a Windows 10 system, something similar to href:https://onedrive.live.com/?authkey=%21ABowWrIzVQzcElo&cid=07CD1B37769E1B7D&id=7CD1B37769E1B7D%21102691&parId=7CD1B37769E1B7D%21102690&o=OneUp. I tried to manually validate the query by creating the same task by hand in the task scheduler GUI, and that seemed to work.

    Here's my test code:

    use File::Basename; use Win32; use Win32::OLE; $Win32::OLE::Warn = 3; use Data::Dumper; my ($me, $dirpath, $suffix) = fileparse($0, qr/\.[^.]*/); my ($system, $login, $domain, $sidbin, $sidtype, $sidtxt) = ""; $login = Win32::LoginName(); Win32::LookupAccountName($system, $login, $domain, $sidbin, $sidtype); my($Revision, $SubAuthorityCount,@IdentifierAuthorities) = unpack("CCn +nn", $sidbin); unless (($IdentifierAuthorities[0] || $IdentifierAuthorities[1])) { my($temp, $temp2, @SubAuthorities) = unpack("VVV$SubAuthorityCount +",$sidbin); $sidtxt = "S-$Revision-$IdentifierAuthorities[2]-".join("-",@SubAu +thorities); } die Win32::OLE->LastError() unless (my $service = Win32::OLE->CreateOb +ject('Schedule.Service')); $service->Connect; my $RootFolder = $service->GetFolder('\\'); die Win32::OLE->LastError() unless (my $TaskDefinition = $service->New +Task(0)); die Win32::OLE->LastError() unless (my $regInfo = $TaskDefinition->Reg +istrationInfo); $regInfo->{Description} = "Register a perl task as an event $me"; $regInfo->{Author} = "$domain\\$login"; $regInfo->{URI} = "$sidtxt\\$me"; die Win32::OLE->LastError() unless (my $settings = $TaskDefinition->Se +ttings); $settings->{Enabled} = 1; $settings->{AllowDemandStart} = 1; $settings->{DisallowStartIfOnBatteries} = 0; $settings->{StopIfGoingOnBatteries} = 0; $settings->{Hidden} = 0; my @Triggers; my $TriggerSet; die Win32::OLE->LastError() unless ($TriggerSet = $TaskDefinition->Tri +ggers); for (10000..10001) { die Win32::OLE->LastError() unless (push @Triggers, $TriggerSet->C +reate(0)); $Triggers[$#Triggers]->{Id} = $_; $Triggers[$#Triggers]->{Subscription} = "<QueryList> <Query Id=\"event$_\" Path=\"Microsoft-Windows-NetworkProfile/Operat +ional\"> <Select Path=\"Microsoft-Windows-NetworkProfile/Operational\">*[Sy +stem[(EventID=\"$_\")]]</Select> </Query> </QueryList>"; die Win32::OLE->LastError() unless (my $values = $Triggers[$#Triggers]->ValueQueries->Create +("eventId", "Event/System/EventID")); $Triggers[$#Triggers]->{Enabled} = 1; } die Win32::OLE->LastError() unless (my $Action = $TaskDefinition->Acti +ons()->Create(0)); $Action->{Path} = 'C:\Perl64\Bin\Perl.exe'; $Action->{Arguments} = "$0 -f event\${eventID}"; $RootFolder->RegisterTaskDefinition("OLE-Test",$TaskDefinition,6,undef +,undef,3); print Dumper $TaskDefinition->{XmlText};

    If I run the code with RegisterTaskDefinition with TASK_VALIDATE_ONLY flag set (third parameter = 1), I get a nice XML dump. So far so good. When I run the code with RegisterTaskDefinition with TASK_CREATE_OR_UPDATE (third parameter = 6), I get this error:

    OLE exception from "<Unknown Source>": (11,263):Subscription:<QueryList><Query Id="event10000" Path="Microsoft-Windows-NetworkProfile/Operational"><Select Path="Microsoft-Windows-NetworkProfile/Operational">*[System[(EventID= +"10000")]]</Select></Query></QueryList> Win32::OLE(0.1712) error 0x80073a99: "The specified query is invalid" in METHOD/PROPERTYGET "RegisterTaskDefinition" at OLE-test.pl line + 63.

    Anyone familiar enough with Win32::OLE, and the Windows task scheduler XML to explain what I'm doing wrong

Simple search and output
3 direct replies — Read more / Contribute
by rvaughans
on Oct 20, 2018 at 10:39
    Hello... VERY new to Perl. I have a test file that I need to do a search (STDIN) and display ALL the lines found with the inputted string/variable. MUCH thanks in advance!!!
OK to Include CHI File Data in module Tests ?
1 direct reply — Read more / Contribute
by localshop
on Oct 20, 2018 at 00:52
    Trying to refine WebService::GoogleAPI::Client which uses CHI to cache resources pulled from Google API Discovery. In the package tests I'd like to maximise the coverage but don't wish to impose a whole bunch of HTTP requests every time tests are run. I was thinking that by bundling in a CHI::Driver::File directory for use by the tests I could default to using this and perhaps provide a switch to allow live requests for local dev testing where needed.

    I am concerned that the cache files won't be portable across platforms but I can probably catch that out.

    1. is this approach missing any obvious bad practice
    2. are any CPAN modules that do this that I could review?
    3. any advice on testing against network resources or cached data appreciated.

    Another option that occurred to me after posting this question is to create my own CHI::Driver subclass and use that for testing with some hard coded values.

    Many thanks for any advice.

glob an array?
2 direct replies — Read more / Contribute
by morgon
on Oct 19, 2018 at 21:10
    Hi,

    just for curiosity...

    If I have an array of filenames and a glob-pattern (as e.g. "*.hubba"), is there a way to "glob" the array (i.e. get the list of all elements matching the glob-pattern) using the same logic "glob" would use, or would I have to translate the gob-pattern into a regex and do a grep?

    Many thanks!

First attempt at bringing in file for input/output
7 direct replies — Read more / Contribute
by catfish1116
on Oct 19, 2018 at 15:48
    I am taking baby steps to understanding out to read in, modify file(s) and then send modified file to output. Here is my attempt to just read in a file and send it to output.
    #!/bin/perl use v5.12; use warnings; my $in = $ARGV[0]; if (! defined $in) { die "Usage: $0 filename"; } my $out = $in; $out =~ s/(\.\w+)?$/out/; if (! open $in_fh, '<', $in ) { die "Can't open '$in': $!"; } if (! open $out_fh, '>', $out) { die "Can't write '$out': $!"; }

    Here is the errors that I received:

    Global symbol "$in_fh" requires explicit package name at ./exer_9_2 li +ne 14. Global symbol "$out_fh" requires explicit package name at ./exer_9_2 l +ine 1

    What 'package' am I missing?

    Catfish
Solved! I would have expected a syntax error here
6 direct replies — Read more / Contribute
by roboticus
on Oct 19, 2018 at 12:05

    Thanks, guys! That was a quick resolution. Indirect Object syntax was what tripped me up. As haukex suggests, I'll have to start using the Yadda, Yadda operator ... to ensure that I don't miss that in the future.

    Using that operator and a comment, I can either let the program run and execute and die only if I reach unfinished code:

    sub find_symbol { ... # got to here today! (20180520) }
    $ perl xyzzy.pl Foo! Unimplemented at xyzzy.pl line 13.

    Or if I'd rather have the program just fail without running, I can prefix my original comment with the operator (so long as I don't use a semicolon as the first character in my comment:

    sub find_symbol { ... got to here today! (20180520) }
    $ perl xyzzy.pl syntax error at xyzzy.pl line 12, near "... got to " Execution of xyzzy.pl aborted due to compilation errors.

    Really, though, not one Monty Python reference? 8^)

    Original post follows:


    Hello, gang:

    When I write experimental bits of code and don't get a chance to finish, I'll frequently mark my position with a few words and no comment marker with the intent that if I run the program, perl will tell me that bit(s) of my code are unfinished, and let me know where the unfinished bits are. This morning I decided to adapt a working program I've been using all week to add some new functionality, and when I looked at the code, I saw this bit:

    sub find_symbol { got to here today! (20180520) }

    What the heck? The code is working, but that subroutine just can't be right. So I looked over the program--It doesn't look like the code is commented out anywhere (I normally use "=h1 foo" and "=cut" to comment out blocks of code I don't want to use). I ran:

    $ perl -c LTSpice_to_graph.pl LTSpice_to_graph.pl syntax OK

    OK, then, *something* has to be masking this syntax error, right? So I copied the code to xyzzy.pl and started removing chunk after chunk, eventually coming up with:

    $ cat xyzzy.pl #!env perl use strict; use warnings; find_symbol(); sub find_symbol { got to here today } $ perl -c xyzzy.pl xyzzy.pl syntax OK $ perl -MO=Concise xyzzy.pl 6 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 5 xyzzy.pl:5) v:*,&,{,x*,x&,x$,$ ->3 5 <1> entersub[t2] vKS/TARG,STRICT ->6 - <1> ex-list K ->5 3 <0> pushmark s ->4 - <1> ex-rv2cv sK/STRICT,1 ->- 4 <#> gv[*find_symbol] s/EARLYCV ->5 - <;> ex-nextstate(main 7 xyzzy.pl:10) v:*,&,{,x*,x&,x$,$ ->6 xyzzy.pl syntax OK

    So consider me baffled, I don't know what's going on here. Can anyone tell me what I'm not seeing?

    For the record:

    $ perl -version This is perl 5, version 26, subversion 2 (v5.26.2) built for x86_64-cy +gwin-threads-multi (with 7 registered patches, see perl -V for more detail)

    Interesting ... one more bit of information before I hit the preview button. I changed the contents of the subroutine to:

    sub find_symbol { I got to here today }

    and now I get what I expected to see:

    $ perl -c xyzzy.pl Bareword "today" not allowed while "strict subs" in use at xyzzy.pl li +ne 8. xyzzy.pl had compilation errors.

    Does anyone know what's happening here? My only (ill-informed) guess would be something to do with parsing the GOTO statement.

    ...roboticus

    When your only tool is a hammer, all problems look like your thumb.

diff vs diff -y
5 direct replies — Read more / Contribute
by MissPerl
on Oct 19, 2018 at 11:16
    I am not sure if anyone have the similar issue,
    $a = "/path/to/a/file"; $b = "/path/to/b/file"; $difference = system("$diff $a $b"); $difference2 = system("$diff -y $a $b");
    The $difference printed in html file only shows the difference - top & bottom (maybe 2 or 3 lines from 1000 lines).

    But the $difference2 printed in html file shows all the difference in 2 columns -left & right (1000 lines from 1000 lines).

    The output is actually fine, since I dont want to compare line by line, as sometime one has some extra lines while the other dont,

    So i want those extra lines which is in a and in b at the same file same time.

    Here, I am wondering if it is possible to have the sort of combination of both $diff and $diff -y, having 2 left/right columns of difference in some lines only (not showing every lines)
    if ($difference eq ''){ $difference = "Exactly Same.\n"; } push @table1, "<table id =\"Table1\">"; push @table1, "<tr><th>path A</th><th>A</th><th>path B</th><th>B</th>< +/tr>"; push @table1, "<tr><td colspan =\"4\">$difference</td></tr>";
    So that, $difference will shown in 2 columns with the line of differences in file.

    Any idea guys ?

New Cool Uses for Perl
Cheat at Scrabble
5 direct replies — Read more / Contribute
by 1nickt
on Oct 21, 2018 at 09:51

    Calculates the highest score possible from the letters given, taking into account any bonuses on the squares to be covered.

    (Rudimentary tool that does not handle combinations with the words already on the board).

    My local newspaper has a Scrabble-based game that involves simply finding the highest scoring word from seven letters and bonus tile positions provided. Note: quite often the highest scoring word according to the newspaper is not found in my words list :-(

    Specify double- and triple-word bonuses with -dw and -tw, and double- and triple-letter bonuses with -dl=N and -tl=N where N is the letter position.

    Examples:

    $ perl scrabble.pl eoaprzn Found 13,699 1-7 letter strings in eoaprzn. Found 57 words in eoaprzn. zap : 14 $ perl scrabble.pl eoaprzn -dw Found 13,699 1-7 letter strings in eoaprzn. Found 57 words in eoaprzn. zap : 28 $ perl scrabble.pl eoaprzn -tl=3 Found 13,699 1-7 letter strings in eoaprzn. Found 57 words in eoaprzn. raze : 33

    use strict; use warnings; use feature 'say'; use Path::Tiny; use Algorithm::Permute; use Number::Format 'format_number'; use List::Util 'uniq'; use Getopt::Long; my @dl; my @tl; my $dw; my $tw; my $debug; GetOptions( 'dl=i' => \@dl, 'tl=i' => \@tl, 'dw' => \$dw, 'tw' => \$tw, 'v' => \$debug, ); my $input = shift or die 'Died: No input!'; my $length = length $input; my @input_chars = split '', $input; my $words_file = '/usr/share/dict/words'; my %words = map { $_ => 1 } path( $words_file )->lines({chomp => + 1}); my %worth = ( a => 1, b => 3, c => 3, d => 2, e => 1, f => 4, g => 2, h => 4, i => 1, j => 8, k => 5, l => 1, m => 3, n => 1, o => 1, p => 3, q => 10, r => 1, s => 1, t => 1, u => 1, v => 2, w => 2, x => 8, y => 4, z => 10, ); my @partials; for (1 .. $length) { my $P = Algorithm::Permute->new( \@input_chars, $_ ); while (my @res = $P->next) { push @partials, join '', @res; } } @partials = uniq @partials; say sprintf 'Found %s 1-%s letter strings in %s.', format_number(scalar @partials), $length, $input; my %found = map { $_ => calc_score($_) } grep { $words{$_} } @partials + ; say sprintf 'Found %s words in %s.', format_number(scalar keys %found) +, $input; for ( sort { $found{$b} <=> $found{$a} } keys %found ) { say "$_ : $found{$_}"; last if not $debug; } ############### sub calc_score { my $word = shift; my $val; $val += $worth{$_} for split '', $word; $val += 50 if length $word == 7; return $val + calc_bonus($word, $val); } sub calc_bonus { my ($word, $val) = @_; my @chars = split '', $word; my $bonus = 0; for (@dl) { $bonus += $worth{ $chars[$_ - 1] } if $chars[$_ - 1]; } for (@tl) { $bonus += 2 * $worth{ $chars[$_ - 1] } if $chars[$_ - 1]; } $bonus += $val if $dw; $bonus += 2 * $val if $tw; return $bonus; } __END__


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 drinking their drinks and smoking their pipes about the Monastery: (3)
As of 2018-10-23 02:43 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    When I need money for a bigger acquisition, I usually ...














    Results (125 votes). Check out past polls.

    Notices?