App-Framework

 view release on metacpan or  search on metacpan

inc/Module/Install.pm  view on Meta::CPAN

#####################################################################
# Common Utility Functions

sub _caller {
	my $depth = 0;
	my $call  = caller($depth);
	while ( $call eq __PACKAGE__ ) {
		$depth++;
		$call = caller($depth);
	}
	return $call;
}

# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
	local *FH;
	open( FH, '<', $_[0] ) or die "open($_[0]): $!";
	binmode FH;

inc/Module/Install/Makefile.pm  view on Meta::CPAN

}

sub Makefile { $_[0] }

my %seen = ();

sub prompt {
	shift;

	# Infinite loop protection
	my @c = caller();
	if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
		die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
	}

	# In automated testing or non-interactive session, always use defaults
	if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
		local $ENV{PERL_MM_USE_DEFAULT} = 1;
		goto &ExtUtils::MakeMaker::prompt;
	} else {
		goto &ExtUtils::MakeMaker::prompt;

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

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

# Set up module import
sub import 
{
    my $pkg     = shift;
    
    $import_args = join ' ', @_ ;
    
	## Set library paths
	my ($package, $filename, $line, $subr, $has_args, $wantarray) = caller(0) ;
	App::Framework::Core->set_paths($filename) ;

	## Add a couple of useful function calls into the caller namespace
	{
		no warnings 'redefine';
		no strict 'refs';

		foreach my $fn (qw/go modpod/)	
		{
			*{"${package}::$fn"} = sub {  
			    my @callinfo = caller(0);
				my $app = App::Framework->new(@_,
					'_caller_info' => \@callinfo) ;
				$app->$fn() ;
			};
		}	
	}
    
}

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

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

=cut

sub new
{
	my ($obj, %args) = @_ ;

	my $class = ref($obj) || $obj ;

    my @callinfo = caller(0);
	$args{'_caller_info'} ||= \@callinfo ;

	print __PACKAGE__."->new() : caller=$args{'_caller_info'}->[0]\n" if $class_debug ;

	if (exists($args{'specification'}))
	{
		$import_args = delete $args{'specification'} ;
	}

lib/App/Framework/Base/Object.pm  view on Meta::CPAN

=cut

sub dump_callstack 
{
	my $this = shift ;
	my ($package, $filename, $line, $subr, $has_args, $wantarray) ;
	my $i=0 ;
	print "\n-----------------------------------------\n";
	do
	{
		($package, $filename, $line, $subr, $has_args, $wantarray) = caller($i++) ;
		if ($subr)
		{
			print "$filename :: $subr :: $line\n" ;	
		}
	}
	while($subr) ;
	print "-----------------------------------------\n\n";
}

lib/App/Framework/Base/Object.pm  view on Meta::CPAN

# Set method = <name>
# Undefine method = undef_<name>
#
sub AUTOLOAD 
{
	print "AUTOLOAD ($AUTOLOAD)\n" if $global_debug>=5 ;

## NEW	
if ($global_debug>=10)
{
my $caller = (caller())[0] ;
print "Unexpected AUTOLOAD ($AUTOLOAD) from $caller\n" ;
}
## NEW	

    my $this = shift;
#	prt_data("AUTOLOAD ($AUTOLOAD) this=", $this) if $global_debug>=5 ;

#print "$this=",ref($this),"\n";
	if (!ref($this)||ref($this)eq'ARRAY')
	{

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

 
=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"}))

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

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

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

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

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

=cut


sub heap
{
	my $this = shift ;
	my ($level) = @_ ;

	## Get calling package
	$level ||= 0 ;
	my $pkg = (caller($level))[0] ;

#print "##!!## heap($pkg)\n" ;
#$this->dump_callstack() ;	

	# Get total heap space
	my $heap = $this->extension_heap() ;

	# Return this package's area
	$heap->{$pkg} ||= {} ;
$this->_dbg_prt(["#!# this=$this pkg=$pkg Heap [$heap->{$pkg}] Total heap [$heap]=", $heap]) ; ;	

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

 
=cut


sub extend_fn
{
	my $this = shift ;
	my (%spec) = @_ ;

#$this->debug(2);
my $pkg = (caller(0))[0] ;
$this->_dbg_prt(["#!# extend_fn() pkg=$pkg (this=$this)", \%spec]) ; ;	
	
	my $heap = $this->heap(1) ;
$this->_dbg_prt(["#!# heap [$heap]", $heap]) ; ;	
	foreach my $fn (keys %spec)
	{
		# save original
		$heap->{'extend_fn'}{$fn} = $this->$fn ;
{
my $saved = $heap->{'extend_fn'}{$fn} || "" ;

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

sub call_extend_fn
{
	my $this = shift ;
	my ($fn, @args) = @_ ;

	my $heap = $this->heap(1) ;
	my $call = $heap->{'extend_fn'}{$fn} ;
#$this->debug(2);
my $pkg = (caller(0))[0] ;
my $dbg_call = $call||'' ;
$this->_dbg_prt(["#!# pkg=$pkg call_extend_fn($fn) call=$dbg_call HEAP [$heap]=", $heap]) ; ;	

	# do call if specified
	if ($call)
	{
		# get options
		my %options = $this->options() ;

$this->_dbg_prt(["#!# + pkg=$pkg calling $fn call=$call\n"]) ;	

lib/App/Framework/Feature/Options.pm  view on Meta::CPAN

sub append_options
{
	my $this = shift ;
	my ($options_aref, $caller_pkg) = @_ ;

$this->_dbg_prt( ["Options: append_options()\n"] ) ;

	# get caller
	unless ($caller_pkg)
	{
		$caller_pkg = (caller(0))[0] ;
	}
	
	my @combined_options = (@{$this->user_options}) ;
	foreach my $opt_aref (@$options_aref)
	{
		my @opt = ($opt_aref->[0], $opt_aref->[1], $opt_aref->[2], $opt_aref->[3], $caller_pkg) ;
		push @combined_options, \@opt ;
	}
	$this->user_options(\@combined_options) ;