view release on metacpan or  search on metacpan

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

Then checks that the load was ok by checking the module's version number.

Returns 1 on success; 0 on failure.
 
=cut

sub dynamic_load
{
	my $class = shift ;
	my ($module, $pkg) = @_ ;

	my $loaded = 0 ;
	
	# for windoze....
	if ($^O =~ /MSWin32/i)
	{
		return 0 unless $class->find_lib($module) ;
	}
	
	$pkg ||= 'temp_app_pkg' ;
	
print "dynamic_load($module) into $pkg\n" if $class_debug ;	

	my $version ;
	eval "
		package $pkg; 
		use $module; 
		\$version = \$${module}::VERSION ;
	" ;
#print "Version = $version\n" ;	
	if ($@)
	{
print "dynamic_load($module, $pkg) : error : $@\nAborting dynamic_load.\n" if $class_debug ;
	}
	elsif (defined($version))
	{
		$loaded = 1 ;
	}
print "dynamic_load($module, $pkg) : loaded = $loaded.\n" if $class_debug ;

	return $loaded ;
}

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

=item B<dynamic_isa($module)>

Load the module into the caller's namespace then set it's @ISA ready for that
module to call it's parent's new() method
 
=cut

sub dynamic_isa
{
	my $class = shift ;
	my ($module, $pkg) = @_ ;

	unless ($pkg)
	{
	    my @callinfo = caller(0);
	    $pkg = $callinfo[0] ;
	}
	my $loaded = $class->dynamic_load($module, $pkg) ;

	if ($loaded)
	{
	no strict 'refs' ;
	
		## Create ourself as if we're an object of the required type (but only if ISA is not already set)
		if (!scalar(@{"${pkg}::ISA"}))
		{
print "dynamic_isa() $pkg set ISA=$module\n" if $class_debug  ;			
			@{"${pkg}::ISA"} = ( $module ) ;
		}
		else
		{
print "dynamic_isa() - $pkg already got ISA=",@{"${pkg}::ISA"}," (wanted to set $module)\n" if $class_debug  ;			
		}

	}	

	return $loaded ;
}


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

=item B< inherit($caller_class, [%args]) >

Initialises the object class variables.

=cut

sub inherit
{
	my $class = shift ;
	my ($caller_class, %args) = @_ ;

	## get calling package
	my $caller_pkg = (caller(0))[0] ;

print "\n\n----------------------------------------\n" if $class_debug ;
print "Core:inherit() caller=$caller_pkg\n" if $class_debug ;
	
	## get inheritence stack, grab this object's class, restore list
	my $inheritence = delete $args{'_inheritence'} || [] ;

print " + inherit=\n\t".join("\n\t", @$inheritence)."\n" if $class_debug ;

	## Get parent and restore new list
	my $parent = shift @$inheritence ;
	$args{'_inheritence'} = $inheritence ;

print "Core: $caller_class parent=$parent inherit=@$inheritence\n" if $class_debug ;

	## load in base objects
	my $_caller = $parent ;
	foreach my $_parent (@$inheritence)
	{
print " + Preloading: load $_parent into $_caller\n" if $class_debug ;

		## Dynamic load this parent into this caller
		my $loaded = App::Framework::Core->dynamic_isa($_parent, $_caller) ;
		croak "Sorry, failed to load \"$_parent\"" unless $loaded ;

App::Framework::Core::_dumpvar($_caller) if $class_debug ;
App::Framework::Core::_dumpvar($_parent) if $class_debug ;

		# update caller for next time round
		$_caller = $_parent ;
	}

print " + Loading: load $parent into $caller_pkg\n" if $class_debug ;

	## Dynamic load this object
	my $loaded = App::Framework::Core->dynamic_isa($parent, $caller_pkg) ;
	croak "Sorry, failed to load \"$parent\"" unless $loaded ;

App::Framework::Core::_dumpvar($caller_pkg) if $class_debug ;
App::Framework::Core::_dumpvar($parent) if $class_debug ;

print "Core: calling $caller_pkg -> $parent ::new()\n" if $class_debug ;
App::Framework::Core::_dumpisa($caller_pkg) if $class_debug ;

	## Create object
	my $this ;
	{
	no strict 'refs' ;

		$this = &{"${parent}::new"}(
			$caller_class,
			%args, 
		) ;
		
	}

print "Core:inherit() - END\n" if $class_debug ;
print "----------------------------------------\n\n" if $class_debug ;
	
	return $this ;

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

	foreach my $method (@function_list)
	{
		$feature_methods_href->{$method} = [ sort {$a->{'priority'} <=> $b->{'priority'}} @{$feature_methods_href->{$method}} ] ;
	}

#$this->prt_data("Sorted feature list=", $feature_methods_href);

}


#----------------------------------------------------------------------------
#
#=item B<_dispatch_features($method, 'entry|exit')>
#
#INTERNAL: For the specified method, run any features that registered for this method.
#
#=cut
#
sub _dispatch_features
{
	my $this = shift ;
	my ($method, $status, @args) = @_ ;

@args = () unless @args ;
$this->_dbg_prt(["_dispatch_features(method=$method, status=$status) : args=", \@args]) ;
	
	# remove package name (if specified)
	$method =~ s/^(.*)::// ;
	
	my $feature_methods_href = $this->_feature_methods() ;
	my $fn = "${method}_${status}" ;
$this->_dbg_prt([" + method=$method fn=$fn\n"])  ;

	if (exists($feature_methods_href->{$fn}))
	{
		foreach my $feature_entry (@{$feature_methods_href->{$fn}})
		{
$this->_dbg_prt([" + dispatching fn=$fn feature=$feature_entry->{feature}\n"]) ;
$this->_dbg_prt(["++ entry=", $feature_entry], 2) ;

			my $feature_obj = $feature_entry->{'obj'} ;
			$feature_obj->$fn(@args) ;
		}
	}	
	
}

#----------------------------------------------------------------------------
#
#=item B<_dispatch_entry_features(@args)>
#
#INTERNAL: Calls _dispatch_features with the correct method name, and $status='entry'
#
#=cut
#
sub _dispatch_entry_features
{
	my $this = shift ;
	my (@args) = @_ ;
	
	my $method = (caller(1))[3] ;
	return $this->_dispatch_features($method, 'entry', @_) ;	
}


#----------------------------------------------------------------------------
#
#=item B<_dispatch_exit_features(@args)>
#
#INTERNAL: Calls _dispatch_features with the correct method name, and $status='exit'
#
#=cut
#
sub _dispatch_exit_features
{
	my $this = shift ;

	my $method = (caller(1))[3] ;
	return $this->_dispatch_features($method, 'exit', @_) ;	
}


#----------------------------------------------------------------------------
#
#=item B<_dispatch_label_entry_features($label, @args)>
#
#INTERNAL: Calls _dispatch_features with the correct method name, and $status='entry'
#
#=cut
#
sub _dispatch_label_entry_features
{
	my $this = shift ;
	my ($label, @args) = @_ ;
	
	my $method = (caller(1))[3] ;
	$method .= "_$label" if $label ;
	return $this->_dispatch_features($method, 'entry', @args) ;	
}


#----------------------------------------------------------------------------
#
#=item B<_dispatch_label_exit_features($label, @args)>
#
#INTERNAL: Calls _dispatch_features with the correct method name, and $status='exit'
#
#=cut
#
sub _dispatch_label_exit_features
{
	my $this = shift ;
	my ($label, @args) = @_ ;

	my $method = (caller(1))[3] ;
	$method .= "_$label" if $label ;
	return $this->_dispatch_features($method, 'exit', @args) ;	
}



#= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 

=back

=head3 Application execution methods

=over 4

=cut




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

=item B<go()>

Execute the application.

Calls the following methods in turn:

* app_start
* application
* app_end
* exit
 
=cut


sub go
{
	my $this = shift ;

$this->_dispatch_entry_features() ;

	$this->app_start() ;
	$this->application() ;
	$this->app_end() ;

$this->_dispatch_exit_features() ;

	$this->exit(0) ;
}

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

=item B<getopts()>

Convert the (already processed) options list into settings. 

Returns result of calling GetOptions

=cut