File Coverage

blib/lib/Venus/Role/Deferrable.pm
Criterion Covered Total %
statement 18 19 94.7
branch 2 4 50.0
condition n/a
subroutine 7 8 87.5
pod 1 2 50.0
total 28 33 84.8


line stmt bran cond sub pod time code
1             package Venus::Role::Deferrable;
2              
3 87     87   1536 use 5.018;
  87         323  
4              
5 87     87   447 use strict;
  87         221  
  87         3462  
6 87     87   413 use warnings;
  87         170  
  87         2301  
7              
8 87     87   483 use Venus::Role 'fault';
  87         164  
  87         505  
9              
10             # METHODS
11              
12             sub defer {
13 44     44 1 209 my ($self, $name, @args) = @_;
14              
15 44 50   0   97 return sub {} if !$name;
16              
17 44 50       169 my $code = $self->can($name)
18 0         0 or fault "Unable to defer $name: can't find $name in @{[ref $self]}";
19              
20 44     19   399 return sub {@_ = ($self, @args, @_); goto $code};
  19         74  
  19         157  
21             }
22              
23             # EXPORTS
24              
25             sub EXPORT {
26 90     90 0 335 ['defer']
27             }
28              
29             1;
30              
31              
32              
33             =head1 NAME
34              
35             Venus::Role::Deferrable - Deferrable Role
36              
37             =cut
38              
39             =head1 ABSTRACT
40              
41             Deferrable Role for Perl 5
42              
43             =cut
44              
45             =head1 SYNOPSIS
46              
47             package Example;
48              
49             use Venus::Class;
50              
51             with 'Venus::Role::Deferrable';
52              
53             sub test {
54             my ($self, @args) = @_;
55              
56             return $self->okay(@args);
57             }
58              
59             sub okay {
60             my ($self, @args) = @_;
61              
62             return [@args];
63             }
64              
65             package main;
66              
67             my $example = Example->new;
68              
69             # my $code = $example->defer('test');
70              
71             # sub {...}
72              
73             # $code->();
74              
75             # [...]
76              
77             =cut
78              
79             =head1 DESCRIPTION
80              
81             This package provides a mechanism for returning callbacks (i.e. closures) that
82             dispatches method calls.
83              
84             =cut
85              
86             =head1 METHODS
87              
88             This package provides the following methods:
89              
90             =cut
91              
92             =head2 defer
93              
94             defer(Str $method, Any @args) (CodeRef)
95              
96             The defer method returns the named method as a callback (i.e. closure) which
97             dispatches to the method call specified.
98              
99             I>
100              
101             =over 4
102              
103             =item defer example 1
104              
105             # given: synopsis
106              
107             package main;
108              
109             $example = Example->new;
110              
111             # bless({}, 'Example1')
112              
113             # my $result = $example->defer('test', 1..4);
114              
115             # $result->();
116              
117             # [1..4]
118              
119             =back
120              
121             =over 4
122              
123             =item defer example 2
124              
125             # given: synopsis
126              
127             package main;
128              
129             $example = Example->new;
130              
131             # bless({}, 'Example1')
132              
133             # my $result = $example->defer('test', 1..4);
134              
135             # $result->(1..4);
136              
137             # [1..4, 1..4]
138              
139             =back
140              
141             =cut
142              
143             =head1 AUTHORS
144              
145             Awncorp, C
146              
147             =cut
148              
149             =head1 LICENSE
150              
151             Copyright (C) 2000, Al Newkirk.
152              
153             This program is free software, you can redistribute it and/or modify it under
154             the terms of the Apache license version 2.0.
155              
156             =cut