File Coverage

blib/lib/XML/SAXDriver/Sablotron.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

#
# The contents of this file are subject to the Mozilla Public
# License Version 1.1 (the "License"); you may not use this file
# except in compliance with the License. You may obtain a copy of
# the License at http://www.mozilla.org/MPL/
#
# Software distributed under the License is distributed on an "AS
# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
# implied. See the License for the specific language governing
# rights and limitations under the License.
#
# The Original Code is the XML::Sablotron module.
#
# The Initial Developer of the Original Code is Ginger Alliance Ltd.
# Portions created by Ginger Alliance are
# Copyright (C) 1999-2000 Ginger Alliance Ltd.
# All Rights Reserved.
#
# Contributor(s):
#
# Alternatively, the contents of this file may be used under the
# terms of the GNU General Public License Version 2 or later (the
# "GPL"), in which case the provisions of the GPL are applicable
# instead of those above.  If you wish to allow use of your
# version of this file only under the terms of the GPL and not to
# allow others to use your version of this file under the MPL,
# indicate your decision by deleting the provisions above and
# replace them with the notice and other provisions required by
# the GPL.  If you do not delete the provisions above, a recipient
# may use your version of this file under either the MPL or the
# GPL.
#

package XML::SAXDriver::Sablotron;

use strict;
use warnings;

use XML::Sablotron;
use XML::Sablotron::DOM;
use XML::SAX::Base;

use vars qw($VERSION @ISA);

$VERSION = '0.30';
@ISA = qw(XML::SAX::Base);


sub new {
    my ($class, %opt) = @_;
    $class = ref $class || $class;
    my $self = { Stylesheet => $opt{Stylesheet},
		 Handler => $opt{Handler},
		 _sab_handlers => $opt{SablotHandlers},
		 ret => 0,
	       };
    bless $self, $class;
    return $self;
}

sub parse_uri {
    my ($self, $uri) = @_;
    my $sit = new XML::Sablotron::Situation;
    my $sab = new XML::Sablotron;

    $self->setSablotHandlers($sab);
    $sab->regHandler(2, $self);
    $sab->process($sit, $self->{Stylesheet}, $uri, "arg:/null");

    return $self->{ret};
}

sub parse_string {
    my ($self, $str) = @_;
    my $sit = new XML::Sablotron::Situation;
    my $sab = new XML::Sablotron;

    $self->setSablotHandlers($sab);
    $sab->regHandler(2, $self);
    $sab->addArg($sit, "_data", $str);
    $sab->process($sit, $self->{Stylesheet}, "arg:/_data", "arg:/null");

    return $self->{ret};
}

sub parse_dom {
    my ($self, $dom) = @_;
    my $sit = new XML::Sablotron::Situation;
    my $sab = new XML::Sablotron;
    my $templ = XML::Sablotron::DOM::parseStylesheet($sit,$self->{Stylesheet});

    $self->setSablotHandlers($sab);
    $sab->regHandler(2, $self);
    $sab->addArgTree($sit, 'data', $dom);
    $sab->addArgTree($sit, 'template', $templ);
    $sab->process($sit, 'arg:/template', 'arg:/data', 'arg:/null');

    return $self->{ret};
}

sub setSablotHandlers {
    my $self = shift;
    my $sab = shift;
    my $h;

    $h = $self->{_sab_handlers}{SchemeHandler};
    $sab->regHandler(1, $h) if $h;

    $h = $self->{_sab_handlers}{MessageHandler};
    $sab->regHandler(0, $h) if $h;

    $h = $self->{_sab_handlers}{MiscHandler};
    $sab->regHandler(3, $h) if $h;
}

############################################################
# SAX-like handler for Sablotron
############################################################

sub SAXStartDocument {
    my ($self, $proc) = @_;
    $self->SUPER::start_document;
    $self->{_pending_ns} = {};
    $self->{_ns_stack} = [{}]; #one empty slot
    $self->{_ele_stack} = [];
}

sub SAXStartNamespace {
    my ($self, $proc, $prefix, $uri) = @_;
    #print "---> SAXStartNamespace: $prefix, $uri\n";

    $self->{_pending_ns}{$prefix} = $uri;
    $self->SUPER::start_prefix_mapping({Prefix => $prefix,
					NamespaceURI => $uri});
}

sub SAXEndNamespace {
    my ($self, $proc, $prefix) = @_;
    #print "---> SAXEndNamespace: $prefix\n";
    $self->SUPER::end_prefix_mapping({Prefix => $prefix});
}

sub SAXStartElement {
    my ($self, $proc, $name, %atts) = @_;
    #print "---> SAXStartElement: $name ";
    #print join " ", map {"$_=$atts{$_}"} keys %atts;
    #print "\n";

    #update namespace mappings
    my $ns = ${$self->{_ns_stack}}[-1];
    while (my($a, $b) = each %{$self->{_pending_ns}}) {
	$$ns{$a} = $b;
    }
    push @{$self->{_ns_stack}}, $ns;
    $self->{_pending_ns} = {};

    #create element for the SAX call
    my $ele = {Name => $name};

    #ns stuff
    my ($le, $pe);
    if (1) {
	if ($name =~ /(.*?):(.*)/) {
	    $pe = $1; $le = $2;
	} else {
	    $pe = ""; $le = $name;
	}
	$$ele{NamespaceURI} = $$ns{$pe};
	$$ele{Prefix} = $pe;
	$$ele{LocalName} = $le;
    }

    #attributes
    my $saxatts = {};
    foreach my $att (keys %atts) {
	my ($la, $pa);
	if ($att =~ /(.*?):(.*)/) {
	    $pa = $1; $la = $2;
	} else {
	    $pa = ""; $la = $att;
	}
	my $uri = $$ns{$pa ? $pa : $pe};
	my $key = "$la";
	$key = "{$uri}" . $key if $uri;
	$$saxatts{$key} = {Name => "$att",
			   Value => $atts{$att},
			   NamespaceURI => $uri,
			   Prefix => $pa,
			   LocalName => $la,
			  };
    }
    $$ele{Attributes} = $saxatts;

    $self->SUPER::start_element($ele);
    delete $$ele{Attributes}; #save element for later use
    push @{$self->{_ele_stack}}, $ele;
}

sub SAXEndElement {
    my ($self, $proc, $name) = @_;
    #print "---> SAXEndElement: $name\n";

    $self->SUPER::end_element(pop @{$self->{_ele_stack}});
    pop @{$self->{_ns_stack}};
}

sub SAXCharacters {
    my ($self, $proc, $data) = @_;
    #print "---> SAXCharacters: $data\n";
    $self->SUPER::characters({Data => $data});
}

sub SAXComment {
    my ($self, $proc, $data) = @_;
    #print "---> SAXComment: $data\n";
    $self->SUPER::comment({Data => $data});
}

sub SAXPI {
    my ($self, $proc, $target, $data) = @_;
    #print "---> SAXPI: $target, $data\n";
    $self->SUPER::processing_instruction({Target => $target, Data => $data});
}

sub SAXEndDocument {
    my ($self, $proc) = @_;
    #print "---> SAXEndDocument\n";
    $self->{ret} = $self->SUPER::end_document;
}

1;
__END__