Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling

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
Effective database column level encryption?
No replies — Read more | Post response
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.
using Linux getdents syscall
5 direct replies — Read more / Contribute
by glasswalk3r
on Nov 23, 2015 at 18:37

    Hello monks,

    I'm looking for a fast way to list the contents of a directory (with thousands of files) on Linux by using Perl.

    I did some research on that and found a sample C code that uses the getdents system call for that. By using it, one can avoid calling stat on each file inside the directory (basically what ls command does).

    I did some tests with readdir, but performance speed compared to the already mentioned C code as good. That said, I'm inclined to try to use Perl syscall to do the same. Below is the C code (for those inclined to read it):

    This is how the C struct should look like:

    struct linux_dirent { unsigned long d_ino; /* Inode number 32*/ unsigned long d_off; /* Offset to next linux_dirent 32*/ unsigned short d_reclen; /* Length of this linux_dirent 16*/ char d_name[]; /* Filename (null-terminated) */ /* length is actually (d_reclen - 2 - offsetof(struct linux_dirent, d_name)) */ }

    Since I'm not a C programmer, I struggling to achieve that. I found that I need to use unpack to retrieve the information from the related C struct, but I'm lost about:

    • Finding out the lenght I need to setup the Perl equivalent to the buffer (a scalar set with NUL characters, as my $buffer = "\0" x 64;), specially because the related C structure has a char array with dynamic length
    • The buffer will retain a N number of dentries inside of it. How can I find the exactly number of bytes each dentrie has and how can I jump from one entry to the other with Perl?

    Is it even possible to do that without having to use XS (or any of it's alternatives)? I found Convert::Binary::C to give a hand, but probably I'm not using it correctly due the 2 issues above. If I use Data::Dumper on the buffer, I can see the file names, but got only garbage from Convert::Binary::C.

    Here is my (not working) Perl code implementation:


    Alceu Rodrigues de Freitas Junior
    "You have enemies? Good. That means you've stood up for something, sometime in your life." - Sir Winston Churchill
Initialize multiple variables in one statement
5 direct replies — Read more / Contribute
by Anonymous Monk
on Nov 23, 2015 at 13:56
    Hi there Monks!

    Is here a better way to initialize multiple variables in one statement other than this?
    ... my ($name1, $name2, $name3, $name4, $name5, $name6); $name1 = $name2 = $name3 = $name4 = $name5 = $name6 = ''; print "\n $name1, $name2, $name3, $name4, $name5, $name6\n\n"; ...

copy line with character
1 direct reply — Read more / Contribute
by jalopez453
on Nov 23, 2015 at 13:32

    Hello everyone, I am looking for a little help on my code here. I want to copy the lines that have the letter M in the first column but not sure what I am doing wrong or what is missing. I am very new to perl, so I apologize for this very basic request. Thank you in advance for the help

    use strict; my $find = 'M'; open (NEW, ">", "output.txt" ) or die "could not open:$!"; open (FILE, "<", "Report.txt") or die "could not open:$!"; while (<FILE>) { print NEW if (/$find/); } close (FILE); close (NEW);
Problem in creating process
5 direct replies — Read more / Contribute
by ravi45722
on Nov 23, 2015 at 00:42

    I write a code normally and its taking 186 wall clocks to read the total files. To reduce the time I created process and split my load for two process. After creating process its taking 261 wall clock seconds. What's the mistake I am doing?? I think by creating process and running it parallel may reduce the execution time. But its increased. How???

    sub SMSBcastCDR { #doing operation on files } sub SMSCDR { #doing operation on files } LINKS: foreach my $linkarray (1 .. 2) { $pm->start and next LINKS; # do the fork if ($first == 1) { my @cdr_list1 = `ls $cdr_directory/SMSBcastCDR_*_$bcat_cdrdate +\_*.log`; print "cdrs_file1 = @cdr_list1\n"; SMSBcastCDR(@cdr_list1); $first++; } if ($first == 2) { my @smsc_cdr_list=`ls $smscdr_directory/SMSCDR_P*_$cdr +date*.log`; SMSCDR(@smsc_cdr_list); } $pm->finish; # do the exit in the child process } $pm->wait_all_children;
New Meditations
Something that bugs me about the Numeric class hierarchy in Perl 6
1 direct reply — Read more / Contribute
by grondilu
on Nov 24, 2015 at 03:16

    Hello Monks,

    This is something that has bugged some times to times : I have the feeling that the class hierarchy for numeric types in Perl 6 is upside down.

    Let me give you an example. The other day I wrote on rosetta code the following function to compute binomial coefficients:

    sub infix:<choose> { [*] ($^n ... 0) Z/ 1 .. $^p } say 5 choose 3;

    I was quite happy about it, until I realized that the output was of type Rat, not Int. So I had to make an explicit conversion:

    sub infix:<choose> { ([*] ($^n ... 0) Z/ 1 .. $^p).Int }

    That was a bit annoying. Frankly, I expect something like 10/5 to be an integer, not a rational. I mean, I know it is a rational, but it also is an integer. Because normally in math, all integers are rationals. Their denominator is just 1.

    Things don't work like this in Perl 6. Numeric types are more about implementation than mathematics. Yet there is a feature in Perl 6 that could be used to make things work more like in math:

    subset Int of Rat where [%%] *.nude;

    If Int was defined as such, integers would be particular cases of rationals. In the same way, real numbers would be special cases of complex numbers:

    subset Real of Complex where { $_ == .conj };

    An other possibility would be:

    role Int does Rational { method nude { self, 1 }; ... }

    Or something like that, I don't know. Neither do I know if it would be possible or desirable to rewrite the whole Numeric hierarchy. Maybe it would not be worth the effort. But I do find it annoying that an Integer is not a Rat, or a Real not a Complex.

"Indirect" object syntax?
3 direct replies — Read more / Contribute
by muba
on Nov 22, 2015 at 21:30

    Disclaimer: IANAL. I am not a lawyer linguist.

    The syntax of (for example) $cgi = new CGI; is called indirect object syntax, which is also said to be in the dative case. Are these actually the correct designations?

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.

Restarting File::Find
1 direct reply — Read more / Contribute
by Preceptor
on Nov 24, 2015 at 06:44

    One of the problems I've had in the past, is a need to walk a filesystem and 'batch up' files. There's a variety of reasons why - things like archiving, virus scanning, etc. Now, you _could_ do it the heavyweight way - collect a full tree directory structure, batch up that way. This didn't suit my needs - I've a billion ish files to inspect, and they change rather frequently.

    So as a workaround - make use of File::Find and it's ability to prune

    #!/usr/bin/env perl use strict; use warnings; use File::Find; my $start_from = "/path/to/search/some_dir/beneath"; my $count = 10_000; #how many files to grab in this 'batch'; my @file_list; sub finder { if ( defined $start_from and not $found ) { #partial match, walk directory. if ( $start_from =~ m/\QFile::Find::name/ ) { $File::Find::prune = 0; if ( $File::Find::name =~ m/\Q$start_from/ ) { $found = 1; } } else { $File::Find::prune = 1; #don't traverse into this dir } } if ( @file_list > $limit ) { $found = 0; $File::Find::prune = 1; return; } return unless -f $File::Find::name; push ( @file_list, $File::Find::name ); #backtracks a bit to the start of the current directory $start_from = $File::Find::dir; } find ( \&finder, '/path/to/search' ); print "Next start point: $start_from\n";

    Note - as it stands, this has a limiting factor in that it'll misbehaving if the directory structure changes (e.g. $start_from no longer exists. The workaround is chopping path elements off the end until you get to a dir that _does_ exist.

    Probably something like:

    while ( not -d $start_from and $start_from =~ m,/, ) { $start_from =~ s,/[^/]+$,,; }

    (There's probably a better solution using File::Spec or similar)

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 musing on the Monastery: (3)
As of 2015-11-29 22:59 GMT
Find Nodes?
    Voting Booth?

    What would be the most significant thing to happen if a rope (or wire) tied the Earth and the Moon together?

    Results (754 votes), past polls