Return Values from IPC::Run
I have the following code snippet:
update OK the previous code works fine when run as a stand alone script, If I run it in the original script I get very different results...
the test script:
The Server script:
The client script
The problem is that in the test script everything executes as I would expect it to. When I run the server code using the code from my test - I get the following output at the server console
Im not seeing how $exit is initialized in the test code, but not in the server code.
Below is the output from the test code
use warnings;
use strict;
use IPC::Run qw( run timeout );
my @command = ('ls', '-la');
#print "cmd = @command\n";
my ( $buff );
my $exit = '0';
run \@command, \$buff, timeout(10) or $exit = 1;
print "exit code = $exit\n";
And the exit code is always 1 - the command runs OK yet I cannot seem to get a valid return value. If I use '$?' to grab the return I get back '-1'. Any ideas?
update OK the previous code works fine when run as a stand alone script, If I run it in the original script I get very different results...
the test script:
#!/usr/bin/perl
use warnings;
use strict;
use IPC::Run qw( run timeout );
my $return = ( suba("XYZ") == 0 ) ? "success" : "failure";
print "return = $return\n";
sub suba
{
my $job = shift;
if ( $job =~ /^XYZ/ )
{
my @return = subb();
my $exit = shift @return;
print "exit = $exit\n";
print "$_\n" for @return;
}
}
sub subb
{
my @command = ('ls', '-la');
my ( $buff, $in, $err );
my $exit;
run \@command, \$in, \$buff, \$err, timeout(10) and $exit = $?;
print "exit = $exit\n";
my @return;
push (@return, $exit, $buff);
print "$_\n" for @return;
return @return;
}
The Server script:
#!/usr/bin/perl
#$Id: Meru-Server.pl,v 1.2 2006/05/03 13:26:33 tfiedler Exp $
use strict;
use warnings;
use IPC::Run qw( run timeout );
use IO::Socket::INET;
use Crypt::CBC;
use Carp;
my $cipher = Crypt::CBC->new( -key => 'S3cr#tabcDeSal35', -cipher => 'Blowfish' );
my $port = 62750;
my $LOG;
$SIG{CHLD} = 'IGNORE';
$SIG{INT} = 'IGNORE';
my $listener = IO::Socket::INET->new(LocalPort => $port,
Listen => 10,
Proto => 'tcp',
Reuse => 1);
confess "Error creating a listener on port 62570: $@\n"
unless $listener;
open $LOG, "+>>", "Log.txt" or
carp "Unable to open Log.txt: $@\n";
print "[Listening on port $port]\n";
while ( my $connection = $listener->accept)
{
my $child;
confess "Cannot fork a process: $!\n"
unless defined ( $child = fork() );
if ( $child == 0 )
{
$listener->close;
$connection->print("\n");
$connection->print("connected\n");
my $receive;
if ( defined( $connection->recv($receive, 100,0) ) )
{
chomp($receive);
my $command = $cipher->decrypt($receive);
print "processing \"$receive\" => \"$command\"\n";
print $LOG scalar(localtime), " $$ received: $receive\n";
print $LOG scalar(localtime), " $$ decrypted: $command\n";
$connection->print("your command was received\n");
my $return = ( execute_command("$command") == 0 ) ? "success" : "failure";
print $LOG scalar(localtime), " $$ \"$command\" $return\n";
$connection->print("Your command ended in $return\n");
$connection->print("Goodbye\n");
$connection->print("1970__");
}
}
else
{
print $LOG scalar(localtime), " $$ Connect from ", $connection->peerhost, "\n";
print "Connection from ", $connection->peerhost, "\n";
$connection->close();
}
}
sub execute_command
{
my $line = shift;
my @info = ( grep /\|/, $line ) ? split /\|/, $line : $line;
#my @info = split /\|/, $line || $line;
my $job = $info[0];
print $LOG scalar(localtime), " $$ job = $job info = @info\n";
my $return = 2;
print "job = $job\n";
$return = ( ListKillProc(@info) == 0 ) ? 0 : 1
if ( $job =~ /^ListKillProc/ );
$return = ( unlockuser(@info) == 0 ) ? 0 : 1
if ( $job =~ /^unlockuser/ );
$return = ( changepass(@info) == 0 ) ? 0 : 1
if ( $job =~ /^changepass/ );
$return = ( showprintersall(@info) == 0 ) ? 0 : 1
if ( $job =~ /^showprintersall/ );
$return = ( showprintersuser(@info) == 0 ) ? 0 : 1
if ( $job =~ /^showprintersuser/ );
$return = ( showprinter(@info) == 0 ) ? 0 : 1
if ( $job =~ /^showprinter/ );
$return = ( killprint(@info) == 0 ) ? 0 : 1
if ( $job =~ /^killprint/ );
print "return before = $return\n";
if ( $job =~ /^APP/ )
{
my @return = APP();
my $exit = shift @return;
print "exit = $exit\n";
print @return;
return $exit;
}
print $LOG scalar(localtime), " $$ execution return code = $return\n";
return $return;
}
sub APP
{
my @command = ('ls', '-la');
print $LOG scalar(localtime), " $$ cmd = @command\n";
my ( $buff, $in, $err );
my $exit;
run \@command, \$in, \$buff, \$err, timeout(10) and $exit = $?;
print "exit = $exit\n";
print $LOG scalar(localtime), " $$ exit code =", $exit, "\n";
#print $out if $out;
my @return;
push (@return, $exit, $buff);
print "$_\n" for @return;
return @return;
}
sub AUTOLOAD
{
print "I dont know how to do $_[0]\n";
print $LOG scalar(localtime), " $$ Uh Oh we hit the Autoloader: no match for $_[0]\n";
return 1;
}
The client script
#!/usr/bin/perl
#$Id: menu.pl,v 1.3 2006/05/03 13:27:47 tfiedler Exp $
use strict;
use warnings;
use IO::Socket::INET;
use Crypt::CBC;
my $cipher = Crypt::CBC->new( -key => 'S3cr#tabcDeSal35', -cipher => 'Blowfish');
$SIG{INT} = 'IGNORE';
sub do_menu
{
my( $menu ) = @_;
while(1)
{
my( $menu ) = @_;
# display the menu
print "\n";
print $_+1, '. ', $menu->[$_]{'label'}, "\n"
for 0 .. $#{$menu};
print '0. ', ( @_ > 1 ? 'Return' : 'Exit' ), "\n";
# get the user's input
local @ARGV;
print STDERR '> ';
local $_ = <>; chomp;
/\d/ && !/\D/ or next;
$_ == 0 and last; # item 0 is special
defined $menu->[$_-1] or warn("Invalid choice\n"), next;
my $op = $menu->[$_-1]{'op'};
my $arg = $menu->[$_-1]{'arg'};
if ( $op eq 'submenu' )
{
do_menu( $arg, @_ ); # maintain the stack!
}
elsif ( $op eq 'exec_cmd' )
{
execute_command( $arg );
}
else
{
warn "Unrecognized op '$op'\n";
}
}
}
my @printers_menu = (
{
label => 'Show all Printers',
op => 'exec_cmd',
arg => 'showprintersall',
},
{
label => 'Show user print jobs',
op => 'exec_cmd',
arg => 'showprintersuser',
},
{
label => 'Show single printer',
op => 'exec_cmd',
arg => 'showprinter',
},
{
label => 'Kill a print job',
op => 'exec_cmd',
arg => 'killprint',
},
);
my @accounts_menu = (
{
label => 'Unlock user account',
op => 'exec_cmd',
arg => 'unlockuser',
},
{
label => 'Change account password',
op => 'exec_cmd',
arg => 'changepass',
},
);
my @main_menu = (
{
label => 'List and Kill UDT* processes by user',
op => 'exec_cmd',
arg => 'ListKillProc',
},
{
label => 'List and Kill Print Jobs...',
op => 'submenu',
arg => \@printers_menu,
},
{
label => 'Manage user accounts...',
op => 'submenu',
arg => \@accounts_menu,
},
{
label => 'Run App',
op => 'exec_cmd',
arg => 'APP',
},
);
sub execute_command
{
warn "Executing command @_\n";
my $command = $_[0];
my @stack = &build_stack($command);
my $STACK = join'|', @stack;
my $cryptostack = $cipher->encrypt($STACK);
if ($STACK =~ /^\d/)
{
print "Houston we have a problem... STACK = $STACK\n";
return 1;
}
my $return = ( send_stack($cryptostack) == 0 ) ? "successful" : "unsuccessful" ;
print "transmission of data was $return\n";
}
sub build_stack
{
my $command = @_;
my @needed = ();
my $set = \&set_item;
my ( $username, $password, $password2, $jobid, $printer );
push (@needed, @_);
return @needed
if grep ( /^(APP|showprintersall)/, @_ );
if ( grep /^(showprintersuser|unlockuser|ListKillProc|changepass)/, @_ )
{
$username = $set->('username');
push (@needed, $username);
}
if ( grep /^changepass/, @_ )
{
$password = $set->('password');
$password2 = $set->('password2');
return 0 if ( $password ne $password2 );
push (@needed, $password);
}
if ( grep /^showprinter/, @_ )
{
$printer = $set->('printer');
push (@needed, $printer);
}
if ( grep /^killprint/, @_ )
{
$jobid = $set->('jobid');
push (@needed, $jobid);
}
return @needed;
}
sub set_item
{
print "Enter @_: ";
my $item = ;
chomp($item);
return $item;
}
sub send_stack
{
my $send = shift;
my $host = shift || "localhost";
my $port = shift || 62750;
my $sock = IO::Socket::INET ->new(
PeerAddr => $host,
PeerPort => $port,
Proto => 'tcp' );
$sock->print($send);
my $rtrn = 1;
while (my $receive = <$sock>)
{
if ($receive =~ /^1970__/)
{
$rtrn = 0;
last;
}
chomp($receive);
print "$receive\n";
}
return $rtrn;
}
sub AUTOLOAD
{
print "Sorry, I dont know how to do @_";
return 1;
}
do_menu( \@main_menu );
The problem is that in the test script everything executes as I would expect it to. When I run the server code using the code from my test - I get the following output at the server console
[Listening on port 62750] processing "Salted__ ##&o#uw##" => "APP" job = APP return before = 2 Connection from 127.0.0.1 Use of uninitialized value in concatenation (.) or string at ./Menu-Server.pl line 136. exit = Use of uninitialized value in print at ./Menu-Server.pl line 137. Use of uninitialized value in concatenation (.) or string at ./Menu-Server.pl line 144. total 10976 drwxr-x--- 4 tfiedler tfiedler 4096 May 4 09:42 . drwxr-x--- 4 tfiedler tfiedler 4096 Apr 27 14:53 .. -rw-r----- 1 tfiedler tfiedler 11115686 May 3 10:02 cbkwanzaa.wmv -rwxr-x--- 1 tfiedler tfiedler 2659 May 1 16:29 client-test.pl -rwxr-x--- 1 tfiedler tfiedler 659 May 4 09:05 ipcruntest.pl -rw-r----- 1 tfiedler tfiedler 364 May 3 13:31 ipctest.pl -rw-r----- 1 tfiedler tfiedler 31945 May 4 09:43 Log.txt -rw-r----- 1 tfiedler tfiedler 16384 May 4 09:29 .Log.txt.swp -rwxr-x--- 1 tfiedler tfiedler 3982 May 3 13:12 menu.pl -rwxr-x--- 1 tfiedler tfiedler 3993 May 4 09:41 Menu-Server.pl drwxr-x--- 2 tfiedler tfiedler 4096 May 1 08:09 ms1help -rw-r----- 1 tfiedler tfiedler 14544 Apr 27 14:51 perlscript.zip drwxr-x--- 2 tfiedler tfiedler 4096 May 3 09:28 RCS -rwxr-x--- 1 tfiedler tfiedler 1775 May 2 13:56 server-test.pl Use of uninitialized value in concatenation (.) or string at ./Menu-Server.pl line 116. exit = total 10976 drwxr-x--- 4 tfiedler tfiedler 4096 May 4 09:42 . drwxr-x--- 4 tfiedler tfiedler 4096 Apr 27 14:53 .. -rw-r----- 1 tfiedler tfiedler 11115686 May 3 10:02 cbkwanzaa.wmv -rwxr-x--- 1 tfiedler tfiedler 2659 May 1 16:29 client-test.pl -rwxr-x--- 1 tfiedler tfiedler 659 May 4 09:05 ipcruntest.pl -rw-r----- 1 tfiedler tfiedler 364 May 3 13:31 ipctest.pl -rw-r----- 1 tfiedler tfiedler 31945 May 4 09:43 Log.txt -rw-r----- 1 tfiedler tfiedler 16384 May 4 09:29 .Log.txt.swp -rwxr-x--- 1 tfiedler tfiedler 3982 May 3 13:12 menu.pl -rwxr-x--- 1 tfiedler tfiedler 3993 May 4 09:41 Menu-Server.pl drwxr-x--- 2 tfiedler tfiedler 4096 May 1 08:09 ms1help -rw-r----- 1 tfiedler tfiedler 14544 Apr 27 14:51 perlscript.zip drwxr-x--- 2 tfiedler tfiedler 4096 May 3 09:28 RCS -rwxr-x--- 1 tfiedler tfiedler 1775 May 2 13:56 server-test.pl Use of uninitialized value in numeric eq (==) at ./Menu-Server.pl line 57.
Im not seeing how $exit is initialized in the test code, but not in the server code.
Below is the output from the test code
exit = 0 0 total 10976 drwxr-x--- 4 tfiedler tfiedler 4096 May 4 09:45 . drwxr-x--- 4 tfiedler tfiedler 4096 Apr 27 14:53 .. -rw-r----- 1 tfiedler tfiedler 0 May 4 09:47 1 -rw-r----- 1 tfiedler tfiedler 11115686 May 3 10:02 cbkwanzaa.wmv -rwxr-x--- 1 tfiedler tfiedler 2659 May 1 16:29 client-test.pl -rwxr-x--- 1 tfiedler tfiedler 659 May 4 09:05 ipcruntest.pl -rw-r----- 1 tfiedler tfiedler 364 May 3 13:31 ipctest.pl -rw-r----- 1 tfiedler tfiedler 32031 May 4 09:43 Log.txt -rw-r----- 1 tfiedler tfiedler 16384 May 4 09:29 .Log.txt.swp -rwxr-x--- 1 tfiedler tfiedler 3982 May 3 13:12 menu.pl -rwxr-x--- 1 tfiedler tfiedler 3993 May 4 09:41 Menu-Server.pl drwxr-x--- 2 tfiedler tfiedler 4096 May 1 08:09 ms1help -rw-r----- 1 tfiedler tfiedler 14544 Apr 27 14:51 perlscript.zip drwxr-x--- 2 tfiedler tfiedler 4096 May 3 09:28 RCS -rwxr-x--- 1 tfiedler tfiedler 1775 May 2 13:56 server-test.pl exit = 0 total 10976 drwxr-x--- 4 tfiedler tfiedler 4096 May 4 09:45 . drwxr-x--- 4 tfiedler tfiedler 4096 Apr 27 14:53 .. -rw-r----- 1 tfiedler tfiedler 0 May 4 09:47 1 -rw-r----- 1 tfiedler tfiedler 11115686 May 3 10:02 cbkwanzaa.wmv -rwxr-x--- 1 tfiedler tfiedler 2659 May 1 16:29 client-test.pl -rwxr-x--- 1 tfiedler tfiedler 659 May 4 09:05 ipcruntest.pl -rw-r----- 1 tfiedler tfiedler 364 May 3 13:31 ipctest.pl -rw-r----- 1 tfiedler tfiedler 32031 May 4 09:43 Log.txt -rw-r----- 1 tfiedler tfiedler 16384 May 4 09:29 .Log.txt.swp -rwxr-x--- 1 tfiedler tfiedler 3982 May 3 13:12 menu.pl -rwxr-x--- 1 tfiedler tfiedler 3993 May 4 09:41 Menu-Server.pl drwxr-x--- 2 tfiedler tfiedler 4096 May 1 08:09 ms1help -rw-r----- 1 tfiedler tfiedler 14544 Apr 27 14:51 perlscript.zip drwxr-x--- 2 tfiedler tfiedler 4096 May 3 09:28 RCS -rwxr-x--- 1 tfiedler tfiedler 1775 May 2 13:56 server-test.pl return = successAny help is appreciated - sorry for such a long post, but I am unable to reproduce the results in a test.
Ted
--
"That which we persist in doing becomes easier, not that the task itself has become easier, but that our ability to perform it has improved."
--Ralph Waldo Emerson
--
"That which we persist in doing becomes easier, not that the task itself has become easier, but that our ability to perform it has improved."
--Ralph Waldo Emerson
Re: Return Values from IPC::Run
created: 2006-05-03 16:28:53
This gives me a 0 exit code on v5.8.2 built for i686-linux. What version of Perl and platform are you on?
Re^2: Return Values from IPC::Run
created: 2006-05-04 10:14:20
Perl 5.8.8 for i386-Linux and Fedora Core5.
Ted
--
"That which we persist in doing becomes easier, not that the task itself has become easier, but that our ability to perform it has improved."
--Ralph Waldo Emerson
--
"That which we persist in doing becomes easier, not that the task itself has become easier, but that our ability to perform it has improved."
--Ralph Waldo Emerson
Re: Return Values from IPC::Run
created: 2006-05-04 00:30:42
I'm using ActivePerl 5.8, build 813; I get a return value of zero. I don't see any reason why you should be getting 1 or -1.
Re: Return Values from IPC::Run
created: 2006-05-04 02:43:02
You are setting $exit to be the opposite of what 'run' returns. You want
Update: Checking the [module://IPC::Run|documentation], I couldn't find any direct mention of what run() returns but it was certainly used as if "true means success" and looking at the source, it appears to return the equivalent of ! $?. So my instinct and advice was wrong. Sorry. It just fit the problem statement so well. Drat. But your claim of what $? returned contradicts this so maybe you've got some version that I'd have to dig out of backpan and I'm actually right after all. ;->
run ... and $exit = 1;just like you should write
system( ... ) and die ...these being a couple of the rare Perl functions that return 0, a false value, to indicate "no failure" instead of the much more usual "true means success" scheme.
Update: Checking the [module://IPC::Run|documentation], I couldn't find any direct mention of what run() returns but it was certainly used as if "true means success" and looking at the source, it appears to return the equivalent of ! $?. So my instinct and advice was wrong. Sorry. It just fit the problem statement so well. Drat. But your claim of what $? returned contradicts this so maybe you've got some version that I'd have to dig out of backpan and I'm actually right after all. ;->
Re: Return Values from IPC::Run
created: 2006-05-04 12:33:17
I think you'll need to simplify this considerably, before someone (including you) will be able to unravel it. What I would suggest is that you begin by removing calls to subs. If you're relying on values to be set by those subs, simply assign them. As you do this, you may at some point notice that the mysterious exit code changes to zero, which would give you an idea of where your problem lies. For this reason, I would make the changes piecemeal, not all at once.
Also, you might try sprinking "reality checks" throughout your code, warn or print statements that show the values of variables at various points. Often you may find some variable contains the wrong value, which can then screw up subsequent code. It might be helpful to log these to a file so you can examine them at your leisure.