File Coverage

blib/lib/XML/Filter/Normalize.pm

Criterion	Covered	Total	%
statement	83	83	100.0
branch	18	18	100.0
condition	15	15	100.0
subroutine	15	15	100.0
pod	10	10	100.0
total	141	141	100.0

# @(#) $Id: Normalize.pm 1022 2005-10-21 20:42:33Z dom $

package XML::Filter::Normalize;

use warnings;
use strict;

use XML::NamespaceSupport;
use XML::SAX::Exception;

our $VERSION = '0.01';

use base qw( XML::SAX::Base );

#---------------------------------------------------------------------
# Create a new exception class.
#---------------------------------------------------------------------

@XML::Filter::Normalize::Exception::ISA = qw( XML::SAX::Exception );

#---------------------------------------------------------------------
# SAX Handlers
#---------------------------------------------------------------------

sub start_document {
    my $self = shift;
    $self->nsup( XML::NamespaceSupport->new() );
    $self->nsup->push_context();
    return $self->SUPER::start_document( @_ );
}

sub end_document {
    my $self = shift;
    $self->nsup( undef );
    return $self->SUPER::end_document( @_ );
}

sub start_prefix_mapping {
    my $self = shift;
    my ( $data ) = @_;
    $self->nsup->declare_prefix( $data->{ Prefix }, $data->{ NamespaceURI } );
    return $self->SUPER::start_prefix_mapping( $data );
}

sub end_prefix_mapping {
    my $self = shift;
    my ( $data ) = @_;
    $self->nsup->undeclare_prefix( $data->{ Prefix } );
    return $self->SUPER::end_prefix_mapping( $data );
}

sub start_element {
    my $self = shift;
    my ( $data ) = @_;
    $self->nsup->push_context();
    $self->correct_element_data( $self->nsup(), $data );
    return $self->SUPER::start_element( $data );
}

sub end_element {
    my $self = shift;
    my ( $data ) = @_;
    $self->correct_element_data( $self->nsup(), $data );
    $self->nsup->pop_context();
    return $self->SUPER::end_element( $data );
}

#---------------------------------------------------------------------
# Internals
#---------------------------------------------------------------------

sub nsup {
    my $self = shift;
    $self->{ nsup } = $_[0] if @_;
    return $self->{ nsup };
}

sub correct_element_data {
    my $self = shift;
    my ( $nsup, $data ) = @_;

    my ( $uri, $prefix, $lname, $name ) =
        $self->extract_name_tuple( $nsup, $data );

    if ( !$lname ) {
        $self->whinge('No LocalName found');
    }

    $data->{ NamespaceURI } = $uri;
    $data->{ Prefix }       = $prefix;
    $data->{ LocalName }    = $lname;
    $data->{ Name }         = $name;

    my %attr;
    foreach my $v ( values %{ $data->{ Attributes } } ) {
        my ( $uri, $prefix, $lname, $name ) =
            $self->extract_name_tuple( $nsup, $v );
        $v->{ NamespaceURI } = $uri;
        $v->{ Prefix }       = $prefix;
        $v->{ LocalName }    = $lname;
        $v->{ Name }         = $name;
        my $k = "{$uri}$lname";
        $attr{ $k } = $v;
    }
    # Ensure that all attributes are in the correct key.
    $data->{ Attributes } = \%attr;

    # XXX Should fix up namespace declarations too.

    return $data;
}

sub extract_name_tuple {
    my $self = shift;
    my ( $nsup, $data ) = @_;
    my ( $uri, $prefix, $lname, $name ) =
        @$data{ qw( NamespaceURI Prefix LocalName Name ) };

    # Take a missing prefix from the name if it's there and looks like
    # we are using a prefix.
    if ( !$prefix && $name && $name =~ m/:/ ) {
        $prefix = ( split /:/, $name, 2 )[0];
    }

    # If we don't have a localname, try to take it from name.
    if ( !$lname && $name ) {
        if ( $name =~ m/:/ ) {
            $lname = ( split /:/, $name, 2 )[1];
        }
        else {
            $lname = $name;
        }
    }

    # If we don't have an NS URI, try to work it out from the prefix.
    # NB: We can't detect anything in the default namespace if it's
    # missing it's URI here.
    if ( !$uri && $prefix ) {
        $uri = $nsup->get_uri( $prefix );
    }

    # If we still have no prefix, but we do have a namespace URI, look
    # it up.
    if ( !$prefix && $uri ) {
        $prefix = $nsup->get_prefix( $uri );
        $prefix = '' if !defined $prefix;
    }

    # Force name to be what we know it should be.
    $name = $prefix ? $prefix . ':' . $lname : $lname;
    return $uri, $prefix, $lname, $name;
}

sub whinge {
    my $self = shift;
    my ( $msg ) = @_;

    XML::Filter::Normalize::Exception->throw( Message => $msg );
}

1;
__END__