File Coverage

blib/lib/Validation/Class/Simple.pm
Criterion Covered Total %
statement 37 42 88.1
branch 0 2 0.0
condition 1 6 16.6
subroutine 12 14 85.7
pod 0 3 0.0
total 50 67 74.6


line stmt bran cond sub pod time code
1             # ABSTRACT: Simple Ad-Hoc Data Validation
2              
3             package Validation::Class::Simple;
4              
5 14     14   832138 use 5.10.0;
  14         166  
6 14     14   76 use strict;
  14         36  
  14         281  
7 14     14   65 use warnings;
  14         42  
  14         489  
8              
9 14     14   9599 use Validation::Class::Prototype;
  14         65  
  14         641  
10              
11 14     14   108 use Scalar::Util ('refaddr');
  14         27  
  14         743  
12 14     14   92 use Validation::Class::Util ('prototype_registry');
  14         40  
  14         54  
13 14     14   8435 use Validation::Class ();
  14         52  
  14         1492  
14              
15             our $VERSION = '7.900059'; # VERSION
16              
17              
18             sub new {
19              
20 14     14 0 1212 my $class = shift;
21              
22 14   33     116 $class = ref $class || $class;
23              
24 14         44 my $self = bless {}, $class;
25 14         91 my $addr = refaddr $self;
26              
27 14         73 prototype_registry->add(
28             $addr => Validation::Class::Prototype->new(
29             package => $class # inside-out prototype
30             )
31             );
32              
33             # let Validation::Class handle arg processing
34 14         126 $self->Validation::Class::initialize_validator(@_);
35              
36 14         61 return $self;
37              
38             }
39              
40             {
41              
42 14     14   109 no strict 'refs';
  14         64  
  14         4148  
43              
44             # inject prototype class aliases unless exist
45              
46             my @aliases = Validation::Class::Prototype->proxy_methods;
47              
48             foreach my $alias (@aliases) {
49              
50             *{$alias} = sub {
51              
52 196     196   89433 my ($self, @args) = @_;
53              
54 196         591 $self->prototype->$alias(@args);
55              
56             };
57              
58             }
59              
60             # inject wrapped prototype class aliases unless exist
61              
62             my @wrapped_aliases = Validation::Class::Prototype->proxy_methods_wrapped;
63              
64             foreach my $alias (@wrapped_aliases) {
65              
66             *{$alias} = sub {
67              
68 180     180   949 my ($self, @args) = @_;
69              
70 180         453 $self->prototype->$alias($self, @args);
71              
72             };
73              
74             }
75              
76             }
77              
78 0     0 0 0 sub proto { goto &prototype } sub prototype {
79              
80 481     481 0 829 my $self = shift;
81 481         1084 my $addr = refaddr $self;
82              
83 481         1172 return prototype_registry->get($addr);
84              
85             }
86              
87             sub DESTROY {
88              
89 0     0     my $self = shift;
90 0           my $addr = refaddr $self;
91              
92 0 0 0       prototype_registry->delete($addr) if $self && prototype_registry;
93              
94 0           return;
95              
96             }
97              
98              
99             1;
100              
101             __END__