File Coverage

blib/lib/Treex/PML/Schema/Reader.pm
Criterion Covered Total %
statement 20 22 90.9
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 28 30 93.3


line stmt bran cond sub pod time code
1             package Treex::PML::Schema::Reader;
2              
3 1     1   3 use strict;
  1         1  
  1         23  
4 1     1   2 use warnings;
  1         2  
  1         25  
5              
6 1     1   2 use vars qw($VERSION);
  1         1  
  1         37  
7             BEGIN {
8 1     1   12 $VERSION='2.22'; # version template
9             }
10 1     1   3 no warnings 'uninitialized';
  1         1  
  1         24  
11 1     1   3 use Carp;
  1         1  
  1         40  
12              
13 1     1   3 use Scalar::Util qw(weaken blessed);
  1         1  
  1         39  
14 1     1   252 use XML::LibXML::Reader;
  0            
  0            
15              
16             sub new {
17             my ($class,$opts)=@_;
18             my $URL = $opts->{URL};
19             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             if ($opts->{validate}) {
29             my $rng = $opts->{relaxng_schema} || Treex::PML::FindInResources('pml_schema_inline.rng');
30             if (defined $rng) {
31             push @common, (RelaxNG => $rng);
32             } else {
33             warn __PACKAGE__.": Validation requested, but 'pml_schema_inline.rng' was not found in the ResourcePath: ".Treex::PML::ResourcePath()."\n";
34             }
35             }
36             my ($reader,$fh);
37             # print "loading schema $opts->{URL}\n";
38             if ($opts->{string}) {
39             $URL ||= 'string://';
40             $reader = XML::LibXML::Reader->new(string => $opts->{string},
41             @common,
42             URI => $URL,
43             )
44             or die "Error reading string ($URL)";
45             } elsif ($opts->{fh}) {
46             $URL ||= 'fh://';
47             $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             $reader = $opts->{reader};
51             $URL ||= $reader->document->URI;
52             } else {
53             my $file = $opts->{URL};
54             print STDERR "parsing schema $file\n" if $Treex::PML::Debug;
55             $fh = eval { Treex::PML::IO::open_uri($file) };
56             croak "Couldn't open PML schema file '$file'\n".$@ if (!$fh || $@);
57             $reader = XML::LibXML::Reader->new(FD => $fh, @common, URI => $URL )
58             or die "Error reading $file";
59             }
60             return bless [$reader,$opts,$fh], $class;
61             }
62             sub DESTROY {
63             my ($self)=@_;
64             my $fh = $self->file_handle;
65             Treex::PML::IO::close_uri($fh) if $fh;
66             }
67             sub reader {
68             return ref($_[0]) && $_[0][0];
69             }
70             sub options {
71             return ref($_[0]) && $_[0][1];
72             }
73             sub file_handle {
74             return ref($_[0]) && $_[0][2];
75             }
76              
77             sub parse_element {
78             my ($self,$parent)=@_;
79             my $reader = $self->reader;
80             my $opts = $self->options;
81             my (@children,@attrs);
82             my $el_ns = $reader->namespaceURI;
83             my $el_name = $reader->localName;
84             my $has_default_ns = $el_ns eq $opts->{DefaultNs} ? 1 : 0;
85             my $el_ns_name = ($has_default_ns) ? $el_name : '{'.$el_ns.'}'.$el_name;
86             my $prefix = $reader->prefix;
87             my %val = (
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             weaken($val{-parent}) if $val{-parent};
95              
96             if ($reader->moveToFirstAttribute==1) {
97             do {{
98             my $name = $reader->name;
99             push @attrs,$name;
100             $val{$name} = $reader->value;
101             }} while ($reader->moveToNextAttribute);
102             $reader->moveToElement;
103             }
104             my $obj = \%val;
105             {
106             my $class = $opts->{Bless}{$el_ns_name} || $opts->{Bless}{'*'};
107             if (defined $class) {
108             bless $obj,$class;
109             $obj->init($opts) if $obj->can('init');
110             }
111             }
112             my $depth = $reader->depth;
113             my $status;
114             while (($status = $reader->read==1)) {
115             last unless $reader->depth > $depth;
116             my $nodeType = $reader->nodeType;
117             my $chld;
118             my $redo = 0;
119             if ($nodeType == XML_READER_TYPE_ELEMENT) {
120             $chld = $self->parse_element($obj);
121             $redo = 1;
122             } elsif ($nodeType == XML_READER_TYPE_TEXT or
123             $nodeType == XML_READER_TYPE_CDATA) {
124             $chld = bless {
125             -xml_name => '#text',
126             -value => $reader->value,
127             }, 'Treex::PML::Schema::XMLNode';
128             } elsif ($nodeType == XML_READER_TYPE_COMMENT) {
129             $chld = bless {
130             -xml_name => '#comment',
131             -value => $reader->value,
132             }, 'Treex::PML::Schema::XMLNode';
133             } elsif ($nodeType == XML_READER_TYPE_PROCESSING_INSTRUCTION) {
134             $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             next;
143             } else {
144             $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             push @children, $chld if defined $chld;
153             redo if $redo;
154             }
155             if ($status == -1) {
156             croak "XMLReader error in $opts->{URL} near line ".$reader->lineNumber;
157             }
158              
159             my $i=0;
160             my %try_data;
161             if (my $cont = $opts->{TextOnly}{$el_ns_name}) {
162             my $text;
163             foreach my $c (@children) {
164             if ($c->{'-xml_name'} ne '#text') {
165             warn "Ignoring unexpected node ".$c->{'-xml_name'}." in a text-only element $el_ns_name\n";
166             } else {
167             $text.=$c->{-value};
168             }
169             }
170             $val{$cont} = $text;
171             } else {
172             foreach my $c (@children) {
173             $c->{'-#'} = $i++;
174             my $name = $c->{-xml_name};
175             if (!ref($val{$name})) {
176             if (exists $val{$name}) {
177             warn "Collision between an attribute and child-element $name\n";
178             $val{'@'.$name} = delete $val{$name}
179             }
180             }
181             my $value;
182             if (my $cont = $opts->{Stringify}{$name}) {
183             $value = $c->{$cont};
184             $value='' unless defined $value;
185             } else {
186             $value = $c;
187             }
188             if ($opts->{Solitary}{$name}) {
189             if (exists $val{$name}) {
190             warn "Multiple occurences of the child-element '$name'\n";
191             }
192             $val{$name} = $value
193             } elsif (my $key = $opts->{KeyAttr}{$name}) {
194             my $val = delete $c->{$key};
195             $c->{-name}=$val;
196             $val{$name}{$val} = $value;
197             } else {
198             push @{$val{$name}}, $value;
199             }
200             weaken($c->{-parent} = $obj);
201             }
202             $obj->{'-##'} = $i;
203             }
204             if (UNIVERSAL::can($obj,'post_process')) {
205             $obj->post_process($opts);
206             }
207             return $obj;
208             }
209              
210              
211             1;
212             __END__