File Coverage

blib/lib/Data/Object.pm
Criterion Covered Total %
statement 156 164 95.1
branch 98 120 81.6
condition 27 34 79.4
subroutine 31 32 96.8
pod 19 21 90.4
total 331 371 89.2


line stmt bran cond sub pod time code
1             # ABSTRACT: Object Orientation for Perl 5
2             package Data::Object;
3              
4 223     223   390507 use 5.010;
  223         671  
5 223     223   1319 use strict;
  223         414  
  223         4992  
6 223     223   1074 use warnings;
  223         392  
  223         8409  
7              
8 223     223   1024 use Carp;
  223         387  
  223         16100  
9              
10 223     223   1084 use Exporter qw(import);
  223         420  
  223         8178  
11 223     223   1603 use Scalar::Util qw(blessed looks_like_number reftype);
  223         410  
  223         78807  
12              
13             my @CORE = grep !/^(data|type)_/, our @EXPORT_OK = qw(
14             codify
15             const
16             data_array
17             data_code
18             data_float
19             data_hash
20             data_integer
21             data_number
22             data_regexp
23             data_scalar
24             data_string
25             data_undef
26             data_universal
27             deduce
28             deduce_deep
29             deduce_type
30             detract
31             detract_deep
32             load
33             throw
34             type_array
35             type_code
36             type_float
37             type_hash
38             type_integer
39             type_number
40             type_regexp
41             type_scalar
42             type_string
43             type_undef
44             type_universal
45             );
46              
47             our %EXPORT_TAGS = (
48             all => [@EXPORT_OK],
49             core => [@CORE],
50             data => [grep m/data_/, @EXPORT_OK],
51             type => [grep m/type_/, @EXPORT_OK],
52             );
53              
54             our $VERSION = '0.42'; # VERSION
55              
56             sub new {
57 0 0   0 0 0 shift and goto &deduce_deep;
58             }
59              
60             sub const ($$) {
61 4     4 1 4321 my $name = shift;
62 4         7 my $expr = shift;
63              
64 4 50 33     21 return unless $name and defined $expr;
65              
66 4         6 my $class = caller(0);
67 4 50       12 $class = caller(1) if __PACKAGE__ eq $class;
68 4 100       21 my $fqsn = $name =~ /(::|')/ ? $name : "${class}::${name}";
69              
70 223     223   1117 no strict 'refs';
  223         391  
  223         9480  
71 223     223   1133 no warnings 'redefine';
  223         381  
  223         432587  
72              
73 4 100   4   13 *{ $fqsn } = sub () { (ref $expr eq "CODE") ? goto &$expr : $expr };
  4         18  
  4         1356  
74              
75 4         10 return $expr;
76             }
77              
78             sub codify ($) {
79 5     5 0 12 my $code = shift;
80 5         48 my $vars = sprintf 'my ($%s) = @_;', join ',$', 'a'..'z';
81 5   100     32 my $body = sprintf 'sub { %s do { %s } }', $vars, $code // 'return(@_)';
82              
83 5         10 my $sub;
84 5         9 my $error = do { local $@; $sub = eval $body; $@ };
  5         8  
  5         645  
  5         18  
85              
86 5 50       23 croak $error unless $sub;
87 5         22 return $sub;
88             }
89              
90             sub load ($) {
91 933     933 1 2902 my $class = shift;
92              
93 933   33     6440 my $failed = ! $class || $class !~ /^\w(?:[\w:']*\w)?$/;
94 933         1625 my $loaded;
95              
96 933         1145 my $error = do {
97 933         1233 local $@;
98 933   100     19130 $loaded = $class->can('new') || eval "require $class; 1";
99 933         1999 $@
100             };
101              
102 933 50 66     6808 croak "Error attempting to load $class: $error"
      66        
103             if $error or $failed or not $loaded;
104              
105 932         2837 return $class;
106             }
107              
108             sub throw (@) {
109 2     2 1 2026 unshift @_, my $class = load 'Data::Object::Exception';
110 2         14 goto $class->can('throw');
111             }
112              
113             sub data_array ($) {
114 93     93 1 1787 unshift @_, my $class = load 'Data::Object::Array';
115 93         745 goto $class->can('new');
116             }
117              
118             sub data_code ($) {
119 14     14 1 1616 unshift @_, my $class = load 'Data::Object::Code';
120 14         112 goto $class->can('new');
121             }
122              
123             sub data_float ($) {
124 16     16 1 3600 unshift @_, my $class = load 'Data::Object::Float';
125 16         104 goto $class->can('new');
126             }
127              
128             sub data_hash ($) {
129 35     35 1 1668 unshift @_, my $class = load 'Data::Object::Hash';
130 35         234 goto $class->can('new');
131             }
132              
133             sub data_integer ($) {
134 36     36 1 6514 unshift @_, my $class = load 'Data::Object::Integer';
135 36         215 goto $class->can('new');
136             }
137              
138             sub data_number ($) {
139 578     578 1 4434 unshift @_, my $class = load 'Data::Object::Number';
140 578         3150 goto $class->can('new');
141             }
142              
143             sub data_regexp ($) {
144 4     4 1 16 unshift @_, my $class = load 'Data::Object::Regexp';
145 4         36 goto $class->can('new');
146             }
147              
148             sub data_scalar ($) {
149 2     2 1 1011 unshift @_, my $class = load 'Data::Object::Scalar';
150 2         13 goto $class->can('new');
151             }
152              
153             sub data_string ($) {
154 136     136 1 1254 unshift @_, my $class = load 'Data::Object::String';
155 136         693 goto $class->can('new');
156             }
157              
158             sub data_undef (;$) {
159 13     13 1 1228 unshift @_, my $class = load 'Data::Object::Undef';
160 13         126 goto $class->can('new');
161             }
162              
163             sub data_universal ($) {
164 2     2 1 1517 unshift @_, my $class = load 'Data::Object::Universal';
165 2         14 goto $class->can('new');
166             }
167              
168             sub deduce ($) {
169 3568     3568 1 11835 my $scalar = shift;
170              
171             # return undef
172 3568 100       13290 if (not defined $scalar) {
    100          
173 11         40 return data_undef $scalar;
174             }
175              
176             # handle blessed objects
177             elsif (blessed $scalar) {
178 2671 100       13451 return data_regexp $scalar if $scalar->isa('Regexp');
179 2667         4685 return $scalar;
180             }
181              
182             # handle data types
183             # ... using spaces for clarity
184             else {
185              
186             # handle references
187 886 100       1825 if (ref $scalar) {
188 136 100       641 return data_array $scalar if 'ARRAY' eq ref $scalar;
189 45 100       217 return data_hash $scalar if 'HASH' eq ref $scalar;
190 12 50       112 return data_code $scalar if 'CODE' eq ref $scalar;
191             }
192              
193             # handle non-references
194             else {
195 750 100       2277 if (looks_like_number $scalar) {
196 616 100       2191 return data_float $scalar if $scalar =~ /\./;
197 604 100       3356 return data_number $scalar if $scalar =~ /^\d+$/;
198 30         87 return data_integer $scalar;
199             }
200             else {
201 134         309 return data_string $scalar;
202             }
203             }
204              
205             # handle unhandled
206 0         0 return data_scalar $scalar;
207              
208             }
209              
210             # fallback
211 0         0 return data_undef $scalar;
212             }
213              
214             sub deduce_deep {
215 464     464 1 3030 my @objects = @_;
216              
217 464         884 for my $object (@objects) {
218 464         582 my $type;
219              
220 464         1674 $object = deduce($object);
221 464         1532 $type = deduce_type($object);
222              
223 464 100 100     2463 if ($type and $type eq 'HASH') {
224 45         385 for my $i (keys %$object) {
225 120         200 my $val = $object->{$i};
226 120 100       388 $object->{$i} = ref($val) ? deduce_deep($val) : deduce($val);
227             }
228             }
229              
230 464 100 100     3065 if ($type and $type eq 'ARRAY') {
231 126         528 for (my $i = 0; $i < @$object; $i++) {
232 500         732 my $val = $object->[$i];
233 500 100       1333 $object->[$i] = ref($val) ? deduce_deep($val) : deduce($val);
234             }
235             }
236             }
237              
238 464 100       2927 return wantarray ? (@objects) : $objects[0];
239             }
240              
241             sub deduce_type ($) {
242 1526     1526 1 8812 my $object = deduce shift;
243              
244 1526 100       7944 return 'ARRAY' if $object->isa('Data::Object::Array');
245 1391 100       6634 return 'HASH' if $object->isa('Data::Object::Hash');
246 1338 100       7953 return 'CODE' if $object->isa('Data::Object::Code');
247              
248 1321 100       5904 return 'FLOAT' if $object->isa('Data::Object::Float');
249 1266 100       5320 return 'NUMBER' if $object->isa('Data::Object::Number');
250 322 100       1561 return 'INTEGER' if $object->isa('Data::Object::Integer');
251              
252 288 100       1188 return 'STRING' if $object->isa('Data::Object::String');
253 37 100       252 return 'SCALAR' if $object->isa('Data::Object::Scalar');
254 34 100       267 return 'REGEXP' if $object->isa('Data::Object::Regexp');
255              
256 27 100       158 return 'UNDEF' if $object->isa('Data::Object::Undef');
257 10 100       59 return 'UNIVERSAL' if $object->isa('Data::Object::Universal');
258              
259 7         13 return undef;
260             }
261              
262             sub detract ($) {
263 1051     1051 1 5639 my $object = deduce shift;
264 1051         3068 my $type = deduce_type $object;
265              
266 1051 100       2603 INSPECT:
267             return $object unless $type;
268              
269 1050 100       2925 return [@$object] if $type eq 'ARRAY';
270 1042 100       3657 return {%$object} if $type eq 'HASH';
271 1035 100       2481 return $$object if $type eq 'REGEXP';
272 1030 100       2720 return $$object if $type eq 'FLOAT';
273 983 100       20569 return $$object if $type eq 'NUMBER';
274 247 100       1490 return $$object if $type eq 'INTEGER';
275 222 100       3901 return $$object if $type eq 'STRING';
276 25 100       109 return undef if $type eq 'UNDEF';
277              
278 12 100 100     90 if ($type eq 'SCALAR' or $type eq 'UNIVERSAL') {
279 6   50     75 $type = reftype $object // '';
280              
281 6 100       71 return [@$object] if $type eq 'ARRAY';
282 5 50       16 return {%$object} if $type eq 'HASH';
283 5 50       17 return $$object if $type eq 'FLOAT';
284 5 50       100 return $$object if $type eq 'INTEGER';
285 5 50       19 return $$object if $type eq 'NUMBER';
286 5 50       16 return $$object if $type eq 'REGEXP';
287 5 50       46 return $$object if $type eq 'SCALAR';
288 0 0       0 return $$object if $type eq 'STRING';
289 0 0       0 return undef if $type eq 'UNDEF';
290              
291 0 0       0 if ($type eq 'REF') {
292 0 0       0 $type = deduce_type($object = $$object)
293             and goto INSPECT;
294             }
295             }
296              
297 6 50       31 if ($type eq 'CODE') {
298 6     3   85 return sub { goto &{$object} };
  3         6  
  3         22  
299             }
300              
301 0         0 return undef;
302             }
303              
304             sub detract_deep {
305 1017     1017 1 2173 my @objects = @_;
306              
307 1017         1845 for my $object (@objects) {
308 1017         7247 $object = detract($object);
309              
310 1017 100 100     5481 if ($object and 'HASH' eq ref $object) {
311 6         16 for my $i (keys %$object) {
312 13         24 my $val = $object->{$i};
313 13 100       56 $object->{$i} = ref($val) ? detract_deep($val) : detract($val);
314             }
315             }
316              
317 1017 100 100     5267 if ($object and 'ARRAY' eq ref $object) {
318 8         44 for (my $i = 0; $i < @$object; $i++) {
319 25         50 my $val = $object->[$i];
320 25 100       78 $object->[$i] = ref($val) ? detract_deep($val) : detract($val);
321             }
322             }
323             }
324              
325 1017 100       679737 return wantarray ? (@objects) : $objects[0];
326             }
327              
328             {
329             # aliases
330 223     223   1339 no warnings 'once';
  223         408  
  223         49198  
331              
332             *type_array = \&data_array;
333             *type_code = \&data_code;
334             *type_float = \&data_float;
335             *type_hash = \&data_hash;
336             *type_integer = \&data_integer;
337             *type_number = \&data_number;
338             *type_regexp = \&data_regexp;
339             *type_scalar = \&data_scalar;
340             *type_string = \&data_string;
341             *type_undef = \&data_undef;
342             *type_universal = \&data_universal;
343             }
344              
345             1;
346              
347             __END__