File Coverage

blib/lib/XML/Filter/SAX1toSAX2.pm

Criterion	Covered	Total	%
statement	12	50	24.0
branch	0	2	0.0
condition	0	2	0.0
subroutine	4	9	44.4
pod	3	4	75.0
total	19	67	28.3

# $Id: SAX1toSAX2.pm,v 1.4 2002/07/08 11:56:04 matt Exp $

package XML::Filter::SAX1toSAX2;

use strict;
use vars qw($VERSION @ISA);

use XML::SAX::Base;
use XML::NamespaceSupport;

@ISA = qw(XML::SAX::Base);

$VERSION = '0.03';

sub start_document {
    my ($self, $document) = @_;

    $self->{NSSupport} = XML::NamespaceSupport->new({ xmlns => 1 });
    $self->SUPER::start_document($document);
}

sub start_element {
    my ($self, $element) = @_;

    $self->{NSSupport}->push_context;

    $self->make_sax2_attribs($element);

    foreach my $prefix ($self->{NSSupport}->get_declared_prefixes) {
        # warn("start_prefix_mapping: $prefix\n");
        $self->SUPER::start_prefix_mapping(
            {
                Prefix => $prefix,
                NamespaceURI => $self->{NSSupport}->get_uri($prefix),
            }
        );
    }

    my ($uri, $prefix, $lname) = $self->{NSSupport}->process_element_name($element->{Name});
    $element->{LocalName} = $lname;
    $element->{Prefix} = $prefix;
    $element->{NamespaceURI} = $uri;
    $self->SUPER::start_element($element);
}

sub end_element {
    my ($self, $element) = @_;

    foreach my $prefix ($self->{NSSupport}->get_declared_prefixes) {
        # warn("end_prefix_mapping: $prefix\n");
        $self->SUPER::end_prefix_mapping(
            {
                Prefix => $prefix,
                NamespaceURI => $self->{NSSupport}->get_uri($prefix),
            }
        );
    }

    delete($self->{Attributes}); # just in case

    my ($uri, $prefix, $lname) = $self->{NSSupport}->process_element_name($element->{Name});
    # warn("$element->{Name} => $uri, $lname, $prefix\n");
    $element->{LocalName} = $lname;
    $element->{Prefix} = $prefix;
    $element->{NamespaceURI} = $uri;

    $self->{NSSupport}->pop_context;

    $self->SUPER::end_element($element);
}

sub make_sax2_attribs {
    my $self = shift;
    my $element = shift;

    $self->_scan_namespaces(%{$element->{Attributes}});

    my %attribs;
    foreach my $key (keys %{$element->{Attributes}}) {
        my ($uri, $prefix, $lname) = $self->{NSSupport}->process_attribute_name($key);
        $attribs{"{$uri}$lname"} = {
            Name => $key,
            Value => $element->{Attributes}{$key},
            Prefix => $prefix,
            NamespaceURI => $uri,
            LocalName => $lname,
        };
    }

    $element->{Attributes} = \%attribs;
}

sub _scan_namespaces {
    my ($self, %attributes) = @_;

    while (my ($attr_name, $value) = each %attributes) {
	if ($attr_name =~ /^xmlns(:(.*))?$/) {
            my $prefix = $2 || '';
            # warn("declare_prefix: $prefix = $value\n");
            $self->{NSSupport}->declare_prefix($prefix, $value)
	}
    }
}

1;
__END__