gistfile1.pl

# Here's an example of having BioPerl write an alignment into the middle 
# of an HTML stream:

use strict;
use IO::Scalar;
use BIo::AlignIO;

my $html = "<h1>Blah!</h1>\n";
my $html_fh = new IO::Scalar \$html;

my $io = Bio::AlignIO->new(
   -file => ("t/data/testaln.aln"));
my $aln = $io->next_aln();

$io = Bio::AlignIO->new(
   '-fh'=> $html_fh, 
   '-format' => 'clustalw');
$io->write_aln($aln);

$html .= "<h1>All done! woot!</h1>\n";
print $html;




# Here's how Bio::AlignIO::clustalw writes $aln objects to files:


=head2 write_aln

 Title   : write_aln
 Usage   : $stream->write_aln(@aln)
 Function: writes the clustalw-format object (.aln) into the stream
 Returns : 1 for success and 0 for error
 Args    : Bio::Align::AlignI object

=cut

sub write_aln {
    my ( $self, @aln ) = @_;
    my ( $count, $length, $seq, @seq, $tempcount, $line_len );
    $line_len = $self->line_length || $LINELENGTH;
    foreach my $aln (@aln) {
        if ( !$aln || !$aln->isa('Bio::Align::AlignI') ) {
            $self->warn(
"Must provide a Bio::Align::AlignI object when calling write_aln"
            );
            next;
        }
        my $matchline = $aln->match_line;
        if ( $self->force_displayname_flat ) {
            $aln->set_displayname_flat(1);
        }
        $self->_print(
            sprintf( "CLUSTAL W(%s) multiple sequence alignment\n\n\n",
                $CLUSTALPRINTVERSION )
        ) or return;
        $length = $aln->length();
        $count  = $tempcount = 0;
        @seq    = $aln->each_seq();
        my $max = 22;
        foreach $seq (@seq) {
            $max = length( $aln->displayname( $seq->get_nse() ) )
              if ( length( $aln->displayname( $seq->get_nse() ) ) > $max );
        }

        while ( $count < $length ) {
            my ( $linesubstr, $first ) = ( '', 1 );
            foreach $seq (@seq) {

              #
              #  Following lines are to suppress warnings
              #  if some sequences in the alignment are much longer than others.

                my ($substring);
                my $seqchars = $seq->seq();
              SWITCH: {
                    if ( length($seqchars) >= ( $count + $line_len ) ) {
                        $substring = substr( $seqchars, $count, $line_len );
                        if ($first) {
                            $linesubstr =
                              substr( $matchline, $count, $line_len );
                            $first = 0;
                        }
                        last SWITCH;
                    }
                    elsif ( length($seqchars) >= $count ) {
                        $substring = substr( $seqchars, $count );
                        if ($first) {
                            $linesubstr = substr( $matchline, $count );
                            $first = 0;
                        }
                        last SWITCH;
                    }
                    $substring = "";
                }
                $self->_print(
                    sprintf(
                        "%-" . $max . "s %s\n",
                        $aln->displayname( $seq->get_nse() ), $substring
                    )
                ) or return;
            }

            my $percentages = '';
            if ( $self->percentages ) {
                my ($strcpy) = ($linesubstr);
                my $count = ( $strcpy =~ tr/\*// );
                $percentages =
                  sprintf( "\t%d%%", 100 * ( $count / length($linesubstr) ) );
            }
            $self->_print(
                sprintf(
                    "%-" . $max . "s %s%s\n",
                    '', $linesubstr, $percentages
                )
            );
            $self->_print( sprintf("\n\n") ) or return;
            $count += $line_len;
        }
    }
    $self->flush if $self->_flush_on_write && defined $self->_fh;
    return 1;
}