File Coverage

blib/lib/XML/Spice.pm

Criterion	Covered	Total	%
statement	37	105	35.2
branch	3	40	7.5
condition	0	9	0.0
subroutine	10	17	58.8
pod	0	1	0.0
total	50	172	29.0

package XML::Spice;
$XML::Spice::VERSION = '0.04';
require 5.008;

use warnings;
use strict;

use Carp;

our $PRETTY_PRINT = 0;

sub import {
    my ($pkg, @args) = @_;

    my $them = caller();

    if (@args) {
        for my $arg (@args) {
            croak "Invalid element name '$arg'" if $arg !~ m/^[A-Za-z]\w*$/;

            {
                no strict "refs";
                *{$them."::".$arg} = sub { x($arg, @_) };
            }
        }
    }

    else {
        no strict "refs";
        *{$them."::x"} = \&x;
    }
}

sub x {
    my ($tag, @args) = @_;

    my $chunk = {
        tag   => $tag,
        attrs => {},
    };

    for my $arg (@args) {
        if (ref $arg eq "HASH") {
            for my $key (keys %$arg) {
                if (!defined $arg->{$key}) {
                    delete $chunk->{attrs}->{$key};
                } else {
                    $chunk->{attrs}->{$key} = "".$arg->{$key};
                }
            }
        }

        else {
            push @{$chunk->{sub}}, $arg;
        }
    }

    return bless $chunk, "XML::Spice::Chunk";
}


package # hide from PAUSE
    XML::Spice::Chunk;

use warnings;
use strict;

use Carp;

use overload
    '""' => \&_xml;

my $TIDY_LOADED;

sub _xml {
    my ($chunk) = @_;

    if ($PRETTY_PRINT && !defined $TIDY_LOADED) {
        eval { require XML::Tidy::Tiny };
        if ($@) {
            carp "Couldn't load XML::Tidy::Tiny: $@";
            $TIDY_LOADED = 0;
        }
        else {
            $TIDY_LOADED = 1;
        }
    }

    my $WANT_PRETTY = $PRETTY_PRINT && $TIDY_LOADED;

    return $chunk->{cached} if exists $chunk->{cached} && !$WANT_PRETTY;

    sub _escape_attr {
        my ($val) = @_;
        $val =~ s/'/'/g;
        return $val;
    }

    sub _escape_cdata {
        my ($val) = @_;
        $val =~ s/&/&/g;
        $val =~ s/
        $val =~ s/>/>/g;
        $val =~ s/"/"/g;
        $val =~ s/([^\x20-\x7E])/'&#' . ord($1) . ';'/ge;
        return $val;
    }

    sub _serialise {
        my ($chunk, @things) = @_;

        my $xml = '';

        for my $thing (@things) {
            next if ! defined $thing;

            if (ref $thing eq "CODE") {
                $thing = &{$thing};

                if (ref $thing eq "HASH") {
                    for my $key (keys %$thing) {
                        if (!defined $thing->{$key}) {
                            delete $chunk->{attrs}->{$key};
                        } else {
                            $chunk->{attrs}->{$key} = "".$thing->{$key};
                        }
                    }
                    undef $thing;
                }

                redo;
            }

            if (ref $thing eq "ARRAY") {
                $xml .= $chunk->_serialise(@$thing);
            }

            elsif (ref $thing eq "XML::Spice::Chunk") {
                $xml .= $thing->_xml;
            }

            else {
                next if $thing eq "";
                $xml .= _escape_cdata($thing);
            }
        }

        return $xml;
    }

    my $subxml = $chunk->_serialise(@{$chunk->{sub}}) if exists $chunk->{sub};

    my $xml = "<" . $chunk->{tag};

    for my $attr (keys %{$chunk->{attrs}}) {
        $xml .= " $attr='" . _escape_attr($chunk->{attrs}->{$attr}) . "'";
    }

    if (!defined $subxml) {
        $xml .= "/>";
        $chunk->{cached} = $xml unless $WANT_PRETTY;
        return $WANT_PRETTY ? XML::Tidy::Tiny::xml_tidy($xml) : $xml;
    }

    $xml .= ">" . $subxml . "{tag} . ">";

    $chunk->{cached} = $xml unless $WANT_PRETTY;
    return $WANT_PRETTY ? XML::Tidy::Tiny::xml_tidy($xml) : $xml;
}

sub forget {
    my ($chunk) = @_;

    delete $chunk->{cached};
}

1;

__END__