view release on metacpan or  search on metacpan

lib/XML/All.pm  view on Meta::CPAN

package XML::All;

use 5.006001;
use strict;
use warnings;
use XML::Twig ();
use Tie::Simple ();
use Exporter::Lite ();
use Class::InsideOut ();

our @EXPORT = qw( xml );
our $VERSION = '0.02';

Class::InsideOut::private(twig => my %twig);
Class::InsideOut::private(sv => my %sv);
Class::InsideOut::private(av => my %av);
Class::InsideOut::private(cv => my %cv);

use XML::Literal sub {
    my $obj = Class::InsideOut::register( bless \(my $s), __PACKAGE__ );
    my $xml = XML::Twig->new;
    $xml->parse($_[0]);
    $twig{ Class::InsideOut::id($obj) } = $xml->root;
    bless($obj);
};

my $id = \&Class::InsideOut::id;

my $xmlify = sub {
    my $xml = XML::Twig->new;
    $xml->parse($_[0]);
    return $xml->root;
};

my $wrap = sub {
    my $res = Class::InsideOut::register( bless \(my $s), __PACKAGE__ );
    $twig{ $id->($res) } = $_[0];
    bless($res);
};

my $unwrap = sub {
    $twig{$id->($_[0]) || do {
        my $elt = XML::Twig::Elt->new(XML::Twig::PCDATA);
        $elt->_set_pcdata($_[0]);
        return $elt;
    }};
};

sub xml {
    if (ref($_[0]) and ref($_[0])->isa(__PACKAGE__)) {
        my $obj = $twig{$id->(shift(@_))};
        my @children = map { $wrap->($_) } $obj->children(join('', 'xml', map { "[$_]" } @_ ));
        wantarray ? @children : $children[0];
    }
    elsif ($_[0] =~ /^\s*</) {
        my $xml = XML::Twig->new;
        $xml->parse($_[0]);
        return $wrap->($xml);
    }
    else {
        my $xml = XML::Twig->new;
        $xml->parsefile($_[0]);
        return $wrap->($xml);
    }
}

sub AUTOLOAD :lvalue {
    my $meth = our $AUTOLOAD;
    $meth =~ s/.*:://;

    return if $meth eq 'DEMOLISH' or $meth eq 'DESTROY';

    my $xml = shift;
    my $obj = $twig{$id->($xml)};
    my @children = $obj->children(join('', $meth, map { "[$_]" } @_ ));
    if (wantarray and @children != 1) {
        @children = map { $wrap->($_) } @children;
        return @children;
    }
    else {
        $children[0] or return undef;
        my $res = Class::InsideOut::register( bless \(my $s), __PACKAGE__ );
        $twig{ $id->($res) } = $children[0];
        bless($res);
        return $res;
    }
}

my $op;
BEGIN { $op = sub {
    my ($sym, $call) = @_;
    return (
        $sym => sub {
            my $obj = $twig{$id->($_[0])} || $xmlify->($_[0]);
            my $tgt = $twig{$id->($_[1])} || $xmlify->($_[1]);
            ($obj, $tgt) = ($tgt, $obj) if $_[2];
            my $cpy = $obj->copy;
            $call->($cpy, $tgt);
            $wrap->($cpy);
        },
        "$sym=" => sub {
            my $obj = $twig{$id->($_[0])} || $xmlify->($_[0]);
            my $tgt = $twig{$id->($_[1])} || $xmlify->($_[1]);