# File.pm: Class Used for File Management Macros package RDA::Library::File; # $Id: File.pm,v 1.60 2015/11/13 15:56:43 RDA Exp $ # ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Library/File.pm,v 1.60 2015/11/13 15:56:43 RDA Exp $ # # Change History # 20151113 MSC Use get_limit. =head1 NAME RDA::Library::File - Class Used for File Management Macros =head1 SYNOPSIS require RDA::Library::File; =head1 DESCRIPTION The objects of the C class are used to interface with file management macros. The following methods are available: =cut use strict; BEGIN { use Exporter; use IO::File; use IO::Handle; use RDA::Text qw(get_string); use RDA::Alarm qw(check_alarm clear_alarm set_alarm); use RDA::Driver::Library qw($PWF $WRK cnv_command exe_command get_alarm get_command get_output log_timeout); use RDA::Object; use RDA::Object::Buffer; use RDA::Object::Limit; use RDA::Object::Rda qw($CREATE $EXE_PERMS $TMP_PERMS); use RDA::Object::View; use RDA::Value::Assoc; use RDA::Value::List; use RDA::Value::Scalar qw(:data); } # Define the global public variables use vars qw($STRINGS $SUSPEND $VERSION @ISA); $SUSPEND = { cnt => 0, err => 0, hdr => undef, lgt => 0, _buf => undef, _dir => undef, _fil => undef, _nat => undef, }; $VERSION = sprintf('%d.%02d', q$Revision: 1.60 $ =~ /(\d+)\.(\d+)/); @ISA = qw(RDA::Driver::Library Exporter); # Define the global private constants my $ERR = 'stderr.txt'; my $OUT = 'stdout.txt'; my $RPT = qr/^RDA::Object::(Pipe|Report)$/i; # Define the global private variables my %tb_fct = ( 'catCommand' => [\&_m_cat_command, 'T'], 'catDir' => [\&_m_cat_dir, 'T'], 'catFile' => [\&_m_cat_file, 'T'], 'catNative' => [\&_m_cat_native, 'T'], 'checksum' => [\&_m_checksum, 'T'], 'cleanBox' => [\&_m_clean_box, 'T'], 'clearLastFile' => [\&_m_clear_last, 'N'], 'collectCommand' => [\&_m_collect_cmd, 'L'], 'collectData' => [\&_m_collect_data, 'L'], 'collectFile' => [\&_m_collect_file, 'L'], 'command' => [\&_m_command, 'L'], 'compareFile' => [\&_m_compare_file, 'N'], 'compareText' => [\&_m_compare_text, 'N'], 'countCommand' => [\&_m_count_cmd, 'L'], 'countFile' => [\&_m_count_file, 'L'], 'countLast' => [\&_m_count_last, 'L'], 'findDir' => [\&_m_find_dir, 'L'], 'getHeader' => [\&_m_get_header, 'T'], 'getLastAccess' => [\&_m_get_atime, 'T'], 'getLastBuffer' => [\&_m_get_buffer, 'O'], 'getLastChange' => [\&_m_get_ctime, 'T'], 'getLastLength' => [\&_m_get_last_lgt, 'N'], 'getLastModify' => [\&_m_get_mtime, 'T'], 'getLength' => [\&_m_get_file_lgt, 'N'], 'getLines' => [\&_m_get_lines, 'L'], 'getOwner' => [\&_m_get_owner, 'T'], 'getSize' => [\&_m_get_size, 'N'], 'getStat' => [\&_m_get_stat, 'L'], 'getTimeout' => [\&_m_get_timeout, 'N'], 'grepCommand' => [\&_m_grep_cmd, 'L'], 'grepDir' => [\&_m_grep_dir, 'L'], 'grepFile' => [\&_m_grep_file, 'L'], 'grepLastFile' => [\&_m_grep_last, 'L'], 'isNewer' => [\&_m_is_newer, 'N'], 'isOlder' => [\&_m_is_older, 'N'], 'isOwner' => [\&_m_is_owner, 'N'], 'kill' => [\&_m_kill, 'N'], 'lastCommand' => [\&_m_last_command, 'T'], 'lastDir' => [\&_m_last_dir, 'T'], 'lastFile' => [\&_m_last_file, 'T'], 'lastNative' => [\&_m_last_native, 'T'], 'loadCommand' => [\&_m_load_cmd, 'N'], 'loadFile' => [\&_m_load_file, 'N'], 'loadString' => [\&_m_load_string, 'N'], 'sameFile' => [\&_m_same_file, 'N'], 'readLink' => [\&_m_read_link, 'T'], 'sameDir' => [\&_m_same_file, 'N'], 'sameFile' => [\&_m_same_file, 'N'], 'setTimeout' => [\&_m_set_timeout, 'N'], 'sortLastFile' => [\&_m_sort_last, 'N'], 'splitDir' => [\&_m_split_dir, 'L'], 'status' => [\&_m_status, 'N'], 'system' => [\&_m_system, 'N'], 'testCommand' => [\&_m_test_cmd, 'X'], 'umask' => [\&_m_umask, 'N'], 'writeCommand' => [\&_m_write_cmd, 'N'], 'writeLastFile' => [\&_m_write_last, 'N'], ); my %tb_fmt = ( '[UTC]' => '%d-%b-%Y %H:%M:%S UTC', '' => '%d-%b-%Y %H:%M:%S UTC', ); my %tb_srt = ( ps_time => { 'aix' => [\&_sort_ps_ms], 'cygwin' => [\&_sort_ps_hmsw, 144], 'darwin' => [\&_sort_ps_msc], 'dec_osf' => [\&_sort_ps_hmsc, 43], 'dynixptx' => [\&_sort_ps_ms], 'hpux' => [\&_sort_ps_hms, 33], 'linux' => [\&_sort_ps_hms, 57], 'MSWin32' => [\&_sort_ps_hmsw, 144], 'solaris' => [\&_sort_ps_ms], q{?} => [\&_sort_ps_ms], } ); # Report the package version sub Version { return $VERSION; } =head2 S<$h = RDA::Library::File-Enew($driver,$collector)> The object constructor. It takes the library driver and collector references as arguments. C is represented by a blessed hash reference. The following special keys are used: =over 12 =item S< B<'cnt' > > Number of lines read for the last load =item S< B<'err' > > Last command exit code =item S< B<'hdr' > > First line for a grep operation =item S< B<'lgt' > > Number of lines read for the last file =item S< B<'lim' > > Execution time limit (in sec) =item S< B<'max' > > Default highest line number to write =item S< B<'_buf'> > Last command/line buffer =item S< B<'_cfg'> > Reference to the RDA software configuration =item S< B<'_cks'> > Check sum function =item S< B<'_col'> > Reference to the collector object =item S< B<'_dir'> > Last directory =item S< B<'_fil'> > Last file =item S< B<'_grp'> > Report group =item S< B<'_lim'> > Reference to the limit control object =item S< B<'_nat'> > Last native path =item S< B<'_not'> > Statistics note =item S< B<'_out'> > Number of operating system requests timed out =item S< B<'_req'> > Number of operating system requests =item S< B<'_rpt'> > Report directory =item S< B<'_sam'> > Function to compare directory or file paths =item S< B<'_sap'> > Short absolute path indicator =item S< B<'_sys'> > Reference to the system view object =item S< B<'_trc'> > Execution time recording indicator =item S< B<'_vms'> > VMS indicator =item S< B<'_win'> > Windows indicator =item S< B<'_wrk'> > Reference to the work file manager =back Internal keys are prefixed by an underscore. =cut sub new { my ($cls, $drv, $col) = @_; my ($flg, $slf); # Create the library object $slf = bless { cnt => 0, err => 0, lgt => 0, _cfg => $col->get_config, _lim => $col->get_limit, _out => 0, _req => 0, _sap => RDA::Object::Rda->is_windows || RDA::Object::Rda->is_cygwin, _sys => $col->get_agent->get_system, _vms => RDA::Object::Rda->is_vms, _win => RDA::Object::Rda->is_windows, }, ref($cls) || $cls; # Determine which functions to use $slf->{'_sam'} = $slf->{'_vms'} ? \&_same_i : $slf->{'_sap'} ? \&_same_i : \&_same_c; # Register the macros $drv->register($slf, [keys(%tb_fct)], qw(rda refresh suspend usage)); # Return the object reference return refresh($slf, $col); } =head2 S<$h-Ecall($name,...)> This method executes the macro code. =cut sub call { my ($slf, $nam, @arg) = @_; return &{$tb_fct{$nam}->[0]}($slf, @arg); } =head2 S<$h-Eclr_stats> This method resets the statistics and clears corresponding module settings. =cut sub clr_stats { my ($slf) = @_; $slf->{'_not'} = q{}; $slf->{'_req'} = $slf->{'_out'} = 0; return; } =head2 S<$h-Edelete_object> This method deletes the library control object. =cut sub delete_object { RDA::Object::dump_caller($_[0], 'Library') if $RDA::Object::DELETE; undef %{$_[0]}; undef $_[0]; return; } =head2 S<$h-Eget_stats> This method reports the library statistics in the specified module. =cut sub get_stats { my ($slf) = @_; my ($use); if ($slf->{'_req'}) { # Get the statistics record $use = $slf->{'_col'}->get_usage; $use->{'OS'} = {not => q{}, out => 0, req => 0} unless exists($use->{'OS'}); $use = $use->{'OS'}; # Indicate the current timeout when there is no other note $slf->{'_not'} = 'Command execution limited to '.$slf->{'lim'}.'s' unless $use->{'not'} || $slf->{'_not'} ## no critic (Unless) || $slf->{'lim'} <= 0; # Generate the module statistics $use->{'out'} += $slf->{'_out'}; $use->{'req'} += $slf->{'_req'}; $use->{'not'} = $slf->{'_not'} if $slf->{'_not'}; # Clear the statistics clr_stats($slf); } return; } =head2 S<$h-Erefresh($col)> This method updates the library control object for a new collector. =cut sub refresh { my ($slf, $col) = @_; my ($dft, $trc); $dft = $col->get_info('dft'); $trc = $col->get_trace('TIME'); $slf->{'lim'} = $trc ? 0 : check_alarm($dft->get_first('N_TIMEOUT', 30)); $slf->{'max'} = $dft->get_first('N_TAIL', 30000); $slf->{'_col'} = $col; $slf->{'_trc'} = $trc; # Set the check mode $slf->{'_sys'}->skip_tests($dft->get_first('B_BIN_CHECK',1) ? q{-} : '-BT'); # Determine the request method delete($slf->{'_wrk'}); $slf->{'_wrk'} = $col if $slf->{'_win'} || $slf->{'_vms'} || $dft->get_first('B_USE_TEMP'); return $slf; } =head2 S<$h-Erun($name,$arg,$ctx)> This method executes the macro with the specified argument list in a given context. =cut sub run { my ($slf, $nam, $arg, $ctx) = @_; my ($fct, $ret, $typ); $fct = $tb_fct{$nam}; $typ = $fct->[1]; # Treat an array context return RDA::Value::List::new_from_data(&{$fct->[0]}($slf, $ctx, $arg->eval_as_array)) if $typ eq 'L'; # Treat a SDCL value context return &{$fct->[0]}($slf, $ctx, $arg->eval_as_array) if $typ eq 'X'; # Treat a scalar context return defined($ret = &{$fct->[0]}($slf, $ctx, $arg->eval_as_array)) ? RDA::Value::Scalar->new($typ, $ret) : $VAL_UNDEF; } =head1 FILE MACROS =head2 S This macro concatenates one or more directory names and a file name to form a complete path ending with a file name. It returns the name quoted as appropriate to execute it in a shell. =cut sub _m_cat_command { my ($slf, $ctx, @arg) = @_; return RDA::Object::Rda->quote($slf->{'_fil'} = ((scalar @arg) > 0) ? RDA::Object::Rda->cat_file(@arg) : undef); } =head2 S This macro concatenates two or more directory names to form a complete path ending with a directory. It removes the trailing slash from the resulting string. If it is the root directory, then the trailing slash is not removed. =cut sub _m_cat_dir { my ($slf, $ctx, @arg) = @_; return $slf->{'_dir'} = ((scalar @arg) > 0) ? RDA::Object::Rda->cat_dir(@arg) : undef; } =head2 S This macro concatenates one or more directory names and a file name to form a complete path ending with a file name. =cut sub _m_cat_file { my ($slf, $ctx, @arg) = @_; return $slf->{'_fil'} = ((scalar @arg) > 0) ? RDA::Object::Rda->cat_file(@arg) : undef; } =head2 S This macro concatenates one or more directory names and a file name to form a complete native path ending with a file name. =cut sub _m_cat_native { my ($slf, $ctx, @arg) = @_; return $slf->{'_nat'} = ((scalar @arg) > 0) ? RDA::Object::Rda->cat_native(@arg) : undef; } =head2 S This macro returns the check sum of the file. Based on available tools, it can use an MD5 digest, the C command, or an internal basic check sum. It returns an undefined value in case of problems. =cut sub _m_checksum { my ($slf, $ctx, $fil) = @_; my ($tmp); # Identify the check sum approach on first usage unless (exists($slf->{'_cks'})) { $slf->{'_cks'} = \&_get_sum; # Check the availability of the MD5 package eval { require Digest::MD5; $slf->{'_cks'} = \&_get_md5; }; # Check the availability of the cksum command if ($@) { my %tbl = ( ## no critic (Numbered) '/bin/cksum' => \&_get_cksum1, '/usr/bin/cksum' => \&_get_cksum2, ); foreach my $pgm (keys(%tbl)) { $tmp = `$pgm rda.sh 2>&1`; next if $?; $slf->{'_cks'} = $tbl{$pgm}; last; } } } # Compute the check sum return ($fil && -f $fil && -r $fil) ? &{$slf->{'_cks'}}($fil) : undef; } sub _get_cksum1 { my ($fil) = @_; my ($lin); ($lin) = `/bin/cksum "$fil"`; return ($lin =~ m/(\d+)/) ? $1 : undef; } sub _get_cksum2 { my ($fil) = @_; my ($lin); ($lin) = `/usr/bin/cksum "$fil"`; return ($lin =~ m/(\d+)/) ? $1 : undef; } sub _get_md5 { my ($fil) = @_; my ($ifh, $val); if (($ifh = IO::File->new)->open("<$fil")) { binmode($ifh); $val = Digest::MD5->new->addfile($ifh)->hexdigest; $ifh->close; } return $val; } sub _get_sum { my ($fil) = @_; my ($buf, $ifh, $sum); if (($ifh = IO::File->new)->open("<$fil")) { binmode($ifh); $sum = 0; while ($ifh->sysread($buf, 1024)) { $sum = (($sum + (unpack('%32C*', $buf) << 12) + unpack('%32B*', $buf)) ^ ($sum << 8)) & 0xffffffff; ## no critic (Bit,Number) } $ifh->close; } return $sum; } =head2 S This macro prepares the sand box directory by creating the directory on first use or by removing any previous content. It returns the directory path. =cut sub _m_clean_box { my ($slf, $ctx) = @_; return RDA::Object::Rda->clean_dir($ctx->get_collector->get_dir('B', 1)); } =head2 S This macro clears the information about the last command/file results. =cut sub _m_clear_last { my ($slf) = @_; delete($slf->{'_buf'}); return $slf->{'cnt'} = $slf->{'err'} = 0; } =head2 S This macro captures the standard output and the standard error of the specified command in two separate reports. By default, it eliminates the standard error report when empty. On successful completion, it creates entries in the Oracle Explorer catalog. It is possible to increase the execution limit by specifying an increasing factor as an argument. A negative or null (zero) value disables any timeout. For finer tuning the collection, you can provide a hash reference as the request argument. It supports the following keys. =over 11 =item S< B<'err'> > Controls the standard error processing. =item S< B<'inc'> > When present, specifies the timeout incremental ratio. =item S< B<'inp'> > Specifies the string to provide as the standard input. =item S< B<'inv'> > When true, inverts redirection arguments. =item S< B<'nam'> > Specifies the name of the Oracle Explorer target. =item S< B<'out'> > Controls the standard output processing. =item S< B<'pwd'> > Controls password injection. =item S< B<'pwf'> > Controls password file use. =item S< B<'pre'> > Trace command prefix. =item S< B<'ret'> > When present, indicates what the macro must returns. =item S< B<'sta'> > Contains the command exit status. =back The standard output and error control hashes can have the following keys: =over 11 =item S< B<'arg'> > Contains the argument added to the command. =item S< B<'blk'> > When true, forces a verbatim block in the RDA report. =item S< B<'cat'> > Controls and specifies the catalog entry type. =item S< B<'cfm'> > Alters the customer file management level. =item S< B<'dup'> > Controls and specifies a duplicated catalog entry. =item S< B<'end'> > Controls report closing. =item S< B<'ext'> > Specifies the extension for the Oracle Explorer target. =item S< B<'fct'> > Specifies the macro to filter the command result. =item S< B<'fil'> > Specifies a file or a redirection request. =item S< B<'flt'> > When true, forces the work file use. =item S< B<'ftr'> > Specifies an associated footer text. =item S< B<'hdr'> > Specifies an associated header text. =item S< B<'lin'> > When true, treats the verbatim block line by line. =item S< B<'mod'> > When true, appends to the file instead of creating it. =item S< B<'kpt'> > When true, keeps empty reports. =item S< B<'rpt'> > Specifies a report to reuse. =item S< B<'tag'> > Associates tags to the result. =item S< B<'wrk'> > Contains the name of the work file. =back The macro can override some parameters to ensure a correct behavior. It returns: =over 2 =item * By default, the list of the generated reports. =item * A list of values when the C key contains an array reference as value. The result is a fixed length list, where missing elements are represented by an undefined value. The entries of the standard output and error control hashes are available by prefixing their key with C or C. =item * A list with a single value when the C key does not contain an array reference as value. The entries of the standard output and error control hashes are available by prefixing their key with C or C. The macro returns an empty list when the requested value is not available. =back =cut sub _m_collect_cmd ## no critic (Complex) { my ($slf, $ctx, $req, $cmd, $inc) = @_; my ($ctl, $env, $flg, $lim, $out, $pid, $pre, $sta, $val, $wrk, @cln, @pwd, @rpt); $slf->{'err'} = 0; ++$slf->{'_req'}; $val = ref($req); if ($val =~ m/^RDA::Value::(Assoc|Hash)$/) { $ctl = $req->eval_as_data(1); delete($ctl->{'sta'}); $ctl->{'err'} = {} unless ref($ctl->{'err'}) eq 'HASH'; $ctl->{'out'} = {kpt => 1} unless ref($ctl->{'out'}) eq 'HASH'; } elsif ($val eq 'HASH') { $ctl = $req; delete($ctl->{'sta'}); $ctl->{'err'} = {} unless ref($ctl->{'err'}) eq 'HASH'; $ctl->{'out'} = {kpt => 1} unless ref($ctl->{'out'}) eq 'HASH'; } else { $ctl = { err => {}, nam => $val ? q{} : $req, out => {kpt => 1}, }; } if ($ctl->{'nam'} && $cmd) { $ctl->{'nam'} =~ s{[^\-\+\=\#\@\.\,\:\/A-Za-z0-9]+}{_}g; ($cmd, $pre, $env, $inc, @cln) = get_command($slf, $ctx, $cmd, $inc, 1); if ($cmd) { $env = $slf->{'_sys'}->set_context($env) if $env; $pre = $ctl->{'pre'} if exists($ctl->{'pre'}); # Prepare the command $out = $ctx->get_output; $wrk = $slf->{'_col'}; _beg_collect($out, $wrk, $ctl->{'nam'}, $ctl->{'out'}, 'O', q{ >}, $OUT, '.out'); _beg_collect($out, $wrk, $ctl->{'nam'}, $ctl->{'err'}, 'E', q{ 2>}, $ERR, '.err'); $val = cnv_command($slf, $ctl->{'inv'} ? $cmd.$ctl->{'err'}->{'arg'}.$ctl->{'out'}->{'arg'} : $cmd.$ctl->{'out'}->{'arg'}.$ctl->{'err'}->{'arg'}); # Execute the command $lim = get_alarm($slf, exists($ctl->{'inc'}) ? $ctl->{'inc'} : $inc); $sta = 0; eval { local $SIG{'ALRM'} = sub { die "Alarm\n" } if $lim; local $SIG{'PIPE'} = 'IGNORE'; # Limit its execution to prevent RDA hangs set_alarm($lim) if $lim; # Execute the command $slf->{'_col'}->log_start if $slf->{'_trc'}; if ($pid = open(OUT, "| $val")) ## no critic (Handle,Open) { local $SIG{'ALRM'} = sub { $sta = RDA::Object::Rda->kill_child($pid); } if $lim; if (exists($ctl->{'inp'})) { if (ref($val = $ctl->{'inp'}) eq 'ARRAY') { ($val, @pwd) = @{$val}; $val = sprintf($val, $slf->{'_col'}->get_access->get_password(@pwd)); } syswrite(OUT, $val, length($val)); } close(OUT); } $slf->{'_col'}->log_end($ctx, $pre.$cmd) if $slf->{'_trc'}; # Disable the alarm clear_alarm() if $lim; }; $slf->{'err'} = $ctl->{'sta'} = $?; $slf->{'_sys'}->restore_context($env) if $env; for (@cln) { $wrk->clean_work($_); } # Treat the results if ($pid) { # Abort sub process when timeout if ($sta) { log_timeout($slf, $ctx, 'OS', $pre.$cmd); $slf->{'err'} = $ctl->{'sta'} = -1; } elsif ($sta = $@) { RDA::Object::Rda->kill_child($pid); log_timeout($slf, $ctx, 'OS', $pre.$cmd); $slf->{'err'} = $ctl->{'sta'} = -1; } # Process the standard output push(@rpt, _end_collect($ctx, $out, $wrk, $ctl, $ctl->{'out'}, ['C', $cmd], '.out')); # Process the standard error push(@rpt, _end_collect($ctx, $out, $wrk, $ctl, $ctl->{'err'}, ['E', $cmd], '.err')); } else { _no_collect($ctl->{'out'}); _no_collect($ctl->{'err'}); } } } # Indicate the command completion return @rpt unless exists($ctl->{'ret'}); $val = $ctl->{'ret'}; return (map {_get_collect($ctl, $_)} @{$val}) if ref($val) eq 'ARRAY'; return _get_collect($ctl, $val, 1); } sub _beg_collect { my ($out, $wrk, $nam, $dsc, $cat, $pre, $fmt, $ext) = @_; my ($rpt); # Treat a file request if (exists($dsc->{'fil'})) { delete($dsc->{'rpt'}); delete($dsc->{'wrk'}); ($dsc->{'mod'}, $dsc->{'fil'}) = (0, RDA::Object::Rda->dev_null) unless defined($dsc->{'fil'}) && length($dsc->{'fil'}); $dsc->{'arg'} = $pre .($dsc->{'mod'} ? '>' : q{}) .(($dsc->{'fil'} =~ m/^\&\d+$/) ? $dsc->{'fil'} : RDA::Object::Rda->quote($dsc->{'fil'})); return; } # Treat a filter request $dsc->{'cat'} = $cat unless exists($dsc->{'cat'}); $dsc->{'ext'} = $ext unless exists($dsc->{'ext'}); if ($dsc->{'flt'} || $dsc->{'fct'} || $out->is_filtered) { $dsc->{'wrk'} = $wrk->get_work($dsc->{'flt'} = $fmt, 1); $dsc->{'arg'} = $pre.$dsc->{'wrk'}; return; } # Treat a report request delete($dsc->{'wrk'}); if (ref($dsc->{'rpt'}) eq 'RDA::Object::Report') { $rpt = $dsc->{'rpt'}; $dsc->{'arg'} = $pre.'>' .RDA::Object::Rda->quote($dsc->{'fil'} = $rpt->get_path); $dsc->{'end'} = 0 unless exists($dsc->{'end'}); $dsc->{'kpt'} = $dsc->{'mod'} = 1; } else { $dsc->{'rpt'} = $rpt = $out->add_report('d', $nam, 0, $ext, undef, $dsc->{'cfm'}); $dsc->{'arg'} = $pre .RDA::Object::Rda->quote($dsc->{'fil'} = $rpt->get_path); $dsc->{'end'} = 1 unless exists($dsc->{'end'}); $dsc->{'mod'} = 0; } $rpt->begin_block($dsc->{'blk'}); if (defined($dsc->{'cat'})) { $rpt->add_block('E', $dsc->{'cat'}, $nam.$dsc->{'ext'}); } else { delete($dsc->{'dup'}); } return $dsc->{'nat'} ? $rpt->suspend : $rpt->close; } sub _end_collect ## no critic (Complex) { my ($ctx, $out, $wrk, $ctl, $dsc, $idx, $ext) = @_; my ($blk, $rpt, $val, @cat, @rpt); push(@cat, ['L', $dsc->{'cfm'}]) if exists($dsc->{'cfm'}); push(@cat, ['T', $dsc->{'tag'}]) if exists($dsc->{'tag'}); if (exists($dsc->{'wrk'})) { if ($dsc->{'kpt'} || -s $dsc->{'wrk'}) { if (ref($dsc->{'rpt'}) eq 'RDA::Object::Report') { $rpt = $dsc->{'rpt'}; $dsc->{'end'} = 0 unless exists($dsc->{'end'}); $dsc->{'kpt'} = $dsc->{'mod'} = 1; } else { $dsc->{'rpt'} = $rpt = $out->add_report('d', $ctl->{'nam'}, 0, $ext, undef, $dsc->{'cfm'}); $dsc->{'end'} = 1 unless exists($dsc->{'end'}); $dsc->{'mod'} = 0; } $dsc->{'fil'} = $rpt->get_path; if (defined($dsc->{'cat'})) { unshift(@cat, ['E', $dsc->{'cat'}, $ctl->{'nam'}.$dsc->{'ext'}]); } else { delete($dsc->{'dup'}); } if (ref($ctl->{'idx'})) { $rpt->begin_block; $rpt->end_block(q{-}, delete($ctl->{'idx'})); } $rpt->write($dsc->{'hdr'}.qq{\n}) if exists($dsc->{'hdr'}); $rpt->suspend if $dsc->{'nat'}; if (exists($dsc->{'fct'})) { $rpt->begin_block($dsc->{'blk'}); $val = RDA::Value::List->new( RDA::Value::Scalar::new_object($rpt), RDA::Value::Scalar::new_object( RDA::Object::Buffer->new('R', $dsc->{'wrk'})), RDA::Value::Assoc::new_from_data(%{$ctl})); if ($dsc->{'fct'} =~ m/^(caller:(\w+))$/) { $blk = $ctx->get_current; $val = $blk->define_operator([$2, '.macro.'], $blk, $2, $val) } else { $val = $ctx->define_operator([$dsc->{'fct'}, '.macro.'], $ctx, $dsc->{'fct'}, $val); } $val->eval_value; $rpt->end_block($idx, @cat); if ($dsc->{'kpt'} || -s $dsc->{'fil'}) { push(@rpt, $rpt->get_report); } else { delete($dsc->{'fil'}); $rpt->unlink; } } elsif ($dsc->{'blk'}) { $dsc->{'lin'} ? $rpt->write_file($dsc->{'wrk'},$idx, @cat) : $rpt->write_verbatim($dsc->{'wrk'},$idx, @cat); push(@rpt, $rpt->get_report); } else { $rpt->write_data($dsc->{'wrk'},$idx, @cat); push(@rpt, $rpt->get_report); } $rpt->dup_block('E', @{$dsc->{'dup'}}) if ref($dsc->{'dup'}) eq 'ARRAY'; $rpt->resume if $dsc->{'nat'}; $rpt->write($dsc->{'ftr'}.qq{\n}) if exists($dsc->{'ftr'}); $out->end_report(delete($dsc->{'rpt'})) if $dsc->{'end'}; } elsif ($dsc->{'idx'}) { $ctl->{'idx'} = ['E', $dsc->{'cat'}, $ctl->{'nam'}.$dsc->{'ext'}] if defined($dsc->{'cat'}); } delete($dsc->{'wrk'}); $wrk->clean_work($dsc->{'flt'}); } elsif (exists($dsc->{'rpt'})) { if ($dsc->{'kpt'} || -s $dsc->{'fil'}) { $rpt = $dsc->{'rpt'}; $rpt->update(1); $rpt->end_block($idx, @cat); $rpt->dup_block('E', @{$dsc->{'dup'}}) if ref($dsc->{'dup'}) eq 'ARRAY'; $rpt->resume if $dsc->{'nat'}; push(@rpt, $rpt->get_report); } else { $dsc->{'rpt'}->unlink; } $out->end_report(delete($dsc->{'rpt'})) if $dsc->{'end'}; } return @rpt; } sub _get_collect { my ($ctl, $key, $flg) = @_; my ($val); if (!ref($key) && defined($key) && length($key)) { return _get_collect($ctl->{$1}, $key, $flg) if $key =~ s/(err|out)_?//; $val = $ctl->{$key} if exists($ctl->{$key}); } if ($flg) { return ($val) if defined($val); return (); } return $val; } sub _no_collect { my ($dsc) = @_; delete($dsc->{'wrk'}); if (exists($dsc->{'rpt'}) && !exists($dsc->{'wrk'}) && !$dsc->{'mod'}) { delete($dsc->{'fil'}); delete($dsc->{'rpt'})->unlink; } return; } =head2 S This macro collects the content of a binary file or a buffer without any transformation. On successful completion, it creates an entry in the Oracle Explorer catalog. It returns the list of the generated reports, as links from the index. =cut sub _m_collect_data { my ($slf, $ctx, $req, $fil, $idx, @arg) = @_; my ($flg, $out, $rpt, @cat, @rpt); if (defined($req) && defined($fil)) { $req =~ s{^/}{}; $req =~ s{[^\-\+\=\#\@\.\,\:\/A-Za-z0-9]+}{_}g; foreach my $cat (@arg) { next unless ref($cat) eq 'RDA::Value::Array'; push(@cat, $cat = $cat->eval_as_data(1)); $flg = 1 if defined($cat->[0]) && $cat->[0] eq 'E'; } push(@cat, ref($fil) ? ['E', 'B', $req] : ['E', 'B', $req, $fil]) unless $flg; $idx = (ref($idx) eq 'RDA::Value::Array') ? $idx->eval_as_data(1) : undef; $out = $ctx->get_output; $rpt = $out->add_report('b', $req, 0, '.bin'); push(@rpt, $rpt->get_report) if !$rpt->is_skipped && $rpt->write_data($fil, $idx, @cat); $out->end_report($rpt); } return @rpt; } =head2 S This macro collects the content of a data file or a buffer. On successful completion, it creates an entry in the Oracle Explorer catalog. It returns the list of the generated reports, as links from the index. =cut sub _m_collect_file { my ($slf, $ctx, $req, $fil, $idx, @arg) = @_; my ($flg, $out, $rpt, @cat, @rpt); if (defined($req) && defined($fil)) { $req =~ s{^/}{}; $req =~ s{[^\-\+\=\#\@\.\,\:\/A-Za-z0-9]+}{_}g; foreach my $cat (@arg) { next unless ref($cat) eq 'RDA::Value::Array'; push(@cat, $cat = $cat->eval_as_data(1)); $flg = 1 if defined($cat->[0]) && $cat->[0] eq 'E'; } push(@cat, ref($fil) ? ['E', 'D', $req] : ['E', 'D', $req, $fil]) unless $flg; $idx = (ref($idx) eq 'RDA::Value::Array') ? $idx->eval_as_data(1) : undef; $out = $ctx->get_output; $rpt = $out->add_report('d', $req, 0, '.lin'); push(@rpt, $rpt->get_report) if !$rpt->is_skipped && $rpt->write_data($fil, $idx, @cat); $out->end_report($rpt); } return @rpt; } =head2 S This macro executes an operating system command and returns the produced lines as a list. If the execution fails, it returns an empty list. You can retrieve the exit status with the C macro. It is possible to increase the execution limit by specifying an increasing factor as an argument. A negative or null (zero) value disables any timeout. =cut sub _m_command { my ($slf, $ctx, $cmd, $inc) = @_; my ($env, $pre, @buf, @cln); $slf->{'err'} = 0; ++$slf->{'_req'}; ($cmd, $pre, $env, $inc, @cln) = get_command($slf, $ctx, $cmd, $inc); if ($cmd) { # Execute the command, storing all resulting lines as a list $env = $slf->{'_sys'}->set_context($env) if $env; $slf->{'_col'}->log_start if $slf->{'_trc'}; eval { local $SIG{'__WARN__'} = sub {}; @buf = `$cmd`; }; $slf->{'err'} = $?; $slf->{'_col'}->log_end($ctx, $pre.$cmd) if $slf->{'_trc'}; $slf->{'_sys'}->restore_context($env) if $env; for (@cln) { $slf->{'_col'}->clean_work($_); } # Remove the ends of line foreach my $lin (@buf) { $lin =~ s/[\r\n]+$//; } } elsif ($pre) { return $pre->get_lines; } # Returns the command result return @buf; } =head2 S This macro compares the content of the specified files or buffers. It returns 0 if the files are equal, 1 if the files are unequal, -1 if an error was encountered, or an undefined value when an argument is missing. =cut ## no critic (Numbered) sub _m_compare_file { my ($slf, $ctx, $fil1, $fil2) = @_; my ($buf1, $buf2, $flg1, $flg2, $ifh1, $ifh2, $ret, $siz); return unless defined($fil1) && defined($fil2); if (ref($fil1) eq 'RDA::Object::Buffer') { $ifh1 = $fil1->get_handle; } else { $ifh1 = IO::File->new; $flg1 = $ifh1->open("<$fil1") or return -1; } if (ref($fil2) eq 'RDA::Object::Buffer') { $ifh2 = $fil2->get_handle; } else { $ifh2 = IO::File->new; $flg2 = $ifh2->open("<$fil2") or return -1; } # Compare the lines $ret = 0; $siz = 8192; while ($ifh1->sysread($buf1, $siz)) { next if ($ifh2->sysread($buf2, $siz)) && $buf1 eq $buf2; $ret = 1; last; } $ret = 1 if $ret == 0 && ($ifh2->sysread($buf2, $siz)); # Close the files and return the comparison result $ifh1->close if $flg1; $ifh2->close if $flg2; return $ret; } =head2 S This macro compares the content of the specified files or buffers, line by line and ignoring ends of line, and stops as soon as a difference is detected. It returns 0 if the files are equal, 1 if the files are unequal, -1 if an error was encountered, or an undefined value when an argument is missing. =cut sub _m_compare_text { my ($slf, $ctx, $fil1, $fil2) = @_; my ($flg1, $flg2, $ifh1, $ifh2, $lin1, $lin2, $ret); return unless defined($fil1) && defined($fil2); if (ref($fil1) eq 'RDA::Object::Buffer') { $ifh1 = $fil1->get_handle; } else { $ifh1 = IO::File->new; $flg1 = $ifh1->open("<$fil1") or return -1; } if (ref($fil2) eq 'RDA::Object::Buffer') { $ifh2 = $fil2->get_handle; } else { $ifh2 = IO::File->new; $flg2 = $ifh2->open("<$fil2") or return -1; } # Compare the lines $ret = 0; while (defined($lin1 = <$ifh1>)) { $lin1 =~ s/[\n\r\s]*$//; if (defined($lin2 = <$ifh2>)) { $lin2 =~ s/[\n\r\s]*$//; next if $lin1 eq $lin2; } $ret = 1; last; } $ret = 1 if $ret == 0 && defined($lin2 = <$ifh2>); # Close the files and return the comparison result $ifh1->close if $flg1; $ifh2->close if $flg2; return $ret; } ## use critic; =head2 S This macro returns the number of lines in the specified command. You can search additional regular expressions also. It returns a list containing the respective counters. =head2 S This macro returns the number of lines in the specified file. You can search additional regular expressions also. It returns a list containing the respective counters. =head2 S This macro returns the number of lines in the last file/command buffer. You can search additional regular expressions also. It returns a list containing the respective counters. =cut sub _m_count_cmd { my ($slf, $ctx, $cmd, @arg) = @_; return @{exe_command(\&_count_in, [], $slf, $ctx, $cmd, 'OS', 1, @arg)}; } sub _m_count_file { my ($slf, $ctx, $fil, @arg) = @_; my ($ifh); $ifh = IO::Handle->new; return () unless $fil && open($ifh, "<$fil"); ## no critic (Handle,Open) return @{_count_in([], $slf, $ctx, $ifh, 1, 0, 0, 0, @arg)}; } sub _m_count_last { my ($slf, $ctx, @arg) = @_; return @{_count_in([], $slf, $ctx, RDA::Object::Buffer->new('l', $slf->{'_buf'})->get_handle, 0, 0, 0, 0, @arg)}; } sub _count_in ## no critic (Args) { my ($cnt, $slf, $ctx, $ifh, $fil, $cmd, $lim, $pid, @arg) = @_; my ($off, $sta, @pat); eval { local $SIG{'ALRM'} = sub { die "Alarm\n"; } if $lim; # Get the regular expressions push(@{$cnt}, 0); foreach my $str (@arg) { next unless defined($str); push(@pat, RDA::Object::View->is_pattern($str)); push(@{$cnt}, 0); } # Scan the input set_alarm($lim) if $lim; while (<$ifh>) { ++$cnt->[$off = 0]; s/^\000+$//; foreach my $pat (@pat) { ++$off; ++$cnt->[$off] if $_ =~ $pat; } } clear_alarm() if $lim; }; RDA::Object::Rda->kill_child($pid) if ($sta = $@) && $pid; close($ifh); if ($sta) { log_timeout($slf, $ctx, 'OS', $cmd); } elsif ($cmd) { $slf->{'err'} = $?; } $slf->{'lgt'} = $cnt->[0] if $fil; # Return the counter array return $cnt; } =head2 S This macro returns the subdirectories that correspond to the specified pattern from the specified directory. It supports the following options: =over 9 =item B< 'd' > Sorts the subdirectories per directory, then by name =item B< 'f' > Stops scanning on the first match =item B< 'i' > Ignores case distinctions in both the pattern and the name =item B< 'm(n)'> Keeps subdirectories modified during last (n) days only =item B< 'n' > Sorts the subdirectories by name =item B< 'p' > Returns the full directory path =item B< 'r' > Reads subdirectories under each directory recursively =item B< 't' > Sorts the subdirectories by modification time =item B< 'u' > Validates the directory entries =item B< 'v' > Inverts the sense of matching to select non-matching names =item B< 'w' > Returns where the subdirectory has been found =back The depth argument controls how far you can descend in the subdirectories. It is limited to 8 levels by default. You can also specify the directory as an array reference containing a base directory and an optional relative path from where the search must be done. Unless you require a full path, the returned paths are relative to the base directory. You can also specify the directory as a hash reference supporting the following keys: =over 11 =item B< 'age' > Specifies a directory modification age limit. =item B< 'ctx' > Specifies the limit context name. =item B< 'bas' > Specifies the base directory. =item B< 'dir' > Specifies the directory. =item B< 'rel' > Specifies an optional relative path. =back =cut sub _m_find_dir ## no critic (Complex) { my ($slf, $ctx, $dir, $pat, $opt, $max) = @_; my ($arg, $bas, $fct, $flg, $f_f, $f_p, $f_r, $f_u, $f_v, $f_w, $rel, @sta, @tbl, %mod); # Abort if we can access to that directory $arg = ref($dir); if ($arg eq 'RDA::Value::Array') { ($bas, $rel) = @{$dir}; $rel = (defined($rel) && $rel->is_defined) ? $rel->eval_as_string : RDA::Object::Rda->current_dir; $dir = (defined($bas) && $bas->is_defined) ? RDA::Object::Rda->cat_dir($bas = $bas->eval_as_string, $rel) : undef; $flg = 0; } elsif ($arg =~ m/^RDA::Value::(Assoc|Hash)$/) { $arg = $dir->eval_as_data(1); if (exists($arg->{'bas'})) { $rel = defined($arg->{'rel'}) ? $arg->{'rel'} : RDA::Object::Rda->current_dir; $dir = defined($bas = $arg->{'bas'}) ? RDA::Object::Rda->cat_dir($bas, $rel) : undef; $flg = 0; } elsif (exists($arg->{'dir'})) { $bas = $dir = $arg->{'dir'}; $rel = RDA::Object::Rda->current_dir; $flg = 1; } else { $dir = undef; } if (exists($arg->{'ctx'})) { ($fct, $arg) = $slf->{'_lim'}->get_file_limit($arg->{'ctx'}); } elsif (exists($arg->{'age'})) { ($fct, $arg) = $slf->{'_lim'}->get_age_limit($arg->{'age'}); } } else { $bas = $dir; $rel = q{.}; $flg = 1; } return @tbl unless $dir && opendir(DIR, $dir); $bas = q{} if $bas =~ m/^[\\\/]$/; # Decode the options $opt = q{} unless defined($opt); $pat = RDA::Object::View->is_pattern((index($opt, 'i') < 0) ? $pat : "$pat#i"); ($fct, $arg) = $slf->{'_lim'}->get_age_limit($1) if $opt =~ m/m(\d+(\.\d+)?)/; $f_f = index($opt, 'f') >= 0; $f_p = index($opt, 'p') >= 0; $f_r = index($opt, 'r') >= 0; $f_u = index($opt, 'u') >= 0; $f_v = index($opt, 'v') >= 0; $f_w = index($opt, 'w') >= 0; $f_p = 1 if $flg && $f_r; $max = 8 unless defined($max) && $max >= 0; ## no critic (Unless) # Read the directory content _find_dir(\@tbl, $bas, $rel, $pat, 0, $max, $fct, $ctx, $arg, $f_f, $f_p, $f_r, $f_u, $f_v, $f_w); # Sort the directory names when requested if (index($opt, 'd') >= 0) { return (sort { RDA::Object::Rda->dirname($a) cmp RDA::Object::Rda->dirname($b) || RDA::Object::Rda->basename($a) cmp RDA::Object::Rda->basename($b)} @tbl); } if (index($opt, 'n') >= 0) { return (sort {$a cmp $b} @tbl); } if (index($opt, 't') >= 0) { %mod = map {$_ => (@sta = stat($f_p ? $_ : RDA::Object::Rda->cat_file($bas, $_))) ? $sta[9] : 0} @tbl; ## no critic (Reverse) return (sort {$mod{$b} <=> $mod{$a} || $a cmp $b} keys(%mod)); } # Return the list of the directories return @tbl; } sub _find_dir ## no critic (Args,Complex) { my ($tbl, $bas, $dir, $pat, $lvl, $max, $fct, $ctx, $arg, $f_f, $f_p, $f_r, $f_u, $f_v, $f_w) = @_; my ($flg, $pth, $rel, $skp, @sub); # Read the directory content foreach my $nam (readdir(DIR)) { $rel = RDA::Object::Rda->cat_dir($dir, $nam); next if $f_u && !defined($rel = RDA::Object::Rda->is_path($rel)); next unless -d ($pth = RDA::Object::Rda->cat_file($bas, $rel)); push(@sub, $rel) if $f_r && -r $pth && $nam !~ m/^\.+$/; next if $skp; $flg = $f_v ? ($nam !~ $pat) : ($nam =~ $pat); $flg = &$fct($ctx, $pth, $arg) if $flg && $fct; if ($flg) { if ($f_w) { push(@{$tbl}, ($f_p ? RDA::Object::Rda->cat_dir($bas, $dir) : $dir)); $skp = 1; } else { push(@{$tbl}, ($f_p ? $pth : $rel)); } if ($f_f) { $lvl = $max; last; } } } closedir(DIR); # Explore subdirectories unless (++$lvl > $max) ## no critic (Unless) { foreach my $sub (@sub) { next unless opendir(DIR, RDA::Object::Rda->cat_dir($bas, $sub)); _find_dir($tbl, $bas, $sub, $pat, $lvl, $max, $fct, $ctx, $arg, $f_f, $f_p, $f_r, $f_u, $f_v, $f_w); return if $f_f && @{$tbl}; } } return; } =head2 S This macro returns the first line of the last C, C, C, or C. =cut sub _m_get_header { my ($slf, $ctx, $str) = @_; $str = $slf->{'hdr'} if exists($slf->{'hdr'}); return $str; } =head2 S This macro returns the last access time. Unless a format is specified, it returns the number of seconds since the epoch. =cut sub _m_get_atime { return _fmt_time(8, @_); } sub _fmt_time { my ($off, $slf, $ctx, $fil, $fmt) = @_; my ($tim, @sta, @tim); $ctx->check_stat($fil, @sta = stat($fil)); return unless @sta; if ($fmt) { eval { require POSIX; @tim = gmtime($sta[$off]); $tim[-1] = -1; ## no critic (Call) $tim = POSIX::strftime(exists($tb_fmt{$fmt}) ? $tb_fmt{$fmt} : $fmt, @tim); }; return $tim unless $@; } return $sta[$off]; } =head2 S This macro returns the last file/command buffer. Unless the flag is set, it assumes Wiki data. =cut sub _m_get_buffer { my ($slf, $ctx, $flg) = @_; return RDA::Object::Buffer->new($flg ? 'L' : 'l', $slf->{'_buf'}); } =head2 S This macro returns the inode change time. Unless a format is specified, it returns the number of seconds since the epoch. =cut sub _m_get_ctime { return _fmt_time(10, @_); } =head2 S This macro returns the number of lines in the last file/command buffer. =cut sub _m_get_last_lgt { return shift->{'cnt'}; } =head2 S This macro returns the last modify time. Unless a format is specified, it returns the number of seconds since the epoch. =cut sub _m_get_mtime { return _fmt_time(9, @_); } =head2 S This macro returns the number of lines read for the last file operation (see C, C macros). =cut sub _m_get_file_lgt { return shift->{'lgt'}; } =head2 S This macro returns a range of the lines stored in the last file/command buffer. It assumes the first and last line as the default for the range definition. You can use negative line numbers to specify lines from the buffer end. =cut sub _m_get_lines { my ($slf, $ctx, $min, $max) = @_; my $buf; return () unless exists($slf->{'_buf'}); # Validate the range $buf = $slf->{'_buf'}; $min = (!defined($min) || ($#$buf + $min) < -1) ? 0 : ($min < 0) ? $#$buf + $min + 1 : $min; $max = (!defined($max)) ? $#$buf : (($#$buf + $max) < -1) ? 0 : ($max < 0) ? $#$buf + $max + 1 : ($max > $#$buf) ? $#$buf : $max; # Return the line range return @{$buf}[$min..$max]; } =head2 S This macro returns the user identifier of the file owner or an undefined value in case of error. =cut sub _m_get_owner { my ($slf, $ctx, $fil) = @_; my (@sta); $ctx->check_stat($fil, @sta = stat($fil)); return $sta[4]; } =head2 S This macro returns the total size of the file, in bytes, or an undefined value in case of error. =cut sub _m_get_size { my ($slf, $ctx, $fil) = @_; my (@sta); $ctx->check_stat($fil, @sta = stat($fil)); return $sta[7]; } =head2 S This macro returns the status information of the file, in bytes, or an empty list in case of error. The following fields are present: =over 8 =item B< 0 > Device number of file system =item B< 1 > Inode number =item B< 2 > File mode (type and permissions) =item B< 3 > Number of (hard) links to the file =item B< 4 > User identifier of file owner =item B< 5 > Group identifier of file owner =item B< 6 > Device identifier (special files only) =item B< 7 > Total size of file (in bytes) =item B< 8 > Last access time in seconds since the epoch =item B< 9 > Last modify time in seconds since the epoch =item B< 10 > Inode change time in seconds since the epoch =item B< 11 > Preferred block size for file system I/O =item B< 12 > Actual number of blocks allocated =back Their effective use depends on file systems. =cut sub _m_get_stat { my ($slf, $ctx, $fil) = @_; my (@sta); $ctx->check_stat($fil, @sta = stat($fil)); return @sta; } =head2 S This macro returns the current duration of the timeout for executing operating system commands or 0 when this mechanism is disabled. =cut sub _m_get_timeout { return shift->{'lim'}; } =head2 S This macro returns the files that correspond to the specified pattern from the specified directory. It supports the following options: =over 9 =item B< 'd' > Sorts the files per directory, then by name =item B< 'f' > Stops scanning on the first match =item B< 'i' > Ignores case distinctions in both the pattern and the file =item B< 'm(n)'> Keeps files modified during last (n) days only =item B< 'n' > Sorts the files by name =item B< 'p' > Returns the full file path =item B< 'r' > Reads files under each directory recursively =item B< 't' > Sorts the files by modification time =item B< 'u' > Validates the directory entries =item B< 'v' > Inverts the sense of matching to select non-matching files =item B< 'w' > Returns where the file has been found =back The depth argument controls how far you can descend in the subdirectories. It is limited to 8 levels by default. You can also specify the directory as an array reference containing a base directory and an optional relative path from where the search must be done. Unless you require a full path, the returned paths are relative to the base directory. You can also specify the directory as a hash reference supporting the following keys: =over 11 =item B< 'age' > Specifies a directory modification age limit. =item B< 'ctx' > Specifies the limit context name. =item B< 'bas' > Specifies the base directory. =item B< 'dir' > Specifies the directory. =item B< 'rel' > Specifies an optional relative path. =back =cut sub _m_grep_dir ## no critic (Complex) { my ($slf, $ctx, $dir, $pat, $opt, $max) = @_; my ($arg, $bas, $fct, $flg, $f_f, $f_p, $f_r, $f_u, $f_v, $f_w, $rel, @sta, @tbl, %mod); # Abort if we can access to that directory $arg = ref($dir); if ($arg eq 'RDA::Value::Array') { ($bas, $rel) = @{$dir}; $rel = (defined($rel) && $rel->is_defined) ? $rel->eval_as_string : RDA::Object::Rda->current_dir; $dir = (defined($bas) && $bas->is_defined) ? RDA::Object::Rda->cat_dir($bas = $bas->eval_as_string, $rel) : undef; $flg = 0; } elsif ($arg =~ m/^RDA::Value::(Assoc|Hash)$/) { $arg = $dir->eval_as_data(1); if (exists($arg->{'bas'})) { $rel = defined($arg->{'rel'}) ? $arg->{'rel'} : RDA::Object::Rda->current_dir; $dir = defined($bas = $arg->{'bas'}) ? RDA::Object::Rda->cat_dir($bas, $rel) : undef; $flg = 0; } elsif (exists($arg->{'dir'})) { $bas = $dir = $arg->{'dir'}; $rel = RDA::Object::Rda->current_dir; $flg = 1; } else { $dir = undef; } if (exists($arg->{'ctx'})) { ($fct, $arg) = $slf->{'_lim'}->get_file_limit($arg->{'ctx'}); } elsif (exists($arg->{'age'})) { ($fct, $arg) = $slf->{'_lim'}->get_age_limit($arg->{'age'}); } } else { $bas = $dir; $rel = RDA::Object::Rda->current_dir; $flg = 1; } return @tbl unless $dir && opendir(DIR, $dir); $bas = q{} if $bas =~ m/^[\\\/]$/; # Decode the options $opt = q{} unless defined($opt); $pat = RDA::Object::View->is_pattern((index($opt, 'i') < 0) ? $pat : "$pat#i"); ($fct, $arg) = $slf->{'_lim'}->get_age_limit($1) if $opt =~ m/m(\d+(\.\d+)?)/; $f_f = index($opt, 'f') >= 0; $f_p = index($opt, 'p') >= 0; $f_r = index($opt, 'r') >= 0; $f_u = index($opt, 'u') >= 0; $f_v = index($opt, 'v') >= 0; $f_w = index($opt, 'w') >= 0; $f_p = 1 if $flg && $f_r; $max = 8 unless defined($max) && $max >= 0; ## no critic (Unless) # Read the directory content _grep_dir(\@tbl, $bas, $rel, $pat, 0, $max, $fct, $ctx, $arg, $f_f, $f_p, $f_r, $f_u, $f_v, $f_w); # Sort the file names when requested if (index($opt, 'd') >= 0) { return (sort { RDA::Object::Rda->dirname($a) cmp RDA::Object::Rda->dirname($b) || RDA::Object::Rda->basename($a) cmp RDA::Object::Rda->basename($b)} @tbl); } if (index($opt, 'n') >= 0) { return (sort {$a cmp $b} @tbl); } if (index($opt, 't') >= 0) { %mod = map {$_ => (@sta = stat($f_p ? $_ : RDA::Object::Rda->cat_file($bas, $_))) ? $sta[9] : 0} @tbl; ## no critic (Reverse) return (sort {$mod{$b} <=> $mod{$a} || $a cmp $b} keys(%mod)); } # Return the list of the files return @tbl; } sub _grep_dir ## no critic (Args,Complex) { my ($tbl, $bas, $dir, $pat, $lvl, $max, $fct, $ctx, $arg, $f_f, $f_p, $f_r, $f_u, $f_v, $f_w) = @_; my ($flg, $pth, $rel, $skp, @sub); # Read the directory content foreach my $nam (readdir(DIR)) { $rel = RDA::Object::Rda->cat_file($dir, $nam); next if $f_u && !defined($rel = RDA::Object::Rda->is_path($rel)); $pth = RDA::Object::Rda->cat_file($bas, $rel) if $fct || $f_p || $f_r; push(@sub, $rel) if $f_r && -d $pth && -r $pth && $nam !~ m/^\.+$/; next if $skp; $flg = $f_v ? ($nam !~ $pat) : ($nam =~ $pat); $flg = &$fct($ctx, $pth, $arg) if $flg && $fct; if ($flg) { if ($f_w) { push(@{$tbl}, ($f_p ? RDA::Object::Rda->cat_dir($bas, $dir) : $dir)); $skp = 1; } else { push(@{$tbl}, ($f_p ? $pth : $rel)); } if ($f_f) { $lvl = $max; last; } } } closedir(DIR); # Explore subdirectories unless (++$lvl > $max) ## no critic (Unless) { foreach my $sub (@sub) { next unless opendir(DIR, RDA::Object::Rda->cat_dir($bas, $sub)); _grep_dir($tbl, $bas, $sub, $pat, $lvl, $max, $fct, $ctx, $arg, $f_f, $f_p, $f_r, $f_u, $f_v, $f_w); return if $f_f && @{$tbl}; } } return; } =head2 S This macro returns the command output lines that match the regular expression. =head2 S This macro returns the file lines that match the regular expression. The following options are supported: =over 9 =item B< 'c' > Returns the match count instead of the match list =item B< 'f' > Stops scanning on the first match =item B< 'i' > Ignores case distinctions in both the pattern and the line =item B< 'j' > Joins continuation lines =item B< 'n' > Prefixes lines with a line number =item B< 'v' > Inverts the sense of matching to select non-matching lines =item B< (n) > Returns the (n)th capture buffer instead of the line. =back You can limit the number of matched lines to the specified number. When the number is positive, it returns the first matches only. When it is negative, it returns the last matches only. You can restrict the search to a line range. When the file is read completely, the macro stores the number of lines contained in the file and this number is accessible by the C macro. =cut sub _m_grep_cmd { my ($slf, $ctx, $cmd, $pat, @arg) = @_; my ($env, $err, $ifh, $pid, $pre, $tmp, @cln, @tbl); return () unless $cmd && $pat; return @{exe_command(\&_grep_in, [], $slf, $ctx, $cmd, 'OS', 1, $pat, @arg)}; } sub _m_grep_file { my ($slf, $ctx, $fil, $pat, @arg) = @_; my ($ifh); $ifh = IO::Handle->new; return () unless $fil && $pat && open($ifh, q{<}.$fil); ## no critic (Handle,Open) return @{_grep_in([], $slf, $ctx, $ifh, 1, 0, 0, 0, $pat, @arg)}; } sub _grep_in ## no critic (Args,Complex) { my ($tbl, $slf, $ctx, $ifh, $fil, $cmd, $lim, $pid, $pat, $opt, $lgt, $min, $max) = @_; my ($all, $beg, $cnt, $end, $f_c, $f_i, $f_n, $inc, $lin, $nxt, $pos, $sta); # Determine the options $min = 0 unless $min && $min > 0; ## no critic (Unless) $max = 0 unless $max && $max > 0; ## no critic (Unless) $opt = q{} unless defined($opt); $pat = RDA::Object::View->is_pattern((index($opt, 'i') < 0) ? $pat : "$pat#i"); $f_c = index($opt, 'c') >= 0; $f_i = index($opt, 'v') >= 0; $f_n = index($opt, 'n') >= 0; $inc = 0 if index($opt, 'j') >= 0; $pos = ($opt =~ m/(\d+)/) ? $1 : 0; # Check the file eval { local $SIG{'ALRM'} = sub { die "Alarm\n"; } if $lim; # Restrict the number of records returned $beg = $end = $cnt = 0; if ($lgt) { $beg = $lgt if $lgt > 0; $end = -$lgt if $lgt < 0; } elsif (index($opt, 'f') >= 0) { $beg = 1; } # Scan the file $all = 1; $lin = q{}; $tbl->[0] = 0 if $f_c; delete($slf->{'hdr'}); set_alarm($lim) if $lim; while (defined($lin = <$ifh>)) { $lin =~ s/[\r\n]+$//; if (defined($inc)) { $cnt += $inc; $inc = 0; while ($lin =~ s/\\$// && defined($nxt = <$ifh>)) { $nxt =~ s/[\r\n]+$//; $lin .= $nxt; $inc++; } } $lin =~ s/^\000+$//; $slf->{'hdr'} = $lin unless $cnt++; next if $cnt < $min; $all = 0; last if $max && $cnt > $max; if ($f_i xor $lin =~ $pat) { if ($f_c) { ++$tbl->[0]; } else { $lin = eval "\$$pos" if $pos; ## no critic (Eval) push(@{$tbl}, $f_n ? "$cnt:$lin" : $lin); last if $beg && (scalar @{$tbl}) == $beg; shift(@{$tbl}) if $end && (scalar @{$tbl}) > $end; } } $all = 1; } clear_alarm() if $lim; }; RDA::Object::Rda->kill_child($pid) if ($sta = $@) && $pid; close($ifh); if ($sta) { log_timeout($slf, $ctx, 'OS', $cmd); } elsif ($cmd) { $slf->{'err'} = $?; } $slf->{'lgt'} = $cnt if $all && $fil; # Return the matches return $tbl; } =head2 S This macro returns the lines in the last file/command buffer that match the regular expression. It supports the same options as C. =cut sub _m_grep_last ## no critic (Complex) { my ($slf, $ctx, $pat, $opt, $lgt, $min, $max) = @_; my ($beg, $buf, $cnt, $end, $f_c, $f_i, $f_n, $inc, $lin, $nxt, $pos, @tbl); if (exists($slf->{'_buf'}) && $pat) { # Determine the options $min = 0 unless $min && $min > 0; ## no critic (Unless) $max = 0 unless $max && $max > 0; ## no critic (Unless) $opt = q{} unless defined($opt); $pat = RDA::Object::View->is_pattern((index($opt, 'i') < 0) ? $pat : "$pat#i"); $f_c = index($opt, 'c') >= 0; $f_i = index($opt, 'v') >= 0; $f_n = index($opt, 'n') >= 0; $inc = 0 if index($opt, 'j') >= 0; $pos = ($opt =~ m/(\d+)/) ? $1 : 0; # Restrict the number of records returned $beg = $end = 0; if ($lgt) { $beg = $lgt if $lgt > 0; $end = -$lgt if $lgt < 0; } elsif (index($opt, 'f') >= 0) { $beg = 1; } # Check the file $tbl[0] = 0 if $f_c; $buf = $slf->{'_buf'}; $cnt = 0; while ($cnt <= $#$buf) { if (defined($inc)) { $cnt += $inc; $lin = $buf->[$cnt++]; $inc = 0; $lin .= $buf->[$inc++ + $cnt] while ($lin =~ s/\\$// && ($cnt + $inc) <= $#$buf); } else { $lin = $buf->[$cnt++]; } next if $cnt < $min; last if $max && $cnt > $max; if ($f_i xor $lin =~ $pat) { if ($f_c) { ++$tbl[0]; } else { $lin = eval "\$$pos" if $pos; ## no critic (Eval) push(@tbl, $f_n ? "$cnt:$lin" : $lin); last if $beg && (scalar @tbl) == $beg; shift(@tbl) if $end && (scalar @tbl) > $end; } } } } return @tbl; } =head2 S This macro indicates if the file is newer than the specified period. It returns a false value if it cannot obtain the status information of the file. =cut sub _m_is_newer { my ($slf, $ctx, $fil, $day, $sec) = @_; my (@sta); # Get the file information $ctx->check_stat($fil, @sta = stat($fil)); return 0 unless @sta; # Get the reference time $day = 0 unless defined($day); $sec = 0 unless defined($sec); # Check the modification time of the file return $sta[9] > (time - $day * 86400 - $sec); } =head2 S This macro indicates if the file is older than the specified period. It returns a false value if it cannot obtain the status information of the file. =cut sub _m_is_older { my ($slf, $ctx, $fil, $day, $sec) = @_; my (@sta); # Get the file information $ctx->check_stat($fil, @sta = stat($fil)); return 0 unless @sta; # Get the reference time $day = 0 unless defined($day); $sec = 0 unless defined($sec); # Check the modification time of the file return $sta[9] < (time - $day * 86400 - $sec); } =head2 S This macro indicates whether the current user is the owner of the specified file. =cut sub _m_is_owner { my ($slf, $ctx, $fil) = @_; my ($uid, @sta); $ctx->check_stat($fil, @sta = stat($fil)); return defined($fil) && defined($uid = $sta[4]) && $uid == $<; } =head2 S This macro sends a signal to a list of processes. It returns the number of processes successfully signaled, which is not necessarily the same as the number of processes killed. If the signal number is zero, then no signal is sent to the process. This is a useful way to check that a child process is alive and has not changed its user identifier. If the signal number is negative, then it kills process groups instead of processes. =cut sub _m_kill { my ($slf, $ctx, $sig, @pid) = @_; return kill($sig, @pid); } =head2 S This macro returns the last file produced by the C or C macro, quoted as appropriate to execute it in a shell. =cut sub _m_last_command { my $slf = shift; return RDA::Object::Rda->quote($slf->{'_fil'}); } =head2 S This macro returns the last directory produced by the C macro. =cut sub _m_last_dir { return shift->{'_dir'}; } =head2 S This macro returns the last file produced by the C or C macro. =cut sub _m_last_file { return shift->{'_fil'}; } =head2 S This macro returns the last native path produced by the C macro. =cut sub _m_last_native { return shift->{'_nat'}; } =head2 S This macro loads the result of the specified command. It returns 1 for a successful load. Otherwise, it returns 0. It saves the effective command exit code and it is accessible through the C macro. When the flag is set, the load is considered successful regardless of the exit code. It is possible to increase the execution limit by specifying an increasing factor as an argument. A negative or null (zero) value disables any timeout. It is possible to limit the number of lines loaded to the specified number also. When the number is positive, it loads the first lines only. When the number is negative, it loads the last lines only. =cut sub _m_load_cmd ## no critic (Complex) { my ($slf, $ctx, $cmd, $flg, $inc, $lgt) = @_; my ($pre, $ret, $sta); $slf->{'err'} = $ret = 0; ++$slf->{'_req'}; if (exists($slf->{'_wrk'})) { my ($err, $tmp); # Write the command output using a temporary file ($err, $sta, $tmp) = get_output($slf, $ctx, $cmd, 'OS', $inc); if (ref($tmp)) { $ret = _load_in($slf, $tmp->get_handle, $lgt); $slf->{'_wrk'}->clean_work($WRK); } elsif ($tmp) { $ret = _m_load_file($slf, $ctx, $tmp, $lgt); $slf->{'_wrk'}->clean_work($WRK); } # Indicate the successful completion $slf->{'err'} = $err; return $flg ? 1 : $err ? 0 : $ret unless $sta || !$tmp; ## no critic (Unless) $ret = 0; } else { my ($beg, $buf, $cnt, $end, $env, $lim, $pid, @cln); local $SIG{'__WARN__'} = sub { }; ($cmd, $pre, $env, $inc, @cln) = get_command($slf, $ctx, $cmd, $inc); if ($cmd) { $env = $slf->{'_sys'}->set_context($env) if $env; $slf->{'_col'}->log_start if $slf->{'_trc'}; if ($pid = open(IN, "$cmd |")) ## no critic (Handle,Open) { eval { $lim = get_alarm($slf, $inc); local $SIG{'ALRM'} = sub { die "Alarm\n"; } if $lim; # Restrict the number of lines loaded $beg = $end = $cnt = 0; if ($lgt) { $beg = $lgt if $lgt > 0; $end = -$lgt if $lgt < 0; } # Load the command result, taking care on end-of-lines $slf->{'_buf'} = $buf = []; delete($slf->{'hdr'}); set_alarm($lim) if $lim; while () { s/[\r\n]+$//; s/^\000+$//; $slf->{'hdr'} = $_ unless $cnt++; push(@{$buf}, $_); last if $beg && (scalar @{$buf}) == $beg; if ($end && (scalar @{$buf}) > $end) { shift(@{$buf}); --$cnt; } } # Disable the alarm clear_alarm() if $lim; }; RDA::Object::Rda->kill_child($pid) if ($sta = $@) && $pid; close(IN); $slf->{'cnt'} = $cnt; unless ($sta) { $slf->{'err'} = $?; $slf->{'_col'}->log_end($ctx, $pre.$cmd) if $slf->{'_trc'}; $slf->{'_sys'}->restore_context($env) if $env; for (@cln) { $slf->{'_col'}->clean_work($_); } return $flg ? 1 : $slf->{'err'} ? 0 : 1; } log_timeout($slf, $ctx, 'OS', $pre.$cmd); $ret = 0; } else { $slf->{'err'} = $?; $ret = 1 if $flg; } $slf->{'_col'}->log_end($ctx, $pre.$cmd) if $slf->{'_trc'}; $slf->{'_sys'}->restore_context($env) if $env; for (@cln) { $slf->{'_col'}->clean_work($_); } } elsif ($pre) { _load_in($slf, $pre->get_handle, $lgt); return 1; } } # Indicate the error delete($slf->{'_buf'}); $slf->{'cnt'} = 0; return $ret; } =head2 S This macro loads the content of the file. It returns 1 for a successful completion. Otherwise, it returns 0. It is possible to limit the number of lines loaded to the specified number. When the number is positive, it loads the first lines only. When the number is negative, it loads the last lines only. =cut sub _m_load_file { my ($slf, $ctx, $fil, $lgt) = @_; my ($beg, $buf, $cnt, $end, $ifh); $slf->{'err'} = 0; $ifh = IO::Handle->new; return _load_in($slf, $ifh, $lgt) if $fil && open($ifh, "<$fil"); ## no critic (Handle,Open) # Indicate the error delete($slf->{'_buf'}); return $slf->{'cnt'} = 0; } sub _load_in { my ($slf, $ifh, $lgt) = @_; my ($beg, $buf, $cnt, $end); # Restrict the number of lines loaded $beg = $end = 0; if ($lgt) { $beg = $lgt if $lgt > 0; $end = -$lgt if $lgt < 0; } # Load the file, taking care on end-of-lines $slf->{'_buf'} = $buf = []; $cnt = 0; delete($slf->{'hdr'}); while (<$ifh>) { s/[\r\n]+$//; s/^\000+$//; $slf->{'hdr'} = $_ unless $cnt++; push(@{$buf}, $_); last if $beg && (scalar @{$buf}) == $beg; if ($end && (scalar @{$buf}) > $end) { shift(@{$buf}); --$cnt; } } close($ifh); $slf->{'cnt'} = $cnt; # Indicate the successful completion return 1; } =head2 S or S This macro loads the character sequences that match the pattern. You can limit the number of extractions by specifying its limit as an extra argument. It returns 1 for a successful completion. Otherwise, it returns 0. =cut sub _m_load_string { my ($slf, $ctx, $fil, $pat, $max) = @_; my ($ifh); $slf->{'cnt'} = $slf->{'err'} = 0; if ($pat) { # Treat a buffer if (ref($fil) eq 'RDA::Object::Buffer') { _load_string($slf, $fil->get_handle, $pat, $max); return 1; } # Treat a file $ifh = IO::File->new; if ($ifh->open("<$fil")) { binmode($ifh); _load_string($slf, $ifh, $pat, $max); $ifh->close; return 1; } } # Indicate the error delete($slf->{'_buf'}); return 0; } sub _load_string { my ($slf, $ifh, $pat, $max) = @_; my ($buf, $nxt); $slf->{'_buf'} = []; for ($buf = q{} ## no critic (Loop) ; $ifh->sysread($buf, 65536, length($buf)) ; $buf = $nxt) { $nxt = ($buf =~ s/([\040-\176]+)$//) ? $1 : q{}; foreach my $str ($buf =~ m{($pat)}g) { push(@{$slf->{'_buf'}}, $str); ++$slf->{'cnt'}; return if $max && $slf->{'cnt'} >= $max; } } if ($nxt =~ $pat) { push(@{$slf->{'_buf'}}, $nxt); ++$slf->{'cnt'}; } return; } =head2 S This macro returns the value of a symbolic link, if symbolic links are implemented. When not applicable, it returns the default value. =cut sub _m_read_link { my ($slf, $ctx, $fil, $dft) = @_; if (defined($fil) && -l $fil) { $fil = eval {readlink($fil)}; return $fil unless $@; } return $dft; } =head2 S or S This macro indicates whether two directory or file paths are identical. For VMS and for Windows, it ignores case differences. No path cleanup is performed. =cut ## no critic (Numbered) sub _m_same_file { my ($slf, $ctx, $fil1, $fil2) = @_; return $fil1 && $fil2 && &{$slf->{'_sam'}}($fil1, $fil2); } sub _same_c { my ($fil1, $fil2) = @_; return $fil1 eq $fil2; } sub _same_i { my ($fil1, $fil2) = @_; return $fil1 eq $fil2 || lc($fil1) eq lc($fil2) || RDA::Object::Rda->native($fil1) eq RDA::Object::Rda->native($fil2) || RDA::Object::Rda->short($fil1, 1) eq RDA::Object::Rda->short($fil2, 1); } ## use critic; =head2 S This macro sets the timeout for executing operating system commands, specified in seconds, only if the value is greater than zero. Otherwise, the timeout mechanism is disabled. It is disabled also if the alarm function is not implemented or when the execution times must be recorded. It returns the effective value. =cut sub _m_set_timeout { my ($slf, $ctx, $val) = @_; return $slf->{'lim'} = $slf->{'_trc'} ? 0 : check_alarm($val); } =head2 S This macro sorts the last file buffer according to the specified criteria. It returns the number of records on successful completion. Otherwise, it returns 0. The following sort types are supported: =over 12 =item B< ps_time> Sorts the C lines by decreasing CPU time. =back It ignores empty lines. Lines that do not contain the sort field are placed at the top of the list. =cut sub _m_sort_last { my ($slf, $ctx, $typ) = @_; my ($fct, $key, $new, $nxt, $off, $rec, @tbl); if (exists($slf->{'_buf'}) && $typ && exists($tb_srt{$typ})) { # Get the sort key function key $new = []; $rec = $tb_srt{$typ}; $rec = $rec->{exists($rec->{$^O}) ? $^O : q{?}}; $fct = $rec->[0]; $off = $rec->[1]; # Create the sort key foreach my $lin (@{$slf->{'_buf'}}) { if (defined($key = &$fct($lin, \$nxt, $off))) { push(@tbl, [$key, $nxt, $lin]); } elsif ($lin !~ m/^\s*$/) { push(@{$new}, $lin); } } # Sort the records foreach my $rec (sort {$b->[0] <=> $a->[0] || ## no critic (Reverse) $b->[1] cmp $a->[1]} @tbl) { push(@{$new}, $rec->[2]); } $slf->{'_buf'} = $new; # Return the number of records return scalar @{$new}; } return 0; } sub _sort_ps_hms { my ($lin, $nxt, $off) = @_; $lin = substr($lin, $off); return unless $lin =~ m/\s(((\d+)-)?(\d+)\:)?(\d+)\:(\d+)\s+(.*)/; $$nxt = $7; my $tps = $5 * 60 + $6; $tps += $4 * 3600 if $4; $tps += $3 * 86400 if $3; return $tps; } sub _sort_ps_hmsc { my ($lin, $nxt, $off) = @_; # Possible formats: # 2-16:17:48 # 04:00:14 # 0:01.31 $lin = substr($lin, $off); return unless $lin =~ m/\s(((\d+)-)?(\d+)\:)?(\d+)\:(\d+)(\.(\d+))?\s+(.*)/; $$nxt = $9; my $tps = $5 * 60 + $6; $tps += $4 * 3600 if $4; $tps += $3 * 86400 if $3; $tps += $8 / 100 if $8; return $tps; } sub _sort_ps_hmsw { my ($lin, $nxt, $off) = @_; $$nxt = substr($lin, 64, 12); $lin = substr($lin, $off); return unless $lin =~ m/\s(\d+)\:(\d+)\:(\d+)\s/; return $1 * 3600 + $2 * 60 + $3; } sub _sort_ps_ms { my ($lin, $nxt) = @_; return unless $lin =~ m/\s(\d+)\:(\d+)\s+(.*)/; $$nxt = $3; return $1 * 60 + $2; } sub _sort_ps_msc { my ($lin, $nxt) = @_; return unless $lin =~ m/\s(\d+)\:(\d+\.\d+)\s+(.*)/; $$nxt = $3; return $1 * 60 + $2; } =head2 S This macro splits the directory in its components. When a base directory is specified, only the relative part is returned. =cut sub _m_split_dir { my ($slf, $ctx, $dir, $bas) = @_; my ($top, @bas, @dir, @rel); if (defined($dir)) { @dir = RDA::Object::Rda->split_dir($dir); if (defined($bas) && length($bas)) { ($top, @bas) = RDA::Object::Rda->split_dir($bas); @rel = @dir; if (shift(@rel) eq $top) { @bas = grep {$_ ne q{}} @bas; @rel = grep {$_ ne q{}} @rel; return @rel unless @bas ## no critic (Unless) && RDA::Object::Rda->short( RDA::Object::Rda->cat_dir($top, splice(@rel, 0, @bas)), 1) ne RDA::Object::Rda->short( RDA::Object::Rda->cat_dir($top, @bas), 1); } } } return @dir; } =head2 S This macro returns the exit status of the last command executed. =cut sub _m_status { return shift->{'err'}; } =head2 S This macro executes an operating system command and returns the exit status. =cut sub _m_system { my ($slf, $ctx, @arg) = @_; my ($cmd, $env, $pre, @cln); $slf->{'err'} = 0; ++$slf->{'_req'}; if ((scalar @arg) > 1) { die get_string('IS_TAINTED', $cmd) if RDA::Object->is_tainted($cmd = join(q{ }, @arg)); $slf->{'_col'}->log_start if $slf->{'_trc'}; $slf->{'err'} = system(@arg); $slf->{'_col'}->log_end($ctx, $cmd) if $slf->{'_trc'}; } else { ($cmd, $pre, $env, undef, @cln) = get_command($slf, $ctx, $arg[0]); if ($cmd) { # Execute the command, storing all resulting lines as a list $env = $slf->{'_sys'}->set_context($env) if $env; $slf->{'_col'}->log_start if $slf->{'_trc'}; $slf->{'err'} = system($cmd); $slf->{'_col'}->log_end($ctx, $pre.$cmd) if $slf->{'_trc'}; $slf->{'_sys'}->restore_context($env) if $env; for (@cln) { $slf->{'_col'}->clean_work($_); } } } return $slf->{'err'}; } =head2 S This macro returns the first command from the list that executes successfully. Otherwise, it returns an undefined value. Specified commands should complete their execution quickly and produce less output. =cut sub _m_test_cmd { my ($slf, $ctx, @arg) = @_; my ($cmd, $env, $pre, $sta, @cln); foreach my $arg (@arg) { ($cmd, $pre, $env, undef, @cln) = get_command($slf, $ctx, $arg, 1, 1); next unless $cmd; $env = $slf->{'_sys'}->set_context($env) if $env; eval { local $SIG{'__WARN__'} = sub { }; local $SIG{'PIPE'} = 'IGNORE'; $cmd = cnv_command($slf, "$cmd 2>&1"); open(PIPE, "$cmd |") or die "Bad open\n"; ## no critic (Handle,Open) while () { ; # Need a loop to prevent pipe errors on platforms like AIX } close(PIPE) or die "Bad close\n";; }; $sta = $@ || $?; $slf->{'_sys'}->restore_context($env) if $env; for (@cln) { $slf->{'_col'}->clean_work($_); } return new_from_data($arg) unless $sta; } return $VAL_UNDEF; } =head2 S =for stopwords umask This macro sets the umask for the process to the specified value and returns the previous value. To specify an octal representation, you can use a string starting with a zero. If the argument is omitted, then it returns the current umask. =cut sub _m_umask { my ($slf, $ctx, $msk) = @_; return umask unless defined($msk); $msk = oct($msk) if $msk =~ m/^0/; return umask($msk); } =head2 S This macro writes the result of the specified command in the report file. It returns 1 for successful completion. Otherwise, it returns 0. It stores the effective command exit code. This code is accessible through the C macro. When the flag is set, the write is considered successful regardless of the exit code. It is possible to increase the execution limit by specifying an increasing factor as an argument. A non-positive value disables any timeout. =cut sub _m_write_cmd { my ($slf, $ctx, $arg, @arg) = @_; my ($rpt); return (ref($arg) =~ $RPT) ? _s_write_cmd($slf, $ctx, $arg, @arg) : ($rpt = $ctx->get_report) ? _s_write_cmd($slf, $ctx, $rpt, $arg, @arg) : 0; } sub _s_write_cmd ## no critic (Complex) { my ($slf, $ctx, $rpt, $cmd, $flg, $inc) = @_; my ($ret, $sta, @cln); $slf->{'err'} = $ret = 0; ++$slf->{'_req'}; if (exists($slf->{'_wrk'})) { my ($err, $tmp); # Write the command output using a temporary file ($err, $sta, $tmp) = get_output($slf, $ctx, $cmd, 'OUT', $inc); if (ref($tmp)) { $ret = $rpt->write_file($tmp, ['C', $cmd]); $slf->{'_wrk'}->clean_work($WRK); } elsif ($tmp) { $ret = (-s $tmp) ? $rpt->write_file($tmp, ['C', $cmd]) : 0; $slf->{'_wrk'}->clean_work($WRK); } # Indicate the successful completion $slf->{'err'} = $err; return $flg ? 1 : $err ? 0 : $ret unless $sta; $ret = 0; } else { my ($env, $lim, $ofh, $pid, $pre); local $SIG{'__WARN__'} = sub { }; ($cmd, $pre, $env, $inc, @cln) = get_command($slf, $ctx, $cmd, $inc); if ($cmd) { $env = $slf->{'_sys'}->set_context($env) if $env; $slf->{'_col'}->log_start if $slf->{'_trc'}; if ($pid = open(IN, "$cmd |")) ## no critic (Handle,Open) { eval { $lim = get_alarm($slf, $inc); local $SIG{'ALRM'} = sub { die "Alarm\n"; } if $lim; # Load the command result, taking care on end-of-lines set_alarm($lim) if $lim; while () { s/[\r\n]+$//; s/^\000+$//; unless ($ofh) { $lim = clear_alarm() + 1 if $lim; $ofh = $rpt->get_handle; $rpt->begin_block(1); set_alarm($lim) if $lim; } $rpt->write("$_\n") if $ofh; } # Disable the alarm clear_alarm() if $lim; }; RDA::Object::Rda->kill_child($pid) if ($sta = $@) && $pid; close(IN); $rpt->end_block(['C', $cmd]) if $ofh; # Indicate the successful completion unless ($sta) { $slf->{'err'} = $?; $slf->{'_col'}->log_end($ctx, $pre.$cmd) if $slf->{'_trc'}; $slf->{'_sys'}->restore_context($env) if $env; for (@cln) { $slf->{'_col'}->clean_work($_); } return $flg ? 1 : $slf->{'err'} ? 0 : 1; } log_timeout($slf, $ctx, 'OS', $pre.$cmd); } else { $slf->{'err'} = $?; $ret = 1 if $flg; } $slf->{'_col'}->log_end($ctx, $pre.$cmd) if $slf->{'_trc'}; $slf->{'_sys'}->restore_context($env) if $env; for (@cln) { $slf->{'_col'}->clean_work($_); } } elsif ($pre) { $ret = $rpt->write_file($pre, ['C', $cmd]); } } # Indicate the error return $ret; } =head2 S This macro writes a line range from the last file/command buffer in the output file. It assumes the first and last line as default for the range definition. You can use negative line numbers to specify lines from the buffer end. It returns 1 for a successful completion. Otherwise, it returns 0. =cut sub _m_write_last { my ($slf, $ctx, $arg, @arg) = @_; my ($rpt); return (ref($arg) =~ $RPT) ? _s_write_last($slf, $ctx, $arg, @arg) : ($rpt = $ctx->get_report) ? _s_write_last($slf, $ctx, $rpt, $arg, @arg) : 0; } sub _s_write_last { my ($slf, $ctx, $rpt, $min, $max, $idx, @cat) = @_; my ($buf); if (exists($slf->{'_buf'})) { # Validate the range $buf = $slf->{'_buf'}; $min = (!defined($min) || ($#$buf + $min) < -1) ? 0 : ($min < 0) ? $#$buf + $min + 1 : $min; $max = (!defined($max)) ? $#$buf : (($#$buf + $max) < -1) ? 0 : ($max < 0) ? $#$buf + $max + 1 : ($max > $#$buf) ? $#$buf : $max; # Write the file to the report file, taking care on end-of-lines $rpt->begin_block(1); foreach my $lin (@{$buf}[$min..$max]) { $rpt->write("$lin\n"); } $rpt->end_block($idx, @cat); # Indicate the successful completion return 1; } return 0; } 1; __END__ =head1 COMMAND SPECIFICATIONS The C, C, C, C, C, C, C, and C macros support the following variants for the command argument: =over 2 =item o A string =item o An array of strings =item o A hash describing the command =back The command hash can contain the following keys: =over 11 =item S< B<'cmd'> > Specifies the command (string or array) =item S< B<'env'> > Specifies environment alterations for the command. =item S< B<'flg'> > When true, does not transform the command. =item S< B<'inc'> > When present, specifies the timeout incremental ratio. =item S< B<'pwd'> > Controls password injection. =item S< B<'pwf'> > Controls password file use. =item S< B<'pre'> > Trace command prefix. =item S< B<'sap'> > When true, uses a short absolute path for password file. =item S< B<'src'> > Specifies a file to source before executing the command. =back When a command is in an array format, RDA obtains the command by joining all defined array items with spaces. The C, C, C, C, and C macros can reuse a previous execution identified by the value of a C key. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, L, L, L =head1 COPYRIGHT NOTICE Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved. =head1 TRADEMARK NOTICE Oracle and Java are registered trademarks of Oracle and/or its affiliates. Other names may be trademarks of their respective owners. =cut