File Coverage

blib/lib/Venus/Role/Optional.pm
Criterion Covered Total %
statement 176 194 90.7
branch 83 100 83.0
condition 33 48 68.7
subroutine 28 28 100.0
pod 3 21 14.2
total 323 391 82.6


line stmt bran cond sub pod time code
1             package Venus::Role::Optional;
2              
3 1     1   20 use 5.018;
  1         4  
4              
5 1     1   6 use strict;
  1         3  
  1         25  
6 1     1   4 use warnings;
  1         3  
  1         35  
7              
8 1     1   6 use Venus::Role 'catch', 'error', 'with';
  1         2  
  1         8  
9              
10             # METHODS
11              
12             sub clear {
13 8     8 1 20 my ($self, $name) = @_;
14              
15 8 50       20 return if !$name;
16              
17 8         42 return delete $self->{$name};
18             }
19              
20             sub has {
21 2     2 1 7 my ($self, $name) = @_;
22              
23 2 50       6 return if !$name;
24              
25 2 100       11 return exists $self->{$name} ? true : false;
26             }
27              
28             sub reset {
29 5     5 1 17 my ($self, $name, @data) = @_;
30              
31 5 50 33     36 return if !$name || !$self->can($name);
32              
33 5         16 my $value = $self->clear($name);
34              
35 5         22 $self->$name(@data);
36              
37 5         58 return $value;
38             }
39              
40             # BUILDERS
41              
42             sub BUILD {
43 46     46 0 121 my ($self, $data) = @_;
44              
45 46         84 for my $name (@{$self->META->attrs}) {
  46         104  
46 102 100       461 my @data = (exists $data->{$name} ? $data->{$name} : ());
47              
48             # option: default
49 102         265 option_default($self, $name, @data);
50              
51             # option: initial
52 102         230 option_initial($self, $name, @data);
53              
54             # option: require
55 102         246 option_require($self, $name, @data);
56              
57             # option: build
58 100 100       258 @data = option_builder($self, $name, @data) if exists $data->{$name};
59              
60             # option: coerce
61 100 100       251 @data = option_coerce($self, $name, @data) if exists $data->{$name};
62              
63             # option: self-coerce
64 100 100       291 @data = option_self_coerce($self, $name, @data) if exists $data->{$name};
65              
66             # option: check
67 100         231 option_check($self, $name, @data);
68              
69             # option: self-assert
70 100         223 option_self_assert($self, $name, @data);
71              
72             # option: assert
73 97         194 option_assert($self, $name, @data);
74             }
75              
76 38         129 return $self;
77             }
78              
79             # EXTENSIONS
80              
81             sub ITEM {
82 79     79 0 202 my ($self, $name, @data) = @_;
83              
84 79         129 my $value;
85              
86 79 50       211 return undef if !$name;
87              
88 79 100       304 @data = (!@data ? READ($self, $name, @data) : WRITE($self, $name, @data));
89              
90             # option: check
91 77         219 option_check($self, $name, @data);
92              
93             # option: self-assert
94 76         190 option_self_assert($self, $name, @data);
95              
96             # option: assert
97 76         183 option_assert($self, $name, @data);
98              
99             # option: trigger
100 76         204 option_trigger($self, $name, @data);
101              
102 76         474 return $data[0];
103             }
104              
105             sub READ {
106 68     68   140 my ($self, $name, @data) = @_;
107              
108             # option: default
109 68         186 option_default($self, $name, @data);
110              
111             # option: builder
112 68         197 option_builder($self, $name, @data);
113              
114             # option: lazy-builder
115 68         564 option_lazy_builder($self, $name, @data);
116              
117             # option: coerce
118 68         186 option_coerce($self, $name, @data);
119              
120             # option: self-coerce
121 68         198 option_self_coerce($self, $name, @data);
122              
123             # option: reader
124 68         156 return option_reader($self, $name, @data);
125             }
126              
127             sub WRITE {
128 11     11   36 my ($self, $name, @data) = @_;
129              
130             # option: readwrite
131 11         45 option_readwrite($self, $name, @data);
132              
133             # option: readonly
134 10         32 option_readonly($self, $name, @data);
135              
136             # option: builder
137 9         28 @data = option_builder($self, $name, @data);
138              
139             # option: lazy-builder
140 9         32 @data = option_lazy_builder($self, $name, @data);
141              
142             # option: coerce
143 9         19 @data = option_coerce($self, $name, @data);
144              
145             # option: self-coerce
146 9         28 @data = option_self_coerce($self, $name, @data);
147              
148             # option: writer
149 9         25 return option_writer($self, $name, @data);
150             }
151              
152             # EXPORTS
153              
154             sub EXPORT {
155 41     41 0 168 ['clear', 'has', 'ITEM', 'reset']
156             }
157              
158             # OPTIONS
159              
160             sub option_assert {
161 173     173 0 323 my ($self, $name, @data) = @_;
162              
163 173 100 66     700 if ((my $code = $self->can("assert_${name}")) && @data) {
164 12         65 require Scalar::Util;
165 12         1113 require Venus::Assert;
166 12         39 my $from = ref $self;
167 12         30 my $label = qq(attribute "$name" in $from);
168 12         73 my $assert = Venus::Assert->new($label);
169 12 50       38 my $value = @data ? $data[0] : $self->{$name};
170 12         308 my $return = $code->($self, $value, $assert);
171 12 50       68 if (Scalar::Util::blessed($return)) {
    50          
172 0 0       0 if ($return->isa('Venus::Assert')) {
173 0         0 $return->validate($value);
174             }
175             else {
176 0         0 require Venus::Throw;
177 0         0 my $throw = Venus::Throw->new(join('::', map ucfirst, ref($self), 'error'));
178 0         0 $throw->name('on.assert');
179 0         0 $throw->message("Invalid return value: \"assert_$name\" in $self");
180 0         0 $throw->stash(data => $value);
181 0         0 $throw->stash(name => $name);
182 0         0 $throw->stash(self => $self);
183 0         0 $throw->error;
184             }
185             }
186             elsif (length($return)) {
187 12         38 $assert->name($label);
188 12         50 $assert->expression($return)->validate($value);
189             }
190             else {
191 0         0 require Venus::Throw;
192 0         0 my $throw = Venus::Throw->new(join('::', map ucfirst, ref($self), 'error'));
193 0         0 $throw->name('on.assert');
194 0         0 $throw->message("Invalid return value: \"assert_$name\" in $self");
195 0         0 $throw->stash(data => $value);
196 0         0 $throw->stash(name => $name);
197 0         0 $throw->stash(self => $self);
198 0         0 $throw->error;
199             }
200             }
201 170         367 return;
202             }
203              
204             sub option_builder {
205 146     146 0 259 my ($self, $name, @data) = @_;
206              
207 146 100       590 if (my $code = $self->can("build_${name}")) {
208 24 100       608 my @return = $code->($self, (@data ? @data : $self->{$name}));
209 24 50       83 $self->{$name} = $return[0] if @return;
210             }
211 146 100       470 return @data ? $data[0] : ();
212             }
213              
214             sub option_check {
215 177     177 0 312 my ($self, $name, @data) = @_;
216              
217 177 100 66     714 if ((my $code = $self->can("check_${name}")) && @data) {
218 8         44 require Venus::Throw;
219 8         67 my $throw = Venus::Throw->new(join('::', map ucfirst, ref($self), 'error'));
220 8         33 $throw->name('on.check');
221 8         39 $throw->message("Checking attribute value failed: \"$name\" in $self");
222 8         31 $throw->stash(data => [@data]);
223 8         24 $throw->stash(name => $name);
224 8         22 $throw->stash(self => $self);
225 8 100       193 if (!$code->($self, @data)) {
226 1         7 $throw->error;
227             }
228             }
229 176         324 return;
230             }
231              
232             sub option_coerce {
233 146     146 0 282 my ($self, $name, @data) = @_;
234              
235 146 100 100     718 if ((my $code = $self->can("coerce_${name}")) && (@data || exists $self->{$name})) {
      100        
236 24         129 require Scalar::Util;
237 24         84 require Venus::Space;
238 24 100       68 my $value = @data ? $data[0] : $self->{$name};
239 24         548 my $return = $code->($self, @data);
240 24         119 my $package = Venus::Space->new($return)->load;
241 24 50 33     96 my $method = $package->can('DOES')
242             && $package->DOES('Venus::Role::Assertable') ? 'make' : 'new';
243 24 100 33     240 return $self->{$name} = $package->$method($value)
      66        
244             if !Scalar::Util::blessed($value)
245             || (Scalar::Util::blessed($value) && !$value->isa($return));
246             }
247 131 100       389 return @data ? $data[0] : ();
248             }
249              
250             sub option_default {
251 170     170 0 318 my ($self, $name, @data) = @_;
252              
253 170 100 66     846 if ((my $code = $self->can("default_${name}")) && !@data) {
254 16 100       189 $self->{$name} = $code->($self, @data) if !exists $self->{$name};
255             }
256 170         325 return;
257             }
258              
259             sub option_initial {
260 102     102 0 186 my ($self, $name, @data) = @_;
261              
262 102 100       382 if ((my $code = $self->can("initial_${name}"))) {
263 1         25 $self->{$name} = $code->($self, @data);
264             }
265 102         179 return;
266             }
267              
268             sub option_lazy_builder {
269 77     77 0 157 my ($self, $name, @data) = @_;
270              
271 77 100       375 if (my $code = $self->can("lazy_build_${name}")) {
272 4 50       112 my @return = $code->($self, (@data ? @data : $self->{$name}));
273 4 50       16 $self->{$name} = $return[0] if @return;
274             }
275 77 100       224 return @data ? $data[0] : ();
276             }
277              
278             sub option_reader {
279 68     68 0 130 my ($self, $name, @data) = @_;
280              
281 68 100 66     363 if ((my $code = $self->can("read_${name}")) && !@data) {
282 2         54 return $code->($self, @data);
283             }
284             else {
285 66         207 return $self->{$name};
286             }
287             }
288              
289             sub option_readonly {
290 10     10 0 24 my ($self, $name, @data) = @_;
291              
292 10 100 66     90 if (my $code = ($self->can("readonly_${name}") || $self->can("readonly"))) {
293 1         6 require Venus::Throw;
294 1         14 my $throw = Venus::Throw->new(join('::', map ucfirst, ref($self), 'error'));
295 1         6 $throw->name('on.readonly');
296 1         8 $throw->message("Setting read-only attribute: \"$name\" in $self");
297 1         5 $throw->stash(data => $data[0]);
298 1         5 $throw->stash(name => $name);
299 1         5 $throw->stash(self => $self);
300 1 50       24 if ($code->($self, @data)) {
301 1         5 $throw->error;
302             }
303             }
304 9         17 return;
305             }
306              
307             sub option_readwrite {
308 11     11 0 37 my ($self, $name, @data) = @_;
309              
310 11 100 66     133 if (my $code = ($self->can("readwrite_${name}") || $self->can("readwrite"))) {
311 1         7 require Venus::Throw;
312 1         16 my $throw = Venus::Throw->new(join('::', map ucfirst, ref($self), 'error'));
313 1         11 $throw->name('on.readwrite');
314 1         12 $throw->message("Setting read-only attribute: \"$name\" in $self");
315 1         10 $throw->stash(data => $data[0]);
316 1         5 $throw->stash(name => $name);
317 1         4 $throw->stash(self => $self);
318 1 50       27 if (!$code->($self, @data)) {
319 1         6 $throw->error;
320             }
321             }
322 10         24 return;
323             }
324              
325             sub option_require {
326 102     102 0 184 my ($self, $name, @data) = @_;
327              
328 102 100       390 if (my $code = $self->can("require_${name}")) {
329 6         29 require Venus::Throw;
330 6         54 my $throw = Venus::Throw->new(join('::', map ucfirst, ref($self), 'error'));
331 6         25 $throw->name('on.require');
332 6         37 $throw->message("Missing required attribute: \"$name\" in $self");
333 6         20 $throw->stash(data => [@data]);
334 6         20 $throw->stash(name => $name);
335 6         17 $throw->stash(self => $self);
336 6 100 100     145 if ($code->($self, @data) && !@data) {
337 2         15 $throw->error;
338             }
339             }
340 100         168 return;
341             }
342              
343             sub option_self_assert {
344 176     176 0 384 my ($self, $name, @data) = @_;
345              
346 176 100 100     719 if ((my $code = $self->can("self_assert_${name}")) && @data) {
347 15 50   15   99 if (my $error = catch {$code->($self, (@data ? $data[0] : $self->{$name}))}) {
  15 100       385  
348 3 100       6 if (do {require Scalar::Util; Scalar::Util::blessed($error)}) {
  3         12  
  3         18  
349 2 100       22 return $error->isa('Venus::Error') ? $error->throw : die $error;
350             }
351             else {
352 1         7 return error {message => $error};
353             }
354             }
355             }
356 173         313 return;
357             }
358              
359             sub option_self_coerce {
360 146     146 0 264 my ($self, $name, @data) = @_;
361              
362 146 50 66     598 if ((my $code = $self->can("self_coerce_${name}")) && (@data || exists $self->{$name})) {
      66        
363 10 100       253 return $self->{$name} = $code->($self, @data ? $data[0] : $self->{$name});
364             }
365 136 100       361 return @data ? $data[0] : ();
366             }
367              
368             sub option_trigger {
369 76     76 0 161 my ($self, $name, @data) = @_;
370              
371 76 100       346 if (my $code = $self->can("trigger_${name}")) {
372 2         55 $code->($self, @data);
373             }
374 76         131 return;
375             }
376              
377             sub option_writer {
378 9     9 0 26 my ($self, $name, @data) = @_;
379              
380 9 100       47 if (my $code = $self->can("write_${name}")) {
381 2         55 return $code->($self, @data);
382             }
383             else {
384 7         27 return $self->{$name} = $data[0];
385             }
386             }
387              
388             1;
389              
390              
391              
392             =head1 NAME
393              
394             Venus::Role::Optional - Optional Role
395              
396             =cut
397              
398             =head1 ABSTRACT
399              
400             Optional Role for Perl 5
401              
402             =cut
403              
404             =head1 SYNOPSIS
405              
406             package Person;
407              
408             use Venus::Class;
409              
410             with 'Venus::Role::Optional';
411              
412             attr 'fname';
413             attr 'lname';
414             attr 'email';
415              
416             package main;
417              
418             my $person = Person->new(
419             fname => 'Elliot',
420             lname => 'Alderson',
421             );
422              
423             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
424              
425             =cut
426              
427             =head1 DESCRIPTION
428              
429             This package modifies the consuming package and provides methods for automating
430             object construction and attribute accessors.
431              
432             =cut
433              
434             =head1 METHODS
435              
436             This package provides the following methods:
437              
438             =cut
439              
440             =head2 clear
441              
442             clear(Str $name) (Any)
443              
444             The clear method deletes an attribute and returns the removed value.
445              
446             I>
447              
448             =over 4
449              
450             =item clear example 1
451              
452             # given: synopsis
453              
454             package main;
455              
456             my $fname = $person->clear('fname');
457              
458             # "Elliot"
459              
460             =back
461              
462             =over 4
463              
464             =item clear example 2
465              
466             # given: synopsis
467              
468             package main;
469              
470             my $lname = $person->clear('lname');
471              
472             # "Alderson"
473              
474             my $object = $person;
475              
476             # bless({fname => "Elliot"}, "Person")
477              
478             =back
479              
480             =over 4
481              
482             =item clear example 3
483              
484             # given: synopsis
485              
486             package main;
487              
488             my $lname = $person->clear('lname');
489              
490             # "Alderson"
491              
492             =back
493              
494             =cut
495              
496             =head2 has
497              
498             has(Str $name) (Boolean)
499              
500             The has method returns truthy if the attribute specified exists, otherwise
501             returns falsy.
502              
503             I>
504              
505             =over 4
506              
507             =item has example 1
508              
509             # given: synopsis
510              
511             package main;
512              
513             my $has_fname = $person->has('fname');
514              
515             # true
516              
517             =back
518              
519             =over 4
520              
521             =item has example 2
522              
523             # given: synopsis
524              
525             package main;
526              
527             my $has_mname = $person->has('mname');
528              
529             # false
530              
531             =back
532              
533             =cut
534              
535             =head2 reset
536              
537             reset(Str $name) (Any)
538              
539             The reset method rebuilds an attribute and returns the deleted value.
540              
541             I>
542              
543             =over 4
544              
545             =item reset example 1
546              
547             # given: synopsis
548              
549             package main;
550              
551             my $fname = $person->reset('fname');
552              
553             # "Elliot"
554              
555             =back
556              
557             =over 4
558              
559             =item reset example 2
560              
561             # given: synopsis
562              
563             package main;
564              
565             my $lname = $person->reset('lname');
566              
567             # "Alderson"
568              
569             my $object = $person;
570              
571             # bless({fname => "Elliot"}, "Person")
572              
573             =back
574              
575             =over 4
576              
577             =item reset example 3
578              
579             # given: synopsis
580              
581             package main;
582              
583             my $lname = $person->reset('lname', 'Smith');
584              
585             # "Alderson"
586              
587             my $object = $person;
588              
589             # bless({fname => "Elliot", lname => "Smith"}, "Person")
590              
591             =back
592              
593             =cut
594              
595             =head1 FEATURES
596              
597             This package provides the following features:
598              
599             =cut
600              
601             =over 4
602              
603             =item asserting
604              
605             This library provides a mechanism for automatically validating class attributes
606             using L based on the return value of the attribute callback. The
607             callback should be in the form of C, and should return a
608             L object or a "validation expression" (string) to be passed to
609             the L method.
610              
611             B
612              
613             package Person;
614              
615             use Venus::Class;
616              
617             with 'Venus::Role::Optional';
618              
619             attr 'fname';
620             attr 'lname';
621             attr 'email';
622              
623             sub assert_fname {
624             return 'string';
625             }
626              
627             sub assert_lname {
628             return 'string';
629             }
630              
631             package main;
632              
633             my $person = Person->new(
634             fname => 'Elliot',
635             lname => 'Alderson',
636             );
637              
638             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
639              
640             B
641              
642             package Person;
643              
644             use Venus::Class;
645              
646             with 'Venus::Role::Optional';
647              
648             attr 'fname';
649             attr 'lname';
650             attr 'email';
651              
652             sub assert_fname {
653             return 'string';
654             }
655              
656             sub assert_lname {
657             return 'string';
658             }
659              
660             package main;
661              
662             my $person = Person->new(
663             fname => 'Elliot',
664             lname => 1234567890,
665             );
666              
667             # Exception! (isa Venus::Assert::Error)
668              
669             B
670              
671             package Person;
672              
673             use Venus::Class;
674              
675             with 'Venus::Role::Optional';
676              
677             attr 'fname';
678             attr 'lname';
679             attr 'email';
680              
681             sub assert_fname {
682             return 'string';
683             }
684              
685             sub assert_lname {
686             return 'string';
687             }
688              
689             package main;
690              
691             my $person = Person->new(
692             fname => 1234567890,
693             lname => 'Alderson',
694             );
695              
696             # Exception! (isa Venus::Assert::Error)
697              
698             B
699              
700             package Person;
701              
702             use Venus::Class;
703              
704             with 'Venus::Role::Optional';
705              
706             attr 'progress';
707              
708             sub assert_progress {
709             return 'number | float';
710             }
711              
712             package main;
713              
714             my $person = Person->new(
715             progress => 1,
716             );
717              
718             # bless({progress => 1}, 'Person')
719              
720             # my $person = Person->new(
721             # progress => 7.89,
722             # );
723              
724             # bless({progress => 7.89}, 'Person')
725              
726             # my $person = Person->new(
727             # progress => '1',
728             # );
729              
730             # Exception! (isa Venus::Assert::Error)
731              
732             =back
733              
734             =over 4
735              
736             =item building
737              
738             This library provides a mechanism for automatically building class attributes
739             on construction, and during getting and setting its value, after any default
740             values are processed, based on the return value of the attribute callback. The
741             callback should be in the form of C, and is passed any arguments
742             provided.
743              
744             B
745              
746             package Person;
747              
748             use Venus::Class;
749              
750             with 'Venus::Role::Optional';
751              
752             attr 'fname';
753             attr 'lname';
754             attr 'email';
755              
756             sub build_fname {
757             my ($self, $value) = @_;
758             return $value ? ucfirst $value : undef;
759             }
760              
761             sub build_lname {
762             my ($self, $value) = @_;
763             return $value ? ucfirst $value : undef;
764             }
765              
766             sub build_email {
767             my ($self, $value) = @_;
768             return $value ? lc $value : undef;
769             }
770              
771             package main;
772              
773             my $person = Person->new(
774             fname => 'elliot',
775             lname => 'alderson',
776             email => 'E.ALDERSON@E-CORP.org',
777             );
778              
779             # bless({fname => 'Elliot', lname => 'Alderson', ...}, 'Person')
780              
781             # $person->fname;
782              
783             # "Elliot"
784              
785             # $person->lname;
786              
787             # "Alderson"
788              
789             # $person->email;
790              
791             # "e.alderson@e-corp.org"
792              
793             B
794              
795             package Person;
796              
797             use Venus::Class;
798              
799             with 'Venus::Role::Optional';
800              
801             attr 'fname';
802             attr 'lname';
803             attr 'email';
804              
805             sub build_fname {
806             my ($self, $value) = @_;
807             return $value ? ucfirst $value : undef;
808             }
809              
810             sub build_lname {
811             my ($self, $value) = @_;
812             return $value ? ucfirst $value : undef;
813             }
814              
815             sub build_email {
816             my ($self, $value) = @_;
817             return $value ? lc $value : undef;
818             }
819              
820             package Person;
821              
822             sub build_email {
823             my ($self, $value) = @_;
824             return lc join '@', (join '.', substr($self->fname, 0, 1), $self->lname),
825             'e-corp.org';
826             }
827              
828             package main;
829              
830             my $person = Person->new(
831             fname => 'Elliot',
832             lname => 'Alderson',
833             );
834              
835             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
836              
837             # $person->email;
838              
839             # "e.alderson@e-corp.org"
840              
841             B
842              
843             package Person;
844              
845             use Venus::Class;
846              
847             with 'Venus::Role::Optional';
848              
849             attr 'fname';
850             attr 'lname';
851              
852             sub build_fname {
853             my ($self, $value) = @_;
854             return $value ? ucfirst $value : undef;
855             }
856              
857             sub coerce_fname {
858             return 'Venus::String';
859             }
860              
861             sub build_lname {
862             my ($self, $value) = @_;
863             return $value ? ucfirst $value : undef;
864             }
865              
866             sub coerce_lname {
867             return 'Venus::String';
868             }
869              
870             package main;
871              
872             my $person = Person->new(
873             fname => 'elliot',
874             lname => 'alderson',
875             );
876              
877             # bless({
878             # fname => bless({value => 'Elliot'}, 'Venus::String'),
879             # lname => bless({value => 'Alderson'}, 'Venus::String')
880             # }, 'Person')
881              
882             B
883              
884             package Person;
885              
886             use Venus::Class;
887              
888             with 'Venus::Role::Optional';
889              
890             attr 'email';
891              
892             sub build_email {
893             my ($self, $value) = @_;
894             return $value ? lc $value : undef;
895             }
896              
897             sub coerce_email {
898             return 'Venus::String';
899             }
900              
901             package main;
902              
903             my $person = Person->new(
904             email => 'Elliot.Alderson@e-corp.org',
905             );
906              
907             # bless({
908             # email => bless({value => 'elliot.alderson@e-corp.org'}, 'Venus::String'),
909             # }, 'Person')
910              
911             B
912              
913             package Person;
914              
915             use Venus::Class;
916              
917             with 'Venus::Role::Optional';
918              
919             attr 'email';
920              
921             sub build_email {
922             my ($self, $value) = @_;
923             return $value ? lc $value : undef;
924             }
925              
926             sub default_email {
927             return 'NO-REPLY@E-CORP.ORG';
928             }
929              
930             package main;
931              
932             my $person = Person->new;
933              
934             # bless({email => 'no-reply@e-corp.org'}, 'Person')
935              
936             =back
937              
938             =over 4
939              
940             =item checking
941              
942             This library provides a mechanism for automatically checking class attributes
943             after getting or setting its value. The callback should be in the form of
944             C, and is passed any arguments provided.
945              
946             B
947              
948             package Person;
949              
950             use Venus::Class;
951              
952             with 'Venus::Role::Optional';
953              
954             attr 'fname';
955             attr 'lname';
956             attr 'email';
957              
958             sub check_fname {
959             my ($self, $value) = @_;
960             if ($value) {
961             return true if lc($value) eq 'elliot';
962             }
963             return false;
964             }
965              
966             sub check_lname {
967             my ($self, $value) = @_;
968             if ($value) {
969             return true if lc($value) eq 'alderson';
970             }
971             return false;
972             }
973              
974             package main;
975              
976             my $person = Person->new(
977             fname => 'Elliot',
978             lname => 'Alderson',
979             );
980              
981             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
982              
983             B
984              
985             package Person;
986              
987             use Venus::Class;
988              
989             with 'Venus::Role::Optional';
990              
991             attr 'fname';
992             attr 'lname';
993             attr 'email';
994              
995             sub check_fname {
996             my ($self, $value) = @_;
997             if ($value) {
998             return true if lc($value) eq 'elliot';
999             }
1000             return false;
1001             }
1002              
1003             sub check_lname {
1004             my ($self, $value) = @_;
1005             if ($value) {
1006             return true if lc($value) eq 'alderson';
1007             }
1008             return false;
1009             }
1010              
1011             package main;
1012              
1013             my $person = Person->new(
1014             fname => 'Elliot',
1015             lname => 'Alderson',
1016             );
1017              
1018             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
1019              
1020             # $person->lname('Alderson');
1021              
1022             # "Alderson"
1023              
1024             # $person->lname('');
1025              
1026             # Exception! (isa Person::Error)
1027              
1028             =back
1029              
1030             =over 4
1031              
1032             =item coercing
1033              
1034             This library provides a mechanism for automatically coercing class attributes
1035             into class instances using L based on the return value of the
1036             attribute callback. The callback should be in the form of C,
1037             and should return the name of the package to be constructed. That package will
1038             be instantiated via the customary C method, passing the data recevied as
1039             its arguments.
1040              
1041             B
1042              
1043             package Person;
1044              
1045             use Venus::Class;
1046              
1047             with 'Venus::Role::Optional';
1048              
1049             attr 'fname';
1050             attr 'lname';
1051             attr 'email';
1052              
1053             sub coerce_fname {
1054             my ($self, $value) = @_;
1055              
1056             return 'Venus::String';
1057             }
1058              
1059             sub coerce_lname {
1060             my ($self, $value) = @_;
1061              
1062             return 'Venus::String';
1063             }
1064              
1065             sub coerce_email {
1066             my ($self, $value) = @_;
1067              
1068             return 'Venus::String';
1069             }
1070              
1071             package main;
1072              
1073             my $person = Person->new(
1074             fname => 'Elliot',
1075             lname => 'Alderson',
1076             );
1077              
1078             # bless({
1079             # 'fname' => bless({'value' => 'Elliot'}, 'Venus::String'),
1080             # 'lname' => bless({'value' => 'Alderson'}, 'Venus::String')
1081             # }, 'Person')
1082              
1083             B
1084              
1085             package Person;
1086              
1087             use Venus::Class;
1088             use Venus::String;
1089              
1090             with 'Venus::Role::Optional';
1091              
1092             attr 'fname';
1093             attr 'lname';
1094             attr 'email';
1095              
1096             sub coerce_fname {
1097             my ($self, $value) = @_;
1098              
1099             return 'Venus::String';
1100             }
1101              
1102             sub coerce_lname {
1103             my ($self, $value) = @_;
1104              
1105             return 'Venus::String';
1106             }
1107              
1108             sub coerce_email {
1109             my ($self, $value) = @_;
1110              
1111             return 'Venus::String';
1112             }
1113              
1114             package main;
1115              
1116             my $person = Person->new(
1117             email => 'e.alderson@e-corp.org',
1118             );
1119              
1120             # bless({
1121             # 'email' => bless({'value' => 'e.alderson@e-corp.org'}, 'Venus::String'),
1122             # }, 'Person')
1123              
1124             B
1125              
1126             package Person;
1127              
1128             use Venus::Class;
1129              
1130             with 'Venus::Role::Optional';
1131              
1132             attr 'email';
1133              
1134             sub coerce_email {
1135             my ($self, $value) = @_;
1136              
1137             return 'Venus::String';
1138             }
1139              
1140             sub default_email {
1141             my ($self, $value) = @_;
1142              
1143             return 'no-reply@e-corp.org';
1144             }
1145              
1146             package main;
1147              
1148             my $person = Person->new;
1149              
1150             # bless({
1151             # 'email' => bless({'value' => 'no-reply@e-corp.org'}, 'Venus::String'),
1152             # }, 'Person')
1153              
1154             =back
1155              
1156             =over 4
1157              
1158             =item defaulting
1159              
1160             This library provides a mechanism for automatically defaulting class attributes
1161             to predefined values, statically or dynamically based on the return value of
1162             the attribute callback. The callback should be in the form of
1163             C, and should return the value to be used if no value exists
1164             or has been provided to the constructor.
1165              
1166             B
1167              
1168             package Person;
1169              
1170             use Venus::Class;
1171              
1172             with 'Venus::Role::Optional';
1173              
1174             attr 'fname';
1175             attr 'lname';
1176             attr 'email';
1177              
1178             sub default_lname {
1179             my ($self, $value) = @_;
1180              
1181             return 'Alderson';
1182             }
1183              
1184             package main;
1185              
1186             my $person = Person->new(
1187             fname => 'Elliot',
1188             );
1189              
1190             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
1191              
1192             # $person->lname('Johnston');
1193              
1194             # "Johnston"
1195              
1196             # $person->reset('lname');
1197              
1198             # "Johnston"
1199              
1200             # $person->lname;
1201              
1202             # "Alderson"
1203              
1204             =back
1205              
1206             =over 4
1207              
1208             =item initialing
1209              
1210             This library provides a mechanism for automatically setting class attributes to
1211             predefined values, statically or dynamically based on the return value of the
1212             attribute callback. The callback should be in the form of C,
1213             and should return the value to be used if no value has been provided to the
1214             constructor. This behavior is similar to the I<"defaulting"> mechanism but is
1215             only executed during object construction.
1216              
1217             B
1218              
1219             package Person;
1220              
1221             use Venus::Class;
1222              
1223             with 'Venus::Role::Optional';
1224              
1225             attr 'fname';
1226             attr 'lname';
1227             attr 'email';
1228              
1229             sub initial_lname {
1230             my ($self, $value) = @_;
1231              
1232             return 'Alderson';
1233             }
1234              
1235             package main;
1236              
1237             my $person = Person->new(
1238             fname => 'Elliot',
1239             );
1240              
1241             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
1242              
1243             # $person->lname('Johnston');
1244              
1245             # "Johnston"
1246              
1247             # $person->reset('lname');
1248              
1249             # "Johnston"
1250              
1251             # $person->lname;
1252              
1253             # undef
1254              
1255             =back
1256              
1257             =over 4
1258              
1259             =item lazy-building
1260              
1261             This library provides a mechanism for automatically building class attributes
1262             during getting and setting its value, after any default values are processed,
1263             based on the return value of the attribute callback. The callback should be in
1264             the form of C, and is passed any arguments provided.
1265              
1266             B
1267              
1268             package Person;
1269              
1270             use Venus::Class;
1271              
1272             with 'Venus::Role::Optional';
1273              
1274             attr 'email';
1275              
1276             sub lazy_build_email {
1277             my ($self, $value) = @_;
1278             return $value ? lc $value : 'no-reply@e-corp.org';
1279             }
1280              
1281             package main;
1282              
1283             my $person = Person->new;
1284              
1285             # bless({}, 'Person')
1286              
1287             # $person->email;
1288              
1289             # "no-reply@e-corp.org"
1290              
1291             B
1292              
1293             package Person;
1294              
1295             use Venus::Class;
1296              
1297             with 'Venus::Role::Optional';
1298              
1299             attr 'email';
1300              
1301             sub coerce_email {
1302             return 'Venus::String';
1303             }
1304              
1305             sub lazy_build_email {
1306             my ($self, $value) = @_;
1307             return $value ? lc $value : 'no-reply@e-corp.org';
1308             }
1309              
1310             package main;
1311              
1312             my $person = Person->new;
1313              
1314             # bless({}, 'Person')
1315              
1316             # $person->email;
1317              
1318             # bless({value => 'no-reply@e-corp.org'}, 'Venus::String')
1319              
1320             B
1321              
1322             package Person;
1323              
1324             use Venus::Class;
1325              
1326             with 'Venus::Role::Optional';
1327              
1328             attr 'email';
1329              
1330             sub default_email {
1331             return 'NO-REPLY@E-CORP.ORG';
1332             }
1333              
1334             sub lazy_build_email {
1335             my ($self, $value) = @_;
1336             return $value ? lc $value : undef;
1337             }
1338              
1339             package main;
1340              
1341             my $person = Person->new;
1342              
1343             # bless({}, 'Person')
1344              
1345             # $person->email;
1346              
1347             # "no-reply@e-corp.org"
1348              
1349             =back
1350              
1351             =over 4
1352              
1353             =item reading
1354              
1355             This library provides a mechanism for hooking into the class attribute reader
1356             (accessor) for reading values via the the attribute reader callback. The
1357             callback should be in the form of C, and should read and return
1358             the value for the attribute specified.
1359              
1360             B
1361              
1362             package Person;
1363              
1364             use Venus::Class;
1365              
1366             with 'Venus::Role::Optional';
1367              
1368             attr 'fname';
1369             attr 'lname';
1370             attr 'email';
1371              
1372             sub read_fname {
1373             my ($self, $value) = @_;
1374              
1375             return ucfirst $self->{fname};
1376             }
1377              
1378             sub read_lname {
1379             my ($self, $value) = @_;
1380              
1381             return ucfirst $self->{lname};
1382             }
1383              
1384             package main;
1385              
1386             my $person = Person->new(
1387             fname => 'elliot',
1388             lname => 'alderson',
1389             );
1390              
1391             # bless({fname => 'elliot', lname => 'alderson'}, 'Person')
1392              
1393             # $person->fname;
1394              
1395             # "Elliot"
1396              
1397             # $person->lname;
1398              
1399             # "Alderson"
1400              
1401             =back
1402              
1403             =over 4
1404              
1405             =item writing
1406              
1407             This library provides a mechanism for hooking into the class attribute writer
1408             (accessor) for writing values via the the attribute writer callback. The
1409             callback should be in the form of C, and should set and return
1410             the value for the attribute specified.
1411              
1412             B
1413              
1414             package Person;
1415              
1416             use Venus::Class;
1417              
1418             with 'Venus::Role::Optional';
1419              
1420             attr 'fname';
1421             attr 'lname';
1422             attr 'email';
1423              
1424             sub write_fname {
1425             my ($self, $value) = @_;
1426              
1427             return $self->{fname} = ucfirst $value;
1428             }
1429              
1430             sub write_lname {
1431             my ($self, $value) = @_;
1432              
1433             return $self->{lname} = ucfirst $value;
1434             }
1435              
1436             package main;
1437              
1438             my $person = Person->new;
1439              
1440             # bless({}, 'Person')
1441              
1442             # $person->fname('elliot');
1443              
1444             # "Elliot"
1445              
1446             # $person->lname('alderson');
1447              
1448             # "Alderson"
1449              
1450             =back
1451              
1452             =over 4
1453              
1454             =item self-asserting
1455              
1456             This library provides a mechanism for automatically validating class attributes
1457             using the attribute callback provided. The author is resposible for validating
1458             the state of the attribute and raising an exception when an attribute fails
1459             validation. The callback should be in the form of C.
1460              
1461             B
1462              
1463             package Person;
1464              
1465             use Venus::Class;
1466              
1467             with 'Venus::Role::Optional';
1468              
1469             attr 'fname';
1470             attr 'lname';
1471              
1472             sub self_assert_fname {
1473             my ($self, $value) = @_;
1474             die 'Bad fname' if $value && $value !~ '^[a-zA-Z]';
1475             }
1476              
1477             sub self_assert_lname {
1478             my ($self, $value) = @_;
1479             die 'Bad lname' if $value && $value !~ '^[a-zA-Z]';
1480             }
1481              
1482             package main;
1483              
1484             my $person = Person->new(
1485             fname => 'Elliot',
1486             lname => 'Alderson',
1487             );
1488              
1489             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
1490              
1491             # my $person = Person->new(fname => '@ElliotAlderson');
1492              
1493             # Exception! (isa Venus::Error)
1494              
1495             B
1496              
1497             package Person;
1498              
1499             use Venus::Class 'attr', 'raise', 'with';
1500              
1501             with 'Venus::Role::Optional';
1502              
1503             attr 'fname';
1504             attr 'lname';
1505              
1506             sub self_assert_fname {
1507             my ($self, $value) = @_;
1508             raise 'Person::Error::BadFname' if $value && $value !~ '^[a-zA-Z]';
1509             }
1510              
1511             sub self_assert_lname {
1512             my ($self, $value) = @_;
1513             raise 'Person::Error::BadLname' if $value && $value !~ '^[a-zA-Z]';
1514             }
1515              
1516             package main;
1517              
1518             my $person = Person->new(
1519             fname => 'Elliot',
1520             lname => 'Alderson',
1521             );
1522              
1523             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
1524              
1525             # my $person = Person->new(lname => '@AldersonElliot');
1526              
1527             # Exception! (isa Person::Error::BadLname, isa Venus::Error)
1528              
1529             B
1530              
1531             package Person;
1532              
1533             use Venus::Class;
1534              
1535             with 'Venus::Role::Optional';
1536              
1537             attr 'fname';
1538             attr 'lname';
1539              
1540             sub self_assert_fname {
1541             my ($self, $value) = @_;
1542             die $self if $value && $value !~ '^[a-zA-Z]';
1543             }
1544              
1545             sub self_assert_lname {
1546             my ($self, $value) = @_;
1547             die $self if $value && $value !~ '^[a-zA-Z]';
1548             }
1549              
1550             package main;
1551              
1552             my $person = Person->new(
1553             fname => 'Elliot',
1554             lname => 'Alderson',
1555             );
1556              
1557             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
1558              
1559             # my $person = Person->new(fname => rand);
1560              
1561             # Exception! (isa Person)
1562              
1563             =back
1564              
1565             =over 4
1566              
1567             =item self-coercing
1568              
1569             This library provides a mechanism for automatically coercing class attributes
1570             using the attribute callback provided. The author is resposible for any
1571             transformations to the attribute and value. The callback should be in the form
1572             of C.
1573              
1574             B
1575              
1576             package Person;
1577              
1578             use Venus::Class;
1579              
1580             with 'Venus::Role::Optional';
1581              
1582             attr 'fname';
1583             attr 'lname';
1584              
1585             sub self_coerce_fname {
1586             my ($self, $value) = @_;
1587              
1588             require Venus::String;
1589              
1590             return Venus::String->new($value || '');
1591             }
1592              
1593             sub self_coerce_lname {
1594             my ($self, $value) = @_;
1595              
1596             require Venus::String;
1597              
1598             return Venus::String->new($value || '');
1599             }
1600              
1601             package main;
1602              
1603             my $person = Person->new(
1604             fname => 'Elliot',
1605             lname => 'Alderson',
1606             );
1607              
1608             # bless({
1609             # fname => bless({value => 'Elliot'}, 'Venus::String'),
1610             # lname => bless({value => 'Alderson'}, 'Venus::String')
1611             # }, 'Person')
1612              
1613             B
1614              
1615             package Person;
1616              
1617             use Venus::Class;
1618              
1619             with 'Venus::Role::Optional';
1620              
1621             attr 'email';
1622              
1623             sub default_email {
1624             my ($self, $value) = @_;
1625              
1626             return 'no-reply@e-corp.org';
1627             }
1628              
1629             sub self_coerce_email {
1630             my ($self, $value) = @_;
1631              
1632             require Venus::String;
1633              
1634             return Venus::String->new($value || '');
1635             }
1636              
1637             package main;
1638              
1639             my $person = Person->new;
1640              
1641             # bless({
1642             # 'email' => bless({'value' => 'no-reply@e-corp.org'}, 'Venus::String'),
1643             # }, 'Person')
1644              
1645             =back
1646              
1647             =over 4
1648              
1649             =item triggering
1650              
1651             This library provides a mechanism for automatically triggering routines after
1652             reading or writing class attributes via an attribute callback. The callback
1653             should be in the form of C, and will be invoked after the
1654             related attribute is read or written.
1655              
1656             B
1657              
1658             package Person;
1659              
1660             use Venus::Class;
1661              
1662             with 'Venus::Role::Optional';
1663              
1664             attr 'fname';
1665             attr 'lname';
1666             attr 'email';
1667              
1668             sub trigger_fname {
1669             my ($self, $value) = @_;
1670              
1671             if ($value) {
1672             $self->{dirty}{fname} = $value;
1673             }
1674             return;
1675             }
1676              
1677             sub trigger_lname {
1678             my ($self, $value) = @_;
1679              
1680             if ($value) {
1681             $self->{dirty}{lname} = $value;
1682             }
1683             return;
1684             }
1685              
1686             package main;
1687              
1688             my $person = Person->new;
1689              
1690             # bless({}, 'Person')
1691              
1692             # $person->fname('Elliot');
1693              
1694             # "Elliot"
1695              
1696             # $person->lname('Alderson');
1697              
1698             # "Alderson"
1699              
1700             # my $object = $person;
1701              
1702             # bless({..., dirty => {fname => 'Elliot', lname => 'Alderson'}}, 'Person')
1703              
1704             =back
1705              
1706             =over 4
1707              
1708             =item readonly
1709              
1710             This library provides a mechanism for marking class attributes as I<"readonly">
1711             (or not) based on the return value of the attribute callback. The callback
1712             should be in the form of C, and should return truthy to
1713             automatically throw an exception if a change is attempted.
1714              
1715             B
1716              
1717             package Person;
1718              
1719             use Venus::Class;
1720              
1721             with 'Venus::Role::Optional';
1722              
1723             attr 'fname';
1724             attr 'lname';
1725             attr 'email';
1726              
1727             sub readonly_fname {
1728             my ($self, $value) = @_;
1729              
1730             return true;
1731             }
1732              
1733             sub readonly_lname {
1734             my ($self, $value) = @_;
1735              
1736             return true;
1737             }
1738              
1739             package main;
1740              
1741             my $person = Person->new(
1742             fname => 'Elliot',
1743             lname => 'Alderson',
1744             );
1745              
1746             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
1747              
1748             $person->fname('Mister');
1749              
1750             # Exception! (isa Person::Error)
1751              
1752             # $person->lname('Johnston');
1753              
1754             # Exception! (isa Person::Error)
1755              
1756             =back
1757              
1758             =over 4
1759              
1760             =item readwrite
1761              
1762             This library provides a mechanism for marking class attributes as I<"readwrite">
1763             (or not) based on the return value of the attribute callback. The callback
1764             should be in the form of C, and should return falsy to
1765             automatically throw an exception if a change is attempted.
1766              
1767             B
1768              
1769             package Person;
1770              
1771             use Venus::Class;
1772              
1773             with 'Venus::Role::Optional';
1774              
1775             attr 'fname';
1776             attr 'lname';
1777             attr 'email';
1778              
1779             sub readwrite_fname {
1780             my ($self, $value) = @_;
1781              
1782             return false;
1783             }
1784              
1785             sub readwrite_lname {
1786             my ($self, $value) = @_;
1787              
1788             return false;
1789             }
1790              
1791             package main;
1792              
1793             my $person = Person->new(
1794             fname => 'Elliot',
1795             lname => 'Alderson',
1796             );
1797              
1798             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
1799              
1800             $person->fname('Mister');
1801              
1802             # Exception! (isa Person::Error)
1803              
1804             # $person->lname('Johnston');
1805              
1806             # Exception! (isa Person::Error)
1807              
1808             =back
1809              
1810             =over 4
1811              
1812             =item requiring
1813              
1814             This library provides a mechanism for marking class attributes as I<"required">
1815             (i.e. to be provided to the constructor) based on the return value of the
1816             attribute callback. The callback should be in the form of C,
1817             and should return truthy to automatically throw an exception if the related
1818             attribute is missing.
1819              
1820             B
1821              
1822             package Person;
1823              
1824             use Venus::Class;
1825              
1826             with 'Venus::Role::Optional';
1827              
1828             attr 'fname';
1829             attr 'lname';
1830             attr 'email';
1831              
1832             sub require_fname {
1833             my ($self, $value) = @_;
1834              
1835             return true;
1836             }
1837              
1838             sub require_lname {
1839             my ($self, $value) = @_;
1840              
1841             return true;
1842             }
1843              
1844             sub require_email {
1845             my ($self, $value) = @_;
1846              
1847             return false;
1848             }
1849              
1850             package main;
1851              
1852             my $person = Person->new(
1853             fname => 'Elliot',
1854             lname => 'Alderson',
1855             );
1856              
1857             # bless({fname => 'Elliot', lname => 'Alderson'}, 'Person')
1858              
1859             B
1860              
1861             package Person;
1862              
1863             use Venus::Class;
1864              
1865             with 'Venus::Role::Optional';
1866              
1867             attr 'fname';
1868             attr 'lname';
1869             attr 'email';
1870              
1871             sub require_fname {
1872             my ($self, $value) = @_;
1873              
1874             return true;
1875             }
1876              
1877             sub require_lname {
1878             my ($self, $value) = @_;
1879              
1880             return true;
1881             }
1882              
1883             sub require_email {
1884             my ($self, $value) = @_;
1885              
1886             return false;
1887             }
1888              
1889             package main;
1890              
1891             my $person = Person->new(
1892             fname => 'Elliot',
1893             );
1894              
1895             # Exception! (isa Person::Error)
1896              
1897             B
1898              
1899             package Person;
1900              
1901             use Venus::Class;
1902              
1903             with 'Venus::Role::Optional';
1904              
1905             attr 'fname';
1906             attr 'lname';
1907             attr 'email';
1908              
1909             sub require_fname {
1910             my ($self, $value) = @_;
1911              
1912             return true;
1913             }
1914              
1915             sub require_lname {
1916             my ($self, $value) = @_;
1917              
1918             return true;
1919             }
1920              
1921             sub require_email {
1922             my ($self, $value) = @_;
1923              
1924             return false;
1925             }
1926              
1927             package main;
1928              
1929             my $person = Person->new(
1930             lname => 'Alderson',
1931             );
1932              
1933             # Exception! (isa Person::Error)
1934              
1935             =back
1936              
1937             =head1 AUTHORS
1938              
1939             Awncorp, C
1940              
1941             =cut
1942              
1943             =head1 LICENSE
1944              
1945             Copyright (C) 2000, Al Newkirk.
1946              
1947             This program is free software, you can redistribute it and/or modify it under
1948             the terms of the Apache license version 2.0.
1949              
1950             =cut