martes, 5 de noviembre de 2013

Tokens - programa en Perl para parsear XML

Sinopsis
use Tokens;

open my $regex_fh, '<', $ARGV[0]; #regex.txt
open my $target_fh, '<', $ARGV[1]; #file.txt

my $target;
{
  local $/ = undef;
  $target = <$target_fh>; #the content
  $target =~ s/\n/ /g;
}

my $regex;
{
  local $/ = undef;
  $regex = <$regex_fh>; #the content
}

printAll parse $target, $regex;
 

Códio (archivo: Tokens.pm):
=pod
 Copyright 2013 Gabriel Czernikier



    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see .
=cut
use strict;
#package declarations
sub digest_single;
sub parse_programme;
sub printAll;

my @token_separator = ('<', '/', '"', '=', '>', ' ');

my @REGEX;
my @MASK;
my $long_tokens;
my @DIGEST_SINGLE;

sub min_token_separator_left {
  my $regex = shift;
  my $T;
  $regex =~ /([@token_separator])/og;
  my $min = (pos $regex) - (length $1);
  my $T = $1;
  return ($T, $min) if $regex =~ m/([@token_separator])/o;
}

sub min_token_separator_right {
  my $regex = shift;
  $regex =~ /.*([@token_separator])/og;
  my $min = (pos $regex) - (length $1);
  my $T = $1;
  return ($T, $min) if $regex =~ m/([@token_separator])/o;
}

sub expand_left {
  $_[0] =~ s/^\(\?:(?:[^)]|\)[^+*])+\)\*//;
  $_[0] =~ s/^\(\?:((?:[^)]|\)[^+*])+)\)\+/\1\(\?:\1\)\*/;
}

sub trim_left {
  $_[0] =~ s/^\(\.\*\?\)//;
}

sub expand_right {
  $_[0] =~ s/\(\?:(?:[^)]|\)[^+*])+\)\*$//;
  $_[0] =~ s/\(\?:((?:[^)]|\)[^+*])+)\)\+$/\(\?:\1\)\*\1/;
}

sub trim_right {
  $_[0] =~ s/\(\.\*\?\)$//;
}

sub digest_single {
  my $target = shift;
  my $regex = shift;
  return unless $regex ne '';
  my $token_desde = shift;
  my $token_hasta = shift;
  return @{$DIGEST_SINGLE[$token_desde][$token_hasta]} if defined $DIGEST_SINGLE[$token_desde][$token_hasta];
  my ($T, $pos)=min_token_separator_left($regex);
  return unless $target =~ /$regex/ or defined $pos;
  $target =~ /($regex)/g;
  my $digit = 2;
  while( my $cg = eval '$'.$digit++ ) {
    goto VISITING if $cg =~ /$long_tokens/;
  }
  my $pff = (pos $target);
  my $pii = $pff - (length $1) if defined $pff;
  VISITING:
  return ($token_desde, $token_hasta, $pii, $pff) unless defined $pos;
  my $re = $regex;
  expand_left $re;
  ($T, $pos)=min_token_separator_left($re);
  my $pos_aux = $pos+length($T);
  $re =~ s/.{$pos_aux}//;
  trim_left $re;
  my ($td, $th, $pi, $pf) = digest_single $target, $re, $token_desde+1, $token_hasta;
  $re = $regex;
  expand_right $re;
  ($T, $pos) = min_token_separator_right($re);
  $re =~ s/(.{$pos}).*/\1/;
  trim_right $re;
  my ($td2, $th2, $pi2, $pf2) = digest_single $target, $re, $token_desde, $token_hasta-1;
  $DIGEST_SINGLE[$token_desde][$token_hasta] = [$token_desde, $token_hasta, $pii, $pff] if (defined $pii) && ($pff-$pii>=$pf-$pi || !defined $pi) && ($pff-$pii>=$pf2-$pi2 || !defined $pi2);
  return @{$DIGEST_SINGLE[$token_desde][$token_hasta]} if defined $DIGEST_SINGLE[$token_desde][$token_hasta];
  $DIGEST_SINGLE[$token_desde][$token_hasta] = [$td, $th, $pi, $pf] if (defined $pi) && ($pf-$pi>$pff-$pii || !defined $pii) && ($pf-$pi>=$pf2-$pi2 || !defined $pi2);
  return @{$DIGEST_SINGLE[$token_desde][$token_hasta]} if defined $DIGEST_SINGLE[$token_desde][$token_hasta];
  $DIGEST_SINGLE[$token_desde][$token_hasta] = [$td2, $th2, $pi2, $pf2] if (defined $pi2) && ($pf2-$pi2>$pff-$pii || !defined $pii) && ($pf2-$pi2>$pf-$pi || !defined $pi);
  return @{$DIGEST_SINGLE[$token_desde][$token_hasta]} if defined $DIGEST_SINGLE[$token_desde][$token_hasta];
  $DIGEST_SINGLE[$token_desde][$token_hasta] = [];
  return @{$DIGEST_SINGLE[$token_desde][$token_hasta]};
}

sub token_count {
  my $regex = shift;
  my @matches = $regex =~ /[@token_separator]/og;
  return scalar @matches;
}

sub digest_multiple {
  my $target = shift;
  my @R = @REGEX;
  my $regex_num = 0;
  my $Pos_Ini;
  my $Token_Desde;
  my $Token_Hasta;
  my $Pos_Fin;
  my $Regex_Num;

  my @DIGEST_MULTIPLE = ();
  while( defined(my $regex = shift @R)) {
    @DIGEST_SINGLE = undef;
    my ($token_desde, $token_hasta, $pos_ini, $pos_fin) = digest_single $target, $regex, 0, token_count($regex);
    return $token_desde, $token_hasta, $pos_ini, $pos_fin, $regex_num if($token_desde==0 && $token_hasta==token_count($regex));
    push @DIGEST_MULTIPLE, [$token_desde, $token_hasta, $pos_ini, $pos_fin, $regex_num] if defined $pos_ini;
    $regex_num++;
  }

  $regex_num = 0;
  while(@DIGEST_MULTIPLE!=0) {
    my ($token_desde, $token_hasta, $pos_ini, $pos_fin) = @{shift @DIGEST_MULTIPLE};
    if(defined $pos_ini && $pos_fin!=0 && ($pos_ini<$Pos_Ini || !defined $Pos_Ini)) {
      $Pos_Ini = $pos_ini;
      $Token_Desde = $token_desde;
      $Token_Hasta = $token_hasta;
      $Pos_Fin = $pos_fin;
      $Regex_Num = $regex_num;
    }
    $regex_num++;
  }
  return $Token_Desde, $Token_Hasta, $Pos_Ini, $Pos_Fin, $Regex_Num if defined $Pos_Ini;
}

sub parse_programme {
  my $target = shift;
  return if $target eq '';
  my ($token_desde, $token_hasta, $pos_ini, $pos_fin, $regex_num) = digest_multiple($target);
  if(not defined $pos_ini) {
    #my $oldfh = select;
    #select STDERR;
    #print "$ARGV[1], [ini-no-parseable]${target}[fin-no-parseable]\n";
    #select $oldfh;
    return $target;
  }
  my $mask_right = @MASK[$regex_num];
  my $repetitions = token_count($mask_right)-$token_hasta;
  $mask_right =~ s/.*((?:[@token_separator][^@token_separator]*){$repetitions})$/\1/;
  my $mask_left = @MASK[$regex_num];
  $mask_left =~ s/^((?:[^@token_separator]*[@token_separator]){$token_desde}).*/\1/;
  my $match = $target;
  $match =~ s/(.{$pos_fin}).*/\1/;
  $match =~ s/.{$pos_ini}//;
  my $produccion = $mask_left . $match . $mask_right;
  $target =~ /(.{$pos_ini})/;
  my $target_left = $1;
  $target =~ /.{$pos_fin}(.*)/;
  my $target_right = $1;
  return $produccion, +[parse_programme $target_left], +[parse_programme $target_right];
}

sub printAll {
  return if @_==0;
  if (@_==1) {
    print "[ini-nonparse]${_[0]}[fin-nonparse]\n";
    return;
  }
  printAll @{$_[1]};
  print "[ini-prod]${_[0]}[fin-prod]\n";
  printAll @{$_[2]};
}

sub parse {
  my $target = shift;
  my $regex = shift;
  while($regex =~ /^(.+)$/mg) {
    my $_ = $1;
    my $other = $_;
    $other =~ s/\(\?:(.+?)\)\+/\1/g;
    $other =~ s/\.\*\?//g;
    push @MASK, $other;
    s/(\.\*\?)/\(\1\)/g;
    push @REGEX, $_;
  }

  $long_tokens = join '|', grep length>=3,keys %{+{  map +($_=>undef), map /\w+/g, @REGEX  }};

  parse_programme $target;
}

1;



Input: 

regex2-group.txt
&lt;MyTag1 myAttr1=".*?" myAttr2=".*?"&gt;(?:&lt;MyTag2 myAttr3=".*?" myAttr4=".*?"&gt;.*?&lt;/MyTag2&gt;)+&lt;/MyTag1&gt;

regex3-multiple.txt
&lt;MyTag1 myAttr1=".*?" myAttr2=".*?"&gt;(?:&lt;MyTag2 myAttr3=".*?" myAttr4=".*?"&gt;.*?&lt;/MyTag2&gt;)+&lt;/MyTag1&gt;
&lt;Foo myFoo=".*?" myFoo2=".*?"&gt;&lt;Bar1 myBar1=".*?" myBar1b=".*?" myBar1c=".*?"&gt;&lt;/Bar1&gt;&lt;Bar2 myBar2=".*?" myBar2b=".*?"&gt;&lt;Bar2Sub1&gt;.*?&lt;/Bar2Sub1&gt;&lt;/Bar2&gt;&lt;/Foo&gt;
&lt;MyA myA=".*?"&gt;&lt;MyAB&gt;(?:&lt;MyB myB=".*?"&gt;&lt;/MyB&gt;)+&lt;/MyAB&gt;&lt;MyAC&gt;(?:&lt;MyC myC=".*?"&gt;&lt;/MyC&gt;)+&lt;/MyAC&gt;&lt;/MyA&gt;
&lt;TagT attrT=".*?"&gt;.*?&lt;/TagT&gt;

file2-broken-left-broken-right-repetitions.txt
Tag2 myAttr3="myVal3Pre" myAttr4="myVal4Pre"&gt;MyText1Pre&lt;/MyTag2&gt;&lt;MyTag2 myAttr3="myVal3" myAttr4="myVal4"&gt;MyText1&lt;/MyTag2&gt;&lt;/MyTag1&gt;&lt;MyTag1 myAttr1="myVal1b" myAttr2="myVal2b"&gt;&lt;MyTag2 myAttr3="myVal3b" myAttr4="myVal4b"&gt;MyText1b&lt;/MyTag2&gt;&lt;MyTag2 myAttr3="myVal3bPos" myAttr4="myVal4bPos"&gt;MyText1bPos&lt;/MyTag2&gt;&lt;/MyTag1&gt;&lt;MyTag1 myAttr1="myVal1c" myAttr2="myVal2c"&gt;&lt;MyTag2 myAttr3="myVal3c" myAttr4="myVal4c"&gt;MyText1c&lt;/MyTag2&gt;&lt;MyTag2 myAttr3="myVal3cPos" myAtt

file3-broken-left-broken-right-repetitions-multiple.txt
Tag2 myAttr3="myVal3Pre" myAttr4="myVal4Pre"&gt;MyText1Pre&lt;/MyTag2&gt;&lt;MyTag2 myAttr3="myVal3" myAttr4="myVal4"&gt;MyText1&lt;/MyTag2&gt;&lt;/MyTag1&gt;&lt;Foo myFoo="foo-123" myFoo2="foo-456"&gt;&lt;Bar1 myBar1="bar-123" myBar1b="bar-456" myBar1c="bar-789"&gt;&lt;/Bar1&gt;&lt;Bar2 myBar2="bar-135" myBar2b="bar-790"&gt;&lt;Bar2Sub1&gt;BarSubText&lt;/Bar2Sub1&gt;&lt;/Bar2&gt;&lt;/Foo&gt;&lt;MyTag1 myAttr1="myVal1b" myAttr2="myVal2b"&gt;&lt;MyTag2 myAttr3="myVal3b" myAttr4="myVal4b"&gt;MyText1b&lt;/MyTag2&gt;&lt;MyTag2 myAttr3="myVal3bPos" myAttr4="myVal4bPos"&gt;MyText1bPos&lt;/MyTag2&gt;&lt;/MyTag1&gt;&lt;MyA myA="MYa-123"&gt;&lt;MyAB&gt;&lt;MyB myB="MYb-123"&gt;&lt;/MyB&gt;&lt;MyB myB="MYb-456"&gt;&lt;/MyB&gt;&lt;MyB myB="MYb-123-bis"&gt;&lt;/MyB&gt;&lt;/MyAB&gt;&lt;MyAC&gt;&lt;MyC myC="mycR"&gt;&lt;/My M&amp;; &lt;MyTag1 myAttr1="myVal1c" myAttr2="myVal2c"&gt;&lt;MyTag2 myAttr3="myVal3c" myAttr4="myVal4c"&gt;MyText1c&lt;/MyTag2&gt;&lt;MyTag2 myAttr3="myVal3cPos" myAtt  &lt;TagT attrT="valueT"&gt;TextT-pr