view release on metacpan or  search on metacpan

lib/App/Framework/Lite.pm  view on Meta::CPAN

#--------------------------------------------------------------------------------------------
#
# Ensure arguments are correct
#
sub _check_run_args
{
	my $this = shift ;
	my ($args) = @_ ;
	
	# If there is no redirection, just add redirect 2>1
	if (!$args || ($args !~ /\>/) )
	{
		$args .= " 2>&1" ;
	}
	
	return $args ;
}


#----------------------------------------------------------------------
# Run command with no timeout
#
sub _run_cmd
{
	my $this = shift ;
	my ($cmd, $args, $progress, $check_results) = @_ ;

$this->_dbg_prt(["_run_cmd($cmd) args=$args\n"]) ;
	
	my @results ;
	@results = `$cmd $args` ;
	my $rc = $? ;

	foreach (@results)
	{
		chomp $_ ;
	}

	# if it's defined, call the progress checker for each line
	if (defined($progress))
	{
		my $linenum = 0 ;
		my $state_href = {} ;
		foreach (@results)
		{
			&$progress($_, ++$linenum, $state_href) ;
		}
	}

	
	# if it's defined, call the results checker for each line
	$rc ||= $this->_check_results(\@results, $check_results) ;

	return ($rc, @results) ;
}

#----------------------------------------------------------------------
#Execute a command in the background, gather output, return status.
#If timeout is specified (in seconds), process is killed after the timeout period.
#
sub _run_timeout
{
	my $this = shift ;
	my ($cmd, $args, $timeout, $progress, $check_results) = @_ ;

$this->_dbg_prt(["_run_timeout($cmd) timeout=$timeout args=$args\n"]) ;

	## Timesout must be set
	$timeout ||= 60 ;

	# Run command and save results
	my @results ;

	# Run command but time it and kill it when timed out
	local $SIG{ALRM} = sub { 
		# normal execution
		die "timeout\n" ;
	};

	# if it's defined, call the progress checker for each line
	my $state_href = {} ;
	my $linenum = 0 ;

	# Run inside eval to catch timeout		
	my $pid ;
	my $rc = 0 ;
	my $endtime = (time + $timeout) ;
	eval 
	{
		alarm($timeout);
		$pid = open my $proc, "$cmd $args |" or $this->throw_fatal("Unable to fork $cmd : $!") ;

		while(<$proc>)
		{
			chomp $_ ;
			push @results, $_ ;

			++$linenum ;

			# if it's defined, call the progress checker for each line
			if (defined($progress))
			{
				&$progress($_, $linenum, $state_href) ;
			}

			# if it's defined, check timeout
			if (time > $endtime)
			{
				$endtime=0;
				last ;
			}
		}
		alarm(0) ;
		$rc = $? ;
print "end of program : rc=$rc\n" if $this->{'debug'} ;  
	};
	if ($@)
	{