view release on metacpan or  search on metacpan

lib/App/Framework/Core.pm  view on Meta::CPAN

$this->_dispatch_exit_features() ;

	$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 ;

$this->_dispatch_entry_features() ;

	# Parse options using GetOpts
	my $opt = $this->feature('Options') ;
	my $args = $this->feature('Args') ;
	
	my $ok = $opt->get_options() ;

	# If ok, get any specified filenames
	if ($ok)
	{
		# Get args
		my $arglist = $args->get_args() ;

		$this->_dbg_prt(["getopts() : arglist=", $arglist], 2) ;
	}
	
	## Expand vars
	my %values ;
	my ($opt_values_href, $opt_defaults_href) = $opt->option_values_hash() ;
	my ($args_values_href) = $args->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
	$opt->option_values_set($opt_values_href, $opt_defaults_href) ;
	$args->args_values_set($args_values_href) ;

$this->_dispatch_exit_features() ;

	return $ok ;
}


#----------------------------------------------------------------------------

=item B<app_start()>

Set up before running the application.

Calls the following methods in turn:

* getopts
* [internal _expand_vars method]
* options
* (Application registered 'app_start' function)
 
=cut


sub app_start
{
	my $this = shift ;

$this->_dispatch_entry_features() ;

	## process the data
	$this->feature('data')->process() ;
	
	## allow features to add their options
	my $features_aref = $this->feature_list() ;
	foreach my $feature (@$features_aref)
	{
		my $feature_obj = $this->feature($feature) ;
		my $feature_options_aref = $feature_obj->feature_options() ;
		if (@$feature_options_aref)
		{
			$this->feature('Options')->append_options($feature_options_aref, $feature_obj->class) ;
		}		
	}

	## Add user-defined options last
	$this->feature('Data')->append_user_options() ;


	## Get options
	# NOTE: Need to do this here so that derived objects work properly
	my $ret = $this->getopts() ;
	
	## Expand any variables in the data
	$this->_expand_vars() ;

	# Handle options errors here after expanding variables
	unless ($ret)
	{
		$this->usage('opt') ;
		$this->exit(1) ;
	} 

	# get options
	my %options = $this->options() ;
	
	## function
	$this->_exec_fn('app_start', $this, \%options) ;
	
$this->_dispatch_exit_features() ;
	
}


#----------------------------------------------------------------------------

=item B<application()>

Execute the application.
 
Calls the following methods in turn:

* (Application registered 'app' function)
 

=cut


sub application
{
	my $this = shift ;

$this->_dispatch_entry_features() ;

	## Execute function
	my %options = $this->options() ;

	## Check args here (do this AFTER allowing derived objects/features a chance to check the options etc)
	$this->feature("Args")->check_args() ;
	
	# get args
	my %args = $this->feature("Args")->arg_hash() ;

	## Run application function
	$this->_exec_fn('app', $this, \%options, \%args) ;

	## Close any open arguments
	$this->feature("Args")->close_args() ;
	

$this->_dispatch_exit_features() ;

}

#----------------------------------------------------------------------------

=item B<app_end()>

lib/App/Framework/Core.pm  view on Meta::CPAN

sub _register_var 
{
	my $this = shift ;
	my ($type, $external_name, $field_name) = @_ ;

	my $package = $this->package() ;

    local (*alias);             # a local typeglob

$this->_dbg_prt(["_register_var($type, $external_name, $field_name)\n"], 2) ;

    # We want to get access to the stash corresponding to the package
    # name
no strict "vars" ;
no strict "refs" ;
    *stash = *{"${package}::"};  # Now %stash is the symbol table

	if (exists($stash{$external_name}))
	{
		*alias = $stash{$external_name} ;

$this->_dbg_prt([" + found $external_name in $package\n"], 2) ;

		if ($type eq 'SCALAR')
		{
			if (defined($alias))
			{
				$this->set($field_name => $alias) ;
			}
		}
		if ($type eq 'ARRAY')
		{
			# was - if (defined(@alias)) - removed due to "deprecated" warning
			if (@alias)
			{
				$this->set($field_name => \@alias) ;
			}
		}
		if ($type eq 'HASH')
		{
			if (%alias)
			{
				$this->set($field_name => \%alias) ;
			}
		}
		elsif ($type eq 'CODE')
		{
			if (defined(&alias))
			{
$this->_dbg_prt([" + + Set $type - $external_name as $field_name\n"], 2) ;
				$this->set($field_name => \&alias) ;
			}
		}

	}
}


#----------------------------------------------------------------------------
#
#=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 ;

$this->_dbg_prt(["_expand_vars() - START\n"], 2) ;

	# Get hash of fields
	my %fields = $this->vars() ;

#$this->_dbg_prt([" + fields=", \%fields], 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}) ;
		
		# First see if this contains a '$'
		$fields{$field} ||= "" ;
		my $ix = index $fields{$field}, '$' ; 
		if ($ix >= 0)
		{
$this->_dbg_prt([" + + $field = $fields{$field} : index=$ix\n"], 3) ;

			# 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;


$this->_dbg_prt([" + + + new = $fields{$field}\n"], 3) ;
			
			# Add to list
			$changed{$field} = $fields{$field} ;
		}
	}

$this->_dbg_prt([" + changed=", \%changed], 2) ;
	
	# If some have changed then set them
	if (keys %changed)
	{
$this->_dbg_prt([" + + set changed\n"], 2) ;
		$this->set(%changed) ;
	}

$this->_dbg_prt(["_expand_vars() - END\n"], 2) ;
}



#----------------------------------------------------------------------------

=item B<debug_prt($items_aref [, $min_debug])>

Print out the items in the $items_aref ARRAY ref iff the application's debug level is >0. 
If $min_debug is specified, will only print out items if the application's debug level is >= $min_debug.

=cut

sub debug_prt
{
	my $this = shift ;
	my ($items_aref, $min_debug) = @_ ;

	$min_debug ||= 1 ;
	
	## check debug level setting
	if ($this->options->option('debug') >= $min_debug)
	{
		$this->prt_data(@$items_aref) ;
	}
}



# ============================================================================================
# PRIVATE FUNCTIONS
# ============================================================================================

#----------------------------------------------------------------------------
#
#=item B<_dumpisa(package)>
#
#Starting at I<package>, show the parents
#
#=cut
#
sub _dumpisa
{
no strict "vars" ;
no strict "refs" ;

    my ($packageName, $level) = @_;
    
    
    if (!defined($level)) 
    {
    	print "#### PACKAGE: $packageName  ISA HIERARCHY ###########################\n" ;
    }
    else
    {
    	print " "x$level ;
    	print "$packageName\n" ;
    }
    
    foreach my $isa (@{"${packageName}::ISA"})