|
0
|
1 package Bio::EnsEMBL::Utils::Scalar;
|
|
|
2
|
|
|
3 =pod
|
|
|
4
|
|
|
5 =head1 LICENSE
|
|
|
6
|
|
|
7 Copyright (c) 1999-2012 The European Bioinformatics Institute and
|
|
|
8 Genome Research Limited. All rights reserved.
|
|
|
9
|
|
|
10 This software is distributed under a modified Apache license.
|
|
|
11 For license details, please see
|
|
|
12
|
|
|
13 http://www.ensembl.org/info/about/code_licence.html
|
|
|
14
|
|
|
15 =head1 CONTACT
|
|
|
16
|
|
|
17 Please email comments or questions to the public Ensembl
|
|
|
18 developers list at <dev@ensembl.org>.
|
|
|
19
|
|
|
20 Questions may also be sent to the Ensembl help desk at
|
|
|
21 <helpdesk@ensembl.org>.
|
|
|
22
|
|
|
23 =cut
|
|
|
24
|
|
|
25 =pod
|
|
|
26
|
|
|
27 =head1 NAME
|
|
|
28
|
|
|
29 Bio::EnsEMBL::Utils::Scalar
|
|
|
30
|
|
|
31 =head1 SYNOPSIS
|
|
|
32
|
|
|
33 use Bio::EnsEMBL::Utils::Scalar qw(check_ref assert_ref wrap_array check_ref_can assert_ref_can assert_numeric assert_integer scope_guard);
|
|
|
34
|
|
|
35 check_ref([], 'ARRAY'); # Will return true
|
|
|
36 check_ref({}, 'ARRAY'); # Will return false
|
|
|
37 check_ref($dba, 'Bio::EnsEMBL::DBSQL::DBAdaptor'); #Returns true if $dba is a DBAdaptor
|
|
|
38
|
|
|
39 assert_ref([], 'ARRAY'); #Returns true
|
|
|
40 assert_ref({}, 'ARRAY'); #throws an exception
|
|
|
41 assert_ref($dba, 'Bio::EnsEMBL::Gene'); #throws an exception if $dba is not a Gene
|
|
|
42
|
|
|
43 wrap_array([]); #Returns the same reference
|
|
|
44 wrap_array($a); #Returns [$a] if $a was not an array
|
|
|
45 wrap_array(undef); #Returns [] since incoming was undefined
|
|
|
46 wrap_array(); #Returns [] since incoming was empty (therefore undefined)
|
|
|
47
|
|
|
48 check_ref_can([], 'dbID'); #returns false as ArrayRef is not blessed
|
|
|
49 check_ref_can($gene, 'dbID'); #returns true as Gene should implement dbID()
|
|
|
50 check_ref_can(undef); #Throws an exception as we gave no method to test
|
|
|
51
|
|
|
52 assert_ref_can([], 'dbID'); #throws an exception since ArrayRef is not blessed
|
|
|
53 assert_ref_can($gene, 'dbID'); #returns true if gene implements dbID()
|
|
|
54 assert_ref_can(undef); #Throws an exception as we gave no method to test
|
|
|
55
|
|
|
56 asssert_integer(1, 'dbID'); #Passes
|
|
|
57 asssert_integer(1.1, 'dbID'); #Fails
|
|
|
58 asssert_numeric(1E-11, 'dbID'); #Passes
|
|
|
59 asssert_numeric({}, 'dbID'); #Fails
|
|
|
60
|
|
|
61 #Scope guards
|
|
|
62 my $v = 'wibble';
|
|
|
63 {
|
|
|
64 #Build a guard to reset $v to wibble
|
|
|
65 my $guard = scope_guard(sub { $v = 'wibble'});
|
|
|
66 $v = 'wobble';
|
|
|
67 warn $v; # prints wobble
|
|
|
68 }
|
|
|
69 # $guard is out of scope; sub is triggered and $v is reset
|
|
|
70 warn $v; # prints wibble
|
|
|
71
|
|
|
72 #Tags are also available for exporting
|
|
|
73 use Bio::EnsEMBL::Utils::Scalar qw(:assert); # brings in all assert methods
|
|
|
74 use Bio::EnsEMBL::Utils::Scalar qw(:check); #brings in all check methods
|
|
|
75 use Bio::EnsEMBL::Utils::Scalar qw(:array); #brings in wrap_array
|
|
|
76 use Bio::EnsEMBL::Utils::Scalar qw(:all); #import all methods
|
|
|
77
|
|
|
78 =head1 DESCRIPTION
|
|
|
79
|
|
|
80 A collection of subroutines aimed to helping Scalar based operations
|
|
|
81
|
|
|
82 =head1 METHODS
|
|
|
83
|
|
|
84 See subroutines.
|
|
|
85
|
|
|
86 =head1 MAINTAINER
|
|
|
87
|
|
|
88 $Author: ady $
|
|
|
89
|
|
|
90 =head1 VERSION
|
|
|
91
|
|
|
92 $Revision: 1.12.14.1 $
|
|
|
93
|
|
|
94 =cut
|
|
|
95
|
|
|
96 use strict;
|
|
|
97 use warnings;
|
|
|
98
|
|
|
99 use base qw(Exporter);
|
|
|
100
|
|
|
101 our %EXPORT_TAGS;
|
|
|
102 our @EXPORT_OK;
|
|
|
103
|
|
|
104 @EXPORT_OK = qw(
|
|
|
105 check_ref check_ref_can
|
|
|
106 assert_ref assert_ref_can assert_numeric assert_integer assert_boolean assert_strand assert_file_handle
|
|
|
107 wrap_array
|
|
|
108 scope_guard
|
|
|
109 );
|
|
|
110 %EXPORT_TAGS = (
|
|
|
111 assert => [qw(assert_ref assert_ref_can assert_integer assert_numeric assert_boolean assert_strand assert_file_handle)],
|
|
|
112 check => [qw(check_ref check_ref_can)],
|
|
|
113 array => [qw/wrap_array/],
|
|
|
114 all => [@EXPORT_OK]
|
|
|
115 );
|
|
|
116
|
|
|
117 use Bio::EnsEMBL::Utils::Exception qw(throw);
|
|
|
118 use Scalar::Util qw(blessed looks_like_number openhandle);
|
|
|
119
|
|
|
120 =head2 check_ref()
|
|
|
121
|
|
|
122 Arg [1] : The reference to check
|
|
|
123 Arg [2] : The type we expect
|
|
|
124 Description : A subroutine which checks to see if the given object/ref is
|
|
|
125 what you expect. If you give it a blessed reference then it
|
|
|
126 will perform an isa() call on the object after the defined
|
|
|
127 tests. If it is a plain reference then it will use ref().
|
|
|
128
|
|
|
129 An undefined value will return a false.
|
|
|
130 Returntype : Boolean indicating if the reference was the type we
|
|
|
131 expect
|
|
|
132 Example : my $ok = check_ref([], 'ARRAY');
|
|
|
133 Exceptions : If the expected type was not set
|
|
|
134 Status : Stable
|
|
|
135
|
|
|
136 =cut
|
|
|
137
|
|
|
138 sub check_ref {
|
|
|
139 my ($ref, $expected) = @_;
|
|
|
140 throw('No expected type given') if ! defined $expected;
|
|
|
141 if(defined $ref) {
|
|
|
142 if(blessed($ref)) {
|
|
|
143 return 1 if $ref->isa($expected);
|
|
|
144 }
|
|
|
145 else {
|
|
|
146 my $ref_ref_type = ref($ref);
|
|
|
147 return 1 if defined $ref_ref_type && $ref_ref_type eq $expected;
|
|
|
148 }
|
|
|
149 }
|
|
|
150 return 0;
|
|
|
151 }
|
|
|
152
|
|
|
153 =head2 assert_ref()
|
|
|
154
|
|
|
155 Arg [1] : The reference to check
|
|
|
156 Arg [2] : The type we expect
|
|
|
157 Arg [3] : The attribute name you are asserting; not required but allows
|
|
|
158 for more useful error messages to be generated. Defaults to
|
|
|
159 C<-Unknown->.
|
|
|
160 Description : A subroutine which checks to see if the given object/ref is
|
|
|
161 what you expect. This behaves in an identical manner as
|
|
|
162 C<check_ref()> does except this will raise exceptions when
|
|
|
163 the values do not match rather than returning a boolean
|
|
|
164 indicating the situation.
|
|
|
165
|
|
|
166 Undefs cause exception circumstances.
|
|
|
167 Returntype : Boolean; true if we managed to get to the return
|
|
|
168 Example : assert_ref([], 'ARRAY');
|
|
|
169 Exceptions : If the expected type was not set and if the given reference
|
|
|
170 was not assignable to the expected value
|
|
|
171 Status : Stable
|
|
|
172
|
|
|
173 =cut
|
|
|
174
|
|
|
175 sub assert_ref {
|
|
|
176 my ($ref, $expected, $attribute_name) = @_;
|
|
|
177 $attribute_name ||= '-Unknown-';
|
|
|
178 throw('No expected type given') if ! defined $expected;
|
|
|
179 my $class = ref($ref);
|
|
|
180 throw("The given reference for attribute $attribute_name was undef") unless defined $ref;
|
|
|
181 throw("Asking for the type of the attribute $attribute_name produced no type; check it is a reference") unless $class;
|
|
|
182 if(blessed($ref)) {
|
|
|
183 throw("${attribute_name}'s type '${class}' is not an ISA of '${expected}'") if ! $ref->isa($expected);
|
|
|
184 }
|
|
|
185 else {
|
|
|
186 throw("$attribute_name was expected to be '${expected}' but was '${class}'") if $expected ne $class;
|
|
|
187 }
|
|
|
188 return 1;
|
|
|
189 }
|
|
|
190
|
|
|
191 =head2 wrap_array()
|
|
|
192
|
|
|
193 Arg : The reference we want to wrap in an array
|
|
|
194 Description : Takes in a reference and returns either the reference if it
|
|
|
195 was already an array, the reference wrapped in an array or
|
|
|
196 an empty array (if the given value was undefined).
|
|
|
197 Returntype : Array Reference
|
|
|
198 Example : my $a = wrap_array($input);
|
|
|
199 Exceptions : None
|
|
|
200 Status : Stable
|
|
|
201
|
|
|
202 =cut
|
|
|
203
|
|
|
204 sub wrap_array {
|
|
|
205 my ($incoming_reference) = @_;
|
|
|
206 if(defined $incoming_reference) {
|
|
|
207 if(check_ref($incoming_reference, 'ARRAY')) {
|
|
|
208 return $incoming_reference;
|
|
|
209 }
|
|
|
210 else {
|
|
|
211 return [$incoming_reference];
|
|
|
212 }
|
|
|
213 }
|
|
|
214 return [];
|
|
|
215 }
|
|
|
216
|
|
|
217 =head2 check_ref_can
|
|
|
218
|
|
|
219 Arg [1] : The reference to check
|
|
|
220 Arg [2] : The method we expect to run
|
|
|
221 Description : A subroutine which checks to see if the given object/ref is
|
|
|
222 implements the given method. This is very similar to the
|
|
|
223 functionality given by C<UNIVERSAL::can()> but works
|
|
|
224 by executing C<can()> on the object meaning we consult the
|
|
|
225 object's potentially overriden version rather than Perl's
|
|
|
226 default mechanism.
|
|
|
227 Returntype : CodeRef
|
|
|
228 Example : check_ref_can($gene, 'dbID');
|
|
|
229 Exceptions : If the expected type was not set.
|
|
|
230 Status : Stable
|
|
|
231
|
|
|
232 =cut
|
|
|
233
|
|
|
234 sub check_ref_can {
|
|
|
235 my ($ref, $method) = @_;
|
|
|
236 throw('No method given') if ! defined $method;
|
|
|
237 return unless defined $ref && blessed($ref);
|
|
|
238 return $ref->can($method);
|
|
|
239 }
|
|
|
240
|
|
|
241 =head2 assert_ref_can
|
|
|
242
|
|
|
243 Arg [1] : The reference to check
|
|
|
244 Arg [2] : The method we expect to run
|
|
|
245 Arg [3] : The attribute name you are asserting; not required but allows
|
|
|
246 for more useful error messages to be generated. Defaults to
|
|
|
247 C<-Unknown->.
|
|
|
248 Description : A subroutine which checks to see if the given object/ref is
|
|
|
249 implements the given method. Will throw exceptions.
|
|
|
250 Returntype : Boolean; true if we managed to get to the return
|
|
|
251 Example : assert_ref_can($gene, 'dbID');
|
|
|
252 Exceptions : If the reference is not defined, if the object does not
|
|
|
253 implement the given method and if no method was given to check
|
|
|
254 Status : Stable
|
|
|
255
|
|
|
256 =cut
|
|
|
257
|
|
|
258 sub assert_ref_can {
|
|
|
259 my ($ref, $method, $attribute_name) = @_;
|
|
|
260 $attribute_name ||= '-Unknown-';
|
|
|
261 throw('No method given') if ! defined $method;
|
|
|
262 throw "The given reference $attribute_name is not defined" unless defined $ref;
|
|
|
263 throw "The given reference $attribute_name is not blessed" unless blessed($ref);
|
|
|
264 if(! $ref->can($method)) {
|
|
|
265 my $str_ref = ref($ref);
|
|
|
266 throw sprintf(q{The given blessed reference '%s' for attribute '%s' does not implement the method '%s'}, $str_ref, $attribute_name, $method);
|
|
|
267 }
|
|
|
268 return 1;
|
|
|
269 }
|
|
|
270
|
|
|
271 =head2 assert_numeric
|
|
|
272
|
|
|
273 Arg [1] : The Scalar to check
|
|
|
274 Arg [2] : The attribute name you are asserting; not required but allows
|
|
|
275 for more useful error messages to be generated. Defaults to
|
|
|
276 C<-Unknown->.
|
|
|
277 Description : A subroutine which checks to see if the given scalar is
|
|
|
278 number or not. If not then we raise exceptions detailing why
|
|
|
279 Returntype : Boolean; true if we had a numeric otherwise we signal failure
|
|
|
280 via exceptions
|
|
|
281 Example : assert_numeric(1, 'dbID');
|
|
|
282 Exceptions : If the Scalar is not defined, if the Scalar was blessed and
|
|
|
283 if the value was not a number
|
|
|
284 Status : Stable
|
|
|
285
|
|
|
286 =cut
|
|
|
287
|
|
|
288 sub assert_numeric {
|
|
|
289 my ($integer, $attribute_name) = @_;
|
|
|
290 $attribute_name ||= '-Unknown-';
|
|
|
291 throw "$attribute_name attribute is undefined" if ! defined $integer;
|
|
|
292 throw "The given attribute $attribute_name is blessed; cannot work with blessed values" if blessed($integer);
|
|
|
293 if(! looks_like_number($integer)) {
|
|
|
294 throw "Attribute $attribute_name was not a number";
|
|
|
295 }
|
|
|
296 return 1;
|
|
|
297 }
|
|
|
298
|
|
|
299 =head2 assert_integer
|
|
|
300
|
|
|
301 Arg [1] : The Scalar to check
|
|
|
302 Arg [2] : The attribute name you are asserting; not required but allows
|
|
|
303 for more useful error messages to be generated. Defaults to
|
|
|
304 C<-Unknown->.
|
|
|
305 Description : A subroutine which checks to see if the given scalar is
|
|
|
306 a whole integer; we delegate to L<assert_numeric> for number
|
|
|
307 checking.
|
|
|
308 Returntype : Boolean; true if we had a numeric otherwise we signal failure
|
|
|
309 via exceptions
|
|
|
310 Example : assert_integer(1, 'dbID');
|
|
|
311 Exceptions : See L<assert_numeric> and we raise exceptions if the value
|
|
|
312 was not a whole integer
|
|
|
313 Status : Stable
|
|
|
314
|
|
|
315 =cut
|
|
|
316
|
|
|
317 sub assert_integer {
|
|
|
318 my ($integer, $attribute_name) = @_;
|
|
|
319 $attribute_name ||= '-Unknown-';
|
|
|
320 assert_numeric($integer, $attribute_name);
|
|
|
321 if($integer != int($integer)) {
|
|
|
322 throw "Attribute $attribute_name was a number but not an Integer";
|
|
|
323 }
|
|
|
324 return 1;
|
|
|
325 }
|
|
|
326
|
|
|
327 =head2 assert_boolean
|
|
|
328
|
|
|
329 Arg [1] : The Scalar to check
|
|
|
330 Arg [2] : The attribute name you are asserting; not required but allows
|
|
|
331 for more useful error messages to be generated. Defaults to
|
|
|
332 C<-Unknown->.
|
|
|
333 Description : A subroutine which checks to see if the given scalar is
|
|
|
334 a boolean i.e. value is set to C<1> or C<0>
|
|
|
335 Returntype : Boolean; true if we were given a boolean otherwise we signal
|
|
|
336 failure via exceptions
|
|
|
337 Example : assert_boolean(1, 'is_circular');
|
|
|
338 Exceptions : See L<assert_integer> and we raise exceptions if the value
|
|
|
339 was not equal to the 2 valid states
|
|
|
340 Status : Stable
|
|
|
341
|
|
|
342 =cut
|
|
|
343
|
|
|
344 sub assert_boolean {
|
|
|
345 my ($boolean, $attribute_name) = @_;
|
|
|
346 $attribute_name ||= '-Unknown-';
|
|
|
347 assert_numeric($boolean, $attribute_name);
|
|
|
348 if($boolean != 0 && $boolean != 1) {
|
|
|
349 throw "Attribute $attribute_name was an invalid boolean. Expected: 1 or 0. Got: $boolean";
|
|
|
350 }
|
|
|
351 return 1;
|
|
|
352 }
|
|
|
353
|
|
|
354 =head2 assert_strand
|
|
|
355
|
|
|
356 Arg [1] : The Scalar to check
|
|
|
357 Arg [2] : The attribute name you are asserting; not required but allows
|
|
|
358 for more useful error messages to be generated. Defaults to
|
|
|
359 C<-Unknown->.
|
|
|
360 Description : A subroutine which checks to see if the given scalar is
|
|
|
361 a whole integer and if the value is set to C<1>, C<0> or C<-1>
|
|
|
362 Returntype : Boolean; true if we had a strand integer otherwise we signal
|
|
|
363 failure via exceptions
|
|
|
364 Example : assert_strand(1, 'strand');
|
|
|
365 Exceptions : See L<assert_integer> and we raise exceptions if the value
|
|
|
366 was not equal to the 3 valid states
|
|
|
367 Status : Stable
|
|
|
368
|
|
|
369 =cut
|
|
|
370
|
|
|
371 sub assert_strand {
|
|
|
372 my ($strand, $attribute_name) = @_;
|
|
|
373 $attribute_name ||= '-Unknown-';
|
|
|
374 assert_numeric($strand, $attribute_name);
|
|
|
375 if($strand != -1 && $strand != 0 && $strand ne 1) {
|
|
|
376 throw "Attribute $attribute_name was an invalid strand. Expected: 1, 0 or -1. Got: $strand";
|
|
|
377 }
|
|
|
378 return 1;
|
|
|
379 }
|
|
|
380
|
|
|
381
|
|
|
382 =head2 assert_file_handle
|
|
|
383
|
|
|
384 Arg [1] : The Scalar to check
|
|
|
385 Arg [2] : The attribute name you are asserting; not required but allows
|
|
|
386 for more useful error messages to be generated. Defaults to
|
|
|
387 C<-Unknown->.
|
|
|
388 Description : A subroutine which checks to see if the given scalar is
|
|
|
389 actually a file handle. This will handle those which are Glob
|
|
|
390 references and those which inherit from C<IO::Handle>. It will
|
|
|
391 also cope with a blessed Glob reference.
|
|
|
392 Returntype : Boolean;
|
|
|
393 Example : assert_file_handle($fh, '-FILE_HANDLE');
|
|
|
394 Exceptions : Raised if not defined, not a reference and was not a
|
|
|
395 GLOB or did not inherit from IO::Handle
|
|
|
396 Status : Stable
|
|
|
397
|
|
|
398 =cut
|
|
|
399
|
|
|
400 sub assert_file_handle {
|
|
|
401 my ($file_handle, $attribute_name) = @_;
|
|
|
402 $attribute_name ||= '-Unknown-';
|
|
|
403 throw "Attribute $attribute_name was undefined" if ! defined $file_handle;
|
|
|
404 my $ref = ref($file_handle);
|
|
|
405 throw "Attribute $attribute_name was not a reference. Got: $file_handle" if ! $ref;
|
|
|
406 if(!openhandle($file_handle)) {
|
|
|
407 if(blessed($file_handle)) {
|
|
|
408 if(! $file_handle->isa('IO::Handle')) {
|
|
|
409 throw "Attribute $attribute_name was blessed but did not inherit from IO::Handle. Ref was: $ref";
|
|
|
410 }
|
|
|
411 }
|
|
|
412 else {
|
|
|
413 throw "Attribute $attribute_name was not a file handle. Ref was: $ref";
|
|
|
414 }
|
|
|
415 }
|
|
|
416 return 1;
|
|
|
417 }
|
|
|
418
|
|
|
419 =head2 scope_guard
|
|
|
420
|
|
|
421 Arg [1] : CodeRef The block of code to exit once it escapes out of scope
|
|
|
422 Description : Simple subroutine which blesses your given code reference into
|
|
|
423 a L<Bio::EnsEMBL::Utils::Scalar::ScopeGuard> object. This has
|
|
|
424 a DESTROY implemented which will cause the code reference
|
|
|
425 to execute once the object goes out of scope and its reference
|
|
|
426 count hits 0.
|
|
|
427 Returntype : Bio::EnsEMBL::Utils::Scalar::ScopeGuard
|
|
|
428 Example : my $v = 'wibble';
|
|
|
429 {
|
|
|
430 #Build a guard to reset $v to wibble
|
|
|
431 my $guard = scope_guard(sub { $v = 'wibble'});
|
|
|
432 $v = 'wobble';
|
|
|
433 warn $v;
|
|
|
434 }
|
|
|
435 # $guard is out of scope; sub is triggered and $v is reset
|
|
|
436 warn $v;
|
|
|
437 Exceptions : Raised if argument was not a CodeRef
|
|
|
438 Status : Stable
|
|
|
439
|
|
|
440 =cut
|
|
|
441
|
|
|
442 sub scope_guard {
|
|
|
443 my ($callback) = @_;
|
|
|
444 assert_ref($callback, 'CODE', 'callback');
|
|
|
445 return bless($callback, 'Bio::EnsEMBL::Utils::Scalar::ScopeGuard');
|
|
|
446 }
|
|
|
447
|
|
|
448 1;
|
|
|
449
|
|
|
450 #### SUPER SECRET PACKAGE. IGNORE ME
|
|
|
451 package Bio::EnsEMBL::Utils::Scalar::ScopeGuard;
|
|
|
452 sub DESTROY {
|
|
|
453 my ($self) = @_;
|
|
|
454 $self->();
|
|
|
455 return;
|
|
|
456 }
|
|
|
457
|
|
|
458 1;
|
