File Coverage

blib/lib/XML/Trivial.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

package XML::Trivial;

use XML::Parser::Expat;

use strict;
use warnings;

our $VERSION = '0.06';

my @stack;
my @nsstack = ({''=>'',
		xml=>'http://www.w3.org/XML/1998/namespace',
		xmlns=>'http://www.w3.org/2000/xmlns/'});
my $cur;

sub parseFile {
    my $filename = shift;
    local *FH;
    open(FH,$filename);
    my $ret = XML::Trivial::parse(*FH);
    close(FH);
    return $ret;
}

sub parse {
    @stack = undef;
    $cur = 0;
    my $expat = new XML::Parser::Expat;
    $expat->setHandlers(XMLDecl    => \&XML::Trivial::_xmldecl,
			Doctype    => \&XML::Trivial::_doctype,
			Start      => \&XML::Trivial::_startElement,
			End        => \&XML::Trivial::_endElement,
			Char       => \&XML::Trivial::_char,
			Comment    => \&XML::Trivial::_comment,
			Proc       => \&XML::Trivial::_proc,
			CdataStart => \&XML::Trivial::_startCDATA,
			CdataEnd   => \&XML::Trivial::_endCDATA
		       );
    $expat->parse(@_);
    $expat->release;
    my $ret = XML::Trivial::Element->new($stack[0]);
    return $ret;
}

#handlers

sub _xmldecl {
    my ($p, $ver, $enc, $std) = @_;
    push @{$stack[$cur]},('-xml',[$ver,$enc,$std]);
}

sub _doctype {
    my ($p, $nam, $sid, $pid, $int) = @_;
    push @{$stack[$cur]},('-doc',[$nam, $sid, $pid, $int]);
}

sub _startElement {
    my ($p, $el, %atts) = @_;
    $cur++;
    push @stack, [$el,\%atts];
    my %ns;
    my ($name, $value);
    while (($name, $value) = each %atts) {
	$name =~ /^xmlns(:|)(.*)$/ and $ns{$2} = $value;
    }
    push @nsstack, \%ns;
}

sub _endElement {
    my ($p, $el) = @_;
    my $n = XML::Trivial::Element->new($stack[$cur], \@nsstack);
    $cur--;
    pop @stack;
    push @{$stack[$cur]},('-elm',$n);
    pop @nsstack;
}

sub _char {
    my ($p, $str) = @_;
    if ($stack[$cur][@{$stack[$cur]}-2] eq '-txt' or
	$stack[$cur][@{$stack[$cur]}-2] eq '-cds') {
	$stack[$cur][@{$stack[$cur]}-1] .= $str;
    } elsif ($stack[$cur][@{$stack[$cur]}-1] eq '-cds') {
	push @{$stack[$cur]},$str;
    } else {
	push @{$stack[$cur]},('-txt',$str);
    }
}

sub _comment {
    my ($p, $str) = @_;
    push @{$stack[$cur]},('-not',$str);
}

sub _proc {
    my ($p, $tgt, $data) = @_;
    push @{$stack[$cur]},('-pro',[$tgt, $data]);
}

sub _startCDATA {
    my ($p) = @_;
    push @{$stack[$cur]},'-cds';
}

sub _endCDATA {
    my ($p) = @_;
    if ($stack[$cur][@{$stack[$cur]}-1] eq '-cds') {
	push @{$stack[$cur]},undef;
    }
    $stack[$cur][@{$stack[$cur]}-2] = '-cdt';
}


package XML::Trivial::Element;
use Scalar::Util 'weaken';
use strict;
use warnings;

sub new {
    my ($class, $aref, $nsstack) = @_;
    tie my %h, $class, $aref || [], $nsstack;
    my $self =  bless \%h, $class;
    my %ehns;
    my $key;
    my $s = tied(%$self);
    foreach (@{$s->{ea}}) {
	tied(%$_)->{parent} = $self;
	weaken(tied(%$_)->{parent});#because it is circular ref
	$key = $_->ns(undef).'*'.$_->ln();
	$ehns{$key} = $_ unless exists $ehns{$key};
    }
    $s->{ehns} = \%ehns;
    return $self;
}

sub TIEHASH {
    my ($class, $a, $nsstack) = @_;
    #$a is arrayref like [name, atts, type1, data1, type2, data2, ...]
    my @ea; my %eh;#elements
    my @ta;        #texts
    my @ca;        #cdatas
    my @pa; my %ph;#process instructions
    my @na;        #notes
    my $firstkey;
    my $lastkey;
    my %next;
    my %nh;        #hash of namespaces in scope
    foreach (@$nsstack) {
	while (my ($name, $value) = each %$_) {
	    $nh{$name} = $value;
	}
    }
    for (my $i = 0; $i < @$a; $i += 2) {
	if ($$a[$i] =~ /^-(.*)$/) {
	    if ($1 eq 'elm') {
		push @ea, $$a[$i+1];
		unless ($eh{$$a[$i+1]->a(0)}) {
		    $eh{$$a[$i+1]->a(0)} = $$a[$i+1];
		    if ($lastkey) {
			$next{$lastkey} = $$a[$i+1]->a(0);
		    }
		    $lastkey = $$a[$i+1]->a(0);
		}
		$firstkey ||= $$a[$i+1]->a(0);
	    } elsif ($1 eq 'txt') {
		push @ta, $$a[$i+1];
	    } elsif ($1 eq 'cdt') {
		push @ta, $$a[$i+1];
		push @ca, $$a[$i+1];
	    } elsif ($1 eq 'pro') {
		push @pa, $$a[$i+1];
		unless ($ph{$$a[$i+1][0]}) {
		    $ph{$$a[$i+1][0]} = $$a[$i+1][1];
		}
	    } elsif ($1 eq 'not') {
		push @na, $$a[$i+1];
	    }
	}
    }
    return bless {a=>$a,
		  ea=>\@ea, eh=>\%eh,
		  ta=>\@ta,
		  ca=>\@ca,
		  pa=>\@pa, ph=>\%ph,
		  na=>\@na,
		  nh=>\%nh,
		  parent=>undef,
		  firstkey=>$firstkey,
		  next=>\%next
		 }, $class;
}

sub FETCH {
    my ($self, $key) = @_;
    $key =~ /^\d+$/ and return $$self{ea}[$key];
    $key =~ /\*/ and return $$self{ehns}{$key};
    return $$self{eh}{$key};
}

sub EXISTS {
    my ($self, $key) = @_;
    $key =~ /\*/ and return exists $$self{ehns}{$key};
    return exists $$self{eh}{$key};
}

sub FIRSTKEY {
    return $$_[0]{firstkey};
}

sub NEXTKEY {
    return $$_[0]{next}{$$_[1]};
}

sub SCALAR {
    return $$_[0]{a}[0];
}

sub p { #parent
    my ($self) = @_;
    return tied(%$self)->{parent};
}

sub xv { #xml version
    my ($self) = @_;
    my $s = tied(%$self);
    defined $s->{parent} and return $s->{parent}->xv();
    $s->{a}[0] eq '-xml' and return $s->{a}[1][0];
    return '1.0';
}

sub xe { #xml encoding
    my ($self) = @_;
    my $s = tied(%$self);
    defined $s->{parent} and return $s->{parent}->xe();
    $s->{a}[0] eq '-xml' and defined $s->{a}[1][1] and
	return $s->{a}[1][1];
    return 'UTF-8';
}

sub xs { #xml standalone
    my ($self) = @_;
    my $s = tied(%$self);
    defined $s->{parent} and return $s->{parent}->xs();
    $s->{a}[0] eq '-xml' and defined $s->{a}[1][2] and
	return $s->{a}[1][2]?1:0;
    return undef;
}

sub dn { #doctype name
    my ($self) = @_;
    my $s = tied(%$self);
    defined $s->{parent} and return $s->{parent}->dn();
    my $i = 0;
    while ($s->{a}[$i] =~ /^-/) {
	$s->{a}[$i] eq '-doc' and return $s->{a}[$i+1][0];
	$i += 2;
    }
    return undef;
}

sub ds { #doctype system
    my ($self) = @_;
    my $s = tied(%$self);
    defined $s->{parent} and return $s->{parent}->ds();
    my $i = 0;
    while ($s->{a}[$i] =~ /^-/) {
	$s->{a}[$i] eq '-doc' and return $s->{a}[$i+1][1];
	$i += 2;
    }
    return undef;
}

sub dp { #doctype public
    my ($self) = @_;
    my $s = tied(%$self);
    defined $s->{parent} and return $s->{parent}->dp();
    my $i = 0;
    while ($s->{a}[$i] =~ /^-/) {
	$s->{a}[$i] eq '-doc' and return $s->{a}[$i+1][2];
	$i += 2;
    }
    return undef;
}

sub en { #element (qualified) name
    my ($self) = @_;
    return tied(%$self)->{a}[0];
}

sub ep { #element prefix
    my ($self) = @_;
    tied(%$self)->{a}[0] =~ /^([^:]*):.*$/ and return $1;
    return '';
}

sub ln { #local (unqualified) name
    my ($self) = @_;
    tied(%$self)->{a}[0] =~ /^([^:]*:)?([^:]*)$/ and return $2;
}

sub ns { #namespace
    my ($self, $p) = @_;
    1 == @_ and return wantarray ? %{tied(%$self)->{nh}} : tied(%$self)->{nh};
    defined $p and return tied(%$self)->{nh}{$p};
    return tied(%$self)->{nh}{$self->ep()};
}

sub ah { #attribute hash
    my ($self, $key, $ns) = @_;
    1 == @_ and return wantarray ? %{tied(%$self)->{a}[1]} : tied(%$self)->{a}[1];
    2 == @_ and return tied(%$self)->{a}[1]{$key};
    my $s = tied(%$self);
    my ($ret, $name, $value);
    if (defined $key) {
	if (defined $ns) {
	    $key =~ /:/ and return undef;
	    while (($name, $value) = each %{$s->{a}[1]}) {
		unless (defined $ret) {
		    if ($name eq $key) {
			$ns eq '' and $ret = $value;
		    } elsif ($name =~ /^([^:]+):$key$/) {
			exists $s->{nh}{$1} and $s->{nh}{$1} eq $ns and
			    $ret = $value;
		    }
		}
	    }
	    return $ret;
	} else {
	    $ret = {};
	    $key =~ /:/ and return $ret;
	    while (($name, $value) = each %{$s->{a}[1]}) {
		if ($name eq $key) {
		    $$ret{''} = $value;
		} elsif ($name =~ /^((([^:]+):)|)$key$/) {
		    $$ret{$s->{nh}{$3}} = $value;
		}
	    }
	}
    } else {
	$ns = $self->ns(undef) unless defined $ns;
	$ret = {};
	if ($ns eq '') {
	    while (($name, $value) = each %{$s->{a}[1]}) {
		$name !~ /:/ and $$ret{$name} = $value;
	    }
	} else {
	    while (($name, $value) = each %{$s->{a}[1]}) {
		$name =~ /^([^:]+):([^:]+)$/ and $s->{nh}{$1} eq $ns and
		    $$ret{$2} = $value;
	    }
	}
    }
    return wantarray ? %$ret : $ret;
}

sub eh { #element hash
    my ($self, $key) = @_;
    1 == @_ and return wantarray ? %{tied(%$self)->{eh}} : tied(%$self)->{eh};
    $key =~ /\*/ and return tied(%$self)->{ehns}{$key};
    return tied(%$self)->{eh}{$key};
}

sub ea { #element array
    my ($self, $index) = @_;
    1 == @_ and return wantarray ? @{tied(%$self)->{ea}} : tied(%$self)->{ea};
    return tied(%$self)->{ea}[$index];
}

sub ta { #text array (ca included)
    my ($self, $index) = @_;
    (1 == @_ or not defined $index)
	and return wantarray ? @{tied(%$self)->{ta}} : tied(%$self)->{ta};
    return tied(%$self)->{ta}[$index];
}

sub ca { #cdata array
    my ($self, $index) = @_;
    (1 == @_ or not defined $index)
	and return wantarray ? @{tied(%$self)->{ca}} : tied(%$self)->{ca};
    return tied(%$self)->{ca}[$index];
}

sub ts { #text serialized
    my ($self) = @_;
    return join '', @{tied(%$self)->{ta}};
}

sub pa { #process instr. array
    my ($self, $index) = @_;
    (1 == @_ or not defined $index)
	and return wantarray ? @{tied(%$self)->{pa}} : tied(%$self)->{pa};
    return tied(%$self)->{pa}[$index];
}

sub ph { #process instr. hash
    my ($self, $key) = @_;
    1 == @_ and return wantarray ? %{tied(%$self)->{ph}} : tied(%$self)->{ph};
    return tied(%$self)->{ph}{$key};
}

sub na { #notes array
    my ($self, $index) = @_;
    (1 == @_ or not defined $index)
	and return wantarray ? @{tied(%$self)->{na}} : tied(%$self)->{na};
    return tied(%$self)->{na}[$index];
}

sub a { #all in the document order
    my ($self, $index) = @_;
    (1 == @_ or not defined $index)
	and return wantarray ? @{tied(%$self)->{a}} : tied(%$self)->{a};
    return tied(%$self)->{a}[$index];
}



sub sr { #serialize
    my ($self) = @_;
    my $s = tied(%$self);
    my $ret = '';
    my $val;
    my $i = 0;
    my $en;
    my $pfix = "\n";
    while ($s->{a}[$i]) {
	if ($s->{a}[$i] =~ /^-(.*)$/) {
	    if ($1 eq 'elm') {
		$ret .= $s->{a}[$i+1]->sr;
	    } elsif ($1 eq 'txt') {
		$val = $s->{a}[$i+1];
		$val =~ s/\&/\&/g;
		$val =~ s/
		$val =~ s/\]\]>/]]\>/g;
	        $ret .= $val;
            } elsif ($1 eq 'cdt') {
	        $ret .= '{a}[$i+1].']]>';
            } elsif ($1 eq 'pro') {
	        $ret .= '{a}[$i+1][0].' '.$s->{a}[$i+1][1].'?>'.$pfix;
            } elsif ($1 eq 'not') {
	        $ret .= ''.$pfix;
            } elsif ($1 eq 'xml') {
		$ret .= "{a}[$i+1][0]."'";
		$s->{a}[$i+1][1] and $ret .= " encoding='".$s->{a}[$i+1][1]."'";
		defined $s->{a}[$i+1][2] and $ret .= " standalone='".($s->{a}[$i+1][2]?'yes':'no')."'";
		$ret .= "?>".$pfix;
	    } elsif ($1 eq 'doc') {
		$ret .= '{a}[$i+1][0];
		$s->{a}[$i+1][2] and $ret .= ' PUBLIC \''.$s->{a}[$i+1][2].'\'';
		$s->{a}[$i+1][1] and not $s->{a}[$i+1][2] and $ret .= ' SYSTEM';
		$s->{a}[$i+1][1] and $ret .= ' \''.$s->{a}[$i+1][1].'\'';
		$ret .= ">".$pfix;
	    }
	} else {
	    $pfix = '';
	    $en = $s->{a}[$i];
	    $ret .= '<'.$en;
	    foreach (keys %{$s->{a}[$i+1]}) {
		$val = $s->{a}[$i+1]{$_};
		$val =~ s/\&/\&/g;
		$val =~ s/\'/\'/g;
		$val =~ s/
		$ret .= ' '.$_."='".$val."'";
	    }
	    $ret .= '>';
	}
	$i += 2;
    }
    defined $en or return $ret;
    return $ret.'';
}

1;

__END__