|
0
|
1 # $Id: seqHandler.pm,v 1.15 2002/06/24 04:29:31 jason Exp $
|
|
|
2 #
|
|
|
3 # BioPerl module for Bio::SeqIO::game::seqHandler
|
|
|
4 #
|
|
|
5 # Cared for by Brad Marshall <bradmars@yahoo.com>
|
|
|
6 #
|
|
|
7 # Copyright Brad Marshall
|
|
|
8 #
|
|
|
9 # You may distribute this module under the same terms as perl itself
|
|
|
10 # _history
|
|
|
11 # June 25, 2000 written by Brad Marshall
|
|
|
12 #
|
|
|
13 # POD documentation - main docs before the code
|
|
|
14
|
|
|
15 =head1 NAME
|
|
|
16
|
|
|
17 Bio::SeqIO::game::seqHandler - GAME helper via PerlSAX helper.
|
|
|
18
|
|
|
19 =head1 SYNOPSIS
|
|
|
20
|
|
|
21 GAME helper for parsing new Sequence objects from GAME XML. Do not use directly
|
|
|
22
|
|
|
23 =head1 FEEDBACK
|
|
|
24
|
|
|
25 =head2 Mailing Lists
|
|
|
26
|
|
|
27 User feedback is an integral part of the evolution of this and
|
|
|
28 other Bioperl modules. Send your comments and suggestions preferably
|
|
|
29 to one of the Bioperl mailing lists. Your participation is much appreciated.
|
|
|
30
|
|
|
31 bioperl-l@bioperl.org - Bioperl list
|
|
|
32 bioxml-dev@bioxml.org - Technical discussion - Moderate volume
|
|
|
33 bioxml-announce@bioxml.org - General Announcements - Pretty dead
|
|
|
34 http://www.bioxml.org/MailingLists/ - About the mailing lists
|
|
|
35
|
|
|
36 =head1 AUTHOR - Brad Marshall
|
|
|
37
|
|
|
38 Email: bradmars@yahoo.com
|
|
|
39
|
|
|
40 =head1 APPENDIX
|
|
|
41
|
|
|
42 The rest of the documentation details each of the object
|
|
|
43 methods. Internal methods are usually preceded with a _
|
|
|
44
|
|
|
45 =cut
|
|
|
46
|
|
|
47 # This template file is in the Public Domain.
|
|
|
48 # You may do anything you want with this file.
|
|
|
49 #
|
|
|
50
|
|
|
51 package Bio::SeqIO::game::seqHandler;
|
|
|
52 use vars qw{ $AUTOLOAD @ISA };
|
|
|
53
|
|
|
54 use XML::Handler::Subs;
|
|
|
55 use Bio::Root::Root;
|
|
|
56 use Bio::Seq::SeqFactory;
|
|
|
57
|
|
|
58 @ISA = qw(Bio::Root::Root XML::Handler::Subs);
|
|
|
59
|
|
|
60 sub new {
|
|
|
61 my ($class,@args) = @_;
|
|
|
62 my $self = $class->SUPER::new(@args);
|
|
|
63 my ($seq,$sb) = $self->_rearrange([qw(SEQ SEQBUILDER)], @args);
|
|
|
64 $self->{'string'} = '';
|
|
|
65 $self->{'seq'} = $seq;
|
|
|
66 $self->sequence_factory($sb || new Bio::Seq::SeqFactory(-type => 'Bio::Seq'));
|
|
|
67 return $self;
|
|
|
68 }
|
|
|
69
|
|
|
70 =head2 sequence_factory
|
|
|
71
|
|
|
72 Title : sequence_factory
|
|
|
73 Usage : $seqio->sequence_factory($builder)
|
|
|
74 Function: Get/Set the Bio::Factory::SequenceFactoryI
|
|
|
75 Returns : Bio::Factory::SequenceFactoryI
|
|
|
76 Args : [optional] Bio::Factory::SequenceFactoryI
|
|
|
77
|
|
|
78
|
|
|
79 =cut
|
|
|
80
|
|
|
81 sub sequence_factory{
|
|
|
82 my ($self,$obj) = @_;
|
|
|
83 if( defined $obj ) {
|
|
|
84 if( ! ref($obj) || ! $obj->isa('Bio::Factory::SequenceFactoryI') ) {
|
|
|
85 $self->throw("Must provide a valid Bio::Factory::SequenceFactoryI object to ".ref($self)." sequence_factory()");
|
|
|
86 }
|
|
|
87 $self->{'_seqio_seqfactory'} = $obj;
|
|
|
88 }
|
|
|
89 if( ! defined $self->{'_seqio_seqfactory'} ) {
|
|
|
90 $self->throw("No SequenceBuilder defined for SeqIO::game::seqHandler object");
|
|
|
91 }
|
|
|
92
|
|
|
93 return $self->{'_seqio_seqfactory'};
|
|
|
94 }
|
|
|
95
|
|
|
96 =head2 start_document
|
|
|
97
|
|
|
98 Title : start_document
|
|
|
99 Usage : $obj->start_document
|
|
|
100 Function: PerlSAX method called when a new document is initialized
|
|
|
101 Returns : nothing
|
|
|
102 Args : document name
|
|
|
103
|
|
|
104 =cut
|
|
|
105
|
|
|
106 # Basic PerlSAX
|
|
|
107 sub start_document {
|
|
|
108 my ($self, $document) = @_;
|
|
|
109 $self->{'in_current_seq'} = 'false';
|
|
|
110 $self->{'Names'} = [];
|
|
|
111 $self->{'string'} = '';
|
|
|
112 }
|
|
|
113
|
|
|
114 =head2 end_document
|
|
|
115
|
|
|
116 Title : end_document
|
|
|
117 Usage : $obj->end_document
|
|
|
118 Function: PerlSAX method called when a document is finished for cleaning up
|
|
|
119 Returns : list of sequences seen
|
|
|
120 Args : document name
|
|
|
121
|
|
|
122 =cut
|
|
|
123
|
|
|
124 sub end_document {
|
|
|
125 my ($self, $document) = @_;
|
|
|
126 delete $self->{'Names'};
|
|
|
127 return $self->sequence_factory->create
|
|
|
128 ( -seq => $self->{'residues'},
|
|
|
129 -alphabet => $self->{'alphabet'},
|
|
|
130 -id => $self->{'seq'},
|
|
|
131 -accession => $self->{'accession'},
|
|
|
132 -desc => $self->{'desc'},
|
|
|
133 -length => $self->{'length'},
|
|
|
134 );
|
|
|
135 }
|
|
|
136
|
|
|
137
|
|
|
138 =head2 start_element
|
|
|
139
|
|
|
140 Title : start_element
|
|
|
141 Usage : $obj->start_element
|
|
|
142 Function: PerlSAX method called when a new element is reached
|
|
|
143 Returns : nothing
|
|
|
144 Args : element object
|
|
|
145
|
|
|
146 =cut
|
|
|
147
|
|
|
148 sub start_element {
|
|
|
149 my ($self, $element) = @_;
|
|
|
150
|
|
|
151 push @{$self->{'Names'}}, $element->{'Name'};
|
|
|
152 $self->{'string'} = '';
|
|
|
153
|
|
|
154 if ($element->{'Name'} eq 'bx-seq:seq') {
|
|
|
155 if ($element->{'Attributes'}->{'bx-seq:id'} eq $self->{'seq'}) {
|
|
|
156 $self->{'in_current_seq'} = 'true';
|
|
|
157 $self->{'alphabet'} = $element->{'Attributes'}->{'bx-seq:type'};
|
|
|
158 $self->{'length'} = $element->{'Attributes'}->{'bx-seq:length'};
|
|
|
159 } else {
|
|
|
160 #This is not the sequence we want to import, but that's ok
|
|
|
161 }
|
|
|
162 }
|
|
|
163 return 0;
|
|
|
164 }
|
|
|
165
|
|
|
166 =head2 end_element
|
|
|
167
|
|
|
168 Title : end_element
|
|
|
169 Usage : $obj->end_element
|
|
|
170 Function: PerlSAX method called when an element is finished
|
|
|
171 Returns : nothing
|
|
|
172 Args : element object
|
|
|
173
|
|
|
174 =cut
|
|
|
175
|
|
|
176 sub end_element {
|
|
|
177 my ($self, $element) = @_;
|
|
|
178
|
|
|
179 if ($self->{'in_current_seq'} eq 'true') {
|
|
|
180 if ($self->in_element('bx-seq:residues')) {
|
|
|
181 while ($self->{'string'} =~ s/\s+//) {};
|
|
|
182 $self->{'residues'} = $self->{'string'};
|
|
|
183 }
|
|
|
184
|
|
|
185
|
|
|
186 if ($self->in_element('bx-seq:name')) {
|
|
|
187 $self->{'string'} =~ s/^\s+//g;
|
|
|
188 $self->{'string'} =~ s/\s+$//;
|
|
|
189 $self->{'string'} =~ s/\n//g;
|
|
|
190 $self->{'name'} = $self->{'string'};
|
|
|
191 }
|
|
|
192
|
|
|
193
|
|
|
194 if ($self->in_element('bx-link:id') && $self->within_element('bx-link:dbxref')) {
|
|
|
195 $self->{'string'} =~ s/^\s+//g;
|
|
|
196 $self->{'string'} =~ s/\s+$//;
|
|
|
197 $self->{'string'} =~ s/\n//g;
|
|
|
198 $self->{'accession'} = $self->{'string'};
|
|
|
199 }
|
|
|
200
|
|
|
201 if ($self->in_element('bx-seq:description')) {
|
|
|
202 $self->{'desc'} = $self->{'string'};
|
|
|
203 }
|
|
|
204
|
|
|
205 if ($self->in_element('bx-seq:seq')) {
|
|
|
206 $self->{'in_current_seq'} = 'false';
|
|
|
207 }
|
|
|
208 }
|
|
|
209
|
|
|
210 pop @{$self->{'Names'}};
|
|
|
211
|
|
|
212 }
|
|
|
213
|
|
|
214 =head2 characters
|
|
|
215
|
|
|
216 Title : characters
|
|
|
217 Usage : $obj->end_element
|
|
|
218 Function: PerlSAX method called when text between XML tags is reached
|
|
|
219 Returns : nothing
|
|
|
220 Args : text
|
|
|
221
|
|
|
222 =cut
|
|
|
223
|
|
|
224 sub characters {
|
|
|
225 my ($self, $text) = @_;
|
|
|
226 $self->{'string'} .= $text->{'Data'};
|
|
|
227 }
|
|
|
228
|
|
|
229 =head2 in_element
|
|
|
230
|
|
|
231 Title : in_element
|
|
|
232 Usage : $obj->in_element
|
|
|
233 Function: PerlSAX method called to test if state is in a specific element
|
|
|
234 Returns : boolean
|
|
|
235 Args : name of element
|
|
|
236
|
|
|
237 =cut
|
|
|
238
|
|
|
239 sub in_element {
|
|
|
240 my ($self, $name) = @_;
|
|
|
241
|
|
|
242 return ($self->{'Names'}[-1] eq $name);
|
|
|
243 }
|
|
|
244
|
|
|
245 =head2 within_element
|
|
|
246
|
|
|
247 Title : within_element
|
|
|
248 Usage : $obj->within_element
|
|
|
249 Function: PerlSAX method called to list depth within specific element
|
|
|
250 Returns : boolean
|
|
|
251 Args : name of element
|
|
|
252
|
|
|
253 =cut
|
|
|
254
|
|
|
255 sub within_element {
|
|
|
256 my ($self, $name) = @_;
|
|
|
257
|
|
|
258 my $count = 0;
|
|
|
259 foreach my $el_name (@{$self->{'Names'}}) {
|
|
|
260 $count ++ if ($el_name eq $name);
|
|
|
261 }
|
|
|
262
|
|
|
263 return $count;
|
|
|
264 }
|
|
|
265
|
|
|
266 =head2 AUTOLOAD
|
|
|
267
|
|
|
268 Title : AUTOLOAD
|
|
|
269 Usage : do not use directly
|
|
|
270 Function: autoload handling of missing DESTROY method
|
|
|
271 Returns : nothing
|
|
|
272 Args : text
|
|
|
273
|
|
|
274 =cut
|
|
|
275
|
|
|
276 # Others
|
|
|
277 sub AUTOLOAD {
|
|
|
278 my $self = shift;
|
|
|
279
|
|
|
280 my $method = $AUTOLOAD;
|
|
|
281 $method =~ s/.*:://;
|
|
|
282 return if $method eq 'DESTROY';
|
|
|
283
|
|
|
284 print "UNRECOGNIZED $method\n";
|
|
|
285 }
|
|
|
286
|
|
|
287 1;
|
|
|
288
|
|
|
289 __END__
|
