File Coverage

blib/lib/Treex/PML/Schema/XMLNode.pm
Criterion Covered Total %
statement 22 124 17.7
branch 0 62 0.0
condition 0 46 0.0
subroutine 8 17 47.0
pod 2 7 28.5
total 32 256 12.5


line stmt bran cond sub pod time code
1             package Treex::PML::Schema::XMLNode;
2              
3 1     1   3 use strict;
  1         0  
  1         21  
4 1     1   3 use warnings;
  1         0  
  1         19  
5              
6 1     1   3 use vars qw($VERSION);
  1         1  
  1         35  
7             BEGIN {
8 1     1   15 $VERSION='2.21'; # version template
9             }
10 1     1   2 no warnings 'uninitialized';
  1         1  
  1         24  
11 1     1   3 use Carp;
  1         1  
  1         39  
12 1     1   3 use Scalar::Util qw(weaken isweak);
  1         1  
  1         35  
13              
14 1     1   3 use UNIVERSAL::DOES;
  1         1  
  1         1108  
15              
16             sub copy_decl {
17 0     0 1   my ($self,$t)=@_;
18 0           my $copy;
19 0 0         if (ref $t->{-schema}) {
20 0           $copy = Treex::PML::CloneValue($t,[$t->{-parent},$t->{-schema}], [$self,$self->{-schema}]);
21             } else {
22 0           $copy = Treex::PML::CloneValue($t,[$t->{-parent}], [$self]);
23             }
24 0 0         if (exists $self->{'-##'}) {
25 0           $copy->{'-#'}=$self->{'-##'}++;
26             }
27             # we must do this here, otherwise any operation
28             # that rewrites this value will create an unaccessible crircular reference
29             Treex::PML::Schema::_traverse_data(
30             $copy => sub {
31 0     0     my ($val,$is_hash) = @_;
32 0 0 0       weaken($val->{-parent}) if ref($val->{-parent}) and not isweak($val->{-parent});
33 0 0 0       weaken($val->{-schema}) if ref($val->{-schema}) and not isweak($val->{-schema});
34             },
35             {
36 0           $self->{-schema}=>1, $self=> 1 # do not recurse into these
37             },
38             1, # only hashes
39             );
40 0           return $copy;
41             }
42              
43             sub serialize_attributes {
44 0     0 0   my ($self,$opts)=@_;
45 0   0       my $attributes = $self->{-attributes}||[];
46 0           my @ret;
47 0           for my $attr (@$attributes) {
48 0 0         next if $attr=~/^xmlns/;
49 0           my $value = $self->{$attr};
50 0 0 0       if (!defined($value) and $attr eq 'name') { # FIXME: THIS IS A HACK
51 0           $value = $self->{'-'.$attr};
52             }
53 0 0         if (defined $value) {
54 0           push @ret, $attr, $value;
55             }
56             }
57 0           return \@ret;
58             }
59              
60       0 0   sub serialize_exclude_keys {}
61             sub serialize_get_children {
62 0     0 0   my ($self,$opts)=@_;
63 0           my %exclude;
64             @exclude{
65 0 0         @{$self->{-attributes}||[]},
  0            
66             $self->serialize_exclude_keys($opts)
67             }=();
68             my @children = map {
69 0           my $name = $_;
70 0           my $val = $self->{$_};
71 0           (ref($val) eq 'HASH') ? ( map { [$name,$_] } grep { UNIVERSAL::DOES::does($_,'Treex::PML::Schema::XMLNode') } values(%{$val})) :
  0            
  0            
72 0 0 0       (ref($val) eq 'ARRAY') ? ( map { [$name,$_] } grep { UNIVERSAL::DOES::does($_,'Treex::PML::Schema::XMLNode') } @{$val}) :
  0 0          
  0 0          
  0            
73             (UNIVERSAL::DOES::does($val,'Treex::PML::Schema::XMLNode') or !ref($val)) ? [$name,$val] : ()
74 0   0       } grep {!/^[-@]/ and !exists($exclude{$_})} keys %$self;
  0            
75             return (
76 0           (grep { !ref($_->[1]) } @children),
77 0           sort { $a->[1]{'-#'} <=> $b->[1]{'-#'} } grep { ref($_->[1]) } @children
  0            
  0            
78             )
79             }
80             sub serialize_children {
81 0     0 0   my ($self,$opts,$children)=@_;
82 0   0       my $writer = $opts->{writer} || croak __PACKAGE__."->serialize: missing required option 'writer'!\n";
83 0           my $ns = $opts->{DefaultNs};
84 0   0       $children ||= [$self->serialize_get_children($opts)];
85 0           for my $child (@$children) {
86 0           my ($key,$value) = @$child;
87 0 0         if (UNIVERSAL::DOES::does($value,'Treex::PML::Schema::XMLNode')) {
88 0           $value->serialize($opts);
89             } else {
90 0           my $tag = [$ns,$key];
91 0 0         $writer->startTag($tag) if defined $key;
92 0           $writer->characters($value);
93 0 0         $writer->endTag($tag) if defined $key;
94             }
95             }
96             }
97             sub serialize {
98 0     0 0   my ($self,$opts)=@_;
99 0   0       my $writer = $opts->{writer} || croak __PACKAGE__."->serialize: missing required option 'writer'!\n";
100 0           my $xml_name = $self->{-xml_name};
101 0 0 0       if ($xml_name =~/^#/) {
    0          
102 0 0         if ($xml_name =~/^#text/) {
    0          
    0          
    0          
103 0           $writer->characters($self->{-value});
104             } elsif ($xml_name =~/^#comment/) {
105 0           my $value = $self->{-value};
106 0           $value=~s/^ | $//g; # remove a leading and trailing space - XML::Writer addes them
107 0           $writer->comment($value);
108             } elsif ($xml_name =~/^#processing-instruction/) {
109 0           $writer->pi($self->{-name}, $self->{-value});
110             } elsif ($xml_name =~/^#other/) {
111 0           $writer->raw($self->{-xml});
112             } else {
113             # ignoring
114             }
115             } elsif ($xml_name=~/^{(.*)}(.*)$/ or $xml_name=~/^()([^#].*)$/) {
116 0           my ($ns,$name)=($1,$2);
117 0   0       my $attrs = $self->serialize_attributes($opts) || [];
118 0   0       my $prefix = $self->{-xml_prefix} || '';
119 0   0       $ns ||= $opts->{DefaultNs};
120 0 0         if (($ns ne $opts->{DefaultNs})) {
121 0           $writer->addPrefix($ns => $prefix);
122             }
123 0           $writer->addPrefix($ns => $prefix);
124             {
125 0           my @children = $self->serialize_get_children($opts);
  0            
126 0 0         if (@children) {
127 0           $writer->startTag([$ns,$name], @$attrs);
128 0           $self->serialize_children($opts,\@children);
129 0           $writer->endTag([$ns,$name]);
130             } else {
131 0           $writer->emptyTag([$ns,$name], @$attrs);
132             }
133             }
134             }
135             }
136              
137             sub write {
138 0     0 1   my ($self,$opts)=@_;
139 0           my $fh;
140             my $have_backup;
141 0           my $filename = $opts->{filename};
142 0 0 0       if (!defined($opts->{fh}) and
      0        
143             !defined($opts->{string}) and
144             defined($filename)) {
145 0 0         unless ($opts->{no_backups}) {
146 0 0         eval { Treex::PML::IO::rename_uri($filename,$filename."~"); $have_backup=1; } || carp($@);
  0            
  0            
147             }
148 0   0       $fh = Treex::PML::IO::open_backend($filename,'w')
149             || die "Cannot open $filename for writing: $!";
150 0           binmode $fh;
151             }
152 0           eval {
153             my $writer = XML::Writer->new(
154             OUTPUT => ($opts->{fh} || $opts->{string} || $fh ),
155             DATA_MODE => $opts->{no_indent} ? 0 : 1,
156 0 0 0       DATA_INDENT => $opts->{no_indent} ? 0 : 1,
    0          
157             NAMESPACES => 1,
158             PREFIX_MAP => {
159             (Treex::PML::Schema->PML_SCHEMA_NS) => '',
160             });
161 0           $self->serialize({
162             writer => $writer,
163             DefaultNs => Treex::PML::Schema->PML_SCHEMA_NS,
164             });
165 0           $writer->end();
166             };
167 0 0         if ($@) {
168 0           my $err=$@;
169 0 0         $have_backup && eval { Treex::PML::IO::rename_uri($filename."~",$filename) };
  0            
170 0 0         $err.=$@ if $@;
171 0           carp("Error while saving schema: $err\n");
172             }
173 0 0         Treex::PML::IO::close_backend($fh) if $fh;
174             }
175              
176             sub DESTROY {
177 0     0     my ($self)=@_;
178 0           %$self=(); # this should not be needed, but
179             # without it, perl 5.10 leaks on weakened
180             # structures, try:
181             # Scalar::Util::weaken({}) while 1
182              
183             }
184              
185              
186             1;
187             __END__