view release on metacpan or  search on metacpan

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

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

=item B<catch_error($error)>

Function that gets called on errors. $error is as defined in L<App::Framework::Base::Object::ErrorHandle>

=cut

sub catch_error
{
	my $this = shift ;
	my ($error) = @_ ;

# Does nothing!

$this->_dispatch_entry_features($error) ;
	
$this->_dispatch_exit_features($error) ;

}


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

=item B<install_features($feature_list [, $feature_args])>

Add the listed features to the application. List is an ARRAY ref list of feature names.

Note: names need correct capitalisation (e.g. Sql not sql) - or just use first char capitalised(?)

Method/feature name will be all lowercase 

Optionally, can specify I<$feature_args> HASH ref. Each feature name in I<$feature_list> should be a key
in the HASH, the value of which is an arguments string (which is a list of feature arguments separated by space and/or
commas)

=cut

sub install_features
{
	my $this = shift ;
	my ($feature_list, $feature_args_href) = @_ ;

	$feature_args_href ||= {} ;
	
	my $features_href = $this->_feature_list() ;

	## make a list of features
	my @features = @$feature_list ;
	
$this->_dbg_prt(["install_features()", \@features, "features args=", $feature_args_href]) ;
$class_debug = $this->debug if $this->debug >= 5 ;

	
	## Now try to install them
	foreach my $feature (@features)
	{
		my $feature_args = $feature_args_href->{$feature} || "" ;
		
		my $loaded ;
		my $feature_guess = ucfirst(lc($feature)) ;
		
		## skip if already loaded
		if (exists($features_href->{$feature}) || exists($features_href->{$feature_guess}))
		{
			## Just need to see if we've got any new args
			foreach my $feat ($feature, $feature_guess)
			{
				if (exists($feature_args_href->{$feat}))
				{
					## override args 
					my $feature_obj = $features_href->{$feature}{'object'} ;
					$feature_obj->feature_args($feature_args_href->{$feat}) ;
				}						
			}
			next ;
		}

		# build list of module names to attempt. If personality name is set, try looking for feature
		# under personality subdir first. This allows for personality override of feature (e.g. POE:app overrides Script:app)
		#
		my @tries ;
		my $personality = $this->personality ;
		my $root = "App::Framework::Feature" ;
		if ($personality)
		{
			push @tries, "${root}::${personality}::$feature" ; 
			push @tries, "${root}::${personality}::$feature_guess" ; 
		}
		push @tries, "${root}::$feature" ; 
		push @tries, "${root}::$feature_guess" ; 
		
		foreach my $module (@tries)
		{
			if ($this->dynamic_load($module))
			{
				$loaded = $module ;
				last ;
			}
		}

		my $cwd = cwd() ;
$this->_dbg_prt(["Feature: $feature - unable to load. CWD=$cwd.\n", "Tried=", \@tries, "\n\@INC=", \@INC]) unless ($loaded) ;

		croak "Feature \"$feature\" not supported" unless ($loaded) ;

$this->_dbg_prt(["Feature: $feature - loaded=$loaded\n"]) ;
		
		if ($loaded)
		{
			# save in list
			my $module = $loaded ;
			my $specified_name = $feature ;
			$feature = lc $feature ;

			$features_href->{$feature} = {
				'module'	=> $module,		# loaded module name
				'specified'	=> $specified_name,	# as specified by user
				'name'		=> $feature,	# name used as a method
				'object'	=> undef, 
				'priority'	=> $App::Framework::Base::PRIORITY_DEFAULT,
			} ;
			
			# see if we have some extra init values to pass to the feature
			my $feature_init_href = $this->_feature_init($feature) ;
			
			# create feature
			my $feature_obj = $module->new(
				%$feature_init_href,
				
				'app'			=> $this,
				'name'			=> $feature,		# ensure it matches with what the app expects
				'feature_args'	=> $feature_args,

				# Set up error handler
				'catch_fn' 		=> sub {$this->catch_error(@_);},

			) ;

			# add to list (may already have been done if feature registers any methods)
			$features_href->{$feature}{'object'} = $feature_obj ;
			$features_href->{$feature}{'priority'} = $feature_obj->priority ;
			
			# set up alias
			{
				no warnings 'redefine';
				no strict 'refs';
				
				## alias <feature>()
				my $alias = lc $feature ; 
				*{"App::Framework::Core::${alias}"} = sub {