App-Framework-Lite
view release on metacpan or search on metacpan
lib/App/Framework/Lite.pm view on Meta::CPAN
$this->_dbg_prt(["Options: append_args() new=", $args_aref], 2) ;
$this->_dbg_prt(["combined=", \@combined_args], 2) ;
## Build new set of args
$this->update() ;
return @combined_args ;
}
#----------------------------------------------------------------------------
=item B< update() >
Take the list of args (created by calls to L</append_args>) and process the list into the
final args list.
Each entry in the ARRAY is an ARRAY ref containing:
[ <arg spec>, <arg summary>, <arg description>, <arg default> ]
Returns the hash of args/values
=cut
sub update
{
my $this = shift ;
$this->_dbg_prt(["Args: update()\n"]) ;
## get user settings
my $args_aref = $this->{user_args} ;
## set up internals
# rebuild these
my $args_href = {} ;
# keep full details
my $args_names_href = {} ;
## fill args_href, get_args_aref
my $args_list = [] ;
# Cycle through
my $optional = 0 ;
my $last_dest_type ;
foreach my $arg_entry_aref (@$args_aref)
{
$this->_dbg_prt(["Arg entry=", $arg_entry_aref], 2) ;
my ($arg_spec, $summary, $description, $default_val) = @$arg_entry_aref ;
## Process the arg spec
my ($name, $pod_spec, $dest_type, $arg_type, $arg_direction, $arg_optional, $arg_append, $arg_mode) ;
($name, $arg_spec, $pod_spec, $dest_type, $arg_type, $arg_direction, $arg_optional, $arg_append, $arg_mode) =
$this->_process_arg_spec($arg_spec) ;
if ($last_dest_type)
{
$this->throw_fatal("Application definition error: arg $name defined after $last_dest_type defined as array") ;
}
$last_dest_type = $name if $dest_type ;
# Set default if required
$args_href->{$name} = $default_val if (defined($default_val)) ;
# See if optional
$arg_optional++ if defined($default_val) ;
if ($optional && !$arg_optional)
{
$this->throw_fatal("Application definition error: arg $name should be optional since previous arg is") ;
}
$optional ||= $arg_optional ;
$this->_dbg_prt(["Args: update() - arg_optional=$arg_optional optional=$optional\n"]) ;
# Create full entry
my $href = $this->_new_arg_entry($name, $arg_spec, $summary, $description, $default_val, $pod_spec, $arg_type, $arg_direction, $dest_type, $optional, $arg_append, $arg_mode) ;
$args_names_href->{$name} = $href ;
$this->_dbg_prt(["Arg $name HASH=", $href], 2) ;
# save arg in specified order
push @$args_list, $name ;
}
$this->_dbg_prt(["update() - END\n"], 2) ;
## Save
$this->{arg_names} = $args_list ;
$this->{_args} = $args_href ;
$this->{_arg_names_hash} = $args_names_href ;
return %$args_href ;
}
#-----------------------------------------------------------------------------
=item B< check_args() >
At start of application, check the arguments for valid files etc.
=cut
sub check_args
{
my $this = shift ;
# specified args
my $argv_aref = $this->{argv} ;
# values
my $args_href = $this->{_args} ;
# details
my $arg_names_href = $this->{_arg_names_hash} ;
# File handles
my $fh_aref = $this->{_fh_list} ;
$this->_dbg_prt(["check_args() Names=", $arg_names_href, "Values=", $args_href, "Name list=", $this->{arg_names}], 2) ;
## Check feature settings
my ($open_out, $open_in) = (1, 1) ;
my $feature_args = $this->{args_feature_args} ;
if ($feature_args =~ m/open\s*=\s*(out|in|no)/i)
{
if ($1 =~ /out/i)
{
++$open_out ;
lib/App/Framework/Lite.pm view on Meta::CPAN
}
if ($arg_entry_href->{'type'} eq 'd')
{
$type = "directory" ;
}
if ($type)
{
my $direction = "input " ;
if ($arg_entry_href->{'direction'} eq 'o')
{
$direction = "output " ;
}
$type = " ($direction $type)" ;
}
my $suffix = "" ;
if ($arg_entry_href->{'dest_type'})
{
$suffix = "(s)" ;
}
if ($arg_entry_href->{'optional'})
{
$synopsis .= 'I<[' ;
}
else
{
$synopsis .= 'B<' ;
}
$synopsis .= "{$arg_name$type$suffix}" ;
$synopsis .= ']' if $arg_entry_href->{'optional'} ;
$synopsis .= '> ' ;
}
# set our best guess
$this->{synopsis} = $synopsis ;
}
return $synopsis ;
}
#============================================================================================
# RUN
#============================================================================================
#-----------------------------------------------------------------------------
=item B<required([$required_href])>
Get/set the required programs list. If specified, B<$required_href> is a HASH ref where the
keys are the names of the required programs (the values are unimportant).
This method returns the B<$required_href> HASH ref having set the values associated with the
program name keys to the path for that program. Where a program is not found then
it's path is set to undef.
Also, if the L</on_error> field is set to 'warning' or 'fatal' then this method throws a warning
or fatal error if one or more required programs are not found. Sets the message string to indicate
which programs were not found.
=cut
sub required
{
my $this = shift ;
my ($new_required_href) = @_ ;
my $required_href = $this->{'required'} ;
if ($new_required_href)
{
## Test for available executables
foreach my $exe (keys %$new_required_href)
{
# only do this is we have File::Which
if ($AVAILABLE_MOD{'File::Which'})
{
$required_href->{$exe} = which($exe) ;
}
else
{
$required_href->{$exe} = 1 ;
}
}
## check for errors
my $throw = $this->_throw_on_error($this->{on_error}) ;
if ($throw)
{
my $error = "" ;
foreach my $exe (keys %$new_required_href)
{
if (!$required_href->{$exe})
{
$error .= " $exe\n" ;
}
}
if ($error)
{
$this->$throw("The following programs are required but not available:\n$error\n") ;
}
}
}
return $required_href ;
}
#--------------------------------------------------------------------------------------------
=item B<run( [args] )>
Execute a command if B<args> are specified. Whether B<args> are specified or not, always returns the run object.
This method has reasonably flexible arguments which can be one of:
=item (%args)
The args HASH contains the information needed to set the L</FIELDS> and then run teh command for example:
('cmd' => 'ping', 'args' => $host)
=item ($cmd)
You can specify just the command string. This will be treated as if you had called the function with:
('cmd' => $cmd)
=item ($cmd, $args)
You can specify the command string and the arguments string. This will be treated as if you had called the function with:
('cmd' => $cmd, 'args' => $args)
NOTE: Need to get B<run> object from application to access this method. This can be done as one of:
$app->run()->run(.....);
or
my $run = $app->run() ;
$run->run(....) ;
=cut
sub run
{
my $this = shift ;
my (@args) = @_ ;
# # See if this is a class call
# $this = $this->check_instance() ;
$this->_dbg_prt(["run() this=", $this], 2) ;
$this->_dbg_prt(["run() args=", \@args]) ;
my %args ;
if (@args == 1)
{
$args{'cmd'} = $args[0] ;
}
elsif (@args == 2)
{
if ($args[0] ne 'cmd')
{
# not 'cmd' => '....' so treat as ($cmd, $args)
$args{'cmd'} = $args[0] ;
$args{'args'} = $args[1] ;
}
else
{
%args = (@args) ;
}
}
else
{
%args = (@args) ;
}
## return immediately if no args
return $this unless %args ;
## create local copy of variables
my %local = $this->vars() ;
# Set any specified args
foreach my $key (keys %local)
{
$local{$key} = $args{$key} if exists($args{$key}) ;
}
## set any 'special' vars
my %set ;
foreach my $key (qw/debug/)
{
$set{$key} = $args{$key} if exists($args{$key}) ;
}
$this->set(%set) if keys %set ;
# Get command
my $cmd = $local{'cmd'} ;
$this->throw_fatal("command not specified") unless $cmd ;
# Add niceness
my $nice = $local{'nice'} ;
if (defined($nice))
{
$cmd = "nice -n $nice $cmd" ;
}
# clear vars
$this->set(
'status' => 0,
'results' => [],
'error_str' => "",
) ;
# Check arguments
my $args = $this->_check_run_args($local{'args'}) ;
# Run command and save results
my @results ;
my $rc ;
## Logging
$this->_logging('cmd', "RUN: $cmd $args\n") ;
my $timeout = $local{'timeout'} ;
if ($local{'dryrun'})
{
## Print
my $timeout_str = $timeout ? "[timeout after $timeout secs]" : "" ;
print "RUN: $cmd $args $timeout_str\n" ;
}
else
{
## Run
if (defined($timeout))
{
# Run command with timeout
($rc, @results) = $this->_run_timeout($cmd, $args, $timeout, $local{'progress'}, $local{'check_results'}) ;
}
else
{
# run command
($rc, @results) = $this->_run_cmd($cmd, $args, $local{'progress'}, $local{'check_results'}) ;
}
}
# Update vars
$this->{'status'} = $rc ;
chomp foreach (@results) ;
$this->{'results'} = \@results ;
$this->_logging('results', \@results) ;
$this->_logging('status', "Status: $rc\n") ;
## Handle non-zero exit status
my $throw = $this->_throw_on_error($local{'on_error'}) ;
if ($throw && $rc)
{
my $results = join("\n", @results) ;
my $error_str = $local{'error_str'} ;
$this->$throw("Command \"$cmd $args\" exited with non-zero error status $rc : \"$error_str\"\n$results\n") ;
}
return($this) ;
}
#----------------------------------------------------------------------------
=item B< Run([%args]) >
Alias to L</run>
=cut
*Run = \&run ;
#--------------------------------------------------------------------------------------------
=item B<results()>
Run: Retrieve the results output from the last run. Results are returned as an ARRAY ref to the lines of
output
=cut
sub results
{
my $this = shift ;
return $this->{'results'} ;
}
#--------------------------------------------------------------------------------------------
=item B<status()>
Run: Retrieve the exit status of the last run.
=cut
sub status
{
my $this = shift ;
return $this->{'status'} ;
}
#--------------------------------------------------------------------------------------------
=item B<on_error( [$on_error] )>
Run: Set/get the on_error field.
=cut
sub on_error
{
my $this = shift ;
my ($on_error) = @_ ;
$this->{'on_error'} = $on_error if (defined($on_error)) ;
lib/App/Framework/Lite.pm view on Meta::CPAN
@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 ($@)
{
$rc ||= 1 ;
if ($@ eq "timeout\n")
{
print "timed out - stopping command pid=$pid...\n" if $this->{'debug'} ;
# timed out - stop command
kill('INT', $pid) ;
}
else
{
print "unexpected end of program : $@\n" if $this->{'debug'} ;
# Failed
alarm(0) ;
$this->throw_fatal( "Unexpected error while timing out command \"$cmd $args\": $@" ) ;
}
}
alarm(0) ;
print "exit program\n" if $this->{'debug'} ;
# if it's defined, call the results checker for each line
$rc ||= $this->_check_results(\@results, $check_results) ;
return($rc, @results) ;
}
#----------------------------------------------------------------------
# Check the results calling the check_results() hook if defined
#
sub _check_results
{
my $this = shift ;
my ($results_aref, $check_results) = @_ ;
my $rc = 0 ;
# If it's defined, run the check results hook
if (defined($check_results))
{
$rc = &$check_results($results_aref) ;
}
return $rc ;
}
#----------------------------------------------------------------------
# If the 'on_error' setting is not 'status' then return the "throw" type
#
sub _throw_on_error
{
my $this = shift ;
my ($on_error) = @_ ;
$on_error ||= $ON_ERROR_DEFAULT ;
my $throw = "";
if ($on_error ne 'status')
{
$throw = 'throw_fatal' ;
if ($on_error =~ m/warn/i)
{
$throw = 'throw_warning' ;
}
}
return $throw ;
}
#============================================================================================
# LOGGING
#============================================================================================
#----------------------------------------------------------------------------
=item B<logging($arg1, [$arg2, ....])>
Log the argument(s) to the log file iff a log file has been specified.
The list of arguments may be: SCALAR, ARRAY reference, HASH reference, SCALAR reference. SCALAR and SCALAR ref are printed
as-is without any extra newlines. ARRAY ref is printed out one entry per line with a newline added. The HASH ref is printed out
in the format produced by L<App::Framework::Base::Object::DumpObj>.
=cut
sub logging
{
my $this = shift ;
my (@args) = @_ ;
my $tolog = "" ;
foreach my $arg (@args)
{
if (ref($arg) eq 'ARRAY')
{
foreach (@$arg)
{
$tolog .= "$_\n" ;
}
}
elsif (ref($arg) eq 'HASH')
{
# $tolog .= prtstr_data($arg) . "\n" ;
}
elsif (ref($arg) eq 'SCALAR')
{
$tolog .= $$arg ;
}
elsif (!ref($arg))
{
$tolog .= $arg ;
}
else
{
# $tolog .= prtstr_data($arg) . "\n" ;
}
}
## Log
my $logfile = $this->{logfile} ;
if ($logfile)
{
## start if we haven't yet
if (!$this->{_started})
{
$this->_start_logging() ;
}
open my $fh, ">>$logfile" or $this->throw_fatal("Error: unable to append to logfile \"$logfile\" : $!") ;
print $fh $tolog ;
close $fh ;
}
## Echo
if ($this->{to_stdout})
{
print $tolog ;
}
return($this) ;
}
#----------------------------------------------------------------------------
=item B<echo_logging($arg1, [$arg2, ....])>
Same as L</logging> but echoes output to STDOUT.
=cut
sub echo_logging
{
my $this = shift ;
my (@args) = @_ ;
# Temporarily force echoing to STDOUT on, then do logging
my $to_stdout = $this->{to_stdout} ;
$this->{to_stdout} = 1 ;
$this->logging(@args) ;
$this->{to_stdout} = $to_stdout ;
return($this) ;
}
#----------------------------------------------------------------------------
=item B< Logging([%args]) >
Alias to L</logging>
=cut
*Logging = \&logging ;
#----------------------------------------------------------------------------
#
#=item B<_start_logging()>
#
#Create/append log file
#
#=cut
#
sub _start_logging
{
my $this = shift ;
my $logfile = $this->{logfile} ;
if ($logfile)
{
my $mode = ">" ;
if ($this->{mode} eq 'append')
{
$mode = ">>" ;
}
open my $fh, "$mode$logfile" or $this->throw_fatal("Unable to write to logfile \"$logfile\" : $!") ;
close $fh ;
## set flag
$this->{_started} = 1 ;
}
}
#============================================================================================
# UTILITY
#============================================================================================
#----------------------------------------------------------------------------
=item B<expand_keys($hash_ref, $vars_aref)>
Processes all of the HASH values, replacing any variables with their contents. The variable
values are taken from the ARRAY ref I<$vars_aref>, which is an array of hashes. Each hash
containing variable name / variable value pairs.
The HASH values being expanded can be either scalar, or an ARRAY ref. In the case of the ARRAY ref each
ARRAY entry must be a scalar (e.g. an array of file lines).
=cut
sub expand_keys
{
my $this = shift ;
my ($hash_ref, $vars_aref, $_state_href, $_to_expand) = @_ ;
print "expand_keys($hash_ref, $vars_aref)\n" if $this->{debug};
$this->prt_data("vars=", $vars_aref, "hash=", $hash_ref) if $this->{debug} ;
my %to_expand = $_to_expand ? (%$_to_expand) : (%$hash_ref) ;
if (!$_state_href)
{
## Top-level
my %data_ref ;
# create state HASH
$_state_href = {} ;
# scan through hash looking for variables
%to_expand = () ;
foreach my $key (keys %$hash_ref)
{
my @vals ;
if (ref($hash_ref->{$key}) eq 'ARRAY')
{
@vals = @{$hash_ref->{$key}} ;
}
elsif (!ref($hash_ref->{$key}))
{
push @vals, $hash_ref->{$key} ;
}
## Set up state - provide a level of indirection so that we can handle the case where multiple keys point to the same data
my $ref = $hash_ref->{$key} || '' ;
if ($ref && exists($data_ref{"$ref"}))
{
lib/App/Framework/Lite.pm view on Meta::CPAN
## use current HASH values before vars
if (defined $hash_ref->{$var})
{
print " ## var=$var current state=${$_state_href->{$var}}\n" if $this->{debug};
if (${$_state_href->{$var}} eq 'to_expand')
{
print " ## var=$var call expand..\n" if $this->{debug};
# go expand it first
$this->expand_keys($hash_ref, $vars_aref, $_state_href, {$var => 1}) ;
}
if (${$_state_href->{$var}} eq 'expanded')
{
print " ## var=$var already expanded\n" if $this->{debug};
$replace = $hash_ref->{$var}; # expand variable
$replace = join("\n", @{$hash_ref->{$var}}) if (ref($hash_ref->{$var}) eq 'ARRAY') ;
}
}
print " ## var=$var can replace from hash=$replace\n" if $this->{debug};
## If not found, use vars
if (!$replace)
{
## use vars
foreach my $href (@$vars_aref)
{
if (defined $href->{$var})
{
$replace = $href->{$var}; # expand variable
$replace = join("\n", @{$hash_ref->{$var}}) if (ref($href->{$var}) eq 'ARRAY') ;
print " ## found var=$var replace=$replace\n" if $this->{debug};
last ;
}
}
}
print " ## var=$var can replace now=$replace\n" if $this->{debug};
if (!$replace)
{
$replace = "" ;
print " ## no replacement\n" if $this->{debug};
print " ## DONE\n" if $this->{debug};
}
}
print " ## ALL DONE $key: $escaped$var = \"$prefix$replace\"\n\n" if $this->{debug};
"$prefix$replace" ;
}egxm; ## NOTE: /m is for multiline anchors; /s is for multiline dots
}
$this->prt_data("Hash now=", $hash_ref) if $this->{debug}>=2;
# mark as expanded
${$_state_href->{$key}} = 'expanded' ;
$this->prt_data("State now=", $_state_href) if $this->{debug}>=2;
}
}
#----------------------------------------------------------------------------
=item B<throw_fatal($message)>
Output error message then exit
=cut
sub throw_fatal
{
my $this = shift ;
my ($message, $errorcode) = @_ ;
print "Fatal Error: $message\n" ;
$this->exit( $errorcode || 1 ) ;
}
#-----------------------------------------------------------------------------
=item B<throw_nonfatal($message, [$errorcode])>
Add a new error (type=nonfatal) to this object instance, also adds the error to this Class list
keeping track of all runtime errors
=cut
sub throw_nonfatal
{
my $this = shift ;
my ($message, $errorcode) = @_ ;
print "Non-Fatal Error: $message\n" ;
return ($errorcode || 0) ;
}
#-----------------------------------------------------------------------------
=item B<throw_warning($message, [$errorcode])>
Add a new error (type=warning) to this object instance, also adds the error to this Class list
keeping track of all runtime errors
=cut
sub throw_warning
{
my $this = shift ;
my ($message, $errorcode) = @_ ;
print "Warning: $message\n" ;
return ($errorcode || 0) ;
}
#-----------------------------------------------------------------------------
=item B<throw_note($message, [$errorcode])>
Add a new error (type=note) to this object instance, also adds the error to this Class list
keeping track of all runtime errors
=cut
sub throw_note
{
my $this = shift ;
my ($message, $errorcode) = @_ ;
print "Info: $message\n" ;
return ($errorcode || 0) ;
}
#----------------------------------------------------------------------------
=item B< find_lib($module) >
Looks for the named module in the @INC path. If found, checks the package name inside the file
to ensure that it really matches the capitalisation.
(Mainly for Microsoft Windows use!)
=cut
sub find_lib
{
my $class = shift ;
my ($module, $file_ref) = @_ ;
my @module_dirs = split /::/, $module ;
my $pm = pop @module_dirs ;
#print "find_lib($module)\n" ;
my $found ;
foreach my $dir (@INC)
{
my $file = File::Spec->catfile($dir, @module_dirs, "$pm.pm") ;
#print " + checking $file\n" ;
if (-f $file)
{
if (open my $fh, "<$file")
{
my $line ;
while (defined($line = <$fh>))
{
chomp $line ;
if ($line =~ m/^\s*package\s+$module\s*;/)
{
if ($file_ref)
{
$file =~ s%\\%/%g ;
$$file_ref = $file ;
}
$found = $module ;
last ;
}
}
close $fh ;
}
last if $found ;
}
}
( run in 0.579 second using v1.01-cache-2.11-cpan-39bf76dae61 )