File Coverage

blib/lib/Treex/PML/Schema/Reader.pm
Criterion Covered Total %
statement 112 129 86.8
branch 49 78 62.8
condition 12 40 30.0
subroutine 14 14 100.0
pod 0 5 0.0
total 187 266 70.3


line stmt bran cond sub pod time code
1             package Treex::PML::Schema::Reader;
2              
3 9     9   48 use strict;
  9         14  
  9         258  
4 9     9   32 use warnings;
  9         14  
  9         379  
5              
6 9     9   32 use vars qw($VERSION);
  9         11  
  9         405  
7             BEGIN {
8 9     9   177 $VERSION='2.29'; # version template
9             }
10 9     9   38 no warnings 'uninitialized';
  9         28  
  9         334  
11 9     9   38 use Carp;
  9         12  
  9         629  
12              
13 9     9   53 use Scalar::Util qw(weaken blessed);
  9         13  
  9         487  
14 9     9   4080 use XML::LibXML::Reader;
  9         307184  
  9         12309  
15              
16             sub new {
17 67     67 0 191 my ($class,$opts)=@_;
18 67         192 my $URL = $opts->{URL};
19 67         392 my @common = (
20             no_xinclude_nodes => 1,
21             no_cdata => 1,
22             expand_xinclude => 1,
23             no_blanks => 1,
24             expand_entities => 1,
25             suppress_errors => 0,
26             suppress_warnings => 0,
27             );
28 67 50       214 if ($opts->{validate}) {
29 0   0     0 my $rng = $opts->{relaxng_schema} || Treex::PML::FindInResources('pml_schema_inline.rng');
30 0 0       0 if (defined $rng) {
31 0         0 push @common, (RelaxNG => $rng);
32             } else {
33 0         0 warn __PACKAGE__.": Validation requested, but 'pml_schema_inline.rng' was not found in the ResourcePath: ".Treex::PML::ResourcePath()."\n";
34             }
35             }
36 67         145 my ($reader,$fh);
37             # print "loading schema $opts->{URL}\n";
38 67 50 33     526 if ($opts->{string}) {
    50          
    50          
39 0   0     0 $URL ||= 'string://';
40             $reader = XML::LibXML::Reader->new(string => $opts->{string},
41 0 0       0 @common,
42             URI => $URL,
43             )
44             or die "Error reading string ($URL)";
45             } elsif ($opts->{fh}) {
46 0   0     0 $URL ||= 'fh://';
47 0 0       0 $reader = XML::LibXML::Reader->new(IO => $opts->{string}, @common )
48             or die "Error reading file-handle $fh ($URL)";
49             } elsif (blessed($opts->{reader}) and $opts->{reader}->isa('XML::LibXML::Reader')) {
50 0         0 $reader = $opts->{reader};
51 0   0     0 $URL ||= $reader->document->URI;
52             } else {
53 67         148 my $file = $opts->{URL};
54 67 50       154 print STDERR "parsing schema $file\n" if $Treex::PML::Debug;
55 67         113 $fh = eval { Treex::PML::IO::open_uri($file) };
  67         272  
56 67 50 33     370 croak "Couldn't open PML schema file '$file'\n".$@ if (!$fh || $@);
57 67 50       617 $reader = XML::LibXML::Reader->new(FD => $fh, @common, URI => $URL )
58             or die "Error reading $file";
59             }
60 67         12478 return bless [$reader,$opts,$fh], $class;
61             }
62             sub DESTROY {
63 67     67   141 my ($self)=@_;
64 67         283 my $fh = $self->file_handle;
65 67 50       380 Treex::PML::IO::close_uri($fh) if $fh;
66             }
67             sub reader {
68 3030   33 3030 0 6306 return ref($_[0]) && $_[0][0];
69             }
70             sub options {
71 2963   33 2963 0 5138 return ref($_[0]) && $_[0][1];
72             }
73             sub file_handle {
74 67   33 67 0 272 return ref($_[0]) && $_[0][2];
75             }
76              
77             sub parse_element {
78 2963     2963 0 3942 my ($self,$parent)=@_;
79 2963         4038 my $reader = $self->reader;
80 2963         4451 my $opts = $self->options;
81 2963         3321 my (@children,@attrs);
82 2963         6239 my $el_ns = $reader->namespaceURI;
83 2963         5064 my $el_name = $reader->localName;
84 2963 50       5426 my $has_default_ns = $el_ns eq $opts->{DefaultNs} ? 1 : 0;
85 2963 50       3945 my $el_ns_name = ($has_default_ns) ? $el_name : '{'.$el_ns.'}'.$el_name;
86 2963         4384 my $prefix = $reader->prefix;
87 2963 50 33     9646 my %val = (
    50          
88             -xml_name => $el_ns_name,
89             ($has_default_ns ? () : (-xml_ns => $el_ns)),
90             (defined($prefix) && length($prefix) ? (-xml_prefix => $prefix) : ()),
91             -parent => $parent,
92             -attributes => \@attrs,
93             );
94 2963 100       5807 weaken($val{-parent}) if $val{-parent};
95              
96 2963 100       5473 if ($reader->moveToFirstAttribute==1) {
97 2062         2259 do {{
98 3182         3172 my $name = $reader->name;
  3182         5826  
99 3182         4399 push @attrs,$name;
100 3182         9965 $val{$name} = $reader->value;
101             }} while ($reader->moveToNextAttribute);
102 2062         3086 $reader->moveToElement;
103             }
104 2963         3355 my $obj = \%val;
105             {
106 2963   66     2973 my $class = $opts->{Bless}{$el_ns_name} || $opts->{Bless}{'*'};
  2963         6691  
107 2963 50       4204 if (defined $class) {
108 2963         5996 bless $obj,$class;
109 2963 100       9811 $obj->init($opts) if $obj->can('init');
110             }
111             }
112 2963         4652 my $depth = $reader->depth;
113 2963         3046 my $status;
114 2963         11716 while (($status = $reader->read==1)) {
115 8709 100       14711 last unless $reader->depth > $depth;
116 5746         7787 my $nodeType = $reader->nodeType;
117 5746         5736 my $chld;
118 5746         5594 my $redo = 0;
119 5746 100 66     12266 if ($nodeType == XML_READER_TYPE_ELEMENT) {
    100 33        
    100 33        
    50          
    50          
120 2896         4828 $chld = $self->parse_element($obj);
121 2896         3197 $redo = 1;
122             } elsif ($nodeType == XML_READER_TYPE_TEXT or
123             $nodeType == XML_READER_TYPE_CDATA) {
124 582         1891 $chld = bless {
125             -xml_name => '#text',
126             -value => $reader->value,
127             }, 'Treex::PML::Schema::XMLNode';
128             } elsif ($nodeType == XML_READER_TYPE_COMMENT) {
129 323         1091 $chld = bless {
130             -xml_name => '#comment',
131             -value => $reader->value,
132             }, 'Treex::PML::Schema::XMLNode';
133             } elsif ($nodeType == XML_READER_TYPE_PROCESSING_INSTRUCTION) {
134 0         0 $chld = bless {
135             -xml_name => '#processing-instruction',
136             -name => $reader->name,
137             -value => $reader->value,
138             }, 'Treex::PML::Schema::XMLNode';
139             } elsif ($nodeType == XML_READER_TYPE_END_ELEMENT or
140             $nodeType == XML_READER_TYPE_SIGNIFICANT_WHITESPACE or
141             $nodeType == XML_READER_TYPE_WHITESPACE) {
142 1945         8322 next;
143             } else {
144 0 0       0 $chld = bless {
145             -xml_name => '#other',
146             -xml_nodetype => $nodeType,
147             -name => $reader->name,
148             ($reader->hasValue ? (-value => $reader->value) : ()),
149             -xml => $reader->readOuterXml,
150             }, 'Treex::PML::Schema::XMLNode';
151             }
152 3801 50       5870 push @children, $chld if defined $chld;
153 3801 100       6694 redo if $redo;
154             }
155 2963 50       4009 if ($status == -1) {
156 0         0 croak "XMLReader error in $opts->{URL} near line ".$reader->lineNumber;
157             }
158              
159 2963         3187 my $i=0;
160 2963         2907 my %try_data;
161 2963 100       4915 if (my $cont = $opts->{TextOnly}{$el_ns_name}) {
162 582         570 my $text;
163 582         768 foreach my $c (@children) {
164 582 50       835 if ($c->{'-xml_name'} ne '#text') {
165 0         0 warn "Ignoring unexpected node ".$c->{'-xml_name'}." in a text-only element $el_ns_name\n";
166             } else {
167 582         907 $text.=$c->{-value};
168             }
169             }
170 582         1109 $val{$cont} = $text;
171             } else {
172 2381         3198 foreach my $c (@children) {
173 3219         4633 $c->{'-#'} = $i++;
174 3219         3798 my $name = $c->{-xml_name};
175 3219 100       4984 if (!ref($val{$name})) {
176 1832 50       2765 if (exists $val{$name}) {
177 0         0 warn "Collision between an attribute and child-element $name\n";
178 0         0 $val{'@'.$name} = delete $val{$name}
179             }
180             }
181 3219         3053 my $value;
182 3219 100       4435 if (my $cont = $opts->{Stringify}{$name}) {
183 580         695 $value = $c->{$cont};
184 580 50       778 $value='' unless defined $value;
185             } else {
186 2639         2802 $value = $c;
187             }
188 3219 100       5704 if ($opts->{Solitary}{$name}) {
    100          
189 1165 50       1740 if (exists $val{$name}) {
190 0         0 warn "Multiple occurences of the child-element '$name'\n";
191             }
192 1165         2045 $val{$name} = $value
193             } elsif (my $key = $opts->{KeyAttr}{$name}) {
194 1211         1749 my $val = delete $c->{$key};
195 1211         1826 $c->{-name}=$val;
196 1211         3069 $val{$name}{$val} = $value;
197             } else {
198 843         774 push @{$val{$name}}, $value;
  843         1483  
199             }
200 3219         5304 weaken($c->{-parent} = $obj);
201             }
202 2381         3584 $obj->{'-##'} = $i;
203             }
204 2963 100       6442 if (UNIVERSAL::can($obj,'post_process')) {
205 151         468 $obj->post_process($opts);
206             }
207 2963         7768 return $obj;
208             }
209              
210              
211             1;
212             __END__