File Coverage

examples/parse-xml.pl
Criterion Covered Total %
statement 62 65 95.3
branch 7 10 70.0
condition n/a
subroutine 18 21 85.7
pod n/a
total 87 96 90.6


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3 1     1   351 use strict;
  1         1  
  1         26  
4 1     1   4 use warnings;
  1         1  
  1         31  
5              
6             # DO NOT RELY ON THIS AS A REAL XML PARSER!
7              
8             # It is not intended to be used actually as an XML parser, simply to stand as
9             # an example of how you might use Parser::MGC to parse an XML-like syntax
10              
11             # There are a great many things it doesn't do correctly; it lacks at least the
12             # following features:
13             # Entities
14             # Processing instructions
15             # Comments
16             # CDATA
17              
18             package XmlParser;
19 1     1   5 use base qw( Parser::MGC );
  1         1  
  1         458  
20              
21             sub parse
22             {
23 5     5   5 my $self = shift;
24              
25 5         7 my $rootnode = $self->parse_node;
26 5 50       9 $rootnode->kind eq "element" or die "Expected XML root node";
27 5 50       6 $rootnode->name eq "xml" or die "Expected XML root node";
28              
29 5         9 return [ $rootnode->children ];
30             }
31              
32             sub parse_node
33             {
34 28     28   25 my $self = shift;
35              
36             # A "node" is either an XML element subtree or plaintext
37 28         60 $self->any_of( 'parse_plaintext', 'parse_element' );
38             }
39              
40             sub parse_plaintext
41             {
42 28     28   28 my $self = shift;
43              
44 28         35 my $str = $self->substring_before( '<' );
45 28 100       64 $self->fail( "No plaintext" ) unless length $str;
46              
47 7         14 return XmlParser::Node::Plain->new( $str );
48             }
49              
50             sub parse_element
51             {
52 21     21   20 my $self = shift;
53              
54 21         25 my $tag = $self->parse_tag;
55              
56 11         24 $self->commit;
57              
58 11 100       16 return XmlParser::Node::Element->new( $tag->{name}, $tag->{attrs} ) if $tag->{selfclose};
59              
60 10         17 my $childlist = $self->sequence_of( 'parse_node' );
61              
62             $self->parse_close_tag->{name} eq $tag->{name}
63 10 50       28 or $self->fail( "Expected $tag->{name} to be closed" );
64              
65 10         33 return XmlParser::Node::Element->new( $tag->{name}, $tag->{attrs}, @$childlist );
66             }
67              
68             sub parse_tag
69             {
70 21     21   18 my $self = shift;
71              
72 21         42 $self->expect( '<' );
73 21         36 my $tagname = $self->token_ident;
74              
75 11         21 my $attrs = $self->sequence_of( 'parse_tag_attr' );
76              
77 11         16 my $selfclose = $self->maybe_expect( '/' );
78 11         25 $self->expect( '>' );
79              
80             return {
81             name => $tagname,
82 11         36 attrs => { map { ( $_->[0], $_->[1] ) } @$attrs },
  2         8  
83             selfclose => $selfclose,
84             };
85             }
86              
87             sub parse_close_tag
88             {
89 10     10   10 my $self = shift;
90              
91 10         19 $self->expect( '
92 10         13 my $tagname = $self->token_ident;
93 10         19 $self->expect( '>' );
94              
95 10         25 return { name => $tagname };
96             }
97              
98             sub parse_tag_attr
99             {
100 13     13   14 my $self = shift;
101              
102 13         17 my $attrname = $self->token_ident;
103 2         4 $self->expect( '=' );
104 2         3 return [ $attrname => $self->parse_tag_attr_value ];
105             }
106              
107             sub parse_tag_attr_value
108             {
109 2     2   3 my $self = shift;
110              
111             # TODO: This sucks
112 2         6 return $self->token_string;
113             }
114              
115              
116 1     1   498 use Data::Dumper;
  1         5664  
  1         110  
117              
118             if( !caller ) {
119             my $parser = __PACKAGE__->new;
120              
121             my $ret = $parser->from_file( \*STDIN );
122             print Dumper( $ret );
123             }
124              
125              
126             package XmlParser::Node;
127 18     18   18 sub new { my $class = shift; bless [ @_ ], $class }
  18         100  
128              
129             package XmlParser::Node::Plain;
130 1     1   18 use base qw( XmlParser::Node );
  1         1  
  1         344  
131 0     0   0 sub kind { "plain" }
132 0     0   0 sub text { shift->[0] }
133              
134             package XmlParser::Node::Element;
135 1     1   6 use base qw( XmlParser::Node );
  1         1  
  1         238  
136 5     5   10 sub kind { "element" }
137 5     5   11 sub name { shift->[0] }
138 0     0   0 sub attrs { shift->[1] }
139 5     5   5 sub children { my $self = shift; @{$self}[2..$#$self] }
  5         7  
  5         18  
140              
141             1;