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 6     6   36 use strict;
  6         11  
  6         154  
4 6     6   27 use warnings;
  6         12  
  6         137  
5              
6 6     6   26 use vars qw($VERSION);
  6         17  
  6         243  
7             BEGIN {
8 6     6   115 $VERSION='2.24'; # version template
9             }
10 6     6   30 no warnings 'uninitialized';
  6         10  
  6         187  
11 6     6   33 use Carp;
  6         10  
  6         329  
12              
13 6     6   40 use Scalar::Util qw(weaken blessed);
  6         19  
  6         314  
14 6     6   2562 use XML::LibXML::Reader;
  6         224199  
  6         7916  
15              
16             sub new {
17 63     63 0 186 my ($class,$opts)=@_;
18 63         167 my $URL = $opts->{URL};
19 63         341 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 63 50       179 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 63         150 my ($reader,$fh);
37             # print "loading schema $opts->{URL}\n";
38 63 50 33     640 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 63         156 my $file = $opts->{URL};
54 63 50       180 print STDERR "parsing schema $file\n" if $Treex::PML::Debug;
55 63         141 $fh = eval { Treex::PML::IO::open_uri($file) };
  63         257  
56 63 50 33     446 croak "Couldn't open PML schema file '$file'\n".$@ if (!$fh || $@);
57 63 50       543 $reader = XML::LibXML::Reader->new(FD => $fh, @common, URI => $URL )
58             or die "Error reading $file";
59             }
60 63         12064 return bless [$reader,$opts,$fh], $class;
61             }
62             sub DESTROY {
63 63     63   154 my ($self)=@_;
64 63         192 my $fh = $self->file_handle;
65 63 50       375 Treex::PML::IO::close_uri($fh) if $fh;
66             }
67             sub reader {
68 2807   33 2807 0 7707 return ref($_[0]) && $_[0][0];
69             }
70             sub options {
71 2744   33 2744 0 5903 return ref($_[0]) && $_[0][1];
72             }
73             sub file_handle {
74 63   33 63 0 322 return ref($_[0]) && $_[0][2];
75             }
76              
77             sub parse_element {
78 2744     2744 0 4629 my ($self,$parent)=@_;
79 2744         4594 my $reader = $self->reader;
80 2744         4882 my $opts = $self->options;
81 2744         3950 my (@children,@attrs);
82 2744         7435 my $el_ns = $reader->namespaceURI;
83 2744         5977 my $el_name = $reader->localName;
84 2744 50       5809 my $has_default_ns = $el_ns eq $opts->{DefaultNs} ? 1 : 0;
85 2744 50       4588 my $el_ns_name = ($has_default_ns) ? $el_name : '{'.$el_ns.'}'.$el_name;
86 2744         4518 my $prefix = $reader->prefix;
87 2744 50 33     11554 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 2744 100       9291 weaken($val{-parent}) if $val{-parent};
95              
96 2744 100       5982 if ($reader->moveToFirstAttribute==1) {
97 1907         2270 do {{
98 2938         3805 my $name = $reader->name;
  2938         6259  
99 2938         5121 push @attrs,$name;
100 2938         10970 $val{$name} = $reader->value;
101             }} while ($reader->moveToNextAttribute);
102 1907         3569 $reader->moveToElement;
103             }
104 2744         4078 my $obj = \%val;
105             {
106 2744   66     3811 my $class = $opts->{Bless}{$el_ns_name} || $opts->{Bless}{'*'};
  2744         7490  
107 2744 50       4829 if (defined $class) {
108 2744         5927 bless $obj,$class;
109 2744 100       10644 $obj->init($opts) if $obj->can('init');
110             }
111             }
112 2744         5205 my $depth = $reader->depth;
113 2744         3511 my $status;
114 2744         12098 while (($status = $reader->read==1)) {
115 8022 100       18111 last unless $reader->depth > $depth;
116 5278         8900 my $nodeType = $reader->nodeType;
117 5278         6333 my $chld;
118 5278         6395 my $redo = 0;
119 5278 100 66     14960 if ($nodeType == XML_READER_TYPE_ELEMENT) {
    100 33        
    100 33        
    50          
    50          
120 2681         5083 $chld = $self->parse_element($obj);
121 2681         3910 $redo = 1;
122             } elsif ($nodeType == XML_READER_TYPE_TEXT or
123             $nodeType == XML_READER_TYPE_CDATA) {
124 553         2169 $chld = bless {
125             -xml_name => '#text',
126             -value => $reader->value,
127             }, 'Treex::PML::Schema::XMLNode';
128             } elsif ($nodeType == XML_READER_TYPE_COMMENT) {
129 224         911 $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 1820         8725 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 3458 50       7050 push @children, $chld if defined $chld;
153 3458 100       7554 redo if $redo;
154             }
155 2744 50       4768 if ($status == -1) {
156 0         0 croak "XMLReader error in $opts->{URL} near line ".$reader->lineNumber;
157             }
158              
159 2744         3394 my $i=0;
160 2744         3325 my %try_data;
161 2744 100       6172 if (my $cont = $opts->{TextOnly}{$el_ns_name}) {
162 553         734 my $text;
163 553         1242 foreach my $c (@children) {
164 553 50       1056 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 553         1214 $text.=$c->{-value};
168             }
169             }
170 553         1107 $val{$cont} = $text;
171             } else {
172 2191         3676 foreach my $c (@children) {
173 2905         5103 $c->{'-#'} = $i++;
174 2905         4181 my $name = $c->{-xml_name};
175 2905 100       5978 if (!ref($val{$name})) {
176 1680 50       3040 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 2905         3647 my $value;
182 2905 100       5596 if (my $cont = $opts->{Stringify}{$name}) {
183 551         882 $value = $c->{$cont};
184 551 50       1003 $value='' unless defined $value;
185             } else {
186 2354         3179 $value = $c;
187             }
188 2905 100       6467 if ($opts->{Solitary}{$name}) {
    100          
189 1086 50       2075 if (exists $val{$name}) {
190 0         0 warn "Multiple occurences of the child-element '$name'\n";
191             }
192 1086         2222 $val{$name} = $value
193             } elsif (my $key = $opts->{KeyAttr}{$name}) {
194 1099         1787 my $val = delete $c->{$key};
195 1099         1973 $c->{-name}=$val;
196 1099         3086 $val{$name}{$val} = $value;
197             } else {
198 720         914 push @{$val{$name}}, $value;
  720         1487  
199             }
200 2905         7043 weaken($c->{-parent} = $obj);
201             }
202 2191         3596 $obj->{'-##'} = $i;
203             }
204 2744 100       7483 if (UNIVERSAL::can($obj,'post_process')) {
205 141         533 $obj->post_process($opts);
206             }
207 2744         8951 return $obj;
208             }
209              
210              
211             1;
212             __END__