File Coverage

blib/lib/Treex/PML/Backend/PML.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             package Treex::PML::Backend::PML;
2              
3 1     1   934 use Treex::PML;
  0            
  0            
4             use Treex::PML::IO qw(close_backend);
5             use strict;
6             use warnings;
7             use File::ShareDir;
8             use File::Spec;
9              
10             use vars qw($VERSION);
11             BEGIN {
12             $VERSION='2.21'; # version template
13             }
14              
15             use Treex::PML::Instance qw( :all :diagnostics $DEBUG );
16              
17             use constant EMPTY => q{};
18              
19             use Carp;
20              
21             use vars qw($config $config_file $allow_no_trees $config_inc_file $TRANSFORM @EXPORT_OK);
22              
23             use Exporter qw(import);
24              
25             BEGIN {
26             $TRANSFORM=0;
27             @EXPORT_OK = qw(open_backend close_backend test read write);
28             $config = undef;
29             $config_file = 'pmlbackend_conf.xml';
30             $config_inc_file = 'pmlbackend_conf.inc';
31             $allow_no_trees = 0;
32             }
33              
34             sub configure {
35             my @resource_path = Treex::PML::ResourcePaths();
36             my $ret = eval { _configure() };
37             my $err = $@;
38             Treex::PML::SetResourcePaths(@resource_path);
39             die $err if ($err);
40             $config = $ret;
41             return $ret;
42             }
43              
44             sub _configure {
45             my $cfg;
46             my $schema_dir = eval { File::ShareDir::module_dir('Treex::PML') };
47             unless (defined($schema_dir) and length($schema_dir) and -f File::Spec->catfile($schema_dir,'pmlbackend_conf_schema.xml')) {
48             $schema_dir = Treex::PML::IO::CallerDir(File::Spec->catfile(qw(.. share)));
49             }
50             Treex::PML::AddResourcePath($schema_dir) if defined($schema_dir) and length($schema_dir);
51             my $file = Treex::PML::FindInResources($config_file,{strict=>1});
52             if ($file and -f $file) {
53             _debug("config file: $file");
54             $cfg = Treex::PML::Instance->load({filename => $file});
55             } else {
56             _debug("using empty pmlbackend_conf.xml file");
57             $cfg = Treex::PML::Instance->load({string=><<'_CONFIG_',filename => $file});
58            
59            
60            
61            
62            
63             _CONFIG_
64             }
65             if ($cfg) {
66             my @config_files = Treex::PML::FindInResources($config_inc_file,{all=>1});
67             my $T = $cfg->get_root->{transform_map} ||= Treex::PML::Factory->createSeq();
68             for my $file (reverse @config_files) {
69             _debug("config include file: $file");
70             eval {
71             my $c = Treex::PML::Instance->load({filename => $file});
72             # merge
73             my $t = $c->get_root->{transform_map};
74             if ($t) {
75             for my $transform (reverse $t->elements) {
76             my $copy = Treex::PML::CloneValue($transform);
77             $T->unshift_element_obj($copy);
78             if (ref($copy->value) and $copy->value->{id}) {
79             $cfg->hash_id($copy->value->{id}, $copy->value, 1);
80             }
81             }
82             }
83             };
84             warn $@ if $@;
85             }
86             }
87             return $cfg;
88             }
89              
90              
91             ###################
92              
93             sub open_backend {
94             my ($filename, $mode, $encoding)=@_;
95             my $fh = Treex::PML::IO::open_backend($filename,$mode) # discard encoding
96             || die "Cannot open $filename for ".($mode eq 'w' ? 'writing' : 'reading').": $!";
97             return $fh;
98             }
99              
100             sub read ($$) {
101             my ($input, $fsfile)=@_;
102             return unless ref($fsfile);
103              
104             my $ctxt = Treex::PML::Instance->load({fh => $input, filename => $fsfile->filename, config => $config });
105             $ctxt->convert_to_fsfile( $fsfile );
106             my $status = $ctxt->get_status;
107             if ($status and
108             !($allow_no_trees or defined($ctxt->get_trees))) {
109             _die("No trees found in the Treex::PML::Instance!");
110             }
111             return $status
112             }
113              
114              
115             sub write {
116             my ($fh,$fsfile)=@_;
117             my $ctxt = Treex::PML::Instance->convert_from_fsfile( $fsfile );
118             $ctxt->save({ fh => $fh, config => $config });
119             }
120              
121              
122             sub test {
123             my ($f,$encoding)=@_;
124             if (ref($f)) {
125             local $_;
126             if ($TRANSFORM and $config) {
127             1 while ($_=$f->getline() and !/\S/);
128             # see <, assume XML
129             return 1 if (defined and /^\s*
130             } else {
131             # only accept PML instances
132             # xmlns:...="..pml-namespace.." must occur in the first tag (on one line)
133              
134             # FIXME: the following code will fail for UTF-16 and UTF-32;
135             # proper fix would be to use XML::LibXML::Reader to read the
136             # first tag (performance impact on processing many files past
137             # PML backend to be measured). Another way to fix for UTF-16 is
138             # to check for UTF-16 BOM (both BE and LE) and decode
139             # accordingly if present; UTF-32 is rarely used and probably not
140             # worth fixing.
141             my ($in_first_tag,$in_pi,$in_comment, $past_BOM);
142             while ($_=$f->getline()) {
143             unless ($past_BOM) {
144             # ignore UTF-8 BOM
145             s{^\x{ef}\x{bb}\x{bf}}{};
146             $past_BOM = 1;
147             }
148             next if !/\S/; # whitespace
149             if ($in_first_tag) {
150             last if />/;
151             return 1 if m{\bxmlns(?::[[:alnum:]]+)?=([\'\"])http://ufal.mff.cuni.cz/pdt/pml/\1};
152             next;
153             } elsif ($in_pi) {
154             next unless s/^.*?\?>//;
155             $in_pi=0;
156             } elsif ($in_comment) {
157             next unless s/^.*?\-->//;
158             $in_comment=0;
159             }
160             s/^(?:\s*<\?.*?\?>|\s*)*\s*//;
161             if (/<\?/) {
162             $in_pi=1;
163             } elsif (/