Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

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
list of four digit lock combinations without repeated digits
7 direct replies — Read more / Contribute
by Lotus1
on Jun 20, 2018 at 14:58

    I have a spare key lock for my front door that takes four digits without repeated digits and the order doesn't matter. I've forgotten the combination so I wrote a script to give me a list of the possible combinations. I'm planning to replace this since I don't like that it only has 210 possible combinations but I have to open it before I can remove it. Here is my solution. I found the text at the top in one of the answers at https://math.stackexchange.com/questions/156928/number-of-4-digit-numbers-with-no-repeated-digit.

    I'm wondering if there is a way to do this with some modules or if anyone else has interesting solutions.

    use strict; use warnings; # Four digit mechanical lock: no repeated digits, order doesn't matter +. # #https://math.stackexchange.com/questions/156928/number-of-4-digit-num +bers-with-no-repeated-digit # Start by finding the permutations: For the first choice, you have 10 + possible digits to choose from. #For the second choice, you have 9 digits because you used one for the + first choice. #The third choice comes from 8 possibilities and the fourth from 7 pos +sibilities. #Now we multiply these together: 10 x 9 x 8 x 7 = 90 x 56 = 5040. That +'s the number of permutations. #No digits repeat, but 0123 is different from 0321. # Now to find the number of combinations, I have to know how many diff +erent ways there are of arranging four digits. #That's the same kind of problem: the first position could be from 4 p +ossibilities, the second from 3 possiblities, #the third from 2 choices and the last has to be the 1 left. So there +are 4 x 3 x 2 x 1 = 24 possible ways of #arranging 4 items. # Therefore I divide 5040 / 24 = 210. So there are 210 different combi +nations of four digits chosen #from 0-9 where the digits don't repeat. my %output; foreach(123..9876){ my $num = sprintf "%04d", $_; next if $num =~ /(\d).*\1/; my @digits = sort split //, $num; my $num_sorted = join '', @digits; #print "$num: @digits - $num_sorted\n"; if (not exists $output{$num_sorted} ) { #print "adding $num_sorted\n"; $output{$num_sorted}=1; } } print "found ", scalar keys %output, " combinations.\n"; print "$_\n" foreach sort keys %output;

    Here are the results:

    Edit:After posting I realized I remembered one of the digits which narrowed the list down by a lot. My $spouse remembered the code before I started trying but the lock would have been opened within my first few attempts from the list.

Replacing CGI.pm
5 direct replies — Read more / Contribute
by horace
on Jun 20, 2018 at 13:22

    I have several Perl, use CGI qw(:standard) - scripts that are fine and well-tested, uses function style programming. I would like to upgrade our servers OS from Wheezy to Debian Stretch which does not have CGI.pm in the Perl core. I believe the upgrade to Stretch will leave CGI.pm intact (which the scripts need), but if not, what do I do? Should I consider PSGI/Plack? I'm happy with everything now but eventually something will have to be done. Is there an easy work-around?

remove a comma
5 direct replies — Read more / Contribute
by luupski
on Jun 20, 2018 at 13:22

    I have the following list in a notepad file called CUSTOMER.txt

    --- this is CUSTOMER.txt (input) ---
    0001 20000001 john CA
    0002 30000002 neill WI
    0003 40000003 joe GA
    0004 50000004 will IL
    0005 60000005 mike IN
    0006 70000006 bill AK

    I feed this into the script and get the following output which is placed in the CUSTOMER_NEW.txt file
    All good for except 1 thing.
    I want the last ' , ' (comma)to be removed before the closing bracket.
    Tried several things after googling, but no success

    So i was wandering if anybody has an idea how to add to the code given that will remove the last ' , '


    --- this is CUSTOMER_NEW.txt (output) ---
    SELECT CUSTOMERID, ORDERID, CUSTOMERNAME, CUSTOMERLOCATION
    FROM DB.CUSTOMER_DATA
    WHERE (CUSTOMERID, ORDERID, CUSTOMERNAME, CUSTOMERLOCATION) IN (
    (0001,20000001,john,CA),
    (0002,30000002,neill,WI),
    (0003,40000003,joe,GA),
    (0004,50000004,will,IL),
    (0005,60000005,mike,IN),
    (0006,70000006,bill,AK),
    )

    --- script used ---
    sub customer {system ("notepad ./CUSTOMER.txt"); $dir="./"; $custom=$dir."CUSTOMER.txt"; $dir="./CUSTOMER_DIR/"; $ofile=$dir."CUSTOMER_NEW.txt"; open (IN,"$custom") || die "Cannot open CUSTOMER.txt!!!\n"; open (OUT,">$ofile") || die "Cannot open CUSTOMER_NEW.txt!!!\n"; print OUT "SELECT CUSTOMERID, ORDERID, CUSTOMERNAME, CUSTOMERLOCATION FROM DB.CUSTOMER_DATA WHERE (CUSTOMERID, ORDERID, CUSTOMERNAME, CUSTOMERLOCATION) IN (\n"; @CUST=<IN>;close IN; foreach $infile (@CUST){ chomp($infile); $i=0; @a=split(/\|/,$infile); @BAGO=$a[$i]; foreach $infile1 (@BAGO){ @b=split(/\s+/,$infile1); print OUT "($b[0],$b[1],$b[2],$b[3])\,\n"; $i++;}} print OUT ")\n"; system ("notepad ./CUSTOMER_DIR/CUSTOMER_NEW.txt"); close OUT; goto START; }
print a file from Bottom to Top (reverse order)
4 direct replies — Read more / Contribute
by theravadamonk
on Jun 20, 2018 at 12:23

    Hi, Monks, I want to know how to print a file from Bottom to Top (reverse order).

    I found this below link with below code

    https://www.perlmonks.org/?node_id=361397

    open(FILE, "<myfile.txt"); @file = reverse <FILE>; foreach (@file) { #process line }

    Given below is My CODE with while loop, I want to go with while loop. How can I print from Bottom to Top ?

    How can I insert reverse order in to while loop?

    What's the easiest way ? I DO hope U monks will come with ideas...

    #!/usr/bin/perl use CGI ':standard'; use strict; use warnings; use CGI::Carp 'fatalsToBrowser'; # use only for testing #my $date = localtime(); $ENV{"PATH"} = "/usr/sbin:/usr/bin:/sbin:/bin"; open FILE, '<', '/var/log/maillog' or die $!; while (<FILE>){ chomp; next unless /\S/; # skip blank lines if (/Passed CLEAN/) { #search string Passed CLEAN print "$_ \n"; # print ALL lines containing Passed CLEAN } } close FILE;
Minimizing the amount of place holders on long identical regex
6 direct replies — Read more / Contribute
by thanos1983
on Jun 20, 2018 at 11:53

    I am really bad in regex and my best attempt that is working from my point of view is really poor in syntax. I am sure that it can be done in a different way and shorter.

    I am currently having a string that it is 24 numerical characters long and I have created a regex to split the string on pieces character by character so I can extract the odd place holders that contain the actual information that I need.

    What I have so far is:

    #!/usr/bin/env perl use strict; use warnings; my $sample = "041424344454647484940414"; $sample =~ /([0-9])([0-9])([0-9])([0-9])([0-9])([0-9])([0-9])([0-9])([ +0-9])([0-9])([0-9])([0-9])([0-9])([0-9])([0-9])([0-9])([0-9])([0-9])( +[0-9])([0-9])([0-9])([0-9])([0-9])([0-9])/; # 24 times the same patte +rn print "$1$3$5$7$9$11$13$15$17$19$21$23\n"; __END__ $ perl test.pl 012345678901

    This is the desired output and it is working but I was wondering if there is a more elegant way to minimize replicating the same group 24 times but also being able to get the odd place holders ($1$3$5...).

    I could use potentially split the string character by character and store the output in an array. Where from there I would remove the even elements and reform the array into string with join. But in my case this is not possible as the system that I am writing the regex does not support the split function or join it only supports C format commands syntax, so I am using Perl as a test tool before implementation.

    If any one has any idea how to make this regex shorter feel free to drop a comment.

    Thanks in advance for your time and effort, BR.

    Seeking for Perl wisdom...on the process of learning...not there...yet!
Input Validation and pattern matching in Template Toolkit
5 direct replies — Read more / Contribute
by dipit
on Jun 20, 2018 at 03:57
    [% META title = 'Add xyz' %] [% attack = params.taskid_login %] [% IF attack.search('<script>') || attack.search('</script>') || attac +k.search('alert') %] [% attack = params.taskid_login | uri | html %] [% ELSE %][% attack = params.taskid_login %] <p> To add a new task ID member to <b>[% attack %]</b>, select one or +more users from the table below. </p> [% WRAPPER filter.tt filterTitle='Users filter' filterAction='add_task +id_member' %] [% INCLUDE form_textfield.tt fieldName='filter_login' fieldValue=p +arams.filter_login maxLength=100 %] [% END %] [%# Show global message is one or more members have been added... %] [% IF NumberOfAddedRecords %] [% INCLUDE global_message.tt globalMessage=NumberOfAddedRecords _ +' users have been added.' %] [% END %] [% INCLUDE form_table.tt table=PossibleMembersTable %]

    Hello All. Here i have created a varibale named "attack" and checking some validation over it. params.taskid_login is the input value to "attack" variable here. I want to detect <script> and alert tags here. I think my syntax is wrong so my page containing this template is not loading. Please help?

win32::serial problem
No replies — Read more | Post response
by spencoid
on Jun 20, 2018 at 00:34
    I finally figured out how to send and receive data to/from my RS232 Balance. It was a struggle to get the correct parameters etc. Now I have a perl script sort of working but there is a major problem. The code below is written as a TKX program. All it does is send hex strings to the scale to make it report back and also to operate the tare function. It works but only once every time I open the program. Multiple clicks on the read button (calls a sub to send characters) after the first return nothing. Tare button does nothing unless it is the first thing done after the program starts and then the scale does not respond until the program is closed. I have looked over win32::serial over and over and tried everything i could think of but nothing changes. The communication is working because the scale does report one value or does on tare operation when the program closes. sorry for all the TK stuff getting in the way. At the end is a bare bones version but it does not work for my testing because the script ends after each sent character.
    #!/usr/bin/perl -w use strict; use Tkx; use Win32::SerialPort; use Cwd; use File::Copy; my $path = getcwd; my $read_scale; my $main_back_color = "#EAC9E0"; my $backcolor = "#E798FF"; my $active_color = "#D4D0C8"; my $scale; my $maintitle = "Read Sartorius"; my $version = " version 1.000"; Tkx::catch("console hide"); my $mw = Tkx::widget->new("."); $mw->g_wm_resizable(0,0); $mw-> g_wm_title($maintitle); $mw->g_grid_columnconfigure(0, -weight => 1); $mw->g_grid_rowconfigure(0, -weight => 1); Tkx::font_create("headtext_font",-size => 14); Tkx::font_create("scale_font",-size => 10); Tkx::font_create("bold_label_font", -size => 12, -weight=> 'bold'); Tkx::font_create("small_button_font", -size => 6,-weight=> 'normal'); my $menu = $mw->new_menu; $mw->configure(-menu => $menu); my $std_fncts = $menu->new_menu; my $test = $menu->new_menu; $menu->add_cascade(-menu => $test, -label => "Help"); $test->add_command(-label => "no Help yet", -command => sub {fill_help("F");do_help(25,100);}); $menu->add_command(-label => "Exit", -command => sub{\&clean_exit()}); my $frame0 = $mw-> new_frame(-relief=>'raised',-borderwidth=>2,-bd=>1, +-background=> "$backcolor"); $frame0->g_grid(-column =>0, -row => 0,-sticky => "ns"); my $buttons = $frame0-> new_frame(-bd=>2,-relief=>'raised',-relief=>'r +aised'); #,-background =>$check_button_color); $buttons->g_grid(-column =>0,-rowspan => 2, -row => 4,-sticky => "nsew +"); my $readbut = $buttons->new_button (-text => "Read", , -width=> 11,-co +mmand => sub {read_scale();}, -background => "green", -activebackgrou +nd => "red", -pady => 5, -padx => 6); $readbut -> g_grid(-column =>0, -row => 0, -sticky => "E"); my $tarebut = $buttons->new_button (-text => "Tare", -width=> 10, -com +mand => sub {tare_scale();}, -background => "red", -pady => 5, -padx +=> 3); $tarebut -> g_grid(-column =>1, -row => 0, -sticky => "E"); my $lblscale = $buttons->new_label (-text => "Scale"); $lblscale -> g_grid(-column => 0, -row => 1, -sticky => "w"); my $eread_scale = $buttons->new_entry (-width => 15, -textvariable => +\$read_scale); $eread_scale -> g_grid(-column => 1, -row => 1, -sticky => "w"); my $PORT = "COM1"; # port to watch my $ob = Win32::SerialPort->new ($PORT) || die "Can't Open $PORT: $!"; $ob->baudrate(1200) || die "failed setting baudrate"; $ob->parity("odd") || die "failed setting parity"; $ob->databits(7) || die "failed setting databits"; $ob->handshake("rts") || die "failed setting handshake"; $ob->stopbits(1) || die "failed setting stop bits";; $ob->write_settings || die "no settings"; sub read_scale{ $ob->transmit_char(0x1b); $ob->transmit_char(0x50); $ob->transmit_char(0x0d); $ob->transmit_char(0x0a); sleep .2; my $result = $ob->input; $read_scale = ($result); print "result = $result\n"; my $got_it = $ob->lookfor; } sub tare_scale{ $ob->transmit_char(0x1b); $ob->transmit_char(0x54); $ob->transmit_char(0x0d); $ob->transmit_char(0x0a); } sub clean_exit{ undef $ob; exit; } Tkx::MainLoop();
    $PORT = "COM1"; # port to watch $ob = Win32::SerialPort->new ($PORT) || die "Can't Open $PORT: $!"; $ob->baudrate(1200) || die "failed setting baudrate"; $ob->parity("odd") || die "failed setting parity"; $ob->databits(7) || die "failed setting databits"; $ob->handshake("rts") || die "failed setting handshake"; $ob->stopbits(1) || die "failed setting stop bits";; $ob->write_settings || die "no settings"; # Send a hex string to the port my $sendP = pack('C*', 0x1b, 0x50); # the print command my $sendT = pack('C*', 0x1b, 0x54); # the tare command my $pass=$ob->write($sendP); sleep 1; my $result = $ob->input; print "result = $result\n"; undef $ob;
Help with script recognizing variable in string
1 direct reply — Read more / Contribute
by TonyNY
on Jun 19, 2018 at 21:36
    Hi,

    I'm most likely not even asking this question correctly so let me try to explain as best I can. I'm running the following relevance query using curl and need for the $bfquery variable to recognize $bfcomputer as the value of the argument when I run the script. Sort of nesting a variable inside of a variable if you will.

    $bfquery='query?relevance=%28names%20of%20it%2C%20ip%20addresses%20of% +20it%2C%20root%20server%20of%20it%2C%20operating%20systems%20of%20it% +2C%20 last%20report%20time%20of%20it%2C%20agent%20versions%20of%20it%2C%20va +lues%20of%20results%20from%20%28BES%20Property%20%22_SupportGroup%22% +29%20of%20it%29%20of%20bes%20 computers%20whose%20%28%20name%20of%20it%20as%20lowercase%20starts%20w +ith%20%22$bfcomputer%22%29';
    tried putting {} around $bfcomputer but that did not help.

    Kind Regards,

    Tony

Matching patterns with or
2 direct replies — Read more / Contribute
by corfuitl
on Jun 19, 2018 at 12:06

    Dear Perlmonks

    Applying the following code

    while ($_ =~ /({\d+})/ || $_ =~ /({\w+&gt;)/ || $_ =~ /(&lt;\w+})/){ print "$1\n"; }

    to this text

    This is &lt;i} a test {i&gt; sentence &lt;i}

    I get

    {i&gt;    &lt;i}    &lt;i}

    Is there any way to get them according to their occurrence? So,

    &lt;i}  {i&gt;  &lt;i}

    Thanks

Module Ideas, Suggestions, and Requests
4 direct replies — Read more / Contribute
by oducs
on Jun 19, 2018 at 08:34

    I am looking for new and interesting ideas for Perl modules!

    The chosen modules will be uploaded to the new oducs CPAN: https://metacpan.org/author/ODUCS

    If you have a module which you would like to abandon into my care, let's hear about it.

    Also, I have an interest in simultaneously developing Pure-Perl and XS versions.

    Appreciated, Charlie Root (perlmonks@oducs.org)

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.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the voices are still...

    How do I use this? | Other CB clients
    Other Users?
    Others rifling through the Monastery: (5)
    As of 2018-06-23 07:05 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      Should cpanminus be part of the standard Perl release?



      Results (125 votes). Check out past polls.

      Notices?