File Coverage

blib/lib/Data/Object/Class/Syntax.pm
Criterion Covered Total %
statement 51 74 68.9
branch 10 28 35.7
condition 13 17 76.4
subroutine 30 32 93.7
pod 23 23 100.0
total 127 174 72.9


line stmt bran cond sub pod time code
1             # ABSTRACT: Class Declaration DSL for Perl 5
2             package Data::Object::Class::Syntax;
3              
4 1     1   19877 use 5.010;
  1         3  
5 1     1   5 use strict;
  1         2  
  1         20  
6 1     1   4 use warnings;
  1         2  
  1         29  
7 1     1   701 use parent 'Exporter';
  1         268  
  1         5  
8              
9 1     1   725 use Sub::Quote;
  1         14617  
  1         131  
10              
11             our $VERSION = '0.42'; # VERSION
12              
13             our @EXPORT = qw(
14             alt
15             builder
16             clearer
17             coerce
18             def
19             default
20             defaulter
21             handles
22             init_arg
23             is
24             isa
25             lazy
26             opt
27             optional
28             predicate
29             reader
30             req
31             required
32             ro
33             rw
34             trigger
35             weak_ref
36             writer
37             );
38              
39             sub import {
40 0     0   0 my $class = $_[0];
41 0         0 my $target = caller;
42              
43 0 0       0 if (my $orig = $target->can('has')) {
44              
45 1     1   7 no strict 'refs';
  1         2  
  1         26  
46 1     1   5 no warnings 'redefine';
  1         1  
  1         1023  
47              
48 0         0 my $has = *{"${target}::has"} = sub {
49 0     0   0 my ($name, @props) = @_;
50              
51 0 0       0 return $orig->($name, @props)
52             if @props % 2 != 0;
53              
54 0         0 my $alt = $name =~ s/^\+//;
55              
56 0         0 my %codes = (
57             builder => 'build',
58             clearer => 'clear',
59             predicate => 'has',
60             reader => 'get',
61             trigger => 'trigger',
62             writer => 'set',
63             );
64              
65 0         0 my %props = @props;
66 0         0 for my $code (sort keys %codes) {
67 0 0 0     0 if ($props{$code} and $props{$code} eq "1") {
68 0         0 my $id = $codes{$code};
69 0         0 $props{$code} = "_${id}_${name}";
70 0         0 $props{$code} =~ s/_${id}__/_${id}_/;
71             }
72             }
73              
74 0 0       0 if (my $method = delete $props{defaulter}) {
75 0 0       0 if ($method eq "1") {
76 0         0 $method = "_default_${name}";
77 0         0 $method =~ s/_default__/_default_/;
78             }
79 0         0 my $routine = q{ $target->$method(@_) };
80 0         0 $props{default} = Sub::Quote::quote_sub($routine, {
81             '$target' => \$target,
82             '$method' => \$method,
83             });
84             }
85              
86 0 0       0 return $orig->($alt ? "+$name" : $name, %props);
87 0         0 };
88              
89             }
90              
91 0         0 return $class->export_to_level(1, @_);
92             }
93              
94             sub alt ($@) {
95 10     10 1 2585 my ($name, @props) = @_;
96 10 50       64 if (my $has = caller->can('has')) {
97 10 50       30 my @name = ref $name ? @$name : $name;
98 10 50       89 @_ = ((map "+$_", @name), @props) and goto $has;
99             }
100             }
101              
102             sub builder (;$) {
103 2   100 2 1 1423 return builder => $_[0] // 1;
104             }
105              
106             sub clearer (;$) {
107 2   100 2 1 1269 return clearer => $_[0] // 1;
108             }
109              
110             sub coerce () {
111 1     1 1 1271 return coerce => 1;
112             }
113              
114             sub def ($$@) {
115 2     2 1 1735 my ($name, $code, @props) = @_;
116 2 50       14 @_ = ($name, 'default', $code, @props) and goto &alt;
117             }
118              
119             sub default ($) {
120 2     2 1 1451 return default => $_[0];
121             }
122              
123             sub defaulter (;$) {
124 1   50 1 1 1250 return defaulter => $_[0] // 1;
125             }
126              
127             sub handles ($) {
128 3     3 1 1291 return handles => $_[0];
129             }
130              
131             sub init_arg ($) {
132 1     1 1 1410 return init_arg => $_[0];
133             }
134              
135             sub is (@) {
136 1     1 1 1241 return (@_);
137             }
138              
139             sub isa ($) {
140 5     5 1 1337 return isa => $_[0];
141             }
142              
143             sub lazy () {
144 1     1 1 1327 return lazy => 1;
145             }
146              
147             sub opt ($;$@) {
148 3     3 1 2452 my ($name, $type, @props) = @_;
149 3         6 my @req = (required => 0);
150 3 100       19 @_ = ($name, ref($type) ? isa($type) : (), @props, @req)
    50          
151             and goto &alt;
152             }
153              
154             sub optional (@) {
155 1     1 1 1557 return required => 0, @_;
156             }
157              
158             sub predicate (;$) {
159 2   100 2 1 1268 return predicate => $_[0] // 1;
160             }
161              
162             sub reader (;$) {
163 2   100 2 1 1273 return reader => $_[0] // 1;
164             }
165              
166             sub req ($;$@) {
167 3     3 1 2785 my ($name, $type, @props) = @_;
168 3         8 my @req = (required => 1);
169 3 100       16 @_ = ($name, ref($type) ? isa($type) : (), @props, @req)
    50          
170             and goto &alt;
171             }
172              
173             sub required (@) {
174 1     1 1 1399 return required => 1, @_;
175             }
176              
177             sub ro () {
178 1     1 1 1254 return is => 'ro';
179             }
180              
181             sub rw () {
182 1     1 1 1308 return is => 'rw';
183             }
184              
185             sub trigger (;$) {
186 2   100 2 1 1248 return trigger => $_[0] // 1;
187             }
188              
189             sub weak_ref () {
190 1     1 1 1345 return weak_ref => 1;
191             }
192              
193             sub writer (;$) {
194 2   100 2 1 1363 return writer => $_[0] // 1;
195             }
196              
197             1;
198              
199             __END__