|
0
|
1 # $Id: RootI.pm,v 1.61 2002/12/16 09:44:28 birney Exp $
|
|
|
2 #
|
|
|
3 # BioPerl module for Bio::Root::RootI
|
|
|
4 #
|
|
|
5 # Cared for by Ewan Birney <birney@ebi.ac.uk>
|
|
|
6 #
|
|
|
7 # Copyright Ewan Birney
|
|
|
8 #
|
|
|
9 # You may distribute this module under the same terms as perl itself
|
|
|
10
|
|
|
11 # POD documentation - main docs before the code
|
|
|
12 #
|
|
|
13 # This was refactored to have chained calls to new instead
|
|
|
14 # of chained calls to _initialize
|
|
|
15 #
|
|
|
16 # added debug and deprecated methods --Jason Stajich 2001-10-12
|
|
|
17 #
|
|
|
18
|
|
|
19 =head1 NAME
|
|
|
20
|
|
|
21 Bio::Root::RootI - Abstract interface to root object code
|
|
|
22
|
|
|
23 =head1 SYNOPSIS
|
|
|
24
|
|
|
25 # any bioperl or bioperl compliant object is a RootI
|
|
|
26 # compliant object
|
|
|
27
|
|
|
28 $obj->throw("This is an exception");
|
|
|
29
|
|
|
30 eval {
|
|
|
31 $obj->throw("This is catching an exception");
|
|
|
32 };
|
|
|
33
|
|
|
34 if( $@ ) {
|
|
|
35 print "Caught exception";
|
|
|
36 } else {
|
|
|
37 print "no exception";
|
|
|
38 }
|
|
|
39
|
|
|
40 # Using throw_not_implemented() within a RootI-based interface module:
|
|
|
41
|
|
|
42 package Foo;
|
|
|
43 @ISA = qw( Bio::Root::RootI );
|
|
|
44
|
|
|
45 sub foo {
|
|
|
46 my $self = shift;
|
|
|
47 $self->throw_not_implemented;
|
|
|
48 }
|
|
|
49
|
|
|
50
|
|
|
51 =head1 DESCRIPTION
|
|
|
52
|
|
|
53 This is just a set of methods which do not assume B<anything> about the object
|
|
|
54 they are on. The methods provide the ability to throw exceptions with nice
|
|
|
55 stack traces.
|
|
|
56
|
|
|
57 This is what should be inherited by all bioperl compliant interfaces, even
|
|
|
58 if they are exotic XS/CORBA/Other perl systems.
|
|
|
59
|
|
|
60 =head2 Using throw_not_implemented()
|
|
|
61
|
|
|
62 The method L<throw_not_implemented()|throw_not_implemented> should be
|
|
|
63 called by all methods within interface modules that extend RootI so
|
|
|
64 that if an implementation fails to override them, an exception will be
|
|
|
65 thrown.
|
|
|
66
|
|
|
67 For example, say there is an interface module called C<FooI> that
|
|
|
68 provides a method called C<foo()>. Since this method is considered
|
|
|
69 abstract within FooI and should be implemented by any module claiming to
|
|
|
70 implement C<FooI>, the C<FooI::foo()> method should consist of the
|
|
|
71 following:
|
|
|
72
|
|
|
73 sub foo {
|
|
|
74 my $self = shift;
|
|
|
75 $self->throw_not_implemented;
|
|
|
76 }
|
|
|
77
|
|
|
78 So, if an implementer of C<FooI> forgets to implement C<foo()>
|
|
|
79 and a user of the implementation calls C<foo()>, a
|
|
|
80 B<Bio::Exception::NotImplemented> exception will result.
|
|
|
81
|
|
|
82 Unfortunately, failure to implement a method can only be determined at
|
|
|
83 run time (i.e., you can't verify that an implementation is complete by
|
|
|
84 running C<perl -wc> on it). So it should be standard practice for a test
|
|
|
85 of an implementation to check each method and verify that it doesn't
|
|
|
86 throw a B<Bio::Exception::NotImplemented>.
|
|
|
87
|
|
|
88 =head1 CONTACT
|
|
|
89
|
|
|
90 Functions originally from Steve Chervitz. Refactored by Ewan
|
|
|
91 Birney. Re-refactored by Lincoln Stein.
|
|
|
92
|
|
|
93 =head1 APPENDIX
|
|
|
94
|
|
|
95 The rest of the documentation details each of the object
|
|
|
96 methods. Internal methods are usually preceded with a _
|
|
|
97
|
|
|
98 =cut
|
|
|
99
|
|
|
100 # Let the code begin...
|
|
|
101
|
|
|
102 package Bio::Root::RootI;
|
|
|
103
|
|
|
104 use vars qw($DEBUG $ID $Revision $VERSION $VERBOSITY);
|
|
|
105 use strict;
|
|
|
106 use Carp 'confess','carp';
|
|
|
107
|
|
|
108 BEGIN {
|
|
|
109 $ID = 'Bio::Root::RootI';
|
|
|
110 $VERSION = 1.0;
|
|
|
111 $Revision = '$Id: RootI.pm,v 1.61 2002/12/16 09:44:28 birney Exp $ ';
|
|
|
112 $DEBUG = 0;
|
|
|
113 $VERBOSITY = 0;
|
|
|
114 }
|
|
|
115
|
|
|
116 sub new {
|
|
|
117 my $class = shift;
|
|
|
118 my @args = @_;
|
|
|
119 unless ( $ENV{'BIOPERLDEBUG'} ) {
|
|
|
120 carp("Use of new in Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead");
|
|
|
121 }
|
|
|
122 eval "require Bio::Root::Root";
|
|
|
123 return Bio::Root::Root->new(@args);
|
|
|
124 }
|
|
|
125
|
|
|
126 # for backwards compatibility
|
|
|
127 sub _initialize {
|
|
|
128 my($self,@args) = @_;
|
|
|
129 return 1;
|
|
|
130 }
|
|
|
131
|
|
|
132
|
|
|
133 =head2 throw
|
|
|
134
|
|
|
135 Title : throw
|
|
|
136 Usage : $obj->throw("throwing exception message")
|
|
|
137 Function: Throws an exception, which, if not caught with an eval brace
|
|
|
138 will provide a nice stack trace to STDERR with the message
|
|
|
139 Returns : nothing
|
|
|
140 Args : A string giving a descriptive error message
|
|
|
141
|
|
|
142
|
|
|
143 =cut
|
|
|
144
|
|
|
145 sub throw{
|
|
|
146 my ($self,$string) = @_;
|
|
|
147
|
|
|
148 my $std = $self->stack_trace_dump();
|
|
|
149
|
|
|
150 my $out = "\n-------------------- EXCEPTION --------------------\n".
|
|
|
151 "MSG: ".$string."\n".$std."-------------------------------------------\n";
|
|
|
152 die $out;
|
|
|
153
|
|
|
154 }
|
|
|
155
|
|
|
156 =head2 warn
|
|
|
157
|
|
|
158 Title : warn
|
|
|
159 Usage : $object->warn("Warning message");
|
|
|
160 Function: Places a warning. What happens now is down to the
|
|
|
161 verbosity of the object (value of $obj->verbose)
|
|
|
162 verbosity 0 or not set => small warning
|
|
|
163 verbosity -1 => no warning
|
|
|
164 verbosity 1 => warning with stack trace
|
|
|
165 verbosity 2 => converts warnings into throw
|
|
|
166 Example :
|
|
|
167 Returns :
|
|
|
168 Args :
|
|
|
169
|
|
|
170 =cut
|
|
|
171
|
|
|
172 sub warn{
|
|
|
173 my ($self,$string) = @_;
|
|
|
174
|
|
|
175 my $verbose;
|
|
|
176 if( $self->can('verbose') ) {
|
|
|
177 $verbose = $self->verbose;
|
|
|
178 } else {
|
|
|
179 $verbose = 0;
|
|
|
180 }
|
|
|
181
|
|
|
182 if( $verbose == 2 ) {
|
|
|
183 $self->throw($string);
|
|
|
184 } elsif( $verbose == -1 ) {
|
|
|
185 return;
|
|
|
186 } elsif( $verbose == 1 ) {
|
|
|
187 my $out = "\n-------------------- WARNING ---------------------\n".
|
|
|
188 "MSG: ".$string."\n";
|
|
|
189 $out .= $self->stack_trace_dump;
|
|
|
190
|
|
|
191 print STDERR $out;
|
|
|
192 return;
|
|
|
193 }
|
|
|
194
|
|
|
195 my $out = "\n-------------------- WARNING ---------------------\n".
|
|
|
196 "MSG: ".$string."\n".
|
|
|
197 "---------------------------------------------------\n";
|
|
|
198 print STDERR $out;
|
|
|
199 }
|
|
|
200
|
|
|
201 =head2 deprecated
|
|
|
202
|
|
|
203 Title : deprecated
|
|
|
204 Usage : $obj->deprecated("Method X is deprecated");
|
|
|
205 Function: Prints a message about deprecation
|
|
|
206 unless verbose is < 0 (which means be quiet)
|
|
|
207 Returns : none
|
|
|
208 Args : Message string to print to STDERR
|
|
|
209
|
|
|
210 =cut
|
|
|
211
|
|
|
212 sub deprecated{
|
|
|
213 my ($self,$msg) = @_;
|
|
|
214 if( $self->verbose >= 0 ) {
|
|
|
215 print STDERR $msg, "\n", $self->stack_trace_dump;
|
|
|
216 }
|
|
|
217 }
|
|
|
218
|
|
|
219 =head2 stack_trace_dump
|
|
|
220
|
|
|
221 Title : stack_trace_dump
|
|
|
222 Usage :
|
|
|
223 Function:
|
|
|
224 Example :
|
|
|
225 Returns :
|
|
|
226 Args :
|
|
|
227
|
|
|
228
|
|
|
229 =cut
|
|
|
230
|
|
|
231 sub stack_trace_dump{
|
|
|
232 my ($self) = @_;
|
|
|
233
|
|
|
234 my @stack = $self->stack_trace();
|
|
|
235
|
|
|
236 shift @stack;
|
|
|
237 shift @stack;
|
|
|
238 shift @stack;
|
|
|
239
|
|
|
240 my $out;
|
|
|
241 my ($module,$function,$file,$position);
|
|
|
242
|
|
|
243
|
|
|
244 foreach my $stack ( @stack) {
|
|
|
245 ($module,$file,$position,$function) = @{$stack};
|
|
|
246 $out .= "STACK $function $file:$position\n";
|
|
|
247 }
|
|
|
248
|
|
|
249 return $out;
|
|
|
250 }
|
|
|
251
|
|
|
252
|
|
|
253 =head2 stack_trace
|
|
|
254
|
|
|
255 Title : stack_trace
|
|
|
256 Usage : @stack_array_ref= $self->stack_trace
|
|
|
257 Function: gives an array to a reference of arrays with stack trace info
|
|
|
258 each coming from the caller(stack_number) call
|
|
|
259 Returns : array containing a reference of arrays
|
|
|
260 Args : none
|
|
|
261
|
|
|
262
|
|
|
263 =cut
|
|
|
264
|
|
|
265 sub stack_trace{
|
|
|
266 my ($self) = @_;
|
|
|
267
|
|
|
268 my $i = 0;
|
|
|
269 my @out;
|
|
|
270 my $prev;
|
|
|
271 while( my @call = caller($i++)) {
|
|
|
272 # major annoyance that caller puts caller context as
|
|
|
273 # function name. Hence some monkeying around...
|
|
|
274 $prev->[3] = $call[3];
|
|
|
275 push(@out,$prev);
|
|
|
276 $prev = \@call;
|
|
|
277 }
|
|
|
278 $prev->[3] = 'toplevel';
|
|
|
279 push(@out,$prev);
|
|
|
280 return @out;
|
|
|
281 }
|
|
|
282
|
|
|
283
|
|
|
284 =head2 _rearrange
|
|
|
285
|
|
|
286 Usage : $object->_rearrange( array_ref, list_of_arguments)
|
|
|
287 Purpose : Rearranges named parameters to requested order.
|
|
|
288 Example : $self->_rearrange([qw(SEQUENCE ID DESC)],@param);
|
|
|
289 : Where @param = (-sequence => $s,
|
|
|
290 : -desc => $d,
|
|
|
291 : -id => $i);
|
|
|
292 Returns : @params - an array of parameters in the requested order.
|
|
|
293 : The above example would return ($s, $i, $d).
|
|
|
294 : Unspecified parameters will return undef. For example, if
|
|
|
295 : @param = (-sequence => $s);
|
|
|
296 : the above _rearrange call would return ($s, undef, undef)
|
|
|
297 Argument : $order : a reference to an array which describes the desired
|
|
|
298 : order of the named parameters.
|
|
|
299 : @param : an array of parameters, either as a list (in
|
|
|
300 : which case the function simply returns the list),
|
|
|
301 : or as an associative array with hyphenated tags
|
|
|
302 : (in which case the function sorts the values
|
|
|
303 : according to @{$order} and returns that new array.)
|
|
|
304 : The tags can be upper, lower, or mixed case
|
|
|
305 : but they must start with a hyphen (at least the
|
|
|
306 : first one should be hyphenated.)
|
|
|
307 Source : This function was taken from CGI.pm, written by Dr. Lincoln
|
|
|
308 : Stein, and adapted for use in Bio::Seq by Richard Resnick and
|
|
|
309 : then adapted for use in Bio::Root::Object.pm by Steve Chervitz,
|
|
|
310 : then migrated into Bio::Root::RootI.pm by Ewan Birney.
|
|
|
311 Comments :
|
|
|
312 : Uppercase tags are the norm,
|
|
|
313 : (SAC)
|
|
|
314 : This method may not be appropriate for method calls that are
|
|
|
315 : within in an inner loop if efficiency is a concern.
|
|
|
316 :
|
|
|
317 : Parameters can be specified using any of these formats:
|
|
|
318 : @param = (-name=>'me', -color=>'blue');
|
|
|
319 : @param = (-NAME=>'me', -COLOR=>'blue');
|
|
|
320 : @param = (-Name=>'me', -Color=>'blue');
|
|
|
321 : @param = ('me', 'blue');
|
|
|
322 : A leading hyphenated argument is used by this function to
|
|
|
323 : indicate that named parameters are being used.
|
|
|
324 : Therefore, the ('me', 'blue') list will be returned as-is.
|
|
|
325 :
|
|
|
326 : Note that Perl will confuse unquoted, hyphenated tags as
|
|
|
327 : function calls if there is a function of the same name
|
|
|
328 : in the current namespace:
|
|
|
329 : -name => 'foo' is interpreted as -&name => 'foo'
|
|
|
330 :
|
|
|
331 : For ultimate safety, put single quotes around the tag:
|
|
|
332 : ('-name'=>'me', '-color' =>'blue');
|
|
|
333 : This can be a bit cumbersome and I find not as readable
|
|
|
334 : as using all uppercase, which is also fairly safe:
|
|
|
335 : (-NAME=>'me', -COLOR =>'blue');
|
|
|
336 :
|
|
|
337 : Personal note (SAC): I have found all uppercase tags to
|
|
|
338 : be more managable: it involves less single-quoting,
|
|
|
339 : the key names stand out better, and there are no method naming
|
|
|
340 : conflicts.
|
|
|
341 : The drawbacks are that it's not as easy to type as lowercase,
|
|
|
342 : and lots of uppercase can be hard to read.
|
|
|
343 :
|
|
|
344 : Regardless of the style, it greatly helps to line
|
|
|
345 : the parameters up vertically for long/complex lists.
|
|
|
346
|
|
|
347 =cut
|
|
|
348
|
|
|
349 sub _rearrange {
|
|
|
350 my $dummy = shift;
|
|
|
351 my $order = shift;
|
|
|
352
|
|
|
353 return @_ unless (substr($_[0]||'',0,1) eq '-');
|
|
|
354 push @_,undef unless $#_ %2;
|
|
|
355 my %param;
|
|
|
356 while( @_ ) {
|
|
|
357 (my $key = shift) =~ tr/a-z\055/A-Z/d; #deletes all dashes!
|
|
|
358 $param{$key} = shift;
|
|
|
359 }
|
|
|
360 map { $_ = uc($_) } @$order; # for bug #1343, but is there perf hit here?
|
|
|
361 return @param{@$order};
|
|
|
362 }
|
|
|
363
|
|
|
364
|
|
|
365 #----------------'
|
|
|
366 sub _rearrange_old {
|
|
|
367 #----------------
|
|
|
368 my($self,$order,@param) = @_;
|
|
|
369
|
|
|
370 # JGRG -- This is wrong, because we don't want
|
|
|
371 # to assign empty string to anything, and this
|
|
|
372 # code is actually returning an array 1 less
|
|
|
373 # than the length of @param:
|
|
|
374
|
|
|
375 ## If there are no parameters, we simply wish to return
|
|
|
376 ## an empty array which is the size of the @{$order} array.
|
|
|
377 #return ('') x $#{$order} unless @param;
|
|
|
378
|
|
|
379 # ...all we need to do is return an empty array:
|
|
|
380 # return unless @param;
|
|
|
381
|
|
|
382 # If we've got parameters, we need to check to see whether
|
|
|
383 # they are named or simply listed. If they are listed, we
|
|
|
384 # can just return them.
|
|
|
385
|
|
|
386 # The mod test fixes bug where a single string parameter beginning with '-' gets lost.
|
|
|
387 # This tends to happen in error messages such as: $obj->throw("-id not defined")
|
|
|
388 return @param unless (defined($param[0]) && $param[0]=~/^-/o && ($#param % 2));
|
|
|
389
|
|
|
390 # Tester
|
|
|
391 # print "\n_rearrange() named parameters:\n";
|
|
|
392 # my $i; for ($i=0;$i<@param;$i+=2) { printf "%20s => %s\n", $param[$i],$param[$i+1]; }; <STDIN>;
|
|
|
393
|
|
|
394 # Now we've got to do some work on the named parameters.
|
|
|
395 # The next few lines strip out the '-' characters which
|
|
|
396 # preceed the keys, and capitalizes them.
|
|
|
397 for (my $i=0;$i<@param;$i+=2) {
|
|
|
398 $param[$i]=~s/^\-//;
|
|
|
399 $param[$i]=~tr/a-z/A-Z/;
|
|
|
400 }
|
|
|
401
|
|
|
402 # Now we'll convert the @params variable into an associative array.
|
|
|
403 # local($^W) = 0; # prevent "odd number of elements" warning with -w.
|
|
|
404 my(%param) = @param;
|
|
|
405
|
|
|
406 # my(@return_array);
|
|
|
407
|
|
|
408 # What we intend to do is loop through the @{$order} variable,
|
|
|
409 # and for each value, we use that as a key into our associative
|
|
|
410 # array, pushing the value at that key onto our return array.
|
|
|
411 # my($key);
|
|
|
412
|
|
|
413 #foreach (@{$order}) {
|
|
|
414 # my($value) = $param{$key};
|
|
|
415 # delete $param{$key};
|
|
|
416 #push(@return_array,$param{$_});
|
|
|
417 #}
|
|
|
418
|
|
|
419 return @param{@{$order}};
|
|
|
420
|
|
|
421 # print "\n_rearrange() after processing:\n";
|
|
|
422 # my $i; for ($i=0;$i<@return_array;$i++) { printf "%20s => %s\n", ${$order}[$i], $return_array[$i]; } <STDIN>;
|
|
|
423
|
|
|
424 # return @return_array;
|
|
|
425 }
|
|
|
426
|
|
|
427 =head2 _register_for_cleanup
|
|
|
428
|
|
|
429 Title : _register_for_cleanup
|
|
|
430 Usage : -- internal --
|
|
|
431 Function: Register a method to be called at DESTROY time. This is useful
|
|
|
432 and sometimes essential in the case of multiple inheritance for
|
|
|
433 classes coming second in the sequence of inheritance.
|
|
|
434 Returns :
|
|
|
435 Args : a code reference
|
|
|
436
|
|
|
437 The code reference will be invoked with the object as the first
|
|
|
438 argument, as per a method. You may register an unlimited number of
|
|
|
439 cleanup methods.
|
|
|
440
|
|
|
441 =cut
|
|
|
442
|
|
|
443 sub _register_for_cleanup {
|
|
|
444 my ($self,$method) = @_;
|
|
|
445 $self->throw_not_implemented();
|
|
|
446 }
|
|
|
447
|
|
|
448 =head2 _unregister_for_cleanup
|
|
|
449
|
|
|
450 Title : _unregister_for_cleanup
|
|
|
451 Usage : -- internal --
|
|
|
452 Function: Remove a method that has previously been registered to be called
|
|
|
453 at DESTROY time. If called with a methoda method to be called at DESTROY time.
|
|
|
454 Has no effect if the code reference has not previously been registered.
|
|
|
455 Returns : nothing
|
|
|
456 Args : a code reference
|
|
|
457
|
|
|
458 =cut
|
|
|
459
|
|
|
460 sub _unregister_for_cleanup {
|
|
|
461 my ($self,$method) = @_;
|
|
|
462 $self->throw_not_implemented();
|
|
|
463 }
|
|
|
464
|
|
|
465 =head2 _cleanup_methods
|
|
|
466
|
|
|
467 Title : _cleanup_methods
|
|
|
468 Usage : -- internal --
|
|
|
469 Function: Return current list of registered cleanup methods.
|
|
|
470 Returns : list of coderefs
|
|
|
471 Args : none
|
|
|
472
|
|
|
473 =cut
|
|
|
474
|
|
|
475 sub _cleanup_methods {
|
|
|
476 my $self = shift;
|
|
|
477 unless ( $ENV{'BIOPERLDEBUG'} || $self->verbose > 0 ) {
|
|
|
478 carp("Use of Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead");
|
|
|
479 }
|
|
|
480 return;
|
|
|
481 }
|
|
|
482
|
|
|
483 =head2 throw_not_implemented
|
|
|
484
|
|
|
485 Purpose : Throws a Bio::Root::NotImplemented exception.
|
|
|
486 Intended for use in the method definitions of
|
|
|
487 abstract interface modules where methods are defined
|
|
|
488 but are intended to be overridden by subclasses.
|
|
|
489 Usage : $object->throw_not_implemented();
|
|
|
490 Example : sub method_foo {
|
|
|
491 $self = shift;
|
|
|
492 $self->throw_not_implemented();
|
|
|
493 }
|
|
|
494 Returns : n/a
|
|
|
495 Args : n/a
|
|
|
496 Throws : A Bio::Root::NotImplemented exception.
|
|
|
497 The message of the exception contains
|
|
|
498 - the name of the method
|
|
|
499 - the name of the interface
|
|
|
500 - the name of the implementing class
|
|
|
501
|
|
|
502 If this object has a throw() method, $self->throw will be used.
|
|
|
503 If the object doesn't have a throw() method,
|
|
|
504 Carp::confess() will be used.
|
|
|
505
|
|
|
506
|
|
|
507 =cut
|
|
|
508
|
|
|
509 #'
|
|
|
510
|
|
|
511 sub throw_not_implemented {
|
|
|
512 my $self = shift;
|
|
|
513 my $package = ref $self;
|
|
|
514 my $iface = caller(0);
|
|
|
515 my @call = caller(1);
|
|
|
516 my $meth = $call[3];
|
|
|
517
|
|
|
518 my $message = "Abstract method \"$meth\" is not implemented by package $package.\n" .
|
|
|
519 "This is not your fault - author of $package should be blamed!\n";
|
|
|
520
|
|
|
521 # Checking if Error.pm is available in case the object isn't decended from
|
|
|
522 # Bio::Root::Root, which knows how to check for Error.pm.
|
|
|
523
|
|
|
524 # EB - this wasn't working and I couldn't figure out!
|
|
|
525 # SC - OK, since most RootI objects will be Root.pm-based,
|
|
|
526 # and Root.pm can deal with Error.pm.
|
|
|
527 # Still, I'd like to know why it wasn't working...
|
|
|
528
|
|
|
529 if( $self->can('throw') ) {
|
|
|
530 $self->throw( -text => $message,
|
|
|
531 -class => 'Bio::Root::NotImplemented');
|
|
|
532 }
|
|
|
533 else {
|
|
|
534 confess $message ;
|
|
|
535 }
|
|
|
536 }
|
|
|
537
|
|
|
538
|
|
|
539 =head2 warn_not_implemented
|
|
|
540
|
|
|
541 Purpose : Generates a warning that a method has not been implemented.
|
|
|
542 Intended for use in the method definitions of
|
|
|
543 abstract interface modules where methods are defined
|
|
|
544 but are intended to be overridden by subclasses.
|
|
|
545 Generally, throw_not_implemented() should be used,
|
|
|
546 but warn_not_implemented() may be used if the method isn't
|
|
|
547 considered essential and convenient no-op behavior can be
|
|
|
548 provided within the interface.
|
|
|
549 Usage : $object->warn_not_implemented( method-name-string );
|
|
|
550 Example : $self->warn_not_implemented( "get_foobar" );
|
|
|
551 Returns : Calls $self->warn on this object, if available.
|
|
|
552 If the object doesn't have a warn() method,
|
|
|
553 Carp::carp() will be used.
|
|
|
554 Args : n/a
|
|
|
555
|
|
|
556
|
|
|
557 =cut
|
|
|
558
|
|
|
559 #'
|
|
|
560
|
|
|
561 sub warn_not_implemented {
|
|
|
562 my $self = shift;
|
|
|
563 my $package = ref $self;
|
|
|
564 my $iface = caller(0);
|
|
|
565 my @call = caller(1);
|
|
|
566 my $meth = $call[3];
|
|
|
567
|
|
|
568 my $message = "Abstract method \"$meth\" is not implemented by package $package.\n" .
|
|
|
569 "This is not your fault - author of $package should be blamed!\n";
|
|
|
570
|
|
|
571 if( $self->can('warn') ) {
|
|
|
572 $self->warn( $message );
|
|
|
573 }
|
|
|
574 else {
|
|
|
575 carp $message ;
|
|
|
576 }
|
|
|
577 }
|
|
|
578
|
|
|
579
|
|
|
580 1;
|
