Filename | /Users/ap13/perl5/lib/perl5/Bio/Root/RootI.pm |
Statements | Executed 18 statements in 1.74ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 15µs | 31µs | BEGIN@2 | Bio::Root::RootI::
1 | 1 | 1 | 12µs | 64µs | BEGIN@84 | Bio::Root::RootI::
1 | 1 | 1 | 10µs | 22µs | BEGIN@242 | Bio::Root::RootI::
1 | 1 | 1 | 10µs | 20µs | BEGIN@562 | Bio::Root::RootI::
1 | 1 | 1 | 9µs | 22µs | BEGIN@227 | Bio::Root::RootI::
1 | 1 | 1 | 8µs | 19µs | BEGIN@549 | Bio::Root::RootI::
1 | 1 | 1 | 8µs | 36µs | BEGIN@3 | Bio::Root::RootI::
1 | 1 | 1 | 4µs | 4µs | BEGIN@85 | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | _cleanup_methods | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | _initialize | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | _not_implemented_msg | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | _rearrange | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | _rearrange_old | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | _register_for_cleanup | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | _set_from_args | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | _unregister_for_cleanup | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | deprecated | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | new | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | stack_trace | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | stack_trace_dump | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | throw | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | throw_not_implemented | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | warn | Bio::Root::RootI::
0 | 0 | 0 | 0s | 0s | warn_not_implemented | Bio::Root::RootI::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Bio::Root::RootI; | ||||
2 | 2 | 37µs | 2 | 48µs | # spent 31µs (15+17) within Bio::Root::RootI::BEGIN@2 which was called:
# once (15µs+17µs) by base::import at line 2 # spent 31µs making 1 call to Bio::Root::RootI::BEGIN@2
# spent 17µs making 1 call to strict::import |
3 | 2 | 55µs | 2 | 65µs | # spent 36µs (8+28) within Bio::Root::RootI::BEGIN@3 which was called:
# once (8µs+28µs) by base::import at line 3 # spent 36µs making 1 call to Bio::Root::RootI::BEGIN@3
# spent 28µs making 1 call to Exporter::import |
4 | |||||
5 | # ABSTRACT: abstract interface to root object code | ||||
6 | # AUTHOR: Steve Chervitz <sac@bioperl.org> | ||||
7 | # AUTHOR: Ewan Birney <birney@ebi.ac.uk> | ||||
8 | # AUTHOR: Lincoln Stein | ||||
9 | # OWNER: Steve Chervitz | ||||
10 | # OWNER: Ewan Birney | ||||
11 | # OWNER: Lincoln Stein | ||||
12 | # LICENSE: Perl_5 | ||||
13 | |||||
14 | # CONTRIBUTOR: Sendu Bala <bix@sendu.me.uk> | ||||
15 | # CONTRIBUTOR: Jason Stajich | ||||
16 | |||||
17 | =head1 SYNOPSIS | ||||
18 | |||||
19 | # any bioperl or bioperl compliant object is a RootI | ||||
20 | # compliant object | ||||
21 | |||||
22 | $obj->throw("This is an exception"); | ||||
23 | |||||
24 | eval { | ||||
25 | $obj->throw("This is catching an exception"); | ||||
26 | }; | ||||
27 | |||||
28 | if( $@ ) { | ||||
29 | print "Caught exception"; | ||||
30 | } else { | ||||
31 | print "no exception"; | ||||
32 | } | ||||
33 | |||||
34 | # Using throw_not_implemented() within a RootI-based interface module: | ||||
35 | |||||
36 | package Foo; | ||||
37 | use base qw(Bio::Root::RootI); | ||||
38 | |||||
39 | sub foo { | ||||
40 | my $self = shift; | ||||
41 | $self->throw_not_implemented; | ||||
42 | } | ||||
43 | |||||
44 | |||||
45 | =head1 DESCRIPTION | ||||
46 | |||||
47 | This is just a set of methods which do not assume B<anything> about the object | ||||
48 | they are on. The methods provide the ability to throw exceptions with nice | ||||
49 | stack traces. | ||||
50 | |||||
51 | This is what should be inherited by all Bioperl compliant interfaces, even | ||||
52 | if they are exotic XS/CORBA/Other perl systems. | ||||
53 | |||||
54 | =head2 Using throw_not_implemented() | ||||
55 | |||||
56 | The method L<throw_not_implemented()|throw_not_implemented> should be | ||||
57 | called by all methods within interface modules that extend RootI so | ||||
58 | that if an implementation fails to override them, an exception will be | ||||
59 | thrown. | ||||
60 | |||||
61 | For example, say there is an interface module called C<FooI> that | ||||
62 | provides a method called C<foo()>. Since this method is considered | ||||
63 | abstract within FooI and should be implemented by any module claiming to | ||||
64 | implement C<FooI>, the C<FooI::foo()> method should consist of the | ||||
65 | following: | ||||
66 | |||||
67 | sub foo { | ||||
68 | my $self = shift; | ||||
69 | $self->throw_not_implemented; | ||||
70 | } | ||||
71 | |||||
72 | So, if an implementer of C<FooI> forgets to implement C<foo()> | ||||
73 | and a user of the implementation calls C<foo()>, a | ||||
74 | L<Bio::Exception::NotImplemented> exception will result. | ||||
75 | |||||
76 | Unfortunately, failure to implement a method can only be determined at | ||||
77 | run time (i.e., you can't verify that an implementation is complete by | ||||
78 | running C<perl -wc> on it). So it should be standard practice for a test | ||||
79 | of an implementation to check each method and verify that it doesn't | ||||
80 | throw a L<Bio::Exception::NotImplemented>. | ||||
81 | |||||
82 | =cut | ||||
83 | |||||
84 | 2 | 38µs | 2 | 117µs | # spent 64µs (12+53) within Bio::Root::RootI::BEGIN@84 which was called:
# once (12µs+53µs) by base::import at line 84 # spent 64µs making 1 call to Bio::Root::RootI::BEGIN@84
# spent 53µs making 1 call to vars::import |
85 | # spent 4µs within Bio::Root::RootI::BEGIN@85 which was called:
# once (4µs+0s) by base::import at line 89 | ||||
86 | 1 | 400ns | $ID = 'Bio::Root::RootI'; | ||
87 | 1 | 100ns | $DEBUG = 0; | ||
88 | 1 | 3µs | $VERBOSITY = 0; | ||
89 | 1 | 318µs | 1 | 4µs | } # spent 4µs making 1 call to Bio::Root::RootI::BEGIN@85 |
90 | |||||
91 | =head2 new | ||||
92 | |||||
93 | =cut | ||||
94 | |||||
95 | sub new { | ||||
96 | my $class = shift; | ||||
97 | my @args = @_; | ||||
98 | unless ( $ENV{'BIOPERLDEBUG'} ) { | ||||
99 | carp("Use of new in Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead"); | ||||
100 | } | ||||
101 | eval "require Bio::Root::Root"; | ||||
102 | return Bio::Root::Root->new(@args); | ||||
103 | } | ||||
104 | |||||
105 | # for backwards compatibility | ||||
106 | sub _initialize { | ||||
107 | my($self,@args) = @_; | ||||
108 | return 1; | ||||
109 | } | ||||
110 | |||||
111 | |||||
112 | =head2 throw | ||||
113 | |||||
114 | Title : throw | ||||
115 | Usage : $obj->throw("throwing exception message") | ||||
116 | Function: Throws an exception, which, if not caught with an eval brace | ||||
117 | will provide a nice stack trace to STDERR with the message | ||||
118 | Returns : nothing | ||||
119 | Args : A string giving a descriptive error message | ||||
120 | |||||
121 | |||||
122 | =cut | ||||
123 | |||||
124 | sub throw{ | ||||
125 | my ($self,$string) = @_; | ||||
126 | |||||
127 | my $std = $self->stack_trace_dump(); | ||||
128 | |||||
129 | my $out = "\n-------------------- EXCEPTION --------------------\n" | ||||
130 | . "MSG: " . $string . "\n" | ||||
131 | . $std."-------------------------------------------\n"; | ||||
132 | die $out; | ||||
133 | } | ||||
134 | |||||
135 | =head2 warn | ||||
136 | |||||
137 | Title : warn | ||||
138 | Usage : $object->warn("Warning message"); | ||||
139 | Function: Places a warning. What happens now is down to the | ||||
140 | verbosity of the object (value of $obj->verbose) | ||||
141 | verbosity 0 or not set => small warning | ||||
142 | verbosity -1 => no warning | ||||
143 | verbosity 1 => warning with stack trace | ||||
144 | verbosity 2 => converts warnings into throw | ||||
145 | Returns : n/a | ||||
146 | Args : string (the warning message) | ||||
147 | |||||
148 | =cut | ||||
149 | |||||
150 | sub warn { | ||||
151 | my ($self,$string) = @_; | ||||
152 | |||||
153 | my $verbose = $self->verbose; | ||||
154 | |||||
155 | my $header = "\n--------------------- WARNING ---------------------\nMSG: "; | ||||
156 | my $footer = "---------------------------------------------------\n"; | ||||
157 | |||||
158 | if ($verbose >= 2) { | ||||
159 | $self->throw($string); | ||||
160 | } | ||||
161 | elsif ($verbose <= -1) { | ||||
162 | return; | ||||
163 | } | ||||
164 | elsif ($verbose == 1) { | ||||
165 | CORE::warn $header, $string, "\n", $self->stack_trace_dump, $footer; | ||||
166 | return; | ||||
167 | } | ||||
168 | |||||
169 | CORE::warn $header, $string, "\n", $footer; | ||||
170 | } | ||||
171 | |||||
172 | =head2 deprecated | ||||
173 | |||||
174 | Title : deprecated | ||||
175 | Usage : $obj->deprecated("Method X is deprecated"); | ||||
176 | $obj->deprecated("Method X is deprecated", 1.007); | ||||
177 | $obj->deprecated(-message => "Method X is deprecated"); | ||||
178 | $obj->deprecated(-message => "Method X is deprecated", | ||||
179 | -version => 1.007); | ||||
180 | Function: Prints a message about deprecation unless verbose is < 0 | ||||
181 | (which means be quiet) | ||||
182 | Returns : none | ||||
183 | Args : Message string to print to STDERR | ||||
184 | Version of BioPerl where use of the method results in an exception | ||||
185 | Notes : The method can be called two ways, either by positional arguments: | ||||
186 | |||||
187 | $obj->deprecated('This module is deprecated', 1.006); | ||||
188 | |||||
189 | or by named arguments: | ||||
190 | |||||
191 | $obj->deprecated( | ||||
192 | -message => 'use of the method foo() is deprecated, use bar() instead', | ||||
193 | -version => 1.006 # throw if $VERSION is >= this version | ||||
194 | ); | ||||
195 | |||||
196 | or timed to go off at a certain point: | ||||
197 | |||||
198 | $obj->deprecated( | ||||
199 | -message => 'use of the method foo() is deprecated, use bar() instead', | ||||
200 | -warn_version => 1.006 # warn if $VERSION is >= this version | ||||
201 | -throw_version => 1.007 # throw if $VERSION is >= this version | ||||
202 | ); | ||||
203 | |||||
204 | Using the last two named argument versions is suggested and will | ||||
205 | likely be the only supported way of calling this method in the future | ||||
206 | Yes, we see the irony of deprecating that particular usage of | ||||
207 | deprecated(). | ||||
208 | |||||
209 | The main difference between usage of the two named argument versions | ||||
210 | is that by designating a 'warn_version' one indicates the | ||||
211 | functionality is officially deprecated beginning in a future version | ||||
212 | of BioPerl (so warnings are issued only after that point), whereas | ||||
213 | setting either 'version' or 'throw_version' (synonyms) converts the | ||||
214 | deprecation warning to an exception. | ||||
215 | |||||
216 | For proper comparisons one must use a version in lines with the | ||||
217 | current versioning scheme for Perl and BioPerl, (i.e. where 1.006000 | ||||
218 | indicates v1.6.0, 5.010000 for v5.10.0, etc.). | ||||
219 | |||||
220 | =cut | ||||
221 | |||||
222 | sub deprecated{ | ||||
223 | my ($self) = shift; | ||||
224 | |||||
225 | my $class = ref $self || $self; | ||||
226 | my $class_version = do { | ||||
227 | 2 | 96µs | 2 | 34µs | # spent 22µs (9+12) within Bio::Root::RootI::BEGIN@227 which was called:
# once (9µs+12µs) by base::import at line 227 # spent 22µs making 1 call to Bio::Root::RootI::BEGIN@227
# spent 12µs making 1 call to strict::unimport |
228 | ${"${class}::VERSION"} | ||||
229 | }; | ||||
230 | |||||
231 | if( $class_version && $class_version =~ /set by/ ) { | ||||
232 | $class_version = 0.0001; | ||||
233 | } | ||||
234 | |||||
235 | my ($msg, $version, $warn_version, $throw_version) = | ||||
236 | $self->_rearrange([qw(MESSAGE VERSION WARN_VERSION THROW_VERSION)], @_); | ||||
237 | |||||
238 | $throw_version ||= $version; | ||||
239 | $warn_version ||= $class_version; | ||||
240 | |||||
241 | for my $v ( $warn_version, $throw_version) { | ||||
242 | 2 | 631µs | 2 | 34µs | # spent 22µs (10+12) within Bio::Root::RootI::BEGIN@242 which was called:
# once (10µs+12µs) by base::import at line 242 # spent 22µs making 1 call to Bio::Root::RootI::BEGIN@242
# spent 12µs making 1 call to warnings::unimport |
243 | $self->throw("Version must be numerical, such as 1.006000 for v1.6.0, not $v") | ||||
244 | unless !defined $v || $v + 0 eq $v; | ||||
245 | } | ||||
246 | |||||
247 | # below default insinuates we're deprecating a method and not a full module | ||||
248 | # but it's the most common use case | ||||
249 | $msg ||= "Use of ".(caller(1))[3]."() is deprecated."; | ||||
250 | |||||
251 | if( $throw_version && $class_version && $class_version >= $throw_version ) { | ||||
252 | $self->throw($msg) | ||||
253 | } | ||||
254 | elsif( $warn_version && $class_version && $class_version >= $warn_version ) { | ||||
255 | |||||
256 | $msg .= "\nTo be removed in $throw_version." if $throw_version; | ||||
257 | |||||
258 | # passing this on to warn() should deal properly with verbosity issues | ||||
259 | $self->warn($msg); | ||||
260 | } | ||||
261 | } | ||||
262 | |||||
263 | =head2 stack_trace_dump | ||||
264 | |||||
265 | Title : stack_trace_dump | ||||
266 | Usage : | ||||
267 | Function: | ||||
268 | Example : | ||||
269 | Returns : | ||||
270 | Args : | ||||
271 | |||||
272 | |||||
273 | =cut | ||||
274 | |||||
275 | sub stack_trace_dump{ | ||||
276 | my ($self) = @_; | ||||
277 | |||||
278 | my @stack = $self->stack_trace(); | ||||
279 | |||||
280 | shift @stack; | ||||
281 | shift @stack; | ||||
282 | shift @stack; | ||||
283 | |||||
284 | my $out; | ||||
285 | my ($module,$function,$file,$position); | ||||
286 | |||||
287 | |||||
288 | foreach my $stack ( @stack) { | ||||
289 | ($module,$file,$position,$function) = @{$stack}; | ||||
290 | $out .= "STACK $function $file:$position\n"; | ||||
291 | } | ||||
292 | |||||
293 | return $out; | ||||
294 | } | ||||
295 | |||||
296 | |||||
297 | =head2 stack_trace | ||||
298 | |||||
299 | Title : stack_trace | ||||
300 | Usage : @stack_array_ref= $self->stack_trace | ||||
301 | Function: gives an array to a reference of arrays with stack trace info | ||||
302 | each coming from the caller(stack_number) call | ||||
303 | Returns : array containing a reference of arrays | ||||
304 | Args : none | ||||
305 | |||||
306 | |||||
307 | =cut | ||||
308 | |||||
309 | sub stack_trace{ | ||||
310 | my ($self) = @_; | ||||
311 | |||||
312 | my $i = 0; | ||||
313 | my @out = (); | ||||
314 | my $prev = []; | ||||
315 | while( my @call = caller($i++)) { | ||||
316 | # major annoyance that caller puts caller context as | ||||
317 | # function name. Hence some monkeying around... | ||||
318 | $prev->[3] = $call[3]; | ||||
319 | push(@out,$prev); | ||||
320 | $prev = \@call; | ||||
321 | } | ||||
322 | $prev->[3] = 'toplevel'; | ||||
323 | push(@out,$prev); | ||||
324 | return @out; | ||||
325 | } | ||||
326 | |||||
327 | |||||
328 | =head2 _rearrange | ||||
329 | |||||
330 | Usage : $object->_rearrange( array_ref, list_of_arguments) | ||||
331 | Purpose : Rearranges named parameters to requested order. | ||||
332 | Example : $self->_rearrange([qw(SEQUENCE ID DESC)],@param); | ||||
333 | : Where @param = (-sequence => $s, | ||||
334 | : -desc => $d, | ||||
335 | : -id => $i); | ||||
336 | Returns : @params - an array of parameters in the requested order. | ||||
337 | : The above example would return ($s, $i, $d). | ||||
338 | : Unspecified parameters will return undef. For example, if | ||||
339 | : @param = (-sequence => $s); | ||||
340 | : the above _rearrange call would return ($s, undef, undef) | ||||
341 | Argument : $order : a reference to an array which describes the desired | ||||
342 | : order of the named parameters. | ||||
343 | : @param : an array of parameters, either as a list (in | ||||
344 | : which case the function simply returns the list), | ||||
345 | : or as an associative array with hyphenated tags | ||||
346 | : (in which case the function sorts the values | ||||
347 | : according to @{$order} and returns that new array.) | ||||
348 | : The tags can be upper, lower, or mixed case | ||||
349 | : but they must start with a hyphen (at least the | ||||
350 | : first one should be hyphenated.) | ||||
351 | Source : This function was taken from CGI.pm, written by Dr. Lincoln | ||||
352 | : Stein, and adapted for use in Bio::Seq by Richard Resnick and | ||||
353 | : then adapted for use in Bio::Root::Object.pm by Steve Chervitz, | ||||
354 | : then migrated into Bio::Root::RootI.pm by Ewan Birney. | ||||
355 | Comments : | ||||
356 | : Uppercase tags are the norm, | ||||
357 | : (SAC) | ||||
358 | : This method may not be appropriate for method calls that are | ||||
359 | : within in an inner loop if efficiency is a concern. | ||||
360 | : | ||||
361 | : Parameters can be specified using any of these formats: | ||||
362 | : @param = (-name=>'me', -color=>'blue'); | ||||
363 | : @param = (-NAME=>'me', -COLOR=>'blue'); | ||||
364 | : @param = (-Name=>'me', -Color=>'blue'); | ||||
365 | : @param = ('me', 'blue'); | ||||
366 | : A leading hyphenated argument is used by this function to | ||||
367 | : indicate that named parameters are being used. | ||||
368 | : Therefore, the ('me', 'blue') list will be returned as-is. | ||||
369 | : | ||||
370 | : Note that Perl will confuse unquoted, hyphenated tags as | ||||
371 | : function calls if there is a function of the same name | ||||
372 | : in the current namespace: | ||||
373 | : -name => 'foo' is interpreted as -&name => 'foo' | ||||
374 | : | ||||
375 | : For ultimate safety, put single quotes around the tag: | ||||
376 | : ('-name'=>'me', '-color' =>'blue'); | ||||
377 | : This can be a bit cumbersome and I find not as readable | ||||
378 | : as using all uppercase, which is also fairly safe: | ||||
379 | : (-NAME=>'me', -COLOR =>'blue'); | ||||
380 | : | ||||
381 | : Personal note (SAC): I have found all uppercase tags to | ||||
382 | : be more manageable: it involves less single-quoting, | ||||
383 | : the key names stand out better, and there are no method naming | ||||
384 | : conflicts. | ||||
385 | : The drawbacks are that it's not as easy to type as lowercase, | ||||
386 | : and lots of uppercase can be hard to read. | ||||
387 | : | ||||
388 | : Regardless of the style, it greatly helps to line | ||||
389 | : the parameters up vertically for long/complex lists. | ||||
390 | : | ||||
391 | : Note that if @param is a single string that happens to start with | ||||
392 | : a dash, it will be treated as a hash key and probably fail to | ||||
393 | : match anything in the array_ref, so not be returned as normally | ||||
394 | : happens when @param is a simple list and not an associative array. | ||||
395 | |||||
396 | =cut | ||||
397 | |||||
398 | sub _rearrange { | ||||
399 | my ($self, $order, @args) = @_; | ||||
400 | |||||
401 | return @args unless $args[0] && $args[0] =~ /^\-/; | ||||
402 | |||||
403 | push @args, undef unless $#args % 2; | ||||
404 | |||||
405 | my %param; | ||||
406 | for( my $i = 0; $i < @args; $i += 2 ) { | ||||
407 | (my $key = $args[$i]) =~ tr/a-z\055/A-Z/d; #deletes all dashes! | ||||
408 | $param{$key} = $args[$i+1]; | ||||
409 | } | ||||
410 | return @param{map uc, @$order}; | ||||
411 | } | ||||
412 | |||||
413 | =head2 _set_from_args | ||||
414 | |||||
415 | Usage : $object->_set_from_args(\%args, -methods => \@methods) | ||||
416 | Purpose : Takes a hash of user-supplied args whose keys match method names, | ||||
417 | : and calls the method supplying it the corresponding value. | ||||
418 | Example : $self->_set_from_args(\%args, -methods => [qw(sequence id desc)]); | ||||
419 | : Where %args = (-sequence => $s, | ||||
420 | : -description => $d, | ||||
421 | : -ID => $i); | ||||
422 | : | ||||
423 | : the above _set_from_args calls the following methods: | ||||
424 | : $self->sequence($s); | ||||
425 | : $self->id($i); | ||||
426 | : ( $self->description($i) is not called because 'description' wasn't | ||||
427 | : one of the given methods ) | ||||
428 | Argument : \%args | \@args : a hash ref or associative array ref of arguments | ||||
429 | : where keys are any-case strings corresponding to | ||||
430 | : method names but optionally prefixed with | ||||
431 | : hyphens, and values are the values the method | ||||
432 | : should be supplied. If keys contain internal | ||||
433 | : hyphens (eg. to separate multi-word args) they | ||||
434 | : are converted to underscores, since method names | ||||
435 | : cannot contain dashes. | ||||
436 | : -methods => [] : (optional) only call methods with names in this | ||||
437 | : array ref. Can instead supply a hash ref where | ||||
438 | : keys are method names (of real existing methods | ||||
439 | : unless -create is in effect) and values are array | ||||
440 | : refs of synonyms to allow access to the method | ||||
441 | : using synonyms. If there is only one synonym it | ||||
442 | : can be supplied as a string instead of a single- | ||||
443 | : element array ref | ||||
444 | : -force => bool : (optional, default 0) call methods that don't | ||||
445 | : seem to exist, ie. let AUTOLOAD handle them | ||||
446 | : -create => bool : (optional, default 0) when a method doesn't | ||||
447 | : exist, create it as a simple getter/setter | ||||
448 | : (combined with -methods it would create all the | ||||
449 | : supplied methods that didn't exist, even if not | ||||
450 | : mentioned in the supplied %args) | ||||
451 | : -code => '' | {}: (optional) when creating methods use the supplied | ||||
452 | : code (a string which will be evaulated as a sub). | ||||
453 | : The default code is a simple get/setter. | ||||
454 | : Alternatively you can supply a hash ref where | ||||
455 | : the keys are method names and the values are | ||||
456 | : code strings. The variable '$method' will be | ||||
457 | : available at evaluation time, so can be used in | ||||
458 | : your code strings. Beware that the strict pragma | ||||
459 | : will be in effect. | ||||
460 | : -case_sensitive => bool : require case sensitivity on the part of | ||||
461 | : user (ie. a() and A() are two different | ||||
462 | : methods and the user must be careful | ||||
463 | : which they use). | ||||
464 | Comments : | ||||
465 | : The \%args argument will usually be the args received during new() | ||||
466 | : from the user. The user is allowed to get the case wrong, include | ||||
467 | : 0 or more than one hyphens as a prefix, and to include hyphens as | ||||
468 | : multi-word arg separators: '--an-arg' => 1, -an_arg => 1 and | ||||
469 | : An_Arg => 1 are all equivalent, calling an_arg(1). However, in | ||||
470 | : documentation users should only be told to use the standard form | ||||
471 | : -an_arg to avoid confusion. A possible exception to this is a | ||||
472 | : wrapper module where '--an-arg' is what the user is used to | ||||
473 | : supplying to the program being wrapped. | ||||
474 | : | ||||
475 | : Another issue with wrapper modules is that there may be an | ||||
476 | : argument that has meaning both to Bioperl and to the program, eg. | ||||
477 | : -verbose. The recommended way of dealing with this is to leave | ||||
478 | : -verbose to set the Bioperl verbosity whilst requesting users use | ||||
479 | : an invented -program_verbose (or similar) to set the program | ||||
480 | : verbosity. This can be resolved back with | ||||
481 | : Bio::Tools::Run::WrapperBase's _setparams() method and code along | ||||
482 | : the lines of: | ||||
483 | : my %methods = map { $_ => $_ } @LIST_OF_ALL_ALLOWED_PROGRAM_ARGS | ||||
484 | : delete $methods{'verbose'}; | ||||
485 | : $methods{'program_verbose'} = 'verbose'; | ||||
486 | : my $param_string = $self->_setparams(-methods => \%methods); | ||||
487 | : system("$exe $param_string"); | ||||
488 | |||||
489 | =cut | ||||
490 | |||||
491 | sub _set_from_args { | ||||
492 | my ($self, $args, @own_args) = @_; | ||||
493 | $self->throw("a hash/array ref of arguments must be supplied") unless ref($args); | ||||
494 | |||||
495 | my ($methods, $force, $create, $code, $case); | ||||
496 | if (@own_args) { | ||||
497 | ($methods, $force, $create, $code, $case) = | ||||
498 | $self->_rearrange([qw(METHODS | ||||
499 | FORCE | ||||
500 | CREATE | ||||
501 | CODE | ||||
502 | CASE_SENSITIVE)], @own_args); | ||||
503 | } | ||||
504 | my $default_code = 'my $self = shift; | ||||
505 | if (@_) { $self->{\'_\'.$method} = shift } | ||||
506 | return $self->{\'_\'.$method};'; | ||||
507 | |||||
508 | my %method_names = (); | ||||
509 | my %syns = (); | ||||
510 | if ($methods) { | ||||
511 | my @names; | ||||
512 | if (ref($methods) eq 'HASH') { | ||||
513 | @names = keys %{$methods}; | ||||
514 | %syns = %{$methods}; | ||||
515 | } | ||||
516 | else { | ||||
517 | @names = @{$methods}; | ||||
518 | %syns = map { $_ => $_ } @names; | ||||
519 | } | ||||
520 | %method_names = map { $case ? $_ : lc($_) => $_ } @names; | ||||
521 | } | ||||
522 | |||||
523 | # deal with hyphens | ||||
524 | my %orig_args = ref($args) eq 'HASH' ? %{$args} : @{$args}; | ||||
525 | my %args; | ||||
526 | while (my ($method, $value) = each %orig_args) { | ||||
527 | $method =~ s/^-+//; | ||||
528 | $method =~ s/-/_/g; | ||||
529 | $args{$method} = $value; | ||||
530 | } | ||||
531 | |||||
532 | # create non-existing methods on request | ||||
533 | if ($create) { | ||||
534 | unless ($methods) { | ||||
535 | %syns = map { $_ => $case ? $_ : lc($_) } keys %args; | ||||
536 | } | ||||
537 | |||||
538 | foreach my $method (keys %syns) { | ||||
539 | $self->can($method) && next; | ||||
540 | |||||
541 | my $string = $code || $default_code; | ||||
542 | if (ref($code) && ref($code) eq 'HASH') { | ||||
543 | $string = $code->{$method} || $default_code; | ||||
544 | } | ||||
545 | |||||
546 | my $sub = eval "sub { $string }"; | ||||
547 | $self->throw("Compilation error for $method : $@") if $@; | ||||
548 | |||||
549 | 2 | 89µs | 2 | 30µs | # spent 19µs (8+11) within Bio::Root::RootI::BEGIN@549 which was called:
# once (8µs+11µs) by base::import at line 549 # spent 19µs making 1 call to Bio::Root::RootI::BEGIN@549
# spent 11µs making 1 call to strict::unimport |
550 | *{ref($self).'::'.$method} = $sub; | ||||
551 | } | ||||
552 | } | ||||
553 | |||||
554 | # create synonyms of existing methods | ||||
555 | while (my ($method, $syn_ref) = each %syns) { | ||||
556 | my $method_ref = $self->can($method) || next; | ||||
557 | |||||
558 | foreach my $syn (@{ ref($syn_ref) ? $syn_ref : [$syn_ref] }) { | ||||
559 | next if $syn eq $method; | ||||
560 | $method_names{$case ? $syn : lc($syn)} = $syn; | ||||
561 | next if $self->can($syn); | ||||
562 | 2 | 467µs | 2 | 29µs | # spent 20µs (10+10) within Bio::Root::RootI::BEGIN@562 which was called:
# once (10µs+10µs) by base::import at line 562 # spent 20µs making 1 call to Bio::Root::RootI::BEGIN@562
# spent 10µs making 1 call to strict::unimport |
563 | *{ref($self).'::'.$syn} = $method_ref; | ||||
564 | } | ||||
565 | } | ||||
566 | |||||
567 | # set values for methods | ||||
568 | while (my ($method, $value) = each %args) { | ||||
569 | $method = $method_names{$case ? $method : lc($method)} || ($methods ? next : $method); | ||||
570 | $self->can($method) || next unless $force; | ||||
571 | $self->$method($value); | ||||
572 | } | ||||
573 | } | ||||
574 | |||||
575 | |||||
576 | =head2 _rearrange_old | ||||
577 | |||||
578 | =cut | ||||
579 | |||||
580 | #----------------' | ||||
581 | sub _rearrange_old { | ||||
582 | #---------------- | ||||
583 | my($self,$order,@param) = @_; | ||||
584 | |||||
585 | # JGRG -- This is wrong, because we don't want | ||||
586 | # to assign empty string to anything, and this | ||||
587 | # code is actually returning an array 1 less | ||||
588 | # than the length of @param: | ||||
589 | |||||
590 | ## If there are no parameters, we simply wish to return | ||||
591 | ## an empty array which is the size of the @{$order} array. | ||||
592 | #return ('') x $#{$order} unless @param; | ||||
593 | |||||
594 | # ...all we need to do is return an empty array: | ||||
595 | # return unless @param; | ||||
596 | |||||
597 | # If we've got parameters, we need to check to see whether | ||||
598 | # they are named or simply listed. If they are listed, we | ||||
599 | # can just return them. | ||||
600 | |||||
601 | # The mod test fixes bug where a single string parameter beginning with '-' gets lost. | ||||
602 | # This tends to happen in error messages such as: $obj->throw("-id not defined") | ||||
603 | return @param unless (defined($param[0]) && $param[0]=~/^-/o && ($#param % 2)); | ||||
604 | |||||
605 | # Tester | ||||
606 | # print "\n_rearrange() named parameters:\n"; | ||||
607 | # my $i; for ($i=0;$i<@param;$i+=2) { printf "%20s => %s\n", $param[$i],$param[$i+1]; }; <STDIN>; | ||||
608 | |||||
609 | # Now we've got to do some work on the named parameters. | ||||
610 | # The next few lines strip out the '-' characters which | ||||
611 | # preceed the keys, and capitalizes them. | ||||
612 | for (my $i=0;$i<@param;$i+=2) { | ||||
613 | $param[$i]=~s/^\-//; | ||||
614 | $param[$i]=~tr/a-z/A-Z/; | ||||
615 | } | ||||
616 | |||||
617 | # Now we'll convert the @params variable into an associative array. | ||||
618 | # local($^W) = 0; # prevent "odd number of elements" warning with -w. | ||||
619 | my(%param) = @param; | ||||
620 | |||||
621 | # my(@return_array); | ||||
622 | |||||
623 | # What we intend to do is loop through the @{$order} variable, | ||||
624 | # and for each value, we use that as a key into our associative | ||||
625 | # array, pushing the value at that key onto our return array. | ||||
626 | # my($key); | ||||
627 | |||||
628 | #foreach (@{$order}) { | ||||
629 | # my($value) = $param{$key}; | ||||
630 | # delete $param{$key}; | ||||
631 | #push(@return_array,$param{$_}); | ||||
632 | #} | ||||
633 | |||||
634 | return @param{@{$order}}; | ||||
635 | |||||
636 | # print "\n_rearrange() after processing:\n"; | ||||
637 | # my $i; for ($i=0;$i<@return_array;$i++) { printf "%20s => %s\n", ${$order}[$i], $return_array[$i]; } <STDIN>; | ||||
638 | |||||
639 | # return @return_array; | ||||
640 | } | ||||
641 | |||||
642 | =head2 _register_for_cleanup | ||||
643 | |||||
644 | Title : _register_for_cleanup | ||||
645 | Usage : -- internal -- | ||||
646 | Function: Register a method to be called at DESTROY time. This is useful | ||||
647 | and sometimes essential in the case of multiple inheritance for | ||||
648 | classes coming second in the sequence of inheritance. | ||||
649 | Returns : | ||||
650 | Args : a code reference | ||||
651 | |||||
652 | The code reference will be invoked with the object as the first | ||||
653 | argument, as per a method. You may register an unlimited number of | ||||
654 | cleanup methods. | ||||
655 | |||||
656 | =cut | ||||
657 | |||||
658 | sub _register_for_cleanup { | ||||
659 | my ($self,$method) = @_; | ||||
660 | $self->throw_not_implemented(); | ||||
661 | } | ||||
662 | |||||
663 | =head2 _unregister_for_cleanup | ||||
664 | |||||
665 | Title : _unregister_for_cleanup | ||||
666 | Usage : -- internal -- | ||||
667 | Function: Remove a method that has previously been registered to be called | ||||
668 | at DESTROY time. If called with a method to be called at DESTROY time. | ||||
669 | Has no effect if the code reference has not previously been registered. | ||||
670 | Returns : nothing | ||||
671 | Args : a code reference | ||||
672 | |||||
673 | =cut | ||||
674 | |||||
675 | sub _unregister_for_cleanup { | ||||
676 | my ($self,$method) = @_; | ||||
677 | $self->throw_not_implemented(); | ||||
678 | } | ||||
679 | |||||
680 | =head2 _cleanup_methods | ||||
681 | |||||
682 | Title : _cleanup_methods | ||||
683 | Usage : -- internal -- | ||||
684 | Function: Return current list of registered cleanup methods. | ||||
685 | Returns : list of coderefs | ||||
686 | Args : none | ||||
687 | |||||
688 | =cut | ||||
689 | |||||
690 | sub _cleanup_methods { | ||||
691 | my $self = shift; | ||||
692 | unless ( $ENV{'BIOPERLDEBUG'} || $self->verbose > 0 ) { | ||||
693 | carp("Use of Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead"); | ||||
694 | } | ||||
695 | return; | ||||
696 | } | ||||
697 | |||||
698 | =head2 throw_not_implemented | ||||
699 | |||||
700 | Purpose : Throws a Bio::Root::NotImplemented exception. | ||||
701 | Intended for use in the method definitions of | ||||
702 | abstract interface modules where methods are defined | ||||
703 | but are intended to be overridden by subclasses. | ||||
704 | Usage : $object->throw_not_implemented(); | ||||
705 | Example : sub method_foo { | ||||
706 | $self = shift; | ||||
707 | $self->throw_not_implemented(); | ||||
708 | } | ||||
709 | Returns : n/a | ||||
710 | Args : n/a | ||||
711 | Throws : A Bio::Root::NotImplemented exception. | ||||
712 | The message of the exception contains | ||||
713 | - the name of the method | ||||
714 | - the name of the interface | ||||
715 | - the name of the implementing class | ||||
716 | |||||
717 | If this object has a throw() method, $self->throw will be used. | ||||
718 | If the object doesn't have a throw() method, | ||||
719 | Carp::confess() will be used. | ||||
720 | |||||
721 | |||||
722 | =cut | ||||
723 | |||||
724 | #' | ||||
725 | |||||
726 | sub throw_not_implemented { | ||||
727 | my $self = shift; | ||||
728 | |||||
729 | # Bio::Root::Root::throw() knows how to check for Error.pm and will | ||||
730 | # throw an Error-derived object of the specified class (Bio::Root::NotImplemented), | ||||
731 | # which is defined in Bio::Root::Exception. | ||||
732 | # If Error.pm is not available, the name of the class is just included in the | ||||
733 | # error message. | ||||
734 | |||||
735 | my $message = $self->_not_implemented_msg; | ||||
736 | |||||
737 | if ( $self->can('throw') ) { | ||||
738 | my @args; | ||||
739 | if ( $self->isa('Bio::Root::Root') ) { | ||||
740 | # Use Root::throw() hash-based arguments instead of RootI::throw() | ||||
741 | # single string argument whenever possible | ||||
742 | @args = ( -text => $message, -class => 'Bio::Root::NotImplemented' ); | ||||
743 | } else { | ||||
744 | @args = ( $message ); | ||||
745 | } | ||||
746 | $self->throw(@args); | ||||
747 | |||||
748 | } else { | ||||
749 | confess $message; | ||||
750 | } | ||||
751 | } | ||||
752 | |||||
753 | |||||
754 | =head2 warn_not_implemented | ||||
755 | |||||
756 | Purpose : Generates a warning that a method has not been implemented. | ||||
757 | Intended for use in the method definitions of | ||||
758 | abstract interface modules where methods are defined | ||||
759 | but are intended to be overridden by subclasses. | ||||
760 | Generally, throw_not_implemented() should be used, | ||||
761 | but warn_not_implemented() may be used if the method isn't | ||||
762 | considered essential and convenient no-op behavior can be | ||||
763 | provided within the interface. | ||||
764 | Usage : $object->warn_not_implemented( method-name-string ); | ||||
765 | Example : $self->warn_not_implemented( "get_foobar" ); | ||||
766 | Returns : Calls $self->warn on this object, if available. | ||||
767 | If the object doesn't have a warn() method, | ||||
768 | Carp::carp() will be used. | ||||
769 | Args : n/a | ||||
770 | |||||
771 | |||||
772 | =cut | ||||
773 | |||||
774 | #' | ||||
775 | |||||
776 | sub warn_not_implemented { | ||||
777 | my $self = shift; | ||||
778 | my $message = $self->_not_implemented_msg; | ||||
779 | if( $self->can('warn') ) { | ||||
780 | $self->warn( $message ); | ||||
781 | }else { | ||||
782 | carp $message ; | ||||
783 | } | ||||
784 | } | ||||
785 | |||||
786 | =head2 _not_implemented_msg | ||||
787 | |||||
788 | Unify 'not implemented' message. -Juguang | ||||
789 | =cut | ||||
790 | |||||
791 | sub _not_implemented_msg { | ||||
792 | my $self = shift; | ||||
793 | my $package = ref $self; | ||||
794 | my $meth = (caller(2))[3]; | ||||
795 | my $msg =<<EOD_NOT_IMP; | ||||
796 | Abstract method \"$meth\" is not implemented by package $package. | ||||
797 | This is not your fault - author of $package should be blamed! | ||||
798 | EOD_NOT_IMP | ||||
799 | return $msg; | ||||
800 | } | ||||
801 | |||||
802 | 1 | 2µs | 1; |