=pod

=head1 LICENSE

Copyright [1999-2015] Wellcome Trust Sanger Institute and the EMBL-European Bioinformatics Institute
Copyright [2016-2022] EMBL-European Bioinformatics Institute

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

     http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.

=head1 NAME

Bio::EnsEMBL::IO::Parser::EMBL - A record-based parser that reads EMBL format.

=head1 DESCRIPTION

EMBL format reading is done according to the following specification:
ftp://ftp.ebi.ac.uk/pub/databases/embl/doc/usrman.txt

=cut

package Bio::EnsEMBL::IO::Parser::EMBL;

use strict;
use warnings;

use parent qw/Bio::EnsEMBL::IO::TokenBasedParser/;

=head2 open

    Description: Open Fasta file
    Argument [1]: Path to file 
    Returntype : Ensembl::IO::Parser::EMBL object

=cut

sub open {
    my ($caller, $filename, @other_args) = @_;
    my $class = ref($caller) || $caller;
    
    my $self = $class->SUPER::open($filename, undef, '^//', @other_args);

    # pre-load peek buffer
    $self->next_block();
    
    return $self;
}

# store each row in a hash keyed with their symbol.
# 
# $self->{record}->{symbol}->[]
#

sub read_record {
    my $self = shift;
    # purge previous record
    foreach (keys (%{$self->{record}})) {$self->{record}->{$_} = []}

    # this is necessary if we want to intercept the record ID
    my $field_type = substr($self->{current_block}, 0, 2);
    push @{$self->{record}->{$field_type}}, $self->{current_block};
    
    $field_type = '';
    until ($field_type eq 'SQ' || $self->is_at_end_of_record) {
        if (!$field_type || $field_type eq 'XX' || $self->is_metadata || $field_type eq 'SQ') {
            $self->next_block;
            $field_type = substr($self->{current_block},0,2);
            next;
        }
        # references are contextual, so just keep the text in a block
        if ($field_type =~ /^R/) {$field_type = 'References'}
        push @{$self->{record}->{$field_type}},$self->{current_block};
        $self->next_block;
        $field_type = substr($self->{current_block},0,2);
    }
    if ($field_type eq 'SQ') {
        push @{$self->{record}->{$field_type}},$self->{current_block};
        $self->next_block;
        until ($self->is_at_end_of_record) {
            my $seq = $self->{current_block};
            chomp $seq;
            $seq =~ s/\d+$//;
            $seq =~ s/\s//g;
            $self->{record}->{sequence} .= $seq;
            $self->next_block;
        }
    }
}

sub is_metadata {
    my $self = shift;
    return $self->{current_block} =~ /^#/;
}

sub read_metadata {
    return;
}

sub get_sequence {
    my $self = shift;
    return $self->{record}->{sequence};
}

=head2 get_id
    Description: Get the ID without extra qualifiers in the record
    Returntype : String
=cut

sub get_id {
    my $self = shift;
    return (split /\s/, $self->get_stuff('ID')->[0])[0];
}

=head2 get_accessions
    Description: Get an unpunctuated list of the AC fields 
    Returntype : listref
=cut

sub get_accessions {
    my $self = shift;
    return $self->get_stuff('AC');
}

=head2 get_description
    Description: Fetch the DE field, combined into a single string
    Returntype : String
=cut

sub get_description {
    my $self = shift;
    return $self->smush_text('DE');
}

=head2 get_keywords
    Description: Get a list of EMBL keywords. An empty string implies no keywords.
    Returntype : ListRef of strings
=cut

sub get_keywords {
    my $self = shift;
    my $keys = $self->get_stuff('KW');
    return [] unless $keys;
    return $keys;
}

sub get_species {
    my $self = shift;
    return $self->smush_text('OS');
}

sub get_classification {
    my $self = shift;
    return $self->get_stuff('OC');
}

sub get_date {
    my $self = shift;
    return $self->get_stuff('DT');
}

=head2 get_database_cross_references
    Description:
    Returntype: ListRef of strings in the format DB:ID
=cut

sub get_database_cross_references {
  my $self = shift;
  my $list = $self->get_raw_database_cross_references;
  return unless defined $list;

  chomp @$list;
  my @xrefs = map { $_ =~ s/^\w\w\s+// and join(':', (split /; /)[0..1]) } @$list;
  
  return \@xrefs;
}

sub smush_text {
    my $self = shift;
    my $key = shift;
    my $list = $self->{record}->{$key};
    if (!defined $list) {return}
    chomp @$list;
    map { $_ =~ s/^\w\w\s+//} @$list;
    return join '',@$list;
}

=head2 get_stuff
    Description: Convenience method for the extraction of arbitrary keys from their
                 multi-line eccentric EMBL format
    Returntype : listref
=cut

sub get_stuff {
    my $self = shift;
    my $key = shift;
    my $list = $self->{record}->{$key};
    if (!defined $list) {return}
    chomp @$list;
    $list->[-1] =~ s/\.//; # last entry has a full stop on the end
    map { $_ =~ s/^\w\w\s+//} @$list;
    my @trimmed_things = split(';\s*',join(' ',@$list));
    return \@trimmed_things;
}

=head2 get_raw_id
    Description: Get the ID field as it was found within the source file 
    Returntype : listref
=cut

sub get_raw_id {
    my $self = shift;
    return $self->{record}->{ID};
}

sub get_raw_accessions {
    my $self = shift;
    return $self->{record}->{AC};
}

sub get_raw_description {
    my $self = shift;
    return $self->{record}->{DE};
}

sub get_raw_keywords {
    my $self = shift;
    return $self->{record}->{KW};
}

sub get_raw_date {
    my $self = shift;
    return $self->{record}->{DT};
}

sub get_raw_species {
    my $self = shift;
    return $self->{record}->{OS};
}

sub get_raw_classification {
    my $self = shift;
    return $self->{record}->{OC};
}

sub get_raw_references {
    my $self = shift;
    return $self->{record}->{References};
}

sub get_raw_features {
    my $self = shift;
    return $self->{record}->{FT};
}

sub get_raw_comments {
    my $self = shift;
    return $self->{record}->{CC};
}

sub get_raw_assembly_header {
    my $self = shift;
    return $self->{record}->{AH};
}

sub get_raw_assembly {
    my $self = shift;
    return $self->{record}->{AS};
}

sub get_raw_contig {
    my $self = shift;
    return $self->{record}->{CO};
}

sub get_raw_pelevel {
    my $self = shift;
    return $self->{record}->{PE};
}

sub get_raw_database_cross_references {
  my $self = shift;
  return $self->{record}->{DR};
}

sub get_pelevel {
    my $self = shift;
    return substr($self->get_raw_pelevel->[0], 5, 1);
}

1;
