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

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
Joining elements of an array in a hash
4 direct replies — Read more / Contribute
by orangepeel1
on Mar 26, 2017 at 13:29
    I have a hash of arrays
    @array1 = ("one", "two", "three", "four", "five"); @array2 = ("banana", "pear", "apple"); my %hash = (numbers => \@array1, fruit => \@array2 );
    I would like to go through all the keys to the hash and join the elements of each array. I have tried something like this
    foreach my $group (keys %hash) { push @group, @{ $hash {$group}}; foreach (@group) { $statement = join ",", @group; } }
    However it does not join them. Does anyone have any suggestions for how I might go about this?
Log::Log4perl help in rotating file
2 direct replies — Read more / Contribute
by ravi45722
on Mar 26, 2017 at 02:56
    log4perl.rootLogger=DEBUG, LOGFILE log4perl.appender.LOGFILE=Log::Log4perl::Appender::File log4perl.appender.LOGFILE.filename=/home/GEMS/ravi/Node/logs/Script.lo +g log4perl.appender.LOGFILE.mode=append log4perl.appender.LOGFILE.layout=PatternLayout log4perl.appender.LOGFILE.layout.ConversionPattern=%d : %r : %c - %m%n +

    This is my config for the logger

    I seen


    to rotate the file. I need to rotate the file based on the date. (Every day one single file). But how to add this to my conf??

    In my conf pattern %d prints 2017/03/26 12:17:33 can I change this pattern to 2017-03-26 12:17:33.432

Need regexp to pick off second parenthetical item
2 direct replies — Read more / Contribute
by cormanaz
on Mar 25, 2017 at 20:50
    Good day Bros. I am processing email sender fields, some of which have an email address embedded in a set of parentheses following a string inside another set of parentheses. I need a regexp that will get only the former, leaving the latter with the sender name. To be clear, in the following example:
    #!/usr/bin/perl -w use strict; my $sentto = 'Fred Flintstone (US) ('; $sentto =~ m/\(.+?@.+?\)/; print "First: $`\nSecond: $&"
    I would like $` to contain "Fred Flintstone (US) " and $& to contain "(". The regexp I have in there puts " (US) " at the beginning of $&. I understand why this happens, but not how to fix it. I thought about maybe a look-back assertion for a close-paren, but I have some addresses like "Barney Rubble (" so I don't think that will work. I'd like to have a regexp that will pick off the parenthetical address for both kinds of senders. Can someone suggest a solution?
    "I think computers have complicated lives very bigly. The whole age of, you know, computer has made it where nobody knows exactly what's going on." --D. Trump
Accessing passwords in a script
4 direct replies — Read more / Contribute
by nysus
on Mar 25, 2017 at 16:12

    I have a script that needs passwords for things like mysql databases on other servers. I want to do this as painlessly and as securely as possible. So what I'm thinking is that my script would prompt for a single master password and then it would be granted access to the other passwords. I found this possible solution which explains how to use the KeePass module which seems like it might be a good route. But I wanted to get some input from the Monks who might have other good ideas. Many thanks.

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

Need clean code
3 direct replies — Read more / Contribute
by ravi45722
on Mar 25, 2017 at 13:34

    I am learning the Perl code. I also want to use the beauty of the perl.

    I can write like this

     $var or $var = 30;

    But in this case how can I write the code using or

    Or is there any smart way to write this

    if (undef $var) { $x = 40; } else { $x = 50; }
Looking for a standalone separator for Perl/Tk
1 direct reply — Read more / Contribute
by kbrannen
on Mar 24, 2017 at 13:04
    I'm looking for a standalone separator widget for Perl/Tk, something to draw a line between other widgets. Imagine something like HTML's "hr" tag that can be horizontal or vertical ... or for those familiar with the old Motif, something like XmSeparator.

    Does anyone know of an existing widget for this? If not, what could easily be made to do this?

    I can do an empty Frame with a raised relief and a non-zero borderwidth like:
    my $frame = $parent->Frame(); my $info = $frame->Label(-text => "General Info")->pack(); # separator ... sort of $frame->Frame(-background => "black", -borderwidth => 1, -relief => 'r +aised', -height => 2) ->pack(-fill => 'x', -padx => 5, -pady => 5); my $comments = $frame->Label(-text => "next widget")->pack();
    which gets me really close, but it seems cumbersome. I assume I can do something similar for verticals with some option changes, but I haven't tried it yet. Is there a better alternative anyone can suggest?
Capture::Tiny alternative
5 direct replies — Read more / Contribute
by melezhik
on Mar 24, 2017 at 06:23

    Hi! I have been using Capture::Tiny to read from processes I launch in my scripts. It works pretty good. Good module. The only thing I need more is reading processes STDOUT "in real time" which impossible with this module as it captures all the data till the process exits and then return it. It makes user waits till long running command finishes and don't let him to see it's STDOUT in real time.

    Another solution with well known construction:

    open(my $fh, '-|', $system_command) or die $!;
    while (my $line = <$fh>) {
        # Do stuff with each $line.
    Does not work for me, as it for mysterious reasons _sometimes_ ( some rare cases of $system_command ) it waits forever even when $system_command finishes and return all the data as STDOUT.

    Any suggestions?

    PS both workaround for open(my $fh, '-|', $system_command) or suggestion new IPC related module would be fine.

Joining multiple lines together while parsing
5 direct replies — Read more / Contribute
by Arengin
on Mar 24, 2017 at 06:08

    I have the following code:
    #!/usr/bin/env perl use strict; use warnings; use Data::Dumper; #read input data: my @rows; #set record separator to 3 line feeds. local $/ = "\n\n\n"; while ( <> ) { next unless m/Dumpdata example/; #map key-values out of this 'chunk'. my %row = m/\s*(\w+)\S*\s+(\S.*)/g; push @rows, \%row; } #print whole data structure for debugging: print Dumper \@rows; #define columns and ordering for output: my @output_cols = qw /Info Detail Warning Spec/; #iterate rows foreach my $row ( @rows ) { #print fields selected from output_cols. #use a 'hash slice' - look it up in perl docs. print join ";", @{$row}{@output_cols},"\n"; }

    It works just fine except for the problem, that it ends at the line end.
    If for example Info is on 2 lines I only get the first part in the output.

    Dumpdata example ----------------- Warning bad news here Detail: Some really nice infos these are Info: This is a problem but there is a solution Spec: 2nd of 4

    The expected output for this should be:
    "bad news here"; "Some really nice infos these are"; "This is a proble +m but there is a solution"; "2nd of 4"

    Thanks you haukex for reminding me to post that too.

    My above code would return This is a problem but it should return This is a problem but there is a solution

    Any ideas on how to get this done?

    Thank you so much

Alternative to
4 direct replies — Read more / Contribute
by sectokia
on Mar 24, 2017 at 04:59

    Hi Monks, what is built in to perl dist these days that is meant to take the place of Especially for the HTTP essentials like params and header?

    Also whats with the apparent 'crusade' against Removing it from dist is fine (great even), but it seems that someone is especially out to make it hard to even get installed. I had some older code to run and I noticed that:

    • Bigger dists (think Ubuntu) got on exclusion lists, even thought they package a pre-compiled version of pretty much everything on cpan. In particular its banned as a security threat?!
    • Someone seems to have 'minified' its build scripts on cpan. Previously I believe it had a mechanism that told you gcc/make wasn't installed. Now it just throws pages of errors that would be impossible to interpret for those who don't know about gcc/make.
parsing a terrible /etc/hosts
3 direct replies — Read more / Contribute
by f77coder
on Mar 24, 2017 at 01:15
    Hello, I'm attempting to parse this monster of a hosts file that is a most un-formatted file with ip4 and ip6 address with comments scattered everywhere. sometimes there are two columns separated by space, sometimes 3 columns, sometimes 4. #SpySweeper.Spy.Cookie

    # 1-800-hostingAS3321069.41.160.0 - 2a02:598:2::1095

    so i want to clean the old file by removing comments, and duplicates, so far i have
    my @array = (); $#array = -1; my @tmp_array = (); $#tmp_array = -1; my @uniq = (); $#uniq = -1; my $i = 0; open(HOST_ORIG,'<', $file_read ) or die "Can't open $file_read: $!"; chomp(@array = <HOST_ORIG>); foreach $i (4...scalar(@array)-1) { (my $local_127, $tmp_array[$i] )=split(" ",$array[$i]); }; close(HOST_ORIG); my %seen; my @uniq = grep {! $seen{$_}++} sort(@tmp_array); open(TEMP, '>', $file_write)|| die "\n error opening file $file_write +\n"; print TEMP "#Hosts file\n"; print TEMP "#Last Modified -> ". localtime() . "\n"; print TEMP "# \n"; print TEMP "# localhost: Needs to stay like this to work\n"; print TEMP "\t localhost\n"; print TEMP "# \n"; foreach $i (1...scalar(@uniq)-1) { print TEMP "\t $uniq[$i]\n"; } close(TEMP);

    it works except when there are 3 or more columns, the 3rd and 4rth columns get wrapped around to a new line like this


    how do i throw away the rest of the line if it exists?


Learning Perl by Doing
4 direct replies — Read more / Contribute
by raywood
on Mar 23, 2017 at 23:04

    I would like to learn Perl by working through specific cases where I need it. This is the first such case. I have a situation much like the one described in an earlier discussion (Extracting blocks of text). Specifically, I have a number of old WordStar files in plain text. Each such file contains multiple .pa-delimited documents (consisting of various numbers of lines and paragraphs of text) that should be broken out into separate files. For example, one of these WordStar files might contain something like this:

    Text text text .pa Other text text text .pa
    In that example, resulting file no. 1 would contain "Text text text," and resulting file no. 2 would contain "Other text text text."

    I assume, but am not certain, that every .pa appears at the left margin, and is followed by no other characters on the same line.

    The earlier discussion suggested this solution, where the delimiter was the word "term" rather than ".pa":

    #! perl -slw use strict; my @array = split 'term', do{ local $/; <DATA> }; shift @array; ## Discard leading null print '---', "\n", $_, "\n" for @array; __DATA__ term { yada yada 12345 () ... } term only occurs here { could be 30 lines here but never that word again until another block starts yadada } term, etc.
    My questions, from that example:

    1. That old discussion mentioned RAM concerns when slurping. My system has 16GB RAM. The files I am working on are small. But I may adapt the solution to other, larger files. When does RAM become an issue?

    2. How would I adapt this solution to refer to a separate input file? In the suggested solution, the Perl code seems to be added to the start of the text file. I would rather have a separate Perl script and specify the target file at runtime.

    3. What would be the best reference source, for purposes of interpreting the few Perl codes suggested in that solution?

    4. Which version of Perl should I install, to run this code?

    Many thanks.
Help converting to a Windows service
1 direct reply — Read more / Contribute
by bajangerry
on Mar 23, 2017 at 14:42

    Hello Monks

    EDIT: Ok so I may have been misleading everyone. I have been able to install the script as a service but for some reason I get an error when running it as a service. What runs perfectly from a command line fails as a service with the below error:

    Error 1053: The service did not respond to the start or control request in a timely fashion

    I have been trying to wrap my head around using Win32::Daemon to have a perl script and/or pp converted executable of the same script run as a service and I can't seem to figure out how this is done. I have tried using the Windows "sc create..." command with the .exe file but that does not work so I am obviously missing the Win32::Daemon portion in the script

    The script simply monitors a network stream and based on the output it will write to a file, see below

    #!/usr/bin/perl use strict; use IO::Socket; use POSIX; use warnings; use Config::Simple; use Win32::Daemon; sub logMonitor{ #subrouting to connect to the PBX log and monitor for +the Emergency calls my ($HOST, $PORT)= @_; OUTER: if (my $sock = new IO::Socket::INET(PeerAddr => $HOST, Peer +Port => $PORT,Proto => "tcp",)) { while (<$sock>) { s/^\0+//; # Remove leading null characters chomp ($_); my $data = substr($_, 1,17); my $event = substr ($data, 2,1); my $hr = substr ($data, 3,2); my $min = substr ($data,5,2); my $year = substr($data, 9,4); my $mon = substr($data, 13,2); my $day = substr ($data,15,2); #print "$hr:$min on $year-$mon-$day \n"; if ($event eq "A") { my $agent = substr($_, 17,4); # print "\n Agent $agent logged in \n" ; my $output = "Agent $agent logged in at $hr:$min on ex +t $year"; filePrint($output); } } else { print "Failed to connect to $HOST on $PORT. Will retry in a mi +nute.\n"; sleep 60; goto OUTER; } } #End of monitor subroutine sub filePrint{ #write data to file with date and time stamp my ($DATA)= @_; print "$DATA\n"; my $dateStamp = strftime '%Y-%m-%d', localtime; my $file = "$dateStamp.log"; my $timeStamp = strftime '%H:%M:%S', localtime; if (-f $file){ open (my $fh,'>>', $file); print $fh "$timeStamp | $DATA\n"; close $file; } else { open (my $fh,'>', $file); print $fh "$timeStamp | $DATA\n"; close $file; } }# End of filePrint routine my $cfg = new Config::Simple(); $cfg->read('config.ini'); my $HOST = $cfg->param("pbx"); my $PORT = $cfg->param("port"); logMonitor($HOST, $PORT); #Open the log monitoring subroutine

    Can anyone explain to me how to use Win32::Daemon with this script to create a service from it? Right now it will run as a command line tool

    many thanks!

New Meditations
OT: Got fired this week
12 direct replies — Read more / Contribute
by karlgoethebier
on Mar 23, 2017 at 05:43

    As i'm aged 60 + i guess i'll never get a new job. I think i need to face retirement. I first thought to delete my account on PM and through away all the code i ever wrote as well as my hand library and forget about everything related to programming. But it isn't so easy. I spent the last 20 years with this stuff. I'll stay a bit here - for fun. And perhaps i'll learn a new programming language ;-)

    Update: What should i say? I'm deeply moved. Thank you very much to all for encouragement and good advice.

    Best regards, Karl

    «The Crux of the Biscuit is the Apostrophe»

    Furthermore I consider that Donald Trump must be impeached as soon as possible

New Cool Uses for Perl
Mutex::Flock - Fcntl advisory locking supporting processes and threads.
2 direct replies — Read more / Contribute
by marioroy
on Mar 23, 2017 at 02:59


    Re: Scheduling Perl Tasks

    This is a nice to have module for anybody that wants it. Lately, I lack the time to make a module and publish on CPAN. It is well tested on all supported platfoms including support for threads. It is also optimized, thus low overhead.

    ## Mutex::Flock - Fcntl-based advisory locking. package Mutex::Flock; use strict; use warnings; no warnings qw( threads recursion uninitialized once ); our $VERSION = '0.007'; use Fcntl ':flock'; use Carp (); my $has_threads = $INC{''} ? 1 : 0; my $tid = $has_threads ? threads->tid() : 0; sub CLONE { $tid = threads->tid() if $has_threads; } sub DESTROY { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); $obj->unlock(), close(delete $obj->{_fh}) if $obj->{ $pid }; unlink $obj->{path} if ($obj->{_init} && $obj->{_init} eq $pid); return; } sub _open { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); return if exists $obj->{ $pid }; open $obj->{_fh}, '+>>:raw:stdio', $obj->{path} or Carp::croak("Could not create temp file $obj->{path}: $!"); return; } ## Public methods. my ($id, $prog_name) = (0); $prog_name = $0; $prog_name =~ s{^.*[\\/]}{}g; $prog_name = 'perl' if ($prog_name eq '-e' || $prog_name eq '-'); sub new { my ($class, %obj) = (@_); if (! defined $obj{path}) { my ($pid, $tmp_dir, $tmp_file) = ( abs($$) ); if ($ENV{TEMP} && -d $ENV{TEMP} && -w _) { $tmp_dir = $ENV{TEMP}; } elsif ($ENV{TMPDIR} && -d $ENV{TMPDIR} && -w _) { $tmp_dir = $ENV{TMPDIR}; } elsif (-d '/tmp' && -w _) { $tmp_dir = '/tmp'; } else { Carp::croak("no writable dir found for temp file"); } $id++, $tmp_dir =~ s{/$}{}; # remove tainted'ness from $tmp_dir if ($^O eq 'MSWin32') { ($tmp_file) = "$tmp_dir\\$prog_name.$pid.$tid.$id" =~ /(.* +)/; } else { ($tmp_file) = "$tmp_dir/$prog_name.$pid.$tid.$id" =~ /(.*) +/; } $obj{_init} = $has_threads ? $$ .'.'. $tid : $$; $obj{ path} = $tmp_file.'.lock'; } # test open open my $fh, '+>>:raw:stdio', $obj{path} or Carp::croak("Could not create temp file $obj{path}: $!"); close $fh; # update permission chmod 0600, $obj{path} if $obj{_init}; return bless(\%obj, $class); } sub lock { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); $obj->_open() unless exists $obj->{ $pid }; flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1 unless $obj->{ $pid }; return; } *lock_exclusive = \&lock; sub lock_shared { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); $obj->_open() unless exists $obj->{ $pid }; flock ($obj->{_fh}, LOCK_SH), $obj->{ $pid } = 1 unless $obj->{ $pid }; return; } sub unlock { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0 if $obj->{ $pid }; return; } sub synchronize { my ($pid, $obj, $code, @ret) = ( $has_threads ? $$ .'.'. $tid : $$, shift, shift ); return if ref($code) ne 'CODE'; $obj->_open() unless exists $obj->{ $pid }; # lock, run, unlock - inlined for performance flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1 unless $obj->{ $p +id }; defined wantarray ? @ret = $code->(@_) : $code->(@_); flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0; return wantarray ? @ret : $ret[-1]; } *enter = \&synchronize; sub timedwait { my ($obj, $timeout) = @_; local $@; local $SIG{'ALRM'} = sub { alarm 0; die "timed out\n" }; eval { alarm $timeout || 1; $obj->lock_exclusive }; alarm 0; ( $@ && $@ eq "timed out\n" ) ? '' : 1; } 1; __END__ =head1 NAME Mutex::Flock - Fcntl advisory locking =head1 SYNOPSIS { use Mutex::Flock; ( my $mutex = Mutex::Flock->new( path => $0 ) )->lock_exclusive +; ... } { my $mutex = MCE::Mutex::Flock->new( path => $0 ); # terminate script if a previous instance is still running exit unless $mutex->timedwait(2); ... } { use threads; use Mutex::Flock; my $mutex = Mutex::Flock->new; threads->create('task', $_) for 1..4; $_->join for ( threads->list ); } { use MCE::Hobo; use Mutex::Flock; my $mutex = Mutex::Flock->new; MCE::Hobo->create('task', $_) for 5..8; MCE::Hobo->waitall; } sub task { my ($id) = @_; $mutex->lock; # access shared resource print $id, "\n"; sleep 1; $mutex->unlock; } =head1 DESCRIPTION This module implements locking methods that can be used to coordinate +access to shared data from multiple workers spawned as processes or threads. =head1 API DOCUMENTATION =head2 Mutex::Flock->new ( [ path => "/tmp/file.lock" ] ) Creates a new mutex. When path is given, it is the responsibility of t +he caller to remove the file. Otherwise, it establishes a C<tempfile> internally + including removal on scope exit. =head2 $mutex->lock ( void ) =head2 $mutex->lock_exclusive ( void ) Attempts to grab an exclusive lock and waits if not available. Multipl +e calls to mutex->lock by the same process or thread is safe. The mutex will r +emain locked until mutex->unlock is called. The method C<lock_exclusive> is an alias for C<lock>. =head2 $mutex->lock_shared ( void ) Like C<lock_exclusive>, but attempts to grab a shared lock instead. =head2 $mutex->unlock ( void ) Releases the lock. A held lock by an exiting process or thread is rele +ased automatically. =head2 $mutex->synchronize ( sub { ... }, @_ ) =head2 $mutex->enter ( sub { ... }, @_ ) Obtains a lock, runs the code block, and releases the lock after the b +lock completes. Optionally, the method is C<wantarray> aware. my $val = $mutex->synchronize( sub { # access shared resource return 'scalar'; }); my @ret = $mutex->enter( sub { # access shared resource return @list; }); The method C<enter> is an alias for C<synchronize>. =head2 $mutex->timedwait ( timeout ) Blocks until taking obtaining an exclusive lock. A false value is retu +rned if the timeout is reached, and a true value otherwise. my $mutex = MCE::Mutex::Flock->new( path => $0 ); # terminate script if a previous instance is still running exit unless $mutex->timedwait(2); ... =head1 AUTHOR Mario E. Roy, S<E<lt>marioeroy AT gmail DOT comE<gt>> =cut

    Regards, Mario

    Edit: Removed the underscore after the sigil in variables.
    Edit: Updated synopsis and code for construction.
    Edit: Added timedwait method. Completed documentation.

Solaris: make iostat output clearer
1 direct reply — Read more / Contribute
by johngg
on Mar 22, 2017 at 18:49

    This might be useful for sysadmins who manage Solaris servers. The iostat -En command can be used to check for cumulative disk errors but the output is rather dense so it can be difficult to sort the wood from the trees. This script uses Term::ANSIColor to make errors easier to spot.

    use strict; use warnings; use Term::ANSIColor qw{ :constants }; my $rxTriggers = do { my @triggers = ( q{Soft Errors: }, q{Hard Errors: }, q{Transport Errors: }, q{Media Error: }, q{Device Not Ready: }, q{No Device: }, q{Recoverable: }, q{Illegal Request: }, q{Predictive Failure Analysis: }, ); local $" = q{|}; qr{(@triggers)(\d+)} }; my @iostatCmd = qw{ /usr/bin/iostat -En }; open my $iostatFH, q{-|}, @iostatCmd or die qq{open: @iostatCmd |: $!\n}; print q{-} x 60, qq{\n}; while ( not eof $iostatFH ) { my $record; $record .= $_ for map { eof $iostatFH ? () : scalar <$iostatFH> } 1 .. 5; substr $record, 16, 0, RESET; substr $record, 0, 0, BOLD; $record =~ s{$rxTriggers} { $2 eq q{0} ? $1 . GREEN . $2 . RESET : YELLOW . $1 . RED . $2 . RESET }eg; print $record; print q{-} x 60, qq{\n}; } close $iostatFH or die qq{close: @iostatCmd |: $!\n};

    I no longer have a working Solaris box to provide example output but I hope this will be useful for somebody out there.



New Monk Discussion
Prohibit empty nodes
2 direct replies — Read more / Contribute
by hippo
on Mar 23, 2017 at 11:54

    It's a minor annoyance but hopefully an even more minor fix. I suggest that the site code be modified such that entirely empty nodes are automatically rejected. It's a particular time-and-resource waster in the case of anonymous posts as they serve absolutely no value - would anyone dispute this?

    There might conceivably be some argument for allowing empty non-anonymous posts (although what it might be escapes me) so that could be up for debate. If you think these are worth allowing then do please contribute to this thread.

Log In?

What's my password?
Create A New User
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (5)
As of 2017-03-27 03:01 GMT
Find Nodes?
    Voting Booth?
    Should Pluto Get Its Planethood Back?

    Results (315 votes). Check out past polls.