view release on metacpan or  search on metacpan

Bio/ClusterIO.pm  view on Meta::CPAN

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
the bugs and their resolution.  Bug reports can be submitted via the
web:

  https://github.com/bioperl/bioperl-live/issues

=head1 AUTHOR - Andrew Macgregor

Email andrew@anatomy.otago.ac.nz

=head1 APPENDIX

The rest of the documentation details each of the object
methods. Internal methods are usually preceded with a _

=cut

#'
# Let the code begin...

package Bio::ClusterIO;

use strict;


use base qw(Bio::Root::Root Bio::Root::IO);



=head2 new

 Title   : new
 Usage   : Bio::ClusterIO->new(-file => $filename, -format => 'format')
 Function: Returns a new cluster stream
 Returns : A Bio::ClusterIO::Handler initialised with the appropriate format
 Args    : -file => $filename
           -format => format

=cut


my $entry = 0;

sub new {
    my ($caller,@args) = @_;
    my $class = ref($caller) || $caller;
    
    # or do we want to call SUPER on an object if $caller is an
    # object?
    if( $class =~ /Bio::ClusterIO::(\S+)/ ) {
	my ($self) = $class->SUPER::new(@args);	
	$self->_initialize(@args);
	return $self;
    } else { 

	my %param = @args;
	@param{ map { lc $_ } keys %param } = values %param; # lowercase keys
	my $format = $param{'-format'} || 
	    $class->_guess_format( $param{-file} || $ARGV[0] );
	$format = "\L$format";	# normalize capitalization to lower case

	return unless( $class->_load_format_module($format) );
	return "Bio::ClusterIO::$format"->new(@args);
    }
}

=head2 format

 Title   : format
 Usage   : $format = $stream->format()
 Function: Get the cluster format
 Returns : cluster format
 Args    : none

=cut

# format() method inherited from Bio::Root::IO


# _initialize is chained for all ClusterIO classes

sub _initialize {
    my($self, @args) = @_;
    # initialize the IO part
    $self->_initialize_io(@args);
}

=head2 next_cluster

 Title   : next_cluster
 Usage   : $cluster = $stream->next_cluster()
 Function: Reads the next cluster object from the stream and returns it.
 Returns : a L<Bio::ClusterI> compliant object
 Args    : none


=cut

sub next_cluster {
   my ($self, $seq) = @_;
   $self->throw("Sorry, you cannot read from a generic Bio::ClusterIO object.");
}

=head2 cluster_factory

 Title   : cluster_factory
 Usage   : $obj->cluster_factory($newval)
 Function: Get/set the object factory to use for creating the cluster
           objects.
 Example : 
 Returns : a L<Bio::Factory::ObjectFactoryI> compliant object
 Args    : on set, new value (a L<Bio::Factory::ObjectFactoryI> 
           compliant object or undef, optional)


=cut

sub cluster_factory{
    my $self = shift;

    return $self->{'cluster_factory'} = shift if @_;
    return $self->{'cluster_factory'};
}

=head2 object_factory

 Title   : object_factory
 Usage   : $obj->object_factory($newval)
 Function: This is an alias to cluster_factory with a more generic name.
 Example : 
 Returns : a L<Bio::Factory::ObjectFactoryI> compliant object
 Args    : on set, new value (a L<Bio::Factory::ObjectFactoryI> 
           compliant object or undef, optional)


=cut

sub object_factory{
    return shift->cluster_factory(@_);
}

=head2 _load_format_module

 Title   : _load_format_module
 Usage   : *INTERNAL ClusterIO stuff*
 Function: Loads up (like use) a module at run time on demand
 Example :
 Returns :
 Args    :

=cut

sub _load_format_module {
  my ($self,$format) = @_;
  my $module = "Bio::ClusterIO::" . $format;
  my $ok;
  
  eval {
      $ok = $self->_load_module($module);
  };
  if ( $@ ) {
    print STDERR <<END;
$self: could not load $format - for more details on supported formats please see the ClusterIO docs
Exception $@
END
  ;
  }
  return $ok;
}

=head2 _guess_format

 Title   : _guess_format
 Usage   : $obj->_guess_format($filename)
 Function: guess format based on file suffix
 Example :
 Returns : guessed format of filename (lower case)
 Args    :
 Notes   : formats that _filehandle() will guess include unigene and dbsnp

=cut

sub _guess_format {
   my $class = shift;
   return unless $_ = shift;
   return 'unigene'   if /\.(data)$/i;
   return 'dbsnp'     if /\.(xml)$/i;
}

sub DESTROY {
    my $self = shift;

    $self->close();
}

# I need some direction on these!! The module works so I haven't fiddled with them!

sub TIEHANDLE {
    my ($class,$val) = @_;
    return bless {'seqio' => $val}, $class;
}

sub READLINE {
  my $self = shift;
  return $self->{'seqio'}->next_seq() || undef unless wantarray;
  my (@list, $obj);
  push @list, $obj while $obj = $self->{'seqio'}->next_seq();
  return @list;
}

sub PRINT {
  my $self = shift;
  $self->{'seqio'}->write_seq(@_);
}

1;