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
Outputting JSON with function () {...} values
3 direct replies — Read more / Contribute
by cosmicperl
on Oct 22, 2018 at 10:36

    Hi All,

    I was just refactoring some hand crafted JSON to use JSON's to_json method. However, I couldn't actually see a way to do it, as some of the values are functions. A simple example:

    { a: function() {return true;} }

    After perusing the JSON POD I can't see a way of getting this output from a Perl data structure.

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}; } }
Destinkifying some weird Moose code
No replies — Read more | Post response
by nysus
on Oct 22, 2018 at 05:50

    For fun, to help improve my Perl skills, and to help understand the Rex module, I decided to clone Rex with Moose using test-driven development and MooseX::App::Cmd::Command.

    Rex is a module for running remote commands on a server. It loads a simple DSL from a config file. The config file is simple Perl code. I was able to get it implemented and it works, but I'm sure there is probably a better approach than what I came up with for loading the config file. I'd be interested in hearing some better approaches to help advance my skills. Here is an SSCCE. To get it to work, just put in your user and host on lines 228 and 232. Name the file spin.pl and run it with ./spin.pl uname.

    The particularly smelly bits are marked with triple hashes (###) and contain explanations for what's going on. Thanks!

    $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

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?

Run executable and follow on commands from CMD line
1 direct reply — Read more / Contribute
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


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.