File Coverage

blib/lib/Venus/Class.pm
Criterion Covered Total %
statement 121 126 96.0
branch 27 28 96.4
condition 30 36 83.3
subroutine 48 49 97.9
pod 6 6 100.0
total 232 245 94.6


line stmt bran cond sub pod time code
1             package Venus::Class;
2              
3 87     6093   1485 use 5.018;
  87         315  
4              
5 87     2843   423 use strict;
  87         165  
  87         1762  
6 87     2030   444 use warnings;
  87         185  
  87         6773  
7              
8             # IMPORT
9              
10             sub import {
11 1307     1307   4963 my ($self, @args) = @_;
12              
13 1307         3374 my $from = caller;
14              
15 1307         40874 require Venus::Core::Class;
16              
17 87     920   654 no strict 'refs';
  87         223  
  87         3092  
18 87     87   510 no warnings 'redefine';
  87         158  
  87         4164  
19 87     87   594 no warnings 'once';
  87         165  
  87         117522  
20              
21 1307   33     16536 @args = grep defined && !ref && /^[A-Za-z]/, @args;
22              
23 1307 100       9999 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 1307         3034 @{"${from}::ISA"} = 'Venus::Core::Class';
  1307         31561  
36              
37 1307 100 100     8209 if ($exports{"attr"} && !*{"${from}::attr"}{"CODE"}) {
  652         5172  
38 469     1597   2694 *{"${from}::attr"} = sub {@_ = ($from, @_); goto \&attr};
  469     1490   1812  
  1597         4201  
  1597         4335  
39             }
40 1307 100 100     4316 if ($exports{"base"} && !*{"${from}::base"}{"CODE"}) {
  1186         7559  
41 1006     993   5531 *{"${from}::base"} = sub {@_ = ($from, @_); goto \&base};
  1006     916   3472  
  993         5003  
  993         5750  
42             }
43 1307 100 66     4314 if ($exports{"catch"} && !*{"${from}::catch"}{"CODE"}) {
  1         8  
44 1     72   5 *{"${from}::catch"} = sub (&) {require Venus; goto \&Venus::catch};
  1         4  
  1         4  
  1         6  
45             }
46 1307 100 100     3790 if ($exports{"error"} && !*{"${from}::error"}{"CODE"}) {
  4         28  
47 2     2   18 *{"${from}::error"} = sub (;$) {require Venus; goto \&Venus::error};
  2         9  
  1         4  
  1         6  
48             }
49 1307 100       1854 if (!*{"${from}::false"}{"CODE"}) {
  1307         6443  
50 1115     9142   4147 *{"${from}::false"} = sub {require Venus; Venus::false()};
  1115     9141   3226  
  9141     9141   32447  
  9141     9141   27737  
        9072      
        8958      
        8403      
        7626      
        6148      
51             }
52 1307 50 33     4023 if ($exports{"fault"} && !*{"${from}::fault"}{"CODE"}) {
  0         0  
53 0     0   0 *{"${from}::fault"} = sub (;$) {require Venus; goto \&Venus::fault};
  0         0  
  0         0  
  0         0  
54             }
55 1307 100 100     3429 if ($exports{"from"} && !*{"${from}::from"}{"CODE"}) {
  236         1104  
56 87     2   442 *{"${from}::from"} = sub {@_ = ($from, @_); goto \&from};
  87         309  
  2         8  
  2         9  
57             }
58 1307 100 66     3374 if ($exports{"raise"} && !*{"${from}::raise"}{"CODE"}) {
  2         16  
59 2     4   10 *{"${from}::raise"} = sub ($;$) {require Venus; goto \&Venus::raise};
  2         8  
  2         19  
  2         12  
60             }
61 1307 100 100     3226 if ($exports{"mixin"} && !*{"${from}::mixin"}{"CODE"}) {
  268         1118  
62 88     38   520 *{"${from}::mixin"} = sub {@_ = ($from, @_); goto \&mixin};
  88         286  
  35         135  
  35         124  
63             }
64 1307 100 100     3260 if ($exports{"role"} && !*{"${from}::role"}{"CODE"}) {
  236         1025  
65 87     40   439 *{"${from}::role"} = sub {@_ = ($from, @_); goto \&role};
  87         312  
  4         15  
  4         16  
66             }
67 1307 100 100     3493 if ($exports{"test"} && !*{"${from}::test"}{"CODE"}) {
  268         1182  
68 88     77   452 *{"${from}::test"} = sub {@_ = ($from, @_); goto \&test};
  88         275  
  39         133  
  39         111  
69             }
70 1307 100       1794 if (!*{"${from}::true"}{"CODE"}) {
  1307         5570  
71 1115     1802   3612 *{"${from}::true"} = sub {require Venus; Venus::true()};
  1115     1802   3034  
  1759     1762   7669  
  1759     1759   4860  
        1759      
        1724      
        1673      
        1555      
        1373      
72             }
73 1307 100 100     4153 if ($exports{"with"} && !*{"${from}::with"}{"CODE"}) {
  916         4623  
74 728     4251   3115 *{"${from}::with"} = sub {@_ = ($from, @_); goto \&test};
  728     3441   2118  
  3100     3100   8666  
  3100     3042   9495  
        2776      
        2087      
75             }
76              
77 1307         2675 ${"${from}::META"} = {};
  1307         5633  
78              
79 1307         2753 ${"${from}::@{[$from->METACACHE]}"} = undef;
  1307         2508  
  1307         11106  
80              
81 1307         560016 return $self;
82             }
83              
84             sub attr {
85 1597     2648 1 3531 my ($from, @args) = @_;
86              
87 1597         6187 $from->ATTR(@args);
88              
89 1597         7917 return $from;
90             }
91              
92             sub base {
93 993     1354 1 3447 my ($from, @args) = @_;
94              
95 993         9695 $from->BASE(@args);
96              
97 993         4401 return $from;
98             }
99              
100             sub from {
101 2     80 1 6 my ($from, @args) = @_;
102              
103 2         15 $from->FROM(@args);
104              
105 2         20 return $from;
106             }
107              
108             sub mixin {
109 35     35 1 95 my ($from, @args) = @_;
110              
111 35         169 $from->MIXIN(@args);
112              
113 35         658 return $from;
114             }
115              
116             sub role {
117 4     4 1 13 my ($from, @args) = @_;
118              
119 4         27 $from->ROLE(@args);
120              
121 4         32 return $from;
122             }
123              
124             sub test {
125 3139     3139 1 7081 my ($from, @args) = @_;
126              
127 3139         11878 $from->TEST(@args);
128              
129 3137         11704 return $from;
130             }
131              
132             1;
133              
134              
135              
136             =head1 NAME
137              
138             Venus::Class - Class Builder
139              
140             =cut
141              
142             =head1 ABSTRACT
143              
144             Class 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 class builder which when used causes the consumer to
227             inherit from L which provides object construction and
228             lifecycle L.
229              
230             =cut
231              
232             =head1 FUNCTIONS
233              
234             This package provides the following functions:
235              
236             =cut
237              
238             =head2 attr
239              
240             attr(Str $name) (Str)
241              
242             The attr function creates attribute accessors for the calling package. This
243             function is always exported unless a routine of the same name already exists.
244              
245             I>
246              
247             =over 4
248              
249             =item attr example 1
250              
251             package Example;
252              
253             use Venus::Class;
254              
255             attr 'name';
256              
257             # "Example"
258              
259             =back
260              
261             =cut
262              
263             =head2 base
264              
265             base(Str $name) (Str)
266              
267             The base function registers one or more base classes for the calling package.
268             This function is always exported unless a routine of the same name already
269             exists.
270              
271             I>
272              
273             =over 4
274              
275             =item base example 1
276              
277             package Entity;
278              
279             use Venus::Class;
280              
281             sub output {
282             return;
283             }
284              
285             package Example;
286              
287             use Venus::Class;
288              
289             base 'Entity';
290              
291             # "Example"
292              
293             =back
294              
295             =cut
296              
297             =head2 catch
298              
299             catch(CodeRef $block) (Error, Any)
300              
301             The catch function executes the code block trapping errors and returning the
302             caught exception in scalar context, and also returning the result as a second
303             argument in list context. This function isn't export unless requested.
304              
305             I>
306              
307             =over 4
308              
309             =item catch example 1
310              
311             package Example;
312              
313             use Venus::Class 'catch';
314              
315             sub attempt {
316             catch {die};
317             }
318              
319             package main;
320              
321             my $example = Example->new;
322              
323             my $error = $example->attempt;
324              
325             $error;
326              
327             # "Died at ..."
328              
329             =back
330              
331             =cut
332              
333             =head2 error
334              
335             error(Maybe[HashRef] $args) (Error)
336              
337             The error function throws a L exception object using the
338             exception object arguments provided. This function isn't export unless requested.
339              
340             I>
341              
342             =over 4
343              
344             =item error example 1
345              
346             package Example;
347              
348             use Venus::Class 'error';
349              
350             sub attempt {
351             error;
352             }
353              
354             package main;
355              
356             my $example = Example->new;
357              
358             my $error = $example->attempt;
359              
360             # bless({...}, 'Venus::Error')
361              
362             =back
363              
364             =cut
365              
366             =head2 false
367              
368             false() (Bool)
369              
370             The false function returns a falsy boolean value which is designed to be
371             practically indistinguishable from the conventional numerical C<0> value. This
372             function is always exported unless a routine of the same name already exists.
373              
374             I>
375              
376             =over 4
377              
378             =item false example 1
379              
380             package Example;
381              
382             use Venus::Class;
383              
384             my $false = false;
385              
386             # 0
387              
388             =back
389              
390             =cut
391              
392             =head2 from
393              
394             from(Str $name) (Str)
395              
396             The from function registers one or more base classes for the calling package
397             and performs an L<"audit"|Venus::Core/AUDIT>. This function is always exported
398             unless a routine of the same name already exists.
399              
400             I>
401              
402             =over 4
403              
404             =item from example 1
405              
406             package Entity;
407              
408             use Venus::Class;
409              
410             sub AUDIT {
411             my ($self, $from) = @_;
412             die "Missing startup" if !$from->can('startup');
413             die "Missing shutdown" if !$from->can('shutdown');
414             }
415              
416             package Example;
417              
418             use Venus::Class;
419              
420             attr 'startup';
421             attr 'shutdown';
422              
423             from 'Entity';
424              
425             # "Example"
426              
427             =back
428              
429             =cut
430              
431             =head2 mixin
432              
433             mixin(Str $name) (Str)
434              
435             The mixin function registers and consumes mixins for the calling package. This
436             function is always exported unless a routine of the same name already exists.
437              
438             I>
439              
440             =over 4
441              
442             =item mixin example 1
443              
444             package YesNo;
445              
446             use Venus::Mixin;
447              
448             sub no {
449             return 0;
450             }
451              
452             sub yes {
453             return 1;
454             }
455              
456             sub EXPORT {
457             ['no', 'yes']
458             }
459              
460             package Answer;
461              
462             use Venus::Class;
463              
464             mixin 'YesNo';
465              
466             # "Answer"
467              
468             =back
469              
470             =over 4
471              
472             =item mixin example 2
473              
474             package YesNo;
475              
476             use Venus::Mixin;
477              
478             sub no {
479             return 0;
480             }
481              
482             sub yes {
483             return 1;
484             }
485              
486             sub EXPORT {
487             ['no', 'yes']
488             }
489              
490             package Answer;
491              
492             use Venus::Class;
493              
494             mixin 'YesNo';
495              
496             sub no {
497             return [0];
498             }
499              
500             sub yes {
501             return [1];
502             }
503              
504             my $package = "Answer";
505              
506             # "Answer"
507              
508             =back
509              
510             =cut
511              
512             =head2 raise
513              
514             raise(Str $class | Tuple[Str, Str] $class, Maybe[HashRef] $args) (Error)
515              
516             The raise function generates and throws a named exception object derived from
517             L, or provided base class, using the exception object arguments
518             provided. This function isn't export unless requested.
519              
520             I>
521              
522             =over 4
523              
524             =item raise example 1
525              
526             package Example;
527              
528             use Venus::Class 'raise';
529              
530             sub attempt {
531             raise 'Example::Error';
532             }
533              
534             package main;
535              
536             my $example = Example->new;
537              
538             my $error = $example->attempt;
539              
540             # bless({...}, 'Example::Error')
541              
542             =back
543              
544             =cut
545              
546             =head2 role
547              
548             role(Str $name) (Str)
549              
550             The role function registers and consumes roles for the calling package. This
551             function is always exported unless a routine of the same name already exists.
552              
553             I>
554              
555             =over 4
556              
557             =item role example 1
558              
559             package Ability;
560              
561             use Venus::Role;
562              
563             sub action {
564             return;
565             }
566              
567             package Example;
568              
569             use Venus::Class;
570              
571             role 'Ability';
572              
573             # "Example"
574              
575             =back
576              
577             =over 4
578              
579             =item role example 2
580              
581             package Ability;
582              
583             use Venus::Role;
584              
585             sub action {
586             return;
587             }
588              
589             sub EXPORT {
590             return ['action'];
591             }
592              
593             package Example;
594              
595             use Venus::Class;
596              
597             role 'Ability';
598              
599             # "Example"
600              
601             =back
602              
603             =cut
604              
605             =head2 test
606              
607             test(Str $name) (Str)
608              
609             The test function registers and consumes roles for the calling package and
610             performs an L<"audit"|Venus::Core/AUDIT>, effectively allowing a role to act as
611             an interface. This function is always exported unless a routine of the same
612             name already exists.
613              
614             I>
615              
616             =over 4
617              
618             =item test example 1
619              
620             package Actual;
621              
622             use Venus::Role;
623              
624             package Example;
625              
626             use Venus::Class;
627              
628             test 'Actual';
629              
630             # "Example"
631              
632             =back
633              
634             =over 4
635              
636             =item test example 2
637              
638             package Actual;
639              
640             use Venus::Role;
641              
642             sub AUDIT {
643             die "Example is not an 'actual' thing" if $_[1]->isa('Example');
644             }
645              
646             package Example;
647              
648             use Venus::Class;
649              
650             test 'Actual';
651              
652             # "Example"
653              
654             =back
655              
656             =cut
657              
658             =head2 true
659              
660             true() (Bool)
661              
662             The true function returns a truthy boolean value which is designed to be
663             practically indistinguishable from the conventional numerical C<1> value. This
664             function is always exported unless a routine of the same name already exists.
665              
666             I>
667              
668             =over 4
669              
670             =item true example 1
671              
672             package Example;
673              
674             use Venus::Class;
675              
676             my $true = true;
677              
678             # 1
679              
680             =back
681              
682             =over 4
683              
684             =item true example 2
685              
686             package Example;
687              
688             use Venus::Class;
689              
690             my $false = !true;
691              
692             # 0
693              
694             =back
695              
696             =cut
697              
698             =head2 with
699              
700             with(Str $name) (Str)
701              
702             The with function registers and consumes roles for the calling package. This
703             function is an alias of the L function and will perform an
704             L<"audit"|Venus::Core/AUDIT> if present. This function is always exported
705             unless a routine of the same name already exists.
706              
707             I>
708              
709             =over 4
710              
711             =item with example 1
712              
713             package Understanding;
714              
715             use Venus::Role;
716              
717             sub knowledge {
718             return;
719             }
720              
721             package Example;
722              
723             use Venus::Class;
724              
725             with 'Understanding';
726              
727             # "Example"
728              
729             =back
730              
731             =over 4
732              
733             =item with example 2
734              
735             package Understanding;
736              
737             use Venus::Role;
738              
739             sub knowledge {
740             return;
741             }
742              
743             sub EXPORT {
744             return ['knowledge'];
745             }
746              
747             package Example;
748              
749             use Venus::Class;
750              
751             with 'Understanding';
752              
753             # "Example"
754              
755             =back
756              
757             =cut
758              
759             =head1 AUTHORS
760              
761             Awncorp, C
762              
763             =cut
764              
765             =head1 LICENSE
766              
767             Copyright (C) 2000, Al Newkirk.
768              
769             This program is free software, you can redistribute it and/or modify it under
770             the terms of the Apache license version 2.0.
771              
772             =cut