#!/usr/bin/perl
# sh2xml_l.pl
# This is about as good as I can do without any more information. Any suggestions
# for where to go from here. Someone could take the output from this automated
# solution and use XSLT to re-organise according to a different DTD.

$VERSION = '1.2.4'; #   MJPH    21-SEP-2007     Add documentation for -t %T
# $VERSION = '1.2.3'; #   MJPH    22-SEP-2006     Add documentation
# $VERSION = '1.2.2'; #   MJPH    30-JUN-2006     Add normalising for normal conversion
# $VERSION = '1.2.1'; #   MJPH    30-JUN-2006     Fix normalising and unicode
# $VERSION = '1.2';   #   MJPH    26-JUN-2006     Add -n (normalising)
# $VERSION = '1.1.1'; #   MJPH    22-APR-2005     Add \codepage xxx.tec direct TECkit support
# $VERSION = '1.1.0'; #   MJPH    21-JAN-2005     Add interlinear text support and -t (move -t to -f)
# $VERSION = '1.0.2'; #   MJPH     8-JUN-2004     Add charset support
# $VERSION = '1.0.1'; #   MJPH     5-MAR-2003     Add system codepage support
# $VERSION = '1.0';   #   MJPH     9-MAY-2003     Add Unicode support for Toolbox

use SIL::Shoe::Settings;
use SIL::Shoe::Data;
use Encode qw(_utf8_on _utf8_off decode_utf8 encode_utf8 find_encoding);
use Encode::Registry;
use Encode::TECkit;
use Unicode::Normalize 'normalize';
use File::Spec;
use Getopt::Std;
use Pod::Usage;

getopts("bc:e:f:hn:s:t:");

%charsets = (
    0 => 1252,      # ansi - Western European
    1 => 0,         # default
    2 => 0,         # symbol
    3 => 0,         # invalid
    77 => 10000,    # mac
    128 => 932,     # Shift JIS
    129 => 949,     # Hangul
    130 => 1361,    # Johab
    134 => 936,     # GB2312 Simplified Chinese
    136 => 950,     # Big5 Traditional Chinese
    161 => 1253,    # Greek
    162 => 1254,    # Turkish
    163 => 1258,    # Vietnamese
    177 => 1255,    # Hebrew
    178 => 1256,    # Arabic
    179 => 'arabictrad',
    180 => 'arabicuser',
    181 => 'hebrewuser',
    186 => 1257,    # Baltic
    204 => 1251,    # Russian (Cyrillic)
    222 => 874,     # Thai
    238 => 1250,    # Eastern European
    254 => 437,     # PC 437
    255 => 'oem'
    );

if ($opt_h)
{
    pod2usage( -verbose => 2);
    exit;
}

unless (defined $ARGV[0])
{
    pod2usage(1);
    exit;
}

unless (defined $ARGV[1])
{
    $ARGV[1] = $ARGV[0];
    $ARGV[1] =~ s/(\.[^.]*)?$/.db1/o;
}

if ($] > 5.007 && $opt_e)
{
    foreach (split(/\s*[,;]\s*/, $opt_e))
    {
        require "Encode/$opt_e.pm";
        &{"Encode::$opt_e::import"};
    }
}

$opt_s = "." unless defined $opt_s;
$settings = SIL::Shoe::Settings->new($opt_s) || die "Unable to read settings directory at $opt_s";

$s = SIL::Shoe::Data->new($ARGV[0], undef, nostripnl => 1)
        || die "Can't open $ARGV[0]";
open(OUTFILE, ">$ARGV[1]") || die "Can't create $ARGV[1]";
# binmode(OUTFILE, ":utf8");
select OUTFILE;

$typef = $settings->type($opt_f || $s->{' Type'}) || die "Can't find .typ file for type: $s->{' Type'}";
$typef->read;
$s->{' key'} = $typef->{'mkrRecord'}[0] || $typef->{'mkrRecord'};        # bug in .typ file results in mkrRecord going in twice
$lngdef = $settings->lang($typef->{'lngDefault'});
$lngdef->add_specials if ($lngdef);
if ($opt_c)
{ $deflng = $opt_c; }
elsif ($lngdef->{'codepage'})
{ $deflng = $lngdef->{'codepage'}; }
elsif ($^O eq 'MSWin32')
{
    require Win32::TieRegistry;
    Win32::TieRegistry->import(Delimiter => '/');

    $deflng = $Registry->{"LMachine/SYSTEM/ControlSet/CurrentControlSet/Control/Nls/CodePage//ACP"};
}

$deflng ||= '1252';

$defenc = Encode::Registry::find_encoding($deflng) || Encode::Registry::find_encoding('iso-8859-1')
    || die "Can't make an encoding converter for $deflng";

$i = 0;
foreach $x (@{$typef->{'intprc'}})
{
    foreach $mk ($x->{'mkrFrom'}, $x->{'mkrTo'})
    {
        unless (defined $markers{$mk})
        {
            $markers{$mk} = $i;
            $markers[$i++] = $mk;
        }
    }
    $parent[$markers{$x->{'mkrTo'}}] = $markers{$x->{'mkrFrom'}};
    push(@{$children[$markers{$x->{'mkrFrom'}}]}, $markers{$x->{'mkrTo'}});
}
$lastrow = $i - 1;

$opt_t =~ s/%T/$s->{' Type'}/og;
$opt_t ||= $s->{' Type'} if ($opt_n);

if ($opt_t)
{
    printf "\\_sh %s  %d  %s\n", $s->{' Version'}, $s->{' CSum'}, $opt_t;
    print "\\_DateStampHasFourDigitYear\n" if ($s->{' DateStamp'} == 4);
    print "\n";
}

while ($s->readrecord(\@fields))
{
    $indent = 0; $instack = 0;
    @stack = ('shoebox');
    for ($i = 0; $i <= $#fields; $i++)
    {
        $f = $fields[$i];
        $marker = $f;
        $marker =~ s/\s+.*$//oi;    # strip to the name back to its sfm
        $ind = $markers{$marker};
        if (defined $ind)
        {
            unless (defined $parent[$ind])
            {
                process_stack($root, \@rows, $lastrow) if ($instack);
                $root = $ind;
                $instack = 1;
                @rows = ();
                $rows[$ind] = build_pos($s->{$f}, $ind);
#                print STDERR "$indnum, $innum\n";
            } else
            {
                $rows[$ind] = build_pos($s->{$f}, $ind);
                $p = $parent[$ind];
                make_tree($rows[$ind], $rows[$p], $ind, $p) if (defined $p);
            }
        } else
        {
            if ($instack)
            {
                process_stack($root, \@rows, $lastrow);
                $instack = 0;
            }
            if ($s->{$f} eq "")
            {
                print "\\$marker\n" unless ($opt_b);
                next;
            }
    
            $temp = convert($s->{$f}, $marker);
            _utf8_off($temp);
            print "\\$marker $temp\n";
        }
    }
    process_stack($root, \@rows, $lastrow) if ($instack);
    print "\n";
}


sub convert
{
    my ($str, $marker) = @_;
    
    if ($opt_n and $lang = $settings->lang($typef->{'mkr'}{$marker}{'lng'})
               and defined $lang->{'UnicodeLang'})
    { return normalize($opt_n, decode_utf8($str)); }

    unless ($lang = $settings->lang($typef->{'mkr'}{$marker}{'lng'}))
    { $enc = $defenc; }
    elsif (defined $lang->{'encoding'})
    { $enc = $lang->{'encoding'}; }
    elsif (defined $lang->{'UnicodeLang'})
    { $enc = find_encoding("UTF-8"); }		# be strict UTF-8
    else
    {
        my ($cp);
        $lang->add_specials;
        $cp = $lang->{'codepage'};
        if ($cp eq 'none')
        { $enc = undef; }
        elsif ($cp =~ /\.tec$/o)
        {
            $enc = Encode::TECkit->new(File::Spec->catfile($opt_s, $cp));
            unless ($enc)
            {
                print STDERR "Unable to find TECkit mapping $cp, using default encoding\n";
                $enc = $defenc;
            }
        }
        else
        {
            $cp ||= $charsets{hex($lang->{'charset'})};
            $enc = Encode::Registry::find_encoding($cp);
            if (!$enc && $cp)
            {
                print STDERR "Unable to find encoding $cp, using default\n";
                $enc = $defenc;
            }
        }
        $lang->{'encoding'} = $enc;
    }
    $str = $enc->decode($str) if ($enc);
	$str = normalize($opt_n, $str) if ($opt_n);
    $str;
}
    
sub build_pos
{
# make linked list of nodes corresponding to each word in the line
# store starting and ending offsets and indices for each word
    my ($str, $ind) = @_;
    my ($match, $num, $pos, $substr, $first, $new, $last);

    $pos = 0;
    $num = 0;
#    $str =~ s/^\s?//og;
    while ($str =~ m/^(\S+)\s*/oi)
    {
        $substr = $1;
        $match = $&;
        $str = $';      #'
        $new = SIL::Shoe::Interlin::Node->new(
            text => $substr,
            num => $num,
            line => $ind,
            pos => $pos,
            end => $pos + length($substr));
        if ($last)
        {
            $last->{'next'} = $new;
            $new->{'prev'} = $last;
            $last = $new;
        }
        else
        {
            $first = $new;
            $last = $new;
        }
        $pos += length($match);
        $num++;
    }
    return $first;
}
    

sub make_tree
{
# work out the parent of each word in a row
# inform parent of its added child. Note we only work at one level, resulting
# in a tree.
    my ($row, $prow, $ind, $pind) = @_;
    my ($child, $parent, $oldp, $plast);

    for ($child = $row; defined $child; $child = $child->{'next'})
    {
# find actual parent of this child
        for ($parent = $prow; defined $parent; $parent = $parent->{'next'})
        {
            if ($child->{'pos'} == $parent->{'pos'})
            {
                $plast = $parent;
                last;
            }
            elsif ($child->{'pos'} < $parent->{'pos'})
            { last; }
            $plast = $parent;
        }
        
        $child->{'parent'} = $plast;
        push(@{$plast->{'children'}[$ind]}, $child);

        $oldp = $plast;
        for ($parent = $plast->{'next'}; defined $parent; $parent = $parent->{'next'})
        {
            last unless ($child->{'end'} >= $parent->{'pos'});
            $oldp = $parent;
        }

        mark_links($plast, $oldp, $pind) if ($oldp ne $plast);
    }
}


sub mark_links
{
# indicates that a range of nodes in a line should be considered as one word
    my ($first, $last, $ind) = @_;
    my ($pfirst, $plast, $pind);

    $pind = $parent[$ind];
    if (defined $pind)
    {
        $pfirst = $first->{'parent'};
        $plast = $last->{'parent'};
        mark_links($pfirst, $plast, $pind) if ($pfirst ne $plast);
    }

    for ($pfirst = $first; $pfirst ne $last; $pfirst = $pfirst->{'next'})
    { $pfirst->{'linked'} = 1; }
}


sub process_stack
{
# output a stack:
#   Link nodes in the row that are empty
#   link children of linked nodes
#   remove links: coallesce linked nodes and tidy up linked lists of nodes
#   convert and set widths for each node
#   output stack
    my ($ind, $rows, $lastrow) = @_;
    my ($p, $c, $op);

    # add default links for parents with no children to merge with previous word
    for ($p = $rows->[$ind]; defined $p; $p = $p->{'next'})
    {
        $op->{'linked'} = 1 if (defined $op && !$p->{'children'});
        $op = $p;
    }

    # link children of a linked set of words (for phrase to phrase translation)
    for ($c = $rows->[$ind]; defined $c; $c = $c->{'next'})
    {
        for ($p = $c; defined $p && $p->{'linked'}; $p = $p->{'next'})
        { }

        if ($p ne $c)
        {
            $c->{'chained'} = $p;
            mark_children($c, $p, $ind);
            $c = $p;
        }
    }

    # convert linked nodes into single nodes and tidy up node sequences
    for ($c = $rows->[$ind]; defined $c; $c = $c->{'next'})
    {
        next unless ($c->{'chained'});
        remove_links($c, $c->{'chained'}, $ind);
    }

    # convert stack to unicode and set widths
    print OUTFILE "$int_mark\n" unless ($contstack);
    for ($p = $rows->[$ind]; defined $p; $p = $p->{'next'})
    { stack_convert($p, $ind); }
    
    # output stack
    foreach $c ($ind .. $lastrow)
    {
        print "\\$markers[$c] ";
        for ($p = $rows->[$c]; defined $p; $p = $p->{'next'})
        { print $p->{'text'}; }
#        { print convert($p->{'text'}, $markers[$c]); }
        print "\n";
    }
}


sub mark_children
{
# links all the children in a tree for a given range of nodes in a parent line
    my ($first, $last, $ind) = @_;
    my ($cind, $cfirst, $clast, $c, $p);

    foreach $cind (@{$children[$ind]})
    {
        # find the spanning range in the children based on starting offsets
        $cfirst = $first->{'children'}[$cind][0];
        next unless $cfirst;
        for ($p = $first; defined $p && $p ne $last->{'next'}; $p = $p->{'next'})
        {
            foreach $c (@{$p->{'children'}[$cind]})
            {
                if ($cfirst->{'pos'} <= $c->{'pos'})
                { $clast = $c; }
                else
                {
                    $clast = $cfirst;
                    $cfirst = $c;
                }
            }
        }

        # link the children and recurse
        if ($cfirst)
        {
            $clast ||= $cfirst;
            $cfirst->{'chained'} = $clast;
            for ($c = $cfirst; $c ne $clast; $c = $c->{'next'})
            { $c->{'linked'} = 1; }
            $first->{'fchild'}[$cind] = $cfirst;
            mark_children($cfirst, $clast, $cind);
        }
    }
}


sub remove_links
{
# coallesce a linked series of words into a single node and adjust node chain
# accordingly
    my ($first, $last, $ind) = @_;
    my ($cind, $c);

    # recurse and set the parent for each first child node
    foreach $cind (@{$children[$ind]})
    {
        $c = $first->{'fchild'}[$cind];
        next unless $c;
        remove_links($c, $c->{'chained'}, $cind);
        $first->{'children'}[$cind] = [$c];
        $c->{'parent'} = $first;
    }

    # merge the text of a linked series of words, remove intermediate words from 
    # linked list of row. IOW true coallescing.
    for ($c = $first->{'next'}; defined $c && $c ne $last->{'next'}; $c = $c->{'next'})
    { $first->{'text'} .= " $c->{'text'}"; }
    $first->{'next'} = $c;
    $c->{'prev'} = $first;
    $first->{'linked'} = 0;
}

sub stack_convert
{
# recursively, convert the string in the node, calculate new max width for node,
# inform all children of new max width of parent, return new max width as width
# of node
    my ($p, $ind) = @_;
    my ($maxwidth, $mwidth, $wid, $cwid, @cwids);
    
    $p->{'text'} = convert($p->{'text'}, $markers[$ind]);
    $p->{'text'} =~ s/\s*$//o;
    _utf8_off($p->{'text'});
    $mwidth = bytes::length($p->{'text'});
    $p->{'width'} = $mwidth;
    $maxwidth = $mwidth + 1;
    
    foreach $cind (@{$children[$ind]})
    {
        $cwid = 0;
        foreach $c (@{$p->{'children'}[$cind]})
        {
            $c->{'width'} = stack_convert($c, $cind);
            $cwid += $c->{'width'};
        }
        $p->{'cwids'}[$cind] = $cwid;
        $maxwidth = $cwid if ($cwid > $maxwidth);
    }
    
    stack_setwidth($p, $ind, $maxwidth);
    $maxwidth;
}

sub stack_setwidth
{
    my ($p, $ind, $wid) = @_;
    
    if ($wid > $p->{'width'})
    {
        $p->{'text'} .= ' ' x ($wid - $p->{'width'});
        $p->{'width'} = $wid;
    }
    
    foreach $cind (@{$children[$ind]})
    {
        unless (defined $p->{'children'}[$cind][-1])
        {
            my ($new) = SIL::Shoe::Interlin::Node->new();
            if (defined $p->{'prev'})
            {
                $new->{'prev'} = $p->{'prev'}{'children'}[$cind][-1];
                $new->{'prev'}{'next'} = $new;
            }
            if (defined $p->{'next'})
            {
                $new->{'next'} = $p->{'next'}{'children'}[$cind][-1];
                $new->{'next'}{'prev'} = $new;
            }
            push (@{$p->{'children'}[$cind]}, $new);
        }
        stack_setwidth($p->{'children'}[$cind][-1], $cind, $wid) if ($wid > $p->{'cwids'}[$cind]);
    }
}    


package SIL::Shoe::Interlin::Node;

sub new
{
    my ($class, %attrs) = @_;
    my ($self) = {%attrs};

    bless $self, ref $class || $class;
}

sub le
{
    my ($test, $against) = @_;
    my ($p);

    for ($p = $test; defined $p; $p = $p->{'next'})
    { return 1 if ($p eq $against); }
    return 0;
}

__END__

=head1 TITLE

sh2sh - convert Shoebox data to Unicode

=head1 SYNOPSIS

    sh2sh -s settings_dir [-c codepage] [-e encs] infile [outfile]

Converts Shoebox data to Shoebox converting to Unicode as it goes.

=head1 OPTIONS

    -b              Delete empty fields
    -c codepage     Set default codepage conversion, otherwise none
    -e enc,enc      Add Encoding:: subsets in Perl 5.8.1
    -f type         Force database type
    -n normalform   normalize unicode text to D,C,KD,KC form
    -s dir          Directory to find .typ files in [.]
    -t type         Generate Toolbox database of given type
    
If outfile is missing, it is created as the input file with extension replaced
by .db1. This allows a user to drop a data file on a shortcut.

=head1 DESCRIPTION

sh2sh converts a Shoebox (or Toolbox) database to Unicode. In particular it

=over 4

=item *

Sonverts strings according to whcih field they are in and the corresponding
language

=item *

Lays out interlinear text so that it remains as interlinear text when the
corresponding underlying strings have changed length.

=back

Using sh2sh involves two aspects: preparing for conversion in terms of giving
information about encoding conversion; and running the program, knowing what
command line option does what.

=head2 Running sh2sh

Here we list the various command line options and give further details on each

=over 4

=item -b

Any empty fields in the input file will be deleted.

=item -c

Specifies the default codepage to be used when converting data. In effect it
specifies that sh2sh should act as though it were running on a system with the
given default codepage. This means that data in languages with no given encoding
conversion will be converted using this codepage.

=item -e

Perl has internal support for a large number of industry standard encodings. This
option specifies which sets to pull in apart from the default set. Values include

  Byte - standard ISO 8859 type single byte encodings
  CN   - Continental China encodings including cp 936, GB 12345 and GB 2312
  JP   - Japanese encodings including cp 932 and ISO 2022
  KR   - Korean encodings including cp 949
  TW   - Taiwanese encodings including cp 950
  HanExtra - more Chinese encodings including GB 18030
  JIS2K - More Japanese encodings
  Ebcdic - surely not!
  Symbols - various symbol encodings

See man Encode::Supported or the corresponding module documentation for details of
what is supported on your Perl installation.

=item -f

Rather than analysing the data in the file using the database type specified in
the database, it is possible to specify that a different one should be used.

=item -n

Particularly with respect to Roman script languages involving letters with
diacritics, there are two options as to how these are to be stored. They can
either be stored as a single code (if such exists in Unicode) in which case
the form to be asked for is C (composed), otherwise they can be stored using
separate codes for base and diacritic and the normal form is D (decomposed).
There are other normal forms which should only be used if you really know
what you are doing (and then you will know why they shouldn't be used).

=item -s

sh2xml requires access to information about the structure of the database
and language information. This is held in files in the same directory as the
C<.prj> project file used when running Shoebox/Toolbox.

=item -t

Gives the name of a database type that is given to the output file. Since the
encoding has changed, the old database type is no longer appropriate for the
output data. If a new database type has already been created that makes reference
to the appropriate languages based on Unicode. In order to access the old
database type name as part of the new name, all occurrences of the string C<%T>
in the C<-t> option will be replaced with the old database type name.

=back

=head2 Preparing for Conversion

The basic need is to be able to specify how to convert text in a particular
language into Unicode. This can be done by specifying a conversion mapping
in each language file. Shoebox and Toolbox do not have a UI for specifying
such conversion information, so we add information to the options/description
field. The codepage specification takes the form:

  \codepage = value

The specification needs to be on a line on its own. The I<value> can take a
number of forms.

=over 4

=item I<name>

A mapping name either from the set of names supported by the Perl Encode
module, or specified in an SIL Converters repository.

=item I<filename>.tec

The path and filename of a TECkit binary mapping file. The path is
relative to the settings directory.

=item none

No mapping should be done. The data is assumed to be in UTF-8 encoding.

=back

=cut