| App::Framework::Base::Object - Basic object |
Object - Basic object
use App::Framework::Base::Object ;
Setting the debug flag to level 1 prints out (to STDOUT) some debug messages, setting it to level 2 prints out more verbose messages.
Steve Price <sdprice at cpan.org>
None that I know of!
new([%args])
Create a new object.
The %args are specified as they would be in the set method, for example:
'mmap_handler' => $mmap_handler
Special arguments are:
'fields' => Either ARRAY list of valid field names, or HASH of field names with default values
Example:
new(
'fields' => {
'cmd' => undef,
'status' => 0,
'results' => [],
)
)
All defined fields have an accessor method created.
init([%args])
Initialises the newly created object instance.
init_class([%args])
Initialises the object class variables.
add_fields($fields_href, $args_href)
Adds the contents of the HASH ref $fields_href to the args HASH ref ($args_href) under the key 'fields'. Used by derived objects to add their fields to the parent object's fields.
init_class_instance([%args])
Initialises the object class variables. Creates a class instance so that these methods can also be called via the class (don't need a specific instance)
global_debug(level)
Set global debug print options to level.
0 = No debug
1 = standard debug information
2 = verbose debug information
global_verbose(level)
Set global verbose print level to level.
0 = None verbose
1 = verbose information
2 = print commands
3 = print command results
strict_fields($flag)
Enable/disable strict field checking
class_instance([%args])
Returns an object that can be used for class-based calls - object contains all the usual fields
=cut
sub class_instance { my $this = shift ; my (@args) = @_ ;
my $class = $this->class() ;
if ($class->allowed_class_instance() && !$class->has_class_instance())
{
$CLASS_INSTANCE{$class} = 1 ; # ensure we don't get here again (breaks recursive loop)
print "-- Create class instance --\n" if $global_debug>=3 ;
# Need to create one using the args
$CLASS_INSTANCE{$class} = $class->new(@args) ;
}
return $CLASS_INSTANCE{$class} ;
}
#----------------------------------------------------------------------------
has_class_instance()
Returns true if this class has a class instance object
=cut
sub has_class_instance
{
my $this = shift ;
my $class = $this->class() ;
#prt_data("has_class_instance($class) CLASS_INSTANCE=", \%CLASS_INSTANCE) if $global_debug>=5 ;
return exists($CLASS_INSTANCE{$class}) ;
}
#----------------------------------------------------------------------------
allowed_class_instance()
Returns true if this class can have a class instance object
=cut
sub allowed_class_instance { return 1 ; }
#----------------------------------------------------------------------------
field_list()
Returns hash of object's field definitions.
debug(level)
Set debug print options to level.
verbose(level)
Set verbose print level to level.
0 = None verbose
1 = verbose information
2 = print commands
3 = print command results
set(%args)
Set one or more settable parameter.
The %args are specified as a hash, for example
set('mmap_handler' => $mmap_handler)
Sets field values. Field values are expressed as part of the HASH (i.e. normal field => value pairs).
vars([@names])
Returns hash of object's fields (i.e. field name => field value pairs).
If @names array is specified, then only returns the HASH containing the named fields.
DESTROY()
Destroy object
check_instance()
If this is not an instance (i.e. a class call), then if there is a class_instance defined use it, otherwise error.
copy_attributes($target)
Transfers all the supported attributes from $this object to $target object.
class()
Returns name of object class.
clone()
Create a copy of this object and return the copy.
quote_str($str)
Returns a quoted version of the string.
=cut
sub quote_str { my $this = shift ; my ($str) = @_ ;
my $class = $this->class() ;
# skip on Windows machines
unless ($^O eq 'MSWin32')
{
# first escape any existing quotes
$str =~ s%\\'%'%g ;
$str =~ s%'%'\\''%g ;
$str = "'".$str."'" ;
}
return $str ;
}
#----------------------------------------------------------------------------
expand_vars($string, \%vars)
Work through string expanding any variables, replacing them with the value stored in the %vars hash. If variable is not stored in %vars, then that variable is left.
Returns expanded string.
prt_data(@args)
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 _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) ;
}
}
#---------------------------------------------------------------------
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) = @_ ;
my $class = $this->class() ;
my $value ;
# Check that field name is valid
my %field_list = $this->field_list() ;
if (!exists($field_list{$field}))
{
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 ;
# Return previous value
return $value ;
}
#---------------------------------------------------------------------------- # get field value sub ___get { my $this = shift ; my ($field) = @_ ;
my $value ;
my $class = $this->class() ;
# Check that field name is valid
my %field_list = $this->field_list() ;
if (!exists($field_list{$field}))
{
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 ;
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 ;
}
# ============================================================================================ # END OF PACKAGE 1;
__END__
| App::Framework::Base::Object - Basic object |