File Coverage

blib/lib/Venus/Role.pm
Criterion Covered Total %
statement 102 126 80.9
branch 28 28 100.0
condition 30 36 83.3
subroutine 40 48 83.3
pod 6 6 100.0
total 206 244 84.4


line stmt bran cond sub pod time code
1             package Venus::Role;
2              
3 87     480   1505 use 5.018;
  87         311  
4              
5 87     212   447 use strict;
  87         154  
  87         1814  
6 87     211   450 use warnings;
  87         226  
  87         7076  
7              
8             # IMPORT
9              
10             sub import {
11 1966     1966   6575 my ($self, @args) = @_;
12              
13 1966         4601 my $from = caller;
14              
15 1966         42133 require Venus::Core::Role;
16              
17 87     203   674 no strict 'refs';
  87         226  
  87         4092  
18 87     87   547 no warnings 'redefine';
  87         241  
  87         3973  
19 87     87   535 no warnings 'once';
  87         195  
  87         115560  
20              
21 1966   33     20076 @args = grep defined && !ref && /^[A-Za-z]/, @args;
22              
23 1966 100       10875 my %exports = map +($_,$_), @args ? @args : qw(
24             attr
25             base
26             false
27             from
28             mixin
29             role
30             test
31             true
32             with
33             );
34              
35 1966         3890 @{"${from}::ISA"} = 'Venus::Core::Role';
  1966         45572  
36              
37 1966 100 100     10454 if ($exports{"attr"} && !*{"${from}::attr"}{"CODE"}) {
  178         1582  
38 104     189   633 *{"${from}::attr"} = sub {@_ = ($from, @_); goto \&attr};
  104         501  
  189         749  
  189         705  
39             }
40 1966 100 100     5211 if ($exports{"base"} && !*{"${from}::base"}{"CODE"}) {
  89         360  
41 15     0   58 *{"${from}::base"} = sub {@_ = ($from, @_); goto \&base};
  15         47  
  0         0  
  0         0  
42             }
43 1966 100 66     4661 if ($exports{"catch"} && !*{"${from}::catch"}{"CODE"}) {
  2         20  
44 2     16   12 *{"${from}::catch"} = sub (&) {require Venus; goto \&Venus::catch};
  2         10  
  16         87  
  16         60  
45             }
46 1966 100 66     4461 if ($exports{"error"} && !*{"${from}::error"}{"CODE"}) {
  2         17  
47 2     18   12 *{"${from}::error"} = sub (;$) {require Venus; goto \&Venus::error};
  2         9  
  2         13  
  2         14  
48             }
49 1966 100       2655 if (!*{"${from}::false"}{"CODE"}) {
  1966         14047  
50 1888     1177   10688 *{"${from}::false"} = sub {require Venus; Venus::false()};
  1888     1175   6669  
  1175     1175   4978  
  1175     1175   3669  
        1175      
        1175      
        1175      
        1062      
        938      
51             }
52 1966 100 66     6278 if ($exports{"fault"} && !*{"${from}::fault"}{"CODE"}) {
  662         3720  
53 662     724   2876 *{"${from}::fault"} = sub (;$) {require Venus; goto \&Venus::fault};
  662     724   1972  
  0         0  
  0         0  
54             }
55 1966 100 100     4726 if ($exports{"from"} && !*{"${from}::from"}{"CODE"}) {
  89         329  
56 15     451   103 *{"${from}::from"} = sub {@_ = ($from, @_); goto \&from};
  15         45  
  0         0  
  0         0  
57             }
58 1966 100 66     4322 if ($exports{"raise"} && !*{"${from}::raise"}{"CODE"}) {
  2         17  
59 2     350   11 *{"${from}::raise"} = sub ($;$) {require Venus; goto \&Venus::raise};
  2         8  
  2         15  
  2         13  
60             }
61 1966 100 100     4256 if ($exports{"mixin"} && !*{"${from}::mixin"}{"CODE"}) {
  89         320  
62 15     4   79 *{"${from}::mixin"} = sub {@_ = ($from, @_); goto \&mixin};
  15         45  
  2         6  
  2         9  
63             }
64 1966 100 100     4272 if ($exports{"role"} && !*{"${from}::role"}{"CODE"}) {
  89         354  
65 15     2   89 *{"${from}::role"} = sub {@_ = ($from, @_); goto \&role};
  15         54  
  0         0  
  0         0  
66             }
67 1966 100 100     4332 if ($exports{"test"} && !*{"${from}::test"}{"CODE"}) {
  89         343  
68 15     2   56 *{"${from}::test"} = sub {@_ = ($from, @_); goto \&test};
  15         39  
  0         0  
  0         0  
69             }
70 1966 100       2499 if (!*{"${from}::true"}{"CODE"}) {
  1966         8518  
71 1888     628   6217 *{"${from}::true"} = sub {require Venus; Venus::true()};
  1888     628   5203  
  628     628   2604  
  628     628   2115  
        628      
        628      
        628      
        628      
        628      
72             }
73 1966 100 100     5358 if ($exports{"with"} && !*{"${from}::with"}{"CODE"}) {
  1211         6650  
74 1137     568   5499 *{"${from}::with"} = sub {@_ = ($from, @_); goto \&test};
  1137     438   3428  
  0     169   0  
  0     0   0  
        0      
        0      
75             }
76              
77 1966         3536 ${"${from}::META"} = {};
  1966         8106  
78              
79 1966         3306 ${"${from}::@{[$from->METACACHE]}"} = undef;
  1966         3328  
  1966         17978  
80              
81 1966         684997 return $self;
82             }
83              
84             sub attr {
85 189     189 1 547 my ($from, @args) = @_;
86              
87 189         1138 $from->ATTR(@args);
88              
89 189         1980 return $from;
90             }
91              
92             sub base {
93 0     0 1 0 my ($from, @args) = @_;
94              
95 0         0 $from->BASE(@args);
96              
97 0         0 return $from;
98             }
99              
100             sub from {
101 0     0 1 0 my ($from, @args) = @_;
102              
103 0         0 $from->FROM(@args);
104              
105 0         0 return $from;
106             }
107              
108             sub mixin {
109 2     2 1 6 my ($from, @args) = @_;
110              
111 2         13 $from->MIXIN(@args);
112              
113 2         27 return $from;
114             }
115              
116             sub role {
117 0     0 1   my ($from, @args) = @_;
118              
119 0           $from->ROLE(@args);
120              
121 0           return $from;
122             }
123              
124             sub test {
125 0     0 1   my ($from, @args) = @_;
126              
127 0           $from->TEST(@args);
128              
129 0           return $from;
130             }
131              
132             1;
133              
134              
135              
136             =head1 NAME
137              
138             Venus::Role - Role Builder
139              
140             =cut
141              
142             =head1 ABSTRACT
143              
144             Role Builder for Perl 5
145              
146             =cut
147              
148             =head1 SYNOPSIS
149              
150             package Person;
151              
152             use Venus::Class 'attr';
153              
154             attr 'fname';
155             attr 'lname';
156              
157             package Identity;
158              
159             use Venus::Role 'attr';
160              
161             attr 'id';
162             attr 'login';
163             attr 'password';
164              
165             sub EXPORT {
166             # explicitly declare routines to be consumed
167             ['id', 'login', 'password']
168             }
169              
170             package Authenticable;
171              
172             use Venus::Role;
173              
174             sub authenticate {
175             return true;
176             }
177              
178             sub AUDIT {
179             my ($self, $from) = @_;
180             # ensure the caller has a login and password when consumed
181             die "${from} missing the login attribute" if !$from->can('login');
182             die "${from} missing the password attribute" if !$from->can('password');
183             }
184              
185             sub BUILD {
186             my ($self, $data) = @_;
187             $self->{auth} = undef;
188             return $self;
189             }
190              
191             sub EXPORT {
192             # explicitly declare routines to be consumed
193             ['authenticate']
194             }
195              
196             package User;
197              
198             use Venus::Class;
199              
200             base 'Person';
201              
202             with 'Identity';
203              
204             attr 'email';
205              
206             test 'Authenticable';
207              
208             sub valid {
209             my ($self) = @_;
210             return $self->login && $self->password ? true : false;
211             }
212              
213             package main;
214              
215             my $user = User->new(
216             fname => 'Elliot',
217             lname => 'Alderson',
218             );
219              
220             # bless({fname => 'Elliot', lname => 'Alderson'}, 'User')
221              
222             =cut
223              
224             =head1 DESCRIPTION
225              
226             This package provides a role builder which when used causes the consumer to
227             inherit from L which provides role construction and
228             lifecycle L. A role differs from a L<"class"|Venus::Class>
229             in that it can't be instantiated using the C method. A role can act as an
230             interface by defining an L<"audit"|Venus::Core/AUDIT> hook which is invoked
231             automatically by the L<"test"|Venus::Class/test> function.
232              
233             =cut
234              
235             =head1 FUNCTIONS
236              
237             This package provides the following functions:
238              
239             =cut
240              
241             =head2 attr
242              
243             attr(Str $name) (Str)
244              
245             The attr function creates attribute accessors for the calling package. This
246             function is always exported unless a routine of the same name already exists.
247              
248             I>
249              
250             =over 4
251              
252             =item attr example 1
253              
254             package Example;
255              
256             use Venus::Class;
257              
258             attr 'name';
259              
260             # "Example"
261              
262             =back
263              
264             =cut
265              
266             =head2 base
267              
268             base(Str $name) (Str)
269              
270             The base function registers one or more base classes for the calling package.
271             This function is always exported unless a routine of the same name already
272             exists.
273              
274             I>
275              
276             =over 4
277              
278             =item base example 1
279              
280             package Entity;
281              
282             use Venus::Class;
283              
284             sub output {
285             return;
286             }
287              
288             package Example;
289              
290             use Venus::Class;
291              
292             base 'Entity';
293              
294             # "Example"
295              
296             =back
297              
298             =cut
299              
300             =head2 catch
301              
302             catch(CodeRef $block) (Error, Any)
303              
304             The catch function executes the code block trapping errors and returning the
305             caught exception in scalar context, and also returning the result as a second
306             argument in list context. This function isn't export unless requested.
307              
308             I>
309              
310             =over 4
311              
312             =item catch example 1
313              
314             package Ability;
315              
316             use Venus::Role 'catch';
317              
318             sub attempt_catch {
319             catch {die};
320             }
321              
322             sub EXPORT {
323             ['attempt_catch']
324             }
325              
326             package Example;
327              
328             use Venus::Class 'with';
329              
330             with 'Ability';
331              
332             package main;
333              
334             my $example = Example->new;
335              
336             my $error = $example->attempt_catch;
337              
338             $error;
339              
340             # "Died at ..."
341              
342             =back
343              
344             =cut
345              
346             =head2 error
347              
348             error(Maybe[HashRef] $args) (Error)
349              
350             The error function throws a L exception object using the
351             exception object arguments provided. This function isn't export unless requested.
352              
353             I>
354              
355             =over 4
356              
357             =item error example 1
358              
359             package Ability;
360              
361             use Venus::Role 'error';
362              
363             sub attempt_error {
364             error;
365             }
366              
367             sub EXPORT {
368             ['attempt_error']
369             }
370              
371             package Example;
372              
373             use Venus::Class 'with';
374              
375             with 'Ability';
376              
377             package main;
378              
379             my $example = Example->new;
380              
381             my $error = $example->attempt_error;
382              
383             # bless({...}, 'Venus::Error')
384              
385             =back
386              
387             =cut
388              
389             =head2 false
390              
391             false() (Bool)
392              
393             The false function returns a falsy boolean value which is designed to be
394             practically indistinguishable from the conventional numerical C<0> value. This
395             function is always exported unless a routine of the same name already exists.
396              
397             I>
398              
399             =over 4
400              
401             =item false example 1
402              
403             package Example;
404              
405             use Venus::Class;
406              
407             my $false = false;
408              
409             # 0
410              
411             =back
412              
413             =over 4
414              
415             =item false example 2
416              
417             package Example;
418              
419             use Venus::Class;
420              
421             my $true = !false;
422              
423             # 1
424              
425             =back
426              
427             =cut
428              
429             =head2 from
430              
431             from(Str $name) (Str)
432              
433             The from function registers one or more base classes for the calling package
434             and performs an L<"audit"|Venus::Core/AUDIT>. This function is always exported
435             unless a routine of the same name already exists.
436              
437             I>
438              
439             =over 4
440              
441             =item from example 1
442              
443             package Entity;
444              
445             use Venus::Role;
446              
447             attr 'startup';
448             attr 'shutdown';
449              
450             sub EXPORT {
451             ['startup', 'shutdown']
452             }
453              
454             package Record;
455              
456             use Venus::Class;
457              
458             sub AUDIT {
459             my ($self, $from) = @_;
460             die "Missing startup" if !$from->can('startup');
461             die "Missing shutdown" if !$from->can('shutdown');
462             }
463              
464             package Example;
465              
466             use Venus::Class;
467              
468             with 'Entity';
469              
470             from 'Record';
471              
472             # "Example"
473              
474             =back
475              
476             =cut
477              
478             =head2 mixin
479              
480             mixin(Str $name) (Str)
481              
482             The mixin function registers and consumes mixins for the calling package. This
483             function is always exported unless a routine of the same name already exists.
484              
485             I>
486              
487             =over 4
488              
489             =item mixin example 1
490              
491             package YesNo;
492              
493             use Venus::Mixin;
494              
495             sub no {
496             return 0;
497             }
498              
499             sub yes {
500             return 1;
501             }
502              
503             sub EXPORT {
504             ['no', 'yes']
505             }
506              
507             package Answer;
508              
509             use Venus::Role;
510              
511             mixin 'YesNo';
512              
513             # "Answer"
514              
515             =back
516              
517             =over 4
518              
519             =item mixin example 2
520              
521             package YesNo;
522              
523             use Venus::Mixin;
524              
525             sub no {
526             return 0;
527             }
528              
529             sub yes {
530             return 1;
531             }
532              
533             sub EXPORT {
534             ['no', 'yes']
535             }
536              
537             package Answer;
538              
539             use Venus::Role;
540              
541             mixin 'YesNo';
542              
543             sub no {
544             return [0];
545             }
546              
547             sub yes {
548             return [1];
549             }
550              
551             my $package = "Answer";
552              
553             # "Answer"
554              
555             =back
556              
557             =cut
558              
559             =head2 raise
560              
561             raise(Str $class | Tuple[Str, Str] $class, Maybe[HashRef] $args) (Error)
562              
563             The raise function generates and throws a named exception object derived from
564             L, or provided base class, using the exception object arguments
565             provided. This function isn't export unless requested.
566              
567             I>
568              
569             =over 4
570              
571             =item raise example 1
572              
573             package Ability;
574              
575             use Venus::Role 'raise';
576              
577             sub attempt_raise {
578             raise 'Example::Error';
579             }
580              
581             sub EXPORT {
582             ['attempt_raise']
583             }
584              
585             package Example;
586              
587             use Venus::Class 'with';
588              
589             with 'Ability';
590              
591             package main;
592              
593             my $example = Example->new;
594              
595             my $error = $example->attempt_raise;
596              
597             # bless({...}, 'Example::Error')
598              
599             =back
600              
601             =cut
602              
603             =head2 role
604              
605             role(Str $name) (Str)
606              
607             The role function registers and consumes roles for the calling package. This
608             function is always exported unless a routine of the same name already exists.
609              
610             I>
611              
612             =over 4
613              
614             =item role example 1
615              
616             package Ability;
617              
618             use Venus::Role;
619              
620             sub action {
621             return;
622             }
623              
624             package Example;
625              
626             use Venus::Class;
627              
628             role 'Ability';
629              
630             # "Example"
631              
632             =back
633              
634             =over 4
635              
636             =item role example 2
637              
638             package Ability;
639              
640             use Venus::Role;
641              
642             sub action {
643             return;
644             }
645              
646             sub EXPORT {
647             return ['action'];
648             }
649              
650             package Example;
651              
652             use Venus::Class;
653              
654             role 'Ability';
655              
656             # "Example"
657              
658             =back
659              
660             =cut
661              
662             =head2 test
663              
664             test(Str $name) (Str)
665              
666             The test function registers and consumes roles for the calling package and
667             performs an L<"audit"|Venus::Core/AUDIT>, effectively allowing a role to act as
668             an interface. This function is always exported unless a routine of the same
669             name already exists.
670              
671             I>
672              
673             =over 4
674              
675             =item test example 1
676              
677             package Actual;
678              
679             use Venus::Role;
680              
681             package Example;
682              
683             use Venus::Class;
684              
685             test 'Actual';
686              
687             # "Example"
688              
689             =back
690              
691             =over 4
692              
693             =item test example 2
694              
695             package Actual;
696              
697             use Venus::Role;
698              
699             sub AUDIT {
700             die "Example is not an 'actual' thing" if $_[1]->isa('Example');
701             }
702              
703             package Example;
704              
705             use Venus::Class;
706              
707             test 'Actual';
708              
709             # "Example"
710              
711             =back
712              
713             =cut
714              
715             =head2 true
716              
717             true() (Bool)
718              
719             The true function returns a truthy boolean value which is designed to be
720             practically indistinguishable from the conventional numerical C<1> value. This
721             function is always exported unless a routine of the same name already exists.
722              
723             I>
724              
725             =over 4
726              
727             =item true example 1
728              
729             package Example;
730              
731             use Venus::Class;
732              
733             my $true = true;
734              
735             # 1
736              
737             =back
738              
739             =over 4
740              
741             =item true example 2
742              
743             package Example;
744              
745             use Venus::Class;
746              
747             my $false = !true;
748              
749             # 0
750              
751             =back
752              
753             =cut
754              
755             =head2 with
756              
757             with(Str $name) (Str)
758              
759             The with function registers and consumes roles for the calling package. This
760             function is an alias of the L function and will perform an
761             L<"audit"|Venus::Core/AUDIT> if present. This function is always exported
762             unless a routine of the same name already exists.
763              
764             I>
765              
766             =over 4
767              
768             =item with example 1
769              
770             package Understanding;
771              
772             use Venus::Role;
773              
774             sub knowledge {
775             return;
776             }
777              
778             package Example;
779              
780             use Venus::Class;
781              
782             with 'Understanding';
783              
784             # "Example"
785              
786             =back
787              
788             =over 4
789              
790             =item with example 2
791              
792             package Understanding;
793              
794             use Venus::Role;
795              
796             sub knowledge {
797             return;
798             }
799              
800             sub EXPORT {
801             return ['knowledge'];
802             }
803              
804             package Example;
805              
806             use Venus::Class;
807              
808             with 'Understanding';
809              
810             # "Example"
811              
812             =back
813              
814             =cut
815              
816             =head1 AUTHORS
817              
818             Awncorp, C
819              
820             =cut
821              
822             =head1 LICENSE
823              
824             Copyright (C) 2000, Al Newkirk.
825              
826             This program is free software, you can redistribute it and/or modify it under
827             the terms of the Apache license version 2.0.
828              
829             =cut