Azure REST API "Put Block" error 596? - perl

I can't see any information in the Azure Blob Service Error Code list https://msdn.microsoft.com/en-us/library/dd179439.aspx that relates to error 596.
I am trying to upload some blocks to the Azure service and am getting a response back from the API with code 596 and description 'Broken pipe'.
Has anyone encountered this before ?
(N.B. Yes, I know the code below is not complete yet in that the code as-is does not upload the final chunk)
#!/usr/bin/perl
use 5.014;
use strict;
use warnings;
use autodie;
use Data::Dumper;
use Digest::MD5 qw(md5_base64);
use Crypt::PRNG::Fortuna qw(random_bytes_b64u random_bytes);
use Digest::SHA qw(hmac_sha256_base64);
use Getopt::Long;
use Sys::Syslog qw( :DEFAULT setlogsock);
use File::stat;
use AnyEvent;
use AnyEvent::HTTP;
use Time::Piece;
use Encode qw(decode encode);
use MIME::Base64 qw(encode_base64 decode_base64 encode_base64url);
use FileHandle;
use Fcntl ':flock', 'SEEK_SET';
delete #ENV{'PATH', 'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
use sigtrap 'handler' => \&term_handler, 'normal-signals';
####### PARAMS
my $script="upload.pl";
my $maxSingleUpload=1048576; # Maximum size of a single attempt upload (in bytes);
my $multiChunkSize=4194304; # Maximum size of a single block (in bytes)
my $multiLimit=6; # Maximum number of parallel HTTP requests
####### AZURE
my $azureKey="<REMOVED>";
my $azureKeyBin=decode_base64($azureKey);
####### ARGS
my ($vault,$container,$localfile,$remotefile);
my $debug=0;
GetOptions(
"vault|v=s" => \$vault,
"container|c=s" => \$container,
"localfile|l=s" => \$localfile,
"remotefile|r=s" => \$remotefile,
"debug|d+" => \$debug
);
if (!defined $vault || !defined $container || !defined $localfile || !defined $remotefile) {
say "USAGE: -v <vault> -c <container> -l <localfile> -r <remotefile> [-d (debug)]";
exit 1;
}
if (!-e $localfile) {
say "Local file does not exist !";
exit 1;
}
####### Vars
my ($wholeChunks,$chunkRemainder,$runID,$condvar,#offsets,#blocklist);
my $activeCount=0;
my $putBlockURL="https://${vault}.blob.core.windows.net/${container}/${remotefile}?comp=block&blockid=";
####### FUNCTIONS
# Quotient remainder calculator
sub qrem {
use integer;
my( $dividend, $divisor ) = #_;
my $quotient = $dividend / $divisor;
my $remainder = $dividend % $divisor;
my #result = ( $quotient, $remainder );
return #result;
}
# Do pad
sub doPad {
my ($raw) = #_;
while (length($raw) % 4) {
$raw .= '=';
}
return $raw;
}
# Random
sub getRandom {
my ($len) = #_;
#return doPad(random_bytes_b64u($len));
return doPad(encode_base64(random_bytes($len)));
}
# Term handler
sub term_handler {
doLog("err","term_handler: Program terminated early due to user input");
exit 2;
}
# Log sub
sub doLog {
my ($priority,$msg) = #_;
return 0 unless ($priority =~ /info|err|debug/);
setlogsock('unix');
openlog($script, 'pid,cons', 'user');
syslog($priority, $msg);
closelog();
return 1;
}
# Get file size
sub fileSz {
my($file) = #_;
my $stat = stat($file);
return $stat->size;
}
# Get data
sub readData {
my ($file,$length,$offset)=#_;
my $fh = FileHandle->new;
my ($data);
if ($debug) { say "Reading ${file} offset ${offset} for length ${length}";}
#open ($fh,"<",$file);
$fh->open("< $file");
binmode($fh);
seek($fh,$offset,SEEK_SET);
read($fh,$data,$length);
if ($debug) { say "readData read ".byteSize($data);}
#close($fh);
$fh->close;
return $data;
}
# Calc MD5
sub calcMD5 {
my ($data)=#_;
my $hash = md5_base64($data);
return doPad($hash);
}
# Populate offsets
sub populateOffsets {
my ($count,$offsetSize)=#_;
if (!defined $count || !defined $offsetSize) {exit 1;}
my $offset=0;
my #offsets;
for my $i (1..$count) {
push #offsets,$offset;
$offset = $offset + $offsetSize;
}
return #offsets;
}
# Calc auth string
sub azureAuth {
my($t,$signstring)=#_;
if (!defined $signstring) { exit 1;}
if ($debug) {say "String to sign:${signstring}";}
my $auth;
$auth=doPad(hmac_sha256_base64($signstring,$azureKeyBin));
if ($debug) { say "Sig:${auth}";}
return $auth;
}
# Byte size
sub byteSize {
use bytes;
my ($inval)=#_;
return length($inval);
}
# Process
sub doProcess {
return if $activeCount >= $multiLimit;
my $offset = shift #offsets;
return if !defined $offset;
$activeCount++;
if ($debug) { say "Active:${activeCount}, Offset:${offset}";}
$condvar->begin;
my $t = localtime;
my $tNow = $t->strftime();
my $blockid = getRandom(8);
my $subRunID=getRandom(5);
my $contentLength=$multiChunkSize-1;
my $content = readData($localfile,$contentLength,$offset);
my $hash = calcMD5($content);
if ($debug) { say "Block ID:${blockid}, Hash: ${hash}";}
my $url = $putBlockURL.$blockid;
my $canocResource="/${vault}/${container}/${remotefile}\nblockid:${blockid}\ncomp:block";
my $hdrs="x-ms-client-request-id:${runID}\nx-ms-date:${tNow}\nx-ms-version:2009-09-19";
my $byteLength=byteSize(${content});
my $canocHeaders=encode('UTF-8',"PUT\n\n\n${byteLength}\n${hash}\n\n\n\n\n\n\n\n${hdrs}\n${canocResource}",Encode::FB_CROAK);
my $authData=azureAuth($t,$canocHeaders);
if ($debug) {say "Length:${byteLength}";say "Sig: ${authData}"; say "URL:${url}";}
my $azureArr = {
"Authorization"=>"SharedKey ${vault}:${authData}",
"Content-Length"=>${byteLength},
"Content-MD5"=>${hash},
"x-ms-version"=>"2009-09-19",
"x-ms-date"=>${tNow},
"x-ms-client-request-id"=>"${runID}"
};
####### ERROR OCCURS HERE ....
http_request "PUT" => $url,
persistent=>0,
headers=>$azureArr,
body=>$content,
sub {
my ($body, $hdr) = #_;
say Dumper($hdr);
#say "received, Size: ", length $body;
#say $body;
$activeCount--;
$condvar->end;
doProcess();
};
return 1;
}
####### MAIN
$runID=getRandom(5);
doLog("info","${runID} Starting upload for ${localfile} (${remotefile})");
if (fileSz($localfile)<$maxSingleUpload) {
if ($debug) {say "Using single upload method";}
} else {
if ($debug) {say "Using multi-upload method";}
# Calculate chunk quantity
my #chunks = qrem(fileSz($localfile),$multiChunkSize);
$wholeChunks=$chunks[0];
$chunkRemainder=$chunks[1];
if ($debug) {say "Whole chunks (${multiChunkSize}):${wholeChunks}, Remainder:${chunkRemainder}";}
# Init
#offsets=populateOffsets(${wholeChunks},${multiChunkSize});
say Dumper(#offsets);
$condvar = AnyEvent->condvar;
# DO IT
for (1..$multiLimit) {
doProcess();
}
$condvar->recv;
}
doLog("info","${runID} Upload complete");
exit 0;

Error 596 is a client-side error returned by AnyEvent::HTTP. You need to investigate locally to see why you are hitting this error.
See this page for more info:
https://metacpan.org/pod/AnyEvent::HTTP
596 - errors during TLS negotiation, request sending and header processing.

Related

My code to change the password from remote server is not working

I was using this in the perl script, where it is login to a couple of servers and trying to change the password for the servers through a remote host. But the problem is that the password is not getting changed on both the servers as well as i am not finding a way to check if the new passwords are passed to the servers using expect. i am posting that part of the code where it is checking for the prompt and trying to change the password.
#!/usr/bin/perl
package Session;
use strict;
use warnings;
use Expect;
use IO::Pty;
use Data::Dumper;
use Time::HiRes qw(usleep);
use Switch;
use YAML;
use feature 'say';
my $host1 = $ARGV[0];
my $host2 = $ARGV[1];
my $host1_adapter_name = $ARGV[2];
my $host2_adapter_name = $ARGV[3];
my $exp = Expect->new;
my ($selfObj) = #_;
my $str = "{$host1}\{root} # ";
my $cmdStr; my $result; my $dev_id;
my $timeout = 10;
my $min = 192;
my $range = 32;
my $host1_dev_id = _adapter($host1_adapter_name);
my $host2_dev_id = _adapter($host2_adapter_name);
my #hosts = ("$host1", "$host2");
print ("host2 name is=$host2------");
foreach my $n (#hosts)
{
print ("value of n is $n\n");
if ( $n eq $host1 )
{
_login($n,$host1_dev_id);
}
if ( $n eq $host2)
{
print ("inside 2nd if-----\n");
_login($n,$host2_dev_id);
}
}
sub _login
{
my ($host,$host_dev_id) = #_;
my $exit = 1;
$exp->raw_pty(1);
$exp = Expect->spawn("telnet $host") or die "unable to connect , Please check the connection & retry again: $!\n";
if (!defined($exp))
{
print "Please check the connection & retry again\n";
return -1;
}
`sleep 2 `;
$exp->expect($timeout,
[
qr'[lL]ogin:[\s]?[a]?[s]?[\s]?$',
sub
{
$exp->send("root\r");
`sleep 3 `;
exp_continue;
}
],
[
qr'[pP]assword:[\s]?$',
sub
{
$exp->send("That11NeverWork!\r");
exp_continue;
}
],
[
qr '[#>:][\s]?$',
sub {
$cmdStr = "passwd\r";
$result =_run_cmd($cmdStr);
qr'root\'s New password:\s*';
$exp->send("raym0nd24");
qr'Enter the new password again:\s*';
$exp->send("raym0nd24");
# $exp->send('passwd:\s*',5);
$exit = 0;
exp_continue;
}
],
[
eof =>
sub
{
print("FileName : Session.pm , ERROR: premature EOF in command execution.\n");
}
],
'-re', qr'[#$>:]\s?$', # wait for shell prompt, then exit expect
);
}
#############################################################
#############################################################################
sub _adapter
{
my ($adapter_name) = #_;
print "Adapter name: $adapter_name\n";
chomp($adapter_name);
switch($adapter_name){
case "AUSTIN" {$dev_id="e414571614102004"}
case "CX5" {$dev_id="b315191014103506"}
case "CX4" {$dev_id="b31513101410f704"}
case "CX4_EG10" {$dev_id="b315151014101f06"}
case "CX4_EG25" {$dev_id="b315151014101e06"}
case "CX3" {$dev_id="RoCE"}
case "CX2" {$dev_id="b315506714106104"}
case "CX3_PRO" {$dev_id="RoCE"}
case "CX3_PRO1" {$dev_id="b31507101410e704"}
case "HOUSTON_LR" {$dev_id="df1020e214104004"}
case "HOUSTON_SR" {$dev_id="df1020e214100f04"}
case "HOUSTON_Cu" {$dev_id="df1020e214103d04"}
case "SHINER_S" {$dev_id="e4148a1614109304"}
case "SHINER_T" {$dev_id="e4148e1614109204"}
case "SLATE_SR" {$dev_id="df1020e21410e304"}
case "SLATE_CU" {$dev_id="df1020e21410e404"}
case "EVERGLADES" {$dev_id="b315151014101e06"}
else { print "Adapter not in list\n"}
}
return $dev_id;
}
#######################################################################################
##########################################################
sub _run_cmd
{
my $output; my $output1;
my ($cmdStr) = #_;
$exp->send($cmdStr ."\r");
$exp->expect(21, '-re', $str);
$output = $exp->exp_before();
$exp->clear_accum();
my #PdAt_val = split("\r?\n", $output);
foreach my $line1 (#PdAt_val)
{
chomp($line1);
if ( $line1 =~ /(\(\d+\))(\s*root\s*\#\s*)/)
{
if ( $1 =~ /\((\d+)\)/)
{
if ($1 != 0)
{
print("*************** Command $cmdStr didn't ran sucessfully ***************\n");
exit;
}
}
}
}
return $output;
}
######################################################################
There are individual solutions for different systems. So some systems got from their god the must have highlevel restrictions. So the regular says, that you cant login as root directly. To step up the long way to the stage you can use sudo or su. I didnt see that mind in your lines.
# The simpliest way is to use what you have!
sub passwd
{
my $user = #_[0];
my $password = #_[1];
#
# as root
my $execline = qq~passwd $user:$password~;
#
# as root with second password
my $execline = qq~passwd $user:$password\n$password~;
#
# for microsoft certified ubuntu noobs, kidding mint's
my $execline = qq~sudo $password && passwd $user:$password~;
#
# for apple greyed, debian nerds, solaris freaks
my $execline = qq~su $password && passwd $user:$password~;
#
my $return = system("$execline");
}
print &passwd("root","the magical word");
#
# elseif read this.url([to get the higher experience][1]);
[1]: https://stackoverflow.com/questions/714915/using-the-passwd-command-from-within-a-shell-script

Is it possible to register a function to preprocess log messages with Log::Log4perl?

In this example:
$logger->debug({
filter => \&Data::Dumper::Dumper,
value => $ref
});
I can pretty print my references instead of ARRAY(0xFFDFKDJ). But it's too boring to type that long code every time. I just want:
$logger->preprocessor({
filter => \&Data::Dumper::Dumper,
value => $ref
});
$logger->debug( $ref, $ref2 );
$logger->info( $array );
And $ref, $ref2, and $array will be dumped by Data::Dumper.
It there a way to do this?
UPD
With help of your answers I do the patch
Now you just:
log4perl.appender.A1.layout=FallbackLayout
log4perl.appender.A1.layout.chain=PatternLayout
log4perl.appender.A1.layout.chain.ConversionPattern=%m%n
log4perl.appender.A1.warp_message = sub { $#_ = 2 if #_ > 3; \
return #_; }
# OR
log4perl.appender.A1.warp_message = main::warp_my_message
sub warp_my_message {
my( #chunks ) = #_;
use Data::Dump qw/ pp /;
for my $msg ( #chunks ) {
$msg = pp $msg if ref $msg;
}
return #chunks;
}
UPD2
Or you can use this small module
log4perl.appender.SomeAPP.warp_message = Preprocess::Messages::msg_filter
log4perl.appender.SomeAPP.layout = Preprocess::Messages
package Preprocess::Messages;
sub msg_filter {
my #chunks = #_;
for my $msg ( #chunks ) {
$msg = pp $msg if ref $msg;
}
return #chunks;
};
sub render {
my $self = shift;
my $layout = Log::Log4perl::Layout::PatternLayout->new(
'%d %P %p> %c %F:%L %M%n %m{indent=2}%n%n'
);
$_[-1] += 1; # increase level of the caller
return $layout->render( join $Log::Log4perl::JOIN_MSG_ARRAY_CHAR, #{ shift() }, #_ );
}
sub new {
my $class = shift;
$class = ref ($class) || $class;
return bless {}, $class;
}
1;
Yes, of course you can set 'warp_message = 0' and combine msg_filter and render together.
log4perl.appender.SomeAPP.warp_message = 0
log4perl.appender.SomeAPP.layout = Preprocess::Messages
sub render {
my($self, $message, $category, $priority, $caller_level) = #_;
my $layout = Log::Log4perl::Layout::PatternLayout->new(
'%d %P %p> %c %F:%L %M%n %m{indent=2}%n%n'
);
for my $item ( #{ $message } ) {
$item = pp $item if ref $item;
}
$message = join $Log::Log4perl::JOIN_MSG_ARRAY_CHAR, #$message;
return $layout->render( $message, $category, $priority, $caller_level+1 );
}
The easy way: use warp_message
The easiest way to do this is to create a custom appender and set the warp_message parameter so you can get the original references that were passed to the logger:
package DumpAppender;
use strict;
use warnings;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Terse = 1;
sub new {
bless {}, $_[0];
}
sub log {
my($self, %params) = #_;
print ref($_) ? Dumper($_) : $_ for #{ $params{message} };
print "\n";
}
package main;
use strict;
use warnings;
use Log::Log4perl;
Log::Log4perl->init(\q{
log4perl.rootLogger=DEBUG,Dump
log4perl.appender.Dump=DumpAppender
log4perl.appender.Dump.layout=NoopLayout
log4perl.appender.Dump.warp_message=0
});
my $logger = Log::Log4perl->get_logger;
$logger->debug(
'This is a string, but this is a reference: ',
{ foo => 'bar' },
);
Output:
This is a string, but this is a reference: {'foo' => 'bar'}
Unfortunately, if you take this approach, you're stuck writing your own code to handle layouts, open files, etc. I wouldn't take this approach except for very simple projects that only need to print to screen.
A better way: composite appender
A better approach is to write your own composite appender. A composite appender forwards messages on to another appender after manipulating them somehow, e.g. filtering or caching them. With this approach, you can write only the code for dumping the references and let an existing appender do the heavy lifting.
The following shows how to write a composite appender. Some of this is explained in the docs for Log::Log4perl::Appender, but I copied much of it from Mike Schilli's Log::Log4perl::Appender::Limit:
package DumpAppender;
use strict;
use warnings;
our #ISA = qw(Log::Log4perl::Appender);
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Terse = 1;
sub new {
my ($class, %options) = #_;
my $self = {
appender => undef,
%options
};
# Pass back the appender to be limited as a dependency to the configuration
# file parser.
push #{ $options{l4p_depends_on} }, $self->{appender};
# Run our post_init method in the configurator after all appenders have been
# defined to make sure the appenders we're connecting to really exist.
push #{ $options{l4p_post_config_subs} }, sub { $self->post_init() };
bless $self, $class;
}
sub log {
my ($self, %params) = #_;
# Adjust call stack so messages are reported with the correct caller and
# file
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2;
# Dump all references with Data::Dumper
$_ = ref($_) ? Dumper($_) : $_ for #{ $params{message} };
$self->{app}->SUPER::log(
\%params,
$params{log4p_category},
$params{log4p_level}
);
}
sub post_init {
my ($self) = #_;
if(! exists $self->{appender}) {
die "No appender defined for " . __PACKAGE__;
}
my $appenders = Log::Log4perl->appenders();
my $appender = Log::Log4perl->appenders()->{$self->{appender}};
if(! defined $appender) {
die "Appender $self->{appender} not defined (yet) when " .
__PACKAGE__ . " needed it";
}
$self->{app} = $appender;
}
package main;
use strict;
use warnings;
use Log::Log4perl;
Log::Log4perl->init(\q{
log4perl.rootLogger=DEBUG, Dump
log4perl.appender.Dump=DumpAppender
log4perl.appender.Dump.appender=SCREEN
log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
log4perl.appender.SCREEN.layout=PatternLayout
log4perl.appender.SCREEN.layout.ConversionPattern=%d %p %m%n
});
my $logger = Log::Log4perl->get_logger;
$logger->debug(
'This is a string, but this is a reference: ',
{ foo => 'bar' },
);
Output:
2015/09/14 13:38:47 DEBUG This is a string, but this is a reference: {'foo' => 'bar'}
Note that you have to take some extra steps if you initialize Log::Log4perl via the API instead of via a file. This is documented in the composite appenders section of the Log::Log4perl::Appender documentation.

Perl: library to log on specific files

I'm creating a library for my stuffs where I want to log errors on a specific file. Unfortunately, while it works if I initiate only one single instance of the library, it doesn't if I initiate more than one instance.
The results in that case is that the output is logged all in the last file and not half and half as I was expecting.
This is the main.pl
eval 'exec /usr/bin/perl -I `pwd` -S $0 ${1+"$#"}'
if 0;
use strict;
use MyLibrary;
my ($rc, $test_2, $test_1);
# The output is not going into this file
exit $test_1 if (($test_1 = MyLibrary->new("/tmp", "test_1")) !~ "HASH");
# It is going all into this file
exit $test_2 if (($test_2 = MyLibrary->new("/tmp", "test_2")) !~ "HASH");
exit $rc if ( $rc = $test_1->test() );
exit $rc if ( $rc = $test_2->test() );
and this is MyLibrary.pm
package MyLibrary;
use strict;
use Symbol;
use vars qw($VERSION #ISA #EXPORT %default);
#EXPORT = qw(
);
$VERSION = '1.00';
require 5.000;
%default;
my $fh;
sub new
{
my $rc;
my ($proto, $log_dir, $log_file) = #_;
my $class = ref($proto) || $proto;
my $self = { %default };
bless($self, $class);
$fh = gensym;
($self->{'log_dir'}, $self->{'log_file'}) = ($log_dir, $log_file);
return $rc if ( $rc = $self->open_log_file() );
return $self;
}
sub destroy
{
my $rc;
my $self = shift;
return $rc if ( $rc = $self->close_log_file() );
}
sub open_log_file
{
my $self = shift;
open $fh, ">>$self->{'log_dir'}/$self->{'log_file'}" or die "cannot open file $self->{'log_dir'}/$self->{'log_file'}";
return 0;
}
sub close_log_file
{
my $self = shift;
close($fh) or die "cannot close $self->{'log_dir'}/$self->{'log_file'}";
return 0;
}
sub test
{
my $self = shift;
print $fh "[$self->{'log_file'}]\n";
return 0;
}
1;
One more thing ... In this example, I'm using $fh as a global variable, while I would like to have this variable part of the %default hash. However, if I try to make it part of the hash replacing all the $fh occurences with $self->{'fh'}, I get the following error:
String found where operator expected at MyLibrary.pm line 75, near "} "[$self->{'log_file'}]\n""
(Missing operator before "[$self->{'log_file'}]\n"?)
syntax error at MyLibrary.pm line 75, near "} "[$self->{'log_file'}]\n""
Row 75 in this case will be the following:
sub test
{
my $self = shift;
Row 75 =>>> print $self->{'fh'} "[$self->{'log_file'}]\n";
return 0;
}
While the full library reviewed accordingly is:
package MyLibrary;
use strict;
use Symbol;
use vars qw($VERSION #ISA #EXPORT %default);
#EXPORT = qw(
);
$VERSION = '1.00';
require 5.000;
%default;
sub new
{
my $rc;
my ($proto, $log_dir, $log_file) = #_;
my $class = ref($proto) || $proto;
my $self = { %default };
bless($self, $class);
$self->{'fh'} = gensym;
($self->{'log_dir'}, $self->{'log_file'}) = ($log_dir, $log_file);
return $rc if ( $rc = $self->open_log_file() );
return $self;
}
sub destroy
{
my $rc;
my $self = shift;
return $rc if ( $rc = $self->close_log_file() );
}
sub open_log_file
{
my $self = shift;
open $self->{'fh'}, ">>$self->{'log_dir'}/$self->{'log_file'}" or die "cannot open file $self->{'log_dir'}/$self->{'log_file'}";
return 0;
}
sub close_log_file
{
my $self = shift;
close($self->{'fh'}) or die "cannot close $self->{'log_dir'}/$self->{'log_file'}";
return 0;
}
sub test
{
my $self = shift;
print $self->{'fh'} "[$self->{'log_file'}]\n";
return 0;
}
1;
Empirically, it seems that the file handle in a print statement cannot be an arbitrary expression. This is really only a minor modification of your code, but to get MyLibrary.pm to compile, I replaced:
print $self->{'fh'} "[$self->{'log_file'}]\n";
with:
my $fh = $self->{'fh'};
print $fh "[$self->{'log_file'}]\n";
There are some other minor tweaks, but this code worked for me:
MyLibrary.pm
package MyLibrary;
use warnings;
use strict;
use vars qw($VERSION #ISA #EXPORT %default);
#EXPORT = qw();
$VERSION = '1.00';
require 5.000;
sub new
{
my ($proto, $log_dir, $log_file) = #_;
my $class = ref($proto) || $proto;
my $self = { %default };
bless($self, $class);
$self->{'log_dir'} = $log_dir;
$self->{'log_file'} = $log_file;
$self->open_log_file();
return $self;
}
sub destroy
{
my $rc;
my $self = shift;
return $rc if ( $rc = $self->close_log_file() );
}
sub open_log_file
{
my $self = shift;
my $log_file = "$self->{log_dir}/$self->{log_file}";
open $self->{'fh'}, ">>", $log_file or die "cannot open file $log_file";
return;
}
sub close_log_file
{
my $self = shift;
close($self->{'fh'}) or die "cannot close $self->{'log_dir'}/$self->{'log_file'}";
return;
}
sub print_data
{
my $self = shift;
my $fh = $self->{fh};
print $fh #_, "\n";
}
sub test
{
my $self = shift;
my $fh = $self->{'fh'};
print $fh "[$self->{'log_file'}]\n";
return 0;
}
1;
I'm not convinced that the use 5.000; buys you very much. The chances of finding a Perl 4.x still running are pretty remote. These days, anything earlier than Perl 5.8 is long dead (or, if it isn't, it should be).
There are many minor improvements that could be made in the code that are not shown above.
testcase.pl
#!/usr/bin/env perl
use warnings;
use strict;
use MyLibrary;
my ($rc, $test_2, $test_1);
my $counter = 0;
sub counter
{
printf"OK %d\n", ++$counter;
}
counter;
# The output is not going into this file
exit $test_1 if (($test_1 = MyLibrary->new("/tmp", "test_1")) !~ "HASH");
counter;
# It is going all into this file
exit $test_2 if (($test_2 = MyLibrary->new("/tmp", "test_2")) !~ "HASH");
counter;
exit $rc if ( $rc = $test_1->test() );
counter;
exit $rc if ( $rc = $test_2->test() );
counter;
$test_1->print_data("Extra information");
$test_2->print_data("Missing syncopation");
print "Finished\n";
Nth Sample Run
It looks like I ran a previous edition of testcase.pl once, before adding the print_data function, and four times since adding the print_data function.
$ perl -I$PWD testcase.pl
OK 1
OK 2
OK 3
OK 4
OK 5
Finished
$ cat /tmp/test_1
[test_1]
[test_1]
Extra information
[test_1]
Extra information
[test_1]
Extra information
[test_1]
Extra information
$ cat /tmp/test_2
[test_2]
[test_2]
Missing syncopation
[test_2]
Missing syncopation
[test_2]
Missing syncopation
[test_2]
Missing syncopation
$

Perl: Using IPC::Shareable for pooling Net::Server connections

I am trying to have a pool of shared connections that can be accessed by Net::Server instances. Unfortunately IPC::Shareable does not allow me to store the connections as they are code references. This is a stripped down version of the code:
use IPC::Shareable (':lock');
use parent 'Net::Server::Fork';
use MyConnectClass;
sub login {
return MyConnectClass->new();
};
my %connection;
tie %connection, 'IPC::Shareable', 'CONN', {
'create' => 1,
'exclusive' => 0,
'mode' => 0666,
'destroy' => 'yes',
}
or croak 'Can not tie connection variable';
sub add_connection {
my $id = shift(#_);
my $con = shift(#_);
$connection{$id} = $con;
};
sub get_connection {
my $id = # .. find unused connection
return $connection{$id};
}
sub process_request {
my $self = shift(#_);
eval {
my $connection = get_connection();
my $line = <STDIN>;
# .. use $connection to fetch data for user
};
};
for (my $i=0; $i<10; $i++) {
add_connection($i, &login);
};
main->run(
'host' => '*',
'port' => 7000,
'ipv' => '*',
'max_server' => 3,
};
Unfortunately the program dies after the first login: 'Can't store CODE items at ../../lib/Storable.pm'. This happens even when hiding $connection in an anonymous array. I am looking for an alternative to utilize the pool.
I appreciate your support
I am unable to propose an alternative module, but make a suggestion which may or not be of use. While you cannot store CODE, you can store strings which can be evaluated to run. would it be possible to pass a reference to the string q!&login! which you can dereference call after being assigned to $connection. ?
#!/usr/bin/perl
use warnings;
use strict;
use Storable;
my $codestring = q'sub { q^japh^ };' ;
#my $codestring = q'sub { return MyConnectClass->new(); }';
#
# for (0..9){ add_connection($i, $codestring) }
open my $file, '>', '.\filestore.dat' or die $!;
store \ $codestring, $file;
close $file;
open $file, '<', '.\filestore.dat' or die " 2 $!";
my $stringref = retrieve $file; # my $con = get_connection()
close $file;
print &{ eval $$stringref } ; # &{eval $$con} ;
exit 0; # my $line = <STDIN>; ...

Is eval/alarm is executing?

I'm writing a quick script to test the failures and interpreted traffic of a load balancer. I want it to keep trying to make connections after it can't connect to one host or another. My current script doesn't look like it's executing the eval block in the mkcnct sub, and I can't figure out why. Can anyone spot what I'm doing wrong?
#!/usr/bin/perl
use strict;
use Net::HTTP;
use Getopt::Std;
my %opts;
getopts('ht:',\%opts);
my #hostlist ("www.foo.com","www1.foo.com","www2.foo.com");
my $timeout;
if ($opts{t} =~ /\d+/) {
$timeout = $opts{t} + time();
} else {
$timeout = 3600 + time();
}
while ($timeout < time()) {
foreach my $host (#hostlist) {
my $cnct = mkcnct($host);
if ($cnct) { mkreq($cnct) };
}
}
sub mkreq {
my $cnct = shift;
my $time = gettime();
my $out;
$cnct->write_request(GET => "/index.html");
($out->{code},$out->{message},%{$out->{headers}}) = $cnct->read_response_headers;
printf "%s\t%s - Size %d\tLast modified %s\n", $time, $out->{message}, $out->{headers}{'Content-Length'}, $out->{headers}{'Last-Modified'};
$out = "";
$cnct->write_request(GET => "/pki/ca.crl");
($out->{code},$out->{message},%{$out->{headers}}) = $cnct->read_response_headers;
printf "%s\t%s - Size %d\tLast modified %s\n", $time, $out->{message}, $out->{headers}{'Content-Length'}, $out->{headers}{'Last-Modified'};
}
sub mkcnct {
my $host = shift;
my $time = gettime();
my $cnct;
eval{
local $SIG{ALRM} = sub { print "$time\tCannot connect to $host\n"};
alarm(2);
$cnct = Net::HTTP->new(Host => $host);
alarm(0);
};
alarm(0);
return($cnct);
}
sub gettime {
my #time = localtime(time);
my $out;
$out = sprintf "%d\/%d\/%d %d:%d", ($time[4] + 1), $time[3], ($time[5] % 100 ), $time[2], $time[1];
return($out);
}
Try replacing return($cnct); with return $cnct; in mkcnct. You might want to revue the docs on returning scalars and lists