EDIT: SOLVED! The eval was not only formatted incorrectly, it needed to be in a BEGIN block, due to the nature of the module's use by the host server. Thanks for all the help!

----

Greetings,

The host server where our intracompany site lives requires this on one of our CGI scripts:

My local machine is running its own Apache server, and I use it to test code. However, it doesn't have cPanelUserConfig installed. It's a pain to have to remember to comment that line out when I'm testing locally and then uncomment it before I upload it to the host server. So I tried this:

eval{"use cPanelUserConfig;"};
unless($@){use cPanelUserConfig}
[download]

The problem is that, even though that Perl module is not installed, $@ is empty, so the "use cPanelUserConfig" tries to execute and the script dies.

Any suggestions for making this work?

Thanks!

I have a database being edited via a web form which needs to allow user-specified substitutions. By providing checkboxes in the form for things like "Match at start of line", "Match at end of line", "Case insensitive", etc., along with the values for the actual text to search for and to replace with, I can provide PERL with a regular expression (regex/regexp) substitution to run against the text in the database. However, I have been unable to use it, and was forced to create pages of code to accommodate all of the possible options, as is shown further below.

What I would like is something more like this:

$substitute = qq|s~$sv$ch$ww$searchQuery$ww$ch$ev~$replacement~g$in;|;
$line =~ $substitute;
[download]

. . . Where $sv would be a "^" if the user had requested the match to start at the beginning of the line, or be blank ("") otherwise, $ev would optionally be the "$" for end of line matching, etc. When I tried this approach, however, it failed. So I ended up doing the following instead:

sub processReplacements {
my $regexM = shift @_;    #TERM(S) TO MATCH
my $regexR = shift @_;    #REPLACEMENT TERM
my $regexI = shift @_;    #FLAG FOR CASE-INSENSITVE SUBSTITUTION
my $sv       = shift @_;  # $sv => START, E.G. /^(.*)/; 
my $ev       = shift @_;  # $ev => END, E.G. /(.*)$/; 
my $ww       = shift @_;  # $ww => WHOLE-WORD, E.G. /\b(.*)\b/; 
my $ch       = shift @_;  # $ch => DELIMIT CHARS, 
            # E.G. /[.,:;!?'"](.*)[.,:;!?'"]/;
my @data = @_;        # INCOMING ARRAY
my @changed = ();    # OUTGOING ARRAY
my $line = '';        
my $linehead = '';
my $sourceline = '';

$regexM = decode("utf8", $regexM);
$regexR = decode("utf8", $regexR);

foreach $line (@data) {    
    chomp $line;
    $line =~ s/\s+$//;
    $line =~ s/((?:\d+\t)+)//;
    $linehead = $1;
    
    #KEEP A COPY OF ORIGINAL FOR LATER COMPARISON
    $sourceline = $line;  

    if ($regexI) { #CASE INSENSITIVE
      if ($sv) { #START VERSE
        if ($ev) { #END VERSE
          if ($ww) { #WHOLE WORD
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~^[$ch]$regexM[$ch]\b$~$regexR~gie;
        } else {   #NO CHAR DELIMITS
        $line =~ s~^$regexM\b$~$regexR~gie;
        }
          } else { #NOT WHOLE
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~^[$ch]$regexM[$ch]$~$regexR~gie;              
        } else {   #NO CHAR DELIMITS
        $line =~ s~^$regexM$~$regexR~gie;              
        }
          }              
        } else { #NOT END VERSE
          if ($ww) { #WHOLE WORD  
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~^\b[$ch]$regexM[$ch]\b~$regexR~gie;
        } else {   #NO CHAR DELIMITS
        $line =~ s~^$regexM\b~$regexR~gie;
        }
          } else { #NOT WHOLE
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~^[$ch]$regexM[$ch]~$regexR~gie;              
        } else {   #NO CHAR DELIMITS
        $line =~ s~^$regexM~$regexR~gie;              
        }
          }              
        }
      } else {   #NOT START    
        if ($ev) { #END VERSE
          if ($ww) { #WHOLE WORD
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~\b[$ch]$regexM[$ch]\b$~$regexR~gie;
        } else {   #NO CHAR DELIMITS
        $line =~ s~\b$regexM\b$~$regexR~gie;
        }
          } else { #NOT WHOLE
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~[$ch]$regexM[$ch]$~$regexR~gie;              
        } else {   #NO CHAR DELIMITS
        $line =~ s~$regexM$~$regexR~gie;              
        }
          }              
        } else {   #NOT END VERSE    
          if ($ww) { #WHOLE WORD
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~\b[$ch]$regexM[$ch]\b~$regexR~gie;
        } else {   #NO CHAR DELIMITS
        $line =~ s~\b$regexM\b~$regexR~gie;
        }
          } else { #NOT WHOLE
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~[$ch]$regexM[$ch]~$regexR~gie;              
        } else {   #NO CHAR DELIMITS
        $line =~ s~$regexM~$regexR~gie;              
        }
          }              
        }    
      }    
    } else { #CASE SENSITIVE
      if ($sv) { #START VERSE
        if ($ev) { #END VERSE
          if ($ww) { #WHOLE WORD
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~^\b[$ch]$regexM[$ch]\b$~$regexR~ge;
        } else {   #NO CHAR DELIMITS
        $line =~ s~^\b$regexM\b$~$regexR~ge;
        }
          } else { #NOT WHOLE
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~^[$ch]$regexM[$ch]$~$regexR~ge;              
        } else {   #NO CHAR DELIMITS
        $line =~ s~^$regexM$~$regexR~ge;              
        }
          }              
        } else {   #NOT END    
          if ($ww) { #WHOLE WORD
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~^\b[$ch]$regexM[$ch]\b~$regexR~ge;
        } else {   #NO CHAR DELIMITS
        $line =~ s~^\b$regexM\b~$regexR~ge;
        }
          } else { #NOT WHOLE
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~^[$ch]$regexM[$ch]~$regexR~ge;              
        } else {   #NO CHAR DELIMITS        
        $line =~ s~^$regexM~$regexR~ge;
        }
          }              
        }    
      } else {   #NOT START
        if ($ev) { #END VERSE
          if ($ww) { #WHOLE WORD
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~\b[$ch]$regexM[$ch]\b$~$regexR~ge;
        } else {   #NO CHAR DELIMITS
        $line =~ s~\b$regexM\b$~$regexR~ge;
        }
          } else { #NOT WHOLE
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~[$ch]$regexM[$ch]$~$regexR~ge;              
        } else {   #NO CHAR DELIMITS
        $line =~ s~$regexM$~$regexR~ge;              
        }
          }              
        } else {   #NOT END    
          if ($ww) { #WHOLE WORD
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~\b[$ch]$regexM[$ch]\b~$regexR~ge;
        } else {   #NO CHAR DELIMITS
        $line =~ s~\b$regexM\b~$regexR~ge;
        }
          } else { #NOT WHOLE
        if ($ch) { #CHAR DELIMITERS
        $line =~ s~[$ch]$regexM[$ch]~$regexR~ge;
        } else {   #NO CHAR DELIMITS
        $line =~ s~$regexM~$regexR~ge;
        }
          }              
        }    
      }
    }
    if ($line ne $sourceline) {
        
        push @changed, "$linehead$sourceline\t$line\n";
    };
    
    $line = $linehead.$line;
    
}
return @changed;
    
} # END SUB processReplacements
[download]

To me, that doesn't seem very Perlish. It is certainly far more unwieldy to work with. Can this whole subroutine be replaced with just a few lines as per my first attempt?

#!/usr/bin/env perl -w
use Parallel::ForkManager;
my $filename = 'all.txt';
my $failuresfilename="failed.tsv";
open (my $target, "<", $filename) or die "Cannot open < $filename: $!"
+;
open (my $failures, ">", $failuresfilename) or die "Cannot open > $fai
+luresfilename: $!";
sub readinFile {
  @lines = <$target>;
}
sub execute {
  $multiprocess = Parallel::ForkManager->new(2);
  TARGETS:
  foreach $processme (@lines) {
    $multiprocess->start and next TARGETS;
    
    chomp $processme;
    $command="cfn_nag_scan -o json --input-path $processme > $processm
+e_.cfnag.json";
    `$command`;
     $multiprocess->finish;
  }
}
sub findFailures {
  @files=`find ./ -iname "*cfnag*"`;
  $jqcommand='jq --raw-output \'.[] | select (.file_results.failure_co
+unt > 0) |[.filename, .file_results.failure_count] |@tsv\'';
  foreach (@files) {
    chomp;
    s/\/\//\//g;
    @a=`cat $_ |$jqcommand`;
    print $failures @a;
  }
}
readinFile();
execute();
#findFailures();
close $failures;
close $failuresfilename;
[download]

I have two hash and trying to join into one hash

 

#!/usr/bin/perl -w

use strict;
use warnings;


my $VAR1 = {
          'Total' => {
                       'month1' => 0,
                       'month2' => 0,
                       'month3' => 0,
                       'month4' => 0,
                       'month5' => 0,
                       'month6' => 0,
                       'month7' => 0,
                       'month8' => 0,
                       'month9' => 0,
                       'month10' => 0,
                       'month11' => 0,
                       'month13' => 0,
                       'month14' => 0,
                       'month15' => 0,
                       'month16' => 0
                     },
          'Tom' => {
                                'month1' => 17,
                                'month2' => 1,
                                'month3' => 15,
                                'month4' => 0,
                                'month5' => 3,
                                'month6' => 30,
                                'month7' => 33,
                                'month8' => 0,
                                'month9' => 0,
                                'month10' => 0,
                                'month11' => 0,
                                'month12' => 0,
                                'month13' => 0,
                                'month14' => 0,
                                'month15' => 0
                              }

        };


my $VAR2 = [
          {
            'Total' => {
                         'week1' => 0,
                         'week2' => 0,
                         'week3' => 0
                       },
            'Harry' => {
                          'week1' => 0,
                          'week2' => 5,
                          'week3' => 5
                       }

          }

        ];

    my %joined_FS;
    $joined_FS{$_} ||= {( %{$VAR1->{$_}||{}}, %{$VAR2->{$_}||{}} )} fo
+r keys(%$VAR1), keys(%$VAR2);
    #This example was given by PerlMonks
    print Dumper(\%joined_FS);

[download]

#Error:

Not a HASH reference at perl_script_work2.pl line 2441.
# Looks like your test exited with 255 just after 2.
[download]

Expected Output:

    $VAR1 = {
          'Tom' => {
                      'month1' => 17,
                      'month2' => 1,
                      'month3' => 15,
                      'month4' => 0,
                      'month5' => 3,
                      'month6' => 30,
                      'month7' => 33,
                      'month8' => 0,
                      'month9' => 0,
                      'month10' => 0,
                      'month11' => 0,
                      'month12' => 0,
                      'month13' => 0,
                      'month14' => 0,
                      'month15' => 0
                    },
          'Total' => {
                       'month1' => 0,
                       'month2' => 0,
                       'month3' => 0,
                       'month4' => 0,
                       'month5' => 0,
                       'month6' => 0,
                       'month7' => 0,
                       'month8' => 0,
                       'month9' => 0,
                       'month10' => 0,
                       'month11' => 0,
                       'month13' => 0,
                       'month14' => 0,
                       'month15' => 0,
                       'month16' => 0,
                       'week1' => 0,
                       'week2' => 0,
                       'week3' => 0
                      },
            'Harry' => {
                          'week1' => 0,
                          'week2' => 5,
                          'week3' => 5
                       }
    };
[download]

Please give me directions to fix this, many thanks.

I'm experimenting on using CHI as the backend of a Data::Throttler-like module. The speed is not great: my module is becoming linearly slower as the max_items parameter is increased: it's about 3 times slower than Data::Throttler with max_items=100, and 20 times slower with max_items=1000. Any idea on how to close the gap, or is my endeavor with CHI in this case a lost cause?

package Data::Throttler_CHI;

use strict;
use warnings;

sub new {
    my ($package, %args) = @_;
    bless \%args, $package;
}

my $counter = 0;
sub try_push {
    my $self = shift;
    my $now = time();
    $counter++;
    $counter = 0 if $counter == 2e31; # wraparound 32bit int
    $self->{cache}->set("$now|$counter", 1, $self->{interval}); # Y228
+6!
    my @keys0 = $self->{cache}->get_keys;

    my @keys;
    for my $key (@keys0) {
        my ($key_time, $key_serial) = split /\|/, $key, 2;
        if ($key_time >= $now - $self->{interval}) {
            push @keys, $key;
        }
    }

    # these drivers return expired keys: Memory. so we need to purge t
+hese keys
    my $do_purge = rand() < 0.05; # probabilistic
    $self->{cache}->purge if $do_purge && @keys < @keys0;

    return @keys <= $self->{max_items} ? 1:0;
}

1;
[download]

More complete code with documentation and tests is on CPAN: Data::Throttler_CHI.

I'm interested in improving the reliability of CPAN modules on systems that do not get all that much attention, and MSWin32 seems to be one of them.

I have been studying the various CPAN testing documents, as well as checking out the CPAN testers log file, that gives the 1000 most recent reports.

This is off-the-cuff and not rigorous, but a quick check for "Linux" gives me around 600 of test results, "BSD" around 360, and "MSWin32" around 40. This suggests to me (making certain assumptions that the testing population represents the broad user population) -- that only about 4% of Perl users are on Windows.

Do those estimates seem at all accurate? Thanks for the guidance.

I have been trying to use C:/Windows/System32/OpenSSH/scp.exe command to copy a file from windows10 to unix server. But I always get error,

I have generated rsa key and copied into authorised_keys file at unix server. So no password required.

  my $src_cmd = "C:/Windows/System32/OpenSSH/scp ". $src_file. " vinot
+hg\@$server:".$target_path;
  print("Source copy cmd: $src_cmd\n");
  my $output = qx($src_cmd);
  my $status = $? >> 8 ;
  if( $status ){
    print("Error: $output\n");
    return 0
  }
[download]

It prints,

Source copy cmd: C:/Windows/System32/OpenSSH/scp D:/dev/eee/src/sample
+.dat vinothg@ipaddress:/home/vinothg/src/20200218124538501.dat

The system cannot find the path specified.
[download]

even I tried with sing backward slash(\) and double(\\)slash, but getting the same error. But when I copy and run the above command in windows cmd prompt it copies the files correctly without any issues.

I have been asked to use this scp command instead of installing perl modules.

I am creating a multi-dimensional hash and then printing a non-existent key in that hash. Curiously (at least to me), that "print" is actually altering the hash, adding an invalid (for lack of a better word) key.

#!/usr/bin/perl

use strict;
use Data::Dumper;

my %hash;
$hash{'key1'}{'key2'} = 'value';

print "\nDump of \%hash (1):\n";
print Dumper \%hash;

# This print statement is actually altering the hash
print "\n\"$hash{'key0'}{'key1'}{'key2'}\"\n";

print "\nDump of \%hash (2):\n";
print Dumper \%hash;
[download]

Dump of %dtoHash (1):
$VAR1 = {
          'key1' => {
                      'key2' => 'value'
                    }
        };

""

Dump of %dtoHash (2):
$VAR1 = {
          'key1' => {
                      'key2' => 'value'
                    },
          'key0' => {
                      'key1' => {}
                    }
        };
[download]

The "print" statement is the only thing that can possibly be altering the hash. Indeed, comment it out and the 2nd dump is normal.

I have reproduced this on multiple versions of perl 5, up to and including 5.26.3 (on CentOS 8).

Why is the "print" statement altering the hash?

Any explanation (or even better, advice on how to avoid it) would be much appreciated.

Thanks in advance.

Hello Monks

It's been a long time since I posted on Perl Monks - it feels good to be back!

On to my problem...

So I know what you're going to say: why oh why are you trying to compile Perl scripts on Windows? I certainly feel the same as I've been tearing what little remains of my hair out on this on and off for a few weeks now. (I haven't been working on this one problem the whole time I should add - that would be a bit extreme!)

Previously I was able to compile my utility without issue. I am not sure whether module updates have caused the problem or something else has changed in the setup of the (virtual) machine I'm using for the compile process. However, the error messages do make the problem fairly obvious (I think). They say things like:

To be clear this is after compile has completed, and when I am trying to run the executable that was produced - and when I'm running it on a different Windows machine)

I believe it is ultimately due to one of the SSL related modules (IO::Socket::SSL, LWP::Protocol::https, Net::SSLeay etc) basically caching. The compiler (I'm using pp = the Par Packer) goes ahead and compiles a fixed reference to the cache file in the temp directory. Then the same file can't be found on a different machine.

So at the top level - in my script - I'm using WWW::Mechanize. I guess if I was using IO::Socket::SSL directly, I might be able to do something to influence caching, since I note the docs on this module have a lot of references to a "session_cache". I presume this is the problem. However, I'm confused how I can persuade it to forget about caching, given I don't have a direct interface to it. Perhaps there is an environment variable I can set, or global constants? I have spent a fair amount of time looking over the code in those modules and even putting print/die statements in there, but without much luck. Trial and error is a bit tedious because it involves compiling then transferring to a different machine, only to see the same error pop up.

Very often when I get to this level of frustration it's down to me having missed something obvious that a new set of eyes will find quickly - hence my question on Perl Monks.

I'm using Strawberry Perl 5.6 (32 bit) and compiling on a virtual (box) machine with Windows 7, and I installed all the relevant modules with the cpan shell (if that helps).

Any thoughts would really be appreciated

Thanks!

$ man 2 send
No manual entry for send in section 2
[download]

But my real interest in the switchover is to get reads to time out. I have a pokey host I connect to; sometimes {annoyingly regularly} the server seems to balk and my program just hangs, dead in the water, on the <$server>. So what I'd like to do is use the socket timeout mechanism to let my program continue. I see that there's a Timeout parameter that unhelpfully just says "Timeout value for various operations". ?? Units?? {I'd have guessed milliseconds, but IO::Socket says it is in seconds, which makes sense} which operations?? what happens when the timeout value is reached??

Also, my incoming data is line-at-a-time and so the <$ssh> is perfect for what I need. Is there an equivalent way to do that with IO::Socket? I guess I could recv a character at a time until I got a newline.