comparison variant_effect_predictor/Bio/Tools/StateMachine/IOStateMachine.pm @ 0:1f6dce3d34e0

Uploaded

0:1f6dce3d34e0

#-----------------------------------------------------------------
# $Id: IOStateMachine.pm,v 1.6 2002/10/22 07:38:49 lapp Exp $
#
# BioPerl module Bio::Tools::StateMachine::IOStateMachine
#
# Cared for by Steve Chervitz <[e-mail]>
#
# You may distribute this module under the same terms as perl itself
#-----------------------------------------------------------------

=head1 NAME

Bio::Tools::StateMachine::IOStateMachine - IO-based implementation of AbstractStateMachine

=head1 SYNOPSIS

    use Bio::Tools::StateMachine::IOStateMachine;

    # A state machine that reads input from a file
    my $sm = Bio::Tools::StateMachine::IOStateMachine->new( -file => 'data.txt' );

    # A state machine that reads input from a STDIN
    my $sm = Bio::Tools::StateMachine::IOStateMachine->new();

    # A state machine that reads input from a STDIN
    # and times out if input doesn't arrive within 30 seconds.
    my $sm = Bio::Tools::StateMachine::IOStateMachine->new( -timeout_sec => 30 );


=head1 DESCRIPTION

An implementation of AbstractStateMachine that samples an input stream
to determine whether a state change has occurred.

=head1 EXAMPLES

To get a feel for how to use this, have look at
Bio::SearchIO::psiblast which subclasses IOStateMachine.


=head1 FEEDBACK

=head2 Mailing Lists 

User feedback is an integral part of the evolution of this and other
Bioperl modules.  Send your comments and suggestions preferably to one
of the Bioperl mailing lists.  Your participation is much appreciated.

    [e-mail]              - General discussion
    http://bio.perl.org/MailList.html  - About the mailing lists

=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 email
or the web:

    [e-mail]                   
    http://bugzilla.bioperl.org/           

=head1 AUTHOR

Steve Chervitz, E<lt>[e-mail]<gt>

See the L<FEEDBACK | FEEDBACK> section for where to send bug reports and comments.

=head1 COPYRIGHT

Copyright (c) 2001 Steve Chervitz. All Rights Reserved.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

=head1 DISCLAIMER

This software is provided "as is" without warranty of any kind.

=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::Tools::StateMachine::IOStateMachine;

use strict;
use vars qw( @ISA @EXPORT_OK );

use Bio::Root::IO;
use Bio::Tools::StateMachine::AbstractStateMachine qw($INITIAL_STATE $FINAL_STATE);

@ISA = qw( Bio::Root::IO
           Bio::Tools::StateMachine::AbstractStateMachine
         );

# Propagating the initial and final states from AbstractStateMachine
@EXPORT_OK = qw( $INITIAL_STATE $FINAL_STATE );

=head2 _init_state_machine()

 Argument : Named parameter -TIMEOUT_SEC => seconds,
            to specify the number of seconds to allow before throwing
            an exception if input fails to arrive within that amount of time. 

=cut

sub _init_state_machine {
    my($self, @args) = @_;

    $self->SUPER::_init_state_machine(@args);

    my ($timeout) = $self->_rearrange( [qw(TIMEOUT_SECS)], @args);

    if( defined $timeout ) {
	if($timeout =~ /^\d+$/ ) {
	    $self->{'_timeout_secs'} = $timeout;
	}
	else {
	    $self->throw(-class =>'Bio::Root::BadParameter',
			 -text => "TIMEOUT_SECS must be a number: $timeout",
			 -value => $timeout
			);
	}
    }
}

=head2 check_for_new_state()
 
 Purpose  : Obtains data from the input stream to be checked 
            for the existence of a new state.
 Usage    : check_for_new_state( [$ignore_blank_lines] );
 Argument : boolean: true if you want to ignore blank lines
 Returns  : the next chunk of input ($/ is not altered)
            If there is no more input, returns undef.

Subclasses should override this method and call it to obtain
the chunk of data for new state testing. 

=cut

sub check_for_new_state {
    my ($self, $ignore_blank_lines) = @_;

    $self->verbose and print STDERR "Checking for new state...\n";

    my $chunk = $self->next_input_chunk();

    # Determine if we're supposed to ignore blanks and if so, loop
    # until we're either out of input or hit a non-blank line.
    if( defined $chunk && 
	$ignore_blank_lines and $chunk =~ /^\s*$/ ) {
        while(  $chunk = $self->next_input_chunk()) {
            last unless not $chunk or $chunk =~ /^\s*$/;
        }
    }

    $self->verbose and print STDERR "  Input chunk: " . $chunk, "\n";

    return $chunk;
}

=head2 next_input_chunk()

 Argument : n/a
 Returns  : The next chunk of input data from the IO stream
            To be used in determining what state the machine should be in.

=cut

sub next_input_chunk {
    my $self = shift;

    $self->verbose and print STDERR "Getting next input chunk...\n", ;

    if(not defined $self->{'_alarm_available'}) {
        $self->_check_if_alarm_available();
    }

    $SIG{ALRM} = sub { die "Timed out!"; };

    my $chunk;

    eval {
        if( $self->{'_alarm_available'} and defined $self->{'_timeout_secs'}) {
	    alarm($self->{'_timeout_secs'});
	}

        $chunk = $self->_readline();

    };
    if($@ =~ /Timed out!/) {
	 $self->throw(-class => 'Bio::Root::IOException',
                      -text => "Timed out while waiting for input (timeout=$self->{'_timeout_secs'}s).");
     } elsif($@ =~ /\S/) {
         my $err = $@;
         $self->throw(-class => 'Bio::Root::IOException',
                      -text => "Unexpected error during readline: $err");
    }

    return $chunk;
}



# alarm() not available (ActiveState perl for win32 doesn't have it.
# See jitterbug PR#98)
sub _check_if_alarm_available {
    my $self = shift;
    eval {
        alarm(0);
    };
    if($@) {
        $self->{'_alarm_available'} = 0;
    }
    else {
        $self->{'_alarm_available'} = 1;
    }
}

sub append_input_cache {
    my ($self, $data) = @_;
    push( @{$self->{'_input_cache'}}, $data) if defined $data;
}

sub get_input_cache {
    my $self = shift;
    my @cache =  ();
    if( ref $self->{'_input_cache'} ) {
       @cache = @{$self->{'_input_cache'}};
    }
    return @cache;
}

sub clear_input_cache {
    my $self = shift;
    @{$self->{'_input_cache'}} = ();
}



1;