File Coverage

lib/XML/Namespace.pm

Criterion	Covered	Total	%
statement	39	39	100.0
branch	3	4	75.0
condition	5	6	83.3
subroutine	10	10	100.0
pod	2	2	100.0
total	59	61	96.7

#============================================================= -*-perl-*-
#
# XML::Namespace
#
# Simple support for XML Namespaces.
#
# Written by Andy Wardley
#
# This is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# $Id: Namespace.pm,v 1.2 2005/08/22 14:04:04 abw Exp $
#
#========================================================================

package XML::Namespace;

use base 'Exporter';
use strict;
use warnings;

our $VERSION = 0.02;
our $AUTOLOAD;
our @EXPORT_OK;

use overload
    '""'     => \&uri,
    fallback => 1;


#------------------------------------------------------------------------
# import(@symbols)
#
# Method called by Exporter base class when the module is loaded via
# a C statement.  Any arguments provided are passed
# to the import() method as @symbols.  These should be pairs of
# (xml_namespace => uri) arguments.  The method constructs an XML::Namespace
# object for each pair, and a closure subroutine with the same name as
# the XML namespace, which simply returns the object.  This is then exported
# to the caller's package namespace.
#------------------------------------------------------------------------

sub import {
    my $class = shift;
    my @symbols = @_;
    my (@imports, $planned);

    while (@symbols) {
        no strict 'refs';
        my $ns  = shift @symbols;
        my $uri = shift @symbols
            || die "no URI provided for namespace $ns in 'use $class' statement";
        my $obj = $class->new($uri);
        *{"$class\::$ns"} = sub { return $obj };
        push(@imports, $ns);
        push(@EXPORT_OK, $ns);
    }
    $class->export_to_level(1, $class, @imports)
        if @imports
}


#------------------------------------------------------------------------
# new($uri)
#
# A simple object constructed as a reference to the URI passed as an
# argument.
#------------------------------------------------------------------------

sub new {
    my $class = shift;
    my $uri   = shift
        || die "no URI parameter provided for $class new() method";
    bless \$uri, $class;
}


#------------------------------------------------------------------------
# uri()
# uri($path)
#
# Returns the URI for the namespace object, with an optional path
# argument added to the end of it.
#------------------------------------------------------------------------

sub uri {
    my $self = shift;
    my $path = shift || '';
    return "$$self$path";
}


#------------------------------------------------------------------------
# AUTOLOAD
#
# Catches all method calls (expect import(), new() and uri(), obviously)
# and delegates them to $self->uri() to resolve.
#------------------------------------------------------------------------

sub AUTOLOAD {
    my $self  = shift;
    my $path = $AUTOLOAD;
    $path  =~ s/^.*:://;
    return if $path eq 'DESTROY';
    return $self->uri($path);
}



1;
__END__