XML-Trivial

 view release on metacpan or  search on metacpan

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

	$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) = @_;

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

	    $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/</\&lt;/g;
		$val =~ s/\]\]>/]]\&gt;/g;
	        $ret .= $val;
            } elsif ($1 eq 'cdt') {
	        $ret .= '<![CDATA['.$s->{a}[$i+1].']]>';

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

=item ah(undef, undef)

B<a>ttribute B<h>ash. If both arguments are not defined but present, it returns the hash or hashref of attributes in the element's namespace.

 print "attributes of 'p1:desc' element in its namespace:\n";
 for (my %h = $$xml{0}{meta}{'p1:desc'}->ah(undef,undef); 
      my ($key, $val) = each %h; 
      print " '$key'='$val'\n"){};

Remember, that unprefixed attribute does NOT inherit namespace from its element.

=item eh() 

B<e>lement B<h>ash(ref). Returns hash or hashref (depends on calling context) of child elements. If more than one child element have the same qualified name, only the first one is present in return. 

 print "hash of child elements of 'sections':\n";
 for (my %h = $$xml{0}{sections}->eh(); 
      my ($key, $val) = each %h; 
      print " '$key'='".$val->sr."'\n"){}; 

=item eh($childname) 

B<e>lement B<h>ash. Returns the first child element with specified name. 

 print "first section: ".$$xml{0}{sections}->eh('section')->sr."\n";

=item ea()

B<e>lement B<a>rray(ref). Returns the array or arrayref of child elements.

 print "all childelements of sections:\n";
 foreach ($$xml{0}{sections}->ea) {
     print " element name:".$_->en."\n";
 }

=item ea($index)

B<e>lement B<a>rray. Returns the $index'th child element.

 print "second childelement of sections: ".$$xml{0}{sections}->ea(1)->sr."\n";

=item ta()

B<t>ext B<a>rray(ref). Returns array(ref) of all textnodes, including CDATA sections.

 print "all texts under <text>:\n";
 foreach ($$xml{0}{sections}{text}->ta) {
     print " piece of text:".$_."\n";
 }

=item ta($index)

B<t>ext B<a>rray. Returns $index'th textnode under element, including CDATA sections.

 print "second text under <text>: ".$$xml{0}{sections}{text}->ta(1)."\n";

=item ca()

B<c>data B<a>rray(ref). Returns array(ref) of CDATA sections.

 print "all cdatas under <text>:\n";
 foreach ($$xml{0}{sections}{text}->ca) {
     print " cdata: ".$_."\n";
 }

=item ca($index)

B<c>data B<a>rray. Returns $index'th CDATA section under element.

 print "first cdata section under <text>: ".$$xml{0}{sections}{text}->ca(0)."\n";

=item ts()

B<t>ext B<s>erialized. Returns all textnodes, serialized into scalar string.

 print "whole serialized text under <text>:".$$xml{0}{sections}{text}->ts."\n";

=item pa()

B<p>rocessing instruction B<a>rray(ref). Returns array(ref) of all processing instructions if called without arguments. Items of returned array are arrayrefs of two items, target and body.

 print "processing instructions under rootelement:\n";
 foreach ($$xml{0}->pa) {
     print " target:$$_[0] body:$$_[1]\n";
 }

=item pa($index)

B<p>rocessing instruction B<a>rray. Returns $index'th processing instruction under element. Returned processing instruction is arrayref of two items, target and body.

 print "first processing instruction under rootelement: ".join(' ',@{$$xml{0}->pa(0)})."\n";

=item ph()

B<p>rocessing instruction B<h>ash(ref). Returns the hash(ref) of processing instructions (the first occur of target wins) if called without arguments. 

 print "processing instructions with different targets under rootelement:\n";
 for (my %h = $$xml{0}->ph(); 
      my ($key, $val) = each %h; 
      print " '$key'='".$val."'\n"){};  

=item ph($target)

B<p>rocessing instruction B<h>ash. Returns the first processing instruction with specified target. 

 print "first processing instruction having target 'first' under rootelement: ".$$xml{0}->ph('first')."\n";

=item na()

B<n>ote B<a>rray(ref). Returns array(ref) of all comments if called without arguments.

 print "notes under rootelement:\n";
 foreach ($$xml{0}->na) {
     print " $_\n";
 }

=item na($index)

B<n>ote B<a>rray. Returns $index'th note under element.

 print "second note under rootelement: ".$$xml{0}->na(1)."\n";

=item a($index)

B<a>ll. Returns internal representation of element. Helpfull if the order of mixed elements, text nodes, PI's etc. does matter. See the code, for instance body of sr() method.

=item sr()

B<s>eB<r>ialize.