File Coverage

blib/lib/Net/OAuth2/Scheme/Option/Builder.pm
Criterion Covered Total %
statement 135 146 92.4
branch 46 62 74.1
condition 12 25 48.0
subroutine 24 24 100.0
pod 6 12 50.0
total 223 269 82.9


line stmt bran cond sub pod time code
1 2     2   54485 use strict;
  2         6  
  2         112  
2 2     2   297 use warnings;
  2         6  
  2         169  
3              
4             package Net::OAuth2::Scheme::Option::Builder;
5             BEGIN {
6 2     2   69 $Net::OAuth2::Scheme::Option::Builder::VERSION = '0.03';
7             }
8             # ABSTRACT: poor man's mixin/role closure builder
9              
10 2     2   1956 use Net::OAuth2::Scheme::Option::Defines qw(All_Classes);
  2         4  
  2         192  
11              
12              
13             # use machinery from Net::OAuth2::TokenType::Scheme::Defines
14             # to gather all default values and group definitions
15             sub _all_defaults {
16 3     3   8 my $class = shift;
17 2     2   13 no strict 'refs';
  2         4  
  2         146  
18 3         10 map {%{"${_}::Default"}} All_Classes($class);
  3         3  
  3         17  
19             }
20              
21             sub _all_groups {
22 4     4   10 my $class = shift;
23 2     2   10 no strict 'refs';
  2         2  
  2         454  
24 4         18 map {%{"${_}::Group"}} All_Classes($class);
  4         7  
  4         29  
25             }
26              
27             # group finder, in case we need it
28             our %find_group;
29             sub _find_group {
30 8     8   11 my $class = shift;
31 8 100       21 unless ($find_group{$class}) {
32 1         6 my %group = $class->_all_groups;
33 1         3 my %fg = ();
34 1         4 for my $g (keys %group) {
35 2         3 $fg{$_} = $g for @{$group{$g}->{keys}};
  2         11  
36             }
37 1         4 $find_group{$class} = \%fg;
38             }
39 8         32 return $find_group{$class};
40             }
41              
42             # if we need to see whether we are leaving behind
43             # any closures with links to self
44             our $Visible_Destroy = 0;
45             sub DESTROY {
46 3 50   3   160 print STDERR "Boom!\n" if $Visible_Destroy;
47             }
48              
49              
50 2     2   3733 use fields qw(value alias default pkg export);
  2         4583  
  2         16  
51              
52             # alias: name -> name2 (where named option actually lives)
53             # default: name -> default value to use if value not specified
54             # pkg: name -> [pkg, args...] to invoke if value not specified
55             # value: name -> value (value for named option or undef)
56             # export: list of exported names
57              
58             sub new {
59 3     3 0 880 my $class = shift;
60 3         11 my %opts = @_;
61 3 50       9 $class = ref($class) if ref($class);
62 3         15 my __PACKAGE__ $self = fields::new($class);
63              
64 3         4675 my %group = $class->_all_groups;
65 3         27 for my $i (values %group) {
66 6 50       27 if (defined $i->{default}) {
67 0         0 $self->{pkg}->{$_} = $i->{default}
68 0         0 for @{$i->{keys}};
69             }
70             }
71 3         11 for my $o (keys %opts) {
72 4 100       47 if (my $i = $group{$o}) {
73 2         5 my $impl = $opts{$o};
74 2 100       10 my @ispec = ref($impl) ? @{$impl} : ($impl);
  1         4  
75 2         6 $ispec[0] = "pkg_${o}_$ispec[0]";
76 2         19 $self->{pkg}->{$_} = \@ispec
77 2         4 for @{$i->{keys}};
78             }
79             else {
80 2         10 $self->{value}->{$o} = $opts{$o};
81             }
82             }
83              
84             $self->{default} =
85             $self->{value}->{defaults_all}
86             ||
87             { _all_defaults(ref($self)),
88 3   50     22 %{$self->{value}->{defaults} || {}},
89             };
90 3         22 return $self;
91             }
92              
93             # define our own croak so that there are reasonable error messages when options get set incorrectly
94             our @load = ();
95             our $Show_Uses_Stack = 1; #for now
96              
97             sub croak {
98 6     6 1 11 my __PACKAGE__ $self = shift;
99 6         8 my $msg = shift;
100 6         10 my $c = 0;
101 6         12 for my $key (@load) {
102 4   50     13 my $from = ref($self)->_find_group->{$key} || '';
103 4 50       11 if ($from) {
104 0 0       0 my $pkg_foo = $self->{pkg}->{$key} ? $self->{pkg}->{$key}->[0] : '?';
105 0         0 $from = " (group $from ($pkg_foo))";
106             }
107 4         12 ++$c;
108 4   33     14 while (defined(caller($c)) && (caller($c))[3] !~ '::uses$') { ++$c; }
  0         0  
109 4         382 while ((caller($c))[0] eq __PACKAGE__) { ++$c; }
  2         95  
110 4 50       188 if ($Show_Uses_Stack) {
111 0         0 my ($file,$line) = (caller($c))[1,2];
112 0         0 print STDERR "... option '$key'$from needed at $file, line $line'\n";
113             }
114             }
115             {
116 2     2   1247 no strict 'refs';
  2         4  
  2         2442  
  6         9  
117             # make Carp trust everyone between here and first caller to uses()
118             # which is usually going to be Scheme->new().
119 12         247 push @{(caller($_))[0] . '::CARP_NOT'}, __PACKAGE__
120 6         16 for (0..$c);
121             }
122 6         344 Carp::croak($msg);
123             }
124              
125             # actual('key')
126             # where to lookup pkg,default,value for 'key'
127             sub actual {
128 68     68 0 117 my __PACKAGE__ $self = shift;
129 68         78 my ($key) = @_;
130 68         241 while (defined(my $nkey = $self->{alias}->{$key})) {
131 14         46 $key = $nkey;
132             }
133 68         156 return $key;
134             }
135              
136             # alias('key','key2')
137             # causes options 'key' and 'key2' to become synonyms
138             sub make_alias {
139 9     9 0 222 my __PACKAGE__ $self = shift;
140 9         19 my ($okey, $okey2) = @_;
141 9         13 my ( $key, $key2) = map {$self->actual($_)} @_;
  18         48  
142              
143             # only options that have not been claimed by groups
144             # can have {alias} entries; so make sure $key is
145             # the one that is not in a group.
146 9 100       35 ( $key, $key2, $okey, $okey2)
147             = ($key2, $key, $okey2, $okey)
148             if $self->{pkg}->{$key};
149              
150             # if both $key and $key2 are in groups, we die,
151             # because otherwise, there will be ambiguity about
152             # which pkg_ routine is invoked to initialize them
153 9 100       75 Carp::croak("cannot alias group members to each other: '$okey'"
    100          
    100          
154             .($okey ne $key ? " ('$key')" : "")
155             ." <-> '$okey2'"
156             .($okey2 ne $key2 ? " ('$key2')" :""))
157             if $self->{pkg}->{$key};
158              
159             # if there is a value, make sure it lives on $key2
160 7 100       22 if (defined($self->{value}->{$key2})) {
    100          
161 4 100 66     28 $self->croak("settings of options '$key' and '$key2' conflict")
162             if (defined($self->{value}->{$key})
163             && $self->{value}->{$key} ne $self->{value}->{$key2});
164             }
165             elsif (defined($self->{value}->{$key})) {
166 1         3 $self->{value}->{$key2} = $self->{value}->{$key};
167             }
168              
169             # if there is a default value, make sure it lives on $key2
170 6 50       26 if (defined($self->{default}->{$key2})) {
    50          
171             # make conflicting defaults disappear
172 0 0 0     0 delete $self->{default}->{$key2}
173             if (defined($self->{default}->{$key})
174             && $self->{default}->{$key} ne $self->{default}->{$key2});
175             }
176             elsif (defined($self->{default}->{$key})) {
177 0         0 $self->{default}->{$key2} = $self->{default}->{$key};
178             }
179             # remove stuff that does not matter anymore
180 6         61 delete $self->{default}->{$key};
181 6         12 delete $self->{value}->{$key};
182              
183             # we can point $key to $key2 (finally)
184 6         36 $self->{alias}->{$key} = $key2;
185             }
186              
187              
188             # installed('key')
189             # value for 'key' or undef
190             sub installed {
191 2     2 0 13 my __PACKAGE__ $self = shift;
192 2         5 my ($key, $default) = @_;
193              
194 2         16 return $self->{value}->{$self->actual($key)};
195             }
196              
197              
198             # uses(key => [,default_value])
199             # value for 'key'; if not defined yet
200             # either use default_value, {default}->{key}, install package for it, or die
201             sub uses {
202 30     30 1 542 my __PACKAGE__ $self = shift;
203 30         47 my ($okey, $default) = @_;
204 30         79 my $key = $self->actual($okey);
205 30         101 local @load = ($okey, @load);
206              
207 30 100       85 unless (exists($self->{value}->{$key})) {
208 9 100 100     52 if (defined $default
    100          
209 6 100       42 || defined($default = $self->{default}->{$key})) {
210 3         26 $self->install($key, $default);
211             }
212             elsif (my ($pkg,@kvs) = @{$self->{pkg}->{$key} || []}) {
213 2 50       7 ($pkg,@kvs) = @$pkg if ref($pkg);
214 2         9 $self->$pkg(@kvs);
215 2 50       9 Carp::croak("package failed to define value: $pkg -> $key")
216             unless defined($self->{value}->{$key});
217             }
218             }
219 30         57 my $value = $self->{value}->{$key};
220 30 100       58 unless (defined($value)) {
221 4         26 my $g = ref($self)->_find_group->{$key};
222 4   33     46 $self->croak("a setting for '".($g || $key)."' is needed");
223             }
224 26         145 return $value;
225             }
226              
227             # ensure(key => $value, $msg)
228             # == uses(key => $value) and die with $msg if value is not $value
229             sub ensure {
230 4     4 1 44 my __PACKAGE__ $self = shift;
231 4         9 my ($key, $value, $msg) = @_;
232 4 100 33     17 $self->uses($key, $value) eq $value
233             or $self->croak($msg || "option '$key' must be '$value' here.");
234 3         15 return $value;
235             }
236              
237             # uses_all(qw(key1 key2 ...))
238             # == (uses('key1'), uses('key2'),...)
239             sub uses_all {
240 3     3 1 7 my __PACKAGE__ $self = shift;
241 3         7 return map {$self->uses($_)} @_;
  10         26  
242             }
243              
244             sub parameter_prefix {
245 2     2 0 16 my __PACKAGE__ $self = shift;
246 2         4 my $prefix = shift;
247 2 50 66     10 if (@_ && $_[0] eq '_default') {
248 0         0 shift;
249             # discard default parameter name if not needed
250 0 0       0 shift if @_ % 2;
251             }
252 2         5 my (%h) = @_;
253             $self->ensure("${prefix}$_",$h{$_})
254 2         14 for (keys %h);
255             }
256              
257             # install(key => $value) sets option 'key' to $value
258             sub install {
259 13     13 1 159 my __PACKAGE__ $self = shift;
260 13         20 my ($okey, $value) = @_;
261 13         37 my $key = $self->actual($okey);
262              
263 13 100       45 Carp::croak("tried to install undef?: $okey")
264             unless defined $value;
265 12 100       52 Carp::croak("multiple definitions?: $okey")
266             if defined $self->{value}->{$key};
267              
268 10         43 $self->{value}->{$key} = $value;
269             }
270              
271             # export(keys...) == uses_all(keys ...)
272             # marking all keys as being exported.
273             sub export {
274 2     2 1 35 my __PACKAGE__ $self = shift;
275 2         12 my @r = $self->uses_all(@_);
276 1         11 $self->{export}->{$_}++ for (@_);
277 1         10 return @r;
278             }
279              
280             sub all_exports {
281 2     2 0 5 my __PACKAGE__ $self = shift;
282 2         3 return keys %{$self->{export}};
  2         19  
283             }
284              
285              
286             # new( defaults => { additional defaults... } ...)
287             # if you want to keep all of the various default values set
288             # and only make minor changes
289             # new( defaults_all => { defaults ...}
290             # if you want to entirely replace all default values;
291             # in which case this function never gets called
292             # since defaults_all is already set;
293             # Kids, don't try this at home...
294              
295             1;
296              
297              
298             __END__