File Coverage

blib/lib/Class/Accessor/Inherited/XS.pm
Criterion Covered Total %
statement 57 58 98.2
branch 17 18 94.4
condition 14 17 82.3
subroutine 19 19 100.0
pod 0 3 0.0
total 107 115 93.0


line stmt bran cond sub pod time code
1             package Class::Accessor::Inherited::XS;
2 38     38   1736964 use 5.010001;
  38         375  
3 38     38   225 use strict;
  38         83  
  38         1055  
4 38     38   233 use warnings;
  38         79  
  38         1566  
5              
6 38     38   11955 use Class::Accessor::Inherited::XS::Compat qw/mk_type_accessors mk_inherited_accessors mk_class_accessors mk_varclass_accessors mk_object_accessors/;
  38         95  
  38         4668  
7              
8             our $PREFIX = '__cag_';
9              
10             BEGIN {
11 38     38   162 our $VERSION = '0.37';
12              
13 38         205 require XSLoader;
14 38         27917 XSLoader::load('Class::Accessor::Inherited::XS', $VERSION);
15             }
16              
17 38     38   341 use Carp qw/confess/;
  38         79  
  38         2221  
18 38     38   280 use Class::Accessor::Inherited::XS::Constants;
  38         103  
  38         40360  
19              
20             my $REGISTERED_TYPES = {};
21             register_types(
22             inherited => {installer => _curry(\&_mk_inherited_accessor, None), clone_arg => 1},
23             inherited_ro => {installer => _curry(\&_mk_inherited_accessor, IsReadonly), clone_arg => 1},
24             class => {installer => _curry(\&_mk_class_accessor, 0, None), clone_arg => undef},
25             class_ro => {installer => _curry(\&_mk_class_accessor, 0, IsReadonly), clone_arg => undef},
26             varclass => {installer => _curry(\&_mk_class_accessor, 1, None), clone_arg => undef},
27             varclass_ro => {installer => _curry(\&_mk_class_accessor, 1, IsReadonly), clone_arg => undef},
28             object => {installer => _curry(\&_mk_object_accessor, None), clone_arg => 1},
29             accessors => {installer => _curry(\&_mk_object_accessor, None), clone_arg => 1}, # alias for object
30             object_ro => {installer => _curry(\&_mk_object_accessor, IsReadonly), clone_arg => 1},
31             getters => {installer => _curry(\&_mk_object_accessor, IsReadonly), clone_arg => 1}, # alias for object_ro
32             constructor => {installer => \&_mk_constructor, clone_arg => undef},
33             );
34              
35             sub import {
36 42     42   1929 my $pkg = shift;
37 42 100       2072 return unless scalar @_;
38              
39 32 100       194 my %opts = ref($_[0]) eq 'HASH' ? %{ $_[0] } : @_;
  10         52  
40 32   66     268 my $class = delete $opts{package} // caller;
41              
42 32         126 for my $type (keys %opts) {
43 51         130 my $accessors = $opts{$type};
44 51         149 my ($installer, $clone_arg) = $pkg->_type_installer($type);
45              
46 50 100       209 if (ref($accessors) eq 'HASH') {
    100          
    50          
47 9         35 $installer->($class, $_, $accessors->{$_}) for keys %$accessors;
48              
49             } elsif (ref($accessors) eq 'ARRAY') {
50 28   66     166 $installer->($class, $_, $clone_arg && $_) for @$accessors;
51              
52             } elsif (!ref($accessors)) {
53 13   66     71 $installer->($class, $accessors, $clone_arg && $accessors);
54              
55             } else {
56 0         0 confess("Can't understand format for '$type' accessors initializer");
57             }
58             }
59             }
60              
61             sub register_types {
62 40     40 0 416 register_type(shift, shift) while scalar @_;
63             }
64              
65 2     2 0 130 sub is_type_registered { exists $REGISTERED_TYPES->{$_[0]} }
66              
67             sub register_type {
68 430     430 0 866 my ($type, $args) = @_;
69              
70 430 100       1001 if (exists $REGISTERED_TYPES->{$type}) {
71 1         267 confess("Type '$type' has already been registered");
72             }
73              
74 429 100       806 if (!exists $args->{installer}) {
75             $args->{installer} = sub {
76 12     12   38 my ($class, $name, $field) = @_;
77             install_inherited_cb_accessor(
78             "${class}::${name}", $field, $PREFIX.$field,
79             $args->{read_cb} // $args->{on_read}, $args->{write_cb} // $args->{on_write},
80 12   100     6798 $args->{opts} // 0,
      100        
      100        
81             );
82 11         45 };
83             }
84              
85 429 100       836 $args->{clone_arg} = 1 unless exists $args->{clone_arg}; # for cb-types
86 429         1557 $REGISTERED_TYPES->{$type} = $args;
87             }
88              
89             #
90             # Functions below are NOT part of the public API
91             #
92              
93             sub _curry {
94 380     380   844 my ($sub, @args) = @_;
95              
96             return sub {
97 72     72   219 $sub->(@_, @args);
98 380         1790 };
99             }
100              
101             sub _type_installer {
102 68     68   163 my (undef, $type) = @_;
103              
104 68 100       413 my $type_info = $REGISTERED_TYPES->{$type} or confess("Don't know how to install '$type' accessors");
105 67         225 return ($type_info->{installer}, $type_info->{clone_arg});
106             }
107              
108             sub _mk_inherited_accessor {
109 37     37   142 my ($class, $name, $field, $flags) = @_;
110              
111 37         22546 install_inherited_accessor("${class}::${name}", $field, $PREFIX.$field, $flags);
112             }
113              
114             sub _mk_class_accessor {
115 29     29   97 my ($class, $name, $default, $is_varclass, $flags) = @_;
116              
117 29         10610 install_class_accessor("${class}::${name}", $default, $is_varclass, $flags);
118             }
119              
120             sub _mk_object_accessor {
121 6     6   16 my ($class, $name, $field, $flags) = @_;
122              
123 6         3633 install_object_accessor("${class}::${name}", $field, $flags);
124             }
125              
126             sub _mk_constructor {
127 2     2   6 my ($class, $name) = @_;
128              
129 2         1636 install_constructor("${class}::${name}");
130             }
131              
132             1;
133             __END__