| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package XML::Invisible::Receiver; | 
| 2 |  |  |  |  |  |  |  | 
| 3 | 1 |  |  | 1 |  | 7 | use strict; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 30 |  | 
| 4 | 1 |  |  | 1 |  | 5 | use warnings; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 27 |  | 
| 5 | 1 |  |  | 1 |  | 5 | use base 'Pegex::Receiver'; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 418 |  | 
| 6 |  |  |  |  |  |  |  | 
| 7 |  |  |  |  |  |  | sub gotrule { | 
| 8 | 20 |  |  | 20 | 1 | 82747 | my $self = shift; | 
| 9 | 20 | 100 |  |  |  | 46 | my $param = (@_ == 1) ? $_[0] : [ @_ ]; | 
| 10 | 20 | 50 |  |  |  | 42 | return unless defined $param; | 
| 11 | 20 |  |  |  |  | 31 | my $parser = $self->{parser}; | 
| 12 | 20 |  |  |  |  | 27 | my $rule = $parser->{rule}; | 
| 13 | 20 |  |  |  |  | 29 | my $parentrule = $parser->{parent}; | 
| 14 | 20 |  |  |  |  | 24 | my ($attr, $flatten) = @{$parentrule}{qw(-wrap -flat)}; | 
|  | 20 |  |  |  |  | 38 |  | 
| 15 | 20 | 50 | 66 |  |  | 52 | die "Can't have both attribute (+) and flatten (-) on same node" | 
| 16 |  |  |  |  |  |  | if $attr and $flatten; | 
| 17 | 20 | 100 |  |  |  | 36 | if ($flatten) { | 
| 18 | 5 |  |  |  |  | 15 | return $param; | 
| 19 |  |  |  |  |  |  | } | 
| 20 | 15 | 100 |  |  |  | 44 | $param = [ $param ] if ref $param ne 'ARRAY'; | 
| 21 | 15 |  |  |  |  | 40 | $param = $self->flatten($param); | 
| 22 | 15 |  |  |  |  | 200 | my %ret = ( | 
| 23 |  |  |  |  |  |  | nodename => $rule, | 
| 24 |  |  |  |  |  |  | type => 'element', | 
| 25 |  |  |  |  |  |  | ); | 
| 26 | 15 |  |  |  |  | 30 | for (@$param) { | 
| 27 | 21 | 100 | 100 |  |  | 71 | if (!ref $_ or $_->{type} eq 'element') { | 
|  |  | 50 |  |  |  |  |  | 
| 28 | 17 |  |  |  |  | 21 | push @{ $ret{children} }, $_; | 
|  | 17 |  |  |  |  | 49 |  | 
| 29 |  |  |  |  |  |  | } elsif ($_->{type} eq 'attr') { | 
| 30 | 4 |  |  |  |  | 8 | $ret{attributes}{$_->{nodename}} = join '', _get_values($_); | 
| 31 |  |  |  |  |  |  | } else { | 
| 32 | 0 |  |  |  |  | 0 | die "Unknown entity type '$_->{type}'"; | 
| 33 |  |  |  |  |  |  | } | 
| 34 |  |  |  |  |  |  | } | 
| 35 | 15 | 100 |  |  |  | 64 | $ret{type} = 'attr' if $attr; | 
| 36 | 15 |  |  |  |  | 55 | \%ret; | 
| 37 |  |  |  |  |  |  | } | 
| 38 |  |  |  |  |  |  |  | 
| 39 |  |  |  |  |  |  | sub _get_values { | 
| 40 | 4 |  |  | 4 |  | 8 | my ($node) = @_; | 
| 41 | 4 | 50 |  |  |  | 6 | map ref($_) ? _get_values($_) : $_, @{ $node->{children} }; | 
|  | 4 |  |  |  |  | 20 |  | 
| 42 |  |  |  |  |  |  | } | 
| 43 |  |  |  |  |  |  |  | 
| 44 |  |  |  |  |  |  | 1; | 
| 45 |  |  |  |  |  |  |  | 
| 46 |  |  |  |  |  |  | __END__ |