File Coverage

lib/XML/Schema/Base.pm

Criterion	Covered	Total	%
statement	138	225	61.3
branch	51	108	47.2
condition	24	50	48.0
subroutine	20	28	71.4
pod	4	10	40.0
total	237	421	56.2

#============================================================= -*-perl-*-
#
# XML::Schema::Base
#
# DESCRIPTION
#   Base class for various XML::Schema::* module implementing common
#   functionality such as error reporting, etc.
#
# AUTHOR
#   Andy Wardley
#
# COPYRIGHT
#   Copyright (C) 2001 Canon Research Centre Europe Ltd.
#   All Rights Reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
# REVISION
#   $Id: Base.pm,v 1.2 2001/12/20 13:26:27 abw Exp $
#
#========================================================================

package XML::Schema::Base;

use strict;
use vars qw( $VERSION $DEBUG $ERROR $ECLASS $ETYPE $SNIPPET
	     $TRACE_LEVEL $INSPECT_LEVEL );
use XML::Schema::Exception;

$VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);
$DEBUG   = 0 unless defined $DEBUG;
$ERROR   = '';
$ECLASS  = 'XML::Schema::Exception';
$ETYPE   = 'undef';
$SNIPPET = 16;
$TRACE_LEVEL = 4 unless defined $TRACE_LEVEL;
$INSPECT_LEVEL = 3 unless defined $INSPECT_LEVEL;



#------------------------------------------------------------------------
# new(@config)
# new(\%config)
#
# General purpose constructor method for instantiating derived class
# objects.  Looks for the @BASEARGS package variable in the derived
# class package which may define mandatory positional parameters
# expected by the constructor.  Values for these @BASEARGS are shifted
# off the argument list leaving any remaining configuration items as a
# hash reference or as a list of key => value pairs which are folded
# into a hash reference.  Creates a new blessed hash seeded with these
# various values and then calls the init() method to perform any
# object initialisation.  On success the new blessed object is
# returned.  On error undef is returned and the $ERROR package
# variable is set in the _derived_ class' package.
#------------------------------------------------------------------------

sub new {
    my $class  = shift;
    my $config = UNIVERSAL::isa($_[0], 'HASH') ? shift : { @_ };

    $class->error('');

    my $self = bless {
	_ERROR   => '',
	_FACTORY => $config->{ factory } || $config->{ FACTORY },
    }, $class;

    return $self->init($config)
	|| $class->error($self->error());
}


#------------------------------------------------------------------------
# init(\%config)
#
# Initialisation method called by the new() constructor and passing a
# reference to a hash array containing any configuration items specified
# as constructor arguments.  Should return $self on success or undef on
# error, via a call to the error() method to set the error message.
#------------------------------------------------------------------------

sub init {
    my ($self, $config) = @_;
    return $self;
}


#------------------------------------------------------------------------
# init_mandopt(\%config)
#
# Optional initialisation method which probes the caller's package
# for @MANDATORY and @OPTIONAL arguments and does the right thing
# to extract them from $config into $self.
#------------------------------------------------------------------------

sub init_mandopt {
    my ($self, $config) = @_;

    my ($mand, $option)
	= @{ $self->_baseargs( qw( @MANDATORY %OPTIONAL ) ) };

    $self->_mandatory($mand, $config)
	|| return if @$mand;

    $self->_optional($option, $config)
	|| return;

    return $self;
}


#------------------------------------------------------------------------
# error()
# error($msg, ...)
#
# General purpose method error for getting/setting object or class
# error value.  When called as a class method it operates on the
# package variable $ERROR.  When called as an object method it
# operates on the internal error item $self->{ _ERROR }.  When called
# without any arguments it returns the current value for the variable.
# When called with one or more arguments (multiple arguments are
# concatenated) it updates the error variable and then returns undef.
#------------------------------------------------------------------------

sub error {
    my $self = shift;
    my $errvar;

    {
	no strict qw( refs );
	$errvar = ref $self ? \$self->{ _ERROR } : \${"$self\::ERROR"};
    }
    if (@_) {
	# don't join if first arg is an object (may force stringification)
	$$errvar = ref($_[0]) ? shift : join('', @_);
	return undef;
    }
    else {
	return $$errvar;
    }
}


#------------------------------------------------------------------------
# error_value($item, $got, @values)
#
# Error reporting method which generates an error message of the form
# "item must be 'this', 'that' or 'the_other' (not: 'value_got')"
# and passes it to the error() method.
#------------------------------------------------------------------------

sub error_value {
    my ($self, $item, $got, @values) = @_;
    my $last = pop @values;
    my $vals = join(', ', map { "'$_'" } @values);
    $self->error("$item must be $vals or '$last' (not '$got')");
}


#------------------------------------------------------------------------
# throw($info)
# throw($type, $info)
#
# Throws an error as an XML::Schema::Exception object of type $type
# with an informational message as supplied by $info.  If the type
# is unspecified (i.e. 1 argument, not 2) then the value defined in
# the object's $ETYPE package variable is used or if undefined, the
# value of the $ETYPE in this base class package.
#------------------------------------------------------------------------

sub throw {
    my ($self, $error, $info) = @_;
    my $factory = $self->factory();
    local $" = ', ';

    # die! die! die!
    if ($factory->isa( exception => $error )) {
#	$self->DEBUG("throwing existing exception $error\n");
	die $error;
    }
    elsif (defined $info) {
	$error = $factory->create( exception => $error, $info );
#	$self->DEBUG("throwing created exception $error\n");
	die $error;
    }
    else {
	no strict 'refs';
	$error ||= '';
	# look for $ETYPE in derived class
	my $class = ref $self;
	my $ename = ${"$class\::ETYPE"} || $ETYPE;
	$error = $factory->create( exception => $ename, $error );
#	$self->DEBUG("throwing created '$ename' exception $error\n");
	die $error;
    }

    # not reached
}


#------------------------------------------------------------------------
# factory()
# factory($new_factory)
#
# When called without arguments, returns the factory referenced by the
# internal _FACTORY item or the value specified in the
# $XML::Schema::FACTORY package variable ('XML::Schema::Factory' by
# default).  When called as an object method with an argument, the
# internal _FACTORY item is updated to store the reference to the new
# factory passed as the argument.
#------------------------------------------------------------------------

sub factory {
    my $self = shift;
    my $factory;

    return ($self->{ _FACTORY } = shift)
	if @_ && ref $self;

    $factory = $self->{ _FACTORY } if ref $self;
    $factory ||= do {
	require XML::Schema;
	$XML::Schema::FACTORY;
    };
    return $factory || $self->error('no factory defined');
}



#========================================================================
# private/protected methods
#========================================================================

#------------------------------------------------------------------------
# _baseargs(@names)
# _baseargs(\%options, @names)
#
# This method walks up the inheritance tree collecting various package
# variables along the way and collating them for the derived object
# class.  Variable names are passed as arguments, e.g. qw( @MANDATORY,
# %OPTIONAL ).  A list reference is returned containing references to
# lists of all the items found.
#------------------------------------------------------------------------

sub _baseargs {
    my ($class, @names) = @_;
    my ($cache, @pending, %examined, $isa, $base);
    my ($name, $type, $arg);
    my $args  = { };
    my $options = ref $names[0] eq 'HASH' ? shift(@names) : { };

    if ($DEBUG) {
	$class->DEBUG("_baseargs options: ",
		      $class->_inspect($options), "\n");
    }

    $class = ref $class || $class;
    push(@pending, $class);

    no strict 'refs';
    local $" = ', ';

    # looked for cached version
#    $cache = \@{"$class\::BASEARGS"};
#    return $cache if @$cache;

    while (@pending) {
	$base = shift @pending;
	next if $examined{ $base };
	$examined{ $base } = 1;

	foreach (@names) {
	    $name = $_;	    # copy to avoid aliasing problems
	    ($type, $name) = ($name =~ /([@%])(\w+)/);
	    next if $options->{ skip }->{ $name };
	    $arg = \@{"$base\::$name"};

	    if ($type eq '@') {
		unshift(@{ $args->{ $name } }, @$arg);
		$class->DEBUG("$type$base\::$name : [ @$arg ]\n")
		    if $DEBUG;
		# stop if we only wanted (and got) first match
		if ($options->{ first } && @$arg) {
		    $class->DEBUG("found first item for $name: [ @$arg ]\n")
			if $DEBUG;
		    $options->{ skip }->{ $name } = 1;
		}
	    }
	    elsif ($type eq '%') {
		if (@$arg) { $arg = { map { ($_ => '') } @$arg } }
		else       { $arg = \%{"$base\::$name"};         }
		$args->{ $name }  = { %$arg, %{ $args->{ $name } || { } } };
		$class->DEBUG("$type$class\::$name : { %$arg }\n")
		    if $DEBUG;
		if ($options->{ first } && %{ $args->{ $name } }) {
		    $class->DEBUG("found first item for $name: [ @$arg ]\n")
			if $DEBUG;
		    $options->{ skip }->{ $name } = 1;
		}
	    }
	}

	# note need to reverse @isa to ensure multiple inheritance (gasp!)
	# of the form @ISA = qw( foo bar ) checks packages in the right
	# order (bar, then foo) for unshifting onto the front of the
	# @baseargs list
	$isa = \@{"$base\::ISA"};
	push(@pending, map { $examined{ $_ } ? () : $_ } reverse @$isa);

	$class->DEBUG("$base isa @$isa\n") if $DEBUG && @$isa;
    }

    # cache arguments for future invocations
#    @$cache = ( @$args{ map { (/(\w+)/) } @names } );
    $cache = [ @$args{ map { (/(\w+)/) } @names } ];
    return $cache;
}


#------------------------------------------------------------------------
# _arguments(\@names, \@args)
#
# Copies mandatory positional arguments, specified in $names list, from
# $args list and sets them as internal data items.  Returns reference to
# $self on success or undef on error.
#------------------------------------------------------------------------

sub _arguments {
    my ($self, $names, $args) = @_;

    # shift off all mandatory positional arguments
    foreach my $name (@$names) {
	return $self->error(ref($self) . ": $name not specified")
	    unless @$args && defined $args->[0];
	$self->{ $name } = shift @$args;
    }
    return $self;
}


#------------------------------------------------------------------------
# _mandatory(\@names, \%config)
#
# Copies mandatory fields, specified in $names list, from $config
# hash ref to $self.  Returns reference to $self on success or raises
# error and returns undef if any field is undefined.
#------------------------------------------------------------------------

sub _mandatory {
    my ($self, $names, $config) = @_;

    foreach my $name (@$names) {
	return $self->error(ref($self) . ": $name not specified")
	    unless defined $config->{ $name };
	$self->{ $name } = $config->{ $name };
    }
    return $self;
}


#------------------------------------------------------------------------
# _optional(\@names, \%config)
# _optional(\%names, \%config)
#
# Copies optional fields, specified in $names, from $config hash ref
# to $self.  If $names is a hash reference then the corresponding value
# for any field will be used as a default if otherwise undefined in
# $config.  Returns reference to $self.
#------------------------------------------------------------------------

sub _optional {
    my ($self, $names, $config) = @_;
    my ($key, $val);

    $names = { map { ($_ => '') } @$names }
	if ref $names eq 'ARRAY';

    while (($key, $val) = each %$names) {
	$self->{ $key } = defined $config->{ $key }
	    ? $config->{ $key }
	    : (ref $val eq 'CODE' ? &$val() : $val);
    }

    return $self;
}




#========================================================================
# debugging methods
#========================================================================

#------------------------------------------------------------------------
# DEBUG(@args)
#
# Prints all arguments to STDERR.
#------------------------------------------------------------------------

sub DEBUG {
    my $self  = shift;
    print STDERR @_;
}


#------------------------------------------------------------------------
# ID
#
# Returns a string to identify an object.  May be redefined in subclasses
# to return more meaningful identifier.
#------------------------------------------------------------------------

sub ID {
    my $self = shift;
    my $class = ref $self || $self;
    no strict 'refs';
    my $etype = ${"$class\::ETYPE"} || $self;
    return $etype;
}


#------------------------------------------------------------------------
# TRACE(@args)
#
# Generates a trace message showing the object and method from where the
# TRACE method was called, along with any additional arguments passed.
# Non-reference arguments are added to the trace message intact, references
# are first stringified via the _dump_ref() method.  The generated message
# is then sent to the DEBUG method.
#
# The internal _DEBUG item (or package variable $DEBUG if not
# defined) is used to determine the verbosity of the generated message.
#
#  1   print argument only
#  2   prefix arguments with object ID
#  3   as 2 but also with calling method name
#  4   as 3 but also with package, file and line info
#------------------------------------------------------------------------

sub TRACE {
    my $self  = shift;
    my ($pkg, $file, $line, $sub, $args,
	$wantarray, $evaltext, $isreq, $hints, $bitmask) = caller(1);

    my $level;
    if (exists $self->{ _DEBUG }) {
	$level = $self->{ _DEBUG };
    }
    else
    {
	no strict 'refs';
	my $class = ref $self;
	$level = ${"$class\::DEBUG"};
    }
    return unless $level;

    my $output = '';

    if ($level > 1) {
	$output .= $self->ID;

	if ($level > 2) {
	    $sub =~ s/.*::(\w+)$/$1/;
	    $output .=  "->$sub()";

	    if ($level > 3) {
		my ($ownpkg, $ownfile, $ownline) = caller();
		$output .= "\n# at $ownfile line $ownline";
		$output .= "\n# called from $file line $line\n";
	    }
	    else {
		$output .= ' : ';
	    }
	}
	else {
	    $output .= ' : ';
	}
    }

    foreach my $arg (@_) {
	$arg = '' unless defined $arg;
	$output .= $self->_inspect($arg);
    }
    chomp($output);
    $output .= "\n";

    $output =~ s/\n(.)/\n |   $1/gs;

    $self->DEBUG('T| ' . $output);
}


#------------------------------------------------------------------------
# _inspect($something, $level)
#
# Attempts to Do The Right Thing to print a meaningful representation of
# the $something passes as an argument.  Will recurse into $something's
# structure while $level is less that $INSPECT_LEVEL.
#------------------------------------------------------------------------

sub _inspect {
    my ($self, $item, $level) = @_;
    $level ||= 0;
    my $output = '';
    my $pad  = '    ';
    my $pad1 = $level ? ($pad x $level) : '';
    my $pad2 = $pad x ++$level;

    $item = '' unless defined $item;
    return $item if $level > $INSPECT_LEVEL;
    return "''" unless length $item;
    return $item unless ref $item;

    if (UNIVERSAL::isa($item, 'HASH')) {
	if (%$item) {
	    $output .= "$item : {\n";
	    while (my ($key, $value) = each %$item) {
		$output .= sprintf("$pad2%-8s => %s,\n", $key, $self->_inspect($value, $level));
	    }
	    $output .= "$pad1}";
	}
	else {
	    $output .= "$item : { }";
	}
    }
    elsif (UNIVERSAL::isa($item, 'ARRAY')) {
	if (@$item) {
	    $output .= "$item : [\n";
	    foreach my $i (@$item) {
		$output .= $pad2 . $self->_inspect($i, $level) . ",\n";
	    }
	    $output .= "$pad1]";
	}
	else {
	    $output .= "$item : [ ]";
	}
    }
    elsif (UNIVERSAL::isa($item, 'SCALAR')) {
	$output .= $item . ' : \\"' . $self->_inspect($$item) . '"';
    }
    else {
	$output .= $item;
    }

#    $output =~ s/^/$pad/mg;
    return $output;
}


#------------------------------------------------------------------------
# _text_snippet($text, $length)
#
# Return $text truncated to at most $length characters or $SNIPPET if
# $length is undefined.
#------------------------------------------------------------------------

sub _text_snippet {
    my ($self, $text, $length) = @_;
    $length ||= $SNIPPET;
    my $snippet = substr($text, 0, $length);
    $snippet .= '...' if length $text > $length;
    $snippet =~ s/\n/\\n/g;
    return $snippet;
}


#------------------------------------------------------------------------
# old stuff, no longer used (I think)
#------------------------------------------------------------------------

sub _old_dump {
    my $self = shift;
    my $output = "$self:\n";
    while (my ($key, $value) = each %$self) {
	$value = '' unless defined $value;
	$output .= sprintf("  %-12s => %s\n", $key, $value);
    }
    return $output;
}

sub _old_dump_ref {
    my ($self, $ref) = @_;
    if (UNIVERSAL::isa($ref, 'HASH')) {
	return $self->_old_dump_hash($ref);
    }
    elsif (UNIVERSAL::isa($ref, 'LIST')) {
	return $self->_old_dump_list($ref);
    }
    else {
	return $ref;
    }
}

sub _old_dump_hash {
    my $self = shift;
    my $hash = shift;
    my $shallow = shift || 0;
    return '{ ' . join(', ', map {
	my $val = $hash->{ $_};
	$val = '' unless defined $val;
#	$val = $self->_old_dump_ref($val) if ref $val && ! $shallow;
	"$_ => $val"
    } keys %$hash) . ' }';
}

sub _old_dump_list {
    my ($self, $list) = @_;
    return '[ ' . join(', ', map {
	my $val = $_;
	$val = '' unless defined $val;
	$val = $self->_old_dump_ref($val) if ref $val;
	$val;
    } @$list) . ' ]';
}


1;

__END__