—
—
—
—
—
—
—
—
—
—

              
## -*- 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::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
##========================================================================
HideShow 8 lines of Pod
## NAME
=pod
=head1 NAME
DTA::CAB::Format::TJ - Datum parser: one-token-per-line text; token data as JSON
=cut
##========================================================================
HideShow 29 lines of Pod
## 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
##========================================================================
HideShow 6 lines of Pod
## DESCRIPTION
=pod
=head1 DESCRIPTION
=cut
##----------------------------------------------------------------
HideShow 24 lines of Pod
## 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
##----------------------------------------------------------------
HideShow 26 lines of Pod
## 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
##----------------------------------------------------------------
HideShow 17 lines of Pod
## 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
##----------------------------------------------------------------
HideShow 35 lines of Pod
## 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
##----------------------------------------------------------------
HideShow 42 lines of Pod
## 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
HideShow 14 lines of Pod
##========================================================================
=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
##======================================================================
HideShow 16 lines of Pod
=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