Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

Return Values from IPC::Run

by tcf03 (Deacon)
on May 03, 2006 at 19:53 UTC ( #547251=perlquestion: print w/replies, xml ) Need Help??
tcf03 has asked for the wisdom of the Perl Monks concerning the following question:

I have the following code snippet:
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 ) ? "succe +ss" : "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" : "u +nsuccessful" ; 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 = <stdin>; 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-Se +rver.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-Se +rver.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-Se +rver.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 = success
Any 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

Replies are listed 'Best First'.
Re: Return Values from IPC::Run
by and (Pilgrim) on May 04, 2006 at 06:43 UTC
    You are setting $exit to be the opposite of what 'run' returns. You want
    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 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
by socketdave (Curate) on May 03, 2006 at 20:28 UTC
    This gives me a 0 exit code on v5.8.2 built for i686-linux. What version of Perl and platform are you on?
      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
Re: Return Values from IPC::Run
by spiritway (Vicar) on May 04, 2006 at 04:30 UTC

    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
by spiritway (Vicar) on May 04, 2006 at 16:33 UTC

    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.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://547251]
Approved by NetWallah
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others scrutinizing the Monastery: (7)
As of 2019-02-19 17:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    I use postfix dereferencing ...









    Results (105 votes). Check out past polls.

    Notices?
    • (Sep 10, 2018 at 22:53 UTC) Welcome new users!