Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things

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
Multiple Perl files sharing a single socket - is it possible/sensible?
1 direct reply — Read more / Contribute
by ljamison
on Dec 01, 2015 at 16:52

    Greetings Monks! I'm new as a user but not new to PM or programming (it has helped countless times in recent weeks during some tough projects!) and I am hoping that the wealth of knowledge here can assist with a problem I can't seem to wrap my head around!

    I am trying to create workflow of sorts which uses socket connections to relay extracted MySQL data from localhost to LAN server and vice versa. I was successfully able to create each individual .pl file (8 files in all) and extract information through each file as necessary.

    The part I am stuck on regards the actual socket connection for them to relay the data to the server. My concern is creating a bottleneck of sorts if (in the worst case scenario) all 8 files were to try sending data over the socket at the same time. Is it possible/sensible to create a separate file just containing socket information and allow that socket file to handle the relay for all files? If so, how could it be achieved? Is there another method that makes more sense?

question about variables from new perl user
5 direct replies — Read more / Contribute
by rst
on Nov 30, 2015 at 17:33
    Hello, I'm new to perl, but not programing. I'm playing with fetching data from web pages. I have a simple program:
    use warnings; use LWP::Simple; my $url = ''; my ($t1, $t2, $t3, $t4, $t5)=head($url) or die 'Unable to get page +'; my $temp = head($url) or die 'Unable to get page'; print Dumper($temp,$t1, $t2, $t3, $t4, $t5); print "done\n"; exit 0;
    Note, this question is about the particular code snippet, but even more it is about understanding variables in Perl. I used $t1 - $t5 because the documentation said that head() returns a list. $temp contains a lot of information, $t1, - $t5 contain only a very little. How would I get something like the return code (_rc) or the etag header, or the user agent? My first instinct (which seems to be wrong) would be to treat this like an associative array and try
    $temp['headers']['etag'] and $temp['_rc'] and $temp['_request']['_headers']['user-agent']
    I would like to understand this. Any help would be appreciated.
Merging Data into one array
5 direct replies — Read more / Contribute
by Anonymous Monk
on Nov 30, 2015 at 15:10
    Hi there Monks!

    I am trying to merge these two arrays only if the acc matches, can any one tell me what could be the best way to do this?
    #!/usr/bin/perl use strict; use warnings; use Data::Dumper; my $data1 = [ { 'NAME' => '1PAUL DY', 'DATE' => '12009-05-05', 'NUMBER' => '100001', 'ACC' => '1A1A', }, { 'NAME' => '2PAUL DY', 'DATE' => '2011-01-05', 'NUMBER' => '200331', 'ACC' => '2A3B', }, { 'NAME' => '4PAUL DY', 'DATE' => '42011-01-05', 'NUMBER' => '4200331', 'ACC' => '6A4B', }, ]; my $data2 = [ { 'EXT1' => '1b', 'EXT2' => '12b', 'EXT3' => '13b', 'EXT4' => '14d', 'ACC' => '1A1A', }, { 'EXT1' => '2b', 'EXT2' => '2b', 'EXT3' => '2b', 'EXT4' => '2d', 'ACC' => '2A3B', }, { 'EXT1X' => '4b', 'EXT2X' => '4b', 'EXT3X' => '4b', 'EXT4X' => '4d', 'ACC' => '4A4B', }, ]; # Merge all the data my @all_data; foreach my $one_data ( @{ $data1 } ) { my $sec_data = shift @{ $data2}; push @all_data, { %{ $one_data }, %{ $sec_data } }; } print Dumper \@all_data;

    Thanks for the help!
I2C help (from python)
4 direct replies — Read more / Contribute
by packetstormer
on Nov 30, 2015 at 10:30

    Hello monks, the following is a long-shot!

    I have a small raspberry pi relay board that I am trying to use. The manufacturer has provided some sample Python code to open and close the relay. However, as the rest of the project is written in perl I'd like to get it working all in one module

    Could anyone take a shot at explaining what the python lines below do and how they might translate to perl?

    I can manage to open all ports (at the same time!), using Device::SMBus on the relay board in perl but I can't figure out what "&=" and "|&" means in the source script

    class Relay(): global bus def __init__(self): self.DEVICE_ADDRESS = 0x20 #7 bit address (will be left shift +ed to add the read write bit) self.DEVICE_REG_MODE1 = 0x06 self.DEVICE_REG_DATA = 0xff bus.write_byte_data(self.DEVICE_ADDRESS, self.DEVICE_REG_MODE1, se +lf.DEVICE_REG_DATA) def ON_1(self): print 'ON_1...' self.DEVICE_REG_DATA &= ~(0x1<<0) bus.write_byte_data(self.DEVICE_ADDRESS, self.DEVICE_REG_MODE1 +, self.DEVICE_REG_DATA)

    And my Perl Code

    #!/usr/bin/perl use strict; use Device::SMBus; use Data::Dumper; my $dev = Device::SMBus->new( I2CBusDevicePath => '/dev/i2c-1', I2CDeviceAddress => 0x20, ); $dev->writeByteData(0x06,0x1<<0); print Dumper $dev

    With the perl code all the relays open (or close). So it's really this line self.DEVICE_REG_DATA &= ~(0x1<<0) that's causing my trouble.

    Like I said, I know this is a long shot but I'd appreciate some input

Effective database column level encryption?
4 direct replies — Read more / Contribute
by maruhige
on Nov 29, 2015 at 17:24

    Hello Monks,

    Given some rather splendid public facing spaffs of database theft in the UK such Talk Talk, I've been checked from mocking by asking 'how would I do it better?' and not finding a good answer.

    Now i'm a firm believer in DBIx::Class and properly parametise my SQL when using DBI, but there's always the 'what happens when the enemy has root access' question to which I haven't found a good answer. Security isn't my strong suit and thus I seek your wisdom.

    My first thought would be to use Crypt::RSA on personally identifiable columns (name, age, address, possibly email), and storing the private key on some other machine, but how exactly could I establish a system that would be useful and still safe if $n > 1 machines were compromised without resorting to security theatre? Is this even practical?

Problems using module Async
2 direct replies — Read more / Contribute
by hfi
on Nov 29, 2015 at 04:03

    Hi, what I want to do is write some daemon with a defined count of worker processes. To keep things readable I will only post a minimal example of the problem I'm facing (some kind of worker queue):

    !/usr/bin/perl use strict; use warnings; use Async; my $workercount = 10; my @workerqueue; for my $i (1..$workercount) { my $proc = Async->new( sub { sleep($i*3); print "$i\n"; } ); print "--> enqueue $proc->{PID}\n"; push @workerqueue, $proc; } while (1) { sleep(1); my @unfinished; while (my $proc = shift @workerqueue) { if ($proc and $proc->ready) { print "--> $proc->{PID} is ready\n"; if (my $e = $proc->error) { print "Something went wrong. The error was: $e\n"; } undef $proc; } else { push @unfinished, $proc; } } push @workerqueue, @unfinished; ## START refill queue block ## my $free = $workercount - @workerqueue; for my $i (1..$free) { my $proc = Async->new( sub { sleep($i*3); print "$i new\n"; } +); print "--> enqueue $proc->{PID}\n"; push @workerqueue, $proc; } ## END refill queue block ## print "mainloop\n"; }

    Actually if I comment out the "refill queue block" everything works as expected, the output looks something like:

    --> enqueue 28304 --> enqueue 28305 --> enqueue 28306 --> enqueue 28307 --> enqueue 28308 --> enqueue 28309 --> enqueue 28310 --> enqueue 28311 --> enqueue 28312 --> enqueue 28313 mainloop mainloop 1 --> 28304 is ready mainloop mainloop mainloop 2 --> 28305 is ready mainloop mainloop mainloop 3 --> 28306 is ready mainloop mainloop mainloop 4 --> 28307 is ready mainloop mainloop mainloop 5 --> 28308 is ready mainloop mainloop mainloop 6 --> 28309 is ready mainloop mainloop mainloop 7 --> 28310 is ready ...

    But as soon as I include the refill queue block it looks like:

    --> enqueue 28319 --> enqueue 28320 --> enqueue 28321 --> enqueue 28322 --> enqueue 28323 --> enqueue 28324 --> enqueue 28325 --> enqueue 28326 --> enqueue 28327 --> enqueue 28328 mainloop mainloop 1 --> 28319 is ready --> enqueue 28329 mainloop mainloop mainloop 2 1 new --> 28320 is ready --> 28327 is ready --> 28328 is ready --> 28329 is ready --> enqueue 28330 --> enqueue 28331 --> enqueue 28332 --> enqueue 28333 mainloop --> 28321 is ready --> 28322 is ready --> 28323 is ready --> 28324 is ready --> 28325 is ready --> 28326 is ready --> enqueue 28334 --> enqueue 28335 --> enqueue 28336 --> enqueue 28337 --> enqueue 28338 --> enqueue 28339 mainloop mainloop 1 new --> 28330 is ready --> enqueue 28340 ...

    So what is happening here? As far as my debugging got me, I can tell that for any reason all running processes are considered to be ->ready() as soon as I start a new process out of the main loop. This leads to cleanup and therefore process being killed, so that it never gets a chance to print its output, after that a new process is created in the workerqueue. Since all previous processes are considered ready at a time this leads to the "--> enqueue ..." spam.

    Now the really interesting question: What am I doing wrong so that Async module considers my processes been ready?

    Note: I tried reading through the Async module and as for lets say 90% I get what it is doing. I tried commenting out the following line, but it didn't change anything:

    kill 9 => $pid; # I don't care.

    EDIT: Refering to , the example posted by Tanktalus sounds absolutely like what I need. However looking at and considering the hint of arpad.szasz: "It seems You are mixing old-style and deprecated threads model(Thread module) with the new ithreads thread model..." I'm wondering. Isn't Tanktalus' example therefore also using the depracated Version of Threads? Is there an equivalent implementaion with the newer ithreads? And could this code be modified to share (or better return to) data with its parent process?

    EDIT 2: I think I will now use something like this (unless anyone has a good reason not to do so):

    #!/usr/bin/perl use strict; use warnings; use threads; use threads::shared; use Data::Dumper; my %state :shared; my $workercount = 10; my $run = 1; $SIG{TERM} = sub { $run = 0; }; $SIG{INT} = sub { $run = 0; }; my @workerqueue; for my $i (1..$workercount) { my $thr = threads->create(\&mysub, $i); my $id = $thr->tid(); print "--> enqueue $id\n"; $state{$id} = 'running'; push @workerqueue, $thr; } while ($run) { sleep(1); my @unfinished; while (my $thr = shift @workerqueue) { my $id = $thr->tid(); if ($thr and $state{$id} eq 'finished') { print "--> $id is ready\n"; my $x = $thr->join(); delete $state{$id}; print Dumper $x; # do something useful with the data } else { push @unfinished, $thr; } } push @workerqueue, @unfinished; ## START refill queue block ## my $free = $workercount - @workerqueue; for my $i (1..$free) { my $thr = threads->create(\&mysub, $i); my $id = $thr->tid(); print "--> enqueue $id\n"; $state{$id} = 'running'; push @workerqueue, $thr; } ## END refill queue block ## print "mainloop\n"; } my @threads = threads->list(); foreach my $thr (@threads) { $thr->join(); } sub mysub { my $i = shift; $i *= 3; sleep $i; my $id = threads->tid(); print "$id : slept for $i sec\n"; my $x = { 'ID' => $id, 'a' => [1,2,3], 'B' => { 'a' => 'A', }, }; $state{$id} = 'finished'; return $x; }
port check
2 direct replies — Read more / Contribute
by deelinux
on Nov 28, 2015 at 08:06

    Hi I want to do some port checks (http and tcp) on an array of servers

    I'm still new to Perl/Programming, and found in the perldoc Net::Ping, from which I have created some ping checks, along with code found on the net, but would like some guidance on how I could ping check and then test if some specific ports are available

    I have created an array to ping some servers, which is fine, but Id like to create a sub function to check an array of ports.

    sub ping_servers { foreach $host (@my_servers) { my $p = Net::Ping ->new("icmp"); #create ping object my $res = $p -> ping ($host); #ping the hosts from array list $output .= "Unknown host $host\n" unless defined $resolve; if (!$res) { $output .= "$host doesn't respond to ping requests!\n" +; } else { $output .= "$host is alive.\n"; } } }

    I's also like to understand what this "->" means in code?

    Any know how, or pointers would be great.

Validate Ip address Regexp
6 direct replies — Read more / Contribute
by akr8986
on Nov 28, 2015 at 06:48

    hi i am new to perl and was trying to write a script to check if ip address is valid. Though i found some solutions online i wanted to try it on my own

    #! /usr/bin/perl -w
    print "Enter IP Address:"; my $ip = <STDIN>; if ( $ip =~ /(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})/) { print "yes match $1 $2 $3 $4\n"; } else { print "no match\n"; }

    when i enter it says ip address matches as expected. But when enter 1000.3.4.5 too it says match is found and the values of $1 to $4 are printed as 000 3 4 5. How could this happen as i am saying to match only 3 digits and not more than that using "\d{1-3}" englighten me!

PAR::Packer/perlbrew confusion
3 direct replies — Read more / Contribute
by karlgoethebier
on Nov 27, 2015 at 14:42

    Hi all,

    today i packed a script using pp under a perlbrew environment on Mac OS X.

    The only none core module i used was Net::Traceroute which i installed using cpanm under perlbrew.

    To my surprise pp referred to @INC of the system Perl and told me that Net::Traceroute is not in @INC.

    N.B.: which told that i use the right pp.

    After i disabled perlbrew and installed the missing module to the system Perl everything worked.

    In other words: It seems like pp or perlbrew confuses the include path.

    Any further hints what is going on here?

    Thank you very much and best regards, Karl

    «The Crux of the Biscuit is the Apostrophe»

Best way to handle interactive user input?
4 direct replies — Read more / Contribute
by Ppeoc
on Nov 26, 2015 at 02:02
    I have a huge XML file to parse. I was thinking that instead of parsing the whole file, I could ask the user to input a few options and then parse only that portion of the file. I was basically planning to do this
    Enter option to be parsed 1. Fiction 2. History 3. Religion 10. Non fiction

    So once the user enters the number 2, Book 2 will get selected and bunch of other options will be displayed as follows

    Selected Book 2. Options are as follow 1. World History 2. American History 3. Oriental History 10. Indian History

    Each option is nested differently with different levels. The plan is to use a switch statement on the returned $_ to display options for the next level. How do I navigate to a different part of the program and display options according to the genre selected. Thanks!

    use strict; use warnings; use Switch; my $level1; print "Select options: \n 1 Fiction \n 2 History \n 3 Religion \n"; my $no = getIP('Enter a digit : ', /^\d/); switch ($no) { case 1 { $level1 = ?? } case 2 { $level1 = ?? } case 3 { $level1 = ?? } else { $level1= ?? } } print $level1; sub getIP { print $_[0]; do { $_ = <STDIN>; chomp; } while ($_[1] && $_ !~ $_[1]); return $_; }
Check a string for consecutive digits
6 direct replies — Read more / Contribute
by Anonymous Monk
on Nov 25, 2015 at 17:38

    Greetings, keepers of knowledge.

    I'm putting together a password checking script for Asterisk voicemail; one of the things I want to disallow is the use of a password that's got too many consecutive digits. "1234" being the classic example, but also "298761" or "4562".

    PHP is my usual language, but it's not available, so I went with Perl, since I used it many years ago, and the two share a lot of common syntax. The code I have works, but I feel like there should be a better way, that doesn't take so many lines of code to go through every digit twice.

    my $password = $2; my $limit = 3; # want to reject 4568 but not 4578 my $counter = 0; my $i = 0; my @digits = split(//, $password); my $pwlength = @digits; for ($i = 0; $i < $pwlength - 1; $i++) { if ($digits[$i] + 1 == $digits[$i + 1]) { $counter += 1; } else { $counter = 0; } if ($counter >= $limit) { exit 1; } } $counter = 0; for ($i = 0; $i < $pwlength - 1; $i++) { if ($digits[$i] - 1 == $digits[$i + 1]) { $counter += 1; } else { $counter = 0; } if ($counter >= $limit) { exit 1; } }
[closed] map sentence as array slice indexes
2 direct replies — Read more / Contribute
by rsFalse
on Nov 25, 2015 at 06:43

    I tried to understand why the following (with map sentence) gives an error. Can't understand.
    use warnings; use strict; @_ = 'a' .. 'c'; print @_[ map $_ -1, grep { $_ > 0 and $_ <= 1 } map { $_ + 1 } -1 .. 1 ];
    Missing comma after first argument to map function at map_inside_splic line 12, near "]"
    And the following (with map block) don't give an error:
    use warnings; use strict; @_ = 'a' .. 'c'; print @_[ map {$_ -1} grep { $_ > 0 and $_ <= 1 } map { $_ + 1 } -1 .. 1 ];
    upd: thanks for answers below.
New Meditations
Looking for CPAN module author: Daniel Yacob (String::LCSS)
1 direct reply — Read more / Contribute
by toolic
on Nov 30, 2015 at 21:59

    Does anyone know of a way to contact Daniel Yacob, the author of the CPAN String::LCSS module?

    I am at step 4 of the PAUSE procedure for taking over a module ("Try posting in public places such as ...").

    I have tried to contact the author by sending emails to 3 addresses. I have not received any positive replies.

New Cool Uses for Perl
Emulating Python's unittests MagicMock
1 direct reply — Read more / Contribute
by stevieb
on Nov 29, 2015 at 11:18

    Update: Mock::Sub. I haven't documented well the difference between OO and imported functions, so see EXAMPLES for the caveat for now. /Update

    I've been writing a lot of unit tests in Python lately, and really took to liking the MagicMock module. This morning, I thought I'd take a crack to see if I could emulate much of its functionality, before I write a full-blown module for it. So far, it implements called(), call_count(), side_effect and return_value:

    The Module itself (./Test/

    package Test::MockSub; sub mock { my $self = bless {}, shift; my $sub = shift; %{ $self } = @_; if (defined $self->{return_value} && defined $self->{side_effect}) +{ die "use only one of return_value or side_effect"; } my $called; { no strict 'refs'; *$sub = sub { $self->{call_count} = ++$called; return $self->{return_value} if defined $self->{return_val +ue}; $self->{side_effect}->() if $self->{side_effect}; }; } return $self; } sub called { return shift->call_count ? 1 : 0; } sub call_count { return shift->{call_count}; } sub reset { my $self = shift; delete $self->{$_} for keys %{ $self }; } 1;

    The outer module I'm calling the inner module with mocked subs from (./

    package MyPackage; use lib '.'; use One; sub test { my $obj = One->new; $obj->foo; } 1;

    The inner module I'm mocking (./

    package One; sub new { return bless {}, shift; } sub foo { print "in One::foo\n"; } 1;

    ... and finally the script I'm testing it all from:

    use warnings; use strict; use feature 'say'; use lib '.'; use Test::MockSub; use MyPackage; {# called() && call_counnt() my $foo = Test::MockSub->mock('One::foo'); MyPackage::test; MyPackage::test; my $count = $foo->call_count; say "testing call_count(): $count"; my $called = $foo->called; say "testing called(): $called"; } {# return_value my $foo = Test::MockSub->mock('One::foo', return_value => 'True'); my $ret = MyPackage::test; say "testing return_value: $ret"; } {# side_effect my $cref = sub {die "thowing error";}; my $foo = Test::MockSub->mock('One::foo', side_effect => $cref); eval{MyPackage::test;}; print "testing side_effect: "; say $@ ? 'success' : 'failed'; } {# side_effect && return_value dies() my $foo; my $cref = sub {}; eval{ $foo = Test::MockSub->mock('One::foo', side_effect => $cref, r +eturn_value => 1);}; print "testing side_effect & return_value dies(): "; say $@ ? 'success' : 'failed'; } {# reset() my $foo = Test::MockSub->mock('One::foo', return_value => 1); my $ret1 = MyPackage::test; $foo->reset; my $ret2 = MyPackage::test; print "testing reset():"; say defined $ret1 && ! defined $ret2 ? 'success' : 'failed'; }

    There's Test::MockModule and Test::MockObject, but I like the built-in methods, and how I've done it allows for mocking functions, class methods and object methods all at the same time (at least I think).

    Thoughts, criticism and feedback welcome as always.

Log In?

What's my password?
Create A New User
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others chanting in the Monastery: (8)
As of 2015-12-01 23:40 GMT
Find Nodes?
    Voting Booth?

    My keyboard shows this many letters:

    Results (29 votes), past polls