view release on metacpan or  search on metacpan

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

Use App::Framework::Base::Object::DumpObj to print out variable information. Automatically enables
object print out
 
=cut

sub prt_data 
{
	my $this = shift ;
	my (@args) = @_ ;
	
	App::Framework::Base::Object::DumpObj::print_objects_flag(1) ;
	App::Framework::Base::Object::DumpObj::prt_data(@args) ;
}

#----------------------------------------------------------------------------
#
#=item B<_dbg_prt($items_aref [, $min_debug])>
#
#Print out the items in the $items_aref ARRAY ref iff the calling object's debug level is >0. 
#If $min_debug is specified, will only print out items if the calling object's debug level is >= $min_debug.
#
#=cut
#
sub _dbg_prt
{
	my $obj = shift ;
	my ($items_aref, $min_debug) = @_ ;

	$min_debug ||= 1 ;
	
	## check debug level setting
	if ($obj->debug >= $min_debug)
	{
		my $pkg = ref($obj) ;
		$pkg =~ s/App::Framework/ApFw/ ;
		
		my $prefix = App::Framework::Base::Object::DumpObj::prefix("$pkg ::  ") ;
		$obj->prt_data(@$items_aref) ;
		App::Framework::Base::Object::DumpObj::prefix($prefix) ;
	}
}



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

=item B<dump_callstack()>

Print out the call stack. Useful for debug output at a crash site. 
=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";
}



# ============================================================================================
# PRIVATE METHODS
# ============================================================================================

#----------------------------------------------------------------------------
# Set field value
sub ___set
{
	my $this = shift ;
	my ($field, $new_value) = @_ ;

## NEW	
if ($global_debug>=10)
{
print "Unexpected ___set($field, $new_value)\n" ;
$this->dump_callstack() ;
}
## NEW	


	#my $class = $this->class() ;
	my $value ;

	# Check that field name is valid
##	my %field_list = $this->field_list() ;
	my $class = ref($this) || $this ;
	my %field_list = ();
	%field_list = %{ $FIELD_LIST{$class} } if exists($FIELD_LIST{$class}) ;

	if (!exists($field_list{$field}))
	{
##		my $class = ref($this) || $this ;

		prt_data("$class : ___set($field) invalid field. Valid fields=", \%field_list) if $global_debug>=5 ;
		$this->dump_callstack() if $global_debug>=10 ;

		# TODO: Do something more useful!
		croak "$class: Attempting to write invalid field $field" ;
	}
	else
	{
		# get existing value
		$value = $this->{$field} ;
		
		# write
		$this->{$field} = $new_value ;
	}
	print " + ___set($field) <= $new_value (was $value)\n" if $global_debug>=5 ;

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

	my $this = shift ;
	my ($field) = @_ ;

	my $value ;
	
	#my $class = $this->class() ;

## NEW	
if ($global_debug>=10)
{
print "Unexpected ___get($field)\n" ;
$this->dump_callstack() ;
}
## NEW	


	# Check that field name is valid
##	my %field_list = $this->field_list() ;
	my $class = ref($this) || $this ;
	my %field_list = ();
	%field_list = %{ $FIELD_LIST{$class} } if exists($FIELD_LIST{$class}) ;

	if (!exists($field_list{$field}))
	{
##		my $class = ref($this) || $this ;

		prt_data("$class : ___get($field) invalid field. Valid fields=", \%field_list) if $global_debug>=5 ;
prt_data("$class : ___get($field) invalid field. Valid fields=", \%field_list) ;
		$this->dump_callstack() if $global_debug>=10 ;
$this->dump_callstack() ;

		# TODO: Do something more useful!
		croak "$class: Attempting to access invalid method $field (or read using invalid data accessor)" ;
	}
	else
	{
		# get existing value
		$value = $this->{$field} ;
	}

	print " + ___get($field) = $value\n" if $global_debug>=5 ;

	# Return previous value
	return $value ;
}


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

# Autoload handle only field value set/undefine
# 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')
	{
		croak "AUTOLOAD ($AUTOLOAD) (@_): $this is not a valid object" ;
	}

    $this = $this->check_instance() ;
#	prt_data(" + this=", $this) if $global_debug>=5 ;

    my $name = $AUTOLOAD;
    $name =~ s/.*://;   # strip fully-qualified portion
    my $class = $AUTOLOAD;
    $class =~ s/::[^:]+$//;  # get class

    my $type = ref($this) ;
    
#    if (!$type)
#    {
#    	# see if there is a class instance object defined
#    	if ($class->has_class_instance())
#    	{
#	    	$this = $class->class_instance() ;
#	    	$type = ref($this) ;
#    	}
#		else
#		{
#			croak "$this is not an object";
#		}
#    }

	# possibly going to set a new value
	my $set=0;
	my $new_value = shift;
	$set = 1 if defined($new_value) ;
	
	# 1st see if this is of the form undef_<name>
	if ($name =~ m/^undef_(\w+)$/)
	{
		$set = 1 ;
		$name = $1 ;
		$new_value = undef ;
	}

	my $value = $this->___get($name);

	if ($set)
	{
		$this->___set($name, $new_value) ;
	}

	# Return previous value
	return $value ;
}