File Coverage

blib/lib/Treex/PML.pm

Criterion	Covered	Total	%
statement	14	16	87.5
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	20	22	90.9

#
# Revision: $Id: Treex::PML.pm 3044 2007-06-08 17:47:08Z pajas $

# See the bottom of this file for the POD documentation. Search for the
# string '=head'.

# Authors: Petr Pajas, Jan Stepanek
# E-mail: [e-mail]
#
# Description:
# Several Perl Routines to handle files in treebank FS format
# See complete help in POD format at the end of this file

package Treex::PML;

use vars qw(@EXPORT @EXPORT_OK @ISA $VERSION $API_VERSION %COMPATIBLE_API_VERSION
            $FSError $Debug $resourcePath $resourcePathSplit @BACKENDS);
BEGIN {
$VERSION = "2.21";        # change when new functions are added etc
}


use Data::Dumper;
use Scalar::Util qw(weaken blessed);
use Storable qw(dclone);
use Treex::PML::Document;

use Treex::PML::Factory;
use Treex::PML::StandardFactory;
BEGIN { Treex::PML::StandardFactory->make_default() }
use Treex::PML::IO;
use UNIVERSAL::DOES qw(does);

use strict;


use Treex::PML::Node;

use Exporter;
use File::Spec;
use Carp;
use URI;
use URI::file;

BEGIN {

@ISA=qw(Exporter);

$API_VERSION = "2.0";    # change when internal data structures change,
                         # in a way that may prevent old binary dumps to work properly

%COMPATIBLE_API_VERSION = map { $_ => 1 }
  (
    qw( 1.1 1.2 ),
    $API_VERSION
  );

@EXPORT = qw/&ImportBackends/;
@EXPORT_OK = qw/&Next &Prev &Cut &DeleteLeaf $FSError &Index &SetParent &SetLBrother &SetRBrother &SetFirstSon &Paste &Parent &LBrother &RBrother &FirstSon ResourcePaths FindInResources FindInResourcePaths FindDirInResources FindDirInResourcePaths ResolvePath &CloneValue AddResourcePath AddResourcePathAsFirst SetResourcePaths RemoveResourcePath UseBackends AddBackends Backends /;

$Debug=$ENV{TREEX_PML_DEBUG}||0;
*DEBUG = \$Debug;

$resourcePathSplit = ($^O eq "MSWin32") ? ',' : ':';

$FSError=0;

}




ImportBackends('FS'); # load FS
UseBackends('PML'); # default will be PML

sub Root {
  my ($node) = @_;
  return ref($node) && $node->root;
}
sub Parent {
  my ($node) = @_;
  return ref($node) && $node->parent;
}

sub LBrother ($) {
  my ($node) = @_;
  return ref($node) && $node->lbrother;
}

sub RBrother ($) {
  my ($node) = @_;
  return ref($node) && $node->rbrother;
}

sub FirstSon ($) {
  my ($node) = @_;
  return ref($node) && $node->firstson;
}

sub SetParent ($$) {
  my ($node,$parent) = @_;
  return ref($node) && $node->set_parent($parent);
}
sub SetLBrother ($$) {
  my ($node,$brother) = @_;
  return ref($node) && $node->set_lbrother($brother);
}
sub SetRBrother ($$) {
  my ($node,$brother) = @_;
  return ref($node) && $node->set_rbrother($brother);
}
sub SetFirstSon ($$) {
  my ($node,$son) = @_;
  return ref($node) && $node->set_firstson($son);
}

sub Next {
  my ($node,$top) = @_;
  return ref($node) && $node->following($top);
}

sub Prev {
  my ($node,$top) = @_;
  return ref($node) && $node->previous($top);
}

sub Cut ($) {
  my ($node)=@_;
  return ref($node) && $node->cut;
}

sub Paste ($$$) {
  my $node = shift;
  return $node->paste_on(@_);
}

sub PasteAfter ($$) {
  my $node = shift;
  return $node->paste_after(@_);
}

sub PasteBefore ($$) {
  my $node = shift;
  return $node->paste_before(@_);
}

sub _WeakenLinks {
  my ($node)=@_;
  while ($node) {
    $node->_weakenLinks();
    $node = $node->following();
  }
}

sub DeleteTree ($) {
  my ($top)=@_;
  return $top->destroy();
}

sub DeleteLeaf ($) {
  my ($node) = @_;
  return $node->destroy_leaf();
}


sub CloneValue {
  my ($what,$old,$new)=@_;
  if (ref $what) {
    my $val;
    if (defined $old) {
      $new = $old unless defined $new;
      # work around a bug in Data::Dumper:
      if (UNIVERSAL::can('Data::Dumper','init_refaddr_format')) {
        Data::Dumper::init_refaddr_format();
      }
# Sometimes occurs, that $new->[1] is undef. This bug appeared randomly, due to reimplimentation of hash in perl5.18 (http://perldoc.perl.org/perldelta.html#Hash-overhaul.
# In previous versions it did not appear, thanks to hash order "new->[1]" < "new->[0]"
      my $dump=Data::Dumper->new([$what],
        		                                         ['val'])
	 ->Seen({map { (ref($old->[$_])
	                               and defined($new->[$_]) # bugfix
	                              )? (qq{new->[$_]} => $old->[$_]) : () } 0..$#$old})
	 ->Purity(1)->Indent(0)->Dump;
      eval $dump;
      die $@ if $@;
    } else {
#      return Scalar::Util::Clone::clone($what);
      return dclone($what);
#      eval Data::Dumper->new([$what],['val'])->Indent(0)->Purity(1)->Dump;
#      die $@ if $@;
    }
    return $val;
  } else {
    return $what;
  }
}

sub Index ($$) {
  my ($ar,$i) = @_;
  for (my $n=0;$n<=$#$ar;$n++) {
    return $n if ($ar->[$n] eq $i);
  }
  return;
}

sub _is_url {
  return ($_[0] =~ m(^\s*[[:alnum:]]+://)) ? 1 : 0;
}
sub _is_updir {
  my $uri = Treex::PML::IO::make_URI($_[0]);
  return ($uri->path =~  m{(/|^)\.\.($|/)} ? 1 : 0);
}
sub _is_absolute {
  my ($path) = @_;
  return (_is_url($path) or File::Spec->file_name_is_absolute($path));
}

sub FindDirInResources {
  my ($filename)=@_;
  unless (_is_absolute($filename) or _is_updir($filename)) {
    for my $dir (ResourcePaths()) {
      my $f = File::Spec->catfile($dir,$filename);
      return $f if -d $f;
    }
  }
  return $filename;
}
BEGIN{
*FindDirInResourcePaths = \&FindDirInResources;
}

sub FindInResources {
  my ($filename,$opts)=@_;
  my $all = ref($opts) && $opts->{all};
  my @matches;
  unless (_is_absolute($filename) or _is_updir($filename)) {
    for my $dir (ResourcePaths()) {
      my $f = File::Spec->catfile($dir,$filename);
      if (-f $f) {
	return $f unless $all;
	push @matches,$f;
      }
    }
  }
  return ($all or (ref($opts) && $opts->{strict})) ? @matches : $filename;
}

BEGIN {
*FindInResourcePaths = \&FindInResources;
}
sub ResourcePaths {
  return unless defined $resourcePath;
  return wantarray ? split(/\Q${resourcePathSplit}\E/, $resourcePath) : $resourcePath;
}
BEGIN { *ResourcePath = \&ResourcePaths; } # old name

sub AddResourcePath {
  if (defined($resourcePath) and length($resourcePath)) {
    $resourcePath.=$resourcePathSplit;
  }
  $resourcePath .= join $resourcePathSplit,@_;
}

sub AddResourcePathAsFirst {
  $resourcePath = join($resourcePathSplit,@_) . (($resourcePath ne q{}) ? ($resourcePathSplit.$resourcePath) : q{});
}

sub RemoveResourcePath {
  my %remove;
  @remove{@_} = ();
  return unless defined $resourcePath;
  $resourcePath = join $resourcePathSplit, grep { !exists($remove{$_}) }
    split /\Q$resourcePathSplit\E/, $resourcePath;
}

sub SetResourcePaths {
  $resourcePath=join $resourcePathSplit,@_;
}

sub _is_local {
  my ($url) = @_;
  return (((blessed($url) && $url->isa('URI') && (($url->scheme||'file') eq 'file')) or $url =~ m{^file:/}) ? 1 : 0);
}
sub _strip_file_prefix {
  my $url = $_[0]; # ARGUMENT WILL GET MODIFIED
  if (_is_local($url)) {
      $_[0] = Treex::PML::IO::get_filename($url);
      return 1;
  } else {
      return 0;
  }
}

sub ResolvePath ($$;$) {
  my ($base, $href,$use_resources)=@_;

  my $rel_uri = Treex::PML::IO::make_URI($href);
  my $base_uri = Treex::PML::IO::make_abs_URI($base);
  print STDERR "ResolvePath: rel='$rel_uri', base='$base_uri'\n" if $Treex::PML::Debug;
  my $abs_uri = $rel_uri->abs($base_uri);

  if (_is_absolute($rel_uri)) {
    return $rel_uri;
  } elsif (_is_updir($rel_uri)) {
    return _is_url($base) ? $abs_uri : Treex::PML::IO::get_filename($abs_uri);
  } else {
    my $abs_f = Treex::PML::IO::get_filename($abs_uri);
    my $rel_f = Treex::PML::IO::get_filename($rel_uri);
    if (_is_local($base_uri)) {
      if (-f $abs_f) {
	print STDERR "\t=> (LocalURL-relative) result='$abs_f'\n" if $Treex::PML::Debug;
	return _is_url($base) ? $abs_uri : $abs_f;
      } elsif ( not _is_url($base) ) { # base was a filename: try path relative to cwd
	print STDERR "\t=> (cwd-relative) result='$rel_f'\n" if $Treex::PML::Debug;
	return $rel_f if -f $rel_f;
      }
    }
    if ($use_resources) {
      my ($res) = FindInResources($rel_f,{strict=>1});
      if ($res) {
	print STDERR "\t=> (resources) result='$res'\n" if $Treex::PML::Debug;
	return $res;
      }
    }
    print STDERR "\t=> (relative) result='$abs_uri'\n" if $Treex::PML::Debug;
# The following line has been changed. The resources are handled
# lazily, i.e. relative URL is returned on not found files to be
# searched in resources later. Original line:
#   return _is_url($base) ? $abs_uri : $abs_f;
    return _is_local($base) ?  $rel_uri : $abs_uri;
  }
}

sub ImportBackends {
  my @backends=();
  foreach my $backend (@_) {
    print STDERR "LOADING $backend\n" if $Treex::PML::Debug;
    my $b;
    for my $try (_BackendCandidates($backend)) {
      my $file = $try.'.pm';
      $file=~s{::}{/}g;
      if (eval { require $file; } or $::INC{$file}) {
	$b=$backend;
	last;
      }
    }
    if ($b) {
      push @backends,$b;
    } else {
      warn $@ if $@;
      warn "FAILED TO LOAD $backend\n";
    }
  }
  return @backends;
}

sub UseBackends {
  @BACKENDS = ImportBackends(@_);
  return wantarray ? @BACKENDS : ((@_==@BACKENDS) ? 1 : 0);
}

sub Backends {
  return @BACKENDS;
}

sub AddBackends {
  my %have;
  @have{ @BACKENDS } = ();
  my @new = grep !exists($have{$_}), @_;
  my @imported = ImportBackends(@new);
  push @BACKENDS, @imported;
  $have{ @BACKENDS } = ();
  return wantarray ? (grep exists($have{$_}), @_) : ((@new==@imported) ? 1 : 0);
}

sub _BackendCandidates {
  my ($backend)=@_;
  return (
    ($backend=~/:/ ? ($backend) : ()),
    ($backend=~/^([^:]+)Backend$/ ? ('Treex::PML::Backend::'.$1) : ()),
    ($backend=~/^Treex::PML::Backend::/ ? () : 'Treex::PML::Backend::'.$backend),
    ($backend=~/:/ ? () : ($backend)),
   );
}

sub BackendCanRead {
  my ($backend)=@_;
  my $b;
  for my $try (_BackendCandidates($backend)) {
    if (UNIVERSAL::can($try,'open_backend')) {
      $b = $try;
      last;
    }
  }
  return $b if ($b and UNIVERSAL::can($b,'test') and UNIVERSAL::can($b,'read'));
  return;
}

sub BackendCanWrite {
  my ($backend)=@_;
  my $b;
  for my $try (_BackendCandidates($backend)) {
    if (UNIVERSAL::can($try,'open_backend')) {
      $b = $try;
      last;
    }
  }
  return $b if ($b and UNIVERSAL::can($b,'write'));
  return;
}

1;

__END__