URL
https://opencores.org/ocsvn/an-fpga-implementation-of-low-latency-noc-based-mpsoc/an-fpga-implementation-of-low-latency-noc-based-mpsoc/trunk
Subversion Repositories an-fpga-implementation-of-low-latency-noc-based-mpsoc
[/] [an-fpga-implementation-of-low-latency-noc-based-mpsoc/] [trunk/] [mpsoc/] [Integration_test/] [synthetic_sim/] [perl_lib/] [Proc/] [Background.pm] - Rev 56
Compare with Previous | Blame | View Log
package Proc::Background; $Proc::Background::VERSION = '1.30'; # ABSTRACT: Generic interface to Unix and Win32 background process management require 5.004_04; use strict; use Exporter; use Carp; use Cwd; use Scalar::Util; @Proc::Background::ISA = qw(Exporter); @Proc::Background::EXPORT_OK = qw(timeout_system); # Determine if the operating system is Windows. my $is_windows = $^O eq 'MSWin32'; my $weaken_subref = Scalar::Util->can('weaken'); # Set up a regular expression that tests if the path is absolute and # if it has a directory separator in it. Also create a list of file # extensions of append to the programs name to look for the real # executable. my $is_absolute_re; my $has_dir_element_re; my $path_sep; my @extensions = (''); if ($is_windows) { $is_absolute_re = '^(?:(?:[a-zA-Z]:[\\\\/])|(?:[\\\\/]{2}\w+[\\\\/]))'; $has_dir_element_re = "[\\\\/]"; $path_sep = "\\"; push(@extensions, '.exe'); } else { $is_absolute_re = "^/"; $has_dir_element_re = "/"; $path_sep = "/"; } # Make this class a subclass of Proc::Win32 or Proc::Unix. Any # unresolved method calls will go to either of these classes. if ($is_windows) { require Proc::Background::Win32; unshift(@Proc::Background::ISA, 'Proc::Background::Win32'); } else { require Proc::Background::Unix; unshift(@Proc::Background::ISA, 'Proc::Background::Unix'); } # Take either a relative or absolute path to a command and make it an # absolute path. sub _resolve_path { my $command = shift; return ( undef, 'empty command string' ) unless length $command; # Make the path to the progam absolute if it isn't already. If the # path is not absolute and if the path contains a directory element # separator, then only prepend the current working to it. If the # path is not absolute, then look through the PATH environment to # find the executable. In all cases, look for the programs with any # extensions added to the original path name. my $path; if ($command =~ /$is_absolute_re/o) { foreach my $ext (@extensions) { my $p = "$command$ext"; if (-f $p and -x _) { $path = $p; last; } } return defined $path? ( $path, undef ) : ( undef, "no executable program located at $command" ); } else { my $cwd = cwd; if ($command =~ /$has_dir_element_re/o) { my $p1 = "$cwd$path_sep$command"; foreach my $ext (@extensions) { my $p2 = "$p1$ext"; if (-f $p2 and -x _) { $path = $p2; last; } } } else { foreach my $dir (split($is_windows ? ';' : ':', $ENV{PATH})) { next unless length $dir; $dir = "$cwd$path_sep$dir" unless $dir =~ /$is_absolute_re/o; my $p1 = "$dir$path_sep$command"; foreach my $ext (@extensions) { my $p2 = "$p1$ext"; if (-f $p2 and -x _) { $path = $p2; last; } } last if defined $path; } } return defined $path? ( $path, undef ) : ( undef, "cannot find absolute location of $command" ); } } # Define the set of allowed options, to warn about unknown ones. # Make it a method so subclasses can override it. %Proc::Background::_available_options= ( autodie => 1, command => 1, exe => 1, cwd => 1, stdin => 1, stdout => 1, stderr => 1, autoterminate => 1, die_upon_destroy => 1, ); sub _available_options { return \%Proc::Background::_available_options; } # We want the created object to live in Proc::Background instead of # the OS specific class so that generic method calls can be used. sub new { my $class = shift; # The parameters are an optional %options hashref followed by any number # of arguments to become the @argv for exec(). If options are given, check # the keys for typos. my $options; if (@_ and ref $_[0] eq 'HASH') { $options= shift; my $known= $class->_available_options; my @unknown= grep !$known->{$_}, keys %$options; carp "Unknown options: ".join(', ', @unknown) if @unknown; } else { $options= {}; } my $self= bless {}, $class; $self->{_autodie}= 1 if $options->{autodie}; # Resolve any confusion between the 'command' option and positional @argv params. # Store the command in $self->{_command} so that the ::Unix and ::Win32 don't have # to deal with it redundantly. my $cmd= $options->{command}; if (defined $cmd) { croak "Can't use both 'command' option and command argument list" if @_; # Can be an arrayref or a single string croak "command must be a non-empty string or an arrayref of strings" unless (ref $cmd eq 'ARRAY' && defined $cmd->[0] && length $cmd->[0]) or (!ref $cmd && defined $cmd && length $cmd); } else { # Back-compat: maintain original API quirks confess "Proc::Background::new called with insufficient number of arguments" unless @_; return $self->_fatal('command is undefined') unless defined $_[0]; # Interpret the parameters as an @argv if there is more than one, # or if the 'exe' option was given. $cmd= (@_ > 1 || defined $options->{exe})? [ @_ ] : $_[0]; } $self->{_command}= $cmd; $self->{_exe}= $options->{exe} if defined $options->{exe}; # Also back-compat: failing to fork or CreateProcess returns undef return unless $self->_start($options); # Save the start time $self->{_start_time} = time; if ($options->{autoterminate} || $options->{die_upon_destroy}) { $self->autoterminate(1); } return $self; } # The original API returns undef from the constructor in case of various errors. # The autodie option converts these undefs into exceptions. sub _fatal { my ($self, $message)= @_; croak $message if $self->{_autodie}; warn "$0: $message"; return undef; } sub autoterminate { my ($self, $newval)= @_; if (@_ > 1 and ($newval xor $self->{_die_upon_destroy})) { if ($newval) { # Global destruction can break this feature, because there are no guarantees # on which order object destructors are called. In order to avoid that, need # to run all the ->die methods during END{}, and that requires weak # references which weren't available until 5.8 $weaken_subref->( $Proc::Background::_die_upon_destroy{$self+0}= $self ) if $weaken_subref; # could warn about it for earlier perl... but has been broken for 15 years and # who is still using < 5.8 anyway? } else { delete $Proc::Background::_die_upon_destroy{$self+0}; } $self->{_die_upon_destroy}= $newval? 1 : 0; } $self->{_die_upon_destroy} || 0 } sub DESTROY { my $self = shift; if ($self->{_die_upon_destroy}) { # During a mainline exit() $? is the prospective exit code from the # parent program. Preserve it across any waitpid() in die() local $?; $self->terminate; delete $Proc::Background::_die_upon_destroy{$self+0}; } } END { # Child processes need killed before global destruction, else the # Win32::Process objects might get destroyed first. for (grep defined, values %Proc::Background::_die_upon_destroy) { $_->terminate; delete $_->{_die_upon_destroy} } %Proc::Background::_die_upon_destroy= (); } # Reap the child. If the first argument is false, then return immediately. # Else, block waiting for the process to exit. If no second argument is # given, wait forever, else wait for that number of seconds. # If the wait was sucessful, then delete # $self->{_os_obj} and set $self->{_exit_value} to the OS specific # class return of _reap. Return 1 if we sucessfully waited, 0 # otherwise. sub _reap { my ($self, $blocking, $wait_seconds) = @_; return 0 unless exists($self->{_os_obj}); # Try to wait on the process. Use the OS dependent wait call using # the Proc::Background::*::waitpid call, which returns one of three # values. # (0, exit_value) : sucessfully waited on. # (1, undef) : process already reaped and exit value lost. # (2, undef) : process still running. my ($result, $exit_value) = $self->_waitpid($blocking, $wait_seconds); if ($result == 0 or $result == 1) { $self->{_exit_value} = defined($exit_value) ? $exit_value : 0; delete $self->{_os_obj}; # Save the end time of the class. $self->{_end_time} = time; return 1; } return 0; } sub alive { my $self = shift; # If $self->{_os_obj} is not set, then the process is definitely # not running. return 0 unless exists($self->{_os_obj}); # If $self->{_exit_value} is set, then the process has already finished. return 0 if exists($self->{_exit_value}); # Try to reap the child. If it doesn't reap, then it's alive. !$self->_reap(0); } sub suspended { $_[0]->{_suspended}? 1 : 0 } sub suspend { my $self= shift; return $self->_fatal("can't suspend, process has exited") if !$self->{_os_obj}; $self->{_suspended} = 1 if $self->_suspend; return $self->{_suspended}; } sub resume { my $self= shift; return $self->_fatal("can't resume, process has exited") if !$self->{_os_obj}; $self->{_suspended} = 0 if $self->_resume; return !$self->{_suspended}; } sub wait { my ($self, $timeout_seconds) = @_; # If $self->{_exit_value} exists, then we already waited. return $self->{_exit_value} if exists($self->{_exit_value}); carp "calling ->wait on a suspended process" if $self->{_suspended}; # If neither _os_obj or _exit_value are set, then something is wrong. return undef if !exists($self->{_os_obj}); # Otherwise, wait for the process to finish. return $self->_reap(1, $timeout_seconds)? $self->{_exit_value} : undef; } sub terminate { shift->die(@_) } sub die { my $self = shift; croak "process is already terminated" if $self->{_autodie} && !$self->{_os_obj}; # See if the process has already died. return 1 unless $self->alive; # Kill the process using the OS specific method. $self->_terminate(@_? ([ @_ ]) : ()); # See if the process is still alive. !$self->alive; } sub command { $_[0]->{_command}; } sub exe { $_[0]->{_exe} } sub start_time { $_[0]->{_start_time}; } sub exit_code { return undef unless exists $_[0]->{_exit_value}; return $_[0]->{_exit_value} >> 8; } sub exit_signal { return undef unless exists $_[0]->{_exit_value}; return $_[0]->{_exit_value} & 127; } sub end_time { $_[0]->{_end_time}; } sub pid { $_[0]->{_pid}; } sub timeout_system { unless (@_ > 1) { confess "$0: timeout_system passed too few arguments.\n"; } my $timeout = shift; unless ($timeout =~ /^\d+(?:\.\d*)?$/ or $timeout =~ /^\.\d+$/) { confess "$0: timeout_system passed a non-positive number first argument.\n"; } my $proc = Proc::Background->new(@_) or return; my $end_time = $proc->start_time + $timeout; my $delay= $timeout; while ($delay > 0 && defined $proc->{_os_obj}) { last if defined $proc->wait($delay); # If it times out, it's likely that wait() already waited the entire duration. # But, if it got interrupted, there might be time remaining. # But, if the system clock changes, this could break horribly. Constrain it to a sane value. my $t= time; if ($t < $end_time - $delay) { # time moved backward! $end_time= $t + $delay; } else { $delay= $end_time - $t; } } my $alive = $proc->alive; $proc->terminate if $alive; if (wantarray) { return ($proc->wait, $alive); } else { return $proc->wait; } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Proc::Background - Generic interface to Unix and Win32 background process management =head1 SYNOPSIS use Proc::Background; timeout_system($seconds, $command, $arg1, $arg2); timeout_system($seconds, "$command $arg1 $arg2"); my $proc1 = Proc::Background->new($command, $arg1, $arg2) || die "failed"; my $proc2 = Proc::Background->new("$command $arg1 1>&2") || die "failed"; if ($proc1->alive) { $proc1->terminate; $proc1->wait; } say 'Ran for ' . ($proc1->end_time - $proc1->start_time) . ' seconds'; Proc::Background->new({ autodie => 1, # Throw exceptions instead of returning undef cwd => 'some/path/', # Set working directory for the new process exe => 'busybox', # Specify executable different from argv[0] command => [ $command ] # resolve ambiguity of command line vs. argv[0] }); # Set initial file handles Proc::Background->new({ stdin => undef, # /dev/null or NUL stdout => '/append/to/fname', # will try to open() stderr => $log_fh, # use existing handle command => \@command, }); # Automatically kill the process if the object gets destroyed my $proc4 = Proc::Background->new({ autoterminate => 1 }, $command); $proc4 = undef; # calls ->terminate =head1 DESCRIPTION This is a generic interface for placing processes in the background on both Unix and Win32 platforms. This module lets you start, kill, wait on, retrieve exit values, and see if background processes still exist. =head1 CONSTRUCTOR =over 4 =item B<new> [options] I<command>, [I<arg>, [I<arg>, ...]] =item B<new> [options] 'I<command> [I<arg> [I<arg> ...]]' This creates a new background process. Just like C<system()>, you can supply a single string of the entire command line, or individual arguments. The first argument may be a hashref of named options. To resolve the ambiguity between a command line vs. a single-element argument list, see the C<command> option below. By default, the constructor returns an empty list on failure, except for a few cases of invalid arguments which call C<croak>. For platform-specific details, see L<Proc::Background::Unix/IMPLEMENTATION> or L<Proc::Background::Win32/IMPLEMENTATION>, but in short: =over 7 =item Unix This implementation uses C<fork>/C<exec>. If you supply a single-string command line, it is passed to the shell. If you supply multiple arguments, they are passed to C<exec>. In the multi-argument case, it will also check that the executable exists before calling C<fork>. =item Win32 This implementation uses the L<Windows CreateProcess API|Win32::Process/METHODS>. If you supply a single-string command line, it derives the executable by parsing the command line and looking for the first element in the C<PATH>, appending C<".exe"> if needed. If you supply multiple arguments, the first is used as the C<exe> and the command line is built using L<Win32::ShellQuote>. =back B<Options:> =over =item C<autodie> This module traditionally has returned C<undef> if the child could not be started. Modern Perl recommends the use of exceptions for things like this. This option, like Perl's L<autodie> pragma, causes all fatal errors in starting the process to die with exceptions instead of returning undef. =item C<command> You may specify the command as an option instead of passing the command as a list. A string value is considered a command line, and an arrayref value is considered an argument list. This can resolve the ambiguity between a command line vs. single-element argument list. =item C<exe> Specify the executable. This can serve two purposes: on Win32 it avoids the parsing of the commandline, and on Unix it can be used to run an executable while passing a different value for C<$ARGV[0]>. =item C<stdin>, C<stdout>, C<stderr> Specify one or more overrides for the standard handles of the child. The value should be a Perl filehandle with an underlying system C<fileno> value. As a convenience, you can pass C<undef> to open the C<NUL> device on Win32 or C</dev/null> on Unix. You may also pass a plain-scalar file name which this module will attmept to open for reading or appending. (for anything more elaborate, see L<IPC::Run> instead) Note that on Win32, none of the parent's handles are inherited by default, which is the opposite on Unix. When you specify any of these handles on Win32 the default will change to inherit them from the parent. =item C<cwd> Specify a path which should become the child process's current working directory. The path must already exist. =item C<autoterminate> If you pass a true value for this option, then destruction of the Proc::Background object (going out of scope, or script-end) will kill the process via C<< ->terminate >>. Without this option, the child process continues running. C<die_upon_destroy> is an alias for this option, used by previous versions of this module. =back =back =head1 ATTRIBUTES =over =item B<command> The command (string or arrayref) that was passed to the constructor. =item B<exe> The path to the executable that was passed as an option to the constructor, or derived from the C<command>. =item B<start_time> Return the value that the Perl function time() returned when the process was started. =item B<pid> Returns the process ID of the created process. This value is saved even if the process has already finished. =item B<alive> Return 1 if the process is still active, 0 otherwise. This makes a non-blocking call to C<wait> to check the real status of the process if it has not been reaped yet. =item B<suspended> Boolean whether the process is thought to be stopped. This does not actually consult the operating system, and just returns the last known status from a call to C<suspend> or C<resume>. It is always false if C<alive> is false. =item B<exit_code> Returns the exit code of the process, assuming it exited cleanly. Returns C<undef> if the process has not exited yet, and 0 if the process exited with a signal (or TerminateProcess). Since 0 is ambiguous, check for C<exit_signal> first. =item B<exit_signal> Returns the value of the signal the process exited with, assuming it died on a signal. Returns C<undef> if it has not exited yet, and 0 if it did not die to a signal. =item B<end_time> Return the value that the Perl function time() returned when the exit status was obtained from the process. =item B<autoterminate> This writeable attribute lets you enable or disable the autoterminate option, which could also be passed to the constructor. =back =head1 METHODS =over =item B<wait> $exit= $proc->wait; # blocks forever $exit= $proc->wait($timeout_seconds); # since version 1.20 Wait for the process to exit. Return the exit status of the command as returned by wait() on the system. To get the actual exit value, divide by 256 or right bit shift by 8, regardless of the operating system being used. If the process never existed, this returns undef. This function may be called multiple times even after the process has exited and it will return the same exit status. Since version 1.20, you may pass an optional argument of the number of seconds to wait for the process to exit. This may be fractional, and if it is zero then the wait will be non-blocking. Note that on Unix this is implemented with L<Time::HiRes/alarm> before a call to wait(), so it may not be compatible with scripts that use alarm() for other purposes, or systems/perls that resume system calls after a signal. In the event of a timeout, the return will be undef. =item B<suspend> Pause the process. This returns true if the process is stopped afterward. This throws an excetion if the process is not C<alive> and C<autodie> is enabled. =item B<resume> Resume a paused process. This returns true if the process is not stopped afterward. This throws an exception if the process is not C<alive> and C<autodie> is enabled. =item B<terminate>, B<terminate(@kill_sequence)> Reliably try to kill the process. Returns 1 if the process no longer exists once B<terminate> has completed, 0 otherwise. This will also return 1 if the process has already exited. C<@kill_sequence> is a list of actions and seconds-to-wait for that action to end the process. The default is C< TERM 2 TERM 8 KILL 3 KILL 7 >. On Unix this sends SIGTERM and SIGKILL; on Windows it just calls TerminateProcess (graceful terminationthe second is set to 1 if the process was killed by B<timeout_system> or 0 if the process exited by itself. The exit status is the value returned from the wait() call. If the process was killed, then the return value will include the killing of it. To get the actual exit value, divide by 256. If something failed in the creation of the process, the subroutine returns an empty list in a list context, an undefined value in a scalar context, or nothing in a void context. =back =head1 SEE ALSO =over =item L<IPC::Run> IPC::Run is a much more complete solution for running child processes. It handles dozens of forms of redirection and pipe pumping, and should probably be your first stop for any complex needs. However, also note the very large and slightly alarming list of limitations it lists for Win32. Proc::Background is a much simpler design and should be more reliable for simple needs. =item L<Win32::ShellQuote> If you are running on Win32, this article by Daniel Colascione helps describe the problem you are up against for passing argument lists: L<Everyone quotes command line arguments the wrong way|https://blogs.msdn.microsoft.com/twistylittlepassagesallalike/2011/04/23/everyone-quotes-command-line-arguments-the-wrong-way/> This module gives you parsing / quoting per the standard CommandLineToArgvW behavior. But, if you need to pass arguments to be processed by C<cmd.exe> then you need to do additional work. =back =head1 AUTHORS =over 4 =item * Blair Zajac <blair@orcaware.com> =item * Michael Conrad <mike@nrdvana.net> =back =head1 CONTRIBUTORS =for stopwords Florian Schlichting Kevin Ryde Salvador Fandiño =over 4 =item * Florian Schlichting <fsfs@debian.org> =item * Kevin Ryde <user42@zip.com.au> =item * Salvador Fandiño <sfandino@yahoo.com> =back =head1 VERSION version 1.30 =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Michael Conrad, (C) 1998-2009 by Blair Zajac. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut