File Coverage

blib/lib/XML/TMX/Reader.pm

Criterion	Covered	Total	%
statement	159	208	76.4
branch	60	104	57.6
condition	26	43	60.4
subroutine	25	32	78.1
pod	6	6	100.0
total	276	393	70.2

package XML::TMX::Reader;
$XML::TMX::Reader::VERSION = '0.39';
# ABSTRACT: Perl extension for reading TMX files

use 5.010;
use warnings;
use strict;
use Exporter ();

use XML::DT;
use XML::TMX::Writer;
use File::BOM qw( open_bom);

our @ISA = 'Exporter';
our @EXPORT_OK = qw();


sub new {
    my ($class, $file) = @_;

    return undef unless -f $file;
    my $self = bless {
                      encoding => _guess_encoding($file),
                      filename => $file,
                      ignore_markup => 1,
                     } => $class;
    $self->_parse_header;
    return $self;
}

sub _guess_encoding {
    my $file = shift;
    my $encoding = 'UTF-8';
    my $enc = open_bom (my $fh, $file, ":utf8"); # or die "can't open $file ($!)";
    $encoding= $enc  if $enc;
    my $line = <$fh>;
    if ($line =~ /encoding=['"]([^'"]+)['"]/) {
        $encoding = $1;
    }
    #print STDERR "Debug: defuse.ENC= $enc; enc=$encoding\n";
    close $fh;
    return $encoding;
}

sub _enc2bin{ my $enc=shift;
    if($enc =~ /utf.*8/i){
        $enc = "utf8"
    }
    else {$enc = "encoding($enc)"}
    return ":$enc";
}

sub _parse_header {
    my $self = shift;

    my $header = "";
    {
        my $fh;
        local $/ = "";
        open_bom($fh, $self->{filename},_enc2bin($self->{encoding})) ;#  or die "$!";
        #print STDERR "Debug2: defuse.ENC= $!- ; enc=$self->{encoding}\n";
        $header = <$fh>;
        close $fh;
    }

    $header =~ s/^.*(
    $header =~ s/(<\/header>).*$/$1/s;

    $header =~ s!().*$!$1!s;

    dtstring($header => (
                         'header' => sub {
                             $self->{header}{$_} = $v{$_} for (keys %v);
                         },
                         'prop' => sub {
                             $v{type} ||= "_";
                             push @{$self->{header}{-prop}{$v{type}}}, $c;
                         },
                         'note' => sub {
                             push @{$self->{header}{-note}}, $c;
                         },
                        ));
}


sub ignore_markup {
  my ($self, $opt) = @_;
  $opt = 1 unless defined $opt;
  $self->{ignore_markup} = $opt;
}


sub languages {
    my $self = shift;
    my %languages = ();
    $self->for_tu({proc_tu => 100},
                  sub {
                      my $tu = shift;
                      for ( keys %$tu ) {
                          $languages{$_}++ unless m/^-/;
                      }
                  } );
    return keys %languages;
}


sub _merge_notes {
    my ($orig, $new) = @_;

    $orig //= [];
    $orig = [$orig] unless ref $orig eq "ARRAY";
    $new  = [$new]  unless ref $new  eq "ARRAY";

    push @$orig => grep { my $x = $_; !grep { $x eq $_} @$orig } @$new;

    return $orig;
}

sub _merge_props {
    my ($orig, $new) = @_;
    die "-prop should be hash" if $orig and ref $orig ne "HASH";
    die "-prop should be hash" if $new  and ref $new  ne "HASH";

    for my $key (keys %$new) {
        $orig->{$key} = _merge_notes($orig->{$key}, $new->{$key});
    }
    return $orig;
}

sub _compute_header {
    my ($current, $conf) = @_;
    my %header = %$current;
    if (exists($conf->{-note})) {
        $header{-note} = _merge_notes($header{-note}, $conf->{-note});
    }
    if (exists($conf->{-prop})) {
        $header{-prop} = _merge_props($header{-prop}, $conf->{-prop});
    }
    return \%header;
}

sub for_tu {
    my $self = shift;
    my $conf = { -header => 1 };
    my $i = 0;

    ref($_[0]) eq "HASH" and $conf = {%$conf , %{shift(@_)}};

    my $code = shift;
    die "invalid processor" unless ref($code) eq "CODE";

    local $/;

    my $outputingTMX = 0;
    my $tmx;
    my $data;
    my $gen=0;
    my %h = (
             -type => { tu => 'SEQ', tuv => 'SEQ' },
             tu  => sub {
                 my $tu;
                 for my $va (@$c) {
                     if ($va->[0] eq "-prop") {
                         push @{$tu->{$va->[0]}{$va->[1]}}, $va->[2]
                     } elsif ($va->[0] eq "-note") {
                         push @{$tu->{$va->[0]}}, $va->[1]
                     } else {
                         $tu->{$va->[0]} = $va->[1]
                     }
                 }
                 my ($ans, $v) = $code->($tu, \%v);

                 # Check if the user wants to create a TMX and
                 # forgot to say us
                 if (!$outputingTMX && $ans && ref($ans) eq "HASH") {
                     $outputingTMX = 1;
                     $tmx = XML::TMX::Writer->new();
                     if ($conf->{-header}) {
                         my $header = _compute_header($self->{header}, $conf);
                         $tmx->start_tmx(encoding => $self->{encoding}, %$header);
                     }
                 }
                 # Add the translation unit
                 if ($ans && ref($ans) eq "HASH") {
                     $gen++;
                     %v = %$v if ($v && ref($v) eq "HASH");

                     my %ans = (%v, %$ans);
                     $ans{"-n"}=$i if $conf->{n} ;
                     $tmx->add_tu(-verbatim => $conf->{-verbatim}, %ans);
                 }
             },

             tuv  => sub {
                 my $tuv;
                 for my $v (@$c) {
                     if ($v->[0] eq "-prop") {
                         push @{$tuv->{$v->[0]}{$v->[1]}}, $v->[2]
                     } elsif ($v->[0] eq "-note") {
                         push @{$tuv->{$v->[0]}}, $v->[1]
                     } elsif ($v->[0] eq "-cdata") {
                         $tuv->{-iscdata} = 1;
                         $tuv->{-seg} = $v->[1];
                     } else {
                         $tuv->{-seg} = $v->[0];
                     }
                 }
                 [ $v{lang} || $v{'xml:lang'} || "_" => $tuv ]
             },
             prop => sub { ["-prop", $v{type} || "_", $c] },
             note => sub { ["-note" , $c] },
             seg  => sub {
                 return ($v{iscdata}) ? [ -cdata => $c ] : [ $c ]
             },
             -cdata => sub {
                father->{'iscdata'} = 1; $c },
             hi   => sub { $self->{ignore_markup}?$c:toxml },
             ph   => sub { $self->{ignore_markup}?$c:toxml },
            );


    $/ = "\n";

    $h{-outputenc} = $h{-inputenc} = $self->{encoding};

    my $resto = "";
    ## Go through the header...
    my $fh;
    open_bom($fh, $self->{filename},_enc2bin($self->{encoding})) ;#  or die "$!";
    #print STDERR "Debug2: defuse.ENC= $! ; enc=" ,_enc2bin($self->{encoding}),"\n";
    while (<$fh>) {
        next if /^\s*$/;
        last if /
    }

    if (m!(.*?)()(.*)!s) {
        $resto = $3;
    }


    # If we have an output filename, user wants to output a TMX
    $conf->{-output} = $conf->{output} if defined($conf->{output});
    if (defined($conf->{-output})) {
        $outputingTMX = 1;
        $tmx = XML::TMX::Writer->new();
        if ($conf->{-header}) {
            my $header = _compute_header($self->{header}, $conf);
            $tmx->start_tmx(encoding => $self->{encoding},
                            -output  => $conf->{-output},
                            %$header);
        }
    }

    $/ = "";
    $conf->{-verbose}++ if $conf->{verbose};
    print STDERR "." if $conf->{-verbose};
    while (<$fh>) {
        ($_ = $resto . $_ and $resto = "" ) if $resto;
        last if /<\/body>/;
        $i++;
        print STDERR "\r$i" if $conf->{-verbose} && !($i % 10);
        last if defined $conf->{proc_tu} && $i > $conf->{proc_tu} ;
        last if defined $conf->{gen_tu}  && $gen > $conf->{gen_tu};
#       next if defined $conf->{patt}    && !m/$conf->{patt}/     ;

        if (defined $conf->{patt}){      ## FIXME untested
           if(ref($conf->{patt})){       ## EN=>/cat/ PT=>/gato/
              my $ok = 1;
              my $textli = "";
              for my $li (keys %{$conf->{patt}}){
                 my $patli= $conf->{patt}{$li};
                 if (m!lang=["']$li['"](.*?)!is ) { $textli = $1 };
                 $ok &&= ($textli =~ /$patli/)
              }
              next unless $ok
           }
           else {                        ## /cat.*/
              next if not m/$conf->{patt}/    ;
           }
        }
        ####
        # This can't be done. Not sure why it was being done.
        # So, please, unless you know the implications for tagged crpora
        # do not uncomment it.
        #       s/\>\s+/>/;
        undef($data);
        if ($conf->{'-raw'}) {
            my $ans = $code->($_);
            if ($conf->{-output}) {
                $ans->{"-n"}=$i if $conf->{n} ;
                $tmx->add_tu(-raw => $ans);
            }
        } else {
            eval { dtstring($_, %h) } ; ## dont die in invalid XML
            warn $@ if $@;
        }
    }
    print STDERR "\r$i\n" if $conf->{-verbose};
    close $fh;


    $tmx->end_tmx if $conf->{-header} && $outputingTMX;
}


sub to_html {
  my $self = shift;
  my %opt = @_;
  my @ls=$self->languages;
  my $html="". join("\n",map{""} @ls) ."\n"; $_




 



  
0
  




 





 





 





 





 



   




311




 





 





 





 





 





 



   $self->for_tu(sub { 




312



  
0
  




 





 




  
0
  




 





 



       my ($langs, $opts) = @_; 




313



  
0
  




 





 





 





 





 



       my $ret = ""; # ""; " " \n" $ret\n\n"; 




314



  
0
  




 





 





 





 





 



       for (@ls) {  




315



  
0
  



  
  0
  




 





 





 





 



          if( defined $langs->{$_}){ 




316



  
0
  




 





 





 





 





 



             $ret .= "\n\t$langs->{$_}{-seg}




317




 





 





 





 





 





 



          } 




318




 





 





 





 





 





 



          else { 




319



  
0
  




 





 





 





 





 



             $ret .= "\n\t




320




 





 





 





 





 





 



          } 




321




 





 





 





 





 





 



       }  




322




 





 





 





 





 





 



   




323




 





 





 





 





 





 



         #if ($opt{icons}) { 




324




 





 





 





 





 





 



         #                    $ret .= "" 




325




 





 





 





 





 





 



         #                } else { 




326




 





 





 





 





 





 



         #                    $ret .= "$_" 




327




 





 





 





 





 





 



         #                } 




328




 





 





 





 





 





 



         #                $ret .= "$langs->{$_}{-seg}




329



  
0
  




 





 





 





 





 



       $html.= "




330



  
0
  




 





 





 





 





 



       return "" 




331




 





 





 





 





 





 



     } 




332



  
0
  




 





 





 





 





 



    ); 




333



  
0
  




 





 





 





 





 



    return $html; 




334




 





 





 





 





 





 



 } 




335




 





 





 





 





 





 



   




336




 





 





 





 





 





 



 sub for_tu2 { 




337



  
0
  




 





 




  
0
  



  
1
  




 



     warn "Please update your code to use 'for_tu'\n"; 




338




0





 





 





 





 





 



     &for_tu; 




339




 





 





 





 





 





 



 } 




340




 





 





 





 





 





 



   




341




 





 





 





 





 





 



   




342




 





 





 





 





 





 



 1; 




343




 





 





 





 





 





 



   




344




 





 





 





 





 





 



 __END__
  $self->for_tu(sub {
      my ($langs, $opts) = @_;
      my $ret = ""; # ""; " " \n" $ret\n\n"; 




314



  
0
  




 





 





 





 





 



       for (@ls) {  




315



  
0
  



  
  0
  




 





 





 





 



          if( defined $langs->{$_}){ 




316



  
0
  




 





 





 





 





 



             $ret .= "\n\t$langs->{$_}{-seg}




317




 





 





 





 





 





 



          } 




318




 





 





 





 





 





 



          else { 




319



  
0
  




 





 





 





 





 



             $ret .= "\n\t




320




 





 





 





 





 





 



          } 




321




 





 





 





 





 





 



       }  




322




 





 





 





 





 





 



   




323




 





 





 





 





 





 



         #if ($opt{icons}) { 




324




 





 





 





 





 





 



         #                    $ret .= "" 




325




 





 





 





 





 





 



         #                } else { 




326




 





 





 





 





 





 



         #                    $ret .= "$_" 




327




 





 





 





 





 





 



         #                } 




328




 





 





 





 





 





 



         #                $ret .= "$langs->{$_}{-seg}




329



  
0
  




 





 





 





 





 



       $html.= "




330



  
0
  




 





 





 





 





 



       return "" 




331




 





 





 





 





 





 



     } 




332



  
0
  




 





 





 





 





 



    ); 




333



  
0
  




 





 





 





 





 



    return $html; 




334




 





 





 





 





 





 



 } 




335




 





 





 





 





 





 



   




336




 





 





 





 





 





 



 sub for_tu2 { 




337



  
0
  




 





 




  
0
  



  
1
  




 



     warn "Please update your code to use 'for_tu'\n"; 




338




0





 





 





 





 





 



     &for_tu; 




339




 





 





 





 





 





 



 } 




340




 





 





 





 





 





 



   




341




 





 





 





 





 





 



   




342




 





 





 





 





 





 



 1; 




343




 





 





 





 





 





 



   




344




 





 





 





 





 





 



 __END__
      for (@ls) {
         if( defined $langs->{$_}){
            $ret .= "\n\t
         }
         else {
            $ret .= "\n\t
         }
      }

        #if ($opt{icons}) {
        #                    $ret .= ""
        #                } else {
        #                    $ret .= "$_"
        #                }
        #                $ret .= "
      $html.= "
      return ""
    }
   );
   return $html;
}

sub for_tu2 {
    warn "Please update your code to use 'for_tu'\n";
    &for_tu;
}


1;

__END__