App-Framework-Lite
view release on metacpan or search on metacpan
lib/App/Framework/Lite.pm view on Meta::CPAN
Optionally, you can specify arguments to the underlying features by appending a string to the 'use' pragma. For exanmple:
use App::Framework::Lite '+Args(open=none)' ;
=head3 Creating Application Object
There are two ways of creating an application object and running it. The normal way is:
# Create application and run it
App::Framework::Lite->new()->go() ;
As an alternative, the framework creates a subroutine in the calling namespace called B<go()> which does the same thing:
# Create application and run it
go() ;
You can use whatever takes your fancy. Either way, the application object will end up calling the user-defined application subroutines
=head3 Application Subroutines
Once the application object has been created it can then be run by calling the 'go()' method. go() calls the application's registered functions
in turn:
=over 2
=item * app_start()
Called at the start of the application. You can use this for any additional set up (usually of more use to extension developers)
=item * app()
Called once all of the arguments and options have been processed
=item * app_end()
Called when B<app()> terminates or returns (usually of more use to extension developers)
=back
The framework looks for these 3 functions to be defined in the script file. The functions B<app_start> and B<app_end> are optional, but it is expected that B<app> will be defined
(otherwise nothing happens!).
=head3 Setup
The application settings are entered into the __DATA__ section at the end of the file. All program settings are grouped under sections which are introduced by '[section]' style headings. There are many
different settings that can be set using this mechanism, but the framework sets most of them to useful defaults.
For more details see L</Options> and L</Args>.
=head4 Summary
This should be a single line, concise summary of what the script does. It's used in the terse man page created by pod2man.
=head4 Description
As you'd expect, this should be a full description, user-guide etc. on what the script does and how to do it. Notice that this example
has used one (of many) of the variables available: $name (which expands to the script name, without any path or extension).
=head4 Example
An example script setup is:
__DATA__
[SUMMARY]
An example of using the application framework
[ARGS]
* infile=f Input file
Should be set to the input file
* indir=d Input dir
Should be set to the input dir
[OPTIONS]
-table=s Table [default=listings2]
Sql table name
-database=s Database [default=tvguide]
Sql database name
[DESCRIPTION]
B<$name> is an example script.
=head2 Args
Args feature that provides command line arguments handling.
Command line arguments are defined once in a text format and this text format generates both the command line arguments data, but also the man pages,
help text etc. Defining the expected arguments and their types allows the module to check for the existence of the program arguments and their correctness.
=head3 Argument Definition
Arguments are specified in the application __DATA__ section in the format:
* <name>=<specification> <Summary> <optional default setting>
<Description>
The parts of the specification are defined below.
=head4 name
The name defines the name of the key to use to access the argument value in the arguments hash. The application framework
passes a reference to the argument hash as the third parameter to the application subroutine B<app> (see L</Script Usage>)
lib/App/Framework/Lite.pm view on Meta::CPAN
When a default is defined, if the user does not specify a value for an argument then that argument takes on the defualt value.
Also, all subsequent arguments must also be defined as optional.
=head4 description
The summary is multiple lines of text used to fully describe the option. It is used in the man pages in 'man' mode.
=head3 Feature Options
The Args feature allows control over how it opens files. By default, any input or output file definitions also create equivalent file handles
(the files being opened for read/write automatically). These file handles are made available only in the arguments HASH. The key name for the handle
being the name of the argument with the suffix '_fh'.
For example, the following definition:
[ARGS]
* file=f Input file
A simple input directory name (directory must exist)
* out=>f Output file (file will be created)
An output filename
And the command line arguments:
infile.txt outfile.txt
Results in the arguments HASH:
'file' => 'infile.txt'
'out' => 'outfile.txt'
'file_fh' => <file handle of 'infile.txt'>
'out_fh' => <file handle of 'outfile.txt'>
If this behaviour is not required, then you can get the framework to open just input files, output files, or none by using the 'open' option.
Specify this in the App::Framework 'use' line as an argument to the Args feature:
# Open no file handles
use App::Framework '+Args(open=none)' ;
# Open only input file handles
use App::Framework '+Args(open=in)' ;
# Open only output file handles
use App::Framework '+Args(open=out)' ;
# Open all file handles (the default)
use App::Framework '+Args(open=all)' ;
=head3 Variable Expansion
Argument values can contain variables, defined using the standard Perl format:
$<name>
${<name>}
When the argument is used, the variable is expanded and replaced with a suitable value. The value will be looked up from a variety of possible sources:
object fields (where the variable name matches the field name) or environment variables.
The variable name is looked up in the following order, the first value found with a matching name is used:
=over 4
=item *
Argument names - the values of any other arguments may be used as variables in arguments
=item *
Option names - the values of any command line options may be used as variables in arguments
=item *
Application fields - any fields of the $app object may be used as variables
=item *
Environment variables - if no application fields match the variable name, then the environment variables are used
=back
=head2 Script Usage
The application framework passes a reference to the argument HASH as the third parameter to the application subroutine B<app>. Alternatively,
the script can call the app object's alias to the args accessor, i.e. the B<args> method which returns the arguments value list. Yet another
alternative is to call the args accessor method directly. These alternatives are shown below:
sub app
{
my ($app, $opts_href, $args_href) = @_ ;
# use parameter
my $infile = $args_href->{infile}
# access alias
my @args = $app->args() ;
$infile = $args[0] ;
# access alias
@args = $app->Args() ;
$infile = $args[0] ;
($infile) = $app->args('infile') ;
# feature object
@args = $app->feature('Args')->args() ;
$infile = $args[0] ;
}
=head3 Examples
With the following script definition:
lib/App/Framework/Lite.pm view on Meta::CPAN
=over 4
=item s
String. An arbitrary sequence of characters. It is valid for the
argument to start with C<-> or C<-->.
=item i
Integer. An optional leading plus or minus sign, followed by a
sequence of digits.
=item o
Extended integer, Perl style. This can be either an optional leading
plus or minus sign, followed by a sequence of digits, or an octal
string (a zero, optionally followed by '0', '1', .. '7'), or a
hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
insensitive), or a binary string (C<0b> followed by a series of '0'
and '1').
=item f
Real number. For example C<3.14>, C<-6.23E24> and so on.
=back
The I<desttype> can be C<@> or C<%> to specify that the option is
list or a hash valued. This is only needed when the destination for
the option value is not otherwise specified. It should be omitted when
not needed.
The I<flag>, if used, can be C<dev:> to specify that the option is meant for application developer
use only. In this case, the option will not be shown in the normal help and man pages, but will
only be shown when the -man-dev option is used.
=head4 summary
The summary is a simple line of text used to summarise the option. It is used in the man pages in 'usage' mode.
=head3 default
Defaults values are optional. If they are defined, they are in the format:
[default=<value>]
When a default is defined, if the user does not specify a value for an option then that option takes on the defualt value.
=head4 description
The summary is multiple lines of text used to fully describe the option. It is used in the man pages in 'man' mode.
=head3 Variable Expansion
Option values and default values can contain variables, defined using the standard Perl format:
$<name>
${<name>}
When the option is used, the variable is expanded and replaced with a suitable value. The value will be looked up from a variety of possible sources:
object fields (where the variable name matches the field name) or environment variables.
The variable name is looked up in the following order, the first value found with a matching name is used:
=over 4
=item *
Option names - the values of any other options may be used as variables in options
=item *
Application fields - any fields of the $app object may be used as variables
=item *
Environment variables - if no application fields match the variable name, then the environment variables are used
=back
=head3 Script Usage
The application framework passes a reference to the options HASH as the second parameter to the application subroutine B<app>. Alternatively,
the script can call the app object's alias to the options accessor, i.e. the B<options> method which returns the options hash. Yet another
alternative is to call the options accessor method directly. These alternatives are shown below:
sub app
{
my ($app, $opts_href, $args_href) = @_ ;
# use parameter
my $log = $opts_href->{log}
# access alias
my %options = $app->options() ;
$log = $options{log} ;
# access alias
%options = $app->Options() ;
$log = $options{log} ;
# feature object
%options = $app->feature('Options')->options() ;
$log = $options{log} ;
}
=head3 Examples
With the following script definition:
[OPTIONS]
-n|'name'=s Test name [default=a name]
String option, accessed as $opts_href->{name}.
-nomacro Do not create test macro calls
lib/App/Framework/Lite.pm view on Meta::CPAN
__DATA__ sections that have special meaning are:
=over 4
=item B<[OPTIONS]> - Application command line options
These are fully described in L<App::Framework::Features::Options>.
If no options are specified, then only those created by the application framework will be defined.
=item B<[ARGS]> - Application command line arguments [I<optional>]
These are fully described in L<App::Framework::Features::Args>.
=back
=head3 Named Data
After the settings (described above), one or more extra data areas can be created by starting that area with a new __DATA__ line.
Each defined data area is named 'data1', 'data2' and so on. These data areas are user-defined multi line text that can be accessed
by the object's accessor method L</data>, for example:
my $data = $app->data('data1') ;
Alternatively, the user-defined data section can be arbitrarily named by appending a text name after __DATA__. For example, the definition:
__DATA__
[DESCRIPTION]
An example
__DATA__ test.txt
some text
__DATA__ a_bit_of_sql.sql
DROP TABLE IF EXISTS `listings2`;
leads to the use of the defined data areas as:
my $file = $app->data('text.txt') ;
# or
$file = $app->data('data1') ;
my $sql = $app->data('a_bit_of_sql.sql') ;
# or
$file = $app->Data('data2') ;
=head3 Variable Expansion
The data text can contain variables, defined using the standard Perl format:
$<name>
${<name>}
When the data is used, the variable is expanded and replaced with a suitable value. The value will be looked up from a variety of possible sources:
object fields (where the variable name matches the field name) or environment variables.
The variable name is looked up in the following order, the first value found with a matching name is used:
=over 4
=item *
Option names - the values of any command line options may be used as variables
=item *
Arguments names - the values of any command line arguments may be used as variables
=item *
Application fields - any fields of the $app object may be used as variables
=item *
Environment variables - if no application fields match the variable name, then the environment variables are used
=back
=head3 Data Comments
Any lines starting with:
__#
are treated as comment lines and not included in the data.
=head2 Directories
The framework sets up various directory paths automatically, as described below.
=head3 @INC path
App::Framework automatically pushes some extra directories at the start of the Perl include library path. This allows you to 'use' application-specific
modules without having to install them globally on a system. The path of the executing Perl application is found by following any links until
an actually Perl file is found. The @INC array has the following added:
* $progpath
* $progpath/lib
i.e. The directory that the script resides in, and a sub-directory 'lib' will be searched for application-specific modules.
Note that this is the path also used when the framework loads in the core personality, and any optional extensions.
=head2 EMBEDDING
A script may be developed and debugged using the App::Framework::Lite module installed on a system, and then turned into a standalone Perl
script by embedding the App::Framework::Lite module into the script file. Also, a developer may choose to also embed any user library modules
related to this script (or may just deliver them in their dubdirectory along with the standalone script).
lib/App/Framework/Lite.pm view on Meta::CPAN
$this->app_start() ;
$this->app_handle_opts() ;
$this->application() ;
$this->app_end() ;
$this->exit(0) ;
}
#----------------------------------------------------------------------------
=item B<getopts()>
Convert the (already processed) options list into settings.
Returns result of calling GetOptions
=cut
sub getopts
{
my $this = shift ;
# get options
my $ok = $this->get_options() ;
# If ok, get any specified filenames
if ($ok)
{
# Get args
my $arglist = $this->get_args() ;
$this->_dbg_prt(["getopts() : arglist=", $arglist], 2) ;
}
## Expand vars
my %values ;
my ($opt_values_href, $opt_defaults_href) = $this->option_values_hash() ;
my ($args_values_href) = $this->args_values_hash() ;
%values = (%$opt_values_href) ;
my %args_clash ;
foreach my $key (keys %$args_values_href)
{
if (exists($values{$key}))
{
$args_clash{$key} = $args_values_href->{$key} ;
}
else
{
$values{$key} = $args_values_href->{$key} ;
}
}
my @vars ;
my %app_vars = $this->vars ;
push @vars, \%app_vars ;
push @vars, \%ENV ;
## expand all vars
$this->expand_keys(\%values, \@vars) ;
# set new values
foreach my $key (keys %$opt_values_href)
{
$opt_values_href->{$key} = $values{$key} ;
}
foreach my $key (keys %$args_values_href)
{
$args_values_href->{$key} = $values{$key} ;
}
## handle any name clash
if (keys %args_clash)
{
unshift @vars, \%values ;
$this->expand_keys(\%args_clash, \@vars) ;
# set new values
foreach my $key (keys %args_clash)
{
$args_values_href->{$key} = $args_clash{$key} ;
}
}
## update settings
$this->option_values_set($opt_values_href, $opt_defaults_href) ;
$this->args_values_set($args_values_href) ;
return $ok ;
}
#----------------------------------------------------------------------------
=item B<app_start()>
Set up before running the application.
Calls the following methods in turn:
* getopts
* [internal _expand_vars method]
* options
=cut
sub app_start
{
my $this = shift ;
## Process data
$this->process_data() ;
## Get options
# get the list suitable for GetOpts
my $get_options_aref = $this->{_get_options} ;
## Get options
# NOTE: Need to do this here so that derived objects work properly
my $ok = $this->getopts() ;
## Expand any variables in the application object field values
$this->_expand_vars() ;
# Handle options errors here after expanding variables
unless ($ok)
{
$this->usage('opt') ;
$this->exit(1) ;
}
## Run application function
my %options = $this->options() ;
$this->_exec_fn('app_start', $this, \%options) ;
## expand data variables
my %app_vars = $this->vars() ;
my %opts = $this->options() ;
my $args_values_href = $this->args_values_hash() ;
my $data_href = $this->{_data_hash} ;
$this->expand_keys($data_href, [\%opts, $args_values_href, \%app_vars, \%ENV]) ;
}
#----------------------------------------------------------------------------
=item B<app_handle_opts()>
Handles the default options (for example -man, -help etc)
=cut
sub app_handle_opts
{
my $this = shift ;
## Get options
my %options = $this->options() ;
## Handle special options
my %opts = $this->options() ;
if ($opts{'man'} || $opts{'help'})
{
my $type = $opts{'man'} ? 'man' : 'help' ;
$this->usage($type) ;
$this->exit(0) ;
}
if ($opts{'man-dev'})
{
$this->usage('man-dev') ;
$this->exit(0) ;
}
if ($opts{'pod'})
{
print $this->pod() ;
$this->exit(0) ;
}
if ($opts{'alf-debug'})
{
$this->{debug} = $opts{'alf-debug'} ;
}
if ($opts{'dbg-data'})
{
$this->_show_data() ;
$this->exit(0) ;
}
if ($opts{'dbg-data-array'})
{
$this->_show_data_array() ;
$this->exit(0) ;
}
if ($opts{'alf-info'})
{
print "App::Framework::Lite info\n" ;
print " Version: $VERSION\n" ;
print " Embedded: " . ($EMBEDDED ? "yes" : "no") . "\n" ;
$this->exit(0) ;
}
lib/App/Framework/Lite.pm view on Meta::CPAN
($exitval, $verbose) = (1, 0) if ($level eq 'help') ;
($exitval, $verbose) = (0, 2) if ($level =~ /^man/) ;
# make file readable by all - in case we're running as root
chmod 0644, $fname ;
# system("perldoc", $fname) ;
pod2usage(
-verbose => $verbose,
# -exitval => $exitval,
-exitval => 'noexit',
-input => $fname,
-noperldoc =>1,
-title => $this->{name},
-section => 1,
) ;
# remove temp file
unlink $fname ;
}
#============================================================================================
# OPTIONS
#============================================================================================
#----------------------------------------------------------------------------
=item B< options() >
Returns the hash of options/values
=cut
sub options
{
my $this = shift ;
$this->_dbg_prt( ["Options()\n"] ) ;
my $options_href = $this->{_options} ;
return %$options_href ;
}
#----------------------------------------------------------------------------
=item B< Options([%args]) >
Alias to L</options>
=cut
*Options = \&options ;
#----------------------------------------------------------------------------
#
#=item B<_expand_options()>
#
#Expand any variables in the options
#
#=cut
#
sub _expand_options
{
my $this = shift ;
$this->_dbg_prt(["_expand_options()\n"]) ;
my $options_href = $this->{_options} ;
my $options_fields_href = $this->{_option_fields_hash} ;
# get defaults & options
my (%defaults, %values) ;
foreach my $opt (keys %$options_fields_href)
{
$defaults{$opt} = $options_fields_href->{$opt}{'default'} ;
$values{$opt} = $options_href->{$opt} if defined($options_href->{$opt}) ;
}
$this->_dbg_prt(["_expand_options: defaults=",\%defaults," values=",\%values,"\n"]) ;
# # get replacement vars
# my @vars ;
# my $app = $this->app ;
# if ($app)
# {
# my %app_vars = $app->vars ;
# push @vars, \%app_vars ;
# }
# ## expand
# my @vars ;
# push @vars, \%ENV ;
# $this->expand_keys(\%values, \@vars) ;
# push @vars, \%values ; # allow defaults to use user-specified values
# $this->expand_keys(\%defaults, \@vars) ;
#
#$this->_dbg_prt(["_expand_options - end: defaults=",\%defaults," values=",\%values,"\n"]) ;
## Update
foreach my $opt (keys %$options_fields_href)
{
# update defaults to reflect any user specified options
$defaults{$opt} = $values{$opt} ;
$options_fields_href->{$opt}{'default'} = $defaults{$opt} ;
# update values
$options_href->{$opt} = $values{$opt} if defined($options_href->{$opt}) ;
}
}
#----------------------------------------------------------------------------
=item B<get_options()>
Use Getopt::Long to process the command line options. Returns 1 on success; 0 otherwise
=cut
sub get_options
{
my $this = shift ;
# Do final processing of the options
$this->update() ;
# get the list suitable for GetOpts
my $get_options_aref = $this->{_get_options} ;
$this->_dbg_prt( ["get_options() : ARGV=", \@ARGV, " Options=", $get_options_aref], 2 ) ;
# Parse options using GetOpts
my $ok = GetOptions(@$get_options_aref) ;
# Expand the options variables
$this->_expand_options() ;
$this->_dbg_prt( ["get_options() : ok=$ok Options now=", $get_options_aref], 2 ) ;
return $ok ;
}
#----------------------------------------------------------------------------
=item B<option_entry($option_name)>
Returns the HASH ref of option if name is found; undef otherwise.
The HASH ref contains:
'field' => option 'main' name
'spec' => specification string
'summary' => summary text
'description' => description text
'default' => default value (if specified)
'pod_spec' => specification string suitable for pod output
'type' => option type (e.g. s, f etc)
'dest_type' => destination type (e.g. @, %)
'developer' => developer only option (flag set if option is to be used for developer use only)
'entry' => reference to the ARRAY that defined the option (as per L</append_options>)
=cut
sub option_entry
{
my $this = shift ;
my ($option_name) = @_ ;
my $option_fields_href = $this->{_option_fields_hash} ;
my $opt_href ;
if (exists($option_fields_href->{$option_name}))
{
$opt_href = $option_fields_href->{$option_name} ;
}
return $opt_href ;
}
#----------------------------------------------------------------------------
=item B<option_values_hash()>
Returns the options values and defaults HASH references in an array, values HASH ref
as the first element.
=cut
sub option_values_hash
{
my $this = shift ;
my $options_href = $this->{_options} ;
my $options_fields_href = $this->{_option_fields_hash} ;
# get defaults & options
lib/App/Framework/Lite.pm view on Meta::CPAN
}
else
{
my $md = $arg_names_href->{$name}{'append'} ? 'append' : 'write' ;
$this->_complain_usage_exit("Unable to $md file \"$val\" : $!") ;
}
}
}
}
}
}
#-----------------------------------------------------------------------------
=item B< close_args() >
If any arguements cause files/devices to be opened, this shuts them down
=cut
sub close_args
{
my $this = shift ;
# File handles
my $fh_aref = $this->{_fh_list} ;
foreach my $fh (@$fh_aref)
{
close $fh ;
}
}
#----------------------------------------------------------------------------
=item B<get_args()>
Finish any args processing and return the arguments list
=cut
sub get_args
{
my $this = shift ;
# save @ARGV
$this->{argv} = \@ARGV ;
my @args = @ARGV ;
# Copy values over
$this->_process_argv() ;
my %args ;
%args = $this->arg_hash() ;
$this->_dbg_prt(["Args before expand : hash=", \%args]) ;
# Expand the args variables
$this->_expand_args() ;
# Set arg list
my @arg_array ;
%args = $this->arg_hash() ;
my $arg_list = $this->{arg_names} ;
foreach my $name (@$arg_list)
{
push @arg_array, $args{$name} ;
}
$this->{_arg_list} = \@arg_array ;
# return arglist
return $this->arg_list ;
}
#----------------------------------------------------------------------------
=item B<arg_entry($arg_name)>
Returns the HASH ref of arg if name is found; undef otherwise
=cut
sub arg_entry
{
my $this = shift ;
my ($arg_name) = @_ ;
my $arg_names_href = $this->{_arg_names_hash} ;
my $arg_href ;
if (exists($arg_names_href->{$arg_name}))
{
$arg_href = $arg_names_href->{$arg_name} ;
}
return $arg_href ;
}
#----------------------------------------------------------------------------
=item B<args_values_hash()>
Returns the args values HASH reference.
=cut
sub args_values_hash
{
my $this = shift ;
my $args_href = $this->{_args} ;
my $args_names_href = $this->{_arg_names_hash} ;
# get args
my %values ;
foreach my $arg (keys %$args_names_href)
{
$values{$arg} = $args_href->{$arg} if defined($args_href->{$arg}) ;
}
return \%values ;
}
#----------------------------------------------------------------------------
=item B<args_values_set($values_href)>
Sets the args values based on the values in the HASH reference B<$values_href>.
=cut
sub args_values_set
{
my $this = shift ;
my ($values_href) = @_ ;
my $args_href = $this->{_args} ;
my $args_names_href = $this->{_arg_names_hash} ;
## Update
# foreach my $arg (keys %$args_names_href)
# {
# $args_href->{$arg} = $values_href->{$arg} if defined($args_href->{$arg}) ;
# }
# Cycle through
my $names_aref = $this->{arg_names} ;
foreach my $arg (@$names_aref)
{
if ( defined($args_href->{$arg}) )
{
my $arg_entry_href = $this->arg_entry($arg) ;
$args_href->{$arg} = $values_href->{$arg} ;
$arg_entry_href->{'default'} = $values_href->{$arg} ;
}
}
}
#----------------------------------------------------------------------------
#
#=item B<_expand_vars()>
#
#Run through some of the application variables/fields and expand any instances of variables embedded
#within the values.
#
#Example:
#
# __DATA_
#
# [SYNOPSIS]
#
# $name [options] <rrd file(s)>
#
#Here the 'synopsis' field contains the $name field variable. This needs to be expanded to the value of $name.
#
#NOTE: Currently this will NOT cope with cross references (so, if in the above example $name also contains a variable
#then that variable may or may not be expanded before the synopsis field is processed)
#
#
#=cut
#
sub _expand_vars
{
my $this = shift ;
# Get hash of fields
my %fields = $this->vars() ;
print "_expand_vars()\n" if $this->{'debug'}>=2 ;
# work through each field, create a list of those that have changed
my %changed ;
foreach my $field (sort keys %fields)
{
# Skip non-scalars
next if ref($fields{$field}) ;
print " + check $field...\n" if $this->{'debug'}>=2 ;
# First see if this contains a '$'
$fields{$field} ||= "" ;
my $ix = index $fields{$field}, '$' ;
if ($ix >= 0)
{
print " + + got some vars in $field = $fields{$field}\n" if $this->{'debug'}>=2 ;
# Do replacement
$fields{$field} =~ s{
\$ # find a literal dollar sign
\{{0,1} # optional brace
(\w+) # find a "word" and store it in $1
\}{0,1} # optional brace
}{
no strict 'refs'; # for $$1 below
if (defined $fields{$1}) {
$fields{$1}; # expand global variables only
} else {
"\${$1}"; # leave it
}
}egx;
# Add to list
$changed{$field} = $fields{$field} ;
print " + + $field now = $fields{$field}\n" if $this->{'debug'}>=2 ;
}
}
# If some have changed then set them
if (keys %changed)
{
$this->set(%changed) ;
}
print "_expand_vars() - done\n" if $this->{'debug'}>=2 ;
}
#----------------------------------------------------------------------------
#
#=item B<_expand_args()>
#
#Expand any variables in the args
#
#=cut
#
sub _expand_args
{
my $this = shift ;
my $args_href = $this->{_args} ;
my $args_names_href = $this->{_arg_names_hash} ;
# get args
my %values ;
foreach my $arg (keys %$args_names_href)
{
$values{$arg} = $args_href->{$arg} if defined($args_href->{$arg}) ;
}
# get replacement vars
# my @vars ;
# my $app = $this->app ;
# if ($app)
# {
# my %app_vars = $app->vars ;
# push @vars, \%app_vars ;
# my %opt_vars = $app->options() ;
# push @vars, \%opt_vars ;
# }
# push @vars, \%ENV ;
# ## expand
# $this->expand_keys(\%values, \@vars) ;
## Update
foreach my $arg (keys %$args_names_href)
{
$args_href->{$arg} = $values{$arg} if defined($args_href->{$arg}) ;
}
}
#----------------------------------------------------------------------------
#
#=item B<_process_argv()>
#
#Processes the @ARGV array
#
#=cut
#
sub _process_argv
{
my $this = shift ;
my $argv_aref = $this->{argv} ;
my @args = @$argv_aref ;
$argv_aref = [] ; # clear our args, rebuild the list as we process them
my $idx = 0 ;
$this->_dbg_prt(["_process_argv() : args=", \@args]) ;
# values
my $args_href = $this->{_args} ;
# details
my $args_names_href = $this->{_arg_names_hash} ;
my $dest_type ;
my $arg_list = $this->{arg_names} ;
foreach my $name (@$arg_list)
{
if ($args_names_href->{$name}{'dest_type'})
{
# set value
$args_href->{$name} = [] ;
}
}
foreach my $name (@$arg_list)
{
last unless @args ;
my $arg = shift @args ;
# set value
$args_href->{$name} = $arg ;
push @$argv_aref, $arg ;
# get this dest type
$dest_type = $name if $args_names_href->{$name}{'dest_type'} ;
++$idx ;
}
# If last arg specified as ARRAY, then convert value to ARRAY ref
lib/App/Framework/Lite.pm view on Meta::CPAN
{
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"}))
{
print " + already seen data for key=$key\n" if $this->{debug}>=2;
# already got created a state for this data, point to it
$_state_href->{$key} = $data_ref{"$ref"} ;
}
else
{
print " + new state key=$key\n" if $this->{debug}>=2;
my $state = 'expanded' ;
$_state_href->{$key} = \$state ;
}
# save data reference
$data_ref{"$ref"} = $_state_href->{$key} if $ref ;
print " + check for expansion...\n" if $this->{debug}>=2;
foreach my $val (@vals)
{
next unless $val ;
print " + + val=$val\n" if $this->{debug}>=2;
if (index($val, '$') >= 0)
{
print " + + + needs expanding\n" if $this->{debug}>=2;
$to_expand{$key}++ ;
${$_state_href->{$key}} = 'to_expand' ;
last ;
}
}
}
}
$this->prt_data("to expand=", \%to_expand) if $this->{debug};
$this->prt_data("Hash=", $hash_ref) if $this->{debug};
## Expand them
foreach my $key (keys %to_expand)
{
print " # Key=$key State=${$_state_href->{$key}}\n" if $this->{debug};
# skip if not valid (if called recursively with a variable that is not in the hash)
next unless exists($hash_ref->{$key}) ;
# Do replacement iff required
next if ${$_state_href->{$key}} eq 'expanded' ;
my @vals ;
if (ref($hash_ref->{$key}) eq 'ARRAY')
{
foreach my $val (@{$hash_ref->{$key}})
{
push @vals, \$val ;
}
}
elsif (!ref($hash_ref->{$key}))
{
push @vals, \$hash_ref->{$key} ;
}
# mark as expanding
${$_state_href->{$key}} = 'expanding' ;
$this->prt_data("Vals to expand=", \@vals) if $this->{debug};
#use re 'debugcolor' ;
foreach my $val_ref (@vals)
{
print " # Expand \"$$val_ref\" ...\n" if $this->{debug};
$$val_ref =~ s{
(?:
[\\\$]\$ # escaped dollar
\{{0,1} # optional brace
([\w\-\d]+) # find a "word" and store it in $1
\}{0,1} # optional brace
)
|
(?:
\$ # find a literal dollar sign
\{{0,1} # optional brace
([\w\-\d]+) # find a "word" and store it in $1
\}{0,1} # optional brace
)
}{
my $prefix = '' ;
my ($escaped, $var) = ($1, $2) ;
$escaped ||= '' ;
$var ||= '' ;
print " # esc=\"$escaped\", prefix=\"$prefix\", var=\"$var\"\n" if $this->{debug};
my $replace='' ;
if ($escaped)
{
$prefix = '$' ;
$replace = $escaped ;
print " ## escaped prefix=$prefix replace=$replace\n" if $this->{debug};
print " ## DONE\n" if $this->{debug};
}
else
{
## 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) ;
}
#-----------------------------------------------------------------------------
( run in 2.484 seconds using v1.01-cache-2.11-cpan-5b529ec07f3 )