On Wed, 25 Apr 2001, Jeff Shanholtz wrote:
> I want to run a command and pipe its output to my perl script (`command`
> won't work because the command takes a long time and produces tons of
> output). However, I really need to know the exit code when it's done
> (ala system()/256). Is it possible? I'm not finding much help in the
> documentation. Can this be done?
Here's something I extracted from one of my production programs.
I had to rewrite it a little to get rid of the application specifics,
and it has had minimal testing.
Make sure you pass in the complete path in command_path arg for
the argument you want to execute.
For example this works:
c:/perl/bin/perl.exe
This will not work:
c:/perl/bin/perl
I'm on Win2k so if your on a win9x machine, you might have to
play with the path separators.
Be warned! Things like this can hang. I have not had this happen
with the programs I run with this, but...
Hope this helps.
###################Clip Here###################################
#!/perl/bin/perl
package run_process;
use strict;
use Win32::Process;
use IO::Handle;
use constant RP_OPTIONAL_ARG => 1;
use constant RP_REQUIRED_ARG => 2;
use Class::MethodMaker
new => [ qw /new/ ],
get_set => [ qw /
command_path
command_args
run_dir
perlinecallback
/ ],
list => [ qw /errors/];
sub perLineCheck {
my ( $self ) = @_;
my $callback = $self->perlinecallback( );
if ( $callback ) {
&$callback( @_ )
} else {
return 0;
}
}
sub check_params {
my ($self, $valid_params, $params) = @_;
my $param;
my $val;
my $error_in = 0;
# If parameters passed in are valid set object attribute to value.
while (($param, $val) = each %$params) {
if ( $$valid_params{$param} ) {
$self->$param($val);
} else {
$self->push_errors("invalid parameter:" . $param . " =
" . $val);
$error_in = 1;
}
}
# Check that required args are present.
while (($param, $val) = each %$valid_params) {
if( ! $self->$param() && $val eq RP_REQUIRED_ARG ) {
$self->error_errors("required parameter: " . $param . " is not
set");
$error_in = 1;
}
}
return $error_in;
}
sub run_command {
# (command_path=>"command_path",command_args=>"command_args",$run_dir)
my ($self, %args) = @_;
my $ProcessObj;
my $error_in = 0;
my $ExitCode = 0;
my $lineback;
my %valid_params = (
command_path => RP_REQUIRED_ARG,
command_args => RP_REQUIRED_ARG,
run_dir => RP_OPTIONAL_ARG,
);
$self->clear_command_path;
$self->clear_command_args;
$self->run_dir("."); # Set the default directory to run in.
# Check if args passed in are valid.
$error_in = $self->check_params(\%valid_params, \%args );
# Return if there are any errors in the input args.
return 1 if ( $error_in );
if ( -d $self->run_dir() ) {
chdir $self->run_dir();
} else {
$self->push_errors("Directory to run in does not exist, nothing
done.");
return 1;
}
#create a pipe in order to read the new process's stdout back
pipe(PIPE_OUT_READ,PIPE_OUT_WRITE) || die "failed to create pipe";
PIPE_OUT_WRITE->autoflush(1);
#asign the pipe's write end to stdout
open(PREV_STDOUT,">&STDOUT") || die "failed to save stdout";
close(STDOUT) || die "failed to close dupped stdout";
open(STDOUT,">&PIPE_OUT_WRITE") || die "failed to reasign stdout";
close(PIPE_OUT_WRITE) || die "failed to pipe write after use";
$ExitCode = Win32::Process::Create($ProcessObj,
$self->command_path(),
$self->command_path() . " " . $self->command_args(),
1,
NORMAL_PRIORITY_CLASS,
$self->run_dir()
);
#after child started (or not), restore the stdout
open(STDOUT,">&PREV_STDOUT") || die "failed to restore stdout";
close(PREV_STDOUT) || die "failed to close the dupped stdout";
if ( $ExitCode == 0 ) {
$self->push_errors("Could not start process.");
return 1
}
do {
$lineback = <PIPE_OUT_READ>;
if ( $self->perLineCheck($lineback) ) {
$self->push_errors("User selected Cancel, Aborting command");
$ProcessObj->Kill( 999 );
return 1;
}
$ProcessObj->GetExitCode( $ExitCode );
} while($ExitCode == 259);
if ( ! PIPE_OUT_READ->close ) {
push_errors("failed to close pipe read after use");
return 1;
}
return $ExitCode;
}
1;
###################Clip Here###################################
Here is a test program test_rp.pl
###################Clip Here###################################
use strict;
use run_process;
sub Main {
my $run_dir = "c:/";
my $command_path = 'c:/perl/bin/perl.exe';
my $command_args = '-V';
my $status;
my @errors;
my $rp = run_process->new();
$rp->perlinecallback(sub {CheckLine(@_)});
$status = $rp->run_command(
"command_path" => $command_path,
"command_args" => $command_args,
"run_dir" => $run_dir,
);
print "status: " . $status . "\n";
if ( $status ) {
@errors = $rp->errors;
foreach my $e ( @errors ) {
print $e . "\n";
}
}
}
sub CheckLine {
my ($zipobj,$lineback) = @_;
if ( $lineback ) {
chomp $lineback;
print "lineback: " . $lineback . "\n";
}
return 0;
}
Main();
###################Clip Here###################################
Eloy
~=====================================================================~
~[ Eloy A. Gonzales Voice: (505) 844-1063 ]~
~[ Sandia National Laboratories Fax: (505) 844-7059 ]~
~[ Org 05743 MS 0965 email: [EMAIL PROTECTED] ]~
~[ Albuquerque, New Mexico 87185-0965 pager: (505) 540-5700 ]~
~=====================================================================~
_______________________________________________
Perl-Win32-Users mailing list
[EMAIL PROTECTED]
http://listserv.ActiveState.com/mailman/listinfo/perl-win32-users
