# 
# 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__
# Below is stub documentation for your module. You better edit it!

=head1 NAME

XML::SAXDriver::Sablotron - Perl SAX driver for the Sablotron XSLT
processor

=head1 SYNOPSIS

  use XML::SAXDriver::Sablotron;
  use XML::Handler::SomeHandler;

  $handler = new XML::Handler::SomeHandler;
  $sab = new XML::SAXDriver::Sablotron(Stylesheet => "style.xsl",
                                    Handler => $handler);
  $sab->parse_uri("data.xml");

=head1 DESCRIPTION

This extension allows to run the Sablotron XSLT processor as a SAX
driver. A stylesheet passed to the constructor is applied to a
document passed in as the parse_uri method argument.

=head1 METHODS

=over

=item new(%params)

Constructs the driver. In addition to the standard L<XML::SAXDriver>
params you may add

B<Stylesheet> - the stylesheet URI

B<SablotHandlers> - the hash containing L<XML::Sablotron>
handlers. Available keys are B<SchemeHandler>, B<MessageHandler> and B<MiscHandler>

=item parse_uri($uri)

  Applies the stylesheet to an XML data specified by $uri. 

=item parse_string($string)

  Applies the stylesheet to an XML data serialized to the $string.

=item parse_dom($dom)

  Applies the stylesheet to a DOM object (by XML::Sablotron::DOM).

=back

=head1 AUTHOR

Pavel Hlavnicka; pavel@gingerall.cz

=head1 SEE ALSO

perl(1), XML::Sablotron(3)

=cut