File Coverage

blib/lib/XML/API.pm

Criterion	Covered	Total	%
statement	343	478	71.7
branch	131	220	59.5
condition	28	67	41.7
subroutine	43	57	75.4
pod	1	1	100.0
total	546	823	66.3

# Private package (not to be used outside XML::API)
package XML::API::Element;
use strict;
use warnings;
use Carp qw(croak);
use Scalar::Util qw(weaken refaddr);

our $VERSION = '0.28';

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {
        attrs     => {},
        contents  => [],
        @_
    };


    if ($self->{comment}) {
        $self->{comment} =~ s/--/- -/go;
    }

    weaken($self->{parent}) if (exists $self->{parent});

    bless ($self, $class);
    return $self;
}



sub parent {
    my $self = shift;
    return $self->{parent};
}


sub inline {
    my $self = shift;
    return $self->{inline};
}


sub attrs_as_string {
    my $self = shift;
    my @strings;

    foreach my $key (sort keys %{$self->{attrs}}) {
        my $val = $self->{attrs}->{$key};
        if (!defined($val)) {
            warn "Attribute '$key' (element '$self->{element}') is undefined";
            $val = '*undef*';
        }
        push(@strings, $key .'="'. $val .'"');
    }

    return '' unless(@strings);
    return ' ' . join(' ', @strings);
}


sub add {
    my $self = shift;
    push(@{$self->{contents}}, @_);
}


sub as_string {
    my $self       = shift;
    my $indent     = shift || '';
    my $growindent = shift || '';

    if ($self->{comment}) {
        return $indent . '';
    }

    if ($self->{cdata}) {
        return $indent . '{cdata} . ']]>';
    }

    if (!@{$self->{contents}}) {
        return $indent . '<'. ($self->{ns} ? $self->{ns}.':' : '')
               .  $self->{element} . $self->attrs_as_string . ' />';
    }

    my $str = $indent . '<'. ($self->{ns} ? $self->{ns}.':' : '')
              . $self->{element} . $self->attrs_as_string .'>';
    my $complex = 0;

    foreach my $c (@{$self->{contents}}) {
        if ( eval { $c->isa( __PACKAGE__ ) and !$c->inline } ) {
            $complex = 1;
            $str .= "\n" . $c->as_string($indent . $growindent, $growindent);
        }
        elsif ( eval { $c->isa( 'XML::API' ) } ) { # assume it is complex?
            $str .= "\n" . join("\n",
                map {$_->as_string($indent . $growindent, $growindent)}
                     $c->_elements);
        }
        else {
            $str .= $c if (defined($c));
        }
    }

    if ($complex) {
        $str .= "\n" . $indent;
    }
    $str .=  '{ns} ? $self->{ns}.':' : '') . $self->{element} .'>';
    return $str;
}


sub fast_string {
    my $self       = shift;

    $self->{comment} && return '';
    $self->{cdata}   && return '{cdata} . ']]>';

    return  '<'. ($self->{ns} ? $self->{ns}.':' : '')
           . $self->{element} . $self->attrs_as_string .'>'
           . join('', map {
                eval { $_->isa( __PACKAGE__ ) }
                    ? $_->fast_string
                    : (eval { $_->isa('XML::API') }
                        ? join('', map {$_->fast_string} $_->_elements)
                        : $_)
                } @{$self->{contents}})
           . '{ns} ? $self->{ns}.':' : '') . $self->{element}
           . '>';
}


# Private package (not to be used outside XML::API)
package XML::API::SAXHandler;
use strict;
use warnings;
use base qw(XML::SAX::Base);

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {
        xmlapi => undef,
        @_,
    };
    bless($self, $class);
    return $self;
}


sub start_element {
    my $self = shift;
    my $hash = shift;
    if($hash->{Name} eq '_xml_api_ignore') {
        $self->{xml_api_ignore} = 1;
        return;
    }
    $self->{xml_api_ignore} = 0;

    my $attrs = {};
    foreach my $val (values %{$hash->{Attributes}}) {
        $attrs->{$val->{Name}} = $val->{Value};
    }

    $self->{xmlapi}->_open($hash->{Name}, $attrs);
    return;
}


sub characters {
    my $self = shift;
    my $hash = shift;
    $self->{xml_api_ignore} && return;
    $self->{xmlapi}->_add($hash->{Data});
    return;
}


sub end_element {
    my $self = shift;
    my $hash = shift;
    if($hash->{Name} eq '_xml_api_ignore') {
        return;
    }

    $self->{xmlapi}->_close($hash->{Name});
    return;
}


# ----------------------------------------------------------------------
# XML::API - Perl extension for creating XML documents
# ----------------------------------------------------------------------
package XML::API;
use strict;
use warnings;
use overload '""' => \&_as_string, 'fallback' => 1;
use Carp qw(carp croak confess);
use Scalar::Util qw(weaken refaddr);
use XML::SAX;

our $VERSION          = '0.28';
our $DEFAULT_ENCODING = 'UTF-8';
our $ENCODING         = undef;
our $Indent           = '  ';
our $AUTOLOAD;


# Not implemented yet:
#  strict   => 0|1                # Optional, defaults to 0
#By default strict checking is performed to make sure that the structure
#of the document matches the Schema. This can be turned off by setting
#'strict' to false (0 or undef).

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    my $self = {
        doctype   => undef,
        encoding  => undef,
        debug     => undef,
        @_,
    };

    #
    # Derived classes
    #
    if ($class ne __PACKAGE__) {
        if ($self->{doctype}) {
            confess("Must not specify doctype when instantiating $class");
        }
    }
    elsif ($self->{doctype}) {
        $class = $class . '::' . uc($self->{doctype});
        if (! eval "require $class;1;") {
            die "Could not load module '$class'";
        }
    }
    delete $self->{doctype};
    bless ($self, $class);

    $self->{encoding} = $self->{encoding} || $ENCODING || $DEFAULT_ENCODING;
    $self->{elements} = [];
    $self->{current}  = undef;
    $self->{string}   = undef;
    $self->{ids}      = {};
    $self->{langs}    = {};

    return $self;
}


sub _root_element {
    return '';
}


sub _root_attrs {
    return {};
}


sub _doctype {
    return '';
}


sub _elements {
    my $self = shift;
    return @{$self->{elements}};
}


sub _open {
    my $self    = shift;
    my $element = shift || croak '_open($element,...)';

    my $namespace = $self->{namespace};

    # reset the output string in case it has been cached
    $self->{string} = undef;

    if ($element eq $self->_root_element) {
        $self->{has_root_element} = 1;
    }

    my $attrs = {};
    my @content;

    my $total = scalar(@_) - 1;
    my $next;

    foreach my $i (0..$total) {
        if ($next) {
            $next = undef;
            next;
        }

        my $arg  = $_[$i];
        if (ref($arg) eq 'HASH') {
            while (my ($key,$val) = each %$arg) {
                $attrs->{$key} = _escapeXML($val);
                if (!defined($val)) {
                    carp "attribute '$key' undefined (element '$element')";
                    $attrs->{$key} = ''
                }
            }
        }
        elsif (defined($arg) and $arg =~ m/^-[^0-9\.]+/o) {
            $arg =~ s/^-//o;
            $attrs->{$arg} = _escapeXML($_[++$i]);
            if (!defined($attrs->{$arg})) {
                carp "attribute '$arg' undefined (element '$element') ";
                $attrs->{$arg} = ''
            }
            $next = 1;
            next;
        }
        else {
            push(@content, $arg);
        }
    }

    #
    # Start with the default root element attributes and add those
    # given if this is the root element
    #
    if ($element eq $self->_root_element) {
        my $rootattrs = $self->_root_attrs;
        while (my ($key,$val) = each %$attrs) {
            $rootattrs->{$key} = $val;
        }
        $attrs = $rootattrs;
    }

    my ($file,$line) = (caller)[1,2] if($self->{debug});

    if ($self->{langnext}) {
        $attrs->{'xml:lang'} = delete $self->{langnext};
    }
    if ($self->{dirnext}) {
        $attrs->{'dir'} = delete $self->{dirnext};
    }

    my $e;
    if ($self->{current}) {
        $e = XML::API::Element->new(
            element  => $element,
            attrs    => $attrs,
            ns       => $namespace,
            parent   => $self->{current},
        );
        $self->_add($e);
    }
    else {
        $e = XML::API::Element->new(
            element  => $element,
            attrs    => $attrs,
            ns       => $namespace,
        );
        push(@{$self->{elements}}, $e);
    }

    $self->{current} = $e;
    if ($self->{_raw}) {
        $self->_raw(@content);
    }
    else {
        $self->_add(@content);
    }

    $self->_comment("DEBUG: '$element' (open) at $file:$line")
        if($self->{debug});

    return $e;
}



sub _add {
    my $self = shift;
    $self->{string} = undef;
    if (!$self->{current}) {
        croak 'Cannot use _add with no current element';
    }

    foreach my $item (@_) {
        carp "undefined input" unless(defined($item));
        if ( eval { $item->isa( __PACKAGE__ ) } ) {
            if (refaddr($item) == refaddr($self)) {
                croak 'Cannot _add object to itself';
            }
            if (!$self->{current}) {
                push(@{$self->{elements}}, $item);
            }
            else {
                $self->{current}->add($item);
            }
            bless($item, ref($self));
            $item->{parent} = $self;
            weaken($item->{parent});

            foreach my $lang (keys %{$item->{langs}}) {
                $self->{langs}->{$lang} = 1;
            }
        }
        else {
            if ( eval { $item->isa( 'XML::API::Element' ) } ) {
                $self->{current}->add($item);
            }
            elsif ( eval { $item->isa( 'XML::API::Cache' ) } ) {
                foreach my $lang ($item->langs) {
                    $self->{langs}->{$lang} = 1;
                }
                $self->{current}->add($item);
            }
            else {
                $self->{current}->add(_escapeXML($item));
            }
        }
    }
}


sub _raw {
    my $self = shift;
    $self->{string} = undef;
    foreach my $item (@_) {
        carp "undefined input" unless(defined($item));
        if (ref($item) and $item->isa( __PACKAGE__ )) {
            croak 'Cannot add XML::API objects as raw';
        }
        if ($self->{current}) {
            $self->{current}->add($item);
        }
        else {
            push(@{$self->{elements}}, $item);
        }
    }
}


sub _close {
    my $self = shift;
    my $element = shift || croak '_close($element)';

    my ($file,$line) = (caller)[1,2] if($self->{debug});

    if (!$self->{current}) {
        carp 'attempt to close non-existent element "' . $element . '"';
        return;
    }

    if ($element eq $self->{current}->{element}) {
        if ($self->{current}->parent) {
            $self->{current} = $self->{current}->parent;
            $self->_comment("DEBUG: '$element' close at $file:$line") if($self->{debug});
        }
        else {
            $self->{current} = undef;
        }
    }
    else {
        carp 'attempted to close element "' . $element . '" when current ' .
             'element is "' . $self->{current}->{element} . '"';
    }
    return;
}


sub _element {
    my $self = shift;
    my $element = shift || croak '_element($element)';
    my $e = $self->_open($element,@_);
    $self->_close($element);
    return $e;
}


#
# The implementation for element, element_open and element_close
#

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

    my ($open, $close) = (0,0);

    if ($element =~ s/.*::(.+)_open$/$1/o) {
        my $old_ns = $self->{namespace};

        if ($element =~ s/(.+)__(.+)/$2/o) {
            $self->{namespace} = $1;
        }

        my $e = $self->_open($element, @_);
        $self->{namespace} = $old_ns;
        return $e;
    }
    elsif ($element =~ s/.*::(.+)_close$/$1/o) {
        $element =~ s/(.+)__(.+)/$2/o;
        return $self->_close($element);
    }
    elsif ($element =~ s/.*::(.+)_raw$/$1/o) {
        $element =~ s/(.+)__(.+)/$2/o;
        $self->{_raw} = 1;
        $self->_open($element, @_);
        $self->{_raw} = 0;
        return $self->_close($element);
    }

    $element =~ s/.*:://o;
    croak 'element not defined' unless($element);

    if ($element =~ /^_/o) {
        croak 'Undefined subroutine &' . ref($self) . "::$element called";
    }

    my $old_ns = $self->{namespace};

    if ($element =~ s/(.+)__(.+)/$2/o) {
        $self->{namespace} = $1;
    }
    my $e = $self->_open($element, @_);
    $self->{namespace} = $old_ns;
    $self->_close($element);
    return $e;
}


sub _ast {
    my $self = shift;

    foreach my $i (1 .. int(scalar(@_) / 2)) {
        my ($e,$val) = splice(@_,0,2);

        if (!ref($val)) {
            $self->_element($e,$val);
            next;
        }

        my $attr = {};
        my @contents = ();

        if (ref($val) and ref($val) eq 'ARRAY') {
            my @val = @$val;

            foreach my $i (1 .. int(scalar(@val) / 2)) {
                my ($arg,$arg2) = splice(@val,0,2);

                if ($arg =~ s/^-(.+)/$1/o) {
                    $attr->{$arg} = $arg2;
                }
                elsif (ref($arg2) and ref($arg2) eq 'ARRAY') {
                    push(@contents, [$arg, $arg2]);
                }
                else {
                    push(@contents, {$arg => $arg2});
                }
            }

            push(@contents, @val) if(@val);
        }
        else {
            push(@contents, $val);
        }
        $self->_open($e,$attr);

        foreach my $c (@contents) {
            if (ref($c) and ref($c) eq 'ARRAY') {
                $self->_ast(@$c);
            }
            elsif (ref($c) and ref($c) eq 'HASH') {
                my ($k,$v) = each %$c;
                $self->_open($k);
                $self->_add($v);
                $self->_close($k);
            }
            else {
                $self->_add($c);
            }
        }

        $self->_close($e);
    }

    return;
}


sub _comment {
    my $self = shift;
    # FIXME: should escape?
    $self->_raw(XML::API::Element->new(comment => join('',@_)));
    return;
}


sub _cdata {
    my $self = shift;
    $self->_raw(XML::API::Element->new(cdata => join('',@_)));
    return;
}


sub _css {
    my $self = shift;
    my $content = shift;
    if ($content =~ /\n/s) {
        $self->_raw('/**/');
    }
    else {
        $self->_raw('/**/');
    }
    return;
}


sub _javascript {
    my $self = shift;
    $self->script_open(-type => 'text/javascript');
    $self->_raw('// -------- JavaScript Begin --------
    $self->_raw(@_);
    $self->_raw('// --------- JavaScript End --------- ]]>');
    $self->script_close;
    return;
}


sub _parse {
    my $self = shift;
    my $current = $self->{current};

    foreach (@_) {
        next unless(defined($_) and $_ ne '');
        local $XML::SAX::ParserPackage = 'XML::LibXML::SAX';
        my $parser = XML::SAX::ParserFactory->parser(
            Handler => XML::API::SAXHandler->new(xmlapi => $self),
        );

        # remove leading and trailing space, otherwise SAX barfs at us.
        (my $t = $_) =~ s/(^\s+)|(\s+$)//go;
        # escape '&' as well
        $t =~ s/\&(\w+\;)/__AMP__$1/go;
        # escape '&' in urls
        $t =~ s/\&(\w+=)/__AMP__amp;$1/go;
        $parser->parse_string('<_xml_api_ignore>'.$t.'');
    }

    # always make sure that we finish where we started
    $self->{current} = $current;
}


sub _parse_chunk {
    my $self = shift;
    my $current = $self->{current};

    foreach (@_) {
        next unless(defined($_) and $_ ne '');
        local $XML::SAX::ParserPackage = 'XML::LibXML::SAX';
        my $parser = XML::SAX::ParserFactory->parser(
            Handler => XML::API::SAXHandler->new(xmlapi => $self),
        );

        # remove leading and trailing space, otherwise SAX barfs at us.
        (my $t = $_) =~ s/(^\s+)|(\s+$)//go;
        # escape '&' as well
        $t =~ s/\&(\w+\;)/__AMP__$1/go;
        # escape '&' in urls
        $t =~ s/\&(\w+=)/__AMP__amp;$1/go;
        # escape '&' on their own.
        $t =~ s/(\W)\&(\W)/$1__AMP__amp;$2/go;
        $parser->parse_chunk($t);
    }

    # always make sure that we finish where we started
    $self->{current} = $current;
}


sub _attrs {
    my $self  = shift;

    if (@_) {
        my $attrs = shift;
        if (!$attrs or ref($attrs) ne 'HASH') {
            croak 'usage: _attrs($hashref)';
        }
        $self->{current}->{attrs} = $attrs;
    }
    return $self->{current}->{attrs};
}


sub _encoding {
    my $self = shift;
    if (@_) {
        $self->{encoding} = shift;
    }
    return $self->{encoding};
}


sub _set_lang {
    my $self = shift;
    my $lang = shift || croak 'usage: set_lang($lang)';
    my $dir  = shift;

    if ($self->{has_root_element} and !$self->_lang) {
        $self->{elements}->[0]->{attrs}->{'xml:lang'} = $lang;
        if ($dir) {
            $self->{elements}->[0]->{attrs}->{'dir'} = $dir;
        }
    }
    else {
        $self->{langnext} = $lang;
        $self->{dirnext} = $dir if($dir);
    }
    $self->{langs}->{$lang} = 1;

    return;
}


sub _lang {
    my $self = shift;

    if ($self->{current}) {
        return $self->{current}->{attrs}->{'xml:lang'}
            if(exists($self->{current}->{attrs}->{'xml:lang'}));

        my $e = $self->{current};
        while ($e = $e->{parent}) {
            return $e->{attrs}->{'xml:lang'}
                if(exists($e->{attrs}->{'xml:lang'}));
        }
    }
    return $self->{langnext} if ($self->{langnext});
    return $self->{parent}->_lang if ($self->{parent});
    return;
}


sub _langs {
    my $self = shift;
    return keys %{$self->{langs}};
}


sub _dir {
    my $self = shift;

    if ($self->{current}) {
        return $self->{current}->{attrs}->{'dir'}
            if(exists($self->{current}->{attrs}->{'dir'}));

        my $e = $self->{current};
        while ($e = $e->{parent}) {
            return $e->{attrs}->{'dir'}
                if(exists($e->{attrs}->{'dir'}));
        }
    }
    return $self->{dirnext} if ($self->{dirnext});
    return $self->{parent}->_dir if ($self->{parent});
    return;
}


sub _ns {
    my $self = shift;
    if (@_) {
        $self->{namespace} = shift;
    }
    return $self->{namespace};
}


sub _debug {
    my $self = shift;
    if (@_) {
        $self->{debug} = shift;
    }
    return $self->{debug};
}


sub _current {
    my $self = shift;
    return $self->{current};
}

sub _set_id {
    my $self = shift;
    my $id   = shift;

    if (!defined($id) or $id eq '') {
        carp '_set_id called without a valid id';
        return;
    }
    if (defined($self->{ids}->{$id})) {
        carp 'id '.$id.' already defined - overwriting';
    }
    $self->{ids}->{$id} = $self->{current};
}


sub _goto {
    my $self = shift;

    if (@_) {
        my $id = shift;
        if (!defined $id) {
            $self->{current} = undef;
            return;
        }
        if ($id->isa( 'XML::API::Element' )) {
            $self->{current} = $id;
        }
        elsif (defined($self->{ids}->{$id})) {
                $self->{current} = $self->{ids}->{$id};
        }
        else {
            carp "Nonexistent ID given to _goto: '$id'. ",
                 '(Known IDs: ', join(',',keys(%{$self->{ids}})),')';
            $self->{current} = undef;
        }
    }
    return $self->{current};
}


sub _as_string {
    my $self = shift;
    my $file = shift;

    my $string = '';

    if (ref($self) eq __PACKAGE__ or $self->{has_root_element}) {
        $string = qq{{encoding}" ?>\n};
        $string .= $self->_doctype . "\n" if($self->_doctype);
    }

    $string .= join("\n", map {
            $_->isa( __PACKAGE__ )
                ? join("\n", map {$_->as_string} $_->_elements)
                : $_->as_string('', '  ')
        } @{$self->{elements}});

    if ($file) {
        open(FH, '>'.$file) || die "open '$file': $!";
        if ($self->_encoding eq 'UTF-8') {
            binmode(FH, ':utf8');
        }
        print FH $string;
        close(FH);
        return;
    }
    return $string;
}


sub _fast_string {
    my $self = shift;
    my $file = shift;

    my $string = '';

    if (ref($self) eq __PACKAGE__ or $self->{has_root_element}) {
        $string = qq{{encoding}" ?>};
        $string .= $self->_doctype if($self->_doctype);
    }

    $string .= join("\n", map {$_->fast_string('', '  ')} @{$self->{elements}});

    if ($file) {
        open(FH, '>'.$file) || die "open '$file': $!";
        if ($self->_encoding eq 'UTF-8') {
            binmode(FH, ':utf8');
        }
        print FH $string;
        close(FH);
        return;
    }
    return $string;
}


sub _escapeXML {
    my $data = $_[0];
    return '' unless(defined($data));
    if ($data =~ /[\&\<\>\"(__AMP__)\']/o) {
        $data =~ s/\&(?!\w+\;)/\&\;/go;
        $data =~ s/\
        $data =~ s/\>/\>\;/go;
        $data =~ s/\"/\"\;/go;
        $data =~ s/__AMP__/\&/go;
        $data =~ s/\'/\&apos\;/go;
    }
    return $data;
}


#
# We must specify the DESTROY function explicitly otherwise our AUTOLOAD
# function gets called at object death.
#
DESTROY {};


1;
__END__