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 8     8   55 use strict;
  8         16  
  8         317  
4 8     8   37 use warnings;
  8         14  
  8         478  
5              
6 8     8   45 use vars qw($VERSION);
  8         14  
  8         435  
7             BEGIN {
8 8     8   200 $VERSION='2.28'; # version template
9             }
10 8     8   70 no warnings 'uninitialized';
  8         16  
  8         373  
11 8     8   57 use Carp;
  8         15  
  8         607  
12              
13 8     8   55 use Scalar::Util qw(weaken blessed);
  8         14  
  8         479  
14 8     8   4375 use XML::LibXML::Reader;
  8         369266  
  8         15093  
15              
16             sub new {
17 66     66 0 234 my ($class,$opts)=@_;
18 66         211 my $URL = $opts->{URL};
19 66         420 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 66 50       275 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 66         145 my ($reader,$fh);
37             # print "loading schema $opts->{URL}\n";
38 66 50 33     693 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 66         188 my $file = $opts->{URL};
54 66 50       182 print STDERR "parsing schema $file\n" if $Treex::PML::Debug;
55 66         158 $fh = eval { Treex::PML::IO::open_uri($file) };
  66         318  
56 66 50 33     410 croak "Couldn't open PML schema file '$file'\n".$@ if (!$fh || $@);
57 66 50       1478 $reader = XML::LibXML::Reader->new(FD => $fh, @common, URI => $URL )
58             or die "Error reading $file";
59             }
60 66         15918 return bless [$reader,$opts,$fh], $class;
61             }
62             sub DESTROY {
63 66     66   180 my ($self)=@_;
64 66         266 my $fh = $self->file_handle;
65 66 50       441 Treex::PML::IO::close_uri($fh) if $fh;
66             }
67             sub reader {
68 2961   33 2961 0 8537 return ref($_[0]) && $_[0][0];
69             }
70             sub options {
71 2895   33 2895 0 6594 return ref($_[0]) && $_[0][1];
72             }
73             sub file_handle {
74 66   33 66 0 339 return ref($_[0]) && $_[0][2];
75             }
76              
77             sub parse_element {
78 2895     2895 0 5185 my ($self,$parent)=@_;
79 2895         5534 my $reader = $self->reader;
80 2895         5390 my $opts = $self->options;
81 2895         4488 my (@children,@attrs);
82 2895         9208 my $el_ns = $reader->namespaceURI;
83 2895         7357 my $el_name = $reader->localName;
84 2895 50       7098 my $has_default_ns = $el_ns eq $opts->{DefaultNs} ? 1 : 0;
85 2895 50       5364 my $el_ns_name = ($has_default_ns) ? $el_name : '{'.$el_ns.'}'.$el_name;
86 2895         6199 my $prefix = $reader->prefix;
87 2895 50 33     13799 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 2895 100       7860 weaken($val{-parent}) if $val{-parent};
95              
96 2895 100       7317 if ($reader->moveToFirstAttribute==1) {
97 2014         2687 do {{
98 3106         3895 my $name = $reader->name;
  3106         6888  
99 3106         5800 push @attrs,$name;
100 3106         13745 $val{$name} = $reader->value;
101             }} while ($reader->moveToNextAttribute);
102 2014         3808 $reader->moveToElement;
103             }
104 2895         4525 my $obj = \%val;
105             {
106 2895   66     4019 my $class = $opts->{Bless}{$el_ns_name} || $opts->{Bless}{'*'};
  2895         8657  
107 2895 50       5126 if (defined $class) {
108 2895         7626 bless $obj,$class;
109 2895 100       12974 $obj->init($opts) if $obj->can('init');
110             }
111             }
112 2895         7242 my $depth = $reader->depth;
113 2895         3821 my $status;
114 2895         16127 while (($status = $reader->read==1)) {
115 8493 100       21879 last unless $reader->depth > $depth;
116 5598         11037 my $nodeType = $reader->nodeType;
117 5598         7475 my $chld;
118 5598         7231 my $redo = 0;
119 5598 100 66     17594 if ($nodeType == XML_READER_TYPE_ELEMENT) {
    100 33        
    100 33        
    50          
    50          
120 2829         6601 $chld = $self->parse_element($obj);
121 2829         4108 $redo = 1;
122             } elsif ($nodeType == XML_READER_TYPE_TEXT or
123             $nodeType == XML_READER_TYPE_CDATA) {
124 573         3333 $chld = bless {
125             -xml_name => '#text',
126             -value => $reader->value,
127             }, 'Treex::PML::Schema::XMLNode';
128             } elsif ($nodeType == XML_READER_TYPE_COMMENT) {
129 290         1272 $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 1906         12223 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 3692 50       7632 push @children, $chld if defined $chld;
153 3692 100       9735 redo if $redo;
154             }
155 2895 50       5220 if ($status == -1) {
156 0         0 croak "XMLReader error in $opts->{URL} near line ".$reader->lineNumber;
157             }
158              
159 2895         3811 my $i=0;
160 2895         3810 my %try_data;
161 2895 100       7096 if (my $cont = $opts->{TextOnly}{$el_ns_name}) {
162 573         844 my $text;
163 573         1138 foreach my $c (@children) {
164 573 50       1418 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 573         1533 $text.=$c->{-value};
168             }
169             }
170 573         1631 $val{$cont} = $text;
171             } else {
172 2322         3896 foreach my $c (@children) {
173 3119         5441 $c->{'-#'} = $i++;
174 3119         4965 my $name = $c->{-xml_name};
175 3119 100       6032 if (!ref($val{$name})) {
176 1785 50       3324 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 3119         3949 my $value;
182 3119 100       6043 if (my $cont = $opts->{Stringify}{$name}) {
183 571         1003 $value = $c->{$cont};
184 571 50       1116 $value='' unless defined $value;
185             } else {
186 2548         3418 $value = $c;
187             }
188 3119 100       7498 if ($opts->{Solitary}{$name}) {
    100          
189 1141 50       2198 if (exists $val{$name}) {
190 0         0 warn "Multiple occurences of the child-element '$name'\n";
191             }
192 1141         2841 $val{$name} = $value
193             } elsif (my $key = $opts->{KeyAttr}{$name}) {
194 1175         2122 my $val = delete $c->{$key};
195 1175         2152 $c->{-name}=$val;
196 1175         3552 $val{$name}{$val} = $value;
197             } else {
198 803         1071 push @{$val{$name}}, $value;
  803         2213  
199             }
200 3119         6771 weaken($c->{-parent} = $obj);
201             }
202 2322         4896 $obj->{'-##'} = $i;
203             }
204 2895 100       9224 if (UNIVERSAL::can($obj,'post_process')) {
205 148         679 $obj->post_process($opts);
206             }
207 2895         11081 return $obj;
208             }
209              
210              
211             1;
212             __END__