package Lingua::Treebank::SimTreeML;

use strict;
use warnings;

require Exporter;

use vars qw($c %v $q @dtcontext %dtcontextcount @attributes );

#our @EXPORT=qw(&downtr &dtstring &dturl &inctxt &ctxt &mkdtskel &mkdtskel_fromDTD &mkdtdskel &MMAPON  &pathdturl @dtcontext %dtcontextcount @attributes &pathdt &pathdtstring );

#our $VERSION = '0.42';

our @ISA = qw(Exporter);

our @EXPORT = qw( &downTr $c $q %v @attributes &toxml &xmltree
                  &compileTB &getmeta &father &adam &gfather &ggfather);

our $VERSION = '0.01';

use Data::Dumper;
$Data::Dumper::Indent=1;
$Data::Dumper::Terse=1;
use DB_File;
use Fcntl;
use XML::Parser;

my (%db1);          # perl dbfile:  sentence-id -> perlTree
my %o;              # options
my $fsfile;         # sentences.txt:  sentence -> sentence-id

sub import {
  my $class = shift;
  %o = (dir => ".", id => "fs");
  %o = (%o, @_);
  $class->export_to_level(1, undef, @EXPORT);
  die("cant find $o{dir}\n") unless -d $o{dir};
  tie %db1,'DB_File', "$o{dir}/$o{id}-perl.db", O_CREAT|O_RDWR, 0640, $DB_BTREE
or warn $!;
  $fsfile="$o{dir}/$o{id}.idx";
}

sub compileTB{
  my $fs = shift;
  my $at = {};
  my $inputenc=undef;
  %o = (%o, @_);
  mkdir($o{dir});
  die("Can't find '$o{dir}'\n") unless -d $o{dir};
  my %dbXML;
  tie %dbXML, 'DB_File', "$o{dir}/$o{id}-perl.db", O_TRUNC|O_CREAT|O_RDWR, 
        0640,$DB_BTREE or die $!;
  open IDX, ">$o{dir}/$o{id}.idx" or die("Can't create $o{dir}/$o{id}.idx\n");
  open XML, $fs or die("Can't open $fs\n");

  my %h = (
     #-inputenc => "iso-8859-1",
     #-outputenc => "iso-8859-1",
           -type    => { tree => "SEQ",
                         extract => "THE_CHILD",},

           source   => sub { "" },
           punct    => sub { "$v{ort}/$v{ort}" },
           t        => sub { $at->{_t}{$v{cat}}++;
                             $v{lemma} ?  "$c/$v{lemma}" : "$c/$c" },
           tree     => sub { $at->{_nt}{$v{cat}}++; $c },
           -default => sub { $c },
          );

  local $/;
  $/ = "<fs>";
  my $lixo=<XML>;
  if($lixo =~ /encoding=['"](.*?)['"]/){$inputenc=$1}

  $/ = "</extract>";

  my $parser;

  #create a new XML::Parser instance using Tree Style
  if ((defined $inputenc) && ($inputenc eq 'ISO-8859-1')){
     $parser = new XML::Parser( Style => 'Tree',
                                ErrorContext => 2 ,
                                ProtocolEncoding => 'ISO-8859-1'); }
  else { $parser = new XML::Parser(Style => 'Tree',
                                    ErrorContext => 2 ,
                                   );
  }

  my $i = 0;
  while(<XML>) {
    last if m!</fs>!;
    $i++;
    my $tree = $parser->parse($_);
    my $dtree= Dumper($tree);
    my $string = downtr($dtree, %h);
    warn("\nWeird... $_ ... $string\n") && next  unless ref($string) ;
    print IDX "$i:",join(" ",_flatten(@$string)),"\n";
    $dbXML{$i} = $dtree;
  }
  $dbXML{meta}= Dumper(+{trees => $i, %$at }) ;
  close(XML);
  untie( %dbXML );
}

sub getmeta{
  return eval($db1{meta})
}

sub father{
  my ($a,$b)=@_;
  if(defined($b)){$attributes[1]{$a} = $b} 
  else           {$attributes[1]{$a}}
}

sub gfather{
  my ($a,$b)=@_;
  if(defined($b)){$attributes[2]{$a} = $b} 
  else           {$attributes[2]{$a}}
}

sub ggfather{
  my ($a,$b)=@_;
  if(defined($b)){$attributes[3]{$a} = $b} 
  else           {$attributes[3]{$a}}
}

sub adam{         ### the root
  my ($a,$b)=@_;
  if(defined($b)){$attributes[-1]{$a} = $b} 
  else           {$attributes[-1]{$a}}
}

sub _flatten {
  return map { ref($_)?_flatten(@$_):$_ } @_
}

sub _trim {
  my $x = shift;
  $x =~ s/^\s*//;
  $x =~ s/\s*$//;
  return $x
}

sub downTr{
  my $proc = shift;
  my $struct;
  my @r=();
  my $patt = delete($proc->{-patt}) || ".";

  if    (ref($patt) eq "CODE"){ }
  elsif (ref($patt) eq "HASH"){ }
  else {
    my $cont=0;
    my $max= (defined $proc->{-max} ? $proc->{-max} : -1);
    for(`grep -E $patt "$o{dir}/$o{id}.idx"`){
      last if ($cont++ == $max );
      chomp();
      if(/(\d+):(.*)/){
        $struct = $db1{$1};
        push(@r,downtr($struct,( # '-inputenc' => 'ISO-8859-1', 
                                    %$proc)));
      }
    }
  }
  return \@r;
}

###---jjDT

our %ty = ();

sub downtr {
  my ($stree,%xml)=@_;
  my ($parser, $tree);

  # Treat -decl option
  my $declr = "";
  if ($xml{-declr}) {
    if ($xml{-outputenc}) {
      $declr = "<?xml version=\"1.0\" encoding=\"$xml{-outputenc}\"?>\n";
    } else {
      $declr = "<?xml version=\"1.0\"?>\n";
    }
  }

  %ty = ();
  %ty = (%{$xml{'-type'}}) if defined($xml{'-type'});
  $ty{-ROOT} = "NONE";

  &{$xml{-begin}} if $xml{-begin};

  $tree = eval($stree);
  die($@) if $@;

  my $return = "";

  # execute End action if it exists
  if($xml{-end}) { $c = _omni("-ROOT", \%xml, @$tree);
                   $return = &{$xml{-end}} } 
  else {    $return = _omni("-ROOT",\%xml, @$tree) }

  if ($declr) { return $declr.$return; } 
  else {        return $return;
  }
}

sub ctxt {
  my $level = $_[0];
  $dtcontext[-$level-1];
}

sub inctxt {
  my $pattern = shift ;
  # see if is in root context...
  return 1 if (($pattern eq "^" && @dtcontext==1) || $pattern eq ".*");
  join("/",@dtcontext) =~ m!$pattern/[^/]*$! ;
}

sub pathdtstring{
  my $string = shift;
  my %h = _pathtodt(@_);
  return dtstring($string,%h);
}

sub pathdturl{
  my $url = shift;
  my %h = _pathtodt(@_);
  return dturl($url,%h);
}

sub dturl{
  my $url = shift;
  my $contents = get($url);
  if ($contents) {
    return dtstring($contents, @_);
  } else {
    return undef;
  }
}

sub dtstring {
  my ($string,%xml)=@_;
  my ($parser, $tree);

  my $declr = "";
  if ($xml{-declr}) {
    if ($xml{-outputenc}) {
      $declr = "<?xml version=\"1.0\" encoding=\"$xml{-outputenc}\"?>\n";
    } else {
      $declr = "<?xml version=\"1.0\"?>\n";
    }
  }

  $xml{'-type'} = {} unless defined $xml{'-type'};
  %ty = (%{$xml{'-type'}}, -ROOT => "NONE");

  # execute Begin action if it exists
  if ($xml{-begin}){ &{$xml{-begin}} }

  # create a new XML::Parser instance using Tree Style
    if (defined($xml{-inputenc}) && ($xml{-inputenc} eq 'ISO-8859-1')){
       $parser = new XML::Parser(Style => 'Tree',
                                 ErrorContext => 2 ,
                                 ProtocolEncoding => 'ISO-8859-1');
    }
    else { $parser = new XML::Parser(Style => 'Tree',
                                     ErrorContext => 2 ,
                                    );
    }

  # Convert XML to Perl code (Tree)
    $tree = $parser->parse($string);

  my $return;

  # Check if we have an end function
  if ($xml{-end}) {
        $c = _omni("-ROOT", \%xml, @$tree);
    $return = &{$xml{-end}}
  } else {
        $return = _omni("-ROOT", \%xml, @$tree)
  }

  if ($declr) {
    return $declr.$return;
  } else {
    return $return;
  }
}

sub pathdt{
  my $file = shift;
  my %h = _pathtodt(@_);
  return downtr($file,%h);
}

# Parsing dos predicados do XPath
sub _testAttr {
  my $atr = shift;
  for ($atr) {
    s/name\(\)/'$q'/g;
    # s/\@([A-Za-z_]+)/'$v{$1}'/g;
    s/\@([A-Za-z_]+)/defined $v{$1}?"'$v{$1}'":"''"/ge;
    s/\@\*/keys %v?"'1'":"''"/ge;
    if (/^not\((.*)\)$/) {
      return ! _testAttr($1);
    } elsif (/^('|")([^\1]*)(\1)\s*=\s*('|")([^\4]*)\4$/) {
      return ($2 eq $5);
    } elsif (/^(.*?)normalize-space\((['"])([^\2)]*)\2\)(.*)$/) {
      my ($back,$forward)=($1,$4);
      my $x = _normalize_space($3);
      return _testAttr("$back'$x'$forward"); 
    } elsif (/starts-with\((['"])([^\1))]*)\1,(['"])([^\3))]*)\3\)/) {
      my $x = _starts_with($2,$4);
      return $x;
    } elsif (/contains\((['"])([^\1))]*)\1,(['"])([^\3))]*)\3\)/) {
      my $x = _contains($2,$4);
      return $x; 
    } elsif (/^(.*?)string-length\((['"])([^\2]*)\2\)(.*)$/) {
      my ($back,$forward) = ($1,$4);
      my $x = length($3);
      return _testAttr("$back$x$forward");
    } elsif (/^(\d+)\s*=(\d+)$/) {
      return ($1 == $2);
    } elsif (/^(\d+)\s*&lt;(\d+)$/) {
      return ($1 < $2);
    } elsif (/^(\d+)\s*&gt;(\d+)$/) {
      return ($1 > $2);
    } elsif (/^(['"])([^\1]*)\1$/) {
      return $2;
    }
  }
  return 0; #$atr;
}

# Funcao auxiliar de teste de predicados do XPath
sub _starts_with {
  my ($string,$preffix) = @_;
  return 0 unless ($string && $preffix);
  return 1 if ($string =~ m!^$preffix!);
  return 0;
}

# Funcao auxiliar de teste de predicados do XPath
sub _contains {
  my ($string,$s) = @_;
  return 0 unless ($string && $s);
  return 1 if ($string =~ m!$s!);
  return 0;
}

# Funcao auxiliar de teste de predicados do XPath
sub _normalize_space {
  my $z = shift;
  $z =~ /^\s*(.*?)\s*$/;
  $z = $1;
  $z =~ s!\s+! !g;
  return $z;
}

sub _pathtodt {
  my %h = @_;
  my %aux=();
  my %aux2=();
  my %n = ();
  my $z;
  for $z (keys %h) {
    # TODO - Make it more generic
    if ( $z=~m{\w+(\|\w+)+}) {
      my @tags = split /\|/, $z;
      for(@tags) {
	$aux2{$_}=$h{$z}
      }
    }
    elsif ( $z=~m{(//|/|)(.*)/([^\[]*)(?:\[(.*)\])?} ) {
      my ($first,$second,$third,$fourth) = ($1,$2,$3,$4);
      if (($first eq "/") && (!$second)) {
	$first = "";
	$second = '.*';
	$third =~ s!\*!-default!;
      } else {
	$second =~ s!\*!\[^/\]\+!g;
	$second =~ s!/$!\(/\.\*\)\?!g;
	$second =~ s!//!\(/\.\*\)\?/!g;
	$third =~ s!\*!-default!g;
      }
      push( @{$aux{$third}} , [$first,$second,$h{$z},$fourth]);
    }
    else                           { $aux2{$z}=$h{$z};}
  }
  for $z (keys %aux){
    my $code = sub {
      my $l;
      for $l (@{$aux{$z}}) {
	my $prefix = "";
	$prefix = "^" unless (($l->[0]) or ($l->[1]));
	$prefix = "^" if (($l->[0] eq "/") && ($l->[1]));
	if ($l->[3]) {
	  if(inctxt("$prefix$l->[1]") && _testAttr($l->[3])) 
	    {return &{$l->[2]}; }
	} else {
	  if(inctxt("$prefix$l->[1]")) {return &{$l->[2]};}
	}
      }
      return &{ $aux2{$z}} if $aux2{$z} ;
      return &{ $h{-default}} if $h{-default};
      &toxml();
    };
    $n{$z} = $code;
  }
  for $z (keys %aux2){
    $n{$z} ||= $aux2{$z} ;
  }
  return %n;
}

sub _omni{
  my ($par, $xml, @l) = @_;
  my $defaulttype = (exists($xml->{-type}) && exists($xml->{-type}{-default}))?$xml->{-type}{-default}:"STR";
  my $type = $ty{$par} || $defaulttype;
  my %typeargs = ();

  if (ref($type) eq "mmapon") {
    for (@$type)
      { $typeargs{$_} = 1 }
    $type = "MMAPON";
  };

  my $r ;

  if( $type eq 'STR')                                   { $r = "" }
  elsif( $type eq 'THE_CHILD' or $type eq 'LAST_CHILD') { $r = 0  }
  elsif( $type eq 'SEQ'  or $type eq "ARRAY")           { $r = [] }
  elsif( $type eq 'SEQH' or $type eq "ARRAYOFHASH")     { $r = [] }
  elsif( $type eq 'MAP'  or $type eq "HASH")            { $r = {} }
  elsif( $type eq 'MULTIMAP')                           { $r = {} }
  elsif( $type eq 'MMAPON' or $type eq "HASHOFARRAY")   { $r = {} }
  elsif( $type eq 'NONE')                               { $r = "" }
  elsif( $type eq 'ZERO')                               { return "" }

  my ($name, $val, @val, $atr, $aux);

  while(@l) {
    ($name,$val,@l) = @l;
    if ($name eq "0") {
      $name = "-pcdata";
      $aux = (defined($xml->{-outputenc}))?_fromUTF8($val,$xml->{-outputenc}):$val;

      if (defined($xml->{-pcdata})) {
	push(@dtcontext,"-pcdata");
	$c = $aux;
	$aux = &{$xml->{-pcdata}};
	pop(@dtcontext); } 
    } 
    else {
      ($atr,@val) = @$val;

      if (exists($xml->{-ignorecase})) {
	$name = lc($name);
	for (keys %$atr) {
	  my ($k,$v) = (lc($_),$atr->{$_});
	  delete($atr->{$_});
	  $atr->{$k} = $v;
	}
      }

      push(@dtcontext,$name);
      $dtcontextcount{$name}++;
      unshift(@attributes, $atr);
      $aux = _omniele($xml, $name, _omni($name, $xml, @val), $atr);
      shift(@attributes);
      pop(@dtcontext); $dtcontextcount{$name}--;
    }
    if    ($type eq "STR"){ if (defined($aux)) {$r .= $aux} ;}
    elsif ($type eq "THE_CHILD" or $type eq "LAST_CHILD"){
      $r = $aux unless _whitepc($aux, $name); }
    elsif ($type eq "SEQ" or $type eq "ARRAY"){
      push(@$r, $aux) unless _whitepc($aux, $name);}
    elsif ($type eq "SEQH" or $type eq "ARRAYHASH"){
      push(@$r,{"-c" => $aux,
		"-q" => $name,
		 (defined $atr ?  %$atr :())
	       }) unless _whitepc($aux,$name);
    }
    elsif($type eq "MMAPON"){
      if(not _whitepc($aux,$name)){
	if(! $typeargs{$name}) {
	  warn "duplicated tag '$name'\n" if(defined($r->{$name}));
	  $r->{$name} = $aux }
	else { push(@{$r->{$name}},$aux) unless _whitepc($aux,$name)}}
    }
    elsif($type eq "MAP" or $type eq "HASH"){
      if(not _whitepc($aux,$name)){
	warn "duplicated tag '$name'\n" if(defined($r->{$name}));
	$r->{$name} = $aux }}
    elsif($type eq "MULTIMAP"){
      push(@{$r->{$name}},$aux) unless _whitepc($aux,$name)}
    elsif($type eq "NONE"){ $r = $aux;}
    else { $r="undefined type !!!"}
  }
  $r;
}

sub _omniele {
  my $xml = shift;
  my $aux;
  ($q, $c, $aux) = @_;

  %v = %$aux;

  if (defined($xml->{-outputenc})) {
    for (keys %v){
      $v{$_} = _fromUTF8($v{$_}, $xml->{-outputenc})
    }
  }

  if (defined $xml->{$q})
    { &{$xml->{$q}} }
  elsif (defined $xml->{'-default'})
    { &{$xml->{'-default'}} }
  else
    { toxml() }
}

sub xmltree { +{'-c' => $c, '-q' => $q, %v} }

sub toxml {
  my ($q,$v,$c);
  if (not @_) {
    ($q, $v, $c) = ($Lingua::Treebank::SimTreeML::q,
                   \%Lingua::Treebank::SimTreeML::v, 
                    $Lingua::Treebank::SimTreeML::c);
  } elsif (ref($_[0])) {
    $c = shift;
  } else {
    ($q, $v, $c) = @_;
  }

  if (not ref($c)) {
    if ($q eq "-pcdata") { return $c } 
    elsif ($c eq "")     { return _emptyTag($q,$v) } 
    else                 { return _openTag($q,$v) . "$c</$q>" }
  }
  elsif (ref($c) eq "HASH" && $c->{'-q'} && $c->{'-c'}) {
    my %a = %$c;
    my ($q,$c) = delete @a{"-q","-c"};
    toxml($q,\%a,(ref($c)?toxml($c):$c));
  }
  elsif (ref($c) eq "HASH") {
    _openTag($q,$v).
      join("",map {($_ ne "-pcdata")
		     ? ( (ref($c->{$_}) eq "ARRAY")
			 ? "<$_>".
			 join("</$_>\n<$_>", @{$c->{$_}}).
			 "</$_>\n" 
			 : toxml($_,{},$c->{$_})."\n" )
		       : () }
	   keys %{$c} ) .
	     "$c->{-pcdata}</$q>" } ########  "NOTYetREady"
  elsif (ref($c) eq "ARRAY") {
    if (defined($q) && exists($ty{$q}) && $ty{$q} eq "SEQH") 
                       { toxml($q,$v,join("\n",map {toxml($_)} @$c)) } 
    elsif (defined $q) { toxml($q,$v,join("",@{$c})) } 
    else               { join("\n",map {(ref($_)?toxml($_):$_)} @$c) }
  }
}

sub _openTag{
  "<$_[0]". join("",map {" $_=\"$_[1]{$_}\""} keys %{$_[1]} ).">"
}

sub _emptyTag{
  "<$_[0]". join("",map {" $_=\"$_[1]{$_}\""} keys %{$_[1]} )."/>"
}

sub mkdtskel_fromDTD {
  my $filename = shift;
  my $file = ParseDTDFile($filename);

  print <<'PERL';
#!/usr/bin/perl
use XML::DT ;
my $filename = shift;

# Variable Reference
#
# $c - contents after child processing
# $q - element name (tag)
# %v - hash of attributes

%handler=(
#    '-outputenc' => 'ISO-8859-1',
#    '-default'   => sub{"<$q>$c</$q>"},
PERL


  for (sort keys %{$file}) {
    print "     '$_' => sub { },";
    print " # attributes: ",
      join(", ", keys %{$file->{$_}{attributes}}) if exists($file->{$_}{attributes});
    print "\n";
  }


  print <<'PERL';
);

print downtr($filename,%handler);
PERL

}

sub mkdtskel{
  my @files = @_;
  my $name;
  my %element;
  my %att;
  my %mkdtskel =
    ('-default' => sub{
       $element{$q}++;
       for (keys %v) {
	 $att{$q}{$_} = 1
       };
       ""},

     '-end' => sub{
       print <<'END';
#!/usr/bin/perl
use XML::DT ;
my $filename = shift;

# Variable Reference
#
# $c - contents after child processing
# $q - element name (tag)
# %v - hash of attributes

%handler=(
#    '-outputenc' => 'ISO-8859-1',
#    '-default'   => sub{"<$q>$c</$q>"},
END
       for $name (sort keys %element) {
	 print "     '$name' => sub{ }, #";
	 print " $element{$name} occurrences;";
	 print ' attributes: ',
	   join(', ', keys %{$att{$name}}) if $att{$name};
#	 print "       \"\$q:\$c\"\n";
	 print "\n";
       }
       print <<'END';
);
print downtr($filename,%handler);
END
     }
    );

  my $file = shift(@files);
  while($file =~ /^-/){
    if   ($file eq "-html")   { $mkdtskel{'-html'} = 1;} 
    elsif($file eq "-latin1") { $mkdtskel{'-inputenc'}='ISO-8859-1';}
    else { die("usage mktskel [-html] [-latin1] file \n")}
    $file=shift(@files)}

  downtr($file,%mkdtskel)
}

sub _nodeAttributes {
  my $node = shift;
  my %answer = ();
  my @attrs = $node->getAttributes();
  for (@attrs) {
    if (ref($_) eq "XML::LibXML::Namespace") {
      # TODO: This should not be ignored, I think.
      # This sould be converted on a standard attribute with
      # key 'namespace' and respective contents
    } else {
      $answer{$_->getName()} = $_->getValue();
    }
  }
  return %answer;
}

sub mkdtdskel {
  my @files = @_; 
  my $name;
  my %att;
  my %ele;
  my %elel;
  my $root;
  my %handler=(
    '-outputenc' => 'ISO-8859-1',
    '-default'   => sub{ 
          $elel{$q}++;
          $root = $q unless ctxt(1);
          $ele{ctxt(1)}{$q} ++;
          for(keys(%v)){$att{$q}{$_} ++ } ;
        },
    '-pcdata'    => sub{ if ($c =~ /[^ \t\n]/){ $ele{ctxt(1)}{"#PCDATA"}=1 }},
  );

  while($files[0] =~ /^-/){
    if   ($files[0] eq "-html")   { $handler{'-html'} = 1;} 
    elsif($files[0] eq "-latin1") { $handler{'-inputenc'}='ISO-8859-1';}
    else { die("usage mkdtdskel [-html] [-latin1] file* \n")}
    shift(@files)}

  for my $filename (@files){
    downtr($filename,%handler); 
  }

  print "<!-- DTD $root ... -->\n<!-- (C) ... " . localtime(time) ." -->\n";
  delete $elel{$root};

  for ($root, keys %elel){
    _putele($_, \%ele);
    for $name (keys(%{$att{$_}})) {
       print( "\t<!-- $name : ... -->\n");
       print( "\t<!ATTLIST $_ $name CDATA #IMPLIED >\n");
    }
  }
}

sub _putele {
  my ($e,$ele) = @_;
  my @f ;
  if ($ele->{$e}) {
    @f = keys %{$ele->{$e}};
    print "<!ELEMENT $e (", join("|", @f ),")",
      (@f >= 1 && $f[0] eq "#PCDATA" ? "" : "*"),
	" >\n";
    print "<!-- ", join(" | ", (map {"$_=$ele->{$e}{$_}"} @f )), " -->\n";
  }
  else {
    print "<!ELEMENT $e  EMPTY >\n";
  }
}

sub _whitepc {
  $_[1] eq '-pcdata' and $_[0] =~ /^[ \t\n]*$/
}

sub MMAPON {
  bless([@_],"mmapon")
}

# not being used...
#
# sub SEQOF {
#   bless([@_],"seqof")
# }


#######################################
#                                     #
#  Auxiliary functions for encodings  #
#                                     #
### STARTLATIN1 #######################
sub _fromUTF8 {
  use Encode;
  my $string = shift;
  my $encode = shift;
  encode($encode, $string);
}
### ENDLATIN1

1;

__END__

#head1 SYNOPSIS

 use XML::DT;

 %xml=( 'music'    => sub{"Music from: $c\n"},
        'lyrics'   => sub{"Lyrics from: $v{name}\n"},
        'title'    => sub{ uc($c) },
        '-default' => sub{"$q:$c"} );

 print downtr($filename,%xml);

#head1 ABSTRACT

This module is a XML down processor. It maps tag (element)
names to functions to process that element and respective
contents.

#head1 DESCRIPTION

This module processes XML files with an approach similar to
OMNIMARK. As XML parser it uses XML::Parser or XML::LibXML module in
an independent way. At configure stage, you should choose one of the
back-ends.

If you use XML::LibXML module as backend, you can parse HTML files as
if they were XML files. For this, you must supply an extra option to
the hash:

 %hander = ( -html => 1,
             ...
           );


#head1 Functions

#head2 downtr

Down translation function C<downtr> receives a filename and a set of
expressions (functions) defining the processing and associated values
for each element.

#head2 dtstring

C<dtstring> works in a similar way with C<downtr> but takes input from a
string instead of a file.

#head2 dturl

C<dturl> works in a similar way with C<downtr> but takes input from an
Internet url instead of a file.

#head2 pathdt

The C<pathdt> function is a C<downtr> function which can handle a subset
of XPath on handler keys. Example:

 %handler = (
   "article/title"        => sub{ toxml("h1",{},$c) },
   "section/title"        => sub{ toxml("h2",{},$c) },
   "title"                => sub{ $c },
   "//image[@type='jpg']" => sub{ "JPEG: <img src=\"$c\">" },
   "//image[@type='bmp']" => sub{ "BMP: sorry, no bitmaps on the web" },
 )

 pathdt($filename,%handler);

Here are some examples of valid XPath expressions under XML::DT:

 /aaa
 /aaa/bbb
 //ccc                           - ccc somewhere (same as "ccc")
 /*/aaa/*
 //*                             - same as "-default"
 /aaa[@id]                       - aaa with an attribute id
 /*[@*]                          - root with an attribute
 /aaa[not(@name)]                - aaa with no attribute "name"
 //bbb[@name='foo']              - ... attribute "name" = "foo"
 /ccc[normalize-space(@name)='bbb']
 //*[name()='bbb']               - complex way of saying "//bbb"
 //*[starts-with(name(),'aa')]   - an element named "aa.*"
 //*[contains(name(),'c')]       - an element       ".*c.*"
 //aaa[string-length(name())=4]                     "...."
 //aaa[string-length(name())&lt;4]                  ".{1,4}"
 //aaa[string-length(name())&gt;5]                  ".{5,}"

Note that not all XPath is currently handled by XML::DT. A lot of
XPath will never be added to XML::DT because is not in accordance with
the down translation model. For more documentation about XPath check
the specification at http://www.w3c.org or some tutorials under
http://www.zvon.org

#head2 pathdtstring

Like the C<dtstring> function but supporting XPath.

#head2 pathdturl

Like the C<dturl> function but supporting XPath.
#head2 mkdtskel

Used by the mkdtskel script to generate automatically a XML::DT perl
script file based on an XML file. Check C<mkdtskel> manpage for
details.

#head2 mkdtskel_fromDTD

Used by the mkdtskel script to generate automatically a XML::DT perl
script file based on an DTD file. Check C<mkdtskel> manpage for
details.

#head2 mkdtdskel

Used by the mkdtskel script to generate automatically a XML::DT perl
script file based on a DTD file. Check C<mkdtdskel> manpage for
details.

#head1 User provided element processing functions

The user must provide an HASH with a function for each element, that
computes element output. Functions can use the element name C<$q>, the
element content C<$c> and the attribute values hash C<%v>.

All those global variables are defined in C<$CALLER::>.

Each time an element is find the associated function is called.

Content is calculated by concatenation of element contents strings and
interior elements return values.
#head2 C<-outputenc> option

C<-outputenc> defines the output encoding (default is Unicode UTF8).

#head2 C<-inputenc> option

C<-inputenc> forces a input encoding type. Whenever that is possible,
define the input encoding in the XML file:

 <?xml version='1.0' encoding='ISO-8859-1'?>
#head2 An example:

 use XML::DT;
 %handler = ( contacts => sub{ [ split(";",$c)] },
              -default => sub{$c},
	      -type    => { institution => 'MAP',
	                    degrees     =>  MMAPON('name')
		            tels        => 'SEQ' }
            );
 $a = downtr ("f.xml", %handler);

with the following f.xml

 <degrees>
    <institution>
       <id>U.M.</id>
       <name>University of Minho</name>
       <tels>
          <item>1111</item>
          <item>1112</item>
          <item>1113</item>
       </tels>
       <where>Portugal</where>
       <contacts>J.Joao; J.Rocha; J.Ramalho</contacts>
    </institution>
    <name>Computer science</name>
    <name>Informatica </name>
    <name> history </name>
 </degrees>

would make $a

 { 'name' => [ 'Computer science',
               'Informatica ',
	       ' history ' ],
   'institution' => { 'tels' => [ 1111, 1112, 1113 ],
  	              'name' => 'University of Minho',
	              'where' => 'Portugal',
	              'id' => 'U.M.',
	              'contacts' => [ 'J.Joao',
			       ' J.Rocha',
			       ' J.Ramalho' ] } };


#head1 DT Skeleton generation

It is possible to build an initial processor program based on an example

To do this use the function C<mkdtskel(filename)>.

Example:

 perl -MXML::DT -e 'mkdtskel "f.xml"' > f.pl

#head1 DTD skeleton generation

It makes a naive DTD based on an example(s).

To do this use the function C<mkdtdskel(filename*)>.

Example:

 perl -MXML::DT -e 'mkdtdskel "f.xml"' > f.dtd

#head1 SEE ALSO

mkdtskel(1) and mkdtdskel(1)

#head1 AUTHORS

Home for XML::DT;

http://natura.di.uminho.pt/~jj/perl/XML/

Jose Joao Almeida, <jj@di.uminho.pt>

Alberto Manuel Simões, <albie@alfarrabio.di.uminho.pt>

thanks to

Michel Rodriguez    <mrodrigu@ieee.org>
José Carlos Ramalho <jcr@di.uminho.pt>
Mark A. Hillebrand

#head1 COPYRIGHT AND LICENSE

Copyright 1999-2004 by Projecto Natura

This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

#cut

=head1 NAME

Lingua::Treebank::SimTreeML - Perl extension for traversing Floresta Sintactica

=head1 SYNOPSIS

  use Lingua::Treebank::SimTreeML    dir => "." , id => "fs" ;

  downTr( { -patt => "-w comer",
            -end  => sub{print "\n"},
            t     => sub{print "$c, "  if $v{cat} eq "n" } });

=head1 ABSTRACT

=head1 DESCRIPTION

C<Lingua::Treebank::SimTreeML> is a perl module to compile and
to make tree-traversal of treebanks.

=head1 EXPORT

=head2 C<use Lingua::Treebank::SimTreeML>

  use Lingua::Treebank::SimTreeML  dir => "." , id=> "fs" ;

=head2 C<downTr>

  downTr( { -patt => "-w comer",
            -end  => sub{print "\n"},
             t    => sub{print "$c, "  if $v{cat} eq "n" } });

This example selects (grep) all the entries with word (or lemma) "comer"
and prints the words in those trees that are nouns ("n")

=head2 C<getmeta>

Get meta-data about the treebank. Example

 print Dumper(getmeta())

returns

 {trees => 7144,           # number of trees
  _nt   => {fcl => 3455,
            pp  => 333,  
            ... }          #list of non terminals cat
  _t    => {adv => 2344,
            art => 1211,
            prp =>  
            ... }          #list of terminals cat

=head2 C<compileTB>

Builds a set of auxilar indexes

 compileTB("f.xml",dir=>"/home/jj/FS", id=>"fs_pt");

 toxml

 xmltree

 -max=20   -- just 20 sentences


=head2 inctxt

C<inctxt(pattern)> is true if the actual element path matches the
provided pattern. This function is meant to be used in the element
functions in order to achieve context dependent processing.

=head2 ctxt

Returns the context element of the currently being processed
element. So, if you call C<ctxt(1)> you will get your father element,
and so on.

=head2 toxml

This is the default "-default" function. It can be used to generate
XML based on C<$c> C<$q> and C<%v> variables. Example: add a new
attribute to element C<ele1> without changing it:

   %handler=( ...
     ele1 => sub { $v{at1} = "v1"; toxml(); },
   )

C<toxml> can also be used with 3 arguments: tag, attributes and contents

   toxml("a",{href=> "http://local/f.html"}, "example")

returns:

 <a href='http://local/f.html'>example</a>

=head2 xmltree

This simple function just makes a HASH reference:

 { -c => $c, -q => $q, all_the_other_attributes }

The function C<toxml> understands this structure and makes XML with it.

=head2 Predefined Variable 

 $c 
 $q 
 %v 
 @attributes 
 $attributes[1]     -- father
 $attributes[2]     -- gran father
 $attributes[3]     -- great gran father
 $attributes[-1]    -- root

 -patt => "...."
 -max  => 300        -- process just 300 syntatic trees

=head1 Accessing parents attributes

With XML::DT you can access an element parent (or grand-parent)
attributes, till the root of the XML document.

If you use c<$attributes[1]{foo} = 'bar'> on a processing function,
you are defining the attribute C<foo> for that element parent.

In the same way, you can use C<$attributes[2]> to access the
grand-parent. C<$attributes[-1]> is, as expected, the XML document
root element.

=head2 C<father>

 father(at1)               # get the value of at1 of father
 father(at1 => new_value)  # set the value

=head2 C<gfather>

 gfather(at1)              # get the value of at1 of gran-father
 gather(at1 => new_value)  # set the value

=head2 C<ggfather>

 ggfather(at1)               # get the value of at1 of great-gran-father
 ggfather(at1 => new_value)  # set the value

=head2 C<adam>

 adam(at1)               # get the value of at1 of root
 adam(at1 => new_value)  # set the value

=head2 C<-default> function

When a element has no associated function, the function associated
with C<-default> called. If no C<-default> function is defined the
default function returns a XML like string for the element.

When you use C</-type> definitions, you often need do set C<-default>
function to return just the contents: C<sub{$c}>.


=head2 C<-pcdata> function

C<-pcdata> function is used to define transformation over the
contents.  Typically this function should look at context (see
C<inctxt> function)

The default C<-pcdata> function is the identity

=head2 C<-begin> function

Function to be executed before processing XML file.

Example of use: initialization of side-effect variables

=head2 C<-end> function

Function to be executed after processing XML file.  I can use C<$c>
content value.  The value returned by C<-end> will be the C<downtr> return
value.

Example of use: post-processing of returned contents



=head1 Elements with values other than strings (C<-type>)

By default all elements return strings, and contents (C<$c>) is the
concatenation of the strings returned by the sub-elements.

In some situations the XML text contains values that are better
processed as a structured type.

The following types (functors) are available:

=over 4

=item THE_CHILD

Return the result of processing the only child of the element.

=item LAST_CHILD

Returns the result of processing the last child of the element.

=item STR

concatenates all the sub-elements returned values (DEFAULT) all the
sub-element should return strings to be concatenated;

=item SEQ

makes an ARRAY with all the sub elements contents; attributes are
ignored (they should be processed in the sub-element). (returns a ref)
If you have different types of sub-elements, you should use SEQH

=item SEQH

makes an ARRAY of HASH with all the sub elements (returns a ref); for
each sub-element:

 -q  => element name
 -c  => contents
 at1 => at value1    for each attribute

=item MAP

makes an HASH with the sub elements; keys are the sub-element names,
values are their contents. Attributes are ignored. (they should be
processed in the sub-element) (returns a ref)

=item MULTIMAP

makes an HASH of ARRAY; keys are the sub-element names; values are
lists of contents; attributes are ignored (they should be processed in
the sub-element); (returns a ref)

=item MMAPON(element-list)

makes an HASH with the sub-elements; keys are the sub-element names,
values are their contents; attributes are ignored (they should be
processed in the sub-element); for all the elements contained in the
element-list, it is created an ARRAY with their contents. (returns a
ref)

=item XML

return a reference to an HASH with:

 -q  => element name
 -c  => contents
 at1 => at value1    for each attribute

=item ZERO

don't process the sub-elements; return ""

=back

When you use C</-type> definitions, you often need do set C<-default>
function returning just the contents C<sub{$id}>.



=head1 SEE ALSO


http://linguateca.di.uminho.pt/FS/fs.html  -- a Portuguese SimTreeML
that can be used with this module

=head1 AUTHOR

Jose Joao Dias de Almeida, E<lt>jj@di.uminho.pt<gt>

Alberto Simoes, E<lt>ambs@di.uminho.pt<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2004 by Jose Joao Dias de Almeida

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut
