File Coverage

lib/Class/Dot/Meta/Accessor/Overrideable.pm
Criterion Covered Total %
statement 57 64 89.0
branch 18 28 64.2
condition n/a
subroutine 39 39 100.0
pod 4 4 100.0
total 118 135 87.4


line stmt bran cond sub pod time code
1             # $Id$
2             # $Source$
3             # $Author$
4             # $HeadURL$
5             # $Revision$
6             # $Date$
7             package Class::Dot::Meta::Accessor::Overrideable;
8 16     16   108 use base 'Class::Dot::Meta::Accessor::Base';
  16         34  
  16         10577  
9              
10 16     16   96 use strict;
  16         36  
  16         503  
11 16     16   81 use warnings;
  16         33  
  16         355  
12 16     16   80 use version;
  16         31  
  16         64  
13 16     16   2767 use 5.00600;
  16         72  
  16         2459  
14              
15             our $VERSION = qv('2.0.0_15');
16             our $AUTHORITY = 'cpan:ASKSH';
17              
18 16     16   89 use Carp qw(croak confess);
  16         42  
  16         960  
19              
20 16     16   96 use Class::Dot::Devel::Sub::Name qw(subname);
  16         37  
  16         10620  
21              
22 16     16   113 use Class::Dot::Meta::Type qw(_NEWSCHOOL_TYPE _OLDSCHOOL_TYPE);
  16         32  
  16         157  
23              
24             sub register_plugin {
25             return {
26 16     16 1 1336 name => 'Overrideable',
27             class => __PACKAGE__,
28             },
29             };
30              
31             sub create_get_accessor {
32 70     70 1 137 my ($self, $caller_class, $property, $isa, $options) = @_;
33 70         83 my $property_key = $property;
34              
35             return subname "${caller_class}::$property" => sub {
36 85     85   23969 my $self = shift;
        56      
        99      
        142      
        201      
        142      
        185      
        99      
        99      
        142      
        112      
        110      
        103      
        34      
        32      
        16      
37              
38 85 100       230 if (@_) {
39 1         13 my $setter_name = $self->__meta__($property)->setter_name;
40 1         30 croak "You tried to set a value with $property(). " .
41             "Did you mean $setter_name() ?"
42             };
43              
44 84 100       338 if (!exists $self->{$property_key}) {
45              
46 42 50       156 if (_NEWSCHOOL_TYPE($isa)) {
    0          
47 42         141 $self->{$property_key} = $isa->default_value($self);
48             }
49             elsif (_OLDSCHOOL_TYPE($isa)) {
50 0         0 $self->{$property_key} = $isa->($self);
51             }
52             else {
53 0         0 $self->{$property_key} = $isa;
54             }
55             }
56              
57 84 100       484 return $options->{'-optimized'} ? $self->{$property_key}
58             : $self->__getattr__($property);
59             }
60 70         1059 }
61              
62             sub create_set_accessor {
63 69     155 1 128 my ($self, $caller_class, $property, $isa, $options) = @_;
64 69         89 my $property_key = $property;
65              
66             return subname "${caller_class}::set_$property" => sub {
67 9     95   8262 my ($self, $value) = @_;
        59      
        66      
        73      
        75      
        66      
        73      
        59      
        16      
        23      
68            
69 9 50       34 if ($options->{'-optimized'}) {
70 0         0 $self->{$property_key} = $value;
71             }
72             else {
73 9         35 $self->__setattr__($property, $value);
74             }
75 9         17 return;
76             }
77 69         734 }
78              
79             sub create_mutator {
80 6     20 1 14 my ($self, $caller_class, $property, $isa, $options, $priv) = @_;
81 6         8 my $property_key = $property;
82              
83             return subname "${caller_class}::$property" => sub {
84 14     28   4493 my ($self, $value) = @_;
85              
86 14 100       44 if (defined $value) {
87 6 100       62 confess "Can't set value with $property(). It's read only!"
88             if not $priv->{has_setter};
89 4 50       17 if ($options->{'-optimized'}) {
90 4         10 $self->{$property_key} = $value;
91             }
92             else {
93 0         0 $self->__setattr__($property, $value);
94             }
95 4         20 return;
96             }
97              
98 8 50       28 if (not $priv->{has_getter}) {
99 0         0 confess "Can only set value with $property(), it's write only!";
100             }
101              
102 8 100       35 if (!exists $self->{$property_key}) {
103            
104 4 50       18 if (_NEWSCHOOL_TYPE($isa)) {
    0          
105 4         17 $self->{$property_key} = $isa->default_value($self);
106             }
107             elsif (_OLDSCHOOL_TYPE($isa)) {
108 0         0 $self->{$property_key} = $isa->($self);
109             }
110             else {
111 0         0 $self->{$property_key} = $isa;
112             }
113             }
114              
115 8 50       62 return $options->{'-optimized'} ? $self->{$property_key}
116             : $self->__getattr__($property);
117             }
118 6         87 }
119              
120             1;
121              
122             __END__