File Coverage

blib/lib/XML/XForms/Generator/Model.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package XML::XForms::Generator::Model;
######################################################################
##                                                                  ##
##  Package:  Model.pm                                              ##
##  Author:   D. Hageman                      ##
##                                                                  ##
##  Description:                                                    ##
##                                                                  ##
##  Perl object to assist in the generation of XML compliant with   ##
##  the W3's XForms specification.                                  ##
##                                                                  ##
######################################################################

##==================================================================##
##  Libraries and Variables                                         ##
##==================================================================##

require 5.006;
require Exporter;

use strict;
use warnings;

use Carp;
use XML::LibXML;
use XML::XForms::Generator::Common;

our @ISA = qw( Exporter XML::LibXML::Element );

our @EXPORT = qw( xforms_model );

our $VERSION = "0.70";

##==================================================================##
##  Constructor(s)/Deconstructor(s)                                 ##
##==================================================================##

##----------------------------------------------##
##  new                                         ##
##----------------------------------------------##
##  XForms::Model default contstructor.         ##
##----------------------------------------------##
sub new
{
	## Pull in what type of an object we will be.
	my $type = shift;
	## Pull in any arguments provided to the constructor.
	my $attributes = shift;
	my @children = @_;
	## The object we are generating is going to be a child class of
	## XML::LibXML's DOM objects.
	my $self = XML::LibXML::Element->new( 'model' );
	## Determine what exact class we will be blessing this instance into.
	my $class = ref( $type ) || $type;
	## Bless the class for it is good [tm].
	bless( $self, $class );
	## We need to set our namespace on our model element and activate it.
	$self->setNamespace( $XFORMS_NAMESPACE{xforms}, "xforms", 1 );
	## Determine if we have an 'id' attribute and set it if we do.
	__xforms_attribute( $self, $attributes );
	__xforms_children( $self, @children );
	## Send it back to the caller all happy like.
	return( $self );
}

##----------------------------------------------##
##  DESTROY                                     ##
##----------------------------------------------##
##  XForms::Model default deconstructor.        ##
##----------------------------------------------##
sub DESTROY
{
	## This is mainly a placeholder to keep things like mod_perl happy.
	return;
}

##==================================================================##
##  Method(s)                                                       ##
##==================================================================##

## Loop through all of the extension elements building convience methods
## as we go along.
no strict 'refs';

foreach my $element ( @XFORMS_MODEL_ELEMENT )
{
	## We need to temporarily remove the namespace prefix for our work.
	$element =~ s/^xforms://g;

##----------------------------------------------##
##  appendCHILDENAME                            ##
##----------------------------------------------##
##  Method generation for the common child      ##
##  elements of the model element.              ##
##----------------------------------------------##
	*{ "append" . ucfirst( $element ) } =
	sub {

		my( $self, $attributes, @children ) = @_;

		my $node = XML::LibXML::Element->new( $element );

		$self->appendChild( $node );

		$node->setNamespace( $XFORMS_NAMESPACE{xforms}, "xforms", 1 );

		__xforms_attribute( $node, $attributes );
		__xforms_children( $node, @children );

		return( $node );
	};

##----------------------------------------------##
##  getCHILDENAME                               ##
##----------------------------------------------##
##  Method generation for the retrieval of      ##
##  common model elements.                      ##
##----------------------------------------------##
	*{ "get" . ucfirst( $element ) } =
	sub {

		my $self = shift;

		my @nodes =
			$self->getChildrenByTagName( "xforms:$element" );

		return( @nodes );
	};
}

use strict 'refs';

##----------------------------------------------##
##  bindControl                                 ##
##----------------------------------------------##
##  Method used to associate a control with a   ##
##  model's instance data.                      ##
##----------------------------------------------##
sub bindControl ($$$$)
{
	my( $self, $control, $bind, $value ) = @_;

	my( $instance ) = $self->getInstance();

	if( !defined( $instance ) )
	{
		croak( qq|Error: Model element requires an instance child |,
			   qq|element before controls can be bound to it.| );
	}

	## We really want the child element of the instance node.
	$instance = $instance->firstChild;

	if( ( defined( $bind ) ) &&
		( ref( $bind ) ) &&
		( $bind->isa( "XML::LibXML::Node" ) ) )
	{
		## The first case exists when we are giving a prebuilt
		## binding node.
		my @attributes = $bind->attributes;
		my @children = $bind->childNodes;

		my $attributes = {};

		foreach( @attributes )
		{
			$attributes->{$_->nodeName} = $_->getValue();
		}

		## We need to ensure we grab a copy of the nodeset and id attributes
		## here because appendBind is destructive.
		$bind = $attributes->{nodeset};
		my $id = $attributes->{id};

		## We don't attach the node that was passed in, but rather
		## we create another using it.  This allows us to do some
		## error/consistancy checking.
		$self->appendBind( $attributes, @children );

		## The second case is when we are just given a XPath to
		## to the instance data.
		$bind =~ s/^\/+//g;
		$bind =~ s/\/+/\//g;

		## We need to set the 'bind' attribute on the node.
		$control->setAttribute( 'bind', $id);
		$control->removeAttribute( 'ref' );

	}
	elsif( defined( $bind ) )
	{
		## The second case is when we are just given a XPath to
		## to the instance data.
		$bind =~ s/^\/+//g;
		$bind =~ s/\/+/\//g;

		## We need to set the 'ref' attribute on the node.
		$control->setAttribute( 'ref', $bind );
		$control->removeAttribute( 'bind' );
	}
	else
	{
		## The last case is the hope that the control element
		## already contains an 'ref' element.
		$bind = $control->getAttribute( "ref" );

		if( !defined( $bind ) )
		{
			croak( qq|Error: A binding expression must already exist on |,
				   qq|the control element or one must be supplied | );
		}

		## Clean the binding expression ...
		$bind =~ s/^\/+//g;
		$bind =~ s/\/+/\//g;

		## We will reset it to ensure that the clean version is used.
		$control->setAttribute( 'ref', $bind );
		$control->removeAttribute( 'bind' );
	}

	## Break up the XPath statement into chunks.
	my @path = split( /\//, $bind );

	## Loop through each of the @path statements to ensure and build
	## the XPath to the instance data.
	for( my $search = 0; $search < scalar( @path ); $search++ )
	{
		my( $node ) = $instance->getChildrenByTagName( $path[ $search ] );

		## Check to see if the node is already defined.
		if( !defined( $node ) )
		{
			my $element = XML::LibXML::Element->new( $path[ $search ] );
			$instance = $instance->appendChild( $element );
		}
		else
		{
			$instance = $node;
		}
	}

	## Look to see if any nodes exist under the current node.
	if( $instance->hasChildNodes() )
	{
		$instance->removeChildNodes();
	}

	## Check to see if the value is text or a node.
	if( ( ref( $value ) ) && ( $value->isa( "XML::LibXML::Node" ) ) )
	{
		$instance->appendChild( $value );
	}
	else
	{
		my $text = XML::LibXML::Text->new( $value );
		$instance->appendChild( $text );
		## The below causes a segfault.  Need to figure that one out.
		##$instance->appendText( $value );
	}

	## I want to make sure that we properly associate this control
	## with the proper model.
	$control->setAttribute( 'model', $self->getAttribute( "id" ) );

	return( $instance );
}

##----------------------------------------------##
##  setInstanceData                             ##
##----------------------------------------------##
##  Convience method for setting instance data  ##
##  in the model element.                       ##
##----------------------------------------------##
sub setInstanceData ($$$)
{
	my( $self, $bind, $value ) = @_;

	## We make sure that $value is defined purely for the removal of
	## perl warning messages.
	if( !defined( $value ) )
	{
		$value = "";
	}

	my( $instance ) = $self->getInstance();

	if( !defined( $instance ) )
	{
		croak( qq|Error: Model element requires an instance child |,
			   qq|element before controls can be bound to it.| );
	}

	## We really want the child element of the instance node.
	$instance = $instance->firstChild;

	## Clean up our binding expression a bit ...
	$bind =~ s/^\/+//g;
	$bind =~ s/\/+/\//g;

	## Break up the XPath statement into chunks.
	my @path = split( /\//, $bind );

	## Loop through each of the @path statements to ensure and build
	## the XPath to the instance data.
	for( my $search = 0; $search < scalar( @path ); $search++ )
	{
		my( $node ) = $instance->getChildrenByTagName( $path[ $search ] );

		## Check to see if the node is already defined.
		if( !defined( $node ) )
		{
			my $element = XML::LibXML::Element->new( $path[ $search ] );
			$instance = $instance->appendChild( $element );
		}
		else
		{
			$instance = $node;
		}
	}

	## Look to see if any nodes exist under the current node.
	if( $instance->hasChildNodes() )
	{
		$instance->removeChildNodes();
	}

	## Check to see if the value is text or a node.
	if( ( ref( $value ) ) &&
		( ref( $value ) ne "ARRAY" ) &&
		( ref( $value ) ne "HASH" ) &&
		( ref( $value ) ne "SCALAR" ) &&
		( ref( $value ) ne "CODE" ) &&
		( ref( $value ) ne "REF" ) &&
		( ref( $value ) ne "LVALUE" ) &&
		( ref( $value ) ne "GLOB" ) &&
		( $value->isa( "XML::LibXML::Node" ) ) )
	{
		$instance->appendChild( $value );
	}
	else
	{
		my $text = XML::LibXML::Text->new( $value );
		$instance->appendChild( $text );
		## The below causes a segfault.  Need to figure that one out.
		##$instance->appendText( $value );
	}

	return( $instance );
}

##==================================================================##
##  Function(s)                                                     ##
##==================================================================##

##----------------------------------------------##
##  xforms_model                                ##
##----------------------------------------------##
##  Alias for the default constructor.          ##
##----------------------------------------------##
sub xforms_model
{
	return( XML::XForms::Generator::Model->new( @_ ) );
}

##==================================================================##
##  Internal Function(s)                                            ##
##==================================================================##

##
## None.
##

##==================================================================##
##  End of Code                                                     ##
##==================================================================##
1;

##==================================================================##
##  Plain Old Documentation (POD)                                   ##
##==================================================================##

__END__