File Coverage

blib/lib/Bio/Phylo/Parsers/Nexus.pm

Criterion	Covered	Total	%
statement	558	677	82.4
branch	195	282	69.1
condition	114	195	58.4
subroutine	45	53	84.9
pod			n/a
total	912	1207	75.5

package Bio::Phylo::Parsers::Nexus;
use strict;
use base 'Bio::Phylo::Parsers::Abstract';
use Bio::Phylo::Factory;
use Bio::Phylo::IO 'parse';
use Bio::Phylo::Util::CONSTANT qw':objecttypes looks_like_instance';
use Bio::Phylo::Util::Exceptions 'throw';

# TODO: handle mixed? distances, splits, bipartitions
my $TAXA = _TAXA_;
my $MATRIX = _MATRIX_;

# useful regular expressions
my $COMMENT = qr|^\[|;    # crude, only checks first char, use after tokenizing!
my $QUOTES_OR_BRACKETS =
  qr/[\[\]'"]/mox;    # catch all for opening/closing square brackets and quotes
my $OPENING_QUOTE_OR_BRACKET =
  qr/^(.*?)([\['"].*)$/mox;    # capturing regex for opening sq. br. & q.

# this is a dispatch table whose sub references are invoked
# during parsing. the keys match the tokens upon which the
# respective subs are called. Underscored (private) fields are for parsing
# context. The fields of this table comprise the default state of the
# parser object.
my %defaults = (
    '_lines'           => undef,
    '_current'         => undef,
    '_previous'        => undef,
    '_begin'           => undef,
    '_ntax'            => undef,
    '_nchar'           => undef,
    '_gap'             => undef,
    '_missing'         => undef,
    '_i'               => undef,
    '_tree'            => undef,
    '_trees'           => undef,
    '_treename'        => undef,
    '_treestart'       => undef,
    '_row'             => undef,
    '_matrixtype'      => undef,
    '_found'           => 0,
    '_linemode'        => 0,
    '_taxlabels'       => [],
    '_tokens'          => [],
    '_context'         => [],
    '_translate'       => [],
    '_symbols'         => [],
    '_charlabels'      => [],
    '_statelabels'     => [],
    '_charstatelabels' => [],
    '_tmpstatelabels'  => [],
    '_comments'        => [],
    '_treenames'       => [],
    '_matrixrowlabels' => [],
    '_matrix'          => {},
    '_charset'         => {},
    '_taxset'          => {},
    'begin'            => \&_begin,
    'taxa'             => \&_taxa,
    'title'            => \&_title,
    'dimensions'       => \&_dimensions,
    'ntax'             => \&_ntax,
    'taxlabels'        => \&_taxlabels,
    'blockid'          => \&_blockid,
    'data'             => \&_data,
    'characters'       => \&_characters,
    'codons'           => \&_codons,
    'nchar'            => \&_nchar,
    'format'           => \&_format,
    'datatype'         => \&_datatype,
    'matchchar'        => \&_matchchar,
    'gap'              => \&_gap,
    'missing'          => \&_missing,
    'charlabels'       => \&_charlabels,
    'statelabels'      => \&_statelabels,
    'charstatelabels'  => \&_charstatelabels,
    'symbols'          => \&_symbols,
    'items'            => \&_items,
    'matrix'           => \&_matrix,
    'charset'          => \&_charset,
    'taxset'           => \&_taxset,
    'trees'            => \&_trees,
    'translate'        => \&_translate,
    'tree'             => \&_tree,
    'utree'            => \&_tree,
    'end'              => \&_end,
    'endblock'         => \&_end,
    '#nexus'           => \&_nexus,
    'link'             => \&_link,
    ';'                => \&_semicolon,
    'interleave'       => \&_interleave,
);

=head1 NAME

Bio::Phylo::Parsers::Nexus - Parser used by Bio::Phylo::IO, no serviceable parts inside

=head1 DESCRIPTION

This module parses nexus files. It is called by the L module,
there is no direct usage. The parser can handle files and strings with multiple
tree, taxon, and characters blocks whose links are defined using Mesquite's
"TITLE = 'some_name'" and "LINK TAXA = 'some_name'" tokens.

The parser returns a reference to an array containing one or more taxa, trees
and matrices objects. Nexus comments are stripped, private nexus blocks (and the
'assumptions' block) are skipped. It currently doesn't handle 'mixed' data.

=begin comment

 Type    : Constructor
 Title   : _new
 Usage   : my $nexus = Bio::Phylo::Parsers::Nexus->_new;
 Function: Initializes a Bio::Phylo::Parsers::Nexus object.
 Returns : A Bio::Phylo::Parsers::Nexus object.
 Args    : none.

=end comment

=cut

sub _process_defaults {
    my $self = shift;
    for my $key ( keys %defaults ) {
        if ( looks_like_instance( $defaults{$key}, 'ARRAY' ) ) {
            $self->{$key} = [];
        }
        elsif ( looks_like_instance( $defaults{$key}, 'HASH' ) ) {
            $self->{$key} = {};
        }
        else {
            $self->{$key} = $defaults{$key};
        }
    }
    return $self;
}

=begin comment

 Type    : Wrapper
 Title   : _from_handle(\*FH)
 Usage   : $nexus->_from_handle(\*FH);
 Function: Does all the parser magic, from a file handle
 Returns : ARRAY
 Args    : \*FH = file handle

=end comment

=cut

sub _parse {
    my $self = shift;
    $self->_process_defaults;
    $self->_logger->info("going to parse nexus data");
    $self->{'_lines'}  = $self->_stringify(@_);
    $self->{'_tokens'} = $self->_tokenize( $self->{'_lines'} );

    # iterate over tokens, dispatch methods from %{ $self } table
    # This is the meat of the parsing, from here everything else is called.
    $self->_logger->info("tokenized and split data, going to parse blocks");
    my $i = 0;
    my $private_block;
    my $token_queue = [ undef, undef, undef ];
    no strict 'refs';
  TOKEN_LINE: for my $token_line ( @{ $self->{'_tokens'} } ) {
        if ( not $self->{'_linemode'} ) {
          RAW_TOKEN: for my $raw_token ( @{$token_line} ) {
                if ( $raw_token =~ qr/^\[/ ) {
                    push @{ $self->{'_comments'} }, $raw_token;
                    next RAW_TOKEN;
                }
                my $lower_case_token = lc($raw_token);
                push @$token_queue, $lower_case_token;
                shift @$token_queue;
                if ( exists $self->{$lower_case_token} and not $private_block )
                {
                    if ( ref $self->{$lower_case_token} eq 'CODE' ) {
                        $self->{'_previous'} = $self->{'_current'};
                        $self->{'_current'}  = $lower_case_token;

                        # pull code ref from dispatch table
                        my $c = $self->{$lower_case_token};

                        # invoke as object method
                        $self->$c($raw_token);
                        next RAW_TOKEN;
                    }
                }
                elsif ( $self->{'_current'} and not $private_block ) {
                    my $c = $self->{ $self->{'_current'} };
                    $self->$c($raw_token);
                    next RAW_TOKEN;
                }

                # $self->{'_begin'} is switched 'on' by &_begin(), and 'off'
                # again by any one of the appropriate subsequent tokens, i.e.
                # taxa, data, characters and trees
                if (    $self->{'_begin'}
                    and not exists $self->{$lower_case_token}
                    and not $private_block )
                {
                    $private_block = $raw_token;
                    next RAW_TOKEN;
                }

                # jump over private block content
                if (    $private_block
                    and $token_queue->[-2] eq 'end'
                    and $token_queue->[-1] eq ';' )
                {
                    $private_block = 0;
                    $self->_logger->info(
                        "Skipped private $private_block block");
                    next RAW_TOKEN;
                }
                else {
                    next RAW_TOKEN;
                }
            }
        }
        elsif ( $self->{'_linemode'} ) {
            my $c = $self->{ $self->{'_current'} };
            push @{$token_queue}, $token_line;
            shift @$token_queue;
            $self->$c($token_line);
            next TOKEN_LINE;
        }
    }
    return $self->_post_process(@_);
}

# makes array reference of strings, one string per line, from input
# file handle or string;
sub _stringify {
    my $self = shift;
    $self->_logger->info("going to split nexus data on lines");
    my %opts = @_;
    my @lines;
    my $handle = $self->_handle;
    while (<$handle>) {
        my $line = $_;
        push @lines, grep { /\S/ } split( /\n|\r|\r\n/, $line );
        $self->_logger->debug("read line: $line");
    }
    return \@lines;
}

=begin comment

 Type    : Method
 Title   : _tokenize()
 Usage   : $nexus->_tokenize($lines);
 Function: Tokenizes lines in $lines array ref
 Returns : Two dimensional ARRAY
 Args    : An array ref of lines (e.g. read from an input file);
 Comments: This method accepts an array ref holding lines that may contain
           single quotes, double quotes or square brackets. Line breaks and
           spaces inside these quoted/bracketed fragments are ignored, otherwise
           it is split, e.g.:

           [
               [ '#NEXUS' ],
               [ 'BEGIN TAXA; [taxablock comment]' ],
               [ 'DIMENSIONS NTAX=3;' ],
               [ 'TAXLABELS "Taxon \' A" \'Taxon B\' TAXON[comment]C' ],
               ...etc...
           ]

           becomes:
           [
               [ '#NEXUS' ],
               [
                   'BEGIN',
                   'TAXA',
                   ';',
                   '[taxablock comment]'
               ],
               [
                   'DIMENSIONS',
                   'NTAX',
                   '=',
                   '3',
                   ';'
               ],
               [
                   'TAXLABELS',
                   '"Taxon \' A"',
                   '\'Taxon B\'',
                   'TAXON',
                   '[comment]',
                   'C'
               ],
               ...etc...
           ]


=end comment

=cut

sub _tokenize {
    my ( $self, $lines ) = @_;
    $self->_logger->info("going to split lines on tokens");
    my ( $extract, $INSIDE_QUOTE, $continue ) = ( '', 0, 0 );
    my ( @tokens, @split );
    my $CLOSING_BRACKET_MIDLINE = qr/^.*?(\])(.*)$/mox;
    my $CONTEXT_QB_AT_START     = qr/^([\['"])(.*)$/mox;
    my $CONTEXT_CLOSER;
    my $QuoteContext;    # either " ' or [
    my $QuoteStartLine;
    my $LineCount  = 0;
    my %CLOSE_CHAR = (
        '"' => '"',
        "'" => "'",
        '[' => ']',
    );
    my %INVERSE_CLOSE_CHAR = (
        '"' => '"',
        "'" => "'",
        ']' => '[',
        ')' => '(',
    );

    # tokenize
  LINE: for my $line ( @{$lines} ) {
        $LineCount++;
      TOKEN: while ( $line =~ /\S/ ) {

            # line in file has no quoting/bracketing characters, and
            # is no extension of a quoted/bracketed fragment starting
            # on a previous line
            if ( $line !~ $QUOTES_OR_BRACKETS && !$INSIDE_QUOTE ) {
                if ($continue) {
                    push @{ $tokens[-1] }, $line;
                    $continue = 0;
                }
                else {
                    push @tokens, [$line];
                }
                my $logline = join( ' ', @{ $tokens[-1] } );
                chomp($logline);
                $self->_logger->debug("Tokenized line $LineCount: $logline");
                next LINE;
            }

            # line in file has opening quoting/bracketing characters, and
            # is no extension of a quoted/bracketed fragment starting
            # on a previous line
            elsif ( $line =~ $OPENING_QUOTE_OR_BRACKET && !$INSIDE_QUOTE ) {
                my ( $start, $quoted ) = ( $1, $2 );
                push @tokens, [$start];
                $line    = $quoted;
                $extract = $quoted;
                $INSIDE_QUOTE++;
                $continue = 1;
                $QuoteContext = substr( $quoted, 0, 1 );
                $self->_logger->debug("Line $LineCount contains $QuoteContext");
                $QuoteStartLine      = $LineCount;
                $CONTEXT_QB_AT_START = qr/^(\Q$QuoteContext\E)(.*)$/;
                my $context_closer = $CLOSE_CHAR{$QuoteContext};
                $CONTEXT_CLOSER = qr/^(.*?)(\Q$context_closer\E)(.*)$/;
                next TOKEN;
            }

            # line in file has no quoting/bracketing characters, and
            # is an extension of a quoted/bracketed fragment starting
            # on a previous line
            elsif ( $line !~ $CONTEXT_CLOSER && $INSIDE_QUOTE ) {
                $self->_logger->debug(
                    "Line $LineCount extends quote or comment");
                $extract .= $line;
                next LINE;
            }
            elsif ( $line =~ $CONTEXT_QB_AT_START && $INSIDE_QUOTE ) {
                my ( $q, $remainder ) = ( $1, $1 . $2 );
                if ( $q eq '"' || $q eq "'" ) {
                    if ( $remainder =~ m/^($q[^$q]*?$q)(.*)$/ ) {
                        $self->_logger->debug(
"Line $LineCount closes $INVERSE_CLOSE_CHAR{$q} with $q"
                        );
                        push @{ $tokens[-1] }, ($1);
                        $line = $2;
                        $INSIDE_QUOTE--;
                        next TOKEN;
                    }
                    elsif ( $remainder =~ m/^$q[^$q]*$/ ) {
                        $extract .= $line;
                        $continue = 1;
                        next LINE;
                    }
                }
                elsif ( $q eq '[' ) {
                    for my $i ( 1 .. length($line) ) {
                        $INSIDE_QUOTE++ if substr( $line, $i, 1 ) eq '[';
                        if ( $i and !$INSIDE_QUOTE ) {
                            push @{ $tokens[-1] }, substr( $line, 0, $i );
                            my $logqc = substr( $line, ( $i - 1 ), 1 );
                            $self->_logger->debug(
"Line $LineCount closes $INVERSE_CLOSE_CHAR{$logqc} with $logqc"
                            );
                            $line = substr( $line, $i );
                            next TOKEN;
                        }
                        $INSIDE_QUOTE-- if substr( $line, $i, 1 ) eq ']';
                    }
                    $extract  = $line;
                    $continue = 1;
                    next LINE;
                }
            }
            elsif ( $line =~ $CONTEXT_CLOSER && $INSIDE_QUOTE ) {
                my ( $start, $q, $remainder ) = ( $1, $2, $3 );
                $self->_logger->debug(
                    "Line $LineCount closes $INVERSE_CLOSE_CHAR{$q} with $q");
                $start = $extract . $start if $continue;
                if ( $q eq '"' or $q eq "'" ) {
                    push @{ $tokens[-1] }, $start;
                    $line = $remainder;
                    next TOKEN;
                }
                elsif ( $q eq ']' ) {
                    for my $i ( 0 .. length($line) ) {
                        $INSIDE_QUOTE++ if substr( $line, $i, 1 ) eq '[';
                        if ( $i and !$INSIDE_QUOTE ) {
                            my $segment = substr( $line, 0, $i );
                            if ($continue) {
                                push @{ $tokens[-1] }, $extract . $segment;
                            }
                            else {
                                push @{ $tokens[-1] }, $segment;
                            }
                            $line = substr( $line, $i );
                            next TOKEN;
                        }
                        $INSIDE_QUOTE-- if substr( $line, $i, 1 ) eq ']';
                    }
                    if ($continue) {
                        $extract .= $line;
                    }
                    else {
                        $extract = $line;
                    }
                    $continue = 1;
                    next LINE;
                }
            }
        }
    }

    # an exception here means that an opening quote symbol " ' [
    # ($QuoteContext) was encountered at input file/string line $QuoteStartLine.
    # This can happen if any of these symbols is used in an illegal
    # way, e.g. by using double quotes as gap symbols in matrices.
    if ($INSIDE_QUOTE) {
        throw 'BadArgs' =>
          "Unbalanced $QuoteContext starting at line $QuoteStartLine";
    }

    # final split: non-quoted/bracketed fragments are split on whitespace,
    # others are preserved verbatim
    $self->_logger->info(
        "going to split non-quoted/commented fragments on whitespace");
    foreach my $line (@tokens) {
        my @line;
        foreach my $word (@$line) {
            if ( $word !~ $QUOTES_OR_BRACKETS ) {
                $word =~ s/(=|;|,)/ $1 /g;
                push @line, grep { /\S/ } split /\s+/, $word;
            }
            else {
                push @line, $word;
            }
        }
        push @split, \@line;
    }
    return \@split;
}

# link matrices and forests to taxa
sub _post_process {
    my $self = shift;
    my $taxa = [];
    foreach my $block ( @{ $self->{'_context'} } ) {
        if ( $block->_type == $TAXA ) {
            push @{$taxa}, $block;
        }
        elsif ( $block->_type != $TAXA and $block->can('set_taxa') ) {
            if (    $taxa->[-1]
                and $taxa->[-1]->can('_type') == $TAXA
                and not $block->get_taxa )
            {
                $block->set_taxa( $taxa->[-1] );    # XXX exception here?
            }
        }
    }
    my $blocks = $self->{'_context'};

    # initialize object, note we have to
    # force data type references to be empty
    @{$taxa} = ();
    for my $key ( keys %defaults ) {
        if ( looks_like_instance( $defaults{$key}, 'ARRAY' ) ) {
            $self->{$key} = [];
        }
        elsif ( looks_like_instance( $defaults{$key}, 'HASH' ) ) {
            $self->{$key} = {};
        }
        else {
            $self->{$key} = $defaults{$key};
        }
    }
    return @{$blocks};
}

=begin comment

The following subs are called by the dispatch table stored in the object when
their respective tokens are encountered.

=end comment

=cut

sub _nexus {
    my $self = shift;
    if ( uc( $_[0] ) eq '#NEXUS' ) {
        $self->_logger->info("found nexus token");
    }
}

sub _begin {
    my $self = shift;
    $self->{'_begin'} = 1;
}

sub _taxa {
    my $self = shift;
    if ( $self->{'_begin'} ) {
        my $taxa = $self->_factory->create_taxa;
        push @{ $self->{'_context'} }, $taxa;
        $self->_logger->info("starting taxa block");
        $self->{'_begin'} = 0;
    }
    else {
        $self->{'_current'} = 'link';  # because of 'link taxa = blah' construct
    }
}

sub _charset {
    my $self = shift;
    my $token = shift;

    # first thing after the CHARSET token is the set name
    if ( $token !~ /CHARSET/i && ! $self->{'_charset'}->{'name'} ) {
        $self->{'_charset'}->{'name'} = $token;
        $self->{'_charset'}->{'range'} = [];
    }

    # then there might be a mesquite-style matrix reference, e.g. (CHARACTERS = matrix_name)
    elsif ( $token =~ m/^\(/ ) {
        $self->{'_charset'}->{'matrix'} = '';
    }
    elsif ( defined $self->{'_charset'}->{'matrix'} && ! $self->{'_charset'}->{'matrix'} && $token !~ /(?:\(?CHARACTERS|=)/i ) {
        $token =~ s/\)$//;
        $self->{'_charset'}->{'matrix'} = $token;
    }

    # then come the indices
    elsif ( $token =~ /(?:\d+|-)/ ) {
        push @{ $self->{'_charset'}->{'range'} }, $token;
    }
}

sub _taxset {
    my $self = shift;
    my $token = shift;

    # first thing after the TAXSET token is the set name
    if ( $token !~ /TAXSET/i && ! $self->{'_taxset'}->{'name'} ) {
        $self->{'_taxset'}->{'name'} = $token;
        $self->{'_taxset'}->{'range'} = [];
    }

    # then there might be a mesquite-style taxa reference, e.g. (TAXA = matrix_name)
    elsif ( $token =~ m/^\(/ ) {
        $self->{'_taxset'}->{'taxa'} = '';
    }
    elsif ( defined $self->{'_taxset'}->{'taxa'} && ! $self->{'_taxset'}->{'taxa'} && $token !~ /(?:\(?TAXA|=)/ ) {
        $token =~ s/\)$//;
        $self->{'_taxset'}->{'taxa'} = $token;
    }

    # then come the indices
    elsif ( $token =~ /(?:\d+|-)/ ) {
        push @{ $self->{'_taxset'}->{'range'} }, $token;
    }
}

sub _interleave {
    my $self  = shift;
    my $token = shift;
    $self->_logger->info("perhaps we'll need to parse interleaved");
    if ( defined $token and uc($token) eq 'NO' ) {
        $self->_logger->info("no, we don't need to parse interleaved");
    }
}

sub _title {
    my $self  = shift;
    my $token = shift;
    if ( defined $token and uc($token) ne 'TITLE' ) {
        my $title = $token;
        if ( not $self->_current->get_name ) {
            $self->_current->set_name($title);
            $self->_logger->info("block has title '$title'");
        }
    }
}

sub _link {
    my $self  = shift;
    my $token = shift;
    if ( defined $token and $token !~ m/^(?:LINK|TAXA|=)$/i ) {
        my $link = $token;
        if ( not $self->_current->get_taxa ) {
            foreach my $block ( @{ $self->{'_context'} } ) {
                if ( $block->get_name and $block->get_name eq $link ) {
                    $self->_current->set_taxa($block);
                    last;
                }
            }
            $self->_logger->info(
                "block links to taxa block with title '$link'");
        }
    }
}

sub _dimensions {

    #my $self = shift;
}

sub _ntax {
    my $self = shift;
    if ( defined $_[0] and $_[0] =~ m/^\d+$/ ) {
        $self->{'_ntax'} = shift;
        my $ntax = $self->{'_ntax'};
        $self->_logger->info("number of taxa: $ntax");
    }
}

sub _taxlabels {
    my $self = shift;
    if ( defined $_[0] and uc( $_[0] ) ne 'TAXLABELS' ) {
        my $taxon = shift;
        $self->_logger->debug("taxon: $taxon");
        push @{ $self->{'_taxlabels'} }, $taxon;
    }
    elsif ( defined $_[0] and uc( $_[0] ) eq 'TAXLABELS' ) {
        $self->_current->set_generic(
            'nexus_comments' => $self->{'_comments'} );
        $self->{'_comments'} = [];
        $self->_logger->info("starting taxlabels");
    }
}

sub _blockid {
    my $self = shift;
    if ( defined $_[0] and uc( $_[0] ) ne 'BLOCKID' ) {
        my $blockid = shift;
        $self->_logger->debug("blockid: $blockid");
        $self->_current->set_generic( 'blockid' => $blockid );
    }
}

sub _data {
    my $self = shift;
    if ( $self->{'_begin'} ) {
        $self->{'_begin'} = 0;
        push @{ $self->{'_context'} }, $self->_factory->create_matrix;
        $self->_logger->info("starting data block");
    }
}

sub _characters {
    my $self = shift;
    if ( $self->{'_begin'} ) {
        $self->{'_begin'} = 0;
        push @{ $self->{'_context'} }, $self->_factory->create_matrix;
        $self->_logger->info("starting characters block");
    }
}

sub _nchar {
    my $self = shift;
    if ( defined $_[0] and $_[0] =~ m/^\d+$/ ) {
        $self->{'_nchar'} = shift;
        my $nchar = $self->{'_nchar'};
        $self->_logger->info("number of characters: $nchar");
    }
}

sub _format {

    #my $self = shift;
}

sub _datatype {
    my $self = shift;
    if ( defined $_[0] and $_[0] !~ m/^(?:DATATYPE|=)/i ) {
        my $datatype = shift;
        $self->_current->set_type($datatype);
        $self->_logger->info("datatype: $datatype");
    }
}

sub _matchchar {
    my $self = shift;
    if ( defined $_[0] and $_[0] !~ m/^(?:MATCHCHAR|=)/i ) {
        my $matchchar = shift;
        $self->_current->set_matchchar($matchchar);
        $self->_logger->info("matchchar: $matchchar");
    }
}

sub _items {

    #my $self = shift;
}

sub _gap {
    my $self = shift;
    if ( $_[0] !~ m/^(?:GAP|=)/i and !$self->{'_gap'} ) {
        $self->{'_gap'} = shift;
        my $gap = $self->{'_gap'};
        $self->_current->set_gap($gap);
        $self->_logger->info("gap character: $gap");
        undef $self->{'_gap'};
    }
}

sub _missing {
    my $self = shift;
    if ( $_[0] !~ m/^(?:MISSING|=)/i and !$self->{'_missing'} ) {
        $self->{'_missing'} = shift;
        my $missing = $self->{'_missing'};
        $self->_current->set_missing($missing);
        $self->_logger->info("missing character: $missing");
        undef $self->{'_missing'};
    }
}

sub _symbols {
    my $self = shift;
    if ( $_[0] !~ m/^(?:SYMBOLS|=)$/i and $_[0] =~ m/^"?(.+)"?$/ ) {
        my $sym = $1;
        $sym =~ s/"//g;
        my @syms = grep { /\S+/ } split /\s+/, $sym;
        push @{ $self->{'_symbols'} }, @syms;
        $self->_logger->debug("recorded character state symbols '@syms'");
    }
}

sub _charlabels {
    my $self = shift;
    if ( defined $_[0] and uc $_[0] ne 'CHARLABELS' ) {
        push @{ $self->{'_charlabels'} }, shift;
    }
}

sub _charstatelabels {
    my $self = shift;
    my $token = shift;
    $self->_logger->debug($token);
    if ( defined $token and uc $token ne 'CHARSTATELABELS' ) {
        push @{ $self->{'_charstatelabels'} }, $token;
    }
}

sub _statelabels {
    my $self  = shift;
    my $token = shift;
    if ( defined $token and uc $token ne 'STATELABELS' ) {
        if ( $token eq ',' ) {
            my $tmpstatelabels = $self->{'_tmpstatelabels'};
            my $index          = shift @{$tmpstatelabels};
            $self->{'_statelabels'}->[ $index - 1 ] = $tmpstatelabels;
            $self->{'_tmpstatelabels'} = [];
        }
        else {
            push @{ $self->{'_tmpstatelabels'} }, $token;
        }
    }
}

# for data type, character labels, state labels
sub _add_matrix_metadata {
    my $self = shift;
    $self->_logger->info("adding matrix metadata");
    if ( not defined $self->{'_matrixtype'} ) {
        $self->{'_matrixtype'} = $self->_current->get_type;
        if ( @{ $self->{'_charlabels'} } ) {
            $self->_current->set_charlabels( $self->{'_charlabels'} );
            $self->_logger->debug("adding character labels");
        }
        if ( @{ $self->{'_statelabels'} } ) {
            $self->_current->set_statelabels( $self->{'_statelabels'} );
            $self->_logger->debug("adding state labels");
        }
        if ( my @symbols = @{ $self->{'_symbols'} } ) {
            $self->_logger->debug("updating state lookup table");
            my $to     = $self->_current->get_type_object;
            my $lookup = $to->get_lookup;
            if ($lookup) {
                for my $sym (@symbols) {
                    if ( not exists $lookup->{$sym} ) {
                        $lookup->{$sym} = [$sym];
                    }
                }
            }
        }
    }
    return $self;
}

sub _add_tokens_to_row {
    my ( $self, $tokens ) = @_;
    my $rowname;
    for my $token ( @{$tokens} ) {
        $self->_logger->debug("token: $token");
        last if $token eq ';';

        # mesquite sometimes writes multiline (but not interleaved)
        # matrix rows (harrumph).
        if ( not defined $rowname and $token !~ $COMMENT ) {
            my $taxa;
            if ( $taxa = $self->_current->get_taxa ) {
                if ( my $taxon = $taxa->get_by_name($token) ) {
                    $rowname = $token;
                }
                else {
                    $rowname = $self->{'_matrixrowlabels'}->[-1];
                }
            }
            elsif ( $taxa = $self->_find_last_seen_taxa_block ) {
                if ( my $taxon = $taxa->get_by_name($token) ) {
                    $rowname = $token;
                }
                else {
                    $rowname = $self->{'_matrixrowlabels'}->[-1];
                }
            }
            else {
                $rowname = $token;
            }
            if ( not exists $self->{'_matrix'}->{$rowname} ) {
                $self->{'_matrix'}->{$rowname} = [];
                push @{ $self->{'_matrixrowlabels'} }, $rowname;
            }
        }
        elsif ( defined $rowname and $token !~ $COMMENT ) {
            my $row = $self->{'_matrix'}->{$rowname};
            if ( $self->{'_matrixtype'} =~ m/^continuous$/i ) {
                push @{$row}, split( /\s+/, $token );
            }
            else {
                push @{$row}, split( //, $token );
            }
        }
    }
}

sub _find_last_seen_taxa_block {
    my $self = shift;
    my $name = shift;
    for ( my $i = $#{ $self->{'_context'} } ; $i >= 0 ; $i-- ) {
        if ( $self->{'_context'}->[$i]->_type == $TAXA ) {
            if ( $name ) {
                if ( $self->{'_context'}->[$i]->get_name eq $name ) {
                    return $self->{'_context'}->[$i];
                }
            }
            else {
                return $self->{'_context'}->[$i];
            }
        }
    }
    return;
}

sub _find_last_seen_matrix {
    my $self = shift;
    my $name = shift;
    for ( my $i = $#{ $self->{'_context'} } ; $i >= 0 ; $i-- ) {
        if ( $self->{'_context'}->[$i]->_type == $MATRIX ) {
            if ( $name ) {
                if ( $self->{'_context'}->[$i]->get_name eq $name ) {
                    return $self->{'_context'}->[$i];
                }
            }
            else {
                return $self->{'_context'}->[$i];
            }
        }
    }
    return;
}

sub _set_taxon {
    my ( $self, $obj, $taxa ) = @_;

    # first case: a taxon by $obj's name already exists
    if ( my $taxon = $taxa->get_by_name( $obj->get_name ) ) {
        $obj->set_taxon($taxon);
        return $self;
    }

    # second case: no taxon by $obj's name exists yet
    else {
        my $taxon = $self->_factory->create_taxon( '-name' => $obj->get_name );
        $taxa->insert($taxon);
        $obj->set_taxon($taxon);
        return $self;
    }
}

sub _resolve_taxon {
    my ( $self, $obj ) = @_;
    my $container = $self->_current;

    # first case: the object is actually already
    # linked to a taxon
    if ( my $taxon = $obj->get_taxon ) {
        return $self;
    }

    # second case: the container is already linked
    # to a taxa block, but the object isn't
    if ( my $taxa = $container->get_taxa ) {
        $self->_set_taxon( $obj, $taxa );
    }

    # third case: the container isn't explicitly linked,
    # but a taxa block has been seen
    if ( my $taxa = $self->_find_last_seen_taxa_block ) {
        $container->set_taxa($taxa);
        $self->_set_taxon( $obj, $taxa );
    }

    # final case: no taxa block exists
    else {
        my $taxa = $container->make_taxa;
        pop @{ $self->{'_context'} };
        push @{ $self->{'_context'} }, $taxa, $container;
        $self->_set_taxon( $obj, $taxa );
    }
}

sub _resolve_ambig {
    my ( $self, $datum, $chars ) = @_;
    my %brackets = (
        '(' => ')',
        '{' => '}',
    );
    my $to = $datum->get_type_object;
    my @resolved;
    my $in_set = 0;
    my @set;
    my $close;
    for my $c ( @{$chars} ) {

        if ( not $in_set and not exists $brackets{$c} ) {
            push @resolved, $c if defined $c;
        }
        elsif ( not $in_set and exists $brackets{$c} ) {
            $in_set++;
            $close = $brackets{$c};
        }
        elsif ( $in_set and $c ne $close ) {
            push @set, $c;
        }
        elsif ( $in_set and $c eq $close ) {
            push @resolved, $to->get_symbol_for_states(@set);
            @set    = ();
            $in_set = 0;
            $close  = undef;
        }
    }
    return \@resolved;
}

sub _codons {
    my $self = shift;
    $self->_logger->info(shift);
    if ( $self->{'_begin'} ) {
        $self->{'_begin'} = 0;
    }
}

sub _matrix {
    my $self  = shift;
    my $token = shift;
    $self->_add_matrix_metadata;

    # first token: 'MATRIX', i.e. we're just starting to parse
    # the actual matrix. Here we need to switch to "linemode",
    # so that subsequently tokens will be array references (all
    # the tokens on a line). This is so that we can handle
    # interleaved matrices, which unfortunately need line breaks
    # in them.
    if ( not looks_like_instance( $token, 'ARRAY' ) and uc($token) eq 'MATRIX' )
    {
        $self->{'_linemode'} = 1;
        $self->_logger->info("starting matrix");
        return;
    }

    # a row inside the matrix, after adding tokens to row, nothing
    # else to do
    elsif ( looks_like_instance( $token, 'ARRAY' )
        and not grep { /^;$/ } @{$token} )
    {
        $self->_add_tokens_to_row($token);
        $self->_logger->info("adding tokens to row");
        return;
    }

    # the last row of the matrix, after adding tokens to row,
    # instantiate & populate datum objects, link against taxa
    # objects
    elsif ( looks_like_instance( $token, 'ARRAY' )
        and grep { /^;$/ } @{$token} )
    {
        $self->_add_tokens_to_row($token);

        # link to taxa
        for my $row ( @{ $self->{'_matrixrowlabels'} } ) {

            # create new datum
            my $datum = $self->_factory->create_datum(
                '-type_object' => $self->_current->get_type_object,
                '-name'        => $row,
            );
            my $char =
              $self->_resolve_ambig( $datum, $self->{'_matrix'}->{$row} );
            $datum->set_char($char);

            # insert new datum in matrix
            $self->_current->insert($datum);

            # link to taxon
            $self->_resolve_taxon($datum);
            my ( $length, $seq ) = ( $datum->get_length, $datum->get_char );
            $self->_logger->info("parsed $length characters for ${row}: $seq");
        }

        # Let's avoid these!
        if ( $self->_current->get_nchar != $self->{'_nchar'} ) {
            my ( $obs, $exp ) =
              ( $self->_current->get_nchar, $self->{'_nchar'} );
            _bad_format("Observed and expected nchar mismatch: $obs vs. $exp");
        }

        # ntax is only defined for "data" blocks (which have ntax token),
        # not for "characters" blocks (which should match up with taxa block)
        elsif ( defined $self->{'_ntax'}
            and $self->_current->get_ntax != $self->{'_ntax'} )
        {
            my ( $obs, $exp ) = ( $self->_current->get_ntax, $self->{'_ntax'} );
            _bad_format("Observed and expected ntax mismatch: $obs vs. $exp");
        }

        # XXX matrix clean up here
        $self->{'_ntax'}            = undef;
        $self->{'_nchar'}           = undef;
        $self->{'_matrixtype'}      = undef;
        $self->{'_matrix'}          = {};
        $self->{'_matrixrowlabels'} = [];
        $self->{'_linemode'}        = 0;
    }
}

sub _bad_format {
    throw 'BadFormat' => shift;
}
sub _current { shift->{'_context'}->[-1] }

sub _trees {
    my $self = shift;
    if ( $self->{'_begin'} ) {
        $self->{'_begin'}     = 0;
        $self->{'_trees'}     = '';
        $self->{'_treenames'} = [];
        push @{ $self->{'_context'} }, $self->_factory->create_forest;
        $self->_logger->info("starting trees block");
    }
}

sub _translate {
    my $self = shift;
    my $i    = $self->{'_i'};
    if ( $i && $i == 1 )
    {    # actually, $i can be 0 according to BayesPhylogenies translation table
        $self->_logger->info("starting translation table");
    }
    if ( !defined($i) && $_[0] =~ m/^\d+$/ ) {
        $self->{'_i'} = shift;
        $self->{'_translate'}->[ $self->{'_i'} ] = undef;
    }
    elsif (defined($i)
        && exists $self->{'_translate'}->[$i]
        && !defined $self->{'_translate'}->[$i]
        && $_[0] ne ';' )
    {
        $self->{'_translate'}->[$i] = $_[0];
        $self->_logger->debug("Translation: $i => $_[0]");
        $self->{'_i'} = undef;
    }
}

sub _tree {
    my $self = shift;
    if ( not $self->{'_treename'} and $_[0] !~ m/^(U?TREE|\*)$/i ) {
        $self->{'_treename'} = $_[0];
    }
    if ( $_[0] eq '=' and not $self->{'_treestart'} ) {
        $self->{'_treestart'} = 1;
    }
    if ( $_[0] ne '=' and $self->{'_treestart'} ) {
        $self->{'_tree'} .= $_[0];
    }

    # tr/// returns # of replacements, hence can be used to check
    # tree description is balanced
    if (    $self->{'_treestart'}
        and $self->{'_tree'}
        and $self->{'_tree'} =~ tr/(/(/ == $self->{'_tree'} =~ tr/)/)/ )
    {
        my $translated = $self->{'_tree'};
        my $translate  = $self->{'_translate'};
        my $start =
          exists $translate->[0]
          ? 0
          : 1;    # BayesPhylogenies starts translation table w. 0
        for my $i ( $start .. $#{$translate} ) {
            $translated =~ s/(\(|,)$i(,|\)|:)/$1$translate->[$i]$2/;
        }
        my ( $logtreename, $logtree ) =
          ( $self->{'_treename'}, $self->{'_tree'} );
        $self->_logger->info("tree: $logtreename string: $logtree");
        $self->{'_trees'} .= $translated . ';';
        push @{ $self->{'_treenames'} }, $self->{'_treename'};

        # XXX tree cleanup here
        $self->{'_treestart'} = 0;
        $self->{'_tree'}      = undef;
        $self->{'_treename'}  = undef;
    }
}

sub _end {
    my $self = shift;
    $self->{'_translate'} = [];
    if ( uc $self->{'_previous'} eq ';' and $self->{'_trees'} ) {
        my $forest = $self->_current;
        my $trees  = parse(
            '-format'     => 'newick',
            '-string'     => $self->{'_trees'},
            '-as_project' => 0
        );
        for my $tree ( @{ $trees->get_entities } ) {
            $forest->insert($tree);
        }

        # set tree names
        for my $i ( 0 .. $#{ $self->{'_treenames'} } ) {
            $forest->get_by_index($i)->set_name( $self->{'_treenames'}->[$i] );
        }

        # link tips to taxa
        for my $tree ( @{ $forest->get_entities } ) {
            for my $tip ( @{ $tree->get_terminals } ) {
                $self->_resolve_taxon($tip);
            }
        }

        # XXX trees cleanup here
        $self->{'_trees'}     = '';
        $self->{'_treenames'} = [];
    }
}

sub _semicolon {
    my $self = shift;
    if ( uc $self->{'_previous'} eq 'MATRIX' ) {
        $self->{'_matrixtype'}  = undef;
        $self->{'_matrix'}      = {};
        $self->{'_charlabels'}  = [];
        $self->{'_statelabels'} = [];
        $self->{'_linemode'}    = 0;
        if ( not $self->_current->get_ntax ) {
            my $taxon = {};
            foreach my $row ( @{ $self->_current->get_entities } ) {
                $taxon->{ $row->get_taxon }++;
            }
            my $ntax = scalar keys %{$taxon};
        }
    }

    # finalize character set
    elsif ( uc $self->{'_previous'} eq 'CHARSET' ) {
        my $matrix = $self->_find_last_seen_matrix( $self->{'_charset'}->{'matrix'} );
        my $characters = $matrix->get_characters;
        my $set = $self->_factory->create_set( '-name' => $self->{'_charset'}->{'name'} );
        $characters->add_set($set);
        my $range = $self->{'_charset'}->{'range'};
        my @range;
        if ( ref($range) eq 'ARRAY' ) {
			while ( @{ $range } ) {
				my $index = shift @{ $range };
				if ( $range->[0] && $range->[0] eq '-' ) {
					shift @{ $range };
					my $end = shift @{ $range };
					push @range, ( $index - 1 ) .. ( $end - 1 );
				}
				else {
					push @range, ( $index - 1 );
				}
			}
			for my $i ( @range ) {
				my $character = $characters->get_by_index($i);
				if ( $character ) {
					$characters->add_to_set($character,$set);
				}
				else {
					throw 'API' => "No character at index $i";
				}
			}
        }
        $self->{'_charset'} = {};
    }

    # finalize character state labels
    elsif ( uc $self->{'_previous'} eq 'CHARSTATELABELS' ) {
        my $matrix = $self->_find_last_seen_matrix;
        my @labels = @{ $self->{'_charstatelabels'} };
        if ( $matrix->get_type =~ m/continuous/i ) {
            my @charlabels;
            my $charnum = 1;
            while (@labels) {

                # expecting an index at the beginning of the statement
                my $index = shift @labels;
                $index != $charnum && _bad_format( "Expecting character number $charnum, observed $index in CHARSTATELABELS" );

                # then the character label
                push @charlabels, shift @labels;

                # then a comma
                if ( @labels ) {
                    $labels[0] eq ',' ? shift @labels : _bad_format( "Expecting , observed $labels[0] in CHARSTATELABELS" );
                }
                $charnum++;
            }
            $matrix->set_charlabels(\@charlabels);
            $self->{'_charstatelabels'} = [];
        }
        else {
            my ( @charlabels, @statelabels );
            my $charnum = 1;
            while (@labels) {

                # expecting an index at the beginning of the statement
                my $index = shift @labels;
                $index != $charnum && _bad_format( "Expecting character number $charnum, observed $index in CHARSTATELABELS" );

                # then the character label
                push @charlabels, shift @labels;

                # then a forward slash
                my $slash = shift @labels;
                $slash ne '/' && _bad_format( "Expecting /, observed $slash in CHARSTATELABELS" );

                # then a list of state labels
                my @stateset;
                push @stateset, shift @labels while(@labels and $labels[0] ne ',');
                push @statelabels, \@stateset;

                # then a comma
                if ( @labels ) {
                    $labels[0] eq ',' ? shift @labels : _bad_format( "Expecting , observed $labels[0] in CHARSTATELABELS" );
                }
                $charnum++;
            }
            $matrix->set_charlabels(\@charlabels);
            $matrix->set_statelabels(\@statelabels);
            $self->{'_charstatelabels'} = [];
        }
    }

    # finalize taxon set
    elsif ( uc $self->{'_previous'} eq 'TAXSET' ) {
        my $taxa = $self->_find_last_seen_taxa_block( $self->{'_taxset'}->{'taxa'} );
        my $set = $self->_factory->create_set( '-name' => $self->{'_taxset'}->{'name'} );
        $taxa->add_set($set);
        my $range = $self->{'_taxset'}->{'range'};
        my @range;
        while ( @{ $range } ) {
            my $index = shift @{ $range };
            if ( $range->[0] && $range->[0] eq '-' ) {
                shift @{ $range };
                my $end = shift @{ $range };
                push @range, ( $index - 1 ) .. ( $end - 1 );
            }
            else {
                push @range, ( $index - 1 );
            }
        }
        for my $i ( @range ) {
            my $taxon = $taxa->get_by_index($i);
            if ( $taxon ) {
                $taxa->add_to_set($taxon,$set);
            }
            else {
                _bad_format( "No taxon at index $i" );
            }
        }
        $self->{'_taxset'} = {};
    }

    # finalize taxa labels
    elsif ( uc $self->{'_previous'} eq 'TAXLABELS' ) {
        foreach my $name ( @{ $self->{'_taxlabels'} } ) {
            my $taxon = $self->_factory->create_taxon( '-name' => $name );
            $self->_current->insert($taxon);
        }
        if ( $self->_current->get_ntax != $self->{'_ntax'} ) {
            _bad_format(
                sprintf(
                    'Mismatch between observed and expected ntax: %d vs %d',
                    $self->_current->get_ntax, $self->{'_ntax'}
                )
            );
        }

        # XXX taxa cleanup here
        $self->{'_ntax'}      = undef;
        $self->{'_taxlabels'} = [];
    }

    # finalize symbols list
    elsif ( uc $self->{'_previous'} eq 'SYMBOLS' ) {
        my $logsymbols = join( ' ', @{ $self->{'_symbols'} } );
        $self->_logger->info("symbols: $logsymbols");
        $self->{'_symbols'} = [];
    }

    # finalize character labels
    elsif ( uc $self->{'_previous'} eq 'CHARLABELS' ) {
        if ( @{ $self->{'_charlabels'} } ) {
            my $logcharlabels = join( ' ', @{ $self->{'_charlabels'} } );
            $self->_logger->info("charlabels: $logcharlabels");
        }
    }

    # finalize state labels
    elsif ( uc $self->{'_previous'} eq 'STATELABELS' ) {
        if ( @{ $self->{'_statelabels'} } ) {
            my $logstatelabels = join( ' ', @{ $self->{'_statelabels'} } );
            $self->_logger->info("statelabels: $logstatelabels");
        }
    }
}

# podinherit_insert_token

=head1 SEE ALSO

There is a mailing list at L
for any user or developer questions and discussions.

=over

=item L

The nexus parser is called by the L object. Look there for
examples of file parsing and manipulation.

=item L

Also see the manual: L and L.

=back

=head1 CITATION

If you use Bio::Phylo in published research, please cite it:

B, B, B, B
and B, 2011. Bio::Phylo - phyloinformatic analysis using Perl.
I B<12>:63.
L

=cut

1;