# $Id$
$VERSION{''.__FILE__} = '$Revision$';
#
# >>Title:: Application Framework Library
#
# >>Copyright::
# Copyright (c) 1992-1996, Ian Clatworthy (ianc@mincom.com).
# You may distribute under the terms specified in the LICENSE file.
#
# >>History::
# -----------------------------------------------------------------------
# Date Who Change
# 12-May-99 ianc Added $app_log_strm support
# 28-Apr-99 ianc Added output directory support
# 24-Oct-98 ianc _AppConfigLibDir() Mac patch (from David Schooley)
# 29-Feb-96 ianc SDF 2.000
# -----------------------------------------------------------------------
#
# >>Purpose::
# This library provides a common application framework
# for [[Perl]] scripts.
#
# >>Description::
# !include "app.sdf"
#
# >>Limitations::
# On MS-DOS using BigPerl v2 or v3, redirecting STDOUT after {{Y:AppProcess}}
# doesn't work.
#
# >>Resources::
#
# >>Implementation::
#
# Save these ASAP. $_app_path is a temporary variable which is
# copied to its public counterpart ($app_path) below. $app_path is
# defined below so that $app_path, $app_dir and $app_name can
# be documented together.
$_app_start = time;
$_app_path = $0;
BEGIN {
require "locale.pm" if $] >= 5.004;
}
require "sdf/name.pl";
require "sdf/misc.pl";
require "sdf/table.pl";
######### Constants #########
# Configuration parameters
@_APP_DETAILED_HELP = (
'Help',
'Type',
'Array',
'Parameter',
'Initial',
'Default',
);
#
# >>Description::
# {{Y:$APP_STDIN_ARGS}} is the pseudo argument (default '+') which
# causes standard input to be processed as a list of arguments.
# Some scripts may wish to use another symbol (i.e. '+' might
# be required as a genuine argument), or disable this behaviour
# altogether. See {{Y:AppProcess}}.
#
$APP_STDIN_ARGS = '+';
# Tables of configuration parameters, associated routines, and help
%_APP_CONFIG_FN = (
'calltree', "_AppConfigCallTree",
'inifile', "_AppConfigInifile",
'libdir', "_AppConfigLibDir",
'noecho', "_AppConfigNoEcho",
'parts', "_AppConfigParts",
'product', "_AppConfigProduct",
'test', "_AppConfigTest",
'time', "_AppConfigTime",
'version', "_AppConfigVersion",
);
%_APP_CONFIG_HELP = (
'calltree', "display call tree leading to application exit",
'inifile', "initialisation file to load",
'libdir', "library/configuration directory",
'noecho', "disable argument echoing",
'parts', "display program parts and versions",
'product', "product name",
'test', "verify outputs",
'time', "time program execution",
'version', "program version",
);
######### Variables #########
#
# >>Description::
# {{Y:$app_path}}, {{Y:$app_dir}} and {{Y:$app_name}} are the full
# pathname, directory and name of the application respectively.
#
$app_path= $_app_path;
(
$app_dir,
$app_name
) = &NameSplit($app_path);
#
# >>Description::
# {{Y:$app_lib_dir}} is the library directory for this application,
# i.e. the directory containing configuration files. The default
# value is the {{Y:$app_dir}}. This directory is typically set by
# searching the Perl library path for the {{libdir}} configuration
# parameter, if any.
#
$app_lib_dir = $app_dir;
# >>Description::
# {{Y:@app_exit_routines}} is the stack of routines to be executed
# on program termination. If you want a routine to be called
# on termination (normal and abnormal), push the name of the
# routine onto this stack. These routines will be executed when
# {{Y:AppExit}} is called. It is thus advisable to ensure that
# {{Y:AppExit}} is NOT called within an exit routine.
#
@app_exit_routines = ();
#
# >>Description::
# {{Y:%app_config}} contains the application's configuration parameters.
%app_config = ();
#
# >>Description::
# {{@app_option}} defines the options supported by the application.
# The default options are {{help}}, {{out_ext}}, {{log_ext}} and {{out_dir}}.
# To append to these, push your arguments onto the array.
# For example:
#
# V: push(@app_option,
# V: 'report|STR|report file',
# V: );
#
# If the script will never have a need for 'per file' output
# or errors, assign {{Y:@app_option_core}}
# to {{Y:@app_option}} before appending your script-specific options.
# For example:
#
# V: @app_option = @app_option_core;
# V: push(@app_option,
# V: 'report|STR|report file',
# V: );
#
# To obtain a concise description of each option, use the help
# option with no parameter. Alternatively, detailed help
# on a given option can be obtained by suppying the option
# name as a parameter.
#
# By default, output goes to standard output and diagnostics
# goes to standard error. These rules can be changed by
# specifying the {{out_ext}} and {{log_ext}} options
# respectively (and calling {{Y:AppProcess}} to process arguments).
# If a string is supplied to these options, it
# is treated as the extension of the file to send things to
# for each file. If supplied without a parameter, the
# extensions default to {{out}} and {{log}} respectively.
# A minus character (-) or an equals character (=) can be
# used to indicate standard output or standard error
# respectively.
#
# By default, output and log files are created in the current
# directory. To specify the same directory as the input file,
# specify the {{out_dir}} option without an argument.
# To specify an explicit directory, pass that directory as the
# argument to the {{out_dir}} option.
#
@app_option_core = (
'Option|Spec|Help',
'help|STR;;|display help on options',
);
@app_option = (
@app_option_core,
'out_ext|STR;;out|output file extension',
'log_ext|STR;;log|log file extension',
'out_dir;O|STR;.;|output to input file\'s (or explicit) directory',
);
#
# >>Description::
# {{Y:app_msg_table}} defines the known message types. Each type
# is defined by the attributes in the table below.
#
# !block table
# Attribute:Description
# Type:message type name
# Severity:application exit code caused by this message
# Layout:format of message text
# !endblock
#
# # Now that TableParse is used, adding new messages is
# # more complicated that it use to be so it's no longer supported..
# #
# # If you wish to support additional message types in your
# # application, simply append them to this table and rebuild
# # {{%app_msg_index}} using {{Y:TableIndex}}.
#
# {{Layout}} can include the symbols given in the table below.
#
# !block table
# Symbol:Description
# $text:user text
# $type:message type
# $app_name:application name
# $ARGV:current argument name (usually a file name)
# $app_context:current "context" (e.g. 'line ')
# $.:current line number
# $app_lineno:current line number (if $. is 0)
# !endblock
#
# The standard message types are explained in the table below.
#
# !block table; format=325; groups
# Tag Severity Description
# current object:
# object 0 general information
# warning 8 something you should know
# error 16 something you should fix
# abort 24 cannot precede processing
# whole application:
# app 0 general information
# app_warning 10 something you should know
# app_error 18 something you should fix
# fatal 32 cannot precede processing
# non-user messages:
# debug 0 debugging diagnostics - ignore
# failed 64 internal check failed - notify developer
# !endblock
#
# All messages are output to the standard error stream
# with a newline appended and prefixed as follows:
#
# * {{object}} messages by the current object name
# * {{warning}}, {{error}} and {{abort}} by current object name, line number and message type
# * {{app}} messages by the application name
# * {{app_warning}} messages by the application name and 'warning'
# * {{app_error}} messages by the application name and 'error'
# * {{fatal}} messages by the application name and 'fatal'
# * {{debug}} by application name and 'debug'
# * {{failed}} by application name and 'internal failure'
#
# Most applications only use {{fatal}}, {{abort}}, {{error}} and {{warning}}.
# {{fatal}} is used when an application decides to terminate.
# (e.g. when an option is illegal.) {{abort}} is used when
# an application decides not be precede any further on the
# current object (e.g. too many errors encountered). {{error}}
# is used when a serious error is detected in processing the
# current object. {{warning}} is used when a minor error or
# possible error is detected. Typically, an application
# continues processing the current object when an error or
# warning is encountered but errors prevent further
# passes on the object while warnings do not.
#
@app_msg_table = &TableParse (
'Type Severity Layout',
'object 0 $ARGV: $text\n',
'warning 8 $ARGV $type, $app_context$.: $text\n',
'error 16 $ARGV $type, $app_context$.: $text\n',
'abort 24 $ARGV $type, $app_context$.: $text\n',
'tst_object 0 # $ARGV: $text\n',
'tst_warning8 # $ARGV $type, $app_context$.: $text\n',
'tst_error 16 # $ARGV $type, $app_context$.: $text\n',
'tst_abort 24 # $ARGV $type, $app_context$.: $text\n',
'.warning 8 $ARGV $type, $app_context$app_lineno: $text\n',
'.error 16 $ARGV $type, $app_context$app_lineno: $text\n',
'.abort 24 $ARGV $type, $app_context$app_lineno: $text\n',
'app 0 $app_name: $text\n',
'app_warning10 $app_name warning: $text\n',
'app_error 18 $app_name error: $text\n',
'fatal 32 $app_name $type: $text\n',
'debug 0 $app_name $type: $text\n',
'failed 64 $app_name internal failure: $text\n',
);
#
# >>Description::
# {{Y:app_context}} and {{Y:app_lineno}} are the context and line number
# used in error messages. {{Y:app_lineno}} is only used if $. is 0.
#
$app_context = 'line ';
$app_lineno = 0;
#
# >>Description::
# {{Y:%app_msg_index}} is the index into the message table.
# (Most programmers have no need for this, but it's provided
# in case someone does want it.)
#
@_app_msg_dupl = ();
%app_msg_index = &TableIndex(*app_msg_table, *_app_msg_dupl, 'Type');
#
# >>Description::
# {{Y:$app_log_strm}} is a stream on which all messages are
# logged to if it's set. If required, this stream is opened and
# provided by the user.
#
$app_log_strm = '';
# Message type log and exit code
@_app_msg_type = ();
$_app_exit_code = 0;
# Usage message buffer and counter
$_app_usage = "";
$_app_usage_cnt = 0;
# display timing flag
$_app_timing = 0;
# enable/disable argument echoing flags - if neither if set, echoing
# occurs if and only if there is more than one argument
$_app_echo = 0;
$_app_noecho = 0;
# Aliases - null-separated lists of options and associated help, if any
%_app_alias = ();
%_app_alias_help = ();
#
# >>Description::
# {{Y:app_product_name}} and {{Y:app_product_version}} are the application
# name and version respectively. These are typically set during execution
# of the {{AppInit}} routine.)
#
$app_product_name = '';
$app_product_version = '';
#
# >>Description::
# {{Y:app_trace_level}} is the highest level of trace messages output by
# {{Y:AppTrace}} for each tracing group.
#
%app_trace_level = ();
# Initialisation file handler
$_app_ini_handler = '';
# Test counter
$_app_test_counter = 0;
######### Routines #########
#
# >>Description::
# {{Y:AppMsg}} outputs a message. The format of the message is
# determined by the {{type}} parameter which should be
# defined in {{Y:app_msg_table}}. If the type is
# unknown, behaviour is undefined.
# If {{calltree}} is set, a call tree is dumped after the
# message is output.
# If {{log_only}} is set, the message is only output
# to the {{$app_log_strm}}, if any.
#
# If a message layout includes the current line number ($.)
# and it is 0, {{Y:AppMsg}} uses the dot-version (e.g. ".error")
# of the message instead.
#
# The messages output via {{Y:AppMsg}} influence the exit
# code returned to the operating system by {{Y:AppExit}}.
# If you wish to influence this but not output a message,
# specify a {{type}} parameter without a {{text}} parameter.
#
sub AppMsg {
local($type, $text, $calltree, $log_only) = @_;
# local();
local(%type, $msg, $code);
# lookup message type
%type = &TableLookup(*app_msg_table, *app_msg_index, $type);
if ($. == 0 && $type{'Layout'} =~ /\$\./) {
%type = &TableLookup(*app_msg_table, *app_msg_index, ".$type");
}
# output message to stream after stripping any trailing
# newlines and formatting
if ($text) {
$text =~ s/\n+$//;
$msg = eval sprintf('"%s"', $type{'Layout'});
if ($type eq 'tst_object') {
printf "%s", $msg; # so make test output is not cluttered
} else {
printf STDERR ("%s", $msg) unless $log_only;
printf $app_log_strm ("%s", $msg) if $app_log_strm ne '';
}
}
# Dump the call tree, if requested
&AppShowCallTree() if $calltree;
# log message
$code = $type{'Severity'};
$_app_exit_code = $code if $code > $_app_exit_code;
push(@_app_msg_type, $type);
}
#
# >>Description::
# {{Y:AppMsgCounts}} returns the number of each message type
# found. If you are interested in the message counts since
# a particular point in time, a starting index to begin the
# counting from can be specified.
#
sub AppMsgCounts {
local($start_index) = @_;
local(%count);
for (@_app_msg_type[$start_index .. $#_app_msg_type]) {
$count{$_}++;
}
return %count;
}
#
# >>Description::
# {{Y:AppMsgNextIndex}} returns the next index to be used
# in the message log. The value returned can be used as
# the {{start_index}} parameter to the {{Y:AppMsgCounts}} routine.
#
sub AppMsgNextIndex {
# local() = @_;
local($index);
return $#_app_msg_type + 1;
}
#
# >>Description::
# {{Y:AppExit}} exits the current application. If a message
# is specified, it is first output via {{Y:AppMsg}}. The
# exit code returned to the operating system is dependent
# on the messages output by {{Y:AppMsg}}.
# If {{calltree}} is set, a call tree is dumped after the
# message is output.
# If {{log_only}} is set, the message is only output
# to the {{$app_log_strm}}, if any.
#
sub AppExit {
local($type, $text, $calltree, $log_only) = @_;
# local();
local($fn);
# Output message, if any
&AppMsg($type, $text, undef, $log_only) if $type;
# Dump the call tree, if requested
&AppShowCallTree() if $calltree;
# Execute any requested exit routines
while ($fn = pop(@app_exit_routines)) {
eval {&$fn};
}
# Output timing info, if requested
if ($_app_timing) {
my $msg;
if ($NAME_OS eq 'unix') {
$msg = sprintf "execution time: %.2f seconds\n", (times)[0];
}
else {
$msg = sprintf "execution time: %d seconds\n", time - $_app_start;
}
print $msg unless $log_only;
print $app_log_strm $msg if $app_log_strm ne '';
}
# Clost the log stream, if any
close($app_log_strm) if $app_log_strm ne '';
# Note: If we're in test mode, return 0
exit( $_app_test_counter > 0 ? 0 : $_app_exit_code);
}
#
# >>Description::
# {{Y:AppTrace}} outputs a trace message if {{group}} tracing is supported and
# for that group, the trace level is >= {{level}}. The default group is
# called {{user}}.
# If {{log_only}} is set, the message is only output
# to the {{$app_log_strm}}, if any.
#
sub AppTrace {
local($group, $level, $msg, $log_only) = @_;
# local();
my $where = '';
if (group eq '' || $group eq 'user') {
if ($app_trace_level{'user'} >= $level) {
$where = $level;
}
}
elsif ($app_trace_level{$group} >= $level) {
$where = "$group-$level";
}
if ($where ne '') {
printf STDERR ("[%s] %s\n", $where, $msg) unless $log_only;
printf $app_log_strm ("[%s] %s\n", $where, $msg) if $app_log_strm ne '';
}
}
#
# >>Description::
# {{Y:AppInit}} processes options and checks the argument count for a
# perl script. The supported options are defined by
# @app_option. Options must occur before arguments
# and begin with a - character for the short format
# or -- for the long format. Option processing is
# terminated when either an argument or the -- symbol
# is detected. If an environment variable of the
# form {{app_name}}OPTS is found, options are first
# processed from there.
#
# The expected number of arguments is derived
# from the format of the {{arguments}} parameter as
# illustrated by the table below.
#
# !block table; format=24
# Expected Format
# 0 ""
# 0 or more "..."
# 1 "file"
# 1 or more "file ..."
# 2 "source destination"
# 2 or more "pattern file ..."
# 2 or more "file ... destination"
# !endblock
#
# The pattern "..." is used to detect if a variable number of
# arguments is permitted. If no arguments are supplied and
# one or more are expected, then a concise usage message is
# output. If an application does not require an argument,
# there is no way to output only a concise usage (use the
# help option instead). {{purpose}} is displayed as part of
# the usage message. {{product}} is an optional parameter.
# If it is supplied and a product of that name exists in the
# internal product version lookup table, the product version
# is included in the usage too. Note that the usage message
# always includes a script version, regardless of whether
# a product version is displayed or not.
#
# If {{Y:AppInit}} encounters an error, it outputs a usage
# message and returns 0. Otherwise, it returns 1.
#
sub AppInit {
local($arguments, $purpose, $product, $ini_handler) = @_;
local($ok);
# my variables
local(%opt_short, $env_opts, $usage_msg);
# local variables
local(@badoptions, @badaliases, @badparams);
local(@opt_code, %opt_attr);
local($param, $value);
# treat product like any other configuration parameter
if ($product ne '') {
$app_config{'product'} = $product;
}
# Save the ini-file handler
$_app_ini_handler = $ini_handler;
# initialise lookup tables:
# * %opt_attr contains the attribute values for each option
# * @opt_code contains the list of short format codes
# * %opt_short converts a long format name to a short format one
%opt_attr = &_AppOptsIndex(*opt_code, *opt_short, @app_option);
# process configuration parameters, ensuring that:
# * the library directory, if any, is the first one processed
# * the inifile, if any, is the last one processed
if ($app_config{'libdir'}) {
&_AppSetConfig('libdir', $app_config{'libdir'});
}
for $param (keys %app_config) {
next if $param eq 'inifile';
next if $param eq 'libdir';
unless (&_AppSetConfig($param, $app_config{$param})) {
&AppExit("failed", "bad app_config key '$param'");
}
}
if ($app_config{'inifile'}) {
&_AppSetConfig('inifile', $app_config{'inifile'});
}
# prepend options in the environment variable ${name}OPTS
$env_opts = "${app_name}OPTS";
$env_opts =~ tr/[a-z]/[A-Z]/;
unshift(@ARGV, split(/ /, $ENV{$env_opts}));
# apply the default alias, if any
if (defined($_app_alias{$app_name})) {
unshift(@ARGV, split("\000", $_app_alias{$app_name}));
$purpose = $_app_alias_help{$app_name};
}
# process the options
option:
while (@ARGV) {
local($opt_prefix, $opt_text, $opt_code);
local($rest, %opt, $action);
# check for the options terminator
$_ = $ARGV[0];
#print "argument: $_<\n";
if ($_ eq '--') {
shift(@ARGV);
last option;
}
# Get next option:
# * $opt_code is the short version (set for short AND long)
# * $rest is the remainder of the text in this argument
# aliases begin with '+'
if (/^\+(.+)$/) {
if (!defined($_app_alias{$1})) {
push(@badaliases, $1);
}
shift(@ARGV);
unshift(@ARGV, split("\000", $_app_alias{$1}));
next option;
}
# configuration parameters begin with '-.'
elsif (/^\-\.(.+)$/) {
$param = $1;
if ($param =~ /^(\w+)[:=](.*)$/) {
$param = $1;
$value = $2;
}
else {
$value = 1;
}
shift(@ARGV);
unless (&_AppSetConfig($param, $value)) {
push(@badparams, $1);
}
next option;
}
# long options begin with '--'
elsif (/^\-\-(.+)$/) {
$opt_text = $1;
if ($opt_text =~ /^(\w+)[:=](.*)$/) {
$opt_text = $1;
$rest = $2;
}
else {
$rest = '';
}
$opt_code = $opt_short{$opt_text};
# if full name not given, check for shortest unique format
unless ($opt_code) {
local(@matches);
@matches = grep(/^$opt_text/, keys %opt_short);
$opt_code = $opt_short{$matches[0]} if $#matches == 0;
}
}
# short options begin with '-'
elsif (/^\-(.)(.*)$/) {
$opt_code = $1;
$rest = $2;
}
# if reach here, must be an argument
else {
last option;
}
# check option exists
%opt = &_AppOption($opt_code);
unless (%opt) {
push(@badoptions, $_);
shift(@ARGV);
next option;
}
# get parameter & process according to type
# ($opt_text is passed as a boolean to indicate long or short format)
($action, $usage_msg) = &_AppOptProcess($rest, $opt_text, %opt);
last option if $usage_msg;
eval $action;
if ($@) {
&AppExit('failed', "option action '$action' error: '$@'");
}
}
# Reset usage variables
$_app_usage = &_AppBuildUsage($arguments, $purpose);
$_app_usage_cnt = 0;
# Check usage and return
return &_AppCheckUsage($arguments, $usage_msg, *badoptions, *badaliases,
*badparams);
}
#
# >>_Description::
# {{Y:_AppOptsIndex}} builds an index of option attributes.
# %opt_attr is a lookup table with the option code as the key
# @opt_code is the set of short format option codes.
# %opt_short converts a long format option name to a short format one.
# @opt_strings is assumed to be a set of Tbl strings ready for parsing
# by {{Y:TableParse}} into records.
#
sub _AppOptsIndex {
local(*opt_code, *opt_short, @opt_strings) = @_;
local(%opt_attr);
local(@opt_table);
local(@field, %o, $code, $name);
local($required, $type, $array, $validate, $init, $default);
local($str, $n, $v);
# Parse the option strings into records
@opt_table = &TableParse(@opt_strings);
@opt_code = ();
%opt_short = ();
@field = &TableFields(shift(@opt_table));
for $o (@opt_table) {
%o = &TableRecSplit(*field, $o);
# determine option code & long name
if ($o{'Option'} =~ /;/) {
$o{'Option'} = $`;
$code = $';
}
else {
$code = substr($o{'Option'}, 0, 1);
}
$name = $o{'Option'};
# check option code & name are unique
if (grep(/^$code$/, @opt_code)) {
&AppExit("failed", "option code '$code' not unique");
}
elsif ($opt_short{$name}) {
&AppExit("failed", "option name '$name' not unique");
}
$o{'Code'} = $code;
# determine type-related attributes
($type, $init, $default) = split(/;/, $o{'Spec'});
$array = '';
$validate = '';
$required = '';
if ($type ne 'BOOL') {
$required = ($o{'Spec'} =~ /;.*;/) ? 'maybe' : 'yes';
if ($type =~ /^(\w+)\-/) {
$type = $1;
$validate = $';
}
if ($type =~ /(LIST|HASH)$/) {
$type = $`;
$array = $1;
}
}
$o{'Parameter'} = $required if $required;
$o{'Type'} = $type;
$o{'Array'} = $array if $array;
$o{'Initial'} = $init;
$o{'Default'} = $default if $required eq 'maybe';
$o{'Validate'} = $validate if $validate;
# some semantic checks
unless (grep(/^$type$/, 'BOOL', 'STR', 'INT', 'NUM',
'ROUTINE')) {
&AppExit("failed", "unknown option type '$type' for option '$code'");
}
if ($type eq 'ROUTINE' && ! $validate) {
&AppExit('failed', "unknown routine for option '$name'");
}
# initialise option, if required
if ($init) {
local($action);
$action = &_AppAction($init, 1, %o);
eval $action;
if ($@) {
&AppExit('failed', "action '$action' error: '$@'");
}
}
# save this option
$str = '';
$str .= "$n=$v\000" while ($n, $v) = each %o;
$opt_attr{$code} = $str;
#print "code:$code<\n";
#print "data:$opt_attr{$code}<\n";
push(@opt_code, $code);
$opt_short{$name} = $code;
}
# Return result
return %opt_attr;
}
#
# >>_Description::
# {{Y:_AppOption}} returns the attributes of an option.
#
sub _AppOption {
local($opt_code) = @_;
local(%opt);
local($nv);
for $nv (split(/\000/, $opt_attr{$opt_code})) {
$opt{$`} = $' if $nv =~ /\=/;
}
# Return result
return %opt;
}
#
# >>_Description::
# {{Y:_AppOptProcess}} processes an option, updating the ARGV array
# as it goes. If {{long}} is true, the option is processed as a long
# option, otherwise short.
#
sub _AppOptProcess {
local($rest, $long, %opt) = @_;
local($action, $usage_msg);
local($param, $required, $default_used, $missing);
if ($long) {
shift(@ARGV);
$param = $rest;
}
else {
# handle required parameter
$required = $opt{'Parameter'};
if ($required eq 'yes') {
shift(@ARGV);
if ($rest ne '') {
$param = $rest;
}
elsif (@ARGV) {
$param = shift(@ARGV);
}
else {
$missing = $opt{'Option'};
}
}
# handle optional parameter
elsif ($required eq 'maybe') {
shift(@ARGV);
if ($rest ne '') {
$param = $rest;
}
else {
$param = $opt{'Default'};
$default_used = 1;
}
}
# handle no parameter
else {
if ($rest ne '') {
$ARGV[0] = "-$rest";
}
else {
shift(@ARGV);
}
}
}
# Get action (if all ok)
if ($missing) {
$usage_msg = "parameter required for option $missing";
}
else {
$param = 1 if $opt{'Type'} eq 'BOOL';
$action = &_AppAction($param, $default_used, %opt);
}
# Return result
return ($action, $usage_msg);
}
#
# >>_Description::
# {{Y:_AppAction}} returns a Perl expression to be eval'ed.
# For arrays, if $init is true, the array is initialised
# to the value specified, otherwise, the value is appended.
#
sub _AppAction {
local($value, $init, %opt) = @_;
local($action);
local($id);
$id = $opt{'Option'};
if ($opt{'Type'} eq 'ROUTINE') {
# Pass parameter as string
$value =~ s/(['\\])/\\$1/g;
$value = "'$value'";
$action = "&$opt{'Validate'}($value)";
}
elsif ($opt{'Array'} eq 'LIST') {
if ($opt{'Type'} eq 'STR') {
local(@value);
@value = split(/,/, $value);
for $v (@value) {
$v =~ s/(['\\])/\\$1/g;
$v = "'$v'";
}
$value = join(',', @value);
}
if ($init) {
$action = "\@$id = ($value)";
}
else {
$action = "push(\@$id, $value)";
}
}
elsif ($opt{'Array'} eq 'HASH') {
local(@key, @value, $key, $v);
@key = split(/,/, $value);
for $k (@key) {
if ($k =~ /^(\w+)[:=]/) {
$k = "'$1'";
$v = $';
if ($opt{'Type'} eq 'STR') {
$v =~ s/(['\\])/\\$1/g;
$v = "'$v'";
}
}
else {
$k = "'$k'";
$v = 1;
}
push(@value, $v);
}
$key = join(',', @key);
$value = join(',', @value);
$action = '@' . $id . "{$key} = ($value)";
$action = "undef %$id;" . $action if $init;
}
else {
if ($opt{'Type'} eq 'STR') {
$value =~ s/(['\\])/\\$1/g;
$value = "'$value'";
}
$action = "\$$id = $value";
}
# Return result
return $action;
}
#
# >>_Description::
# _AppCheckUsage() checks if a usage message is required. If it is,
# it outputs one together with any necessary supporting messages.
# It returns 1 if things are fine.
#
sub _AppCheckUsage {
local($arguments, $usage_msg, *badoptions, *badaliases, *badparams) = @_;
local($ok);
local(%badvalue, %opt, $check, $min, $max, @ok);
local($args_reqd, $args_variable, $args_left, $arg_missing);
# validate options
%badvalue = ();
check:
for $opt (@opt_code) {
%opt = &_AppOption($opt);
if ($opt{'Validate'} && $opt{'Type'} ne 'ROUTINE') {
# build the check string
if ($opt{'Type'} eq 'STR') {
$check = 'grep(/^$value$/, ' .
$opt{"Validate"} . ')';
}
else {
($min, $max) = split(/,/, $opt{'Validate'});
if ($min eq '' && $max ne '') {
$check = '$value <= $max';
}
elsif ($min ne '' && $max eq '') {
$check = '$min <= $value';
}
elsif ($min ne '' && $max ne '') {
$check = '$min <= $value && $value <= $max';
}
else {
next check;
}
}
# check the value(s)
if ($opt{'Array'} eq 'LIST') {
for $value (eval "\@$opt{'Option'}") {
if ($opt{'Type'} eq 'STR') {
$value =~ s/(\W)/\\$1/g;
}
unless (eval $check) {
$badvalue{$opt{'Option'}} = $value;
next check;
}
}
}
elsif ($opt{'Array'} eq 'HASH') {
for $value (eval "values \%$opt{'Option'}") {
if ($opt{'Type'} eq 'STR') {
$value =~ s/(\W)/\\$1/g;
}
unless (eval $check) {
$badvalue{$opt{'Option'}} = $value;
next check;
}
}
}
else {
$value = eval "\$$opt{'Option'}";
if ($opt{'Type'} eq 'STR') {
$value =~ s/(\W)/\\$1/g;
}
unless (eval $check) {
$badvalue{$opt{'Option'}} = $value;
}
}
}
}
# check the argument count
$args_reqd = split(/ /, $arguments);
if ($args_variable = ($arguments =~ /\.\.\./)) {
$args_reqd--;
}
$args_left = scalar(@ARGV);
if (! $usage_msg) {
if ($args_reqd && $args_left == 0) {
$arg_missing = 1;
}
elsif ($args_variable && $args_left < $args_reqd) {
$arg_missing = 1;
$usage_msg = "at least $args_reqd arguments required" .
" - $args_left supplied";
}
elsif (! $args_variable && $args_left != $args_reqd) {
$arg_missing = 1;
$usage_msg = "$args_reqd arguments required" .
" - $args_left supplied";
}
}
# Output usage, if required
$ok = 1;
if (defined $help || $usage_msg || @badoptions || @badaliases ||
@badparams || %badvalue || $arg_missing) {
&AppPrintUsage();
$ok = 0;
}
# Output help on option requested or all options/aliases
# if the option requested does not exist, show the options/aliases
if (@badoptions || @badaliases || defined $help) {
%opt = &_AppOption($help);
if (%opt) {
printf "Detailed help on option: -%s,--%s\n\n", $help,
$opt{'Option'};
printf "%-10.10s %s\n", 'Attribute', 'Value';
for $attr (@_APP_DETAILED_HELP) {
if (defined $opt{$attr}) {
printf "%-10.10s %s\n", $attr,
$opt{$attr};
}
}
if ($opt{'Validate'} && $opt{'Type'} ne 'ROUTINE') {
if ($opt{'Type'} eq 'STR') {
@ok = eval "$opt{'Validate'}";
printf "%-10.10s %s\n", 'Legal',
join(', ', @ok);
}
else {
($min, $max) = split(/,/,
$opt{'Validate'});
printf "%-10.10s %d..%d\n", 'Range',
$min, $max;
}
}
}
else {
print "options:\n";
for $opt (@opt_code) {
%opt = &_AppOption($opt);
printf "-%s, --%-15.15s %s\n", $opt,
$opt{'Option'}, $opt{'Help'};
}
if ($_app_alias{$app_name} eq '' && %_app_alias_help) {
print "aliases:\n";
for $opt (sort keys %_app_alias_help) {
printf "+%-15.15s %s\n", $opt,
$_app_alias_help{$opt};
}
}
}
}
# Print configuration parameters
if (@badparams) {
print "configuration parameters:\n";
for $opt (sort keys %_APP_CONFIG_HELP) {
printf "%-10.10s %s\n", $opt, $_APP_CONFIG_HELP{$opt};
}
}
# Print bad options
if (@badoptions) {
print "\n";
for $opt (@badoptions) {
&AppMsg('fatal', "unknown or non-unique option '$opt'");
}
}
# Print bad aliases
if (@badaliases) {
print "\n";
for $opt (@badaliases) {
&AppMsg('fatal', "unknown alias '$opt'");
}
}
# Print bad configuration parameters
if (@badparams) {
print "\n";
for $opt (@badparams) {
&AppMsg('fatal', "unknown configuation parameter '$opt'");
}
}
# Print bad values
if (%badvalue) {
for $value (sort keys %badvalue) {
&AppMsg('fatal', sprintf("bad %s value '%s'",
$value, $badvalue{$value}));
}
}
# Print usage message
if ($usage_msg) {
&AppMsg('fatal', $usage_msg);
}
# Return result
return $ok;
}
#
# >>Description::
# {{Y:AppPrintUsage}} outputs the usage header message build during the
# last call to {{Y:AppInit}}. Only the first call to this routine
# (after {{Y:AppInit}} is called) will print the message. This
# allows programmers to do additional validation after {{Y:AppInit}}
# returns and know that only one usage header message will be output.
#
sub AppPrintUsage {
# local() = @_;
# local();
if ($_app_usage_cnt++ == 0) {
print $_app_usage;
}
}
#
# >>_Description::
# {{Y:_AppBuildUsage}} builds and returns a usage message, based on the
# options defined in @app_option.
#
sub _AppBuildUsage {
local($arguments, $purpose) = @_;
local($text);
local($usage);
local(%o, $required, $code, $desc, $version);
local($product_info);
# build usage string - application name and aliases
$text = $app_name;
if ($_app_alias{$app_name} eq '' && %_app_alias) {
$text .= " [+alias]";
}
# build usage string - options
for $opt (@opt_code) {
%o = &_AppOption($opt);
$required = $o{'Parameter'};
# determine usage
$code = $o{'Code'};
$desc = $o{'Option'};
$desc .= ",.." if $o{'Array'};
if ($required eq 'yes') {
$usage = "$code $desc";
}
elsif ($required eq 'maybe') {
$usage = $code . "[$desc]";
}
else {
$usage = "$code";
}
$text .= " [-$usage]";
}
# Get version:
# * use public one if available, otherwise physical version
# * strip RCS/SCCS stuff
$version = $VERSION{'PUBLIC'};
$version = $VERSION{$app_path} unless $version;
if ($version =~ /^\$\w+: (.*)\$$/) {
$version = $1;
}
elsif ($version =~ /^\@\(\#\)\s*(.*)$/) {
$version = $1;
}
# Get product info, if any
$product_info = '';
if ($app_product_name) {
$product_info = " ($app_product_name $app_product_version)";
}
# Return result
return "usage : $text $arguments\n".
"purpose: $purpose\n".
"version: $version$product_info\n";
}
#
# >>_Description::
# {{Y:_AppSetConfig}} sets a configuration parameter.
# It returns true if the parameter is known.
#
sub _AppSetConfig {
local($param, $value) = @_;
local($ok);
local($fn);
# process the associated action
$fn = $_APP_CONFIG_FN{$param};
if ($fn) {
$app_config{$param} = $value;
eval {&$fn($value)};
&AppExit('fatal', $@) if $@;
}
# Return result
return $fn;
}
#
# >>_Description::
# {{Y:_AppConfigLibDir}} sets the library directory.
#
sub _AppConfigLibDir {
local($value) = @_;
# local();
local($inc);
my $nom_path;
# Search the library path for the nominated directory
for $inc (@INC) {
$nom_path = "$inc/$value";
$nom_path =~ s#:*/+#:#g if $^O eq 'MacOS';
if (-d $nom_path) {
$app_lib_dir = $nom_path;
return;
}
}
}
#
# >>_Description::
# {{Y:_AppConfigInifile}} loads an inifile.
#
sub _AppConfigInifile {
local($value) = @_;
# local();
local($fname);
local(%inidata, $section, %config);
local($product);
local($alias_name, $alias_help, @alias_opts);
local($next_inifile, $param);
# Find the file
$fname = &NameFind($value, ".", $app_lib_dir);
if ($fname eq '') {
&AppExit("fatal", "initialisation file '$value' not found");
}
# Fetch the file
%inidata = &_AppFetchInifile($fname);
# Get the configuration for later processing
%config = &AppSectionValues($inidata{'Configuration'});
delete $inidata{'Configuration'};
# If this is also the product ini-file, process it accordingly
$product = $app_config{'product'};
$product =~ tr/A-Z/a-z/;
if ($value eq "$product.ini") {
&_AppProductIni($fname, *inidata);
}
# Process the standard data
for $section (sort keys %inidata) {
if ($section =~ /^Alias\s+(\w+)/) {
$alias_name = $1;
($alias_help) = ($' =~ /^\s*:\s*(.*)$/);
@alias_opts = &_AppSectionList($inidata{$section});
for $param (@alias_opts) {
$param = "--$param";
}
&_AppStoreAlias($alias_name, $alias_help, @alias_opts);
# Remove the processed data from the configuration file
delete $inidata{$section};
}
}
# Process the user data
if ($_app_ini_handler) {
eval {&$_app_ini_handler($fname, *inidata)};
}
# Warn about the unknown sections
for $section (sort keys %inidata) {
&AppMsg("warning", "unknown section '$section' in initialisation file '$fname'");
}
# Process the configuration
$next_inifile = $config{'inifile'};
delete $config{'inifile'};
for $param (keys %config) {
&_AppSetConfig($param, $config{$param});
}
if ($next_inifile ne '') {
&_AppSetConfig('inifile', $next_inifile);
}
}
#
# >>_Description::
# {{Y:_AppFetchInifile}} fetches an inifile.
# Each section is returned as an entry in {{%data}}.
# Within each section, lines are terminated by a newline.
#
sub _AppFetchInifile {
local($inifile) = @_;
local(%data);
local($section, $_);
# Open the file
unless (open(INIFILE, $inifile)) {
&AppExit("fatal", "unable to open initialisation file '$inifile'");
}
# Read the data
while (<INIFILE>) {
# skip blank and comment lines
s/^\s+//;
s/\s+$//;
next if /^$/ || /^#/ || /^;/;
# change the section or add data to the current section
if (/^\[(.*)\]$/) {
$section = $1;
}
else {
$data{$section} .= "$_\n";
}
}
# Close the file
close(INIFILE);
# Return result
return %data;
}
#
# >>_Description::
# {{Y:_AppSectionList}} converts an inifile section into a list.
#
sub _AppSectionList {
local($text) = @_;
local(@data);
# Return result
return split("\n", $text);
}
#
# >>Description::
# {{Y:AppSectionValues}} converts an inifile section into a set of
# name-value pairs.
#
sub AppSectionValues {
local($strs) = @_;
local(%values);
local($line);
# process the lines
for $line (split("\n", $strs)) {
if ($line =~ /^\s*([\w\.]+)\s*\=\s*(.*)\s*$/) {
$values{$1} = $2;
}
}
# Return result
return %values;
}
#
# >>_Description::
# {{Y:_AppStoreAlias}} stores an alias.
#
sub _AppStoreAlias {
local($name, $help, @options) = @_;
# local();
$_app_alias{$name} = join("\000", @options);
$_app_alias_help{$name} = $help;
}
#
# >>_Description::
# {{Y:_AppConfigVersion}} sets the version number of a script.
#
sub _AppConfigVersion {
local($value) = @_;
# local();
$VERSION{'PUBLIC'} = $value;
}
#
# >>_Description::
# {{Y:_AppConfigProduct}} makes this script part of the nominated product.
#
sub _AppConfigProduct {
local($value) = @_;
# local();
local($inifile);
local($fname);
local($section);
# Save the product name
$app_product_name = $value;
# Get the product ini-file
$value =~ tr/A-Z/a-z/;
$inifile = &NameJoin('', $value, 'ini');
# Skip processing it if it's going to be done later
return if $inifile eq $app_config{'inifile'};
# Load and process the ini-file data
$fname = &NameFind($inifile, ".", $app_lib_dir);
if ($fname eq '') {
&AppExit("fatal", "initialisation file '$value' not found");
}
%inidata = &_AppFetchInifile($fname);
&_AppProductIni($fname, *inidata);
# Ignore aliases in the product ini-file data
for $section (sort keys %inidata) {
if ($section =~ /^Alias\s+(\w+)/) {
delete $inidata{$section};
}
}
# Process the user data
if ($_app_ini_handler) {
eval {&$_app_ini_handler($fname, *inidata)};
# Warn about the unknown sections - but only if the application
# has an ini file handler (otherwise, warnings are produced for
# commands which share a product ini file)
for $section (sort keys %inidata) {
&AppMsg("warning", "unknown section '$section' in initialisation file '$fname'");
}
}
}
#
# >>_Description::
# {{Y:_AppProductIni}} processes the product-specific ini-file data.
#
sub _AppProductIni {
local($fname, *inidata) = @_;
# local();
local($section, %values, $key);
# Process the infile
for $section (keys %inidata) {
if ($section eq 'Product') {
%values = &AppSectionValues($inidata{$section});
for $key (keys %values) {
if ($key eq 'version') {
$app_product_version = $values{$key};
}
else {
&AppMsg("warning", "unknown [Product] parameter '$key' in initialisation file '$fname'");
}
}
# Remove the processed data from the configuration file
delete $inidata{$section};
}
}
}
#
# >>_Description::
# {{Y:_AppConfigTest}} enables verification of the output files.
# If value is a number, Perl-style test output is generated and
# the first test has that number. Otherwise, the value is the name
# of the verification routine to use.
#
sub _AppConfigTest {
local($value) = @_;
# local();
# Ensure output and log file are generated & disable argument echoing
unshift(@ARGV, '-o', '-l');
$_app_noecho = 1;
# The default test handler is _AppVerifyOutputs
if ($value =~ /^\d+$/) {
$_app_test_fn = '_AppVerifyOutputs';
$_app_test_counter = $value;
}
else {
$_app_test_fn = $value;
}
}
#
# >>_Description::
# {{Y:_AppConfigNoEcho}} disables argument echoing.
#
sub _AppConfigNoEcho {
local($value) = @_;
# local();
$_app_noecho = 1;
}
#
# >>_Description::
# {{Y:_AppConfigTime}} enables timing the execution of a program.
#
sub _AppConfigTime {
local($value) = @_;
# local();
$_app_timing = 1;
}
#
# >>_Description::
# {{Y:_AppConfigParts}} enables the display (upon exit) of the
# components (and their versions) making up this application.
#
sub _AppConfigParts {
local($value) = @_;
# local();
push(@app_exit_routines, "AppShowParts");
}
#
# >>_Description::
# {{Y:_AppConfigCallTree}} enables the display (upon exit) of the
# call tree of routines.
#
sub _AppConfigCallTree {
local($value) = @_;
# local();
push(@app_exit_routines, "AppShowCallTree");
}
#
# >>_Description::
# {{Y:_AppVerifyOutputs}} compares {{outfile}} and {{logfile}} to
# verified files in the {{checked}} directory. Files which match are
# deleted. Files which do not match are kept so that the developer
# can diff the errors.
#
sub _AppVerifyOutputs {
local($infile, $outfile, $logfile) = @_;
# local();
# Verify the output file
&_AppVerifyFile($outfile, &NameJoin("checked", $outfile), 'output');
# Verify the log file
&_AppVerifyFile($logfile, &NameJoin("checked", $logfile), 'log');
}
#
# >>_Description::
# {{Y:_AppVerifyFile}} compares a test file against a checked file.
#
sub _AppVerifyFile {
local($test, $check, $type) = @_;
local($ok);
local($testdata, $checkdata);
# Get the data from the test file
unless (open(TESTFILE, $test)) {
&AppMsg("tst_error", "unable to open $type data file '$test' for testing");
return 0;
}
$testdata = join('', <TESTFILE>);
close TESTFILE;
# Get the data from the check file
unless (open(CHECKFILE, $check)) {
&AppMsg("tst_error", "unable to open $type check file '$check' for testing");
return 0;
}
$checkdata = join('', <CHECKFILE>);
close CHECKFILE;
# Compare the data
if ($testdata eq $checkdata) {
&AppMsg("tst_object", "$type file ok");
printf "ok %d\n", $_app_test_counter++;
unlink $test;
return 1;
}
else {
&AppMsg("tst_object", "$type file FAILED");
printf "not ok %d\n", $_app_test_counter++;
return 0;
}
}
#
# >>Description::
# {{Y:AppShowParts}} displays the versions of components making up
# this application and exits. To support this facility, each library
# should include a line of the form:
#
# . $VERSION{__FILE__} = "x.y"
#
# Strings containing SCCS or RCS stuff have the baggage stripped.
# For example:
#
# * '@(#) 3.2' is displayed as '3.2'
# * '$Revision: 1.27 $' is displayed as '3.3'
#
# {{Y:AppShowParts}} is usually called via the '.parts' special
# help option. However, certain application code might have a
# need to call it directly.
#
sub AppShowParts {
# local = @_;
# local();
local($version);
for (sort keys %VERSION) {
$version = $VERSION{$_};
if ($version =~ /^\$\w+: (.*)\$$/) {
$version = $1;
}
elsif ($version =~ /^\@\(\#\)\s*(.*)$/) {
$version = $1;
}
printf "%-16s %s\n", $version, $_;
}
}
#
# >>Description::
# {{Y:AppShowCallTree}} displays the call tree (excluding the call
# to itself). The routine is usually called indirectly:
#
# * via {{Y:AppMsg}} or {{Y:AppExit}} ({{calltree}} parameter set), or
# * via the .calltree special help parameter
#
# Like {{Y:AppShowComponents}}, certain application code may wish to
# call {{Y:AppShowCallTree}} directly.
#
sub AppShowCallTree {
# local() = @_;
# local();
local($i,$p,$f,$l,$s,$h,$a,@a,@sub);
for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
@a = @DB'args;
for (@a) {
if (/^StB\000/ && length($_) == length($_main{'_main'})) {
$_ = sprintf("%s",$_);
}
else {
s/'/\\'/g;
s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
}
}
$w = $w ? '@ = ' : '$ = ';
$a = $h ? '(' . join(', ', @a) . ')' : '';
push(@sub, "$f $l: $w&$s$a\n");
}
print STDERR "CALL TREE IS..\n";
for ($i=0; $i <= $#sub; $i++) {
print STDERR $sub[$i];
}
print STDERR "END CALL TREE.\n";
}
#
# >>Description::
# {{Y:AppProcess}} processes each argument on the command-line.
# In particular, it does the following for each argument:
#
# * if the argument is '+', processes each line of standard input
# as an argument
# * if a file matching an argument is not found, but {{default_ext}} is
# supplied and adding that extension results in a file being found,
# then {{default_ext}} is added as an extension to the argument
# * echos the argument to standard error if there is more than one
# * if $out_ext is set, opens an output file for the current
# argument and redirects STDOUT to it
# * if $log_ext is set, opens a log file for the current
# argument and redirects STDERR to it
# * calls {{arg_process_fn}}
# * close the output and log files, returning STDOUT and STDERR back
# to their initial state
# * calls {{arg_post_process_fn}}, if any
#
# Note that {{arg_post_process}}
# is optional - it is only used in scripts which need to
# do additional processing on an file {{after}} output streams
# have been closed.
#
# {{arg_process_fn}} has the following interface:
#
# V: $err = &arg_process_fn($arg)
#
# {{arg_post_process_fn}} has the following interface:
#
# V: $err = &arg_post_process_fn($arg, $arg_err)
#
# where {{arg_err}} is the error code returned by {{arg_process_fn}}.
# {{Y:AppProcess}} returns the highest error code it encounters from
# the user processing functions it calls.
#
# If you need to disable the special meaning of '+', set the
# {{Y:APP_STDIN_ARGS}} configuration constant to an empty string.
# Likewise, you can change the character used by setting it
# to another value, although this is not recommended given the
# consistency implications.
#
sub AppProcess {
local($arg_process_fn, $arg_post_process_fn, $default_ext) = @_;
local($app_err);
local($echo_args, $stdin_read, @stdin_args);
local($in_dir, $base, $ext, $dir, $outfile, $logfile);
local($base_ext);
local($arg_err, $post_err);
# Decide if we should echo arguments
$echo_args = @ARGV > 1 && !$_app_noecho;
# Loop through the arguments
argument:
while ($ARGV = shift(@ARGV)) {
# Process stdin as a list of arguments, if requested
if (! $stdin_read && $ARGV eq $APP_STDIN_ARGS) {
# append the arguments to the front of ARGV
@stdin_args = <STDIN>;
chop(@stdin_args);
unshift(@ARGV, @stdin_args);
# update echoing accordingly
$echo_args || ($echo_args = @ARGV > 1 && !$_app_noecho);
$stdin_read = 1;
next argument;
}
# Append the default extension, if necessary and supplied
if (! -f $ARGV && $default_ext ne '') {
$base_ext = &NameJoin('', $ARGV, $default_ext);
$ARGV = $base_ext if -f $base_ext;
}
# init the per argument stuff
$arg_err = 0;
($in_dir, $base, $ext) = &NameSplit($ARGV);
# echo the argument name
if ($echo_args || $_app_echo) {
print STDERR "$ARGV:\n";
}
# decide the output directory
if ($out_dir eq '.') {
$dir = '';
}
elsif ($out_dir eq '') {
$dir = $in_dir;
}
else {
$dir = $out_dir;
}
# decide on output and log streams
$outfile = '';
$logfile = '';
if ($out_ext && -f $ARGV && $out_ext ne '-') {
if ($out_ext eq '=') {
$outfile = "&STDERR";
}
else {
$outfile = &NameJoin($dir, $base, $out_ext);
}
}
if ($log_ext && -f $ARGV && $log_ext ne '=') {
if ($log_ext eq '-') {
$logfile = "&STDOUT";
}
else {
$logfile = &NameJoin($dir, $base, $log_ext);
}
}
# if required, redirect output and log streams
if ($outfile) {
unless (open(APP_OUT, ">&STDOUT")) {
print STDERR "failed to save stdout: $!";
}
unless (open(STDOUT, "> $outfile")) {
print STDERR "failed to redirect stdout: $!";
}
}
if ($logfile) {
unless (open(APP_ERR, ">&STDERR")) {
print STDERR "failed to save stderr: $!";
}
unless (open(STDERR, "> $logfile")) {
print APP_ERR "failed to redirect stderr: $!";
}
}
# process each argument
$arg_err = &$arg_process_fn($ARGV);
# if required, close the output/log files
if ($logfile) {
unless (close(STDERR)) {
print APP_ERR "failed to close stderr: $!";
}
unless (open(STDERR, ">&APP_ERR")) {
print STDERR "failed to re-open stderr: $!";
}
}
if ($outfile) {
unless (close(STDOUT)) {
print STDERR "failed to close stdout: $!";
}
unless (open(STDOUT, ">&APP_OUT")) {
print STDERR "failed to re-open stdout: $!";
}
}
# do the post processing, if any
if ($arg_post_process_fn) {
$post_err = &$arg_post_process_fn($ARGV, $arg_err);
}
# do the test function, if any
if ($_app_test_fn) {
&$_app_test_fn($ARGV, $outfile, $logfile);
}
# update the overall error code
$app_err = $arg_err if $arg_err > $app_err;
$app_err = $post_err if $post_err > $app_err;
}
# return result
return $app_err;
}
# package return value
1;