File Coverage

blib/lib/XML/API.pm

Criterion	Covered	Total	%
statement	345	480	71.8
branch	134	224	59.8
condition	28	67	41.7
subroutine	43	57	75.4
pod	1	1	100.0
total	551	829	66.4

# 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.30';

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 . ' />'
      unless @{ $self->{contents} };

    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} }
      )
      . '
      . ( $self->{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.30';
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__