|
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);
|
|
|
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 #Tags are also available for exporting
|
|
|
62 use Bio::EnsEMBL::Utils::Scalar qw(:assert); # brings in all assert methods
|
|
|
63 use Bio::EnsEMBL::Utils::Scalar qw(:check); #brings in all check methods
|
|
|
64 use Bio::EnsEMBL::Utils::Scalar qw(:array); #brings in wrap_array
|
|
|
65 use Bio::EnsEMBL::Utils::Scalar qw(:all); #import all methods
|
|
|
66
|
|
|
67 =head1 DESCRIPTION
|
|
|
68
|
|
|
69 A collection of subroutines aimed to helping Scalar based operations
|
|
|
70
|
|
|
71 =head1 METHODS
|
|
|
72
|
|
|
73 See subroutines.
|
|
|
74
|
|
|
75 =head1 MAINTAINER
|
|
|
76
|
|
|
77 $Author: ady $
|
|
|
78
|
|
|
79 =head1 VERSION
|
|
|
80
|
|
|
81 $Revision: 1.12 $
|
|
|
82
|
|
|
83 =cut
|
|
|
84
|
|
|
85 use strict;
|
|
|
86 use warnings;
|
|
|
87
|
|
|
88 use base qw(Exporter);
|
|
|
89
|
|
|
90 our %EXPORT_TAGS;
|
|
|
91 our @EXPORT_OK;
|
|
|
92
|
|
|
93 @EXPORT_OK = qw(
|
|
|
94 check_ref check_ref_can
|
|
|
95 assert_ref assert_ref_can assert_numeric assert_integer assert_boolean assert_strand assert_file_handle
|
|
|
96 wrap_array
|
|
|
97 );
|
|
|
98 %EXPORT_TAGS = (
|
|
|
99 assert => [qw(assert_ref assert_ref_can assert_integer assert_numeric assert_boolean assert_strand assert_file_handle)],
|
|
|
100 check => [qw(check_ref check_ref_can)],
|
|
|
101 array => [qw/wrap_array/],
|
|
|
102 all => [@EXPORT_OK]
|
|
|
103 );
|
|
|
104
|
|
|
105 use Bio::EnsEMBL::Utils::Exception qw(throw);
|
|
|
106 use Scalar::Util qw(blessed looks_like_number openhandle);
|
|
|
107
|
|
|
108 =head2 check_ref()
|
|
|
109
|
|
|
110 Arg [1] : The reference to check
|
|
|
111 Arg [2] : The type we expect
|
|
|
112 Description : A subroutine which checks to see if the given object/ref is
|
|
|
113 what you expect. If you give it a blessed reference then it
|
|
|
114 will perform an isa() call on the object after the defined
|
|
|
115 tests. If it is a plain reference then it will use ref().
|
|
|
116
|
|
|
117 An undefined value will return a false.
|
|
|
118 Returntype : Boolean indicating if the reference was the type we
|
|
|
119 expect
|
|
|
120 Example : my $ok = check_ref([], 'ARRAY');
|
|
|
121 Exceptions : If the expected type was not set
|
|
|
122 Status : Stable
|
|
|
123
|
|
|
124 =cut
|
|
|
125
|
|
|
126 sub check_ref {
|
|
|
127 my ($ref, $expected) = @_;
|
|
|
128 throw('No expected type given') if ! defined $expected;
|
|
|
129 if(defined $ref) {
|
|
|
130 if(blessed($ref)) {
|
|
|
131 return 1 if $ref->isa($expected);
|
|
|
132 }
|
|
|
133 else {
|
|
|
134 my $ref_ref_type = ref($ref);
|
|
|
135 return 1 if defined $ref_ref_type && $ref_ref_type eq $expected;
|
|
|
136 }
|
|
|
137 }
|
|
|
138 return 0;
|
|
|
139 }
|
|
|
140
|
|
|
141 =head2 assert_ref()
|
|
|
142
|
|
|
143 Arg [1] : The reference to check
|
|
|
144 Arg [2] : The type we expect
|
|
|
145 Arg [3] : The attribute name you are asserting; not required but allows
|
|
|
146 for more useful error messages to be generated. Defaults to
|
|
|
147 C<-Unknown->.
|
|
|
148 Description : A subroutine which checks to see if the given object/ref is
|
|
|
149 what you expect. This behaves in an identical manner as
|
|
|
150 C<check_ref()> does except this will raise exceptions when
|
|
|
151 the values do not match rather than returning a boolean
|
|
|
152 indicating the situation.
|
|
|
153
|
|
|
154 Undefs cause exception circumstances.
|
|
|
155 Returntype : Boolean; true if we managed to get to the return
|
|
|
156 Example : assert_ref([], 'ARRAY');
|
|
|
157 Exceptions : If the expected type was not set and if the given reference
|
|
|
158 was not assignable to the expected value
|
|
|
159 Status : Stable
|
|
|
160
|
|
|
161 =cut
|
|
|
162
|
|
|
163 sub assert_ref {
|
|
|
164 my ($ref, $expected, $attribute_name) = @_;
|
|
|
165 $attribute_name ||= '-Unknown-';
|
|
|
166 throw('No expected type given') if ! defined $expected;
|
|
|
167 my $class = ref($ref);
|
|
|
168 throw("The given reference for attribute $attribute_name was undef") unless defined $ref;
|
|
|
169 throw("Asking for the type of the attribute $attribute_name produced no type; check it is a reference") unless $class;
|
|
|
170 if(blessed($ref)) {
|
|
|
171 throw("${attribute_name}'s type '${class}' is not an ISA of '${expected}'") if ! $ref->isa($expected);
|
|
|
172 }
|
|
|
173 else {
|
|
|
174 throw("$attribute_name was expected to be '${expected}' but was '${class}'") if $expected ne $class;
|
|
|
175 }
|
|
|
176 return 1;
|
|
|
177 }
|
|
|
178
|
|
|
179 =head2 wrap_array()
|
|
|
180
|
|
|
181 Arg : The reference we want to wrap in an array
|
|
|
182 Description : Takes in a reference and returns either the reference if it
|
|
|
183 was already an array, the reference wrapped in an array or
|
|
|
184 an empty array (if the given value was undefined).
|
|
|
185 Returntype : Array Reference
|
|
|
186 Example : my $a = wrap_array($input);
|
|
|
187 Exceptions : None
|
|
|
188 Status : Stable
|
|
|
189
|
|
|
190 =cut
|
|
|
191
|
|
|
192 sub wrap_array {
|
|
|
193 my ($incoming_reference) = @_;
|
|
|
194 if(defined $incoming_reference) {
|
|
|
195 if(check_ref($incoming_reference, 'ARRAY')) {
|
|
|
196 return $incoming_reference;
|
|
|
197 }
|
|
|
198 else {
|
|
|
199 return [$incoming_reference];
|
|
|
200 }
|
|
|
201 }
|
|
|
202 return [];
|
|
|
203 }
|
|
|
204
|
|
|
205 =head2 check_ref_can
|
|
|
206
|
|
|
207 Arg [1] : The reference to check
|
|
|
208 Arg [2] : The method we expect to run
|
|
|
209 Description : A subroutine which checks to see if the given object/ref is
|
|
|
210 implements the given method. This is very similar to the
|
|
|
211 functionality given by C<UNIVERSAL::can()> but works
|
|
|
212 by executing C<can()> on the object meaning we consult the
|
|
|
213 object's potentially overriden version rather than Perl's
|
|
|
214 default mechanism.
|
|
|
215 Returntype : CodeRef
|
|
|
216 Example : check_ref_can($gene, 'dbID');
|
|
|
217 Exceptions : If the expected type was not set.
|
|
|
218 Status : Stable
|
|
|
219
|
|
|
220 =cut
|
|
|
221
|
|
|
222 sub check_ref_can {
|
|
|
223 my ($ref, $method) = @_;
|
|
|
224 throw('No method given') if ! defined $method;
|
|
|
225 return unless defined $ref && blessed($ref);
|
|
|
226 return $ref->can($method);
|
|
|
227 }
|
|
|
228
|
|
|
229 =head2 assert_ref_can
|
|
|
230
|
|
|
231 Arg [1] : The reference to check
|
|
|
232 Arg [2] : The method we expect to run
|
|
|
233 Arg [3] : The attribute name you are asserting; not required but allows
|
|
|
234 for more useful error messages to be generated. Defaults to
|
|
|
235 C<-Unknown->.
|
|
|
236 Description : A subroutine which checks to see if the given object/ref is
|
|
|
237 implements the given method. Will throw exceptions.
|
|
|
238 Returntype : Boolean; true if we managed to get to the return
|
|
|
239 Example : assert_ref_can($gene, 'dbID');
|
|
|
240 Exceptions : If the reference is not defined, if the object does not
|
|
|
241 implement the given method and if no method was given to check
|
|
|
242 Status : Stable
|
|
|
243
|
|
|
244 =cut
|
|
|
245
|
|
|
246 sub assert_ref_can {
|
|
|
247 my ($ref, $method, $attribute_name) = @_;
|
|
|
248 $attribute_name ||= '-Unknown-';
|
|
|
249 throw('No method given') if ! defined $method;
|
|
|
250 throw "The given reference $attribute_name is not defined" unless defined $ref;
|
|
|
251 throw "The given reference $attribute_name is not blessed" unless blessed($ref);
|
|
|
252 if(! $ref->can($method)) {
|
|
|
253 my $str_ref = ref($ref);
|
|
|
254 throw sprintf(q{The given blessed reference '%s' for attribute '%s' does not implement the method '%s'}, $str_ref, $attribute_name, $method);
|
|
|
255 }
|
|
|
256 return 1;
|
|
|
257 }
|
|
|
258
|
|
|
259 =head2 assert_numeric
|
|
|
260
|
|
|
261 Arg [1] : The Scalar to check
|
|
|
262 Arg [2] : The attribute name you are asserting; not required but allows
|
|
|
263 for more useful error messages to be generated. Defaults to
|
|
|
264 C<-Unknown->.
|
|
|
265 Description : A subroutine which checks to see if the given scalar is
|
|
|
266 number or not. If not then we raise exceptions detailing why
|
|
|
267 Returntype : Boolean; true if we had a numeric otherwise we signal failure
|
|
|
268 via exceptions
|
|
|
269 Example : assert_numeric(1, 'dbID');
|
|
|
270 Exceptions : If the Scalar is not defined, if the Scalar was blessed and
|
|
|
271 if the value was not a number
|
|
|
272 Status : Stable
|
|
|
273
|
|
|
274 =cut
|
|
|
275
|
|
|
276 sub assert_numeric {
|
|
|
277 my ($integer, $attribute_name) = @_;
|
|
|
278 $attribute_name ||= '-Unknown-';
|
|
|
279 throw "$attribute_name attribute is undefined" if ! defined $integer;
|
|
|
280 throw "The given attribute $attribute_name is blessed; cannot work with blessed values" if blessed($integer);
|
|
|
281 if(! looks_like_number($integer)) {
|
|
|
282 throw "Attribute $attribute_name was not a number";
|
|
|
283 }
|
|
|
284 return 1;
|
|
|
285 }
|
|
|
286
|
|
|
287 =head2 assert_integer
|
|
|
288
|
|
|
289 Arg [1] : The Scalar to check
|
|
|
290 Arg [2] : The attribute name you are asserting; not required but allows
|
|
|
291 for more useful error messages to be generated. Defaults to
|
|
|
292 C<-Unknown->.
|
|
|
293 Description : A subroutine which checks to see if the given scalar is
|
|
|
294 a whole integer; we delegate to L<assert_numeric> for number
|
|
|
295 checking.
|
|
|
296 Returntype : Boolean; true if we had a numeric otherwise we signal failure
|
|
|
297 via exceptions
|
|
|
298 Example : assert_integer(1, 'dbID');
|
|
|
299 Exceptions : See L<assert_numeric> and we raise exceptions if the value
|
|
|
300 was not a whole integer
|
|
|
301 Status : Stable
|
|
|
302
|
|
|
303 =cut
|
|
|
304
|
|
|
305 sub assert_integer {
|
|
|
306 my ($integer, $attribute_name) = @_;
|
|
|
307 $attribute_name ||= '-Unknown-';
|
|
|
308 assert_numeric($integer, $attribute_name);
|
|
|
309 if($integer != int($integer)) {
|
|
|
310 throw "Attribute $attribute_name was a number but not an Integer";
|
|
|
311 }
|
|
|
312 return 1;
|
|
|
313 }
|
|
|
314
|
|
|
315 =head2 assert_boolean
|
|
|
316
|
|
|
317 Arg [1] : The Scalar to check
|
|
|
318 Arg [2] : The attribute name you are asserting; not required but allows
|
|
|
319 for more useful error messages to be generated. Defaults to
|
|
|
320 C<-Unknown->.
|
|
|
321 Description : A subroutine which checks to see if the given scalar is
|
|
|
322 a boolean i.e. value is set to C<1> or C<0>
|
|
|
323 Returntype : Boolean; true if we were given a boolean otherwise we signal
|
|
|
324 failure via exceptions
|
|
|
325 Example : assert_boolean(1, 'is_circular');
|
|
|
326 Exceptions : See L<assert_integer> and we raise exceptions if the value
|
|
|
327 was not equal to the 2 valid states
|
|
|
328 Status : Stable
|
|
|
329
|
|
|
330 =cut
|
|
|
331
|
|
|
332 sub assert_boolean {
|
|
|
333 my ($boolean, $attribute_name) = @_;
|
|
|
334 $attribute_name ||= '-Unknown-';
|
|
|
335 assert_numeric($boolean, $attribute_name);
|
|
|
336 if($boolean != 0 && $boolean != 1) {
|
|
|
337 throw "Attribute $attribute_name was an invalid boolean. Expected: 1 or 0. Got: $boolean";
|
|
|
338 }
|
|
|
339 return 1;
|
|
|
340 }
|
|
|
341
|
|
|
342 =head2 assert_strand
|
|
|
343
|
|
|
344 Arg [1] : The Scalar to check
|
|
|
345 Arg [2] : The attribute name you are asserting; not required but allows
|
|
|
346 for more useful error messages to be generated. Defaults to
|
|
|
347 C<-Unknown->.
|
|
|
348 Description : A subroutine which checks to see if the given scalar is
|
|
|
349 a whole integer and if the value is set to C<1>, C<0> or C<-1>
|
|
|
350 Returntype : Boolean; true if we had a strand integer otherwise we signal
|
|
|
351 failure via exceptions
|
|
|
352 Example : assert_strand(1, 'strand');
|
|
|
353 Exceptions : See L<assert_integer> and we raise exceptions if the value
|
|
|
354 was not equal to the 3 valid states
|
|
|
355 Status : Stable
|
|
|
356
|
|
|
357 =cut
|
|
|
358
|
|
|
359 sub assert_strand {
|
|
|
360 my ($strand, $attribute_name) = @_;
|
|
|
361 $attribute_name ||= '-Unknown-';
|
|
|
362 assert_numeric($strand, $attribute_name);
|
|
|
363 if($strand != -1 && $strand != 0 && $strand ne 1) {
|
|
|
364 throw "Attribute $attribute_name was an invalid strand. Expected: 1, 0 or -1. Got: $strand";
|
|
|
365 }
|
|
|
366 return 1;
|
|
|
367 }
|
|
|
368
|
|
|
369
|
|
|
370 =head2 assert_file_handle
|
|
|
371
|
|
|
372 Arg [1] : The Scalar to check
|
|
|
373 Arg [2] : The attribute name you are asserting; not required but allows
|
|
|
374 for more useful error messages to be generated. Defaults to
|
|
|
375 C<-Unknown->.
|
|
|
376 Description : A subroutine which checks to see if the given scalar is
|
|
|
377 actually a file handle. This will handle those which are Glob
|
|
|
378 references and those which inherit from C<IO::Handle>. It will
|
|
|
379 also cope with a blessed Glob reference.
|
|
|
380 Returntype : Boolean;
|
|
|
381 Example : assert_file_handle($fh, '-FILE_HANDLE');
|
|
|
382 Exceptions : Raised if not defined, not a reference and was not a
|
|
|
383 GLOB or did not inherit from IO::Handle
|
|
|
384 Status : Stable
|
|
|
385
|
|
|
386 =cut
|
|
|
387
|
|
|
388 sub assert_file_handle {
|
|
|
389 my ($file_handle, $attribute_name) = @_;
|
|
|
390 $attribute_name ||= '-Unknown-';
|
|
|
391 throw "Attribute $attribute_name was undefined" if ! defined $file_handle;
|
|
|
392 my $ref = ref($file_handle);
|
|
|
393 throw "Attribute $attribute_name was not a reference. Got: $file_handle" if ! $ref;
|
|
|
394 if(!openhandle($file_handle)) {
|
|
|
395 if(blessed($file_handle)) {
|
|
|
396 if(! $file_handle->isa('IO::Handle')) {
|
|
|
397 throw "Attribute $attribute_name was blessed but did not inherit from IO::Handle. Ref was: $ref";
|
|
|
398 }
|
|
|
399 }
|
|
|
400 else {
|
|
|
401 throw "Attribute $attribute_name was not a file handle. Ref was: $ref";
|
|
|
402 }
|
|
|
403 }
|
|
|
404 return 1;
|
|
|
405 }
|
|
|
406
|
|
|
407 1;
|
