|
0
|
1 #-----------------------------------------------------------------
|
|
|
2 # $Id: IOStateMachine.pm,v 1.6 2002/10/22 07:38:49 lapp Exp $
|
|
|
3 #
|
|
|
4 # BioPerl module Bio::Tools::StateMachine::IOStateMachine
|
|
|
5 #
|
|
|
6 # Cared for by Steve Chervitz <sac@bioperl.org>
|
|
|
7 #
|
|
|
8 # You may distribute this module under the same terms as perl itself
|
|
|
9 #-----------------------------------------------------------------
|
|
|
10
|
|
|
11 =head1 NAME
|
|
|
12
|
|
|
13 Bio::Tools::StateMachine::IOStateMachine - IO-based implementation of AbstractStateMachine
|
|
|
14
|
|
|
15 =head1 SYNOPSIS
|
|
|
16
|
|
|
17 use Bio::Tools::StateMachine::IOStateMachine;
|
|
|
18
|
|
|
19 # A state machine that reads input from a file
|
|
|
20 my $sm = Bio::Tools::StateMachine::IOStateMachine->new( -file => 'data.txt' );
|
|
|
21
|
|
|
22 # A state machine that reads input from a STDIN
|
|
|
23 my $sm = Bio::Tools::StateMachine::IOStateMachine->new();
|
|
|
24
|
|
|
25 # A state machine that reads input from a STDIN
|
|
|
26 # and times out if input doesn't arrive within 30 seconds.
|
|
|
27 my $sm = Bio::Tools::StateMachine::IOStateMachine->new( -timeout_sec => 30 );
|
|
|
28
|
|
|
29
|
|
|
30 =head1 DESCRIPTION
|
|
|
31
|
|
|
32 An implementation of AbstractStateMachine that samples an input stream
|
|
|
33 to determine whether a state change has occurred.
|
|
|
34
|
|
|
35 =head1 EXAMPLES
|
|
|
36
|
|
|
37 To get a feel for how to use this, have look at
|
|
|
38 Bio::SearchIO::psiblast which subclasses IOStateMachine.
|
|
|
39
|
|
|
40
|
|
|
41 =head1 FEEDBACK
|
|
|
42
|
|
|
43 =head2 Mailing Lists
|
|
|
44
|
|
|
45 User feedback is an integral part of the evolution of this and other
|
|
|
46 Bioperl modules. Send your comments and suggestions preferably to one
|
|
|
47 of the Bioperl mailing lists. Your participation is much appreciated.
|
|
|
48
|
|
|
49 bioperl-l@bioperl.org - General discussion
|
|
|
50 http://bio.perl.org/MailList.html - About the mailing lists
|
|
|
51
|
|
|
52 =head2 Reporting Bugs
|
|
|
53
|
|
|
54 Report bugs to the Bioperl bug tracking system to help us keep track
|
|
|
55 the bugs and their resolution. Bug reports can be submitted via email
|
|
|
56 or the web:
|
|
|
57
|
|
|
58 bioperl-bugs@bio.perl.org
|
|
|
59 http://bugzilla.bioperl.org/
|
|
|
60
|
|
|
61 =head1 AUTHOR
|
|
|
62
|
|
|
63 Steve Chervitz, E<lt>sac@bioperl.orgE<gt>
|
|
|
64
|
|
|
65 See the L<FEEDBACK | FEEDBACK> section for where to send bug reports and comments.
|
|
|
66
|
|
|
67 =head1 COPYRIGHT
|
|
|
68
|
|
|
69 Copyright (c) 2001 Steve Chervitz. All Rights Reserved.
|
|
|
70
|
|
|
71 This library is free software; you can redistribute it and/or modify
|
|
|
72 it under the same terms as Perl itself.
|
|
|
73
|
|
|
74 =cut
|
|
|
75
|
|
|
76 =head1 DISCLAIMER
|
|
|
77
|
|
|
78 This software is provided "as is" without warranty of any kind.
|
|
|
79
|
|
|
80 =head1 APPENDIX
|
|
|
81
|
|
|
82 The rest of the documentation details each of the object methods.
|
|
|
83 Internal methods are usually preceded with a _
|
|
|
84
|
|
|
85 =cut
|
|
|
86
|
|
|
87 # Let the code begin...
|
|
|
88
|
|
|
89 package Bio::Tools::StateMachine::IOStateMachine;
|
|
|
90
|
|
|
91 use strict;
|
|
|
92 use vars qw( @ISA @EXPORT_OK );
|
|
|
93
|
|
|
94 use Bio::Root::IO;
|
|
|
95 use Bio::Tools::StateMachine::AbstractStateMachine qw($INITIAL_STATE $FINAL_STATE);
|
|
|
96
|
|
|
97 @ISA = qw( Bio::Root::IO
|
|
|
98 Bio::Tools::StateMachine::AbstractStateMachine
|
|
|
99 );
|
|
|
100
|
|
|
101 # Propagating the initial and final states from AbstractStateMachine
|
|
|
102 @EXPORT_OK = qw( $INITIAL_STATE $FINAL_STATE );
|
|
|
103
|
|
|
104 =head2 _init_state_machine()
|
|
|
105
|
|
|
106 Argument : Named parameter -TIMEOUT_SEC => seconds,
|
|
|
107 to specify the number of seconds to allow before throwing
|
|
|
108 an exception if input fails to arrive within that amount of time.
|
|
|
109
|
|
|
110 =cut
|
|
|
111
|
|
|
112 sub _init_state_machine {
|
|
|
113 my($self, @args) = @_;
|
|
|
114
|
|
|
115 $self->SUPER::_init_state_machine(@args);
|
|
|
116
|
|
|
117 my ($timeout) = $self->_rearrange( [qw(TIMEOUT_SECS)], @args);
|
|
|
118
|
|
|
119 if( defined $timeout ) {
|
|
|
120 if($timeout =~ /^\d+$/ ) {
|
|
|
121 $self->{'_timeout_secs'} = $timeout;
|
|
|
122 }
|
|
|
123 else {
|
|
|
124 $self->throw(-class =>'Bio::Root::BadParameter',
|
|
|
125 -text => "TIMEOUT_SECS must be a number: $timeout",
|
|
|
126 -value => $timeout
|
|
|
127 );
|
|
|
128 }
|
|
|
129 }
|
|
|
130 }
|
|
|
131
|
|
|
132 =head2 check_for_new_state()
|
|
|
133
|
|
|
134 Purpose : Obtains data from the input stream to be checked
|
|
|
135 for the existence of a new state.
|
|
|
136 Usage : check_for_new_state( [$ignore_blank_lines] );
|
|
|
137 Argument : boolean: true if you want to ignore blank lines
|
|
|
138 Returns : the next chunk of input ($/ is not altered)
|
|
|
139 If there is no more input, returns undef.
|
|
|
140
|
|
|
141 Subclasses should override this method and call it to obtain
|
|
|
142 the chunk of data for new state testing.
|
|
|
143
|
|
|
144 =cut
|
|
|
145
|
|
|
146 sub check_for_new_state {
|
|
|
147 my ($self, $ignore_blank_lines) = @_;
|
|
|
148
|
|
|
149 $self->verbose and print STDERR "Checking for new state...\n";
|
|
|
150
|
|
|
151 my $chunk = $self->next_input_chunk();
|
|
|
152
|
|
|
153 # Determine if we're supposed to ignore blanks and if so, loop
|
|
|
154 # until we're either out of input or hit a non-blank line.
|
|
|
155 if( defined $chunk &&
|
|
|
156 $ignore_blank_lines and $chunk =~ /^\s*$/ ) {
|
|
|
157 while( $chunk = $self->next_input_chunk()) {
|
|
|
158 last unless not $chunk or $chunk =~ /^\s*$/;
|
|
|
159 }
|
|
|
160 }
|
|
|
161
|
|
|
162 $self->verbose and print STDERR " Input chunk: " . $chunk, "\n";
|
|
|
163
|
|
|
164 return $chunk;
|
|
|
165 }
|
|
|
166
|
|
|
167 =head2 next_input_chunk()
|
|
|
168
|
|
|
169 Argument : n/a
|
|
|
170 Returns : The next chunk of input data from the IO stream
|
|
|
171 To be used in determining what state the machine should be in.
|
|
|
172
|
|
|
173 =cut
|
|
|
174
|
|
|
175 sub next_input_chunk {
|
|
|
176 my $self = shift;
|
|
|
177
|
|
|
178 $self->verbose and print STDERR "Getting next input chunk...\n", ;
|
|
|
179
|
|
|
180 if(not defined $self->{'_alarm_available'}) {
|
|
|
181 $self->_check_if_alarm_available();
|
|
|
182 }
|
|
|
183
|
|
|
184 $SIG{ALRM} = sub { die "Timed out!"; };
|
|
|
185
|
|
|
186 my $chunk;
|
|
|
187
|
|
|
188 eval {
|
|
|
189 if( $self->{'_alarm_available'} and defined $self->{'_timeout_secs'}) {
|
|
|
190 alarm($self->{'_timeout_secs'});
|
|
|
191 }
|
|
|
192
|
|
|
193 $chunk = $self->_readline();
|
|
|
194
|
|
|
195 };
|
|
|
196 if($@ =~ /Timed out!/) {
|
|
|
197 $self->throw(-class => 'Bio::Root::IOException',
|
|
|
198 -text => "Timed out while waiting for input (timeout=$self->{'_timeout_secs'}s).");
|
|
|
199 } elsif($@ =~ /\S/) {
|
|
|
200 my $err = $@;
|
|
|
201 $self->throw(-class => 'Bio::Root::IOException',
|
|
|
202 -text => "Unexpected error during readline: $err");
|
|
|
203 }
|
|
|
204
|
|
|
205 return $chunk;
|
|
|
206 }
|
|
|
207
|
|
|
208
|
|
|
209
|
|
|
210 # alarm() not available (ActiveState perl for win32 doesn't have it.
|
|
|
211 # See jitterbug PR#98)
|
|
|
212 sub _check_if_alarm_available {
|
|
|
213 my $self = shift;
|
|
|
214 eval {
|
|
|
215 alarm(0);
|
|
|
216 };
|
|
|
217 if($@) {
|
|
|
218 $self->{'_alarm_available'} = 0;
|
|
|
219 }
|
|
|
220 else {
|
|
|
221 $self->{'_alarm_available'} = 1;
|
|
|
222 }
|
|
|
223 }
|
|
|
224
|
|
|
225 sub append_input_cache {
|
|
|
226 my ($self, $data) = @_;
|
|
|
227 push( @{$self->{'_input_cache'}}, $data) if defined $data;
|
|
|
228 }
|
|
|
229
|
|
|
230 sub get_input_cache {
|
|
|
231 my $self = shift;
|
|
|
232 my @cache = ();
|
|
|
233 if( ref $self->{'_input_cache'} ) {
|
|
|
234 @cache = @{$self->{'_input_cache'}};
|
|
|
235 }
|
|
|
236 return @cache;
|
|
|
237 }
|
|
|
238
|
|
|
239 sub clear_input_cache {
|
|
|
240 my $self = shift;
|
|
|
241 @{$self->{'_input_cache'}} = ();
|
|
|
242 }
|
|
|
243
|
|
|
244
|
|
|
245
|
|
|
246 1;
|
|
|
247
|
|
|
248
|
|
|
249
|
