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
Security Checks for CPAN Module Authors
No replies — Read more | Post response
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?

Run executable and follow on commands from CMD line
No replies — Read more | Post response
by Anonymous Monk
on Oct 22, 2018 at 04:31

    I am trying to write a simple script to 1) open a new CMD window 2) navigate to a location 3) execute a .exe 3) run commands in new state (from .exe). The purpose of the exe is to open a com into another program.

    #!/bin/perl use strict; use warnings; system ('start cmd /k cd C:/some location/gateway.exe uname@jupiter.ju +piter &&COM open_job,job=232');
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
2 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.

Object Identifier?
2 direct replies — Read more / Contribute
by damfer21
on Oct 21, 2018 at 18:17

    I tried to add a parameter to the following code and it does not work. If you see the "$last240_flag" in the code, that one is the one that doesn't work. The others do as expected. Is there somewhere that I can find the definitions of the "_flag"? I am extremely new at this, and my admin retired so I cannot get any help. Apologies if this is a silly question.

    # ******************************************************************** +********************* # camp_schedule.cgi # # ******************************************************************** +********************* # include Perl Modules use strict; use CGI; use empire; # get some objects to use later my $pms = empire->new; my $query = CGI->new; my $sth; my $sth2; my $sql; my $dbh; my $campaign_id = $query->param('campaign_id'); my $list_id; my $status; my $cname; my $schedule_date; my $shour; my $smin; my $max_emails; my $old_mid; my $old_dname; my $clast60; my $openflag; my $aolflag; my $yahoo_flag; my $yahoo_only_flag; my $yahoo_no_flag; my $yes_flag; my $no_flag; my $seven_flag; my $last90_flag; my $last120_flag; my $last240_flag; my $yes_open_flag; my $no_open_flag; my $aol_yes_flag; my $aol_no_flag; my $both_flag; my $light_table_bg = $pms->get_light_table_bg; my $images = $pms->get_images_url; my $list_members = 1; my $counter; # connect to the pms database $pms->db_connect(); $dbh = $pms->get_dbh; # check for login my $user_id = empire::check_security(); if ($user_id == 0) { print "Location: notloggedin.cgi\n\n"; $pms->clean_up(); exit(0); } # make sure this campaign has some valid member list or lists assigned + to it before # allowing the user to schedule it to be sent. $sql = "select list_id from campaign_list where campaign_id = $campaig +n_id"; $sth = $dbh->prepare($sql); $sth->execute(); while (($list_id) = $sth->fetchrow_array()) { $sql = "select member_cnt from list where list_id = $list_id and s +tatus = 'A'"; $sth2 = $dbh->prepare($sql); $sth2->execute(); ($counter) = $sth2->fetchrow_array(); $sth2->finish(); $list_members = $list_members + $counter; } $sth->finish(); if ($list_members == 0) { empire::logerror("Error, the campaign you selected does not have a +ny email member lists <br> assigned to it. You must assign at least one emai +l list that contains <br> some active members to this campaign before it can + be scheduled."); $pms->clean_up(); exit(0); } # print out the html page my $cdate; $sql = "select now()"; $sth = $dbh->prepare($sql); $sth->execute(); ($cdate)=$sth->fetchrow_array(); $sth->finish(); empire::header("Campaign Schedule"); $sql = "select status,curdate(),max_emails,last60_flag,aol_flag,open_f +lag,yahoo_flag,hour(schedule_time),minute(schedule_time),mid,redirect +_domain,campaign_name from campaign where campaign_id=$campaign_id"; $sth = $dbh->prepare($sql); $sth->execute(); ($status,$schedule_date,$max_emails,$clast60,$aolflag,$openflag,$yahoo +_flag,$shour,$smin,$old_mid,$old_dname,$cname) = $sth->fetchrow_array +(); print << "end_of_html"; </TD> </TR> <TR> <TD vAlign=top align=left bgColor=#999999> <TABLE cellSpacing=0 cellPadding=10 bgColor=#999999 border=0 width +="100%"> <TBODY> <TR> <TD vAlign=top align=left bgColor=#ffffff colSpan=10><!-- doing ct +-table-open --> <TABLE cellSpacing=0 cellPadding=0 width=660 bgColor=#ffffff b +order=0> <TBODY> <TR> <TD vAlign=center align=left><font face="verdana,arial,hel +vetica,sans serif" color="#509C10" size="3"><b>Schedule Your Campaign</b> +</font></TD> </TR> <TR> <TD><IMG height=3 src="$images/spacer.gif"></TD> </TR> </TBODY> </TABLE> <TABLE cellSpacing=0 cellPadding=0 width=660 bgColor=#ffffff b +order=0> <TBODY> <TR> <TD><FONT face="verdana,arial,helvetica,sans serif" color=#509 +C10 size=2> Set your Campaign status to either Draft or Scheduled. You +r Campaign will remain in Draft mode until you move it to Scheduled. +If you schedule your Campaign, it will be sent on the date specified beginning +around midnight. If you schedule your Campaign for today, it will begin goi +ng out in the next 5 minutes.<BR></FONT></TD> </TR> <TR> <TD><IMG height=5 src="$images/spacer.gif"></TD> </TR> </TBODY> </TABLE> <FORM action="camp_copy_schedule_save.cgi" method=post name="b +date"> <INPUT type=hidden name="campaign_id" value="$campaign_id"> <TABLE cellSpacing=0 cellPadding=0 width=760 bgColor=#ffffff b +order=0> <TBODY> <TR> <TD> <TABLE cellSpacing=0 cellPadding=5 width="100%" border=0> <TBODY> <TR> <TD align=middle> <TABLE cellSpacing=0 cellPadding=0 width=500 bgColor=$ +light_table_bg border=0> <TBODY> <TR align=top bgColor=#509C10 height=18> <TD vAlign=top align=left height=15><IMG src="$images/ +blue_tl.gif" border=0 width="7" height="7"></TD> <TD height=15><IMG height=1 src="$images/spacer.gif" w +idth=3 border=0></TD> <TD align=middle height=15> <TABLE cellSpacing=0 cellPadding=0 width="100%" bo +rder=0> <TBODY> <TR bgColor=#509C10 height=15> <TD align=middle width="100%" height=15> <FONT face=Verdana,Arial,Helvetica,sans-serif +color=white size=2> <B>Campaign Status</B>&nbsp;&nbsp;Current Date +time: $cdate </FONT> </TD> </TR> </TBODY> </TABLE> </TD> <TD height=15><IMG height=1 src="$images/spacer.gif" w +idth=3 border=0></TD> <TD vAlign=top align=right bgColor=#509C10 height=15> <IMG src="$images/blue_tr.gif" border=0 width="7" +height="7"></TD> </TR> <TR bgColor=$light_table_bg> <TD colSpan=5><IMG height=3 src="$images/spacer.gif" w +idth=1 border=0></TD> </TR> <TR bgColor=$light_table_bg> <TD><IMG height=3 src="$images/spacer.gif" width=3></T +D> <TD align=middle><IMG height=3 src="$images/spacer.gif +" width=3></TD> <TD align=middle> <TABLE cellSpacing=0 cellPadding=0 width="100%" bo +rder=0> <TBODY> <TR> <TD align=middle><IMG height=3 src="$images/spacer +.gif" width=3></TD> </TR> <tr> <TD vAlign=center align=left><FONT face="verdana,a +rial,helvetica,sans serif" color=#509C10 size=2>New Campaign Name: <input type=text name=cname value="$cname" siz +e=50></font></td> </tr> <TR> <TD vAlign=center align=left><FONT face="verdana,a +rial,helvetica,sans serif" color=#509C10 size=2> end_of_html # get schedule information for this campaign if ($old_dname eq "") { $old_dname="NONE"; } if ($status eq "D") { my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localti +me(); $year = $year + 1900; $mon = $mon + 1; if ($mon < 10) { $mon = "0$mon"; } if ($mday < 10) { $mday = "0$mday"; } $schedule_date = "$mon/$mday/$year"; print<<"end_of_html"; <script language="JavaScript1.2" src="/CalendarPopup.js"></script> <SCRIPT LANGUAGE="JavaScript"> var cal = new CalendarPopup(); </SCRIPT> end_of_html print qq { <INPUT style="BACKGROUND: $light_table_bg" type=radio CHECKED +name=schedule value=D>Draft<BR> <INPUT style="BACKGROUND: $light_table_bg" type=radio name=sch +edule value=S>Scheduled for <INPUT type="text" name="sdate" size="10" value="$schedule_dat +e">\n }; print qq { <A HREF="#" onClick="cal.select(document.forms['bdate'].sdate +,'anchor1','MM/dd/yyyy'); return false;" NAME="anchor1" ID="anchor1"> +<img src="/images/calendar_Icon.jpg" border=0 width="27" height="25"> +</A> }; } else { $schedule_date = substr($schedule_date,5,2) . "/" . substr($schedu +le_date,8,2) . "/" . substr($schedule_date,0,4); print qq { <INPUT style="BACKGROUND: $light_table_bg" type=radio name=sch +edule value=D>Draft<BR> <INPUT style="BACKGROUND: $light_table_bg" type=radio CHECKED +name=schedule value="$status">Scheduled for <INPUT type="text" name="sdate" size="10" value="$schedule_dat +e"> \n }; print qq { <A HREF="#" onClick="cal.select(document.forms['bdate'].sdate +,'anchor1','MM/dd/yyyy'); return false;" NAME="anchor1" ID="anchor1"> +<img src="/images/calendar_Icon.jpg" border=0 width="27" height="25"> +</A> }; } $sth->finish(); my $i=0; print "&nbsp;&nbsp;Hour: <select name=shour>\n"; while ($i < 24) { if ($i == $shour) { print "<option selected value=$i>$i</option>"; } else { print "<option value=$i>$i</option>"; } $i++; } print "</select>"; my $i=0; print "&nbsp;&nbsp;Minute: <select name=smin>\n"; while ($i < 60) { if ($i == $smin) { print "<option selected value=$i>$i</option>"; } else { print "<option value=$i>$i</option>"; } $i++; } print "</select>"; if ($clast60 eq "Y") { $yes_flag="checked"; $no_flag = ""; $seven_flag = ""; $last90_flag = ""; $last120_flag = ""; $last240_flag = ""; } elsif ($clast60 eq "7") { $no_flag=""; $yes_flag = ""; $seven_flag = "checked"; $last90_flag = ""; $last120_flag = ""; $last240_flag = ""; } elsif ($clast60 eq "9") { $no_flag=""; $yes_flag = ""; $seven_flag = ""; $last90_flag = "checked"; $last120_flag = ""; $last240_flag = ""; } elsif ($clast60 eq "2") { $no_flag=""; $yes_flag = ""; $seven_flag = ""; $last90_flag = ""; $last120_flag = "checked"; $last240_flag = ""; } elsif ($clast60 eq "4") { $no_flag=""; $yes_flag = ""; $seven_flag = ""; $last90_flag = ""; $last120_flag = ""; $last240_flag = "checked";";
Possible to change package of code reference?
2 direct replies — Read more / Contribute
by nysus
on Oct 21, 2018 at 14:07

    I have the following to output the contents of a $func which contains a code reference:

    my $deparse = B::Deparse->new; print dumper $deparse->coderef2text($func);

    It spits out:

    $VAR1 = '{ package Spin::Command::spin; run(q[export MYVAR=\'(R)?ex\']); run(\'uname -a\'); run(q[echo \'Running: \' $MYVAR]); run(\'id\'); }';

    I'd like to change the package from Spin::Command::spin to something else. Is this possible?

    $PM = "Perl Monk's";
    $MCF = "Most Clueless Friar Abbot Bishop Pontiff Deacon Curate Priest Vicar";
    $nysus = $PM . ' ' . $MCF;
    Click here if you love Perl Monks

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.


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.