File Coverage

blib/lib/Class/ReturnValue.pm

Criterion	Covered	Total	%
statement			n/a
branch			n/a
condition			n/a
subroutine			n/a
pod			n/a
total			n/a

line	stmt	bran	cond	sub	pod	time	code
1							use warnings;
2							use strict;
3
4							package Class::ReturnValue;
5
6							# {{{ POD Overview
7
8							=head1 NAME
9
10							Class::ReturnValue - A return-value object that lets you treat it
11							as as a boolean, array or object
12
13							=head1 DESCRIPTION
14
15							Class::ReturnValue is a "clever" return value object that can allow
16							code calling your routine to expect:
17							a boolean value (did it fail)
18							or a list (what are the return values)
19
20							=head1 EXAMPLE
21
22							sub demo {
23							my $value = shift;
24							my $ret = Class::ReturnValue->new();
25							$ret->as_array('0', 'No results found');
26
27							unless($value) {
28							$ret->as_error(errno => '1',
29							message => "You didn't supply a parameter.",
30							do_backtrace => 1);
31							}
32
33							return($ret->return_value);
34							}
35
36							if (demo('foo')){
37							print "the routine succeeded with one parameter";
38							}
39							if (demo()) {
40							print "The routine succeeded with 0 paramters. shouldn't happen";
41							} else {
42							print "The routine failed with 0 parameters (as it should).";
43							}
44
45
46							my $return = demo();
47							if ($return) {
48							print "The routine succeeded with 0 paramters. shouldn't happen";
49							} else {
50							print "The routine failed with 0 parameters (as it should). ".
51							"Stack trace:\n".
52							$return->backtrace;
53							}
54
55							my @return3 = demo('foo');
56							print "The routine got ".join(',',@return3).
57							"when asking for demo's results as an array";
58
59
60							my $return2 = demo('foo');
61
62							unless ($return2) {
63							print "The routine failed with a parameter. shouldn't happen.".
64							"Stack trace:\n".
65							$return2->backtrace;
66							}
67
68							my @return2_array = @{$return2}; # TODO: does this work
69							my @return2_array2 = $return2->as_array;
70
71
72
73							=for testing
74							use Class::ReturnValue;
75							use Test::More;
76
77							=cut
78
79							# }}}
80
81							use Exporter;
82
83							use vars qw/$VERSION @EXPORT @ISA/;
84
85							@ISA = qw/Exporter/;
86							@EXPORT = qw /&return_value/;
87							use Carp;
88							use Devel::StackTrace;
89							use Data::Dumper;
90
91
92							$VERSION = '0.53';
93
94
95							use overload 'bool' => \&error_condition;
96							use overload '""' => \&error_condition;
97							use overload 'eq' => \&my_eq;
98							use overload '@{}' => \&as_array;
99							use overload 'fallback' => \&as_array;
100
101
102							=head1 METHODS
103
104							=item new
105
106							Instantiate a new Class::ReturnValue object
107
108							=cut
109
110							sub new {
111							my $self = {};
112							bless($self);
113							return($self);
114							}
115
116							sub my_eq {
117							my $self = shift;
118							if (wantarray()) {
119							return($self->as_array);
120							}
121							else {
122							return($self);
123							}
124							}
125
126							=item as_array
127
128							Return the 'as_array' attribute of this object as an array.
129
130							=begin testing
131
132							sub foo {
133							my $r = Class::ReturnValue->new();
134							$r->as_array('one', 'two', 'three');
135							return $r->return_value();
136
137
138
139							}
140
141							my @array;
142							ok(@array = foo());
143							is($array[0] , 'one','dereferencing to an array is ok');
144							is($array[1] , 'two','dereferencing to an array is ok');
145							is($array[2] , 'three','dereferencing to an array is ok');
146							is($array[3] , undef ,'dereferencing to an array is ok');
147
148							ok(my $ref = foo());
149							ok(my @array2 = $ref->as_array());
150							is($array2[0] , 'one','dereferencing to an arrayref is ok');
151
152							is($array2[1] , 'two','dereferencing to an arrayref is ok');
153							is($array2[2] , 'three','dereferencing to an arrayref is ok');
154							is($array2[3] , undef ,'dereferencing to an arrayref is ok');
155							ok(foo(),"Foo returns true in a boolean context");
156
157							my ($a, $b, $c) = foo();
158							is ($a , 'one', "first element is 1");
159							is ($b, 'two' , "Second element is two");
160							is ($c , 'three', "Third element is three");
161
162							my ($a2, $b2, $c2) = foo();
163							is ($a2 , 'one', "first element is 1");
164							is ($b2, 'two' , "Second element is two");
165							is ($c2 , 'three', "Third element is three");
166
167							=end testing
168
169							=cut
170
171
172							=item as_array [ARRAY]
173
174							If $self is called in an array context, returns the array specified in ARRAY
175
176							=begin testing
177
178							sub bing {
179							my $ret = Class::ReturnValue->new();
180							return $ret->return_value;
181							return("Dead");
182							}
183
184							ok(bing());
185							ok(bing() ne 'Dead');
186
187							=end testing
188
189							=cut
190
191							sub as_array {
192
193							my $self = shift;
194							if (@_) {
195							@{$self->{'as_array'}} = (@_);
196							}
197							return(@{$self->{'as_array'}});
198							}
199
200
201							=item as_error HASH
202
203							Turns this return-value object into an error return object. TAkes three parameters:
204
205							message
206							do_backtrace
207							errno
208
209							'message' is a human readable error message explaining what's going on
210
211							'do_backtrace' is a boolean. If it's true, a carp-style backtrace will be
212							stored in $self->{'backtrace'}. It defaults to true
213
214							errno and message default to undef. errno _must_ be specified.
215							It's a numeric error number. Any true integer value will cause the
216							object to evaluate to false in a scalar context. At first, this may look a
217							bit counterintuitive, but it means that you can have error codes and still
218							allow simple use of your functions in a style like this:
219
220
221							if ($obj->do_something) {
222							print "Yay! it worked";
223							} else {
224							print "Sorry. there's been an error.";
225							}
226
227
228							as well as more complex use like this:
229
230							my $retval = $obj->do_something;
231
232							if ($retval) {
233							print "Yay. we did something\n";
234							my ($foo, $bar, $baz) = @{$retval};
235							my $human_readable_return = $retval;
236							} else {
237							if ($retval->errno == 20) {
238							die "Failed with error 20 (Not enough monkeys).";
239							} else {
240							die $retval->backtrace; # Die and print out a backtrace
241							}
242							}
243
244
245							=cut
246
247							sub as_error {
248							my $self = shift;
249							my %args = ( errno => undef,
250							message => undef,
251							do_backtrace => 1,
252							@_);
253
254							unless($args{'errno'}) {
255							carp "$self -> as_error called without an 'errno' parameter";
256							return (undef);
257							}
258
259							$self->{'errno'} = $args{'errno'};
260							$self->{'error_message'} = $args{'message'};
261							if ($args{'do_backtrace'}) {
262							# Use carp's internal backtrace methods, rather than duplicating them ourselves
263							my $trace = Devel::StackTrace->new(ignore_package => 'Class::ReturnValue');
264
265							$self->{'backtrace'} = $trace->as_string; # like carp
266							}
267
268							return(1);
269							}
270
271
272							=item errno
273
274							Returns the errno if there's been an error. Otherwise, return undef
275
276							=cut
277
278							sub errno {
279							my $self = shift;
280							if ($self->{'errno'}) {
281							return ($self->{'errno'});
282							}
283							else {
284							return(undef);
285							}
286							}
287
288
289							=item error_message
290
291							If there's been an error return the error message.
292
293							=cut
294
295							sub error_message {
296							my $self = shift;
297							if ($self->{'error_message'}) {
298							return($self->{'error_message'});
299							}
300							else {
301							return(undef);
302							}
303							}
304
305
306							=item backtrace
307
308							If there's been an error and we asked for a backtrace, return the backtrace.
309							Otherwise, return undef.
310
311							=cut
312
313							sub backtrace {
314							my $self = shift;
315							if ($self->{'backtrace'}) {
316							return($self->{'backtrace'});
317							}
318							else {
319							return(undef);
320							}
321							}
322
323							=begin testing
324
325
326							sub bar {
327							my $retval3 = Class::ReturnValue->new();
328							$retval3->as_array(1,'asq');
329							return_value $retval3;
330							}
331							ok(bar());
332							sub baz {
333							my $retval = Class::ReturnValue->new();
334							$retval->as_error(errno=> 1);
335							return_value $retval;
336							}
337
338							if(baz()){
339							ok (0,"returning an error evals as true");
340							} else {
341							ok (1,"returning an error evals as false");
342
343							}
344
345							ok(my $retval = Class::ReturnValue->new());
346							ok($retval->as_error( errno => 20,
347							message => "You've been eited",
348							do_backtrace => 1));
349							ok($retval->backtrace ne undef);
350							is($retval->error_message,"You've been eited");
351
352
353							ok(my $retval2 = Class::ReturnValue->new());
354							ok($retval2->as_error( errno => 1,
355							message => "You've been eited",
356							do_backtrace => 0 ));
357							ok($retval2->backtrace eq undef);
358							is($retval2->errno, 1, "Got the errno");
359							isnt($retval2->errno,20, "Errno knows that 20 != 1");
360
361							=end testing
362
363							=cut
364
365							=item error_condition
366
367							If there's been an error, return undef. Otherwise return 1
368
369							=cut
370
371							sub error_condition {
372							my $self = shift;
373							if ($self->{'errno'}) {
374							return (undef);
375							}
376							elsif (wantarray()) {
377							return(@{$self->{'as_array'}});
378							}
379							else {
380							return(1);
381							}
382							}
383
384							sub return_value {
385							my $self = shift;
386							if (wantarray) {
387							return ($self->as_array);
388							}
389							else {
390							return ($self);
391							}
392							}
393
394
395							=head1 AUTHOR
396
397							Jesse Vincent <jesse@bestpractical.com>
398
399							=head1 BUGS
400
401							This module has, as yet, not been used in production code. I thing
402							it should work, but have never benchmarked it. I have not yet used
403							it extensively, though I do plan to in the not-too-distant future.
404							If you have questions or comments, please write me.
405
406							If you need to report a bug, please send mail to
407							<bug-class-returnvalue@rt.cpan.org> or report your error on the web
408							at http://rt.cpan.org/
409
410							=head1 COPYRIGHT
411
412							Copyright (c) 2002,2003,2005 Jesse Vincent <jesse@bestpractical.com>
413							You may use, modify, fold, spindle or mutilate this module under
414							the same terms as perl itself.
415
416							=head1 SEE ALSO
417
418							Class::ReturnValue isn't an exception handler. If it doesn't
419							do what you want, you might want look at one of the exception handlers
420							below
421
422							Error, Exception, Exceptions, Exceptions::Class
423
424							You might also want to look at Contextual::Return, another implementation
425							of the same concept as this module.
426
427							=cut
428
429							1;
430