File Coverage

blib/lib/Venus/Try.pm
Criterion Covered Total %
statement 115 116 99.1
branch 33 36 91.6
condition 7 11 63.6
subroutine 27 27 100.0
pod 15 17 88.2
total 197 207 95.1


line stmt bran cond sub pod time code
1             package Venus::Try;
2              
3 95     95   2735 use 5.018;
  95         380  
4              
5 95     95   697 use strict;
  95         241  
  95         2577  
6 95     95   520 use warnings;
  95         228  
  95         4007  
7              
8 95     95   595 use Venus::Class 'attr', 'base';
  95         212  
  95         908  
9              
10             base 'Venus::Kind::Utility';
11              
12 95     95   744 use Scalar::Util ();
  95         244  
  95         144012  
13              
14             # ATTRIBUTES
15              
16             attr 'invocant';
17             attr 'arguments';
18             attr 'on_try';
19             attr 'on_catch';
20             attr 'on_default';
21             attr 'on_finally';
22              
23             # BUILDERS
24              
25             sub build_arg {
26 26     26 0 71 my ($self, $data) = @_;
27              
28             return {
29 26         98 on_try => $data,
30             };
31             }
32              
33             sub build_self {
34 3613     3613 0 8200 my ($self, $data) = @_;
35              
36 3613 50       11241 $self->on_catch([]) if !defined $self->on_catch;
37              
38 3613         8682 return $self;
39             }
40              
41             # METHODS
42              
43             sub any {
44 2     2 1 11 my ($self) = @_;
45              
46 2     2   10 $self->on_default(sub{(@_)});
  2         6  
47              
48 2         20 return $self;
49             }
50              
51             sub call {
52 3583     3583 1 8219 my ($self, $callback) = @_;
53              
54 3583         10126 $self->on_try($self->callback($callback));
55              
56 3583         18695 return $self;
57             }
58              
59             sub callback {
60 3626     3626 1 7796 my ($self, $callback) = @_;
61              
62 3626 100       18560 if (not(UNIVERSAL::isa($callback, 'CODE'))) {
63 3563         6225 my $method;
64 3563         10198 my $invocant = $self->invocant;
65              
66 3563 100       9835 if (defined($invocant)) {
67 3562         13715 $method = $invocant->can($callback);
68             }
69             else {
70 1         14 $method = $self->can($callback);
71             }
72              
73 3563 100       9402 if (!$method) {
74 1         14 $self->throw('error_on_callback', {
75             invocant => $invocant,
76             callback => $callback,
77             });
78             }
79              
80 3562     3520   18550 $callback = sub {goto $method};
  3520         15702  
81             }
82              
83 3625         13825 return $callback;
84             }
85              
86             sub catch {
87 30     30 1 114 my ($self, $package, $callback) = @_;
88              
89 30   100 23   226 $callback ||= sub{(@_)};
  23         68  
90              
91 30         69 push @{$self->on_catch}, [$package, $self->callback($callback)];
  30         102  
92              
93 30         151 return $self;
94             }
95              
96             sub default {
97 6     6 1 62 my ($self, $callback) = @_;
98              
99 6         34 $self->on_default($self->callback($callback));
100              
101 6         96 return $self;
102             }
103              
104             sub error {
105 386     386 1 1932 my ($self, $variable) = @_;
106              
107 386 100       1250 if ($variable) {
108 339     339   1243 $self->on_default(sub{($$variable) = @_})
109 362         2172 }
110             else {
111 24         103 $self->catch('Venus::Error');
112             }
113              
114 386         1907 return $self;
115             }
116              
117             sub execute {
118 3568     3568 1 8886 my ($self, $callback, @args) = @_;
119              
120 3349         8316 unshift @args, @{$self->arguments}
121 3568 100 100     9947 if $self->arguments && @{$self->arguments};
  3524         8671  
122              
123 3568 100       10333 unshift @args, $self->invocant
124             if defined($self->invocant);
125              
126 3568 100       13817 return wantarray ? ($callback->(@args)) : $callback->(@args);
127             }
128              
129             sub finally {
130 4     4 1 11 my ($self, $callback) = @_;
131              
132 4         12 $self->on_finally($self->callback($callback));
133              
134 4         119 return $self;
135             }
136              
137             sub maybe {
138 11     11 1 53 my ($self) = @_;
139              
140 11     1   67 $self->on_default(sub{(undef)});
  1         4  
141              
142 11         77 return $self;
143             }
144              
145             sub no_catch {
146 1     1 1 4 my ($self) = @_;
147              
148 1         6 $self->on_catch([]);
149              
150 1         13 return $self;
151             }
152              
153             sub no_default {
154 2     2 1 5 my ($self) = @_;
155              
156 2         11 $self->on_default(undef);
157              
158 2         24 return $self;
159             }
160              
161             sub no_finally {
162 1     1 1 3 my ($self) = @_;
163              
164 1         5 $self->on_finally(undef);
165              
166 1         15 return $self;
167             }
168              
169             sub no_try {
170 1     1 1 4 my ($self) = @_;
171              
172 1         10 $self->on_try(undef);
173              
174 1         13 return $self;
175             }
176              
177             sub result {
178 3564     3564 1 37255 my ($self, @args) = @_;
179              
180 3564         6483 my $dollarat = $@;
181 3564         5506 my @returned;
182              
183             # try
184 3564         5346 my $error = do {
185 3564         5651 local $@;
186 3564         6578 eval {
187 3564         8219 my $tryer = $self->on_try;
188 3564         12103 @returned = ($self->execute($tryer, @args));
189             };
190 3564         10370 $@;
191             };
192              
193             # catch
194 3564 100       10105 if ($error) {
195 372         1175 my $caught = $error;
196 372         1599 my $catchers = $self->on_catch;
197 372         1461 my $default = $self->on_default;
198              
199 372         1394 for my $catcher (@$catchers) {
200 25 50       177 if (UNIVERSAL::isa($caught, $catcher->[0])) {
201 25         168 @returned = ($catcher->[1]->($caught));
202 25         69 last;
203             }
204             }
205              
206             # catchall
207 372 100       1046 if(!@returned) {
208 347 100       1025 if ($default) {
209 344         1043 @returned = ($default->($caught))
210             }
211             }
212              
213             # uncaught
214 372 100       1180 if(!@returned) {
215 3 100       210 if (Scalar::Util::blessed($caught)) {
216 2         182 die $caught;
217             }
218             else {
219 1 50       24 if (UNIVERSAL::isa($caught, 'Venus::Error')) {
220 0         0 $caught->throw;
221             }
222             else {
223 1         7 require Venus::Error;
224 1         8 Venus::Error->throw($caught);
225             }
226             }
227             }
228             }
229              
230             # finally
231 3561 100       12079 if (my $finally = $self->on_finally) {
232 3         12 $self->execute($finally, @args);
233             }
234              
235 3561         7919 $@ = $dollarat;
236              
237 3561 100       28568 return wantarray ? (@returned) : $returned[0];
238             }
239              
240             # ERRORS
241              
242             sub error_on_callback {
243 2     2 1 10 my ($self, $data) = @_;
244              
245 2         7 my $callback = $data->{callback};
246 2         4 my $invocant = $data->{invocant};
247              
248 2 100 33     28 my $message = sprintf(
      33        
249             qq(Can't locate object method "%s" on package "%s"), ($callback,
250             $invocant ? (ref($invocant) || $invocant) : (ref($self) || $self))
251             );
252              
253 2         9 my $stash = {
254             invocant => $invocant,
255             callback => $callback,
256             };
257              
258 2         10 my $result = {
259             name => 'on.callback',
260             raise => true,
261             stash => $stash,
262             message => $message,
263             };
264              
265 2         8 return $result;
266             }
267              
268             1;
269              
270              
271              
272             =head1 NAME
273              
274             Venus::Try - Try Class
275              
276             =cut
277              
278             =head1 ABSTRACT
279              
280             Try Class for Perl 5
281              
282             =cut
283              
284             =head1 SYNOPSIS
285              
286             package main;
287              
288             use Venus::Try;
289              
290             my $try = Venus::Try->new;
291              
292             $try->call(sub {
293             my (@args) = @_;
294              
295             # try something
296              
297             return time;
298             });
299              
300             $try->catch('Example::Error', sub {
301             my ($caught) = @_;
302              
303             # caught an error (exception)
304              
305             return;
306             });
307              
308             $try->default(sub {
309             my ($caught) = @_;
310              
311             # catch the uncaught
312              
313             return;
314             });
315              
316             $try->finally(sub {
317             my (@args) = @_;
318              
319             # always run after try/catch
320              
321             return;
322             });
323              
324             my @args;
325              
326             my $result = $try->result(@args);
327              
328             =cut
329              
330             =head1 DESCRIPTION
331              
332             This package provides an object-oriented interface for performing complex
333             try/catch operations.
334              
335             =cut
336              
337             =head1 ATTRIBUTES
338              
339             This package has the following attributes:
340              
341             =cut
342              
343             =head2 invocant
344              
345             invocant(Object)
346              
347             This attribute is read-only, accepts C<(Object)> values, and is optional.
348              
349             =cut
350              
351             =head2 arguments
352              
353             arguments(ArrayRef)
354              
355             This attribute is read-only, accepts C<(ArrayRef)> values, and is optional.
356              
357             =cut
358              
359             =head2 on_try
360              
361             on_try(CodeRef)
362              
363             This attribute is read-write, accepts C<(CodeRef)> values, and is optional.
364              
365             =cut
366              
367             =head2 on_catch
368              
369             on_catch(ArrayRef[CodeRef])
370              
371             This attribute is read-write, accepts C<(ArrayRef[CodeRef])> values, is optional, and defaults to C<[]>.
372              
373             =cut
374              
375             =head2 on_default
376              
377             on_default(CodeRef)
378              
379             This attribute is read-write, accepts C<(CodeRef)> values, and is optional.
380              
381             =cut
382              
383             =head2 on_finally
384              
385             on_finally(CodeRef)
386              
387             This attribute is read-write, accepts C<(CodeRef)> values, and is optional.
388              
389             =cut
390              
391             =head1 INHERITS
392              
393             This package inherits behaviors from:
394              
395             L
396              
397             =cut
398              
399             =head1 METHODS
400              
401             This package provides the following methods:
402              
403             =cut
404              
405             =head2 any
406              
407             any() (Venus::Try)
408              
409             The any method registers a default C condition that returns whatever
410             value was encoutered on error and returns it as a result.
411              
412             I>
413              
414             =over 4
415              
416             =item any example 1
417              
418             package main;
419              
420             use Venus::Try;
421              
422             my $try = Venus::Try->new;
423              
424             $try->call(sub {
425             die 'Oops!';
426             });
427              
428             my $any = $try->any;
429              
430             # bless({ on_catch => ... }, "Venus::Try")
431              
432             =back
433              
434             =over 4
435              
436             =item any example 2
437              
438             package main;
439              
440             use Venus::Try;
441              
442             my $try = Venus::Try->new;
443              
444             $try->call(sub {
445             die $try;
446             });
447              
448             my $any = $try->any;
449              
450             # bless({ on_catch => ... }, "Venus::Try")
451              
452             =back
453              
454             =cut
455              
456             =head2 call
457              
458             call(string | coderef $method) (Venus::Try)
459              
460             The call method takes a method name or coderef, registers it as the tryable
461             routine, and returns the object. When invoked, the callback will received an
462             C if one was provided to the constructor, the default C if
463             any were provided to the constructor, and whatever arguments were provided by
464             the invocant.
465              
466              
467              
468              
469             I>
470              
471             =over 4
472              
473             =item call example 1
474              
475             package main;
476              
477             use Venus::Try;
478              
479             my $try = Venus::Try->new;
480              
481             my $call = $try->call(sub {
482             my (@args) = @_;
483              
484             return [@args];
485             });
486              
487             # bless({ on_catch => ... }, "Venus::Try")
488              
489             =back
490              
491             =cut
492              
493             =head2 callback
494              
495             callback(string | coderef $method) (coderef)
496              
497             The callback method takes a method name or coderef, and returns a coderef for
498             registration. If a coderef is provided this method is mostly a passthrough.
499              
500             I>
501              
502             =over 4
503              
504             =item callback example 1
505              
506             package main;
507              
508             use Venus::Try;
509              
510             my $try = Venus::Try->new;
511              
512             my $callback = $try->callback(sub {
513             my (@args) = @_;
514              
515             return [@args];
516             });
517              
518             # sub { ... }
519              
520             =back
521              
522             =over 4
523              
524             =item callback example 2
525              
526             package Example1;
527              
528             sub new {
529             bless {};
530             }
531              
532             sub test {
533             my (@args) = @_;
534              
535             return [@args];
536             }
537              
538             package main;
539              
540             use Venus::Try;
541              
542             my $try = Venus::Try->new(
543             invocant => Example1->new,
544             );
545              
546             my $callback = $try->callback('test');
547              
548             # sub { ... }
549              
550             =back
551              
552             =over 4
553              
554             =item callback example 3
555              
556             package main;
557              
558             use Venus::Try;
559              
560             my $try = Venus::Try->new;
561              
562             my $callback = $try->callback('missing_method');
563              
564             # Exception! (isa Venus::Try::Error) (see error_on_callback)
565              
566             =back
567              
568             =cut
569              
570             =head2 catch
571              
572             catch(string $isa, string | coderef $method) (Venus::Try)
573              
574             The catch method takes a package or ref name, and when triggered checks whether
575             the captured exception is of the type specified and if so executes the given
576             callback. If no callback is provided the exception is captured in a L
577             operation and returned as a result.
578              
579             I>
580              
581             =over 4
582              
583             =item catch example 1
584              
585             package main;
586              
587             use Venus::Try;
588              
589             my $try = Venus::Try->new;
590              
591             $try->call(sub {
592             my (@args) = @_;
593              
594             die $try;
595             });
596              
597             my $catch = $try->catch('Venus::Try', sub {
598             my (@args) = @_;
599              
600             return [@args];
601             });
602              
603             # bless({ on_catch => ... }, "Venus::Try")
604              
605             =back
606              
607             =over 4
608              
609             =item catch example 2
610              
611             package main;
612              
613             use Venus::Try;
614              
615             my $try = Venus::Try->new;
616              
617             $try->call(sub {
618             my (@args) = @_;
619              
620             $try->throw->error;
621             });
622              
623             my $catch = $try->catch('Venus::Try::Error', sub {
624              
625             return (@_);
626             });
627              
628             # bless({ on_catch => ... }, "Venus::Try")
629              
630             =back
631              
632             =over 4
633              
634             =item catch example 3
635              
636             package main;
637              
638             use Venus::Try;
639              
640             my $try = Venus::Try->new;
641              
642             $try->call(sub {
643              
644             $try->throw->error;
645             });
646              
647             my $catch = $try->catch('Venus::Try::Error');
648              
649             # bless({ on_catch => ... }, "Venus::Try")
650              
651             =back
652              
653             =cut
654              
655             =head2 default
656              
657             default(string | coderef $method) (Venus::Try)
658              
659             The default method takes a method name or coderef and is triggered if no
660             C conditions match the exception thrown.
661              
662             I>
663              
664             =over 4
665              
666             =item default example 1
667              
668             package main;
669              
670             use Venus::Try;
671              
672             my $try = Venus::Try->new;
673              
674             $try->call(sub {
675             my (@args) = @_;
676              
677             die $try;
678             });
679              
680             my $default = $try->default(sub {
681             my (@args) = @_;
682              
683             return [@args];
684             });
685              
686             # bless({ on_catch => ... }, "Venus::Try")
687              
688             =back
689              
690             =cut
691              
692             =head2 error
693              
694             error(Ref $variable) (Venus::Try)
695              
696             The error method takes a scalar reference and assigns any uncaught exceptions
697             to it during execution. If no variable is provided a L operation will
698             be registered to capture all L exceptions.
699              
700             I>
701              
702             =over 4
703              
704             =item error example 1
705              
706             package main;
707              
708             use Venus::Try;
709              
710             my $try = Venus::Try->new;
711              
712             $try->call(sub {
713             my (@args) = @_;
714              
715             die $try;
716             });
717              
718             my $error = $try->error(\my $object);
719              
720             # bless({ on_catch => ... }, "Venus::Try")
721              
722             =back
723              
724             =over 4
725              
726             =item error example 2
727              
728             package main;
729              
730             use Venus::Try;
731              
732             my $try = Venus::Try->new;
733              
734             $try->call(sub {
735             my (@args) = @_;
736              
737             $try->throw->error;
738             });
739              
740             my $error = $try->error;
741              
742             # bless({ on_catch => ... }, "Venus::Try")
743              
744             =back
745              
746             =cut
747              
748             =head2 execute
749              
750             execute(coderef $code, any @args) (any)
751              
752             The execute method takes a coderef and executes it with any given arguments.
753             When invoked, the callback will received an C if one was provided to
754             the constructor, the default C if any were provided to the
755             constructor, and whatever arguments were passed directly to this method. This
756             method can return a list of values in list-context.
757              
758             I>
759              
760             =over 4
761              
762             =item execute example 1
763              
764             package Example2;
765              
766             sub new {
767             bless {};
768             }
769              
770             package main;
771              
772             use Venus::Try;
773              
774             my $try = Venus::Try->new(
775             invocant => Example2->new,
776             arguments => [1,2,3],
777             );
778              
779             my $execute = $try->execute(sub {
780             my (@args) = @_;
781              
782             return [@args];
783             });
784              
785             # [bless({}, "Example2"), 1, 2, 3]
786              
787             =back
788              
789             =cut
790              
791             =head2 finally
792              
793             finally(string | coderef $method) (Venus::Try)
794              
795             The finally method takes a package or ref name and always executes the callback
796             after a try/catch operation. The return value is ignored. When invoked, the
797             callback will received an C if one was provided to the constructor,
798             the default C if any were provided to the constructor, and whatever
799             arguments were provided by the invocant.
800              
801             I>
802              
803             =over 4
804              
805             =item finally example 1
806              
807             package Example3;
808              
809             sub new {
810             bless {};
811             }
812              
813             package main;
814              
815             use Venus::Try;
816              
817             my $try = Venus::Try->new(
818             invocant => Example3->new,
819             arguments => [1,2,3],
820             );
821              
822             $try->call(sub {
823             my (@args) = @_;
824              
825             return $try;
826             });
827              
828             my $finally = $try->finally(sub {
829             my (@args) = @_;
830              
831             $try->{args} = [@args];
832             });
833              
834             # bless({ on_catch => ... }, "Venus::Try")
835              
836             =back
837              
838             =cut
839              
840             =head2 maybe
841              
842             maybe() (Venus::Try)
843              
844             The maybe method registers a default C condition that returns falsy,
845             i.e. an undefined value, if an exception is encountered.
846              
847             I>
848              
849             =over 4
850              
851             =item maybe example 1
852              
853             package main;
854              
855             use Venus::Try;
856              
857             my $try = Venus::Try->new;
858              
859             $try->call(sub {
860             my (@args) = @_;
861              
862             die $try;
863             });
864              
865             my $maybe = $try->maybe;
866              
867             # bless({ on_catch => ... }, "Venus::Try")
868              
869             =back
870              
871             =cut
872              
873             =head2 no_catch
874              
875             no_catch() (Venus::Try)
876              
877             The no_catch method removes any configured catch conditions and returns the
878             object.
879              
880             I>
881              
882             =over 4
883              
884             =item no_catch example 1
885              
886             package main;
887              
888             use Venus::Try;
889              
890             my $try = Venus::Try->new;
891              
892             $try->call(sub {
893             my (@args) = @_;
894              
895             die $try;
896             });
897              
898             $try->catch('Venus::Try', sub {
899             my (@args) = @_;
900              
901             return [@args];
902             });
903              
904              
905             my $no_catch = $try->no_catch;
906              
907             # bless({ on_catch => ... }, "Venus::Try")
908              
909             =back
910              
911             =cut
912              
913             =head2 no_default
914              
915             no_default() (Venus::Try)
916              
917             The no_default method removes any configured default condition and returns the
918             object.
919              
920             I>
921              
922             =over 4
923              
924             =item no_default example 1
925              
926             package main;
927              
928             use Venus::Try;
929              
930             my $try = Venus::Try->new;
931              
932             $try->call(sub {
933             my (@args) = @_;
934              
935             die $try;
936             });
937              
938             my $default = $try->default(sub {
939             my (@args) = @_;
940              
941             return [@args];
942             });
943              
944             my $no_default = $try->no_default;
945              
946             # bless({ on_catch => ... }, "Venus::Try")
947              
948             =back
949              
950             =cut
951              
952             =head2 no_finally
953              
954             no_finally() (Venus::Try)
955              
956             The no_finally method removes any configured finally condition and returns the
957             object.
958              
959             I>
960              
961             =over 4
962              
963             =item no_finally example 1
964              
965             package Example4;
966              
967             sub new {
968             bless {};
969             }
970              
971             package main;
972              
973             use Venus::Try;
974              
975             my $try = Venus::Try->new(
976             invocant => Example4->new,
977             arguments => [1,2,3],
978             );
979              
980             $try->call(sub {
981             my (@args) = @_;
982              
983             return $try;
984             });
985              
986             $try->finally(sub {
987             my (@args) = @_;
988              
989             $try->{args} = [@args];
990             });
991              
992             my $no_finally = $try->no_finally;
993              
994             # bless({ on_catch => ... }, "Venus::Try")
995              
996             =back
997              
998             =cut
999              
1000             =head2 no_try
1001              
1002             no_try() (Venus::Try)
1003              
1004             The no_try method removes any configured C operation and returns the
1005             object.
1006              
1007             I>
1008              
1009             =over 4
1010              
1011             =item no_try example 1
1012              
1013             package main;
1014              
1015             use Venus::Try;
1016              
1017             my $try = Venus::Try->new;
1018              
1019             $try->call(sub {
1020             my (@args) = @_;
1021              
1022             return [@args];
1023             });
1024              
1025             my $no_try = $try->no_try;
1026              
1027             # bless({ on_catch => ... }, "Venus::Try")
1028              
1029             =back
1030              
1031             =cut
1032              
1033             =head2 result
1034              
1035             result(any @args) (any)
1036              
1037             The result method executes the try/catch/default/finally logic and returns
1038             either 1) the return value from the successfully tried operation 2) the return
1039             value from the successfully matched catch condition if an exception was thrown
1040             3) the return value from the default catch condition if an exception was thrown
1041             and no catch condition matched. When invoked, the C and C
1042             callbacks will received an C if one was provided to the constructor,
1043             the default C if any were provided to the constructor, and whatever
1044             arguments were passed directly to this method. This method can return a list of
1045             values in list-context.
1046              
1047             I>
1048              
1049             =over 4
1050              
1051             =item result example 1
1052              
1053             package main;
1054              
1055             use Venus::Try;
1056              
1057             my $try = Venus::Try->new;
1058              
1059             $try->call(sub {
1060             my (@args) = @_;
1061              
1062             return [@args];
1063             });
1064              
1065             my $result = $try->result;
1066              
1067             # []
1068              
1069             =back
1070              
1071             =over 4
1072              
1073             =item result example 2
1074              
1075             package main;
1076              
1077             use Venus::Try;
1078              
1079             my $try = Venus::Try->new;
1080              
1081             $try->call(sub {
1082             my (@args) = @_;
1083              
1084             return [@args];
1085             });
1086              
1087             my $result = $try->result(1..5);
1088              
1089             # [1..5]
1090              
1091             =back
1092              
1093             =over 4
1094              
1095             =item result example 3
1096              
1097             package main;
1098              
1099             use Venus::Try;
1100              
1101             my $try = Venus::Try->new;
1102              
1103             $try->call(sub {die});
1104              
1105             my $result = $try->result;
1106              
1107             # Exception! Venus::Error
1108              
1109             =back
1110              
1111             =cut
1112              
1113             =head1 ERRORS
1114              
1115             This package may raise the following errors:
1116              
1117             =cut
1118              
1119             =over 4
1120              
1121             =item error: C
1122              
1123             This package may raise an error_on_callback exception.
1124              
1125             B
1126              
1127             # given: synopsis;
1128              
1129             my $input = {
1130             invocant => 'Example',
1131             callback => 'execute',
1132             };
1133              
1134             my $error = $try->throw('error_on_callback', $input)->catch('error');
1135              
1136             # my $name = $error->name;
1137              
1138             # "on_callback"
1139              
1140             # my $message = $error->render;
1141              
1142             # "Can't locate object method \"execute\" on package \"Example\""
1143              
1144             =back
1145              
1146             =head1 AUTHORS
1147              
1148             Awncorp, C
1149              
1150             =cut
1151              
1152             =head1 LICENSE
1153              
1154             Copyright (C) 2000, Awncorp, C.
1155              
1156             This program is free software, you can redistribute it and/or modify it under
1157             the terms of the Apache license version 2.0.
1158              
1159             =cut