File Coverage

lib/Kite/XML/Node.pm

Criterion	Covered	Total	%
statement	103	133	77.4
branch	33	64	51.5
condition	12	18	66.6
subroutine	16	17	94.1
pod	1	5	20.0
total	165	237	69.6

#============================================================= -*-perl-*-
#
# Kite::XML::Node
#
# DESCRIPTION
#   Base class for XML node modules which are constructed automatically
#   by the Kite::XML::Parser.  These represent the XML elements.
#
# AUTHOR
#   Andy Wardley
#
# COPYRIGHT
#   Copyright (C) 2000 Andy Wardley.  All Rights Reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
# VERSION
#   $Id: Node.pm,v 1.1 2000/10/17 11:58:16 abw Exp $
#
#========================================================================

package Kite::XML::Node;

require 5.004;

use strict;
use Kite::Base;
use base qw( Kite::Base );
use vars qw( $VERSION $AUTOLOAD );

$VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);

# create some aliases for method names
*attribute = \&attr;
*element   = \&elem;
*content   = \&char;


#------------------------------------------------------------------------
# init(\%config)
#
# Initialisation method called by the base class constructor, new().
# Copies attributes pass in the $config hash reference into the $self
# object, checking that all mandatory attributes are specified.
#------------------------------------------------------------------------

sub init {
    my ($self, $config) = @_;
    my $class = ref $self;
    my ($attribs, $elems, $default, $key, $val, $mult);

    {
	no strict qw( refs );
	$attribs =  ${"$class\::ATTRIBUTES"} || { };
	$elems   =  ${"$class\::ELEMENTS"}   || { };
    }

    # ugy hack: we must call keys() to reset the iterators on the hashes
    my @dud = (keys(%$attribs), keys(%$elems));

    # set attributes from the $config hash, where specified in $ATTRIBUTES
    while (($key, $val) = each %$attribs) {
	if ($key =~ /^_/) {
	    # just set default for private keys with leading _UNDERSCORE
	    $self->{ $key } = ref $val eq 'CODE' ? &$val : $val;
	}
	else {
	    if (defined $config->{ $key }) {
		$self->{ $key } = $config->{ $key };
	    }
	    elsif (defined $val) {
		$self->{ $key } = $val;
	    }
	    else {
		return $self->error("$key not defined");
	    }
	}
	delete $config->{ $key };
    }

    # set elements from the $config hash, or initialise
    while (($key, $val) = each %$elems) {
	# value can be an array ref containing [ $pkg, $module ]
	$val = $val->[0]
	    if ref $val eq 'ARRAY';

	# look for, and strip trailing '+' on package name, then create
	# array reference for elements with multiplicity
	$mult = ($val =~ s/\+$//);
	$self->{ $key } = []
	    if $mult;

	# copy any config value(s) into the elements
	if (defined ($val = $config->{ $key })) {
	    if ($mult) {
		push(@{ $self->{ $key } }, ref $val eq 'ARRAY' ? @$val : $val);
	    }
	    else {
		$self->{ $key } = $val;
	    }
	}
	delete $config->{ $key };
    }

    # any items remaining in $config are invalid
    foreach $key (keys %$config) {
	return $self->error("invalid attribute '$key'");
    }

    return $self;
}


#------------------------------------------------------------------------
# attr($name)
# attr($name, $value)
#
# Accessor method to retrieve or update element attributes.
#------------------------------------------------------------------------

sub attr {
    my $self = shift;
    my $attr = shift;
    my $class = ref $self;

    no strict qw( refs );
    my $attribs = ${"$class\::ATTRIBUTES"} || { };

    # set new or return existing value for valid PARAMS
    if (exists $attribs->{ $attr }) {
	if (@_) {
	    return ($self->{ $attr } = shift);
	}
	else {
	    return $self->{ $attr };
	}
    }
    else {
	return $self->error("no such attribute '$attr'");
    }
}


#------------------------------------------------------------------------
# char()
# char($text)
#
# Returns the internal CDATA member when called without any arguments,
# which contains the current character content for the node.  When called
# with an argument, the passed value will be appended to the CDATA member.
# The CDATA item must be defined in the $ELEMENTS hash reference in the
# subclass's package for character content to be accepted.  A call to
# char() for a node that don't accept CDATA will be considered an error
# and will set the internal ERROR variable and return undef.  There is
# one caveat to this rule: any node that *doesn't* define CDATA will
# accept and silently ignore any $text that contains only whitespace.
# This is required to prevent XML nodes that shouldn't define content,
# but do contain whitespace, from raising errors.
#------------------------------------------------------------------------

sub char {
    my ($self, $text) = @_;
    my $class = ref $self;

    no strict qw( refs );
    my $elems = ${"$class\::ELEMENTS"} || { };

    if ($elems->{ CDATA }) {
	$self->{ CDATA }  = '' unless defined $self->{ CDATA };
	$self->{ CDATA } .= $text if defined $text;
	return $self->{ CDATA };
    }
    elsif(defined $text) {
	# complain about character data unless it's just white noise
	return $self->error("invalid character data")
	    unless $text =~ /^\s*$/;
	return 1;
    }
    else {
	return $self->error("no character data");
    }
}


#------------------------------------------------------------------------
# elem($name)
# elem($name, @args)
#
# Accessor method to retrieve the element specified by parameter.  If
# additional arguments are provided then the call is assumed to be a
# construction request and is delegated to child($name, @args).
#------------------------------------------------------------------------

sub elem {
    my $self = shift;
    my $elem = shift;
    my $class = ref $self;

    # delegate to child() if additional arguments specified!
    return $self->child($elem, @_)
	if @_;

    no strict qw( refs );
    my $elems = ${"$class\::ELEMENTS"} || { };

    # set new or return existing value for valid PARAMS
    if  (exists $elems->{ $elem }) {
        return $self->{ $elem };
    }
    else {
	return $self->error("no such element '$elem'");
    }
}


#------------------------------------------------------------------------
# child($element, @args)
#
# Creates a new child element of type denoted by the first parameter.
# Examines the $ELEMENTS hash reference in the object's package for
# a key matching $element and uses the relevant value as a package
# name against which the new() constructor can be called, passing
# any additional arguments specified.  The package name may be suffixed
# by a '+' to indicate that multiple child elements are permitted.
#------------------------------------------------------------------------

sub child {
    my $self = shift;
    my $class = ref $self;
    my $elem = shift;
    my ($pkg, $mod, $mult) = (0) x 3;

    no strict qw( refs );
    my $elems = ${"$class\::ELEMENTS"} || { };

    if (defined($pkg = $elems->{ $elem })) {
	# value can be an array ref containing [ $pkg, $module ]
	($pkg, $mod) = @$pkg
	    if ref $pkg eq 'ARRAY';

	# look for, and strip trailing '+' on package name
	$mult = ($pkg =~ s/\+$//);

	# use package name to define module name if $mod set to 1
	if ($mod eq '1') {
	    $mod = $pkg;
	    $mod =~ s/::/\//g;
	    $mod .= '.pm';
	}

	require $mod if $mod;

	my $node = $pkg->new(@_)
	    || return $self->error($pkg->error());

	if ($mult) {
	    push(@{ $self->{ $elem } }, $node);
	}
	else {
	    return $self->error("$elem already defined")
		if defined $self->{ $elem };
	    $self->{ $elem } = $node;
	}
	return $node;
    }
    else {
	return $self->error("invalid element '$elem'");
    }
}


#------------------------------------------------------------------------
# AUTOLOAD
#
# Autoload method.
#------------------------------------------------------------------------

sub AUTOLOAD {
    my $self = shift;
    my $class = ref $self;
    my $method = $AUTOLOAD;

    $method =~ s/.*:://;
    return if $method eq 'DESTROY';

    no strict qw( refs );
    my $attribs = ${"$class\::ATTRIBUTES"} || { };
    my $elems   = ${"$class\::ELEMENTS"}   || { };

    if ($method =~ /^_/) {
	my ($pkg, $file, $line) = caller();
	die "attempt to access private member $method at $file line $line\n";
    }

    if (exists $attribs->{ $method }) {
	return $self->attr($method, @_);
    }
    elsif (exists $elems->{ $method }) {
	return $self->elem($method, @_);
    }
    else {
        return $self->error("no such attribute '$method'");
    }
}


#------------------------------------------------------------------------
# _dump()
#
# Debug method to return a formatted string containing the object data.
#------------------------------------------------------------------------

sub _dump {
    my $self = shift;
    my $text = "$self:\n";
    local $" = ', ';
    while (my ($key, $value) = each %$self) {
	my $v;
	$value = '' unless defined $value;
	$value = [ map { $v = $value->{ $_ };
			 $v = '' unless defined $v;
			 "$_ => $v" } keys %$value ]
	    if ref $value eq 'HASH';
	$value = "[ @$value ]"
	    if ref $value eq 'ARRAY';
	$text .= sprintf("    %-12s => $value\n", $key);
    }
    return $text;
}


1;

__END__