BEGIN {
$VERSION='2.05';
}
my $attr_name_re='[^\\\\ \\n\\r\\t{}(),=|]+';
our $SpecialTypes='WNVH';
our %Specials = (sentord => 'W', order => 'N', value => 'V', hide => 'H');
sub new {
my $self = shift;
my $class = ref($self) || $self;
my $new = [];
bless $new, $class;
if (@_==1 and ref($_[0]) and !UNIVERSAL::isa($_[0],'HASH')) {
$new->initialize();
$new->readFrom(@_);
} else {
$new->initialize(@_);
}
return $new;
}
sub create {
my $self = shift;
my $new=$self->new();
$new->readFrom([@_]);
return $new;
}
sub clone {
my ($self) = @_;
return unless ref($self);
return $self->new(
{%{$self->defs()}},
[$self->attributes()],
[@{$self->unparsed()}],
undef,
);
}
sub initialize {
my $self = $_[0];
return unless ref($self);
$self->[0] = ref($_[1]) ? $_[1] : { };
$self->[1] = ref($_[2]) ? $_[2] : [ ];
$self->[2] = ref($_[3]) ? $_[3] : [ ];
$self->[3] = ref($_[4]) ? $_[4] : undef;
return $self;
}
sub addNewAttribute {
my ($self,$type,$color,$name,$list)=@_;
$self->list->[$self->count()]=$name if (!defined($self->defs->{$name}));
if (index($SpecialTypes, $type)+1) {
$self->set_special($type,$name);
}
if ($list) {
$self->defs->{$name}.=" $type=$list";
} else {
$self->defs->{$name}.=" $type";
}
if ($color) {
$self->defs->{$name}.=" $color";
}
}
sub readFrom {
my ($self,$handle,$out) = @_;
return unless ref($self);
my $read = \&Treex::PML::Backend::FS::ReadEscapedLine;
my %result;
my $count=0;
local $_;
while ($_=$read->($handle)) {
s/\r$//o;
if (ref($out)) {
print $out $_;
} else {
push @{$self->unparsed}, $_;
}
if (/^\@([KPOVNWLHE])([A-Z0-9])* (${attr_name_re})(?:\|(.*))?/o) {
if ($1 eq 'E') {
unless (defined $self->special('E')) {
$self->set_special('E',$3);
if (ref($handle) ne 'ARRAY') {
binmode $handle, ':raw:perlio:encoding('.$3.')';
if ($count>0) {
warn "\@E should be on the first line!\n";
}
}
} else {
warn __PACKAGE__.": There should be just one encoding (\@E) and that should occur on the very first line. Ignoring $_!\n";
}
next;
}
if (index($SpecialTypes, $1)+1) {
$self->set_special($1,$3);
}
$self->list->[$count++]=$3 if (!defined($self->defs->{$3}));
if ($4) {
$self->defs->{$3}.=" $1=$4";
} else {
$self->defs->{$3}.=" $1";
}
if ($2) {
$self->defs->{$3}.=" $2";
}
next;
} elsif (/^\r*$/o) {
last;
} else {
return 0;
}
}
return 1;
}
sub toArray {
my ($self) = @_;
return unless ref($self);
my $defs = $self->defs;
my @ad;
my @result;
my $l;
my $vals;
foreach (@{$self->list}) {
@ad=split ' ',$defs->{$_};
while (@ad) {
$l='@';
if ($ad[0]=~/^L=(.*)/) {
$vals=$1;
shift @ad;
$l.="L";
$l.=shift @ad if (@ad and $ad[0]=~/^[A0-3]/);
$l.=" $_|$vals\n";
} else {
$l.=shift @ad if @ad;
$l.=shift @ad if (@ad and $ad[0]=~/^[A0-3]/);
$l.=" $_\n";
}
push @result, $l;
}
}
push @result,"\n";
return @result;
}
sub writeTo {
my ($self,$fileref) = @_;
return unless ref($self);
print $fileref $self->toArray;
return 1;
}
{
my ($sub, $key);
while (($sub,$key)= each %Specials) {
eval "sub $sub { \$_[0]->special('$key'); }";
}
}
sub DESTROY {
my ($self) = @_;
return unless ref($self);
$self->[0]=undef;
$self->[1]=undef;
$self->[2]=undef;
$self=undef;
}
sub isHidden {
my ($self,$node)=@_;
my $hide=$self->special('H');
return unless defined $hide;
my $h;
while ($node and !(($h = $node->get_member($hide)) eq 'hide'
or $h eq 'true'
or $h == 1 )) {
$node=$node->parent;
}
return ($node||undef);
}
sub defs {
my ($self) = @_;
return ref($self) ? $self->[0] : undef;
}
sub list {
my ($self) = @_;
return ref($self) ? $self->[1] : undef;
}
sub unparsed {
my ($self) = @_;
return ref($self) ? $self->[2] : undef;
}
sub renew_specials {
my ($self)=@_;
my $re = " ([$SpecialTypes])";
my %spec;
my $defs = $self->[0];
my ($k,$v);
while (($k,$v)=each %$defs) {
$spec{$1} = $k if $v=~/$re/o;
}
return $self->[3] = \%spec;
}
sub findSpecialDef {
my ($self,$defchar)=@_;
my $defs = $self->defs;
foreach (keys %{$defs}) {
return $_ if (index($defs->{$_}," $defchar")>=0);
}
return undef;
}
sub specials {
my ($self) = @_;
return ($self->[3] || $self->renew_specials());
}
sub attributes {
my ($self) = @_;
return @{$self->list};
}
sub atno {
my ($self,$index) = @_;
return ref($self) ? $self->list->[$index] : undef;
}
sub atdef {
my ($self,$name) = @_;
return ref($self) ? $self->defs->{$name} : undef;
}
sub count {
my ($self) = @_;
return ref($self) ? $
}
sub isList {
my ($self,$attrib)=@_;
return (index($self->defs->{$attrib}," L")>=0) ? 1 : 0;
}
sub listValues {
my ($self,$attrib)=@_;
return unless ref($self);
my $defs = $self->defs;
my ($I,$b,$e);
$b=index($defs->{$attrib}," L=");
if ($b>=0) {
$e=index($defs->{$attrib}," ",$b+1);
if ($e>=0) {
return split /\|/,substr($defs->{$attrib},$b+3,$e-$b-3);
} else {
return split /\|/,substr($defs->{$attrib},$b+3);
}
} else { return (); }
}
sub color {
my ($self,$arg) = @_;
return unless ref($self);
if (index($self->defs->{$arg}," 1")>=0) {
return "Shadow";
} elsif (index($self->defs->{$arg}," 2")>=0) {
return "Hilite";
} elsif (index($self->defs->{$arg}," 3")>=0) {
return "XHilite";
} else {
return "normal";
}
}
sub special {
my ($self,$defchar)=@_;
return ($self->[3]||$self->renew_specials)->{$defchar};
}
sub set_special {
my ($self,$defchar,$value)=@_;
my $spec = ($self->[3]||$self->renew_specials);
$spec->{$defchar}=$value;
return;
}
sub indexOf {
my ($self,$arg)=@_;
return
ref($self) ? Treex::PML::Index($self->list,$arg) : undef;
}
sub exists {
my ($self,$arg)=@_;
return
ref($self) ?
(exists($self->defs->{$arg}) &&
defined($self->defs->{$arg})) : undef;
}
sub make_sentence {
my ($self,$root,$separator)=@_;
return unless ref($self);
$separator=' ' unless defined($separator);
my @nodes=();
my $sentord = $self->sentord || $self->order;
my $value = $self->value;
my $node=$root;
while ($node) {
push @nodes,$node;
$node=$node->following($root);
}
return join ($separator,
map { $_->getAttribute($value) }
sort { $a->getAttribute($sentord) <=> $b->getAttribute($sentord) } @nodes);
}
sub clone_node {
my ($self,$node)=@_;
my $new = ref($node)->new();
if ($node->type) {
foreach my $atr ($node->type->get_normal_fields,'#name') {
if (ref($node->{$atr})) {
$new->{$atr} = Treex::PML::CloneValue($node->{$atr});
} else {
$new->{$atr} = $node->{$atr};
}
}
$new->set_type($node->type);
} else {
foreach (@{$self->list}) {
$new->{$_}=$node->{$_};
}
}
return $new;
}
sub clone_subtree {
my ($self,$node)=@_;
my $nc;
return 0 unless $node;
my $prev_nc=0;
my $nd=$self->clone_node($node);
foreach ($node->children()) {
$nc=$self->clone_subtree($_);
$nc->set_parent($nd);
if ($prev_nc) {
$nc->set_lbrother($prev_nc);
$prev_nc->set_rbrother($nc);
} else {
$nd->set_firstson($nc);
}
$prev_nc=$nc;
}
return $nd;
}
1;