File Coverage

lib/XML/Toolset.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package XML::Toolset;

use strict;
use App;
use App::Service;
use vars qw($VERSION @ISA);

$VERSION = sprintf"%d.%03d", q$Revision: 1.25 $ =~ /: (\d+)\.(\d+)/;
@ISA = ("App::Service");

use XML::Toolset::Document;

=head1 NAME

XML::Toolset - perform XML construction, parsing, validation, and XPath operations using whatever underlying XML library is available (ALPHA!)

=head1 SYNOPSIS

    use App;
    use XML::Toolset;

    my $context = App->context();
    my $toolset = $context->xml_toolset(class => "XML::Toolset::BestAvailable");

    ...

=head1 DESCRIPTION

The XML-Toolset distribution is a wrapper which provides a simplified XML
processing API which uses XPath to construct and dissect XML messages.

The architecture of the XML-Toolset distribution allows for the user of
the API to access XML capabilities independent of the underlying XML
toolset technology: i.e. Xerces, LibXML, XML::XMLDOM, MSXML.

=cut

###########################################################################
# abstract methods
###########################################################################

sub get_value {
    &App::sub_entry if ($App::trace);
	my ($self, $xpath) = @_;
	my ($value);
	die "get_value() must be implemented in a subclass";
    &App::sub_exit($value) if ($App::trace);
    return($value);
}

sub set_value {
    &App::sub_entry if ($App::trace);
	my ($self, $xpath, $value) = @_;
	die "set_value() must be implemented in a subclass";
    &App::sub_exit() if ($App::trace);
}

sub get_nodes {
    &App::sub_entry if ($App::trace);
	my ($self, $xpath) = @_;
	my (@nodes);
	die "set_nodes() must be implemented in a subclass";
    &App::sub_exit(@nodes) if ($App::trace);
    return(@nodes);
}

sub set_nodes {
    &App::sub_entry if ($App::trace);
	my ($self, @nodes) = @_;
	die "set_nodes() must be implemented in a subclass";
    &App::sub_exit() if ($App::trace);
}

sub to_string {
    &App::sub_entry if ($App::trace);
	my ($self) = @_;
	my ($xml);
	die "to_string() must be implemented in a subclass";
    &App::sub_exit($xml) if ($App::trace);
    return($xml);
}

sub transform {
    &App::sub_entry if ($App::trace);
	my ($self) = @_;
	die "transform() must be implemented in a subclass";
    &App::sub_exit() if ($App::trace);
}

sub version {
    &App::sub_entry if ($App::trace);
	my ($self) = @_;
    my ($version);
	die "version() must be implemented in a subclass";
    &App::sub_exit($version) if ($App::trace);
    return($version);
}

sub new_parser {
    &App::sub_entry if ($App::trace);
	my ($self, $options) = @_;
	my $parser = undef;
    die "new_parser() must be implemented in a subclass";
    &App::sub_exit($parser) if ($App::trace);
	return($parser);
}

sub new_dom {
    &App::sub_entry if ($App::trace);
    my ($self, $root_tag, $xmlns) = @_;
    my ($dom);
    die "new_dom() must be implemented in a subclass";
    &App::sub_exit($dom) if ($App::trace);
    return($dom);
}

sub parse {
    &App::sub_entry if ($App::trace);
	my ($self, $xml, $options) = @_;

    my $valid = 1;
    die "parse() must be implemented in a subclass";

    &App::sub_exit($valid) if ($App::trace);
	return($valid);
}

###########################################################################
# base class methods
###########################################################################

#
#

sub get_root_tag {
    &App::sub_entry if ($App::trace);
	my ($self, $doc) = @_;
    my ($tag);
    my $xml = $self->doc2xml($doc);
    if ($xml =~ /^(<\?xml[^<>]*\?>)?\s*<\s*(\S+)/s) {
        $tag = $2;
    }
    &App::sub_exit($tag) if ($App::trace);
    return($tag);
}

sub get_root_element_attribute {
    &App::sub_entry if ($App::trace);
	my ($self, $xml, $attrib) = @_;
    my ($root_tag, $value);
    if ($xml =~ /^(<\?xml[^<>]*\?>)?\s*<\s*(\S+)[^<>]*\s+$attrib\s*=\s*['"]([^<>'"]*)['"]/s) {
        $root_tag = $2;
        $value = $3;
    }
    &App::sub_exit($value) if ($App::trace);
    return($value);
}

sub set_root_element_attribute {
    &App::sub_entry if ($App::trace);
	my ($self, $xmlref, $attrib, $value) = @_;
    my ($root_tag);
    $$xmlref =~ s/^(<\?xml[^<>]*\?>)?(\s*<\s*\S+[^<>]*\s+$attrib\s*=\s*['"])([^<>'"]*)(['"])/$1$2$value$4/s;
    &App::sub_exit() if ($App::trace);
}

sub new_document {
    &App::sub_entry if ($App::trace);
    my ($self, @args) = @_;
    my $doc = XML::Toolset::Document->new(@args, xml_toolset => $self);
    &App::sub_exit($doc) if ($App::trace);
    return($doc);
}

sub type {
    &App::sub_entry if ($App::trace);
	my ($self) = @_;
	my $class = ref($self);
	$class =~ m/XML::Toolset::(.*)/;
    my $type = $1;
    &App::sub_exit($type) if ($App::trace);
	return($type);
}

sub validate_document {
    &App::sub_entry if ($App::trace);
	my ($self, $doc, $options) = @_;
    my $xml = $self->doc2xml($doc);

    if ($self->{xmlns} && $self->{schema_location}) {
        my $schema_location = $self->get_root_element_attribute($xml,"xsi:schemaLocation");
        #if ($schema_location && $schema_location =~ /^$self->{xmlns} /) { }
        if ($schema_location) {
            my $schema_file = $schema_location;
            $schema_file =~ s/.* //;
            if ($schema_file =~ m/^[a-z]:/i || $schema_file =~ m/^[\\\/]/) {
                $schema_file =~ s/.*[\\\/]//;
                my $good_schema_location = "$self->{xmlns} $self->{schema_location}/$schema_file";
                $self->set_root_element_attribute(\$xml,"xsi:schemaLocation",$good_schema_location);
            }
        }
    }

    $options = {} if (!$options);
    my $valid = 1;
    delete $options->{dom};
    delete $options->{error};
    delete $options->{error_line};
    delete $options->{error_column};

	die "validate called with no data to validate\n" unless defined $xml and length $xml > 0;

    my $dom = $self->parse($xml, $options);
    if ($dom && !$options->{error}) {
        $options->{dom} = $dom;
    }
    else {
        $valid = 0;
    }

    &App::sub_exit($valid) if ($App::trace);
	return($valid);
}

sub doc2dom {
    &App::sub_entry if ($App::trace);
    my ($self, $doc) = @_;
    my $ref = ref($doc);
    my ($dom);
    if (!$ref) {
        $dom = $self->parse($doc);
    }
    elsif ($ref eq "XML::Toolset::Document") {
        $dom = $doc->dom();
    }
    else {
        $dom = $doc;
    }
    &App::sub_exit($dom) if ($App::trace);
    return($dom);
}

sub doc2xml {
    &App::sub_entry if ($App::trace);
    my ($self, $doc) = @_;
    my $ref = ref($doc);
    my ($xml);
    if (!$ref) {
        $xml = $doc;
    }
    elsif ($ref eq "XML::Toolset::Document") {
        $xml = $doc->xml();
    }
    else {
        $xml = $doc->to_string();
    }
    &App::sub_exit($xml) if ($App::trace);
    return($xml);
}

sub set_validation {
    &App::sub_entry if ($App::trace);
    my ($self, $validation) = @_;
    $self->{validation} = $validation;
    delete $self->{parser};   # the next parser will have the new validation setting
    &App::sub_exit() if ($App::trace);
}

sub parser {
    &App::sub_entry if ($App::trace);
	my ($self, $options) = @_;
	my $parser = $self->{parser};
    if (!$parser) {
	    $parser = $self->new_parser($options);
	    $self->{parser} = $parser;
    }
    &App::sub_exit($parser) if ($App::trace);
	return($parser);
}

1;

__END__