File Coverage

blib/lib/Treex/PML/Backend/PML.pm

Criterion	Covered	Total	%
statement	99	128	77.3
branch	25	60	41.6
condition	12	47	25.5
subroutine	20	20	100.0
pod	0	5	0.0
total	156	260	60.0

package Treex::PML::Backend::PML;

use Treex::PML;
use Treex::PML::IO qw(close_backend);
use strict;
use warnings;
use File::ShareDir;
use File::Spec;

use vars qw($VERSION);
BEGIN {
  $VERSION='2.24'; # version template
}

use Treex::PML::Instance qw( :all :diagnostics $DEBUG );

use constant EMPTY => q{};

use Carp;

use vars qw($config $config_file $allow_no_trees $config_inc_file $TRANSFORM @EXPORT_OK);

use Exporter qw(import);

BEGIN {
  $TRANSFORM=0;
  @EXPORT_OK = qw(open_backend close_backend test read write);
  $config = undef;
  $config_file = 'pmlbackend_conf.xml';
  $config_inc_file = 'pmlbackend_conf.inc';
  $allow_no_trees = 0;
}

sub configure {
  my @resource_path = Treex::PML::ResourcePaths();
  my $ret = eval { _configure() };
  my $err = $@;
  Treex::PML::SetResourcePaths(@resource_path);
  die $err if ($err);
  $config = $ret;
  return $ret;
}

sub _configure {
  my $cfg;
  my $schema_dir = eval { File::ShareDir::module_dir('Treex::PML') };
  unless (defined($schema_dir) and length($schema_dir) and -f File::Spec->catfile($schema_dir,'pmlbackend_conf_schema.xml')) {
    $schema_dir = Treex::PML::IO::CallerDir(File::Spec->catfile(qw(.. share)));
  }
  Treex::PML::AddResourcePath($schema_dir) if defined($schema_dir) and length($schema_dir);
  my $file = Treex::PML::FindInResources($config_file,{strict=>1});
  if ($file and -f $file) {
    _debug("config file: $file");
    $cfg = Treex::PML::Instance->load({filename => $file});
  } else {
    _debug("using empty pmlbackend_conf.xml file");
    $cfg = Treex::PML::Instance->load({string=><<'_CONFIG_',filename => $file});





_CONFIG_
  }
  if ($cfg) {
    my @config_files = Treex::PML::FindInResources($config_inc_file,{all=>1});
    my $T = $cfg->get_root->{transform_map} ||= Treex::PML::Factory->createSeq();
    for my $file (reverse @config_files) {
      _debug("config include file: $file");
      eval {
	my $c = Treex::PML::Instance->load({filename => $file});
	# merge
	my $t = $c->get_root->{transform_map};
	if ($t) {
	  for my $transform (reverse $t->elements) {
	    my $copy = Treex::PML::CloneValue($transform);
	    $T->unshift_element_obj($copy);
	    if (ref($copy->value) and $copy->value->{id}) {
	      $cfg->hash_id($copy->value->{id}, $copy->value, 1);
	    }
	  }
	}
      };
      warn $@ if $@;
    }
  }
  return $cfg;
}


###################

sub open_backend {
  my ($filename, $mode, $encoding)=@_;
  my $fh = Treex::PML::IO::open_backend($filename,$mode) # discard encoding
    || die "Cannot open $filename for ".($mode eq 'w' ? 'writing' : 'reading').": $!";
  return $fh;
}

sub read ($$) {
  my ($input, $fsfile)=@_;
  return unless ref($fsfile);

  my $ctxt = Treex::PML::Instance->load({fh => $input, filename => $fsfile->filename, config => $config });
  $ctxt->convert_to_fsfile( $fsfile );
  my $status = $ctxt->get_status;
  if ($status and
      !($allow_no_trees or defined($ctxt->get_trees))) {
    _die("No trees found in the Treex::PML::Instance!");
  }
  return $status
}


sub write {
  my ($fh,$fsfile)=@_;
  my $ctxt = Treex::PML::Instance->convert_from_fsfile( $fsfile );
  $ctxt->save({ fh => $fh, config => $config });
}


sub test {
  my ($f,$encoding)=@_;
  if (ref($f)) {
    local $_;
    if ($TRANSFORM and $config) {
      1 while ($_=$f->getline() and !/\S/);
      # see <, assume XML
      return 1 if (defined and /^\s*
    } else {
      # only accept PML instances
      # xmlns:...="..pml-namespace.." must occur in the first tag (on one line)

      # FIXME: the following code will fail for UTF-16 and UTF-32;
      # proper fix would be to use XML::LibXML::Reader to read the
      # first tag (performance impact on processing many files past
      # PML backend to be measured). Another way to fix for UTF-16 is
      # to check for UTF-16 BOM (both BE and LE) and decode
      # accordingly if present; UTF-32 is rarely used and probably not
      # worth fixing.
      my ($in_first_tag,$in_pi,$in_comment, $past_BOM);
      while ($_=$f->getline()) {
	unless ($past_BOM) {
	  # ignore UTF-8 BOM
	  s{^\x{ef}\x{bb}\x{bf}}{};
	  $past_BOM = 1;
	}
	next if !/\S/;  # whitespace
	if ($in_first_tag) {
	  last if />/;
	  return 1 if m{\bxmlns(?::[[:alnum:]]+)?=([\'\"])http://ufal.mff.cuni.cz/pdt/pml/\1};
	  next;
	} elsif ($in_pi) {
	  next unless s/^.*?\?>//;
	  $in_pi=0;
	} elsif ($in_comment) {
	  next unless s/^.*?\-->//;
	  $in_comment=0;
	}
	s/^(?:\s*<\?.*?\?>|\s*)*\s*//;
	if (/<\?/) {
	  $in_pi=1;
	} elsif (/