view release on metacpan or  search on metacpan

lib/Bio/Phylo/Parsers/Nexus.pm  view on Meta::CPAN

                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