File Coverage

blib/lib/Method/Declarative.pm
Criterion Covered Total %
statement 11 33 33.3
branch 0 4 0.0
condition n/a
subroutine 4 7 57.1
pod n/a
total 15 44 34.0


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;