line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Method::Declarative; |
2
|
2
|
|
|
2
|
|
61429
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
73
|
|
3
|
2
|
|
|
2
|
|
10
|
use warnings; |
|
2
|
|
|
|
|
8
|
|
|
2
|
|
|
|
|
53
|
|
4
|
2
|
|
|
2
|
|
11
|
use Carp; |
|
2
|
|
|
|
|
8
|
|
|
2
|
|
|
|
|
4704
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
our $VERSION=0.03; |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
=pod |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=head1 NAME |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
Method::Declarative - Create methods with declarative syntax |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
=head1 SYNOPSIS |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
use Method::Declarative |
17
|
|
|
|
|
|
|
( |
18
|
|
|
|
|
|
|
'--defaults' => |
19
|
|
|
|
|
|
|
{ |
20
|
|
|
|
|
|
|
precheck => |
21
|
|
|
|
|
|
|
[ |
22
|
|
|
|
|
|
|
[ qw(precheck1 arg1 arg2) ], |
23
|
|
|
|
|
|
|
# ... |
24
|
|
|
|
|
|
|
], |
25
|
|
|
|
|
|
|
postcheck => |
26
|
|
|
|
|
|
|
[ |
27
|
|
|
|
|
|
|
[ qw(postcheck1 arg3 arg4) ], |
28
|
|
|
|
|
|
|
# ... |
29
|
|
|
|
|
|
|
], |
30
|
|
|
|
|
|
|
init => |
31
|
|
|
|
|
|
|
[ |
32
|
|
|
|
|
|
|
[ 'initcheck1' ], |
33
|
|
|
|
|
|
|
# ... |
34
|
|
|
|
|
|
|
], |
35
|
|
|
|
|
|
|
end => |
36
|
|
|
|
|
|
|
[ |
37
|
|
|
|
|
|
|
[ 'endcheck1' ], |
38
|
|
|
|
|
|
|
# ... |
39
|
|
|
|
|
|
|
], |
40
|
|
|
|
|
|
|
once => |
41
|
|
|
|
|
|
|
[ |
42
|
|
|
|
|
|
|
[ 'oncecheck1' ], |
43
|
|
|
|
|
|
|
] , |
44
|
|
|
|
|
|
|
package => '__CALLER__::internal', |
45
|
|
|
|
|
|
|
}, |
46
|
|
|
|
|
|
|
method1 => |
47
|
|
|
|
|
|
|
{ |
48
|
|
|
|
|
|
|
ignoredefaults => [ qw(precheck end once) ], |
49
|
|
|
|
|
|
|
code => '__method1', |
50
|
|
|
|
|
|
|
}, |
51
|
|
|
|
|
|
|
) ; |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
=head1 DESCRIPTION |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
The B module creates methods in a using class' |
57
|
|
|
|
|
|
|
namespace. The methods are created using a declarative syntax and |
58
|
|
|
|
|
|
|
building blocks provided by the using class. This class does B |
59
|
|
|
|
|
|
|
create the objects themselves. |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
The using class invokes B, passing it list of |
62
|
|
|
|
|
|
|
key-value pairs, where each key is the name of a method to declare (or |
63
|
|
|
|
|
|
|
the special key '--default') and a hash reference of construction |
64
|
|
|
|
|
|
|
directives. The valid keys in the construction hash refs are: |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=over 4 |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=item code |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
The value corresponding to C key is a method name or code reference |
71
|
|
|
|
|
|
|
to be executed as the method. It is called like this: |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
$obj->$codeval(@args) |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
where C<$obj> is the object or class name being used, C<$codeval> is the |
76
|
|
|
|
|
|
|
coresponding reference or method name, and C<@args> are the current |
77
|
|
|
|
|
|
|
arguments for the invocation. If C<$codeval> is a method name, it |
78
|
|
|
|
|
|
|
needs to be reachable from C<$obj>. |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
A C key in a method declaration will override any C key |
81
|
|
|
|
|
|
|
set in the C<--defaults> section. |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=item end |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
The value corresponding to the C key is an array reference, where |
86
|
|
|
|
|
|
|
each entry of the referenced array is another array ref. Each of the |
87
|
|
|
|
|
|
|
internally referenced arrays starts with a code reference or method name. |
88
|
|
|
|
|
|
|
The remaining elements of the array are used as arguments. |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
Each method declared by the arrays referenced from C are called on |
91
|
|
|
|
|
|
|
the class where the declared method resides in an B block when |
92
|
|
|
|
|
|
|
B unloads. |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
Each method is called like this: |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
$pkg->$codeval($name[, @args]); |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
where C<$pkg> is the package or class name for the method, C<$name> is |
99
|
|
|
|
|
|
|
the method name, and C<@args> is the optional arguments that can be listed |
100
|
|
|
|
|
|
|
in each referenced list. |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
C blocks are run in the reverse order of method declaration (for |
103
|
|
|
|
|
|
|
example, if I is declared before I, I's C |
104
|
|
|
|
|
|
|
declaration will be run before I's), and for each method they |
105
|
|
|
|
|
|
|
are run in the order in which they are declared. |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
Note that this is B an object destructor, and no objects of a |
108
|
|
|
|
|
|
|
particular class may still exist when these methods are run. |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
=item ignoredefaults |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
The value corresponding to the C key is an array reference |
113
|
|
|
|
|
|
|
pointing to a list of strings. Each string must corespond to a valid |
114
|
|
|
|
|
|
|
key, and indicates that any in-force defaults for that key are to be |
115
|
|
|
|
|
|
|
ignored. See the section on the special C<--defaults> method for details. |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
=item init |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
The value corresponding to the C key is identical in structure |
120
|
|
|
|
|
|
|
to that corresponding to the C key. The only difference is that the |
121
|
|
|
|
|
|
|
declared methods/code refs are executed as soon as the method is available, |
122
|
|
|
|
|
|
|
rather than during an B block. |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=item once |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
The value corresponding to the C key is identical in structure |
127
|
|
|
|
|
|
|
to that corresponding to the C key. The values are used when the |
128
|
|
|
|
|
|
|
method is invoked, however. |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
If the method is invoked on an object based on a hash ref, or on the |
131
|
|
|
|
|
|
|
class itself, and it has not been invoked before on that object or hash |
132
|
|
|
|
|
|
|
ref, the methods and code refs declared by this key are executed one at |
133
|
|
|
|
|
|
|
a time, like this: |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
$obj->$codeval($name, $isscalar, $argsref[, @args ]); |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
where C<$obj> is the object or class on which the method is being invoked, |
138
|
|
|
|
|
|
|
C<$codeval> is the method name or code reference supplied, C<$name> is |
139
|
|
|
|
|
|
|
the name of the method, C<$isscalar> is a flag to specify if the declared |
140
|
|
|
|
|
|
|
method itself is being executed in a scalar context, C<$argsref> is a |
141
|
|
|
|
|
|
|
reference to the method arguments (C<\@_>, in other words), and C<@args> |
142
|
|
|
|
|
|
|
are any optional arguments in the declaration. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
The return value of each method or code reference call is used as the new |
145
|
|
|
|
|
|
|
arguments array for successive iterations or the declared method itself |
146
|
|
|
|
|
|
|
(including the object or class name). Yes, that means that these functions |
147
|
|
|
|
|
|
|
can change the the object or class out from under successive operations. |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
Any method or code ref returning an empty list will cause further processing |
150
|
|
|
|
|
|
|
for the method to abort, and an empty list or undefined value (as appropriate |
151
|
|
|
|
|
|
|
for the context) will be returned as the declared method's return value. |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
=item package |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
The value coresponding to the C key is a string that determines |
156
|
|
|
|
|
|
|
where the declared method is created (which is the caller's package by |
157
|
|
|
|
|
|
|
default, unless modified with a C<--defaults> section). The string |
158
|
|
|
|
|
|
|
'__CALLER__' can be used to specify the caller's namespace, so constructions |
159
|
|
|
|
|
|
|
like the one in the synopsis can be used to create methods in a namespace |
160
|
|
|
|
|
|
|
based on the calling package namespace. |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
=item postcheck |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
The value coresponding to the C key is identical in structure |
165
|
|
|
|
|
|
|
to that coresponding to the C key. The C operations are |
166
|
|
|
|
|
|
|
run like this: |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
$obj->$codeval($name, $isscalar, $vref[, @args ]); |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
where C<$obj> is the underlying object or class, C<$codeval> is the |
171
|
|
|
|
|
|
|
method or code ref from the list, C<$name> is the name of the declared |
172
|
|
|
|
|
|
|
method, C<$isscalar> is the flag specifying if the declared method was |
173
|
|
|
|
|
|
|
called in a scalar context, C<$vref> is an array reference of the |
174
|
|
|
|
|
|
|
currently to-be-returned values, and C<@args> is the optional arguments |
175
|
|
|
|
|
|
|
from the list. |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
Each method or code reference is expected to return the value(s) it |
178
|
|
|
|
|
|
|
wishes to have returned from the method. Returning a null list does NOT |
179
|
|
|
|
|
|
|
stop processing of later C declarations. |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=item precheck |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
The C phase operates similarly to the C phase, except |
184
|
|
|
|
|
|
|
that it's triggered on all method calls (even if the underlying object is |
185
|
|
|
|
|
|
|
not a hash reference or a class name). |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
=back |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
Any illegal or unrecognized key will cause a warning, and processing of |
190
|
|
|
|
|
|
|
the affected hashref will stop. This means a C<--defaults> section will |
191
|
|
|
|
|
|
|
be ineffective, or a declared method won't be created. |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
=head2 The --defaults section |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
The values in a hashref tagged with the key C<--defaults> (called "The |
196
|
|
|
|
|
|
|
--defaults section") provide defaults for each of the keys. For the keys |
197
|
|
|
|
|
|
|
that take array references pointing to lists of array refs, the values are |
198
|
|
|
|
|
|
|
prepended. For example, if the following declaration were encountered: |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
use Method::Declarative |
201
|
|
|
|
|
|
|
( |
202
|
|
|
|
|
|
|
'--defaults' => |
203
|
|
|
|
|
|
|
{ |
204
|
|
|
|
|
|
|
package => 'Foo', |
205
|
|
|
|
|
|
|
precheck => [ [ '__validate' ] ], |
206
|
|
|
|
|
|
|
}, |
207
|
|
|
|
|
|
|
new => |
208
|
|
|
|
|
|
|
{ |
209
|
|
|
|
|
|
|
ignoredefaults => [ 'precheck' ], |
210
|
|
|
|
|
|
|
code => sub { return bless {}, (ref $_[0]||$_[0]); }, |
211
|
|
|
|
|
|
|
}, |
212
|
|
|
|
|
|
|
method1 => |
213
|
|
|
|
|
|
|
{ |
214
|
|
|
|
|
|
|
precheck => [ [ '__firstcanfoo', 'shortstop' ] ], |
215
|
|
|
|
|
|
|
code => '__method1_guts', |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
) ; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
then the methods new() and method1() would be created in the package |
220
|
|
|
|
|
|
|
B. The following code fragment: |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
my $res = Foo->new()->method1($arg); |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
would actually be expanded like this: |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
my $obj = Foo->new(); # Returns a blessed hashref |
227
|
|
|
|
|
|
|
my @aref = $obj->__validate('method1', 1, [ $obj, $arg ]); |
228
|
|
|
|
|
|
|
@aref = $aref[0]->__firstcanfoo('method1', 1, \@aref, 'shortstop'); |
229
|
|
|
|
|
|
|
my $res = $aref[0]->__method1_guts(@aref[1..$#aref]); |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=head1 MOTIVATION |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
This module was born out of my increasing feeling of "there just |
234
|
|
|
|
|
|
|
I to be a better way" while I was grinding out yet another |
235
|
|
|
|
|
|
|
`leven-teen hundred little methods that differed just enough that I |
236
|
|
|
|
|
|
|
couldn't conveniently write a universal template for all of them, but |
237
|
|
|
|
|
|
|
that were similar enough that I saw a huge amount of duplicated code. |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
Take, for example a subclass of B that's responsible |
240
|
|
|
|
|
|
|
for the presentation of a moderately complex web app with three sections - |
241
|
|
|
|
|
|
|
a general section, a members's only section, and an administration section. |
242
|
|
|
|
|
|
|
The methods that present the general section only need to load the |
243
|
|
|
|
|
|
|
appropriate templates (and possibly validate some form data or update |
244
|
|
|
|
|
|
|
a database), while the methods that present the member's only and |
245
|
|
|
|
|
|
|
admin sections need to validate credentials against a database first, |
246
|
|
|
|
|
|
|
and the methods for the administrative section also need to check |
247
|
|
|
|
|
|
|
the admin user against a capabilities table. Add in some basic |
248
|
|
|
|
|
|
|
sanity checking (making sure the object methods aren't called as class |
249
|
|
|
|
|
|
|
methods, check for a database connection, etc.), and real soon you |
250
|
|
|
|
|
|
|
have a whole hoard of methods that pretty much look alike except for |
251
|
|
|
|
|
|
|
about a half dozen lines each. |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
With B, you can stick much of the pre- and post- |
254
|
|
|
|
|
|
|
processing into the '--defaults' section, and forget about it. |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
=head1 EXAMPLE |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
Following the B section above, for the general section of the |
259
|
|
|
|
|
|
|
site, we may need to do something like this: |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
BEGIN { our ($dbuser,$dbpasswd) = qw(AUserName APassword); } |
262
|
|
|
|
|
|
|
use Method::Declarative |
263
|
|
|
|
|
|
|
( |
264
|
|
|
|
|
|
|
'--defaults' => |
265
|
|
|
|
|
|
|
{ |
266
|
|
|
|
|
|
|
precheck => |
267
|
|
|
|
|
|
|
[ |
268
|
|
|
|
|
|
|
[ '__load_rm_template' ], |
269
|
|
|
|
|
|
|
[ '__populate_template' ], |
270
|
|
|
|
|
|
|
], |
271
|
|
|
|
|
|
|
code => 'output', |
272
|
|
|
|
|
|
|
}, |
273
|
|
|
|
|
|
|
main => { }, |
274
|
|
|
|
|
|
|
home => { }, |
275
|
|
|
|
|
|
|
aboutus => { }, |
276
|
|
|
|
|
|
|
faq => |
277
|
|
|
|
|
|
|
{ |
278
|
|
|
|
|
|
|
ignoredefaults => [ 'precheck' ], |
279
|
|
|
|
|
|
|
precheck => |
280
|
|
|
|
|
|
|
[ |
281
|
|
|
|
|
|
|
[ '__connect_to_database', $dbuser, $dbpasswd ], |
282
|
|
|
|
|
|
|
[ '__load_rm_template' ], |
283
|
|
|
|
|
|
|
[ '__load_faq' ], |
284
|
|
|
|
|
|
|
[ '__populate_template' ], |
285
|
|
|
|
|
|
|
], |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
) ; |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
In this particular example, you could have the C<__load_rm_template> load |
290
|
|
|
|
|
|
|
an B object and return it, , with the template to be |
291
|
|
|
|
|
|
|
loaded determined from the run mode, have C<__populate_template> fill out |
292
|
|
|
|
|
|
|
common run mode-dependent parameters in the template (and return the |
293
|
|
|
|
|
|
|
template as the new argument array), and have C<__connect_to_database> |
294
|
|
|
|
|
|
|
and C<__load_faq> do the obvious things. |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
With that, the run mode methods main(), home(), and aboutus() become |
297
|
|
|
|
|
|
|
trivial, and faq() isn't that much more complicated. When the home() |
298
|
|
|
|
|
|
|
method is invoked, it results in this series of calls: |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
# This returns ($obj, $tmpl) |
301
|
|
|
|
|
|
|
$obj->__load_rm_template('main', 1, [ $obj ]); |
302
|
|
|
|
|
|
|
# This returns ($tmpl) |
303
|
|
|
|
|
|
|
$obj->__populate_template('main', 1, [ $obj, $tmpl ]); |
304
|
|
|
|
|
|
|
# This returns the HTML |
305
|
|
|
|
|
|
|
$tmpl->output; |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
Adding authentication checking wouldn't be that much more complex: |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
BEGIN { our ($dbuser,$dbpasswd) = qw(AUserName APassword); } |
310
|
|
|
|
|
|
|
use Method::Declarative |
311
|
|
|
|
|
|
|
( |
312
|
|
|
|
|
|
|
'--defaults' => |
313
|
|
|
|
|
|
|
{ |
314
|
|
|
|
|
|
|
precheck => |
315
|
|
|
|
|
|
|
[ |
316
|
|
|
|
|
|
|
[ '__connect_to_database', $dbuser, $dbpasswd ], |
317
|
|
|
|
|
|
|
[ '__load_rm_template' ], |
318
|
|
|
|
|
|
|
[ '__check_auth' ], |
319
|
|
|
|
|
|
|
[ '__populate_template' ], |
320
|
|
|
|
|
|
|
], |
321
|
|
|
|
|
|
|
code => 'output', |
322
|
|
|
|
|
|
|
}, |
323
|
|
|
|
|
|
|
login => { }, |
324
|
|
|
|
|
|
|
account_view => { }, |
325
|
|
|
|
|
|
|
account_update => |
326
|
|
|
|
|
|
|
{ |
327
|
|
|
|
|
|
|
ignoredefaults => 'precheck', |
328
|
|
|
|
|
|
|
precheck => |
329
|
|
|
|
|
|
|
precheck => |
330
|
|
|
|
|
|
|
[ |
331
|
|
|
|
|
|
|
[ '__connect_to_database', $dbuser, $dbpasswd ], |
332
|
|
|
|
|
|
|
[ '__check_update_auth' ], |
333
|
|
|
|
|
|
|
[ '__update_account' ], |
334
|
|
|
|
|
|
|
[ '__load_rm_template' ], |
335
|
|
|
|
|
|
|
[ '__populate_template' ], |
336
|
|
|
|
|
|
|
], |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
) ; |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
We can even go futher, and add capabilities: |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
BEGIN { our ($dbuser,$dbpasswd) = qw(AUserName APassword); } |
343
|
|
|
|
|
|
|
use Method::Declarative |
344
|
|
|
|
|
|
|
( |
345
|
|
|
|
|
|
|
'--defaults' => |
346
|
|
|
|
|
|
|
{ |
347
|
|
|
|
|
|
|
precheck => |
348
|
|
|
|
|
|
|
[ |
349
|
|
|
|
|
|
|
[ '__connect_to_database', $dbuser, $dbpasswd ], |
350
|
|
|
|
|
|
|
[ '__check_auth' ], |
351
|
|
|
|
|
|
|
], |
352
|
|
|
|
|
|
|
code => 'output', |
353
|
|
|
|
|
|
|
}, |
354
|
|
|
|
|
|
|
login => { code => '__process_admin_login' }, |
355
|
|
|
|
|
|
|
chpasswd => |
356
|
|
|
|
|
|
|
{ |
357
|
|
|
|
|
|
|
precheck => |
358
|
|
|
|
|
|
|
[ |
359
|
|
|
|
|
|
|
[ '__has_capability', 'change_password' ], |
360
|
|
|
|
|
|
|
[ '__change_password' ], |
361
|
|
|
|
|
|
|
], |
362
|
|
|
|
|
|
|
}, |
363
|
|
|
|
|
|
|
) ; |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
=head1 CAVEATS |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
This module is S-L-O-W. That's because the main engine of the module |
368
|
|
|
|
|
|
|
is essentially an interpreter that loops through the given data structures |
369
|
|
|
|
|
|
|
every time a method is called. |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
The B module will use the |
372
|
|
|
|
|
|
|
C<__Method__Declarative_done_once> key of hashref-based objects to scoreboard |
373
|
|
|
|
|
|
|
calls to methods with a C phase declaration. This probably won't |
374
|
|
|
|
|
|
|
cause a problem unless your object happens to be tied or restricted. |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
=head1 BUGS |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
Please report bugs to Eperl@jrcsdevelopment.comE. |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
=head1 AUTHOR |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
Jim Schneider |
383
|
|
|
|
|
|
|
CPAN ID: JSCHNEID |
384
|
|
|
|
|
|
|
perl@jrcsdevelopment.com |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
=head1 COPYRIGHT |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
Copyright (c) 2006 by Jim Schneider. |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
391
|
|
|
|
|
|
|
under the same terms as Perl itself. |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
=head1 SEE ALSO |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
perl(1) |
396
|
|
|
|
|
|
|
CGI::Application(3) |
397
|
|
|
|
|
|
|
HTML::Template(3). |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
=cut |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
my @end_decls = (); |
402
|
|
|
|
|
|
|
my %once_decls = (); |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
# The destructor |
405
|
|
|
|
|
|
|
END |
406
|
|
|
|
|
|
|
{ |
407
|
2
|
|
|
2
|
|
6
|
my $decl; |
408
|
2
|
|
|
|
|
21
|
while($decl = shift @end_decls) |
409
|
|
|
|
|
|
|
{ |
410
|
0
|
|
|
|
|
|
my ($pkg, $meth, $spec) = @$decl; |
411
|
0
|
|
|
|
|
|
do_global_op($pkg, $meth, $spec); |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
# Return a copy of a list from its reference |
416
|
|
|
|
|
|
|
sub clone_list |
417
|
|
|
|
|
|
|
{ |
418
|
0
|
|
|
0
|
|
|
my ($lref) = @_; |
419
|
0
|
|
|
|
|
|
return [ @$lref ]; |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
# Return a copy of a list of lists |
423
|
|
|
|
|
|
|
sub clone_listoflist |
424
|
|
|
|
|
|
|
{ |
425
|
0
|
|
|
0
|
|
|
my ($lref) = @_; |
426
|
0
|
|
|
|
|
|
my $res = []; |
427
|
0
|
|
|
|
|
|
my $ocarplevel = $Carp::CarpLevel; |
428
|
0
|
|
|
|
|
|
$Carp::CarpLevel = 2; |
429
|
0
|
|
|
|
|
|
eval { push @$res, clone_list($_) foreach @$lref; }; |
|
0
|
|
|
|
|
|
|
430
|
0
|
0
|
|
|
|
|
croak $@ if $@; |
431
|
0
|
|
|
|
|
|
$Carp::CarpLevel = $ocarplevel; |
432
|
0
|
|
|
|
|
|
$res; |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
# Merge two lists of lists |
436
|
|
|
|
|
|
|
sub merge_listoflists |
437
|
|
|
|
|
|
|
{ |
438
|
0
|
|
|
0
|
|
|
my ($ref1, $ref2) = @_; |
439
|
0
|
|
|
|
|
|
my $res = []; |
440
|
0
|
|
|
|
|
|
my $ocarplevel = $Carp::CarpLevel; |
441
|
0
|
|
|
|
|
|
$Carp::CarpLevel = 2; |
442
|
0
|
|
|
|
|
|
eval { push @$res, clone_list($_) foreach @$ref1, @$ref2; }; |
|
0
|
|
|
|
|
|
|
443
|
0
|
0
|
|
|
|
|
croak $@ if $@; |
444
|
0
|
|
|
|
|
|
$Carp::CarpLevel = $ocarplevel; |
445
|
0
|
|
|
|
|
|
$res; |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
# The heart of the package - create the declared methods. |
449
|
|
|
|
|
|
|
sub import |
450
|
|
|
|
|
|
|
{ |
451
|
|
|
|
|
|
|
my ($pkg, @args) = @_; |
452
|
|
|
|
|
|
|
my ($realdefclass) = caller(); |
453
|
|
|
|
|
|
|
my %h; |
454
|
|
|
|
|
|
|
if(@args % 2) |
455
|
|
|
|
|
|
|
{ |
456
|
|
|
|
|
|
|
carp "Expected a list of key-value pairs\n"; |
457
|
|
|
|
|
|
|
return unless @args==1; |
458
|
|
|
|
|
|
|
eval { %h = %{$args[0]}; }; |
459
|
|
|
|
|
|
|
croak $@ if $@; |
460
|
|
|
|
|
|
|
if($h{'--defaults'}) |
461
|
|
|
|
|
|
|
{ |
462
|
|
|
|
|
|
|
@args = ('--defaults', delete $h{'--defaults'}); |
463
|
|
|
|
|
|
|
@args = (@args, %h); |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
else |
466
|
|
|
|
|
|
|
{ |
467
|
|
|
|
|
|
|
@args = %h; |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
my %defaults = (package => $realdefclass); |
471
|
|
|
|
|
|
|
while(@args) |
472
|
|
|
|
|
|
|
{ |
473
|
|
|
|
|
|
|
my ($key, $href); |
474
|
|
|
|
|
|
|
($key, $href, @args) = @args; |
475
|
|
|
|
|
|
|
eval { %h = %$href; }; |
476
|
|
|
|
|
|
|
croak $@ if $@; |
477
|
|
|
|
|
|
|
if($key eq '--defaults') |
478
|
|
|
|
|
|
|
{ |
479
|
|
|
|
|
|
|
my %defs = ( package => $realdefclass ); |
480
|
|
|
|
|
|
|
for my $k (qw(end init once precheck postcheck)) |
481
|
|
|
|
|
|
|
{ |
482
|
|
|
|
|
|
|
if($h{$k}) |
483
|
|
|
|
|
|
|
{ |
484
|
|
|
|
|
|
|
$defs{$k} = clone_listoflist(delete $h{$k}); |
485
|
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
if($h{package}) |
488
|
|
|
|
|
|
|
{ |
489
|
|
|
|
|
|
|
$defs{package} = delete $h{package}; |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
if($h{code}) |
492
|
|
|
|
|
|
|
{ |
493
|
|
|
|
|
|
|
$defs{code} = delete $h{code}; |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
carp "Illegal keys in --defaults section" and next if %h; |
496
|
|
|
|
|
|
|
%defaults = %defs; |
497
|
|
|
|
|
|
|
next; |
498
|
|
|
|
|
|
|
} |
499
|
|
|
|
|
|
|
my %res; |
500
|
|
|
|
|
|
|
my %curdefs = %defaults; |
501
|
|
|
|
|
|
|
if($h{ignoredfaults}) |
502
|
|
|
|
|
|
|
{ |
503
|
|
|
|
|
|
|
for my $k (@{$h{ignoredefaults}}) |
504
|
|
|
|
|
|
|
{ |
505
|
|
|
|
|
|
|
delete $curdefs{$k}; |
506
|
|
|
|
|
|
|
if($k eq 'package') |
507
|
|
|
|
|
|
|
{ |
508
|
|
|
|
|
|
|
$curdefs{package} = $realdefclass; |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
delete $h{ignoredefaults}; |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
for my $k qw(package code) |
514
|
|
|
|
|
|
|
{ |
515
|
|
|
|
|
|
|
if($h{$k}) { $curdefs{$k} = delete $h{$k}; } |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
for my $k (qw(end init once precheck postcheck)) |
518
|
|
|
|
|
|
|
{ |
519
|
|
|
|
|
|
|
if($h{$k} or $curdefs{$k}) |
520
|
|
|
|
|
|
|
{ |
521
|
|
|
|
|
|
|
$res{$k} = merge_listoflists($curdefs{$k}, delete $h{$k}); |
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
carp "Illegal keys in declaration of $key" and next if %h; |
525
|
|
|
|
|
|
|
my $pkg = $curdefs{package}; |
526
|
|
|
|
|
|
|
$res{code} = $curdefs{code}; |
527
|
|
|
|
|
|
|
if($pkg =~ /__CALLER__/) |
528
|
|
|
|
|
|
|
{ |
529
|
|
|
|
|
|
|
$pkg = join '', map {$_ eq '__CALLER__'?$realdefclass:$_ } |
530
|
|
|
|
|
|
|
split /::/, $pkg; |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
if($res{end}) |
533
|
|
|
|
|
|
|
{ |
534
|
|
|
|
|
|
|
push @end_decls, [ $pkg, $key, clone_listoflist($res{end}) ]; |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
my $symname = $pkg . '::' . $key; |
537
|
|
|
|
|
|
|
no strict 'refs'; |
538
|
|
|
|
|
|
|
*{$symname} = sub |
539
|
|
|
|
|
|
|
{ |
540
|
|
|
|
|
|
|
my ($obj) = @_; |
541
|
|
|
|
|
|
|
do_method($obj, $key, \@_, @res{qw(once precheck code postcheck)}); |
542
|
|
|
|
|
|
|
} ; |
543
|
|
|
|
|
|
|
if($res{init}) |
544
|
|
|
|
|
|
|
{ |
545
|
|
|
|
|
|
|
do_global_op($pkg, $key, $res{init}); |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
} |
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
sub do_global_op |
551
|
|
|
|
|
|
|
{ |
552
|
|
|
|
|
|
|
my ($pkg, $name, $spec) = @_; |
553
|
|
|
|
|
|
|
my $ocarplevel = $Carp::CarpLevel; |
554
|
|
|
|
|
|
|
$Carp::CarpLevel = 2; |
555
|
|
|
|
|
|
|
eval { no warnings "void"; @$spec; }; |
556
|
|
|
|
|
|
|
croak $@ if $@; |
557
|
|
|
|
|
|
|
for my $op (@$spec) |
558
|
|
|
|
|
|
|
{ |
559
|
|
|
|
|
|
|
my ($meth, @args); |
560
|
|
|
|
|
|
|
eval { ($meth, @args) = @$op; }; |
561
|
|
|
|
|
|
|
croak $@ if $@; |
562
|
|
|
|
|
|
|
$pkg->$meth($name, @args); |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
sub apply_before |
567
|
|
|
|
|
|
|
{ |
568
|
|
|
|
|
|
|
my ($obj, $name, $isscalar, $argsref, $spec) = @_; |
569
|
|
|
|
|
|
|
my $ocarplevel = $Carp::CarpLevel; |
570
|
|
|
|
|
|
|
$Carp::CarpLevel = 3; |
571
|
|
|
|
|
|
|
eval { no warnings "void"; @$spec; }; |
572
|
|
|
|
|
|
|
croak $@ if $@; |
573
|
|
|
|
|
|
|
for my $op (@$spec) |
574
|
|
|
|
|
|
|
{ |
575
|
|
|
|
|
|
|
eval { no warnings "void"; @$op; }; |
576
|
|
|
|
|
|
|
croak $@ if $@; |
577
|
|
|
|
|
|
|
my ($meth, @args) = @$op; |
578
|
|
|
|
|
|
|
my @res = $obj->$meth($name, $isscalar, $argsref, @args); |
579
|
|
|
|
|
|
|
$argsref = [ @res ]; |
580
|
|
|
|
|
|
|
$obj = $res[0]; |
581
|
|
|
|
|
|
|
last unless $obj; |
582
|
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
|
$Carp::CarpLevel = $ocarplevel; |
584
|
|
|
|
|
|
|
return @$argsref; |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
sub do_method |
588
|
|
|
|
|
|
|
{ |
589
|
|
|
|
|
|
|
my ($obj, $name, $argsref, $once, $pre, $code, $post) = @_; |
590
|
|
|
|
|
|
|
my $ocarplevel = $Carp::CarpLevel; |
591
|
|
|
|
|
|
|
$Carp::CarpLevel = 2; |
592
|
|
|
|
|
|
|
my $isscalar = not wantarray; |
593
|
|
|
|
|
|
|
# Do the "once" ops |
594
|
|
|
|
|
|
|
if($once) |
595
|
|
|
|
|
|
|
{ |
596
|
|
|
|
|
|
|
if(ref $obj) |
597
|
|
|
|
|
|
|
{ |
598
|
|
|
|
|
|
|
my $skip = 1; |
599
|
|
|
|
|
|
|
eval { $skip = $obj->{__Method__Declarative_done_once}{$name}; }; |
600
|
|
|
|
|
|
|
unless($skip) |
601
|
|
|
|
|
|
|
{ |
602
|
|
|
|
|
|
|
# In case the object gets prestidigitated away... |
603
|
|
|
|
|
|
|
my $orig_obj = $obj; |
604
|
|
|
|
|
|
|
my @args = |
605
|
|
|
|
|
|
|
apply_before($obj, $name, $isscalar, $argsref, $once); |
606
|
|
|
|
|
|
|
$obj = $args[0]; |
607
|
|
|
|
|
|
|
$argsref = [ @args ]; |
608
|
|
|
|
|
|
|
$orig_obj->{__done_once}{$name} = 1; |
609
|
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
else |
612
|
|
|
|
|
|
|
{ |
613
|
|
|
|
|
|
|
unless($once_decls{$obj}{$name}) |
614
|
|
|
|
|
|
|
{ |
615
|
|
|
|
|
|
|
# In case the object gets prestidigitated away... |
616
|
|
|
|
|
|
|
my $orig_obj = $obj; |
617
|
|
|
|
|
|
|
my @args = |
618
|
|
|
|
|
|
|
apply_before($obj, $name, $isscalar, $argsref, $once); |
619
|
|
|
|
|
|
|
$obj = $args[0]; |
620
|
|
|
|
|
|
|
$argsref = [ @args ]; |
621
|
|
|
|
|
|
|
$once_decls{$orig_obj}{$name} = 1; |
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
} |
624
|
|
|
|
|
|
|
# We bail out here, if we don't have an object |
625
|
|
|
|
|
|
|
unless($obj) |
626
|
|
|
|
|
|
|
{ |
627
|
|
|
|
|
|
|
carp "Initializer lost the object, aborting call to $name"; |
628
|
|
|
|
|
|
|
$Carp::CarpLevel = $ocarplevel; |
629
|
|
|
|
|
|
|
return; |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
# Do the "precheck" ops |
633
|
|
|
|
|
|
|
if($pre) |
634
|
|
|
|
|
|
|
{ |
635
|
|
|
|
|
|
|
my @args = apply_before($obj, $name, $isscalar, $argsref, $pre); |
636
|
|
|
|
|
|
|
unless(@args) |
637
|
|
|
|
|
|
|
{ |
638
|
|
|
|
|
|
|
carp "Validation lost the object, aborting call to $name"; |
639
|
|
|
|
|
|
|
$Carp::CarpLevel = $ocarplevel; |
640
|
|
|
|
|
|
|
return ; |
641
|
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
|
$obj = $args[0]; |
643
|
|
|
|
|
|
|
$argsref = [ @args ]; |
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
# Do the "code" operation |
646
|
|
|
|
|
|
|
my @res; |
647
|
|
|
|
|
|
|
if($code) |
648
|
|
|
|
|
|
|
{ |
649
|
|
|
|
|
|
|
if($isscalar) |
650
|
|
|
|
|
|
|
{ |
651
|
|
|
|
|
|
|
$res[0] = $obj->$code(@{$argsref}[1..$#{$argsref}]); |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
else |
654
|
|
|
|
|
|
|
{ |
655
|
|
|
|
|
|
|
@res = $obj->$code(@{$argsref}[1..$#{$argsref}]); |
656
|
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
# Do the "postcheck" operation |
659
|
|
|
|
|
|
|
if($post) |
660
|
|
|
|
|
|
|
{ |
661
|
|
|
|
|
|
|
eval { no warnings "void"; @$post; }; |
662
|
|
|
|
|
|
|
croak $@ if $@; |
663
|
|
|
|
|
|
|
for my $op (@$post) |
664
|
|
|
|
|
|
|
{ |
665
|
|
|
|
|
|
|
my ($meth, @args); |
666
|
|
|
|
|
|
|
eval |
667
|
|
|
|
|
|
|
{ |
668
|
|
|
|
|
|
|
($meth, @args) = @$op; |
669
|
|
|
|
|
|
|
@res = $obj->$meth($name, $isscalar, \@res, @args); |
670
|
|
|
|
|
|
|
} ; |
671
|
|
|
|
|
|
|
croak $@ if $@; |
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
} |
674
|
|
|
|
|
|
|
$Carp::CarpLevel = $ocarplevel; |
675
|
|
|
|
|
|
|
return unless defined wantarray; |
676
|
|
|
|
|
|
|
return $res[0] if $isscalar; |
677
|
|
|
|
|
|
|
return @res; |
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
1; |