File Coverage

lib/XML/Schema/Type/Complex.pm

Criterion	Covered	Total	%
statement	77	93	82.8
branch	14	24	58.3
condition	17	29	58.6
subroutine	16	24	66.6
pod	1	17	5.8
total	125	187	66.8

#============================================================= -*-perl-*-
#
# XML::Schema::Type::Complex
#
# DESCRIPTION
#   Module implementing an object class for representing complex XML
#   Schema datatypes.  Complex types are those that contain other
#   elements and/or carry attributes.
#
# 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: Complex.pm,v 1.2 2001/12/20 13:26:28 abw Exp $
#
#========================================================================

package XML::Schema::Type::Complex;

use strict;
use XML::Schema;
use XML::Schema::Type;
use XML::Schema::Scope;
use XML::Schema::Scheduler;
use base qw( XML::Schema::Scope XML::Schema::Type XML::Schema::Scheduler );
use vars qw( $VERSION $DEBUG $ERROR @OPTIONAL @SCHEDULES );

$VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);
$DEBUG   = 0 unless defined $DEBUG;
$ERROR   = '';

@OPTIONAL  = qw( annotation mixed scope );
@SCHEDULES = qw( start_element end_element start_child end_child text );


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

    $self->SUPER::init($config)
	|| return;

    # set by base class (Scope) constructor
    my $factory = $self->{ _FACTORY };

    # tell attribute group to delegate to $self for types
    $config->{ scope } ||= $self;
    $config->{ name  } ||= 'anon';
    $config->{ name  }   = '_complex_type_$config->{ name }';

    # create attribute group to manage attributes
    $self->{ attributes } = $factory->create( attribute_group => $config )
	|| return $self->error($factory->error());

    # initialise scheduler
    $self->init_scheduler($config)
	|| return;

    # required ??
    $self->{ simple  } = 0;
    $self->{ complex } = 1;

    my $content;
    if ($content = $config->{ content }) {
	if ($factory->isa( content => $content )) {
	    return $content;
	}
	elsif ($content = $factory->create( content => $content )) {
	    $self->{ content } = $content;
	}
	else {
	    return $self->error($factory->error());
	}
    }
    else {
	# TODO: this is laborious, need to find a better way
	my $ctype = $factory->module('content')
	    || return $self->error($factory->error());
	$factory->load($ctype)
	    || return $self->error($factory->error());

	my $ptype = $factory->module('particle')
	    || return $self->error($factory->error());
	$factory->load($ptype)
	    || return $self->error($factory->error());

	my $regex = join('|', $ctype->args(), $ptype->models());
	if (grep(/^$regex$/, keys %$config)) {
	    # create content model
	    $self->{ content } = $factory->create( content => $config )
		|| return $self->error($factory->error());
	}
    }

    return $self;
}


#------------------------------------------------------------------------
# attribute( ... )
#
# Accessor method to fetch and update attributes.  Delegates to
# equivalent method of internal $self->{ attributes } attribute group
# object.
#------------------------------------------------------------------------

sub attribute {
    my $self = shift;
    my $agroup = $self->{ attributes };

    return $agroup->attribute(@_)
	|| $self->error($agroup->error());
}


#------------------------------------------------------------------------
# attributes( )
#
# Returns reference to the internal XML::Schema::Attribute::Group object
# which manages attributes.
#------------------------------------------------------------------------

sub attributes {
    my $self = shift;
    return $self->{ attributes };
}


#------------------------------------------------------------------------
# content()
#
# Return a reference to the current content model object.  Creates a
# new content object via the current factory if called with
# arguments.
#------------------------------------------------------------------------

sub content {
    my $self = shift;
    return $self->{ content } unless @_;

    my $factory = $self->{ _FACTORY }
        || return $self->error("no factory defined");

    $self->{ content } = $factory->create( content => @_ )
	|| return $self->error($factory->error());
}


#------------------------------------------------------------------------
# sequence( @items )
#
# Used to create a sequence content model, e.g.
#
#
#
#
#
#
#
#------------------------------------------------------------------------

sub sequence {
    my $self = shift;
    my $content = { };

    while (! ref $_[0]) {
	my $key = shift;
	$content->{ $key } = shift;
    }
    $content->{ sequence } = [ @_ ];

    $self->TRACE("content => ", $content) if $DEBUG;
    $self->content($content);
}



#------------------------------------------------------------------------
# choice( @items )
#
# Used to create a choice content model, e.g.
#
#
#
#
#
#
#
#------------------------------------------------------------------------

sub choice {
    my $self = shift;
    my $content = { };

    while (! ref $_[0]) {
	my $key = shift;
	$content->{ $key } = shift;
    }
    $content->{ choice } = [ @_ ];

    $self->TRACE("choice => ", $content) if $DEBUG;
    $self->content($content);
}


#------------------------------------------------------------------------
# simpleContent( @items )
#
# Used to create a simpleContent model for the complexType, e.g.
#
# 3.14
#
#
#
#   				<---- simpleContent()
#
#
#
#
#
#------------------------------------------------------------------------

sub simpleContent {
    my $self = shift;
    $self->throw('simpleContent() not yet implemented');
}


#------------------------------------------------------------------------
# complexContent( @items )
#
# Used to create a complexContent model for the complexType, e.g.
#
#
#
#
#
#   				<---- complexContent()
#
#
#
#
#
#
#------------------------------------------------------------------------

sub complexContent {
    my $self = shift;
    $self->throw('complexContent() not yet implemented');
}


#========================================================================
# misc accessor methods
#========================================================================

sub annotation {
    my $self = shift;
    return @_ ? ($self->{ annotation } = shift) : $self->{ annotation };
}

sub simple {
    return 0;
}

sub complex {
    return 1;
}

sub mixed {
    my $self = shift;
    my $content = $self->{ content }
	|| return $self->error("no content defined");
    return $content->mixed(@_);
}

sub empty {
    my $self = shift;
    my $content = $self->{ content }
	|| return $self->error("no content defined");
    return $content->empty(@_);
}

sub element_only {
    my $self = shift;
    my $content = $self->{ content }
	|| return $self->error("no content defined");
    return $content->element_only(@_);
}

#========================================================================
# parser methods
#========================================================================

#------------------------------------------------------------------------
# handler($instance, $element)
#
# Calls the complex_handler($self, $element) method on the $instance
# reference.
#
# TODO: we could optimise away this chain of method calls by having the
# instance Start() method unwrap the calls.
#------------------------------------------------------------------------

sub handler {
    my ($self, $instance, $element) = @_;
    return $instance->complex_handler($self, $element)
	|| $self->error($instance->error());
}

sub present {
    my ($self, $view) = @_;
    $view->view( complex => $self );
}

sub ID {
    my $self = shift;
    return 'ComplexType';
}

1;

__END__