#!/usr/bin/perl
# Time-stamp: <2007-09-02 01:00:32 phm>
BEGIN { $ENV{PATH} = '/bin:/usr/bin:/usr/local/bin' };
package A2E::Tratext;
use base A2E::db;
use strict;
use POSIX qw(strftime);
use English -no_match_vars;
umask oct('002');
use utf8;
binmode STDIN, ':utf8';
binmode STDOUT, ':utf8';
binmode STDERR, ':utf8';
use Encode qw(_utf8_on);
use IO::File;
use A2E::CJK2ASC;
use Data::Dumper;
use A2E::CString;

our @tratext_params = qw(tratext_etcdir cjk2asc_names cjk2asc_files table nlin JA_EN verbose debug localhost interact nolookup reset_reks prefer_file_over_db write_file nlin_skip);
our $optvals0 = {
    table => 'jaen',
    tratext_etcdir => '/usr/local/etc/tratext',
    cjk2asc_names => [ 'cjk2asc', 'cjk2asc_en' ],
    verbose => $ENV{VERBOSE},
    debug => $ENV{debug},
    localhost => 0, 
    interact => $ENV{interact},
    reset_reks => 0,
    prefer_file_over_db => 0,
    write_file => 0,
    nlin_skip => 0,
    nolookup => 0,
    nlin => 0,
    JA_EN => {},
};
our ($fo_h, $fi_h) = ();
our @id_chars = (65..90, 97..122, 49..57, 95);
our @deplate_macro_name_end_chars = (32, ord("\t"), ord("\n"), 58, 125);
our @latin_spaces = (9, 32);
our @cjk_spaces = (12288);
our @spaces = (@latin_spaces, @cjk_spaces);
our @cjk_colons = (65306);
our @colons = (58, @cjk_colons);
our @cjk_numerals = (65296..65305);
our @latin_numerals = (48..57);
our @numerals = (@latin_numerals, @cjk_numerals);
our @cjk_footnote_marks = (65290);
our @latin_footnote_marks = (42);
our @footnote_marks = (@latin_footnote_marks, @cjk_footnote_marks);
our @cjk_blanks = (12288);
our @latin_blanks = (9, 32);
our @blanks = (@latin_blanks, @cjk_blanks);
our @cjk_periods = (12290); # "。"
our @latin_quote_chars = (34, 39);;
our @latin_closing_chars_non_deplate = (41, 93);
our @latin_opening_chars = (40, 91, 123, 171);
our @latin_closing_chars = (41, 93, 125, 187);
our @latin_opening_chars_non_deplate = (40, 91);
our @cjk_closing_chars = (65289, 12301);
our @closing_chars_non_deplate = (@latin_closing_chars_non_deplate, @cjk_closing_chars);
our @closing_chars = (125, @closing_chars_non_deplate);
our @cjk_opening_chars = (65288, 12300);
our @opening_chars_non_deplate = (@latin_opening_chars_non_deplate, @cjk_opening_chars);
our @opening_chars = (123, @opening_chars_non_deplate);
our %opening_closers = (40 => 41, 91 => 93, 123 => 125, 171=>187, 65288 => 65289, 12300=>12301);
our %closing_openers = (41 => 40, 93 => 90, 125 => 123, 187=>171, 65289 => 65288, 12301=>12300);

sub set_dvar { # set debug variable
    my $self = shift;
    return unless $self->{debug};
    my $var = shift;
    my $val = shift;
    $self->{dvar}->{$var} = $val;
};

sub new_vals ($$) {
    my $self = shift;
    my $optvals = shift;
    for (@tratext_params) {
	next unless defined $optvals->{$_};
	$self->{$_} = $optvals->{$_};
    };
    for (@tratext_params) {
	next if defined $self->{$_};
	$self->{$_} = $optvals0->{$_};	
    };
    $self->{cjk2asc_files} = [ map { join('/', $self->{tratext_etcdir}, join('.', $_, 'tab')) } @{$self->{cjk2asc_names}} ] unless $self->{cjk2asc_files} and @{$self->{cjk2asc_files}};
    $self->{cjk2asc} = new A2E::CJK2ASC @{$self->{cjk2asc_files}};
    $self->{lookup_function} = $self->make_lookup;
    $self->{cs} = new A2E::CString [], $self, { lookup => $self->{lookup_function}, verbose => $self->{verbose}, debug => $self->{debug} };
    $self->{vars} = {};
    $self->set_timestamp;
    $self->{dvars} = {};
    $self->{skip_until} = [];
    $self->{columns} = {};
    return $self; # redundant
};

sub set_timestamp {
    my $self = shift;
    $self->{timestamp} = strftime('%Y%m%d%H%M%S', localtime(time));
}

sub syntax_die {
    my $self = shift;
    my $msg = shift;
    $self->{error} = { typ => { user=>1 }, msg => $msg };
    die "user syntax error at line $self->{nlin} in file $self->{fi}:\n\t$msg";
};
sub syntax_warn {
    my $self = shift;
    my $msg = shift;
    $self->{error} = { typ => { user => 1, warn => 1 }, msg => $msg };
    warn "user syntax error at line $self->{nlin} in file $self->{fi}:\n\t$msg";
};
sub weird_die {
    my $self = shift;
    my $msg = shift;    
    $self->{error} = { typ => { prog=>1 }, msg => $msg };
    die "internal error at line $self->{nlin} in file $self->{fi}:\n\t$msg";
};
sub raise {
    my $self = shift;
    my $error = shift;
    return unless $error;
    return unless %$error;
    $self->{error} = $error;
    my $typ = join ' ', keys %{$error->{typ}};
    my $msg = $error->{msg};
    die "$typ error at line $self->{nlin} in file $self->{fi}:\n\t$msg";
};
sub debug {
    my $self = shift;
    my $on_off = shift;
    $self->{debug} = $on_off;
    $self->{cs}->{debug} = $on_off;
    $self->{cjk2asc}->{debug} = $on_off;
    return $on_off;
};

sub pick_old_or_new {
    my $self = shift;
    my $ja = '';
    $ja = shift;
    my $en0 = '';
    $en0 = shift;
    my $en1 = '';
    $en1 = shift; 
    my $en = '';
    $self->decho("start pick_old_or_new with ja $ja, en0 $en0, en1 $en1");
    my $num = 0;
  INTERACTION: {
      print STDERR "Input string\n  1\t".$en1."\nat line ".$self->{nlin}." of file ".$self->{fi}." differs from existing\n  0\t".$en0."\n. Both are translations of\n\t".$ja."\n. Default is $self->{prefer_file_over_db}.\n  Please pick 0, 1 or write your own text\n  here: ";
      $num = <STDIN>;
      chomp $num;
      local $_ = $num;
      m(\A1\Z) && do { $en = $en1;last };
      m(\A0\Z) && do { $en = $en0;last };
      m(\A\Z) && do { $en = $self->{prefer_file_over_db} ? $en : $en0;last };
      m(\A(.*\S{2}.*)\Z) && do { $en = $1;last };
      redo INTERACTION;
  };
    print "ACK\t".$en."\nOK\n";
    weird_die "en is still null even after PICK" unless length($en) > 0;
    $self->decho("from pick_old_or_new return $en");
    return $en;
};

sub lookup_and_put {
    my $self = shift;
    my $ja = '';
    $ja = shift;
    my $en = '';
    $en = shift;
    my $mlexp_found = $en;
    $self->decho("start lookup_and_put\n\tja: $ja\n\ten: $en");
  NOLOOKUP: {
      last unless $self->{nolookup};
      $self->decho("from lookup_and_put nolookup return $en");
      return $en;
  };
  SET_EN: {
      $_ = $en;
      $en = m(\A\?[\?\s]+\Z) ? '' : $_;
      $self->decho("in lookup_and_put set_en en to $en");
  };
    local $_;
    my $en0 = '';
  LOOKUP_CACHE: {
      $en0 = $self->{JA_EN}->{$ja};
      $self->decho("lookup_and_put lookup_cache found en0 $en0");
      last if length($en0) == 0;
      $self->decho("from lookup_and_put lookup_cache return $en0");
      return $en0;
  };
  LOOKUP_DB: {
      $en0 = $self->lookup($ja);
      $self->decho("in lookup_and_put lookup_db en0 $en0");
  };
  FIND: {
      last if length($en0) == 0;
      last if length($en) == 0;
      last if lc($en) eq lc($en0);
      if ($self->{interact}) {
	  $en = $self->pick_old_or_new($ja, $en0, $en);
      } else {
	  $en = $self->{prefer_file_over_db} ? $en : $en0;
      };
      $self->{JA_EN}->{$ja} = $en;
  };
    $en ||= $en0;
    my $ok = ($mlexp_found || length($en) > 0) ? 'true' : '';
  DBPUT: {
    NO_DBPUT: {
	last unless $ok;
	last DBPUT if $en eq $en0;
    };
      $self->put($self->{table}, { ja=>$ja }, en=>$en, ok=>$ok, file=>$self->{fi}, dok=>$self->{dok}, line=>$self->{nlin});
  };
    $self->decho("from lookup_and_put end return $en");
    return $en;
};

sub contains_mlexp {
    my $self = shift;
    my $s0 = shift;
    $self->decho("start contains_mlexp with $s0");
    local $_ = $s0;
    my @matches = m((.*)\{ml\b([^\{\}]+)\bja\=\"?([^\"]+)\"?\:([^\{\}]*)\}(.*));
  NO_MATCHES: {
      last if @matches;
      $self->decho("from contains_mlexp no_matches return");
      return;
  };
    # my ($pre, $ifx, $ja, $en, $post) = ('', '', '', '', ''); # reduce debug log noise
    my ($pre, $ifx, $ja, $en, $post) = @matches;
  EMPTY_MATCH: {
      last if length($ja) > 0;
      $self->decho("from contains_mlexp empty_match return");      
      return;
  };
    $en = $self->lookup_and_put($ja, $en);
    $en ||= '??';
    my $mlexp = sprintf '{ml%sja="%s":%s}', $ifx, $ja, $en;
    my $s = ($self->contains_mlexp($pre) || $pre) . $mlexp . ($self->contains_mlexp($post) || $post);
    $self->decho("from contains_mlexp end return $s");
    return $s;
};

sub parse_vok_args {
    # start on initial char of first argument
    # receive expected end_chr 41 or 125 and chars of string to be parsed
    # return delta p of original string and expanded string, not including end_chr
    my $self = shift;
    my $end_ch = shift;
    $self->weird_die("in parse_vok_args: end_ch $end_ch should be a closing bracket") unless grep { $_ == $end_ch } @latin_closing_chars;
    my $end_chr = chr $end_ch;
    my @chars = @_;
    my $s0 = pack 'U*', @chars; # used for debugging only
    $self->decho("start parse_vok_args with end_chr $end_chr and packed chars $s0");
    my $len = scalar @chars;
    my $s = '';
    my $p = 0;
    my $p0 = 0;
    my $pd = 0;
    my $sd = '';
    my $ch = $chars[$p];
    my $chr = chr $ch;
    my $arg1_is_macro_p = $ch == 123;
    if ($arg1_is_macro_p) {
	($pd, $sd) = $self->parse_macro(@chars[$p..$#chars]);
	$s .= $sd;
	$p += $pd;
    } else {
	$self->syntax_die("deplate macro vok: argument 1 must consist of an identifier or a deplate macro p $p in s0 $s0") unless grep { $_ == $chars[$p] } @id_chars;
	$p++;
	$p++ while grep { $_ == $chars[$p] } @id_chars;
	$s .= pack 'U*', @chars[0..$p-1];
    };
    $ch = $chars[$p];
    $chr = chr $ch;
    if ($ch == $end_ch) {
      SYNTAX_WARN: { 
	  last unless $arg1_is_macro_p;
	  $self->syntax_warn("You used macro $sd as argument 1 to vok, immediately followed by a closing brace $chr.  It seems the vok macro call is redundant here.");
      };
	$self->decho("from parse_vok_args simply return $p, $s");
	return $p, $s;
    };
    my $sep_ch = $ch;
    my $sep_chr = chr $sep_ch;
    my $n_arg = 1;
    $s .= $sep_chr;
    $self->decho("in parse_vok_args up to sep_chr $sep_chr at p $p end of arg $n_arg $s");
    $p++;$p0 = $p;$n_arg++;
  CHAR: while ($p < $len) {
	$ch = $chars[$p];
	$chr = chr $chr;
	if ($ch == 123) {
	    $self->decho("in parse_vok_args char found $chr at $p in $s0");
	    $s .= $self->make_mlexp(pack 'U*', @chars[$p0..$p-1]) if $p > $p0;
	    ($pd, $sd) = $self->parse_macro(@chars[$p..$#chars]);
	    $p += $pd;
	    $s .= $sd;
	    $p0 = $p;
	    $self->decho("in parse_vok_args char parsed to $p of $s"); 
	} elsif ($ch == $sep_ch) {
	    $sd = $self->make_mlexp(pack 'U*', @chars[$p0..$p-1]);
	    $s .= $sd . $sep_chr;
	    $self->decho("vok_args char: added arg $n_arg $sd and $sep_chr at p $p, got s $s");
	    $p++;$n_arg++;
	    $ch = $chars[$p];
	    if (grep { $_ == $ch } @latin_opening_chars_non_deplate) {
		$p++;
		($pd, $sd) = $self->parse_vok_args($opening_closers{$ch}, @chars[$p..$#chars]);
		$p += $pd;$s .= '('.$sd.')';
		$p++;$ch = $chars[$p];$chr = chr $ch;
		$self->syntax_die("vok sub-invocation should not end with $chr but with $sep_chr or $end_chr") unless grep { $_ == $ch } $sep_ch, $end_ch;
		$p0 = $p + 1;
	    };
	    $p0 = $p;
	} elsif ($ch == $end_ch) {
	    $sd = $self->make_mlexp(pack 'U*', @chars[$p0..$p-1]);
	    $s .= $sd;
	    $self->decho("from parse_vok_args return $p, $s");
	    return $p, $s;
	} else {
	    $p++;
	};
    };
    $self->syntax_die("parse_vok_args: no $end_chr found up to p $p in s0 $s0");
};

sub parse_body {
    # return body part of deplate macro
    # including the final '}'
    # in_args: $self, $verb, $attrs, @chars 
    # out_args: $pd, $sd
    # ($pd, $sd) = $tt->parse_body('ml', { ja=>$ja }, unpack('U*', '??}') );
    my $self = shift;
    my $verb = shift;
    my $attrs = shift;
    my @chars = @_;
    my $s0 = pack 'U*', @chars;
    $self->decho("start parse_body with $s0");
    my $closers = [ 125 ];
    my $p = 0;
    my $p0 = $p;
    my $pd = 0;
    my $sd = '';
    my $len = scalar @chars;
    my $ch = $chars[$p];
    my $chr = chr $ch;
    my $s = '';
    my %END_OK = ();
  TRY_VOK: {
      last unless $verb =~ m(\Avok\Z);
      ($pd, $sd) = $self->parse_vok_args(125, @chars[$p..$#chars]);
      $self->decho("in parse_body try_vok add pd $pd to p $p, sd $sd to s $s");
      $p += $pd + 1;
      $s .= $sd . '}';
      $self->decho("from parse_body try_vok after $chr return p $p, s $s");
      return $p, $s;
  };
  TRY_ML: {
      last unless $verb =~ m(\Aml\Z);
      my $ja = $attrs->{ja};
      $self->syntax_die("no attribute ja found in macro ml of $s0") unless $ja;
    ML_TEXT_CHAR: while ($p < $len) {
	$ch = $chars[$p];
	$END_OK{ML_TEXT_CHAR} = $ch == 125;
	last if $END_OK{ML_TEXT_CHAR};
	if (($ch == 123) and not ($chars[$p-1] == 92)) {
	    $self->syntax_die("ml macro argument contains macro opening brace at $p in $s0");
	};
    } continue { $p++ };
      $self->syntax_die("parse_macro try_ml did not end correctly at $p in $s0") unless $END_OK{ML_TEXT_CHAR};
      my $en = pack 'U*', @chars[$p0..$p-1];
      $en = $self->lookup_and_put($ja, $en);
      $en ||= '??';
      $s .= $en . '}';
      $p0 = $p + 1; 
      $self->decho("from parse_body try_ml return $p0, $s");      
      return $p0, $s;
  };
  MACRO_CHAR: while ($p < $len) {
	$ch = $chars[$p];
	$chr = chr $ch;
	if ($ch == 123) {
	    $self->decho("in parse_body macro_char found $chr at $p in $s");
	    $s .= $self->trim_to_mlexp(pack 'U*', @chars[$p0..$p-1]);
	    # 2007-09-06 debug removed, recursion does this now: unshift @$closers, 125;
	    ($pd, $sd) = $self->parse_macro(@chars[$p..$#chars]);
	    $self->decho("in parse_body macro_char add $pd and $sd");
	    $p += $pd;
	    $s .= $sd;
	    $p0 = $p;
	} elsif (grep { $_ == $ch } @opening_chars_non_deplate) {
	    $self->decho("macro_char opening bracket $ch at $p in $s");
	    $self->{cs}->reset(@chars[$p..$#chars]);
	    ($pd, $sd) = $self->{cs}->read_sexp;
	    $self->raise($self->{cs}->{error});
	    if ($pd) {
		$p += $pd;
	    } else {
		$self->vecho("SYNTAX WARNING: invalid sexp at $chr at $p in $s0");
		$p++;
	    }
	} elsif (grep { $_ == $ch } @closing_chars) {
	    if ($ch == $closers->[0]) {
		$self->decho("macro_char closing bracket %s at position $p", chr($ch));
		$p++;
		shift @$closers;
		last unless scalar @$closers; 
	    } else {
		$chr = chr $ch;
		my $closer_chr = chr $closers->[0];
		$self->syntax_die("macro_char mismatched bracket $chr, expecting $closer_chr at position $p in string $s0");
		$p++;
	    };
	} else { $p++ }; 
    };
    $s .= pack 'U*', @chars[$p0..$p-1];
    $chr = chr $chars[$p-1];
    my $closers_chrs = join ', ', map { chr $_ } @$closers;
    $self->syntax_die("curly brace mismatch at position $p of deplate macro body $s0 with expected closers $closers_chrs") if @$closers;
    $self->decho("from parse_body after $chr return $p, $s");
    return $p, $s;
};

sub parse_macro {
    # return pd: length of used portion of source string
    # return sd: expanded macro string
    # return 0 and empty string if nothing was found
    my $self = shift;
    my @chars = @_;
    my $s0 = pack 'U*', @chars; # readable copy of source string for debugging only
    my $s = ''; # result string;
    $self->decho("start parse_macro with $s0");
    my $p = 0;
    my $ch = $chars[0];
    my $chr = chr $ch;
    $self->weird_die("claimed deplate macro doesnt start with curly brace: $s") unless $ch == 123;
    $p++;
    my $p0 = 1;
    my $pd = 0;
    my $sd = '';
    my $len = scalar @chars;
    $p++ while grep { $_ == $chars[$p] } @id_chars;
    my $verb = pack 'U*', @chars[1..$p-1];
    $ch = $chars[$p];
  VERB_ONLY: {
      last unless $ch == 125;
      $p0 = $p + 1;
      $s = pack 'U*', @chars[0..$p];
      $self->decho("from parse_macro verb_only return p0 $p0, s{$s}");
      return $p0, $s;
  };
    $chr = chr $ch;
    my %END_OK = ();
    my $attrs;
  SYNTAX_ERROR: {
      last if grep { $_ == $chars[$p] } @deplate_macro_name_end_chars;
      $self->syntax_die("verb $verb ended by inadmissible character $chr"); 
  };
    $self->decho("in parse_macro got verb $verb");
    $self->{cs}->reset(@chars[$p..$#chars]);
    ($pd, $attrs) = $self->{cs}->read_deplate_attrs;
    $self->raise($self->{cs}->{error});
    $p += $pd;
    $ch = $chars[$p];
    $chr = chr $ch;
    $self->weird_die("claimed macro verb does not end properly in $chr at $p in $s0") unless grep { $_ == $ch } 58, 125;
    $s = pack 'U*', @chars[0..$p];
    $self->decho("in parse_macro ch $ch chr $chr, p $p in $s0");
    $p++;
  BODY: {
      last unless $ch == 58;
      ($pd, $sd) = $self->parse_body($verb, $attrs, @chars[$p..$#chars]);
      $p += $pd;
      $s .= $sd;
  };
    $self->decho("from parse_macro return $p, $s");
    return $p, $s;
};

sub rtrim ($) {
    my $s = shift;
    my @chars = unpack 'U*', $s;
    my $p = $#chars;
    $p-- while grep { $_ == $chars[$p] } @blanks;
    $s = pack 'U*', @chars[0..$p];
    return $s;
};

 sub cjk_sentences ($$) {
    my $self = shift;
    my $s0 = shift || '';
    $self->decho("start cjk_sentences with $s0");
    my @chars = unpack 'U*', $s0;
    # $self->decho("chars: @chars");
    my $p = 0;
    my $pd = 0;
    my $p0 = $p;
    my $p1 = $p;
    my $s = '';
    my $sd = '';
    my $n_sent = 0;
    my $len = scalar @chars;
    my $closers = [];
    my $ch = 0;
    my $chr = ''; # for debugging messages only
  SUBSTRING: while ($p < $len) {
      $ch = $chars[$p];
      $chr = chr $ch;
    DEPLATE_MACRO: {
	last unless $ch == 123;
	$s .= $self->trim_to_mlexp(pack('U*', @chars[$p0..$p-1]));
	($pd, $sd) = $self->parse_macro(@chars[$p..$#chars]);
	$self->decho("in cjk_sentences substring deplate_macro add pd $pd to p $p, sd $sd to s $s");
	$p += $pd;
	$s .= $sd;
	$p0 = $p;
	# preserve trailing blanks in result string but move p0 beyond them
	$p0++ while grep { $_ == $chars[$p0] } @blanks;
	$s .= pack 'U*', @chars[$p..$p0-1];
	next SUBSTRING;
    };
    SUB_SEXP: { 
	# make sure subordinate sexps are not torn apart
	# do not generate any sub-expressions nor move the p0 counter here
	last unless grep { $_ == $ch } @opening_chars_non_deplate;
	$self->decho("in cjk_sentences substring other_sexp p $p ch $ch chr $chr");
	$self->{cs}->reset(@chars[$p..$#chars]);
	($pd, $sd) = $self->{cs}->read_sexp;
	$self->raise($self->{cs}->{error});
	if ($pd) { 
	    $p += $pd;
	} else {
	    $self->syntax_die("mismatched opening bracket $chr in $s0");
	    $p++;
	};
	next SUBSTRING;
    };
    CLOSING_CHARS: {
	last unless grep { $_ == $ch } @closing_chars;
	$self->syntax_warn("unopened brace closed by $chr at $p in $s0");
	$p++;
    };
    SENTENCE: {
	last unless grep { $_ == $ch } @cjk_periods;
	$sd = $self->trim_to_mlexp(pack 'U*', @chars[$p0..$p]);
	$s .= $sd;
	$s .= ' ' if $ch < 256;
	$self->decho("sentence added sd $sd leading to $s");
	$p++; 
	$p0 = $p;
	$p0++ while grep { $_ == $chars[$p0] } @blanks;
	$n_sent++; 
	next SUBSTRING;
    };
      if ($n_sent) { $p++;next }; # ingore any non-sentence junctures inside sentences
    BLANK_SEPARATED: {
	last unless (grep { $_ == $ch } @blanks) and (grep { $_ > 8192 } @chars[$p0..$p]);
	$sd = $self->trim_to_mlexp(pack 'U*', @chars[$p0..$p-1]);
	$s .= $sd;
	$s .= ' ';
	$self->decho("blank_separated added $sd and blank leading to $s");
	$p0 = $p + 1;
	$p0++ while grep { $_ == $chars[$p0] } @blanks;
	$p++;
	next SUBSTRING;
    };
    COLON_SEPARATED: {
	last unless grep { $_ == $ch } @colons;
	last unless ($ch > 255) or grep({ $_ == $chars[$p+1] } @blanks);
	$sd = $self->trim_to_mlexp(pack 'U*', @chars[$p0..$p-1]);
	$s .= $sd . ': ';
	$self->decho("colon_separated added $sd and colon leading to $s");
	$p++;
	$p0 = $p;
	$p0++ while grep { $_ == $chars[$p0] } @blanks;
	next SUBSTRING;
    };
    NO_JUNCTURE_FOUND: {
	$p++;
    };
  }; # end of SUBSTRING loop
    $s .= $self->trim_to_mlexp(pack 'U*', @chars[$p0..$#chars]) if $p0 < $len;
    $s = rtrim $s;
    $self->decho("from cjk_sentences return $s");
    return $s;
};

sub make_mlexp ($$) {
    my $self = shift;
    my $s0 = shift;
    my $s = '';
    $self->decho("start make_mlexp with $s0");
  REFUSE_EMPTY: {
      last if length($s0) > 0;
      $self->decho("from make_mlexp refuse_empty return");
      return;
  };
  REFUSE_NON_BIGCHAR_P: {
      last if $self->{cjk2asc}->bigchar_p($s0);
      $s = $self->{cjk2asc}->map_symbols($s0);
      $self->decho("from make_mlexp refuse_non_bigchar_p return $s");
      return $s;
  }; 
  REFUSE_MLEXP: {
      $s = $self->contains_mlexp($s0);
      last unless length($s) > 0;
      $self->decho("from make_mlexp refuse_mlexp return $s");
      return $s;
  };
    my $en = $self->lookup_and_put($s0);
    $en ||= '??';
    $s = sprintf '{ml ja="%s":%s}', $s0, $en;
    $self->decho("from make_mlexp finally return $s");
    return $s;
};

sub trim_to_mlexp {
    my $self = shift;
    my $s = shift || '';
    $self->decho("start trim_to_mlexp with s q{$s}");
    return unless length($s) > 0;
    $s = $self->trim_edges($s, \&make_mlexp);
    $self->decho("from trim_to_mlexp return $s");
    return $s;
}; 

sub trim_edges {
    my $self = shift;
    my $s = shift;
    my $midfun = shift;
    $self->decho("start trim_edges with s $s and midfun $midfun");
    $self->weird_die("invalid function reference") unless ref $midfun;
  NULL_STRING: {
      last if length($s) > 0;
      $self->decho("from trim_edges null_string return");
      return '';
  };
    my @chars = unpack 'U*', $s;
    my $p = 0;
    my $p0 = 0;
    my $p1 = $#chars;
    my $ch = 0;
    my $chr = '';
    my $pd = 0;
    my $sd = '';
    my ($left, $mid, $right) = ('', '', '');
  LEFT_BLANKS: while ($p0 <= $#chars) {
      last unless grep { $_ == $chars[$p0] } @blanks;
  } continue { $p0++ };
  RIGHT_BLANKS: while ($p1 >= $p0) {
      last unless grep { $_ == $chars[$p1] } @blanks;
  } continue { $p1-- };
  TRIM_NON_BLANKS: {
      $self->decho("in trim_edges start trim_non_blanks leave if p1 $p1 leq p0 $p0");
      last if $p1 <= $p0;
    RECUR_CHOP: { # chop off trailing parentheses (sexps)
	$self->decho("in trim_edges start recur_chop with p0 $p0 p1 $p1");
	last unless grep { $_ == $chars[$p1] } @closing_chars_non_deplate;
	$self->{cs}->reset(@chars[$p0..$p1]);
	($pd, $sd) = $self->{cs}->read_sexp_to_left($p1-$p0);
	$self->raise($self->{cs}->{error});
	$self->decho("in trim_edges leave recur_chop unless pd $pd, p0 $p0, p1 $p1, sd q{$sd}");
	last RECUR_CHOP unless $pd;
	my $pm = $p1 - $pd;
	my $s1 = $pm >= 0 ? $self->trim_edges(pack('U*', @chars[$p0..$pm]), $midfun) : '';
	$self->decho("in trim_edges recur_chop pm $pm, s1 q{$s1}");
	my $s2 = ($chars[$pm+1] > 255 ? ' ' : '') . $self->{cjk2asc}->symchar($chars[$pm+1]) . $self->trim_edges(pack('U*', @chars[$pm+2..$p1-1]), $midfun) . $self->{cjk2asc}->symchar($chars[$p1]);
	$self->decho("in trim_edges recur_chop s2 q{$s2}");
	$mid = $s1 . $s2;
	$self->decho("in trim_edges recur_chop leave trim_non_blanks with mid q{$mid}");
	last TRIM_NON_BLANKS;
	$self->decho("in trim_edges leave recur_chop with p0 $p0, p1 $1");
    }; # RECUR_CHOP
    TRIM_COLONS_FOOTNOTES: { # chop *1, : et al from right side
	$self->decho("in trim_edges start trim_colons_footnotes with p0 $p0, p1 $p1");
	$p0++ while grep { $_ == $chars[$p0] } @cjk_blanks;
	while (grep { $_ == $chars[$p1] } @cjk_blanks) {
	    $p1--;
	    last if $p1 < 0;
	};
	last TRIM_NON_BLANKS if $p1 < $p0;
      COLON: { # trim ':' and the like from the right
	  $ch = $chars[$p1];
	  $chr = chr $ch;
	  $self->decho("in trim_edges start colon leave unless chr $chr in colons");
	  last unless grep { $_ == $ch } @colons;
	  $self->decho("in trim_edges colon $chr at p1 $p1");
	  $p1--;
	  $self->decho("in trim_edges colon p1 to $p1 redo");
	  redo TRIM_NON_BLANKS;
      };
      FOOTNOTE: { # trim '*1' and the like from the right
	  $self->decho("in trim_edges start footnote");
	  last unless grep { $_ == $chars[$p1] } @numerals;
	  $self->decho("in trim_edges footnote found numeral");
	  my $p2 = $p1;
	  $p2--;
	  $p2-- while grep { $_ == $chars[$p2] } @numerals;
	  last unless grep { $_ == $chars[$p2] } @footnote_marks;
	  $self->decho("in trim_edges footnote found mark");
	  $p1 = $p2;
	  $p1--;
	  $self->decho("in trim_edges leave footnote at p1 $p1");
	  redo TRIM_NON_BLANKS;
      };
	#bloko BRACKET estis tcitie, movatis al Tratext.old tagante 2007-09-06
	$self->decho("in trim_edges leave trim_colons_footnotes with p0 $p0, p1 $p1");
    }; # TRIM_NON_BLANKS
      $self->decho("in trim_edges trim_non_blanks end with p0 $p0, p1 $p1");
  }; # TRIM_NON_BLANKS
  RESTORE_EDGES: { # put the unparsed edges back on
      ($left, $right) = ('', '');
      $self->decho("in trim_edges start restore_edges with p0 $p0, p1 $p1");
    SET_LEFT: {
	$self->decho("in trim_edges set_left leave unless p0 $p0 gt 0");
	last unless $p0 > 0;
	$left = join '', $self->{cjk2asc}->map_symchars(@chars[0..$p0-1]);
	$self->decho("in trim_edges leave set_left with left [$left]");
    };
    SET_RIGHT: {
	$self->decho("in trim_edges set_right leave unless p1 $p1 lt p_chars $#chars");
	last unless $p1 < $#chars;
	$right = $self->{cjk2asc}->map_symchars(@chars[$p1+1..$#chars]);
	$self->decho("in trim_edges leave set_right with right [$right]");
    };
    SET_MID: {
	$self->decho("in trim_edges set_mid leave if mid [$mid]");
	last if length($mid) > 0;
	$self->decho("in trim_edges set_mid leave unless p1 $p1 geq p0 $p0");
	last unless $p1 >= $p0;
	$mid = pack 'U*', @chars[$p0..$p1];
	$mid = &$midfun($self, $mid);
	$self->decho("in trim_edges leave set_mid with mid [$mid]");
    };
      $s = $left . $mid . $right;
      $self->decho("in trim_edges leave restore_edges with [$s]");
  }; # RESTORE_EDGES
    $self->decho("from trim_edges return s '$s'");
    return $s;
};

sub ml_bracket ($$) {
    my $self = shift;
    local $_ = shift;
    $self->decho("start ml_bracket with $_");
    my $s = '';
  TRY_CONTAINS_MLEXP: {
      $s = $self->contains_mlexp($_);
      last unless length($s) > 0;
      $self->decho("from ml_bracket try_contains_mlexp return s{$s}");
      return $s;
  };
  TRY_NO_BIGCHAR_P: {
      my $bigchar_p = $self->{cjk2asc}->bigchar_p($_, 256);
      $self->decho("bigchar_p is $bigchar_p for $_");
      last if $bigchar_p;
      $self->decho("no bigchar found in $_");
      $s = $self->{cjk2asc}->map_symbols($_);
      $self->decho("from ml_bracket return $s");
  }; 
    $s = $self->trim_edges($_, \&cjk_sentences);
    $self->decho("from ml_bracket with trimmed edges return $s");
    return $s;
};

sub cjk_textchunks ($$) {
    my $self = shift;
    my $s = shift;
    $self->decho("start cjk_textchunks $s");
    $s = $self->cjk_sentences($s);
    $self->decho("from cjk_textchunks return $s");
    return $s;
};
sub cjk_tabcolumn ($$) {
    my $self = shift;
    my $s = shift;
    $self->decho("start cjk_tabcolumn $s");
    $s = $self->trim_to_mlexp($s);
  ESCAPE_HYPHENS: { # deplate misunderstands columns that consist of hyphens only
      local $_ = $s;
      last unless m(\A\s*\-\s*\Z);
      $self->decho("sub_tabcolumn: protect standalone hyphens with a backslash in $_");
      s(\-)(\\-);
      $s = $_;
  };
    $self->decho("from cjk_tabcolumn return $s");
    return $s;
};

sub check_columns {
    my $self = shift;
    my @columns = @_;
    my $n_columns = scalar @columns;
    $self->decho("start check_columns with n_columns $n_columns, self dok $self->{dok}, self nlin $self->{nlin}, self columns %s", Dumper($self->{columns}));
  SET_COLUMNS: {
      last if $self->{columns}->{dok} eq $self->{dok} and $self->{columns}->{nlin} == $self->{nlin} - 1;
      $self->{columns}->{n} = $n_columns;
      $self->{columns}->{dok} = $self->{dok};
      $self->{columns}->{nlin} = $self->{nlin};
      $self->decho("in check_columns from set_columns return with self columns %s", Dumper($self->{columns}));
      return $n_columns;
  };
    $self->{columns}->{nlin}++;
  SAME_COLUMNS: {
      last unless $self->{columns}->{n} == $n_columns;
      $self->decho("in check_columns from same_columns return with self columns %s", Dumper($self->{columns}));
      return $n_columns 
      };
    $self->syntax_die("wrong number of columns in table: expecting $self->{columns}->{n}, got $n_columns");
};		       

sub transtring ($$) {
    my $self = shift;
    local $_ = shift;
    $self->decho("start transtring with $_");
    my $pre_blank = '';
  TRY: {
      my ($pre, $text, $tag, $post, $key, $val, @matches) = ('', '', '', '', '', '', '', '', '', '');
      ($text) = m(\A(.*)(\s+)\Z);
      $_ = $text if $post;
    MACRO: {
	@matches = m(\A\#(\w+\b[^\:]*)\:\s*(\S.*));
	last unless @matches;
	my $macro_with_attrs = '';
	($macro_with_attrs, $_) = @matches;
	$self->decho("in transtring macro got macro_with_attrs $macro_with_attrs");
      TRY_MACRO: {
	  $self->decho("in transtring macro start try_macro _ $_");
	VAR: {
	    last unless $macro_with_attrs eq 'VAR';
	    @matches = m(\A(\w+)\s*\=\s*(\S.*)\Z);
	    $self->syntax_die("in argument of VAR macro: $_") unless @matches;
	    ($key, $val) = @matches;
	    $self->decho("in transtring try_macro var got key $key val $val");
	    $self->{vars}->{$key} = $val;
	  DOK: {
	      last unless $key eq 'dok';
	      $self->syntax_die("invalid dok $val") unless $val =~ m(\A[\w\_]+\Z);
	      $self->decho("in transtring try_macro dok to $val");
	      $self->{dok} = $val;
	      $self->put('mlhtdok', { dok=>$self->{dok} }, doktmp => 'now()', dokurl => $self->{vars}->{url});
	  };
	  URL: {
	      last unless $key eq 'url';
	      $self->decho("in transtring try_macro url to $val");
	      last unless $self->{dok};
	      $self->put('mlhtdok', { dok=>$self->{dok} }, doktmp => 'now()', dokurl => $self->{vars}->{url});
	  };
	    $_ = $key.'='.$val; 
	    last TRY_MACRO;
	};
	SET_ID: {
	    last unless $macro_with_attrs =~ m(\ASET\s+id\=\w+\Z);
	    $self->decho("in transtring try_macro set_id matched");
	    $_ = $self->trim_to_mlexp($_);
	    last TRY_MACRO;
	};
	CAP: {
	    last unless $macro_with_attrs eq 'CAP';
	    $self->decho("in transtring try_macro cap found");
	    $_ = $self->cjk_textchunks($_);
	    last TRY_MACRO;
	};
	  $self->decho("in transtring macro from try_macro _ $_");
      };
	$_ = '#' . $macro_with_attrs . ': ' .  $_;
	$self->decho("in transtring from macro last _ $_");
	last TRY;
    };
    REGION: {
	@matches = m(\A\#(\w+)\b.*\s\<\<(\S*));
	last unless @matches;
	my ($region, $endmark) = @matches;
      TRY_REGION: {
	  $self->decho("in transtring found region $region with endmark $endmark");
	SKIP_UNTIL: {
	    last unless grep { $region eq $_ } 'Verbatim', 'Native';
	    unshift @{$self->{skip_until}}, $endmark;
	    my $skips = join ', ', @{$self->{skip_until}};
	    $self->decho("in transtring region skip_until $skips");
	    last TRY_REGION;
	};
      };
	$self->decho("in transtring from region last _ $_");
	last TRY;
    };
    HEADING: {
	@matches = m(\A(\*+\s+)(.*)\Z);
	last unless @matches;
	($pre, $text) = @matches;
	$self->decho("in transtring heading found prefix $pre, text $text");
	$_ = $pre . $self->cjk_textchunks($text);
	last TRY;
    };
    PRE_BLANK: {
	@matches = m(\A(\s+)(.*));
	last unless @matches;
	($pre_blank, $_) = @matches;
	$self->decho("transtring try pre_blank: found %d preceding blanks", length($pre_blank));
	# go on with ENUMITEM ff
    };
    ENUMITEM: {
	@matches = m(\A(\#[\.\)]?\s+)(.*)\Z);
	last unless @matches;
	($pre, $text) = @matches;
	$self->decho("enumitem found, prefix $pre, text $text");
	$_ = $pre . $self->cjk_textchunks($text);
	last TRY;
    };
    BULLITEM: {
	@matches = m(\A(\-\s+)(.*)\Z);
	last unless @matches;
	($pre, $text) = @matches;
	$self->decho("transtring bullitem: pre $pre, text $text");	
	$_ = $pre . $self->cjk_textchunks($text);
	last TRY;
    };
    DESCITEM: {
	@matches = m(\A(\#[\.\)]?\s+)(.*)\s+\:\:\s+(.*)\Z);
	last unless @matches;
	($pre, $tag, $text) = @matches;
	$self->decho("transtring descitem: prefix $pre, tag $tag, text $text");
	$_ = $pre . join ' :: ', $self->cjk_textchunks($tag), $self->cjk_textchunks($text);
	last TRY;
    };
    TABRULE: {
	@matches = m(\A\|[\|\-\s]*\|\Z);
	last unless @matches;
	$self->decho("transtring tabrule: leave it alone");
      INCREMENT_COLUMNS_NLIN: { 
	  # see check_columns
	  # line number nlin helps decide whether to reset {columns}->{n} or use existing value to compare against number of columns found in TABROW or TABHROW
	  # increment only if {columns}->{n} was already set in the current table
	  last unless $self->{columns}->{dok} eq $self->{dok};
	  last unless $self->{columns}->{nlin} == $self->{nlin} - 1;
	  $self->{columns}->{nlin}++;
      };
	last TRY;
    };
      my @columns = ();
    TABHROW: {
	@matches = m(\A\|\|(.*)\|\|\Z);
	last unless @matches;
	@columns = split /\|\|\s/, $matches[0];
	$self->check_columns(@columns);
	$self->decho("transtring found tabhrow with $self->{columns} columns");
	$_ = $pre . '||' . join('|| ', map { $self->cjk_tabcolumn($_) } @columns) . '||';
	last TRY;
    };
    TABROW: {
	@matches = m(\A\|(.*)\|\Z);
	last unless @matches;
	@columns = split /\|\s/, $matches[0];
	$self->check_columns(@columns);
	$self->decho("transtring found trabrow with $self->{columns} columns");
	$_ = '|' . join('| ', map { $self->cjk_tabcolumn($_) } @columns) . '|';
	last TRY;
    }; 
      # TABBED_CHUNKS section moved to Tratext.old 2007-09-01
      $_ = $self->cjk_textchunks($_);
  };
    $self->decho("in transtring end with pre_blank $pre_blank, _ $_");
    $_ = $pre_blank . $_;
    $self->decho("from transtring return $_");
    return $_;
};

sub lookup {
    my $self = shift;
    my $ja = shift;
    my ($en) = $self->get_record($self->{table}, { ja=>$ja }, 'en');
    return $en;
};

sub make_lookup {
    my $self = shift;
    return sub {
	my $ja = shift;
	my ($en) = $self->lookup($ja);
	$self->put($self->{table}, { ja=>$ja }, ok=> $en ? 'true' : 'false', dok => $self->{dok}, file => $self->{fi}, line => $self->{nlin});
    };
};

sub update_line {
    my $self = shift;
    local $_ = shift;
    $self->decho("start update_line _ $_");
  NLIN_SKIP: {
      last unless $self->{nlin_skip};
      if ($self->{nlin} > $self->{nlin_skip}) {
	  $self->{nlin_skip} = 0;
	  last NLIN_SKIP;
      };
      $self->decho("in update_line nlin_skip with my nlin $self->{nlin} lt my nlin_skip $self->{nlin_skip} return q{$_}");
      return $_;
  };
    my ($pre, $text) = ('', '');
  EVAL_LINE: {
      s(\s+\Z)();
      last EVAL_LINE if m(\A\Z);
    SKIP_UNTIL: {
	last unless @{$self->{skip_until}};
	my $endmark = $self->{skip_until}->[0];
	$self->decho("in update_line skip_until endmark $endmark");
	  END_FOUND: {
	      last unless m(\A$endmark\Z);
	      shift @{$self->{skip_until}};
	      my $skips = join ', ', @{$self->{skip_until}};
	      $self->decho("in update_line skip_until end_found leaving skips $skips"); 
	  };
	last EVAL_LINE;
    };
      last if m(\A\%);
      last if m(\A\#(\w\_)+\Z);
      ($pre, $text) = m(\A(\s*)(\S.*)\Z);
      $text = eval { $self->transtring($text) };
      unless ($@) {
	  $_ = $pre . $text;
	  last EVAL_LINE;
      };
      print $@, "\n";
      die unless $self->{error}->{typ}->{user};
      die unless $self->{interact};
      print "$@\nTry Again?\n  OLD:  $_\n  NEW:  ";
      $_ = <STDIN>;
      chomp $_;
      redo EVAL_LINE;
  };
    return $_;
};


sub update_input_to_output {
    my $self = shift;
    my $fi_h = shift;
    $self->decho("start update_input_to_output");
    %{$self->{vars}} = ();
    $self->{nlin} = 0;
    @{$self->{skip_until}} = ();
  FILE_LINE: while (<$fi_h>) {
      $self->{nlin}++;
      chomp $_;
      _utf8_on $_;
      $_ = $self->update_line($_);
      print $fo_h $_, "\n";
  };    
};

sub open_input {
    my $self = shift;
    my $fi_h = new IO::File $self->{fi}, 'r' or die "cant read file $self->{fi}";
    $fi_h->binmode(':utf8') or die "cant read $self->{fi} in utf8";
    return $fi_h;
}

sub open_output {
    my $self = shift;
    $self->decho("start open_output write_file $self->{write_file}");
    return *STDOUT unless $self->{write_file};
    $self->{fo} = join '.', $self->{fi}, $self->{timestamp}, 'nov';
    $fo_h = new IO::File $self->{fo}, 'w' or die "cant write file $self->{fo}";
    $fo_h->binmode(':utf8') or die "cant write $self->{fo} in utf8";
    $self->decho("from open_output return fo_h $fo_h");
    return $fo_h;
};

sub close_output {
    my $self = shift;
    $self->decho("start close_output");
    return unless $self->{write_file};
    my $fo_h = shift;
    $fo_h->close;
    my $fi_bak = join '.', $self->{fi}, $self->{timestamp}, 'bak';
    $self->decho("in close_output rename $self->{fi} to $fi_bak");
    rename $self->{fi}, $fi_bak or die "cant rename $self->{fi} to $fi_bak";
    $self->decho("in close_output rename $self->{fo} to $self->{fi}");
    rename $self->{fo}, $self->{fi} or die "cant rename $self->{fo} to $self->{fi}";
};

sub update_file {
    my $self = shift;
    $self->{fi} = shift;
    $self->decho("start update_file with my fi $self->{fi}");
    $fi_h = $self->open_input;
    $fo_h = $self->open_output;
    $self->update_input_to_output($fi_h);
    $fi_h->close;
    $self->close_output($fo_h);
    $self->decho("from update_file return");
};

sub update {
    my $self = shift;
    my @files = @_;
    $self->query(qq{update $self->{table} set ok = false}) if $self->{reset_reks};
    $self->update_file($_) for @files;
    $self->vecho("resolved %d conflicts", scalar keys %{$self->{JA_EN}});
    $self->decho("\t$_\t$self->{JA_EN}->{$_}") for keys %{$self->{JA_EN}};
};

return 1;

# Local Variables:
# coding: utf-8
# url: http://a2e.de/adv/tratext/Tratext.pm
# srcfile:/adv/tratext/Tratext.pm
# mode: perl
# End:
