File Coverage

blib/lib/Venus/Core.pm
Criterion Covered Total %
statement 187 196 95.4
branch 27 36 75.0
condition 8 12 66.6
subroutine 41 42 97.6
pod 0 24 0.0
total 263 310 84.8


line stmt bran cond sub pod time code
1             package Venus::Core;
2              
3 87     81363   1552 use 5.018;
  87         277  
4              
5 87     87   480 use strict;
  87         168  
  87         1810  
6 87     87   442 use warnings;
  87         193  
  87         12845  
7              
8             # METHODS
9              
10             sub ARGS {
11 17207     17207 0 35023 my ($self, @args) = @_;
12              
13             return (!@args)
14             ? ($self->DATA)
15             : ((@args == 1 && ref($args[0]) eq 'HASH')
16 17207 100 66     92267 ? (!%{$args[0]} ? $self->DATA : {%{$args[0]}})
  6795 50       15515  
  6791 100       32279  
    100          
17             : (@args % 2 ? {@args, undef} : {@args}));
18             }
19              
20             sub ATTR {
21 1800     1800 0 3746 my ($self, $attr, @args) = @_;
22              
23 87     87   650 no strict 'refs';
  87         211  
  87         3381  
24 87     87   576 no warnings 'redefine';
  87         200  
  87         27508  
25              
26 1524     156549   2717 *{"@{[$self->NAME]}::$attr"} = sub {$_[0]->ITEM($attr, @_[1..$#_])}
  1524         3330  
  156549         388425  
27 1800 100       15899 if !$self->can($attr);
28              
29 1800         3100 my $index = int(keys(%{$${"@{[$self->NAME]}::META"}{ATTR}})) + 1;
  1800         2356  
  1800         2395  
  1800         3278  
30              
31 1800         4575 $${"@{[$self->NAME]}::META"}{ATTR}{$attr} = [$index, [$attr, @args]];
  1800         2471  
  1800         3118  
32              
33 1800         3205 ${"@{[$self->NAME]}::@{[$self->METACACHE]}"} = undef;
  1800         2423  
  1800         3139  
  1800         3563  
34              
35 1800         4073 return $self;
36             }
37              
38             sub AUDIT {
39 2169     2169 0 3967 my ($self) = @_;
40              
41 2169         3141 return $self;
42             }
43              
44             sub BASE {
45 1003     1003 0 2931 my ($self, $base, @args) = @_;
46              
47 87     87   684 no strict 'refs';
  87         1736  
  87         33537  
48              
49 1003 100       1742 if (!grep !/\A[^:]+::\z/, keys(%{"${base}::"})) {
  1003         15942  
50 309 100       619 local $@; eval "require $base"; do{require Venus; Venus::fault($@)} if $@;
  309         16865  
  309         1870  
  1         5  
  1         8  
51             }
52              
53 1002         1962 @{"@{[$self->NAME]}::ISA"} = (
  1002         2153  
54 1002         3041 $base, (grep +($_ ne $base), @{"@{[$self->NAME]}::ISA"})
  1002         1755  
  1002         5452  
55             );
56              
57 1002         4973 my $index = int(keys(%{$${"@{[$self->NAME]}::META"}{BASE}})) + 1;
  1002         1615  
  1002         1807  
  1002         5688  
58              
59 1002         3226 $${"@{[$self->NAME]}::META"}{BASE}{$base} = [$index, [$base, @args]];
  1002         1629  
  1002         2130  
60              
61 1002         2111 ${"@{[$self->NAME]}::@{[$self->METACACHE]}"} = undef;
  1002         1650  
  1002         2080  
  1002         4114  
62              
63 1002         2899 return $self;
64             }
65              
66             sub BLESS {
67 16628     16628 0 34001 my ($self, @args) = @_;
68              
69 16628         40263 my $name = $self->NAME;
70 16628         58393 my $data = $self->DATA($self->ARGS($self->BUILDARGS(@args)));
71 16628         47953 my $anew = bless($data, $name);
72              
73 87     87   715 no strict 'refs';
  87         214  
  87         29218  
74              
75 16628         50982 $anew->BUILD($data);
76              
77             # FYI, every call to "new" calls "BUILD" which dispatches to each "BUILD"
78             # defined in each attached role.
79              
80             # If one (or more) roles use reflection (i.e. calls "META") to introspect the
81             # package's configuration, which could cause a performance problem given that
82             # the Venus::Meta class uses recursion to introspect all superclasses and
83             # roles to determine and present aggregate lists of package members. It's
84             # your classic n+1 problem.
85              
86             # The solution to this is to cache the associated Venus::Meta object which
87             # itself caches the results of its recursive lookups. The cache is stored on
88             # the subclass (i.e. on the calling package) and the cache will go away
89             # whenever the package does.
90              
91 16619 100 66     40609 ${"${name}::@{[$self->METACACHE]}"} ||= Venus::Meta->new(name => $name)
  13872         25344  
  13872         31904  
92             if $name ne 'Venus::Meta';
93              
94 16619         131135 return $anew;
95             }
96              
97             sub BUILD {
98 2763     2763 0 5054 my ($self) = @_;
99              
100 2763         4171 return $self;
101             }
102              
103             sub BUILDARGS {
104 3165     3165 0 6884 my ($self, @args) = @_;
105              
106 3165         8353 return (@args);
107             }
108              
109             sub DATA {
110 20064     20064 0 37377 my ($self, $data) = @_;
111              
112 20064 100       71078 return $data ? {%$data} : {};
113             }
114              
115             sub DESTROY {
116 2131     2131   4780 my ($self) = @_;
117              
118 2131         11664 return;
119             }
120              
121             sub DOES {
122 633     633 0 1453 my ($self, $role) = @_;
123              
124 633 50       1939 return if !$role;
125              
126 633         1803 return $self->META->role($role);
127             }
128              
129             sub EXPORT {
130 0     0 0 0 my ($self, $into) = @_;
131              
132 0         0 return [];
133             }
134              
135             sub FROM {
136 5     5 0 19 my ($self, $base) = @_;
137              
138 5         25 $self->BASE($base);
139              
140 5 50       57 $base->AUDIT($self->NAME) if $base->can('AUDIT');
141              
142 87     87   630 no warnings 'redefine';
  87         196  
  87         16391  
143              
144 5         31 $base->IMPORT($self->NAME);
145              
146 5         44 return $self;
147             }
148              
149             sub GET {
150 136166     136166 0 199956 my ($self, $name) = @_;
151              
152 136166         571633 return $self->{$name};
153             }
154              
155             sub IMPORT {
156 15     15 0 39 my ($self, $into) = @_;
157              
158 15         66 return $self;
159             }
160              
161             sub ITEM {
162 157640     157640 0 264408 my ($self, $name, @args) = @_;
163              
164 157640 50       265158 return undef if !$name;
165 157640 100       344258 return $self->GET($name) if !@args;
166 21475         49402 return $self->SET($name, $args[0]);
167             }
168              
169             sub META {
170 41272     41272 0 65349 my ($self) = @_;
171              
172 87     87   694 no strict 'refs';
  87         184  
  87         15618  
173              
174 41272         196427 require Venus::Meta;
175              
176 41272         81539 my $name = $self->NAME;
177              
178 41272   66     59324 return ${"${name}::@{[$self->METACACHE]}"}
179             || Venus::Meta->new(name => $name);
180             }
181              
182             sub METACACHE {
183 64488     64488 0 101872 my ($self) = @_;
184              
185 64488         361692 return 'METACACHE';
186             }
187              
188             sub MIXIN {
189 43     43 0 124 my ($self, $mixin, @args) = @_;
190              
191 87     87   618 no strict 'refs';
  87         181  
  87         12055  
192              
193 43 50       88 if (!grep !/\A[^:]+::\z/, keys(%{"${mixin}::"})) {
  43         556  
194 0 0       0 local $@; eval "require $mixin"; do{require Venus; Venus::fault($@)} if $@;
  0         0  
  0         0  
  0         0  
  0         0  
195             }
196              
197 87     87   610 no warnings 'redefine';
  87         167  
  87         5374  
198              
199 43         195 $mixin->IMPORT($self->NAME);
200              
201 87     87   548 no strict 'refs';
  87         180  
  87         18210  
202              
203 43         71 my $index = int(keys(%{$${"@{[$self->NAME]}::META"}{MIXIN}})) + 1;
  43         69  
  43         73  
  43         103  
204              
205 43         150 $${"@{[$self->NAME]}::META"}{MIXIN}{$mixin} = [$index, [$mixin, @args]];
  43         101  
  43         102  
206              
207 43         94 ${"@{[$self->NAME]}::@{[$self->METACACHE]}"} = undef;
  43         77  
  43         84  
  43         104  
208              
209 43         142 return $self;
210             }
211              
212             sub NAME {
213 92822     92822 0 142227 my ($self) = @_;
214              
215 92822   66     386947 return ref $self || $self;
216             }
217              
218             sub ROLE {
219 3174     3174 0 8369 my ($self, $role, @args) = @_;
220              
221 87     87   670 no strict 'refs';
  87         227  
  87         11997  
222              
223 3174 100       4529 if (!grep !/\A[^:]+::\z/, keys(%{"${role}::"})) {
  3174         26772  
224 1860 50       3394 local $@; eval "require $role"; do{require Venus; Venus::fault($@)} if $@;
  1860         103300  
  1860         9360  
  0         0  
  0         0  
225             }
226              
227 87     87   671 no warnings 'redefine';
  87         226  
  87         4494  
228              
229 3174         13810 $role->IMPORT($self->NAME);
230              
231 87     87   603 no strict 'refs';
  87         190  
  87         19102  
232              
233 3174         4601 my $index = int(keys(%{$${"@{[$self->NAME]}::META"}{ROLE}})) + 1;
  3174         4110  
  3174         4283  
  3174         5800  
234              
235 3174         7805 $${"@{[$self->NAME]}::META"}{ROLE}{$role} = [$index, [$role, @args]];
  3174         4215  
  3174         5406  
236              
237 3174         5948 ${"@{[$self->NAME]}::@{[$self->METACACHE]}"} = undef;
  3174         4222  
  3174         5378  
  3174         6764  
238              
239 3174         5914 return $self;
240             }
241              
242             sub SET {
243 21476     21476 0 36539 my ($self, $name, $data) = @_;
244              
245 21476         57504 return $self->{$name} = $data;
246             }
247              
248             sub SUBS {
249 1     1 0 5 my ($self) = @_;
250              
251 87     87   744 no strict 'refs';
  87         218  
  87         36112  
252              
253             return [
254 11         18 sort grep *{"@{[$self->NAME]}::$_"}{"CODE"},
  11         17  
255 1         3 grep /^[_a-zA-Z]\w*$/, keys %{"@{[$self->NAME]}::"}
  1         3  
  1         5  
256             ];
257             }
258              
259             sub TEST {
260 3153     3153 0 5746 my ($self, $role) = @_;
261              
262 3153         9494 $self->ROLE($role);
263              
264 3153 50       23922 $role->AUDIT($self->NAME) if $role->can('AUDIT');
265              
266 3149         6823 return $self;
267             }
268              
269             sub UNIMPORT {
270 1     1 0 4 my ($self, $into, @args) = @_;
271              
272 1         9 return $self;
273             }
274              
275             sub USE {
276 3021     3021 0 6821 my ($self, $into, @args) = @_;
277              
278 3021         6566 return $self;
279             }
280              
281             1;
282              
283              
284              
285             =head1 NAME
286              
287             Venus::Core - Core Base Class
288              
289             =cut
290              
291             =head1 ABSTRACT
292              
293             Core Base Class for Perl 5
294              
295             =cut
296              
297             =head1 SYNOPSIS
298              
299             package User;
300              
301             use base 'Venus::Core';
302              
303             package main;
304              
305             my $user = User->BLESS(
306             fname => 'Elliot',
307             lname => 'Alderson',
308             );
309              
310             # bless({fname => 'Elliot', lname => 'Alderson'}, 'User')
311              
312             # i.e. BLESS is somewhat equivalent to writing
313              
314             # User->BUILD(bless(User->ARGS(User->BUILDARGS(@args) || User->DATA), 'User'))
315              
316             =cut
317              
318             =head1 DESCRIPTION
319              
320             This package provides a base class for L<"class"|Venus::Core::Class> and
321             L<"role"|Venus::Core::Role> (kind) derived packages and provides class building,
322             object construction, and object deconstruction lifecycle hooks. The
323             L and L packages provide a simple DSL for automating
324             L derived base classes.
325              
326             =cut
327              
328             =head1 METHODS
329              
330             This package provides the following methods:
331              
332             =cut
333              
334             =head2 args
335              
336             ARGS(Any @args) (HashRef)
337              
338             The ARGS method is a object construction lifecycle hook which accepts a list of
339             arguments and returns a blessable data structure.
340              
341             I>
342              
343             =over 4
344              
345             =item args example 1
346              
347             # given: synopsis
348              
349             package main;
350              
351             my $args = User->ARGS;
352              
353             # {}
354              
355             =back
356              
357             =over 4
358              
359             =item args example 2
360              
361             # given: synopsis
362              
363             package main;
364              
365             my $args = User->ARGS(name => 'Elliot');
366              
367             # {name => 'Elliot'}
368              
369             =back
370              
371             =over 4
372              
373             =item args example 3
374              
375             # given: synopsis
376              
377             package main;
378              
379             my $args = User->ARGS({name => 'Elliot'});
380              
381             # {name => 'Elliot'}
382              
383             =back
384              
385             =cut
386              
387             =head2 attr
388              
389             ATTR(Str $name, Any @args) (Str | Object)
390              
391             The ATTR method is a class building lifecycle hook which installs an attribute
392             accessors in the calling package.
393              
394             I>
395              
396             =over 4
397              
398             =item attr example 1
399              
400             package User;
401              
402             use base 'Venus::Core';
403              
404             User->ATTR('name');
405              
406             package main;
407              
408             my $user = User->BLESS;
409              
410             # bless({}, 'User')
411              
412             # $user->name;
413              
414             # ""
415              
416             # $user->name('Elliot');
417              
418             # "Elliot"
419              
420             =back
421              
422             =over 4
423              
424             =item attr example 2
425              
426             package User;
427              
428             use base 'Venus::Core';
429              
430             User->ATTR('role');
431              
432             package main;
433              
434             my $user = User->BLESS(role => 'Engineer');
435              
436             # bless({role => 'Engineer'}, 'User')
437              
438             # $user->role;
439              
440             # "Engineer"
441              
442             # $user->role('Hacker');
443              
444             # "Hacker"
445              
446             =back
447              
448             =cut
449              
450             =head2 audit
451              
452             AUDIT(Str $role) (Str | Object)
453              
454             The AUDIT method is a class building lifecycle hook which exist in roles and is
455             executed as a callback when the consuming class invokes the L hook.
456              
457             I>
458              
459             =over 4
460              
461             =item audit example 1
462              
463             package HasType;
464              
465             use base 'Venus::Core';
466              
467             sub AUDIT {
468             die 'Consumer missing "type" attribute' if !$_[1]->can('type');
469             }
470              
471             package User;
472              
473             use base 'Venus::Core';
474              
475             User->TEST('HasType');
476              
477             package main;
478              
479             my $user = User->BLESS;
480              
481             # Exception! Consumer missing "type" attribute
482              
483             =back
484              
485             =over 4
486              
487             =item audit example 2
488              
489             package HasType;
490              
491             sub AUDIT {
492             die 'Consumer missing "type" attribute' if !$_[1]->can('type');
493             }
494              
495             package User;
496              
497             use base 'Venus::Core';
498              
499             User->ATTR('type');
500              
501             User->TEST('HasType');
502              
503             package main;
504              
505             my $user = User->BLESS;
506              
507             # bless({}, 'User')
508              
509             =back
510              
511             =cut
512              
513             =head2 base
514              
515             BASE(Str $name) (Str | Object)
516              
517             The BASE method is a class building lifecycle hook which registers a base class
518             for the calling package. B Unlike the L hook, this hook doesn't
519             invoke the L hook.
520              
521             I>
522              
523             =over 4
524              
525             =item base example 1
526              
527             package Entity;
528              
529             sub work {
530             return;
531             }
532              
533             package User;
534              
535             use base 'Venus::Core';
536              
537             User->BASE('Entity');
538              
539             package main;
540              
541             my $user = User->BLESS;
542              
543             # bless({}, 'User')
544              
545             =back
546              
547             =over 4
548              
549             =item base example 2
550              
551             package Engineer;
552              
553             sub debug {
554             return;
555             }
556              
557             package Entity;
558              
559             sub work {
560             return;
561             }
562              
563             package User;
564              
565             use base 'Venus::Core';
566              
567             User->BASE('Entity');
568              
569             User->BASE('Engineer');
570              
571             package main;
572              
573             my $user = User->BLESS;
574              
575             # bless({}, 'User')
576              
577             =back
578              
579             =over 4
580              
581             =item base example 3
582              
583             package User;
584              
585             use base 'Venus::Core';
586              
587             User->BASE('Manager');
588              
589             # Exception! "Can't locate Manager.pm in @INC"
590              
591             =back
592              
593             =cut
594              
595             =head2 bless
596              
597             BLESS(Any @args) (Object)
598              
599             The BLESS method is an object construction lifecycle hook which returns an
600             instance of the calling package.
601              
602             I>
603              
604             =over 4
605              
606             =item bless example 1
607              
608             package User;
609              
610             use base 'Venus::Core';
611              
612             package main;
613              
614             my $example = User->BLESS;
615              
616             # bless({}, 'User')
617              
618             =back
619              
620             =over 4
621              
622             =item bless example 2
623              
624             package User;
625              
626             use base 'Venus::Core';
627              
628             package main;
629              
630             my $example = User->BLESS(name => 'Elliot');
631              
632             # bless({name => 'Elliot'}, 'User')
633              
634             =back
635              
636             =over 4
637              
638             =item bless example 3
639              
640             package User;
641              
642             use base 'Venus::Core';
643              
644             package main;
645              
646             my $example = User->BLESS({name => 'Elliot'});
647              
648             # bless({name => 'Elliot'}, 'User')
649              
650             =back
651              
652             =over 4
653              
654             =item bless example 4
655              
656             package List;
657              
658             use base 'Venus::Core';
659              
660             sub ARGS {
661             my ($self, @args) = @_;
662              
663             return @args
664             ? ((@args == 1 && ref $args[0] eq 'ARRAY') ? @args : [@args])
665             : $self->DATA;
666             }
667              
668             sub DATA {
669             my ($self, $data) = @_;
670              
671             return $data ? [@$data] : [];
672             }
673              
674             package main;
675              
676             my $list = List->BLESS(1..4);
677              
678             # bless([1..4], 'List')
679              
680             =back
681              
682             =over 4
683              
684             =item bless example 5
685              
686             package List;
687              
688             use base 'Venus::Core';
689              
690             sub ARGS {
691             my ($self, @args) = @_;
692              
693             return @args
694             ? ((@args == 1 && ref $args[0] eq 'ARRAY') ? @args : [@args])
695             : $self->DATA;
696             }
697              
698             sub DATA {
699             my ($self, $data) = @_;
700              
701             return $data ? [@$data] : [];
702             }
703              
704             package main;
705              
706             my $list = List->BLESS([1..4]);
707              
708             # bless([1..4], 'List')
709              
710             =back
711              
712             =cut
713              
714             =head2 build
715              
716             BUILD(HashRef $data) (Object)
717              
718             The BUILD method is an object construction lifecycle hook which receives an
719             object and the data structure that was blessed, and should return an object
720             although its return value is ignored by the L hook.
721              
722             I>
723              
724             =over 4
725              
726             =item build example 1
727              
728             package User;
729              
730             use base 'Venus::Core';
731              
732             sub BUILD {
733             my ($self) = @_;
734              
735             $self->{name} = 'Mr. Robot';
736              
737             return $self;
738             }
739              
740             package main;
741              
742             my $example = User->BLESS(name => 'Elliot');
743              
744             # bless({name => 'Mr. Robot'}, 'User')
745              
746             =back
747              
748             =over 4
749              
750             =item build example 2
751              
752             package User;
753              
754             use base 'Venus::Core';
755              
756             sub BUILD {
757             my ($self) = @_;
758              
759             $self->{name} = 'Mr. Robot';
760              
761             return $self;
762             }
763              
764             package Elliot;
765              
766             use base 'User';
767              
768             sub BUILD {
769             my ($self, $data) = @_;
770              
771             $self->SUPER::BUILD($data);
772              
773             $self->{name} = 'Elliot';
774              
775             return $self;
776             }
777              
778             package main;
779              
780             my $elliot = Elliot->BLESS;
781              
782             # bless({name => 'Elliot'}, 'Elliot')
783              
784             =back
785              
786             =cut
787              
788             =head2 buildargs
789              
790             BUILDARGS(Any @args) (Any @args | HashRef $data)
791              
792             The BUILDARGS method is an object construction lifecycle hook which receives
793             the arguments provided to the constructor (unaltered) and should return a list
794             of arguments, a hashref, or key/value pairs.
795              
796             I>
797              
798             =over 4
799              
800             =item buildargs example 1
801              
802             package User;
803              
804             use base 'Venus::Core';
805              
806             sub BUILD {
807             my ($self) = @_;
808              
809             return $self;
810             }
811              
812             sub BUILDARGS {
813             my ($self, @args) = @_;
814              
815             my $data = @args == 1 && !ref $args[0] ? {name => $args[0]} : {};
816              
817             return $data;
818             }
819              
820             package main;
821              
822             my $user = User->BLESS('Elliot');
823              
824             # bless({name => 'Elliot'}, 'User')
825              
826             =back
827              
828             =cut
829              
830             =head2 data
831              
832             DATA() (Ref)
833              
834             The DATA method is an object construction lifecycle hook which returns the
835             default data structure reference to be blessed when no arguments are provided
836             to the constructor. The default data structure is an empty hashref.
837              
838             I>
839              
840             =over 4
841              
842             =item data example 1
843              
844             package Example;
845              
846             use base 'Venus::Core';
847              
848             sub DATA {
849             return [];
850             }
851              
852             package main;
853              
854             my $example = Example->BLESS;
855              
856             # bless([], 'Example')
857              
858             =back
859              
860             =over 4
861              
862             =item data example 2
863              
864             package Example;
865              
866             use base 'Venus::Core';
867              
868             sub DATA {
869             return {};
870             }
871              
872             package main;
873              
874             my $example = Example->BLESS;
875              
876             # bless({}, 'Example')
877              
878             =back
879              
880             =cut
881              
882             =head2 destroy
883              
884             DESTROY() (Any)
885              
886             The DESTROY method is an object destruction lifecycle hook which is called when
887             the last reference to the object goes away.
888              
889             I>
890              
891             =over 4
892              
893             =item destroy example 1
894              
895             package User;
896              
897             use base 'Venus::Core';
898              
899             our $USERS = 0;
900              
901             sub BUILD {
902             return $USERS++;
903             }
904              
905             sub DESTROY {
906             return $USERS--;
907             }
908              
909             package main;
910              
911             my $user = User->BLESS(name => 'Elliot');
912              
913             undef $user;
914              
915             # undef
916              
917             =back
918              
919             =cut
920              
921             =head2 does
922              
923             DOES(Str $name) (Bool)
924              
925             The DOES method returns true or false if the invocant consumed the role or
926             interface provided.
927              
928             I>
929              
930             =over 4
931              
932             =item does example 1
933              
934             package Admin;
935              
936             use base 'Venus::Core';
937              
938             package User;
939              
940             use base 'Venus::Core';
941              
942             User->ROLE('Admin');
943              
944             sub BUILD {
945             my ($self) = @_;
946              
947             return $self;
948             }
949              
950             sub BUILDARGS {
951             my ($self, @args) = @_;
952              
953             return (@args);
954             }
955              
956             package main;
957              
958             my $admin = User->DOES('Admin');
959              
960             # 1
961              
962             =back
963              
964             =over 4
965              
966             =item does example 2
967              
968             package Admin;
969              
970             use base 'Venus::Core';
971              
972             package User;
973              
974             use base 'Venus::Core';
975              
976             User->ROLE('Admin');
977              
978             sub BUILD {
979             my ($self) = @_;
980              
981             return $self;
982             }
983              
984             sub BUILDARGS {
985             my ($self, @args) = @_;
986              
987             return (@args);
988             }
989              
990             package main;
991              
992             my $is_owner = User->DOES('Owner');
993              
994             # 0
995              
996             =back
997              
998             =cut
999              
1000             =head2 export
1001              
1002             EXPORT(Any @args) (ArrayRef)
1003              
1004             The EXPORT method is a class building lifecycle hook which returns an arrayref
1005             of routine names to be automatically imported by the calling package whenever
1006             the L or L hooks are used.
1007              
1008             I>
1009              
1010             =over 4
1011              
1012             =item export example 1
1013              
1014             package Admin;
1015              
1016             use base 'Venus::Core';
1017              
1018             sub shutdown {
1019             return;
1020             }
1021              
1022             sub EXPORT {
1023             ['shutdown']
1024             }
1025              
1026             package User;
1027              
1028             use base 'Venus::Core';
1029              
1030             User->ROLE('Admin');
1031              
1032             package main;
1033              
1034             my $user = User->BLESS;
1035              
1036             # bless({}, 'User')
1037              
1038             =back
1039              
1040             =cut
1041              
1042             =head2 from
1043              
1044             FROM(Str $name) (Str | Object)
1045              
1046             The FROM method is a class building lifecycle hook which registers a base class
1047             for the calling package, automatically invoking the L and L
1048             hooks on the base class.
1049              
1050             I>
1051              
1052             =over 4
1053              
1054             =item from example 1
1055              
1056             package Entity;
1057              
1058             use base 'Venus::Core';
1059              
1060             sub AUDIT {
1061             my ($self, $from) = @_;
1062             die "Missing startup" if !$from->can('startup');
1063             die "Missing shutdown" if !$from->can('shutdown');
1064             }
1065              
1066             package User;
1067              
1068             use base 'Venus::Core';
1069              
1070             User->ATTR('startup');
1071             User->ATTR('shutdown');
1072              
1073             User->FROM('Entity');
1074              
1075             package main;
1076              
1077             my $user = User->BLESS;
1078              
1079             # bless({}, 'User')
1080              
1081             =back
1082              
1083             =over 4
1084              
1085             =item from example 2
1086              
1087             package Entity;
1088              
1089             use base 'Venus::Core';
1090              
1091             sub AUDIT {
1092             my ($self, $from) = @_;
1093             die "Missing startup" if !$from->can('startup');
1094             die "Missing shutdown" if !$from->can('shutdown');
1095             }
1096              
1097             package User;
1098              
1099             use base 'Venus::Core';
1100              
1101             User->FROM('Entity');
1102              
1103             sub startup {
1104             return;
1105             }
1106              
1107             sub shutdown {
1108             return;
1109             }
1110              
1111             package main;
1112              
1113             my $user = User->BLESS;
1114              
1115             # bless({}, 'User')
1116              
1117             =back
1118              
1119             =cut
1120              
1121             =head2 get
1122              
1123             GET(Str $name) (Any)
1124              
1125             The GET method is a class instance lifecycle hook which is responsible for
1126             I<"getting"> instance items (or attribute values). By default, all class
1127             attributes I<"getters"> are dispatched to this method.
1128              
1129             I>
1130              
1131             =over 4
1132              
1133             =item get example 1
1134              
1135             package User;
1136              
1137             use base 'Venus::Core';
1138              
1139             User->ATTR('name');
1140              
1141             package main;
1142              
1143             my $user = User->BLESS(title => 'Engineer');
1144              
1145             # bless({title => 'Engineer'}, 'User')
1146              
1147             my $get = $user->GET('title');
1148              
1149             # "Engineer"
1150              
1151             =back
1152              
1153             =cut
1154              
1155             =head2 import
1156              
1157             IMPORT(Str $into, Any @args) (Str | Object)
1158              
1159             The IMPORT method is a class building lifecycle hook which dispatches the
1160             L lifecycle hook whenever the L or L hooks are used.
1161              
1162             I>
1163              
1164             =over 4
1165              
1166             =item import example 1
1167              
1168             package Admin;
1169              
1170             use base 'Venus::Core';
1171              
1172             our $USES = 0;
1173              
1174             sub shutdown {
1175             return;
1176             }
1177              
1178             sub EXPORT {
1179             ['shutdown']
1180             }
1181              
1182             sub IMPORT {
1183             my ($self, $into) = @_;
1184              
1185             $self->SUPER::IMPORT($into);
1186              
1187             $USES++;
1188              
1189             return $self;
1190             }
1191              
1192             package User;
1193              
1194             use base 'Venus::Core';
1195              
1196             User->ROLE('Admin');
1197              
1198             package main;
1199              
1200             my $user = User->BLESS;
1201              
1202             # bless({}, 'User')
1203              
1204             =back
1205              
1206             =cut
1207              
1208             =head2 item
1209              
1210             ITEM(Str $name, Any @args) (Str | Object)
1211              
1212             The ITEM method is a class instance lifecycle hook which is responsible for
1213             I<"getting"> and I<"setting"> instance items (or attributes). By default, all
1214             class attributes are dispatched to this method.
1215              
1216             I>
1217              
1218             =over 4
1219              
1220             =item item example 1
1221              
1222             package User;
1223              
1224             use base 'Venus::Core';
1225              
1226             User->ATTR('name');
1227              
1228             package main;
1229              
1230             my $user = User->BLESS;
1231              
1232             # bless({}, 'User')
1233              
1234             my $item = $user->ITEM('name', 'unknown');
1235              
1236             # "unknown"
1237              
1238             =back
1239              
1240             =over 4
1241              
1242             =item item example 2
1243              
1244             package User;
1245              
1246             use base 'Venus::Core';
1247              
1248             User->ATTR('name');
1249              
1250             package main;
1251              
1252             my $user = User->BLESS;
1253              
1254             # bless({}, 'User')
1255              
1256             $user->ITEM('name', 'known');
1257              
1258             my $item = $user->ITEM('name');
1259              
1260             # "known"
1261              
1262             =back
1263              
1264             =cut
1265              
1266             =head2 meta
1267              
1268             META() (Meta)
1269              
1270             The META method return a L object which describes the invocant's
1271             configuration.
1272              
1273             I>
1274              
1275             =over 4
1276              
1277             =item meta example 1
1278              
1279             package User;
1280              
1281             use base 'Venus::Core';
1282              
1283             package main;
1284              
1285             my $meta = User->META;
1286              
1287             # bless({name => 'User'}, 'Venus::Meta')
1288              
1289             =back
1290              
1291             =cut
1292              
1293             =head2 mixin
1294              
1295             MIXIN(Str $name) (Str | Object)
1296              
1297             The MIXIN method is a class building lifecycle hook which consumes the mixin
1298             provided, automatically invoking the mixin's L hook. The role
1299             composition semantics are as follows: Routines to be consumed must be
1300             explicitly declared via the L hook. Routines will be copied to the
1301             consumer even if they already exist. If multiple roles are consumed having
1302             routines with the same name (i.e. naming collisions) the last routine copied
1303             wins.
1304              
1305             I>
1306              
1307             =over 4
1308              
1309             =item mixin example 1
1310              
1311             package Action;
1312              
1313             use base 'Venus::Core';
1314              
1315             package User;
1316              
1317             use base 'Venus::Core';
1318              
1319             User->MIXIN('Action');
1320              
1321             package main;
1322              
1323             my $admin = User->DOES('Action');
1324              
1325             # 0
1326              
1327             =back
1328              
1329             =cut
1330              
1331             =head2 name
1332              
1333             NAME() (Str)
1334              
1335             The NAME method is a class building lifecycle hook which returns the name of
1336             the package.
1337              
1338             I>
1339              
1340             =over 4
1341              
1342             =item name example 1
1343              
1344             package User;
1345              
1346             use base 'Venus::Core';
1347              
1348             package main;
1349              
1350             my $name = User->NAME;
1351              
1352             # "User"
1353              
1354             =back
1355              
1356             =over 4
1357              
1358             =item name example 2
1359              
1360             package User;
1361              
1362             use base 'Venus::Core';
1363              
1364             package main;
1365              
1366             my $name = User->BLESS->NAME;
1367              
1368             # "User"
1369              
1370             =back
1371              
1372             =cut
1373              
1374             =head2 role
1375              
1376             ROLE(Str $name) (Str | Object)
1377              
1378             The ROLE method is a class building lifecycle hook which consumes the role
1379             provided, automatically invoking the role's L hook. B Unlike
1380             the L and L hooks, this hook doesn't invoke the L hook.
1381             The role composition semantics are as follows: Routines to be consumed must be
1382             explicitly declared via the L hook. Routines will be copied to the
1383             consumer unless they already exist (excluding routines from base classes, which
1384             will be overridden). If multiple roles are consumed having routines with the
1385             same name (i.e. naming collisions) the first routine copied wins.
1386              
1387             I>
1388              
1389             =over 4
1390              
1391             =item role example 1
1392              
1393             package Admin;
1394              
1395             use base 'Venus::Core';
1396              
1397             package User;
1398              
1399             use base 'Venus::Core';
1400              
1401             User->ROLE('Admin');
1402              
1403             package main;
1404              
1405             my $admin = User->DOES('Admin');
1406              
1407             # 1
1408              
1409             =back
1410              
1411             =over 4
1412              
1413             =item role example 2
1414              
1415             package Create;
1416              
1417             use base 'Venus::Core';
1418              
1419             package Delete;
1420              
1421             use base 'Venus::Core';
1422              
1423             package Manage;
1424              
1425             use base 'Venus::Core';
1426              
1427             Manage->ROLE('Create');
1428             Manage->ROLE('Delete');
1429              
1430             package User;
1431              
1432             use base 'Venus::Core';
1433              
1434             User->ROLE('Manage');
1435              
1436             package main;
1437              
1438             my $create = User->DOES('Create');
1439              
1440             # 1
1441              
1442             =back
1443              
1444             =cut
1445              
1446             =head2 set
1447              
1448             SET(Str $name, Any @args) (Any)
1449              
1450             The SET method is a class instance lifecycle hook which is responsible for
1451             I<"setting"> instance items (or attribute values). By default, all class
1452             attributes I<"setters"> are dispatched to this method.
1453              
1454             =over 4
1455              
1456             =item set example 1
1457              
1458             package User;
1459              
1460             use base 'Venus::Core';
1461              
1462             User->ATTR('name');
1463              
1464             package main;
1465              
1466             my $user = User->BLESS(title => 'Engineer');
1467              
1468             # bless({title => 'Engineer'}, 'User')
1469              
1470             my $set = $user->SET('title', 'Manager');
1471              
1472             # "Manager"
1473              
1474             =back
1475              
1476             =cut
1477              
1478             =head2 subs
1479              
1480             SUBS() (ArrayRef)
1481              
1482             The SUBS method returns the routines defined on the package and consumed from
1483             roles, but not inherited by superclasses.
1484              
1485             I>
1486              
1487             =over 4
1488              
1489             =item subs example 1
1490              
1491             package Example;
1492              
1493             use base 'Venus::Core';
1494              
1495             package main;
1496              
1497             my $subs = Example->SUBS;
1498              
1499             # [...]
1500              
1501             =back
1502              
1503             =cut
1504              
1505             =head2 test
1506              
1507             TEST(Str $name) (Str | Object)
1508              
1509             The TEST method is a class building lifecycle hook which consumes the role
1510             provided, automatically invoking the role's L hook as well as the
1511             L hook if defined.
1512              
1513             I>
1514              
1515             =over 4
1516              
1517             =item test example 1
1518              
1519             package Admin;
1520              
1521             use base 'Venus::Core';
1522              
1523             package IsAdmin;
1524              
1525             use base 'Venus::Core';
1526              
1527             sub shutdown {
1528             return;
1529             }
1530              
1531             sub AUDIT {
1532             my ($self, $from) = @_;
1533             die "${from} is not a super-user" if !$from->DOES('Admin');
1534             }
1535              
1536             sub EXPORT {
1537             ['shutdown']
1538             }
1539              
1540             package User;
1541              
1542             use base 'Venus::Core';
1543              
1544             User->ROLE('Admin');
1545              
1546             User->TEST('IsAdmin');
1547              
1548             package main;
1549              
1550             my $user = User->BLESS;
1551              
1552             # bless({}, 'User')
1553              
1554             =back
1555              
1556             =cut
1557              
1558             =head2 unimport
1559              
1560             UNIMPORT(Str $into, Any @args) (Any)
1561              
1562             The UNIMPORT method is a class building lifecycle hook which is invoked
1563             whenever the L declaration is used.
1564              
1565             I>
1566              
1567             =over 4
1568              
1569             =item unimport example 1
1570              
1571             package User;
1572              
1573             use base 'Venus::Core';
1574              
1575             package main;
1576              
1577             User->UNIMPORT;
1578              
1579             # 'User'
1580              
1581             =back
1582              
1583             =cut
1584              
1585             =head1 AUTHORS
1586              
1587             Awncorp, C
1588              
1589             =cut
1590              
1591             =head1 LICENSE
1592              
1593             Copyright (C) 2000, Al Newkirk.
1594              
1595             This program is free software, you can redistribute it and/or modify it under
1596             the terms of the Apache license version 2.0.
1597              
1598             =cut