## -*- Mode: CPerl -*-
##
## File: DTA::CAB::Format::TJ.pm
## Author: Bryan Jurish <moocow@cpan.org>
## Description: Datum parser: one-token-per-line text

package DTA::CAB::Format::TJ;
use DTA::CAB::Format;
use DTA::CAB::Format::TT;
use DTA::CAB::Datum ':all';
use IO::File;
use Carp;
use strict;

##==============================================================================
## Globals
##==============================================================================

our @ISA = qw(DTA::CAB::Format::TT);

BEGIN {
  DTA::CAB::Format->registerFormat(name=>__PACKAGE__, filenameRegex=>qr/\.(?i:tj|tjson|cab\-tj|cab\-tjson)$/);
}

##==============================================================================
## Constructors etc.
##==============================================================================

## $fmt = CLASS_OR_OBJ->new(%args)
##  + object structure: assumed HASH
##    {
##     ##-- Input
##     doc => $doc,                    ##-- buffered input document
##
##     ##-- Output
##     #outbuf  => $stringBuffer,     ##-- buffered output
##     level   => $formatLevel,      ##-- <0:no 'text' attribute; >=0: all attributes; abs($_)>=2: canonical
##
##     ##-- Common
##     raw => $bool,                   ##-- attempt to load/save raw data
##     defaultFieldName => $name,      ##-- default name for unnamed fields; parsed into @{$tok->{other}{$name}}; default=''
##    }

sub new {
  my $that = shift;
  my $fmt = bless({
		   ##-- input
		   doc => undef,

		   ##-- output
		   #outbuf => '',
		   level => 0,

		   ##-- common
		   utf8 => 1,
		   defaultFieldName => '',

		   ##-- user args
		   @_
		  }, ref($that)||$that);
  return $fmt;
}

##==============================================================================
## Methods: Persistence
##==============================================================================

## @keys = $class_or_obj->noSaveKeys()
##  + returns list of keys not to be saved
##  + default just returns empty list
sub noSaveKeys {
  return ($_[0]->SUPER::noSaveKeys, qw(doc outbuf jxs));
}

##==============================================================================
## Methods: I/O: Generic
##==============================================================================

## $jxs = $fmt->jsonxs()
sub jsonxs {
  require JSON::XS;
  return $_[0]{jxs} if (defined($_[0]{jxs}));
  return $_[0]{jxs} = JSON::XS->new->utf8(0)->relaxed(1)->canonical(abs($_[0]{level})>=2 ? 1 : 0)->allow_blessed(1)->convert_blessed(1);
}

##==============================================================================
## Methods: I/O: Block-wise
##==============================================================================

## \%head = blockScanHead(\$buf,\%opts)
##  + gets header offset, length from (mmaped) \$buf
##  + %opts are as for blockScan()
sub blockScanHead {
  my ($fmt,$bufr,$opts) = @_;
  return [0,$+[0]] if ($$bufr =~ m(\A\n*+(?:%%\$TJ:DOC=.*\n++)?));
  return [0,0];
}


##==============================================================================
## Methods: Input
##==============================================================================

##--------------------------------------------------------------
## Methods: Input: Input selection

## $fmt = $fmt->fromFh($filename_or_handle)
##  + new override calls Format::fromFh
sub fromFh {
  #return $_[0]->fromFh_str(@_[1..$#_]);
  my $fmt = shift;
  $fmt->DTA::CAB::Format::fromFh(@_)
    or $fmt->logconfess("fromFh(): inherited Format::fromFh() failed: $!");
  return $fmt->parseTJFh($_[0]);
}

## $fmt = $fmt->fromString(\$string)
##  + select input from string $string
##  + new override calls Format::fromString() [-> fromFh]
sub fromString {
  my $fmt = shift;
  $fmt->close();
  #return $fmt->parseTJString(ref($_[0]) ? $_[0] : \$_[0]);
  return $fmt->DTA::CAB::Format::fromString(@_);
}

##--------------------------------------------------------------
## Methods: Input: Local

## $fmt = $fmt->parseTJFh($fh)
##  + guts for fromFh(): parse handle $fh into local document buffer.
sub parseTJFh {
  my ($fmt,$fh) = @_;
  $fmt->setLayers($fh);
  my $jxs = $fmt->jsonxs();

  ##-- ye olde loope
  my (%sa,%doca);
  my $toks = [];
  my @body = qw();
  my ($tok,$text,$json);
  while (defined($_=<$fh>)) {
    if ($_ =~ /^\%\%\$TJ\:DOC=(.+)$/) {
      ##-- tj directive: document attributes
      $json = defined($1) && $1 ? $jxs->decode($1) : {};
      @doca{keys %$json} = values %$json;
    }
    elsif ($_ =~ /^\%\%\$TJ\:SENT=(.+)$/) {
      ##-- tj directive: sentence attributes
      $json = defined($1) && $1 ? $jxs->decode($1) : {};
      @sa{keys %$json} = values %$json;
    }
    elsif ($_ =~ /^\%\% (?:xml\:)?base=(.*)$/) {
      ##-- (tt-compat) special comment: document attribute: xml:base
      $doca{'base'} = $1;
    }
    elsif ($_ =~ /^\%\% Sentence (.*)$/) {
      ##-- (tt-compat) special comment: sentence attribute: xml:id
      $sa{'id'} = $1;
    }
    elsif ($_ =~ /^\%\%(.*)$/) {
      ##-- (tt-compat) generic line: add to _cmts
      push(@{$sa{_cmts}},$1); ##-- generic doc- or sentence-level comment
    }
    elsif ($_ =~ /^$/) {
      ##-- empty line: EOS
      if (%sa || @$toks) {
	push(@body,{%sa,tokens=>$toks});
	$toks = [];
	%sa   = qw();
      }
    }
    else {
      ##-- vanilla token
      chomp;
      ($text,$json) = split(/\t/,$_,2);
      push(@$toks, $tok = (defined($json) && $json ne '' ? $jxs->decode($json) : {}));
      $tok->{text}=$text if (!defined($tok->{text}));
    }
  }
  push(@body, {%sa,tokens=>$toks}) if (%sa || @$toks); ##-- handle missing EOS at EOF

  ##-- construct & buffer output document
  #$_ = bless($_,'DTA::CAB::Sentence') foreach (@$sents);
  $fmt->{doc} = bless({%doca,body=>\@body}, 'DTA::CAB::Document');
  return $fmt;
}


##--------------------------------------------------------------
## Methods: Input: Generic API

## $doc = $fmt->parseDocument()
sub parseDocument { return $_[0]{doc}; }


##==============================================================================
## Methods: Output
##==============================================================================

##--------------------------------------------------------------
## Methods: Output: Generic

## $type = $fmt->mimeType()
##  + default returns text/plain
sub mimeType { return 'text/plain'; }

## $ext = $fmt->defaultExtension()
##  + returns default filename extension for this format
sub defaultExtension { return '.tj'; }

##--------------------------------------------------------------
## Methods: Output: output selection
##  + inherited


##--------------------------------------------------------------
## Methods: Output: Generic API

## $fmt = $fmt->putToken($tok)
sub putToken {
  #my ($fmt,$tok) = @_;

  $_[0]{fh}->print
    (
     ($_[1]{_cmts} ? join('', map {"%%$_\n"} map {split(/\n/,$_)} @{$_[1]{_cmts}}) : ''),
     $_[1]{text},
     "\t",
     $_[0]->jsonxs->encode(($_[0]{level}||0) >= 0
			   ? $_[1]
			   : {(map {$_ eq 'text' ? qw() : ($_=>$_[1]{$_})} keys %{$_[1]})}
			  ),
     "\n",
    );

  return $_[0];
}

## $fmt = $fmt->putSentence($sent)
##  + concatenates formatted tokens, adding sentence-id comment if available
sub putSentence {
  #my ($fmt,$sent) = @_;
  my $sh = {(map {$_ eq 'tokens' ? qw() : ($_=>$_[1]{$_})} keys %{$_[1]})};
  $_[0]{fh}->print('%%$TJ:SENT=', $_[0]->jsonxs->encode($sh), "\n") if (%$sh);
  $_[0]->putToken($_) foreach (@{toSentence($_[1])->{tokens}});
  $_[0]{fh}->print("\n");
  return $_[0];
}

## $fmt = $fmt->putDocument($doc)
##  + concatenates formatted sentences, adding document 'xmlbase' comment if available
our %TJ_BAD_DOC_KEYS = (body=>1, teibufr=>1, textbufr=>1);
sub putDocument {
  #my ($fmt,$doc) = @_;
  my $dh = { (map {($_=>$_[1]{$_})} grep {!exists($TJ_BAD_DOC_KEYS{$_})} keys %{$_[1]}) };
  $_[0]{fh}->print('%%$TJ:DOC=', $_[0]->jsonxs->encode($dh), "\n") if (%$dh);
  $_[0]->putSentence($_) foreach (@{toDocument($_[1])->{body}});
  return $_[0];
}


## $fmt = $fmt->putData($data)
##  + puts raw data (json)
sub putData {
  $_[0]{fh}->print($_[0]->jsonxs->encode($_[1]));
}


1; ##-- be happy

__END__

##========================================================================
## POD DOCUMENTATION, auto-generated by podextract.perl, edited

##========================================================================
## NAME
=pod

=head1 NAME

DTA::CAB::Format::TJ - Datum parser: one-token-per-line text; token data as JSON

=cut

##========================================================================
## SYNOPSIS
=pod

=head1 SYNOPSIS

 use DTA::CAB::Format::TJ;
 
 ##========================================================================
 ## Constructors etc.
 
 $fmt = DTA::CAB::Format::TJ->new(%args);
 
 ##========================================================================
 ## Methods: Input
 
 $fmt = $fmt->close();
 $fmt = $fmt->fromString($string);
 $doc = $fmt->parseDocument();
 
 ##========================================================================
 ## Methods: Output
 
 $fmt = $fmt->flush();
 $str = $fmt->toString();
 $fmt = $fmt->putToken($tok);
 $fmt = $fmt->putSentence($sent);
 $fmt = $fmt->putDocument($doc);

=cut

##========================================================================
## DESCRIPTION
=pod

=head1 DESCRIPTION

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Format::TJ: Globals
=pod

=head2 Globals

=over 4

=item Variable: @ISA

DTA::CAB::Format::TJ
inherits from
L<DTA::CAB::Format::TT|DTA::CAB::Format::TT>.

=item Filenames

DTA::CAB::Format::TJ registers the filename regex:

 /\.(?i:tj|cab-tj)$/

with L<DTA::CAB::Format|DTA::CAB::Format>.

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Format::TJ: Constructors etc.
=pod

=head2 Constructors etc.

=over 4

=item new

 $fmt = CLASS_OR_OBJ->new(%args);

%args, %$fmt:

 ##-- Input
 doc => $doc,                    ##-- buffered input document
 ##
 ##-- Output
 outbuf    => $stringBuffer,     ##-- buffered output
 #level    => $formatLevel,      ##-- n/a
 ##
 ##-- Common
 encoding => $inputEncoding,     ##-- default: UTF-8, where applicable

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Format::TJ: Methods: Persistence
=pod

=head2 Methods: Persistence

=over 4

=item noSaveKeys

 @keys = $class_or_obj->noSaveKeys();

Returns list of keys not to be saved.
This implementation returns C<qw(doc outbuf)>.

=back

=cut


##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Format::TJ: Methods: Input
=pod

=head2 Methods: Input

=over 4

=item close

 $fmt = $fmt->close();

Override: close current input source, if any.

=item fromString

 $fmt = $fmt->fromString($string);

Override: select input from string $string.

=item parseTJString

 $fmt = $fmt->parseTJString($str)

Guts for fromString(): parse string $str into local document buffer
$fmt-E<gt>{doc}.

=item parseDocument

 $doc = $fmt->parseDocument();

Override: just returns local document buffer $fmt-E<gt>{doc}.

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Format::TJ: Methods: Output
=pod

=head2 Methods: Output

=over 4

=item flush

 $fmt = $fmt->flush();

Override: flush accumulated output

=item toString

 $str = $fmt->toString();
 $str = $fmt->toString($formatLevel)

Override: flush buffered output document to byte-string.
Just encodes string in $fmt-E<gt>{outbuf}.

=item putToken

 $fmt = $fmt->putToken($tok);

Override: token output.

=item putSentence

 $fmt = $fmt->putSentence($sent);

Override: sentence output.

=item putDocument

 $fmt = $fmt->putDocument($doc);

Override: document output.

=back

=cut

##========================================================================
## END POD DOCUMENTATION, auto-generated by podextract.perl

##========================================================================
## EXAMPLE
##========================================================================
=pod

=head1 EXAMPLE

An example file in the format accepted/generated by this module (with very long lines) is:

 %%$TJ:SENT={"lang":"de"}
 wie	{"errid":"ec","hasmorph":"1","msafe":"1","moot":{"word":"wie","tag":"PWAV","lemma":"wie"},"exlex":"wie","lang":["de"],"xlit":{"latin1Text":"wie","isLatin1":"1","isLatinExt":"1"},"text":"wie"}
 oede	{"moot":{"word":"öde","tag":"ADJD","lemma":"öde"},"text":"oede","xlit":{"latin1Text":"oede","isLatin1":"1","isLatinExt":"1"},"msafe":"0"}
 !	{"errid":"ec","exlex":"!","msafe":"1","xlit":{"isLatin1":"1","isLatinExt":"1","latin1Text":"!"},"text":"!","moot":{"word":"!","tag":"$.","lemma":"!"}}
  

=cut

##======================================================================
## Footer
##======================================================================

=pod

=head1 AUTHOR

Bryan Jurish E<lt>moocow@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009-2019 by Bryan Jurish

This package is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.24.1 or,
at your option, any later version of Perl 5 you may have available.

=cut
