package AMF::2ReDIF;

=head1 NAME

AMF::2ReDIF -- convert AMF::Record object to ReDIF::Record template object

=head1 SYNOPSIS

  use AMF::Parser;
  use AMF::2ReDIF;

  ...
  $rec = amf_get_next_record;

  my $template = AMF::2ReDIF::translate( $rec );

  if ( $template ) {
    my $type   = $template -> {'template-type'}[0];
    my $handle = $template -> {handle}[0];
    ...

=head1 DESCRIPTION

This module's only function for external consumption is C<translate()>.  It
takes an AMF::Record object as an argument and returns a ReDIF::Record object.
Returns undef if translation is impossible.  ReDIF::Record object is template
hash reference, blessed into ReDIF::Record class.

The AMF and ReDIF data models do not match, although overlap very much.  Very
likely the translation will loose some of the original AMF's information,
which can't be represented in ReDIF terms.

So, this module is not supposed to work on 100% of your data.  It will
translate to ReDIF only "reasonably well-behaved AMF" and fail otherwise.

Also, we do not guarantee that the resulting template structure will be
anything like the structure produced by ReDIF::Parser.  The structure itself
-- will be almost the same (but blessed into ReDIF::Record).  Some technical
rarely-used top-level elements will be absent (such as C<FILENAME, STARTFPOS,
START_LINE_NUMBER, ENCODING, REPORT, ERRORS, MESSAGES, WARNINGS, TEXT>).  The
AMF adjectives' values and identifiers are not checked equivalently to how
ReDIF::Parser does that.  It doesn't do all the checks that redif.spec does.
Be warned.

One of the best ways to see this module in action and to see what exactly
C<translate()> function produces, is to use C<amfch> utility with C<-o> option
on an AMF file.


=head1 SEE ALSO

L<ReDIF::Parser>, L<ReDIF::Record>, L<amfch>, L<AMF::Record>, L<AMF::Parser>

=head1 AUTHOR

Ivan Kurmanov, http://www.ahinea.com/en/
for ACIS project, http://acis.openlib.org/

=cut


use strict;
use warnings;

use Carp::Assert;
require UNIVERSAL;

use ReDIF::Record;

require AMF;


use vars qw( $rec $src $cuda $te $status $pref @stack );

sub attr ($@);

sub translate {
  $src = $rec = shift;

  $status = 0;
  $pref   = '';
  @stack  = ();

  my $id;
  if ( $id = $rec -> id ) {
    $te = ReDIF::Record -> new( $id, "ReDIF-something 1.0" );
    $cuda = $te;

  } else {
    return undef;
  }
 
  my $type = $rec -> type;
  if ( $type eq 'text' ) {
    make_document_te();

  } elsif ( $type eq 'person' ) {
    make_person_te();

  } elsif ( $type eq 'organization' ) {
    make_institution_te();

  } elsif ( $type eq 'collection' ) {
    process_collection_no();
  }

  if ( $te ) {
    attr 'handle', lc $rec ->id;
    
    if ( exists $rec -> {MD5SUM} ) {
      $te -> {MD5SUM} = $rec -> {MD5SUM};
    }
    
    my $res = 'good';
    if ( $te -> {PROBLEMS} ) {  $res = 'bad';  }
    $te -> {RESULT} = $res;
  }

  return $te;
}



my %text2redif = 
  ( "preprint" => 'paper',
    "article"  => 'article',
    "book"     => 'book',
    "bookitem" => 'chapter',
    "code"     => 'software',
    "conferencepaper" => "paper",
    
);


sub __attr ($@) {
  my $at = shift;
  my @va = @_;

  $te -> add_property( $at, @va );
}


sub attr ($@) {
  my $at = shift;
  my @va = @_;

  if ( not scalar @va 
       or not defined $va[0] ) {
    return;
  }
  for ( $cuda -> {$at} ) {
    if ( not $_ ) {
      $_ = [];
    }
    push @$_, @va;
  }
}

use Carp qw( confess );

sub transf ($;$) {
  my $name = shift;
  my $what = shift || $name;
  
  if ( UNIVERSAL::isa( $src, "AMF::Noun" ) ) {
    attr $name, $src -> get_value( $what );

  } elsif ( UNIVERSAL::isa( $src, "HASH" ) ) {
    attr $name, $src ->{ $what }[0];

  } else {
    confess "Extract $what from $src--HOW??";
  }
}


sub get ($) {
  my $what = shift;
  
  if ( UNIVERSAL::isa( $src, "AMF::Noun" ) ) {
    return $src -> get_value( $what );

  } elsif ( UNIVERSAL::isa( $src, "HASH" ) ) {
    return $src ->{ $what }[0];

  } else {
    die "Extract $what from $src--HOW??";
  }
}


sub open_cluster {
  my $type   = shift;
  my $prefix = shift;
  my $source = shift;
  
  push @stack, [ $cuda, $pref, $src ];

  if ( $pref ) {
    $pref .= "$prefix-";
  } else {
    $pref = "$prefix-";
  }
  
  my $self = { TYPE   => $type,
               PREFIX => $pref, };

  attr $prefix, $self;

  $cuda = $self;
  $src  = $source;
}

sub close_cluster {
  my $state = pop @stack;
  assert( $state );
  $cuda = $state -> [0];
  $pref = $state -> [1];
  $src  = $state -> [2];
}


sub problem ($$) {
  my $le = shift;
  my $me = shift;

  if ( $status < $le ) {
    $status = $le;
  }

  for ( $te -> {PROBLEMS} ) {
    if ( $_ ) {
      $_ .= "\n$me";
    } else {
      $_ = $me;
    }
  }
}


sub fatal ($) {
  my $m = shift;
  problem 3, $m;
}

sub error ($) {
  my $m = shift;
  problem 2, $m;
}

sub warning ($) {
  my $m = shift;
  problem 1, $m;
}


sub must_be (@) {
  my @ats = shift;
  foreach ( @ats ) {
    if ( not $cuda -> {$_} ) {
      error "Attribute $_ is absent";
    }
  }
}
  


#############################################################
###   ReDIF   S P E C I F I C S 
#############################################################





sub make_person_clu ($$) {
  my $prefix = shift;
  my $noun   = shift;

  return if not $noun;
  return if not $noun -> get_value( 'name' );

  my $orgmode;

  if ( $noun -> type eq 'organization' ) {
    error "Organization where a person description expected";
    $orgmode = 1;
  }

  open_cluster( 'person', $prefix, $noun );

  transf 'name';
  transf 'email';
  transf 'homepage';

  if ( not $orgmode 
       and $noun -> {ispartof} ) {
    foreach ( get 'ispartof' ) {
      make_org_clu ( 'workplace', $_ );
    }
  }

  transf 'fax';
  transf 'phone';
  transf 'postal';

  transf 'person', '@id';
  transf 'person', '@ref';

  close_cluster;
}

sub make_org_clu ($$) {
  my $prefix = shift;
  my $noun   = shift;
  
  return if not $noun;
  return if not $noun -> get_value( 'name' );

  open_cluster( 'organization', $prefix, $noun );

  my @names = $noun -> get_value_wattr( 'name' );
  
  my $name;
  my $name_en;

  foreach ( @names ) {
    my $data = $_ ->[0];
    my $at   = $_ ->[1];

    my $lang;
    if ( $at ) {
      $lang = $at ->{'xml:lang'};
    }

    if ( $lang 
         and $lang eq 'en' ) {
      $name_en = $data;
    } else {
      $name = $data;
    }

    if ( $name and $name_en ) {  last;  }
  }

  if ( not $name ) {
    if ( $name_en ) {  $name = $name_en;  }
    else { fatal "no name for organization"; }
  }
   
  attr 'name', $name;
  attr 'name-english', $name_en;
   
  ###  XXX Location ?
  transf 'homepage';
  transf 'email';
  transf 'postal';
  transf 'phone';
  transf 'fax';
  
  transf 'institution', '@id';
  transf 'institution', '@ref';

  close_cluster;
}


sub make_file_clu ($$) {
  my $prefix = shift;
  my $noun   = shift;

  return if not $noun;
  return if not $noun -> get_value( 'url' );

  open_cluster( 'file', $prefix, $noun );
  transf 'url';
  transf 'format';
  transf 'function';
  transf 'restriction';
  close_cluster;

}

########################################################
###   O T H E R    T O O L S
########################################################


sub transf_relations ($$) {
  my $role = shift;
  my $type = shift;

  my $verb = "is" . $role . "of";
  foreach ( get $verb ) {
    my $oty = $_ -> type;
    
    if ( $oty ne $type ) { next; }

    my $ref = $_->{REF};
    if ( $ref ) {
      my $ty  = $_ -> get_value( 'type' );
      my $rty = $ty ? $text2redif{$ty} : 0;
      if ( $rty ) {
        attr "$role-$rty", $ref;
      } else {
        attr "X-$role-of", $ref;
      }
    }
  }
}

sub transf_creators (@) {
  foreach ( @_ ) {
    my $role = $_;
    foreach ( get "has$role" ) {
      assert ( ref $_ and UNIVERSAL::isa( $_, 'AMF::Noun' ) );
      if ( $_ -> type eq 'person' ) {
        make_person_clu( $role, $_ );
      } else {
        make_org_clu( $role, $_ );
      }
    }
  }
}




########################################################
###   R e D I F   D O C U M E N T   T E M P L A T E S 
########################################################

sub make_document_te {

  my $type    = $rec ->type;
  my $subtype = $rec ->get_value( 'type' );

  if ( $subtype ) {
    my $tetype  = $text2redif{$subtype};
    assert( $tetype ) if DEBUG;
    $tetype = "ReDIF-" . ucfirst( $tetype ) . " 1.0";
    $te -> set_scalar_property( 'TYPE', $tetype );
    attr 'template-type', $tetype;
    
  } else {
    fatal "Document type is unknown";
  }


  transf 'title';
  must_be 'title';

  ###  authors

  transf_creators 'author', 'editor';
  must_be 'author';

  transf 'abstract';
  transf 'keywords';
  transf 'note', 'comment';


  ###  files

  my $f = $rec -> {file};

  foreach ( @$f ) {
    make_file_clu( 'file', $_->[0] );
  }


  ### dates

  my @dates = $rec -> get_value_wattr( 'date' );
  my $crea;
  my $publ;
  my @revi;

  foreach ( @dates ) {
    my $data = $_ ->[0];
    my $at   = $_ ->[1];
    
    my $event;
    if ( $at 
         and $at ->{event} ) {
      $event = $at ->{event};
    } else { next; }
    
    if ( $event eq 'created' ) {
      $crea = $data;

    } elsif ( $event eq 'available' ) {
#      $publ = $data;

    } elsif ( $event eq 'issued' ) {
      $publ = $data;

    } elsif ( $event eq 'modified' ) {
      push @revi, $data;
    }
  }

  attr 'creation-date', $crea;
  attr 'revision-date', @revi;


  {
    my @class = $rec -> {classification};
    my @jel;
    
    foreach ( @class ) {
      if (     $_ ->[1] 
           and $_ ->[1] {'xsi:type'} eq 'jel1991' ) {
        push @jel, $_ ->[0];
      }
    }
    my $jel_value = join ' ', @jel;
    attr 'classification-jel', $jel_value;
  }

  ###  QUESTIONABLE POINTS: 
  ### 
  ###  AMF               ReDIF
  ###  ---------------------------------------------
  ###  status         -> publication-status 
  ###  displaypage    -> order-url
  ###  email          -> note: "contact email: em@ail" ?
  ###                 -> 
  ###  serial/part    -> 
  ###  ?


  ###  No match in AMF for these ReDIF attributes:
  ###
  ###  template-type | attributes
  ###  ---------------------------------------------
  ###    *           | number, keywords-attent
  ###    paper       | availability, restriction, price, length
  ###    book        | edition, ISBN
  ###    chapter     | provider-(ORG), sponsor-(ORG), chapter
  ###    software    | requires, programming-language, size
  

  if ( $subtype eq 'article' ) {
    my @s = get 'serial';
    my $serial = shift @s;  ### only the first one works
    
    $src = $serial;
    

    transf 'journal', 'journaltitle';

    my $date = get 'issuedate';
    ###  get year and month
    if ( $date =~ /^(\d{4})(\-\d{2})?/m ) {
      attr "year",  $1;
      attr "month", $2;
    }

    transf 'volume';
    transf 'issue';

    my $startpage = get 'startpage';
    my $endpage   = get 'endpage'  ;
    if ( $startpage and $endpage ) {
      attr 'pages', "$startpage-$endpage";
    } else {
      transf 'pages';
    }
    
    $src = $rec;
      
  }

  ###  series or book name
  if ( get "ispartof/title" ) {
    my @coll = get "ispartof";

    foreach ( @coll ) {

      if ( $_ -> type ne 'collection' ) { next; }

      my $ctype  = $_ -> get_value( 'type' );
      my $ctitle = $_ -> get_value( 'title' );
      if ( $ctype eq 'serial' ) {
        attr 'series', $ctitle;

      } elsif ( $ctype eq 'book' ) {
        ###  is this a chapter?
        attr 'book-title', $ctitle;
      }
    }

  } 
  

  if ( $subtype eq 'book' ) {  ###  if that's a book text

    ###  publication year, month
    if ( $publ and $publ =~ /^(\d{4})(\-\d{2})?/m ) {
      attr "year",  $1;
      attr "month", $2;
    }


    if ( get 'haspart/@id' ) {
      
      foreach ( get "haspart" ) {
        
        if ( $_ -> type ne 'text' ) { next; }
        
        my $pid    = $_ -> id;
        my $ptype  = $_ -> get_value( 'type' );
#        my $ptitle = $_ -> get_value( 'title' );
#        if ( $ptype eq 'bookitem' ) { ### XX  is this check needed?
          attr 'haschapter', $pid;
#        }          
      }
      
    }

    get_haspublisher ();

  }



}


sub get_haspublisher {
  if ( get "haspublisher/name" ) {
    transf_creators 'publisher';
  }
}



sub make_person_te {

  ### $rec 
  
  my $type = "ReDIF-Person 1.0";

  $te -> set_scalar_property( 'TYPE', $type );
  attr 'template-type', $type;

  transf 'name-full',   'name';
  transf 'name-first',  'givenname';
  transf 'name-middle', 'additionalname';
  transf 'name-last',   'familyname';
  transf 'name-prefix', 'nameprefix';
  transf 'name-suffix', 'namesuffix';

  must_be 'name-full', 'name-first', 'name-last';

  foreach ( get 'ispartof' ) {
    if ( $_ -> type ne 'organization' ) { next; }
    if ( $_ -> {name} ) {
      make_org_clu ( 'workplace', $_ );

    } elsif ( $_ -> {REF} ) { 
      attr 'workplace-organization', $_ ->{REF};
    }
  }

  transf 'email';
  transf 'homepage';
  transf 'postal';
  transf 'phone';
  transf 'fax';

  transf_relations 'author', 'text';
  transf_relations 'editor', 'text';
  transf_relations 'editor', 'collection';

  ### classification jel -- no such AMF adjective

  my $object = $te;
  ###
  ###  redif.spec's post-processing
  ### 
  if ( ref ( $object->{'workplace-institution'} ) eq 'ARRAY' ) {
    $object->{'workplace-organization'} = $object->{'workplace-institution'};
  }

}


sub process_collection_no {

  my $id = get 'ID';
  my $type;

  my $otype = get 'type';
  my $archive_mode;

  if ( $otype eq 'journal' 
       or $otype eq 'serial' 
       or $otype eq 'proceedings' 
     ) {
    $type = 'ReDIF-Series 1.0';

  } elsif ( $otype eq 'book' ) {
    make_book_te_from_collection ();
    
  } elsif ( $otype eq 'archive' ) {
    return make_archive_te ();

  } else {
    undef $te;
    return;
  }
  
#  if ( index( $id, ":" ) != rindex( $id, ":" ) ) {
#    ###  id contains two colons or no colon at all
#  } else {
#    $type = 'ReDIF-Archive 1.0';
#  }
  
  $te -> set_scalar_property( 'TYPE', $type );
  attr 'template-type', $type;
 
  transf "name", "title";
  transf "maintainer-email", "hasmaintainer/email";

  if ( $type eq 'journal' ) {
    attr "type", 'ReDIF-Article';
  }

###  transf "type", 'XXX';
# transf "order-email",    'XXX';
# transf "order-homepage", 'XXX';
# transf "order-postal",   'XXX';
# transf "price", 'XXX';
  
  ### provider
  transf_creators 'publisher';

  ### restriction
  transf "maintainer-phone",  "hasmaintainer/phone";
  transf "maintainer-fax",    "hasmaintainer/fax";
  transf "maintainer-name",   "hasmaintainer/name";

  transf "description";
#  transf "classification-jel", "XXX";
#  transf "keywords", "XXX";

  transf_creators 'editor';
  transf "notification", "XXX";
  transf "issn", 'XXX';


}



sub make_archive_te {

  my $type = 'ReDIF-Archive 1.0';
  $te -> set_scalar_property( 'TYPE', $type );
  attr 'template-type', $type;

  transf "URL", "accesspoint";
  transf "maintainer-email", "hasmaintainer/email";
  transf "name", "title";

  transf "maintainer-name",   "hasmaintainer/name";
  transf "maintainer-phone",  "hasmaintainer/phone";
  transf "maintainer-fax",    "hasmaintainer/fax";

  ## classification

  transf "homepage";
  transf "description";

  ## notification, restriction

}


sub make_book_te_from_collection {
  my $type = 'ReDIF-Book 1.0';
  $te -> set_scalar_property( 'TYPE', $type );
  attr 'template-type', $type;

  transf 'title';

  transf_creators 'editor', 'publisher';

  # Author-(PERSON*)
  # Year
  # Month: Month of publication, non-repeatable.
  # Volume
  # Edition

  my @ispartof = get 'ispartof';
  foreach ( @ispartof ) {
    if ( $_ -> type eq 'collection' ) {
      my $cty = $_ -> get_value( 'type' );
      my $ser = $_ -> get_value( 'title' );
      if ( $cty eq 'serial' 
           and $ser ) {
        attr "series", $ser;
      }
    }
  }

  # ISBN
  # Publication-Status
  transf "note", "description";
  # abstract

  # Classification-scheme
  # Keywords[-scheme]

  my @haspart = get 'haspart';
  foreach ( @haspart ) {
    if ( $_ -> type eq 'text' ) {
      my $tty = $_ -> get_value( 'type' );
      my $chi = $_ -> get_value( 'ID' );
      my $chr = $_ -> get_value( 'REF' );
      attr "haschapter", $chi;
      attr "haschapter", $chr;
    }
  }


}


sub make_institution_te {

  my $type = 'ReDIF-Institution 1.0';
  $te -> set_scalar_property( 'TYPE', $type );
  attr 'template-type', $type;

  
  my @clusters = qw( primary secondary tertiary );

  for ( get 'ispartof/ispartof' ) {
    my $prefix = shift @clusters;
    make_org_clu $prefix, $_;
    last;
  }

  for ( get 'ispartof' ) {
    my $prefix = shift @clusters;
    make_org_clu $prefix, $_;
    last;
  }

  { 
    my $prefix = shift @clusters;
    make_org_clu $prefix, $rec;
  }

  ### 
  ###  Copied from the redif.spec:
  ###

  my $object = $te;

  my ( $title, $title_en );
  
  my @tit;  my @titEn;
  foreach ( qw( primary secondary tertiary ) ) {
    if ( $object ->{$_} ) {
      my $branch = $object ->{$_}[0];
      my $name   = $branch ->{name}[0];
      my $nameEn;
      if ( exists $branch ->{'name-english'} ) {
        $nameEn = $branch ->{'name-english'}[0];
      } else { $nameEn = $name; }
      push @tit,   $name;
      push @titEn, $nameEn;
    };
  };
  $title    = join "\n\n", @tit;
  $title_en = join "\n\n", @titEn;
  
  $object -> {name}      = $title;
  
  if ( $title ne $title_en ) {
    $object -> {'name-en'} = $title_en;
  };
  

}



1;

