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

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>; ...

Related

How to get methods from HTTP::Daemon

How can I find out the $code and $mess in HTTP::Daemon module? In cpan the usage is as
$c->send_status_line( $code, $mess, $proto )
but I dont know where/how to get $code, $mess from.
Like, send_error($code) is used as send_error(RC_FORBIDDEN) which I found from someone's code online, where did he get RC_FORBIDDEN from?
Have been playing with the following code. Sorry for the formatting and many thanks to #choroba for formatting it for me.
use warnings;
use strict;
use HTTP::Daemon;
use HTTP::Status;
use LWP;
my $daemon = HTTP::Daemon->new or die;
my $d = HTTP::Daemon->new(
LocalAddr => '0.0.0.0',
LocalPort => '5000',
);
printf ("\n\n URL of webserver is %s, show this script with %stest\n",
$d->url, $d->url);
while (my $client_connection = $d->accept)
{
new_connection($client_connection);
}
sub new_connection
{
my $client_connection = shift;
printf "new connection\n";
while (my $request = $client_connection->get_request)
{
if (my $pid = fork)
{
print "Child created : $pid\n";
}
elsif (!defined $pid)
{
die "Cannot fork $!\n";
}
else
{
my $address_of_client = $client_connection->peerhost();
my $port_of_client = $client_connection->peerport();
print "Connection from client $address_of_client on port
$port_of_client\n";
print " request\n";
if ($request->method eq 'GET' and $request->uri->path
eq "/test")
{
$client_connection->send_file_response(RC_OK);
#$client_connection->send_status_line(200);
#print "OK ";
#$client_connection->send_file_response($0);
}
else
{
$client_connection->send_error(RC_NOT_FOUND);
}
}
$client_connection->close;
}
}
The documentation also states
If $code is omitted 200 is assumed. If $mess is omitted, then a message corresponding to $code is inserted. If $proto is missing the content of the $HTTP::Daemon::PROTO variable is used.
So, you don't have to specify the arguments at all. Otherwise, just use any of the possible HTTP status codes for $code, and either don't specify the $mess to get the default message for the code, or use any message you like.
RC_FORBIDEN is exported from HTTP::Status.

perl: How to make 'warn' think we read from a file?

I have a function (a variation of string++):
sub inc
{
$_[0] =~ /^(.*?)([0-9]+)$/;
my ($a,$b)=($1,$2);
die "cannot increment [$_[0]]" unless defined $b;
warn "increment overflow [$_[0]]" if length(++$b) != length($2);
$a.$b;
}
It is invoked in many places of a script, on different data (sometimes from a file, sometimes from a database).
When I read from a filehandle, die and warn print a message like this:
cannot increment [abc] at script line 5, <filehandle> line 123.
otherwise a shorter message is printed:
cannot increment [abc] at script line 5.
When I read from database I would like to have a message like this:
cannot increment [abc] at script line 5, <SELECT...> line 123.
Is it possible?
Setting the line number is quite simple: an assignment to $. can be made. But how to set the 'filehandle' part and make it visible?
I have found such a workaround:
my $fh = "SELECT...";
open $fh, "/dev/null";
<$fh>;
but it is a bit long, and it actually does open a file.
The filehandle information that appears in warn and die messages is only set after calls to <HANDLE>, readline, tell, eof, and seek. When you fetch data from a database with DBI, for example, you're not calling any of these, so you have to pass the extra data yourself.
One way to do this is to write a custom exception class that stringifies to the text you want:
package MyException;
use strict;
use warnings 'all';
use v5.18.0;
use overload '""' => \&as_string;
sub new {
my ($self, $message, $src, $src_line) = #_;
my ($package, $file, $line) = caller;
if (! defined $src && ref ${^LAST_FH} eq 'GLOB') {
$src = *${^LAST_FH}{NAME};
$src_line = $.;
}
bless { message => $message,
file => $file,
line => $line,
src => $src,
src_line => $src_line }, $self;
}
sub as_string {
my ($self) = #_;
my $message = "$self->{message} at $self->{file} line $self->{line}";
if (defined $self->{src} && defined $self->{src_line}) {
$message .= ", <$self->{src}> line $self->{src_line}";
}
$message .= "\n";
}
1;
Note that Perl 5.18.0 or up is required to use the read-only ${^LAST_FH} variable, which holds a reference to the last read filehandle.
Here's how you would use this when reading from a file:
use strict;
use warnings 'all';
use MyException;
while (<DATA>) {
warn MyException->new('foo'); # equivalent to warn 'foo'
}
__DATA__
first
second
Output:
foo at ./myscript line 9, <DATA> line 1
foo at ./myscript line 9, <DATA> line 2
And here's how you would use it when fetching records from a database:
use strict;
use warnings 'all';
use DBI;
use MyException;
my $dbh = DBI->connect('dbi:mysql:test', 'user', 'pass', {
RaiseError => 1
});
my $sql = 'SELECT * FROM test';
my $sth = $dbh->prepare($sql);
$sth->execute;
my $count;
while (my $row = $sth->fetch) {
warn MyException->new('foo', $sql, ++$count);
}
Output:
foo at ./myscript line 19, <SELECT * FROM test> line 1
foo at ./myscript line 19, <SELECT * FROM test> line 2
(Unfortunately, DBI doesn't provide a method to get the number of rows that have been fetched so far, so you have to count them yourself.)
Since you're trying to warn or die from inside a subroutine, you have to do a little bit more work. The simplest approach for die would be to trap exceptions from your subroutine with eval and re-throw them:
my $count = 1;
while (my $row = $sth->fetch) {
eval {
inc($row[0]);
};
if ($# =~ /^(cannot increment \[.*?\])/) {
die MyException->new($1, $sql, $count);
}
elsif ($#) {
die $#;
}
$count++;
}
You can handle warnings in a similar way by creating a __WARN__ handler:
{
my $count = 1;
local $SIG{__WARN__} = sub {
if ($_[0] =~ /^(increment overflow \[.*?\])/) {
warn MyException->new($1, $sql, $count);
}
else {
warn #_;
}
};
while (my $row = $sth->fetch) {
inc($row[0]);
$count++;
}
}
You may prefer this implementation of your inc subroutine. Your own uses the reserved variables $a and $b, as well as saving and retrieving the initial non-numeric part of the string
Note that the STDERR output is not in sync with STDOUT, so the warning appears prematurely in the aggregated text. In reality the warning is issued only when the passed string has an all-nines numeric field
use strict;
use warnings 'all';
my $s = 'ZZ90';
for ( 1 .. 20 ) {
$s = inc_str($s);
print $s, "\n";
}
sub inc_str {
my ($str) = #_;
$str =~ s{([0-9]+)$}{
my $num = $1;
warn "Increment overflow [$str]" unless $num =~ /[^9]/;
sprintf '%0*d', length($num), $num+1;
}e or die "Cannot increment [$str]";
return $str;
}
output
Increment overflow [ZZ99] at E:\Perl\source\inc_str.pl line 18.
ZZ91
ZZ92
ZZ93
ZZ94
ZZ95
ZZ96
ZZ97
ZZ98
ZZ99
ZZ100
ZZ101
ZZ102
ZZ103
ZZ104
ZZ105
ZZ106
ZZ107
ZZ108
ZZ109
ZZ110

Read ini files without section names

I want to make a configuration file which hold some objects, like this (where of course none of the paramaters can be considered as a primary key)
param1=abc
param2=ghj
param1=bcd
param2=hjk
; always the sames parameters
This file could be read, lets say with Config::IniFiles, because it has a direct transcription into ini file, like this
[0]
param1=abc
param2=ghj
[1]
param1=bcd
param2=hjk
with, for example, something like
perl -pe 'if (m/^\s*$/ || !$section ) print "[", ($section++ || 0) , "]"'
And finish with
open my $fh, '<', "/path/to/config_file.ini" or die $!;
$cfg = Config::IniFiles->new( -file => $fh );
(...parse here the sections starting with 0.)
But, I here ask me some question about the thing becoming quite complex....
(A) Is There a way to transform the $fh, so that it is not required to execute the perl one-liner BEFORE reading the file sequentially? So, to transform the file during perl is actually reading it.
or
(B) Is there a module to read my wonderfull flat database? Or something approching? I let myslef said, that Gnu coreutils does this kind of flat file reading, but I cannot remember how.
You can create a simple subclass of Config::INI::Reader:
package MyReader;
use strict;
use warnings;
use base 'Config::INI::Reader';
sub new {
my $class = shift;
my $self = $class->SUPER::new( #_ );
$self->{section} = 0;
return $self;
}
sub starting_section { 0 };
sub can_ignore { 0 };
sub parse_section_header {
my ( $self, $line ) = #_;
return $line =~ /^\s*$/ ? ++$self->{section} : undef ;
}
1;
With your input this gives:
% perl -MMyReader -MData::Dumper -e 'print Dumper( MyReader->read_file("cfg") )'
$VAR1 = {
'1' => {
'param2' => 'hjk',
'param1' => 'bcd'
},
'0' => {
'param2' => 'ghj',
'param1' => 'abc'
}
};
You can use a variable reference instead of a file name to create a filehandle that reads from it:
use strict;
use warnings;
use autodie;
my $config = "/path/to/config_file.ini";
my $content = do {
local $/;
open my $fh, "<", $config;
"\n". <$fh>;
};
# one liner replacement
my $section = 0;
$content =~ s/^\s*$/ "\n[". $section++ ."]" /mge;
open my $fh, '<', \$content;
my $cfg = Config::IniFiles->new( -file => $fh );
# ...
You can store the modified data in a real file or a string variable, but I suggest that you use paragraph mode by setting the input record separator $/ to the empty string. Like this
use strict;
use warnings;
{
local $/ = ''; # Read file in "paragraphs"
my $section = 0;
while (<DATA>) {
printf "[%d]\n", $section++;
print;
}
}
__DATA__
param1=abc
param2=ghj
param1=bcd
param2=hjk
output
[0]
param1=abc
param2=ghj
[1]
param1=bcd
param2=hjk
Update
If you read the file into a string, adding section identifiers as above, then you can read the result directly into a Config::IniFiles object using a string reference, for instance
my $config = Config::IniFiles->new(-file => \$modified_contents)
This example shows the tie interface, which results in a Perl hash that contains the configuration information. I have used Data::Dump only to show the structure of the resultant hash.
use strict;
use warnings;
use Config::IniFiles;
my $config;
{
open my $fh, '<', 'config_file.ini' or die "Couldn't open config file: $!";
my $section = 0;
local $/ = '';
while (<$fh>) {
$config .= sprintf "[%d]\n", $section++;
$config .= $_;
}
};
tie my %config, 'Config::IniFiles', -file => \$config;
use Data::Dump;
dd \%config;
output
{
# tied Config::IniFiles
"0" => {
# tied Config::IniFiles::_section
param1 => "abc",
param2 => "ghj",
},
"1" => {
# tied Config::IniFiles::_section
param1 => "bcd",
param2 => "hjk",
},
}
You may want to perform operations on a flux of objects (as Powershell) instead of a flux of text, so
use strict;
use warnings;
use English;
sub operation {
# do something with objects
...
}
{
local $INPUT_RECORD_SEPARATOR = '';
# object are separated with empty lines
while (<STDIN>) {
# key value
my %object = ( m/^ ([^=]+) = ([[:print:]]*) $ /xmsg );
# key cannot have = included, which is the delimiter
# value are printable characters (one line only)
operation ( \%object )
}
A like also other answers.

inserting expect into perl loop

I have the following script that runs a command and puts the data in a DB. I need to account for the possibility of being asked for a password "password:" some of the time. How do I wrap an expect call into this?
#!/usr/software/bin/perl
use strict;
use DatabaseLib;
use Data::Dumper;
use Expect;
#Connect to database
my $dbh = DBI->connect($DB_CONNECT_STRING, $DB_USER, $DB_PASSWORD, { RaiseError => 1, AutoCommit => 1 })
or die "failed to connect to database: $DB_CONNECT_STRING";
my $expect = Expect->new;
my %burtHash;
my #cols = qw/date_create sub_by impact date-lastmod lastmod-by bug_rel case_score state s p type subtype subteam found_by target_release/;
my #burtInfo = `mycommand`;
my $timeout = 20;
my $password = "password";
while(my $ele = shift(#burtInfo)){
my ($index, #data) = split(/\s+/, $ele);
for my $i(0 .. $#cols){
$burtHash{$index}->{$cols[$i]} = shift(#data);
}
for my $id (keys %burtHash){
my %burt_details;
for my $col (keys %{$burtHash{$id}} ) {
$burt_details{$col} = $burtHash{$id}->{$col};
}
if ( $id =~ /\d+/) {
burt_update(
$dbh,
$id ,
\%burt_details,
);
}
}
}
I think I just need to put in something like this and call it, but i'm not sure where/how:
$expect->expect($timeout,
[ qr/password:/i, #/
sub {
my $self = shift;
$self->send("$password\n");
exp_continue;
}
]);
You're not using $expect anywhere there. You have to run your command via $expect->spawn so that your Expect object can handle things. And then you'll need some way of gathering its output (I'm thinking using $expect->log_file(...) to set the log to a string filehandle or something).
Once you're using $expect->spawn, then you can insert your password check. But there's no way you can do this with qx (the backticks).

Creating A Single Threaded Server with AnyEvent (Perl)

I'm working on creating a local service to listen on localhost and provide a basic call and response type interface. What I'd like to start with is a baby server that you can connect to over telnet and echoes what it receives.
I've heard AnyEvent is great for this, but the documentation for AnyEvent::Socket does not give a very good example how to do this. I'd like to build this with AnyEvent, AnyEvent::Socket and AnyEvent::Handle.
Right now the little server code looks like this:
#!/usr/bin/env perl
use AnyEvent;
use AnyEvent::Handle;
use AnyEvent::Socket;
my $cv = AnyEvent->condvar;
my $host = '127.0.0.1';
my $port = 44244;
tcp_server($host, $port, sub {
my($fh) = #_;
my $cv = AnyEvent->condvar;
my $handle;
$handle = AnyEvent::Handle->new(
fh => $fh,
poll => "r",
on_read => sub {
my($self) = #_;
print "Received: " . $self->rbuf . "\n";
$cv->send;
}
);
$cv->recv;
});
print "Listening on $host\n";
$cv->wait;
This doesn't work and also if I telnet to localhost:44244 I get this:
EV: error in callback (ignoring): AnyEvent::CondVar:
recursive blocking wait attempted at server.pl line 29.
I think if I understand how to make a small single threaded server that I can connect to over telnet and prints out whatever its given and then waits for more input, I could take it a lot further from there. Any ideas?
You're blocking inside a callback. That's not allowed. There are a few ways to handle this. My preference is to launch a Coro thread from within the tcp_server callback. But without Coro, something like this might be what you're looking for:
#!/usr/bin/env perl5.16.2
use AnyEvent;
use AnyEvent::Handle;
use AnyEvent::Socket;
my $cv = AE::cv;
my $host = '127.0.0.1';
my $port = 44244;
my %connections;
tcp_server(
$host, $port, sub {
my ($fh) = #_;
print "Connected...\n";
my $handle;
$handle = AnyEvent::Handle->new(
fh => $fh,
poll => 'r',
on_read => sub {
my ($self) = #_;
print "Received: " . $self->rbuf . "\n";
},
on_eof => sub {
my ($hdl) = #_;
$hdl->destroy();
},
);
$connections{$handle} = $handle; # keep it alive.
return;
});
print "Listening on $host\n";
$cv->recv;
Note that I'm only waiting on one condvar. And I'm storing the handles to keep the AnyEvent::Handle objects alive longer. Work to clean up the $self->rbuf is left as an excersise for the reader :-)
Question cross-posted, answer, too :-)
I have heard good things about AnyEvent as well, but have not used it. I wrote a small nonblocking server in the past using IO::Select. There is an example in the documentation for that module (I've added a few lines):
use IO::Select;
use IO::Socket;
$lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
$sel = new IO::Select( $lsn );
while(#ready = $sel->can_read) {
foreach $fh (#ready) {
if($fh == $lsn) {
# Create a new socket
$new = $lsn->accept;
$sel->add($new);
}
else {
# Process socket
my $input = <$fh>;
print $fh "Hello there. You said: $input\n";
# Maybe we have finished with the socket
$sel->remove($fh);
$fh->close;
}
}
}
I'm not sure what your condvar is trying to trigger there. Use it to send state, like:
#!/usr/bin/env perl
use AnyEvent;
use AnyEvent::Handle;
use AnyEvent::Socket;
my $host = '127.0.0.1';
my $port = 44244;
my $exit = AnyEvent->condvar;
tcp_server($host, $port, sub {
my($fh) = #_;
my $handle; $handle = AnyEvent::Handle->new(
fh => $fh,
poll => "r",
on_read => sub {
my($self) = #_;
print "Received: " . $self->rbuf . "\n";
if ($self->rbuf eq 'exit') {
$exit->send;
}
}
);
});
print "Listening on $host\n";
$exit->recv;