## -*- Mode: CPerl -*-
##
## File: DTA::CAB::Format::Perl.pm
## Author: Bryan Jurish <moocow@cpan.org>
## Description: Datum parser|formatter: perl code via Data::Dumper, eval()

package DTA::CAB::Format::Perl;
use DTA::CAB::Format;
use DTA::CAB::Datum ':all';
use Data::Dumper;
use IO::File;
use Encode qw(encode decode);
use Carp;
use strict;

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

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

BEGIN {
  DTA::CAB::Format->registerFormat(name=>__PACKAGE__, filenameRegex=>qr/\.(?i:prl|pl|perl|dump)$/);
}

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

## $fmt = CLASS_OR_OBJ->new(%args)
##  + object structure: assumed HASH
##    (
##     ##---- Input
##     doc => $doc,                    ##-- buffered input document
##
##     ##---- Output
##     dumper => $dumper,              ##-- underlying Data::Dumper object
##
##     ##---- INHERITED from DTA::CAB::Format
##     level     => $formatLevel,      ##-- sets Data::Dumper->Indent() option
##     outbuf    => $stringBuffer,     ##-- buffered output
##    )
sub new {
  my $that = shift;
  my $fmt = bless({
		   ##-- I/O common
		   utf8 => undef, ##-- n/a

		   ##-- Input
		   #doc => undef,

		   ##-- Output
		   dumper => Data::Dumper->new([])->Purity(1)->Terse(0)->Deepcopy(1),
		   level  => 0,
		   outbuf => '',

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

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

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

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

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

## $fmt = $fmt->close()
sub close {
  delete($_[0]{doc});
  return $_[0]->SUPER::close(@_[1..$#_]);
}

## $fmt = $fmt->fromString( $string)
## $fmt = $fmt->fromString(\$string)
sub fromString {
  my $fmt = shift;
  $fmt->close(1);
  return $fmt->parsePerlString(ref($_[0]) ? $_[0] : \$_[0]);
}

## $fmt = $fmt->fromFile($filename_or_handle)
##  + default calls $fmt->fromFh()

## $fmt = $fmt->fromFh($filename_or_handle)
##  + default calls $fmt->fromString() on file contents
sub fromFh {
  return shift->SUPER::fromFh_str(@_);
}


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

## $fmt = $fmt->parsePerlString(\$str)
sub parsePerlString {
  my $fmt = shift;
  my ($doc);
  $doc = eval "no strict; ".(ref($_[0]) ? ${$_[0]} : $_[0]).";";
  $fmt->warn("parsePerlString(): error in eval: $@") if ($@);
  $doc = DTA::CAB::Utils::deep_utf8_upgrade($doc);
  $fmt->{doc} = $fmt->{raw} ? $doc : $fmt->forceDocument($doc);
  return $fmt;
}

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

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


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

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

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

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

## $fmt = $fmt->putToken($tok)
sub putToken {
  $_[0]{fh}->print($_[0]{dumper}->Reset->Indent($_[0]{level}||0)->Names(['token'])->Values([$_[1]])->Dump."\$token\n");
  return $_[0];
}

## $fmt = $fmt->putSentence($sent)
sub putSentence {
  $_[0]{fh}->print($_[0]{dumper}->Reset->Indent($_[0]{level}||0)->Names(['sentence'])->Values([$_[1]])->Dump."\$sentence\n");
  return $_[0];
}

## $fmt = $fmt->putDocument($doc)
sub putDocument {
  $_[0]{fh}->print($_[0]{dumper}->Reset->Indent($_[0]{level}||0)->Names(['document'])->Values([$_[1]])->Dump."\$document\n");
  return $_[0];
}


1; ##-- be happy

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

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

=head1 NAME

DTA::CAB::Format::Perl - Datum parser|formatter: perl code via Data::Dumper, eval()

=cut

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

=head1 SYNOPSIS

 use DTA::CAB::Format::Perl;
 
 $fmt = DTA::CAB::Format::Perl->new(%args);
 
 ##========================================================================
 ## Methods: Input
 
 $fmt = $fmt->close();
 $fmt = $fmt->parsePerlString($str);
 $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

DTA::CAB::Format::perl is a L<DTA::CAB::Format|DTA::CAB::Format> datum parser/formatter
which reads & writes data as perl code via eval() and Data::Dumper respectively.

=cut

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

=head2 Globals

=over 4

=item Variable: @ISA

DTA::CAB::Format::Perl
inherits from
L<DTA::CAB::Format|DTA::CAB::Format>.

=item Filenames

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

 /\.(?i:prl|pl|perl|dump)$/

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

=back

=cut

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

=head2 Constructors etc.

=over 4

=item new

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

Constructor.

%args, %$fmt:

 ##---- Input
 doc    => $doc,                 ##-- buffered input document
 ##
 ##---- Output
 dumper => $dumper,              ##-- underlying Data::Dumper object
 ##
 ##---- INHERITED from DTA::CAB::Format
 #encoding => $encoding,         ##-- n/a
 level     => $formatLevel,      ##-- sets Data::Dumper->Indent() option
 outbuf    => $stringBuffer,     ##-- buffered output

=back

=cut

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

=head2 Methods: Persistence

=over 4

=item noSaveKeys

 @keys = $class_or_obj->noSaveKeys();

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

=back

=cut

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

=head2 Methods: Input

=over 4

=item close

 $fmt = $fmt->close();

Override: close currently selected input source.

=item fromString

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

Override: select input from the string $string.

=item parsePerlString

 $fmt = $fmt->parsePerlString($str);

Evaluates $str as perl code, which is expected to
return a L<DTA::CAB::Document|DTA::CAB::Document>
object (or something which can be massaged into one),
and sets $fmt-E<gt>{doc} to this new document object.

=item parseDocument

 $doc = $fmt->parseDocument();

Returns the current contents of $fmt-E<gt>{doc},
e.g. the most recently parsed document.

=back

=cut

##----------------------------------------------------------------
## DESCRIPTION: DTA::CAB::Format::Perl: 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.
This implementation just returns $fmt-E<gt>{outbuf},
which should already be a byte-string, and has no need of encoding.

=item putToken

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

Override: writes a token to the output buffer (non-destructive on $tok).

=item putSentence

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

Override: write a sentence to the outupt buffer (non-destructive on $sent).

=item putDocument

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

Override: write a document to the outupt buffer (non-destructive on $doc).

=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 is:

 $document = bless( {
   'body' => [
     {
       'tokens' => [
         {
           'xlit' => {
             'isLatin1' => '1',
             'latin1Text' => 'wie',
             'isLatinExt' => '1'
           },
           'text' => 'wie',
           'hasmorph' => '1',
           'moot' => {
             'tag' => 'PWAV',
             'word' => 'wie',
             'lemma' => 'wie'
           },
           'msafe' => '1',
           'exlex' => 'wie',
           'errid' => 'ec',
           'lang' => [
             'de'
           ]
         },
         {
           'xlit' => {
             'isLatinExt' => '1',
             'latin1Text' => 'oede',
             'isLatin1' => '1'
           },
           'msafe' => '0',
           'moot' => {
             'word' => "\x{f6}de",
             'tag' => 'ADJD',
             'lemma' => "\x{f6}de"
           },
           'text' => 'oede'
         },
         {
           'errid' => 'ec',
           'xlit' => {
             'isLatinExt' => '1',
             'latin1Text' => '!',
             'isLatin1' => '1'
           },
           'exlex' => '!',
           'moot' => {
             'word' => '!',
             'tag' => '$.',
             'lemma' => '!'
           },
           'msafe' => '1',
           'text' => '!'
         }
       ],
       'lang' => 'de'
     }
   ]
 }, 'DTA::CAB::Document' );
 $document

=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.

