view release on metacpan or  search on metacpan

lib/PerlIO/via/SeqIO.pm  view on Meta::CPAN

	return (wantarray ? $fh->getlines : $fh->getline);
    }
    # on EOF, return undef.
}

sub WRITE {
    my ($self, $buf, $fh) = @_;
    my $ios = $self->{io_string};
    my $ret = 0;
    # following may not work, if a Bio...=HASH... is broken up 
    # by buffering...
    my @input = split( /(Bio::.*?=HASH\(0x[0-9a-f]+\)\s)/, $buf ); 
    foreach my $item (@input) {
	if ($item =~ /HASH/) { # string rep of object
	    $item = $OBJS{$item};
	    $self->{engine}->write_seq($item);
	    $ios->pos(0); # seek to top
	    my $line = join('', <$ios>);
	    $ios->pos(0); ${$ios->string_ref}=''; 
	    $ret += $fh->write($line, length $line);
	    undef $OBJS{$item}; # clean up
	}
	else { # write the raw buffer
	    $fh->write($item, length($item)) if $item;
	}
    }
    $ret;
}

sub FLUSH {
    my ($self, $fh) = @_;
#    $DB::single=1;
    return $fh ? $fh->flush : 0;
#    return $fh->flush if !defined $self->{mode} or $self->{mode} =~ /w|a|\+/;
    return -1;
}

sub CLOSE {
    my ($self, $fh) = @_;
    return $fh->close;
}

# This open() is an optional (exported on explicit demand) replacement
# for the core, that provides for the redirection of STDIN/STDOUT/DATA
# through the via(SeqIO) layer. When this open is active, ordinary uses
# of open should be passed through unharmed (tests are in 001_passthru.t)

# to emulate redirection, which PerlIO::via doesn't do yet, the 
# special filehandle is tied to an internal tied class.
# This is truly spaghettified, because the tied handle needs access to 
# the via object's goodies, but it seems to work (002_seqio.t)

sub open  {
    no strict qw(refs);
    my ($fh, $mode, $file) = @_;
    if ($file or $mode !~ /:via\(SeqIO(?:::[a-zA-Z_]+)?\)/) {
	#passthru
	# if !defined $file, parse $mode according to presence of &...
	if ($fh) {
	    if ( $fh =~ /^[A-Z]+$/ ) {
		$fh = *{(caller)[0]."::$fh"};
	    }
	}
	if ($file) {
	    if ( $file =~ /^[A-Z]+$/) {
		$file = *{(caller)[0]."::$file"};
	    }
	    return CORE::open($fh || $_[0],$_[1],$file);
	}
	else {
	    $_[0] ? 
		($_[0] = PerlIO::Util->open($_[1])) : 
		CORE::open($fh || $_[0],$_[1]);

	}
    }
    # deal with special filehandles with 2-argument opens
    if ($fh and $fh =~ /(DATA|STD(?:IN|OUT))/) {
	no strict qw(refs);
	my $dup = gensym;
	my $bareword = $1;
	my $redirect = ($bareword =~ /OUT/ ? ">&" : "<&");
	# get a pristine copy of DATA/STDIN/STDOUT
	$fh = *{(caller)[0]."::$bareword"};
	CORE::open($dup, $redirect, $fh) or croak($!);
	if ($bareword =~ /OUT/) {
	    $| && $dup->autoflush(1);
	}
	# now, need to make everything output to the duplicated
	# handle; may need to use ties after all (to make real
	# writes to the subordinate handle only...)
	
	# provide dummy file to CORE::open
	my ($dumh, $file) = tempfile("dumXXXX", UNLINK=>1);
	close($dumh);
	# secretly pass the dup
	$PerlIO::via::SeqIO::__seqio_DUP = $dup;
	# kick PUSHED
	CORE::open( $dumh, $mode, $file) or croak( $! );
	undef $PerlIO::via::SeqIO::__seqio_DUP;

	tie $fh, '_viaSeqIO_FH';
	(tied $fh)->sub_fh($dup);
	# private pointer for tied object...
	(tied $fh)->via_o( $dumh->via_o );
	return 1;
	
    }
    else { # passthru
	$DB::single=1;
	($mode, $file) = $mode =~ /(\+?(?:<|>)?>?&?)(.*)/;
	$file =~ /^[A-Z]+$/ and $file = *{(caller)[0]."::$file"};
	$_[0] = PerlIO::Util->open($mode,$file);
    }
    1;
}

# seq object converter

sub T {
    my @objs = @_;
    my @ret;
    foreach my $s (@objs) {
	unless (defined $s and ref($s) and
		($s->isa('Bio::SeqI') || $s->isa('Bio::Seq') || 
		 $s->isa('Bio::PrimarySeq'))) {
	    carp "Item undefined or not a sequence object; returning an undef";
	    push @ret, undef;
	    next;
	}
	$s->isa('Bio::PrimarySeq') and $s = _pseq_to_seq($s);
	push @ret, sprintf("%s\n", $s);
	$OBJS{$ret[-1]} = $s;
    }
    return wantarray ? @ret : $ret[0];
}

# object getter ...

sub O {
    no strict qw(refs);
    my $sym = shift;
    $sym ||= $_; 
    for ($sym) {
	m/Bio/ && do {
	    return $OBJS{$sym}; last;
	};
	m/via/ && do {
	    return (tied $sym)->via_o; last;
	};
	m/^[A-Z]+$/ && do {
	    $sym = (caller)[0]."::$sym";
	    return (tied *$sym)->via_o if (tied *$sym);
	    return;
	    last;
	};
    }
    croak("Don't understand the arg");
}

# wrap Bio::PrimarySeqs (incl. Bio::LocatableSeqs) in a Bio::Seq
# for Bio::SeqIO use

sub _pseq_to_seq {
    my @pseqs = @_;
    my @ret;
    foreach (@pseqs) {
	unless (defined $_ && ref($_) && $_->isa('Bio::PrimarySeq')) {
	    push @ret, undef;
	    next;
	}
	my $seq = Bio::Seq->new();
	$seq->id( $_->display_id || $_->id );
	$seq->primary_seq( $_ );
	push @ret, $seq;
    }
    return wantarray ? @ret : $ret[0];
}

1;

# tied handle class for special filehandle 2-argument opens
# see comments to open()

package _viaSeqIO_FH;
use strict;
use warnings;
use Config;
our %__SUB_FH;
our $AUTOLOAD;

sub TIEHANDLE { bless ( { sub_fh => undef, via_o => undef }, $_[0] ) }

sub PRINT {
    my ($self, @args) = @_;
    # use the via object's write method on the sub-handle:
    foreach (@args) {
	$self->via_o->WRITE( $_, $self->sub_fh);
    }
    return 1;
}

sub sub_fh {
    my ($self, $fh) = @_;
    if ($fh) {
	#kludge for ActivePerl:
	if ($Config{cf_email} =~ /ActiveState/) { 
	    push @IO::Handle::ISA, 'IO::Seekable';
	}
	return $__SUB_FH{$fh->fileno} = $fh;
    }
    return unless defined $self->fileno;