line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# ABSTRACT: Data Type Objects for Perl 5 |
2
|
|
|
|
|
|
|
package Data::Object; |
3
|
|
|
|
|
|
|
|
4
|
219
|
|
|
219
|
|
314766
|
use 5.010; |
|
219
|
|
|
|
|
584
|
|
|
219
|
|
|
|
|
8111
|
|
5
|
219
|
|
|
219
|
|
1051
|
use strict; |
|
219
|
|
|
|
|
322
|
|
|
219
|
|
|
|
|
8210
|
|
6
|
219
|
|
|
219
|
|
1024
|
use warnings; |
|
219
|
|
|
|
|
298
|
|
|
219
|
|
|
|
|
7108
|
|
7
|
|
|
|
|
|
|
|
8
|
219
|
|
|
219
|
|
931
|
use Carp; |
|
219
|
|
|
|
|
320
|
|
|
219
|
|
|
|
|
13855
|
|
9
|
|
|
|
|
|
|
|
10
|
219
|
|
|
219
|
|
1165
|
use Exporter qw(import); |
|
219
|
|
|
|
|
704
|
|
|
219
|
|
|
|
|
7818
|
|
11
|
219
|
|
|
219
|
|
1755
|
use Scalar::Util qw(blessed looks_like_number reftype); |
|
219
|
|
|
|
|
1191
|
|
|
219
|
|
|
|
|
415091
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
our @EXPORT_OK = qw( |
14
|
|
|
|
|
|
|
codify |
15
|
|
|
|
|
|
|
data_array |
16
|
|
|
|
|
|
|
data_code |
17
|
|
|
|
|
|
|
data_float |
18
|
|
|
|
|
|
|
data_hash |
19
|
|
|
|
|
|
|
data_integer |
20
|
|
|
|
|
|
|
data_number |
21
|
|
|
|
|
|
|
data_regexp |
22
|
|
|
|
|
|
|
data_scalar |
23
|
|
|
|
|
|
|
data_string |
24
|
|
|
|
|
|
|
data_undef |
25
|
|
|
|
|
|
|
data_universal |
26
|
|
|
|
|
|
|
deduce |
27
|
|
|
|
|
|
|
deduce_deep |
28
|
|
|
|
|
|
|
deduce_type |
29
|
|
|
|
|
|
|
detract |
30
|
|
|
|
|
|
|
detract_deep |
31
|
|
|
|
|
|
|
load |
32
|
|
|
|
|
|
|
type_array |
33
|
|
|
|
|
|
|
type_code |
34
|
|
|
|
|
|
|
type_float |
35
|
|
|
|
|
|
|
type_hash |
36
|
|
|
|
|
|
|
type_integer |
37
|
|
|
|
|
|
|
type_number |
38
|
|
|
|
|
|
|
type_regexp |
39
|
|
|
|
|
|
|
type_scalar |
40
|
|
|
|
|
|
|
type_string |
41
|
|
|
|
|
|
|
type_undef |
42
|
|
|
|
|
|
|
type_universal |
43
|
|
|
|
|
|
|
); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( |
46
|
|
|
|
|
|
|
data => [grep m/data_/, @EXPORT_OK], |
47
|
|
|
|
|
|
|
type => [grep m/type_/, @EXPORT_OK], |
48
|
|
|
|
|
|
|
); |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
our $VERSION = '0.20'; # VERSION |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub new { |
53
|
0
|
0
|
|
0
|
0
|
0
|
shift and goto &deduce_deep; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
sub codify ($) { |
57
|
5
|
|
|
5
|
0
|
10
|
my $code = shift; |
58
|
5
|
|
|
|
|
42
|
my $vars = sprintf 'my ($%s) = @_;', join ',$', 'a'..'z'; |
59
|
5
|
|
100
|
|
|
25
|
my $body = sprintf 'sub { %s do { %s } }', $vars, $code // 'return(@_)'; |
60
|
|
|
|
|
|
|
|
61
|
5
|
|
|
|
|
7
|
my $sub; |
62
|
5
|
|
|
|
|
8
|
my $error = do { local $@; $sub = eval $body; $@ }; |
|
5
|
|
|
|
|
6
|
|
|
5
|
|
|
|
|
649
|
|
|
5
|
|
|
|
|
15
|
|
63
|
|
|
|
|
|
|
|
64
|
5
|
50
|
|
|
|
18
|
croak $error unless $sub; |
65
|
5
|
|
|
|
|
17
|
return $sub; |
66
|
|
|
|
|
|
|
}; |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
sub load ($) { |
69
|
892
|
|
|
892
|
1
|
3022
|
my $class = shift; |
70
|
892
|
|
33
|
|
|
6548
|
my $failed = ! $class || $class !~ /^\w(?:[\w:']*\w)?$/; |
71
|
|
|
|
|
|
|
|
72
|
892
|
|
|
|
|
927
|
my $loaded; |
73
|
892
|
|
|
|
|
931
|
my $error = do { |
74
|
892
|
|
|
|
|
1036
|
local $@; |
75
|
892
|
|
100
|
|
|
17158
|
$loaded = $class->can('new') || eval "require $class; 1"; |
76
|
892
|
|
|
|
|
1858
|
$@; |
77
|
|
|
|
|
|
|
}; |
78
|
|
|
|
|
|
|
|
79
|
892
|
50
|
66
|
|
|
6169
|
croak join ": ", "Error attempting to load $class", $error |
|
|
|
66
|
|
|
|
|
80
|
|
|
|
|
|
|
if $error or $failed or not $loaded; |
81
|
|
|
|
|
|
|
|
82
|
891
|
|
|
|
|
2940
|
return $class; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub data_array ($) { |
86
|
90
|
|
|
90
|
1
|
1643
|
unshift @_, my $class = load 'Data::Object::Array'; |
87
|
90
|
|
|
|
|
720
|
goto $class->can('new'); |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
sub data_code ($) { |
91
|
14
|
|
|
14
|
1
|
1237
|
unshift @_, my $class = load 'Data::Object::Code'; |
92
|
14
|
|
|
|
|
104
|
goto $class->can('new'); |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
sub data_float ($) { |
96
|
16
|
|
|
16
|
1
|
3683
|
unshift @_, my $class = load 'Data::Object::Float'; |
97
|
16
|
|
|
|
|
117
|
goto $class->can('new'); |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
sub data_hash ($) { |
101
|
24
|
|
|
24
|
1
|
1355
|
unshift @_, my $class = load 'Data::Object::Hash'; |
102
|
24
|
|
|
|
|
175
|
goto $class->can('new'); |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
sub data_integer ($) { |
106
|
36
|
|
|
36
|
1
|
5998
|
unshift @_, my $class = load 'Data::Object::Integer'; |
107
|
36
|
|
|
|
|
232
|
goto $class->can('new'); |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub data_number ($) { |
111
|
554
|
|
|
554
|
1
|
4935
|
unshift @_, my $class = load 'Data::Object::Number'; |
112
|
554
|
|
|
|
|
3284
|
goto $class->can('new'); |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub data_regexp ($) { |
116
|
4
|
|
|
4
|
1
|
17
|
unshift @_, my $class = load 'Data::Object::Regexp'; |
117
|
4
|
|
|
|
|
32
|
goto $class->can('new'); |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
sub data_scalar ($) { |
121
|
2
|
|
|
2
|
1
|
2159
|
unshift @_, my $class = load 'Data::Object::Scalar'; |
122
|
2
|
|
|
|
|
18
|
goto $class->can('new'); |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
sub data_string ($) { |
126
|
136
|
|
|
136
|
1
|
1918
|
unshift @_, my $class = load 'Data::Object::String'; |
127
|
136
|
|
|
|
|
826
|
goto $class->can('new'); |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
sub data_undef (;$) { |
131
|
12
|
|
|
12
|
1
|
1001
|
unshift @_, my $class = load 'Data::Object::Undef'; |
132
|
12
|
|
|
|
|
79
|
goto $class->can('new'); |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sub data_universal ($) { |
136
|
2
|
|
|
2
|
1
|
1224
|
unshift @_, my $class = load 'Data::Object::Universal'; |
137
|
2
|
|
|
|
|
10
|
goto $class->can('new'); |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
sub deduce ($) { |
141
|
3465
|
|
|
3465
|
1
|
11479
|
my $scalar = shift; |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# return undef |
144
|
3465
|
100
|
|
|
|
11987
|
if (not defined $scalar) { |
|
|
100
|
|
|
|
|
|
145
|
10
|
|
|
|
|
33
|
return data_undef $scalar; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
# handle blessed objects |
149
|
|
|
|
|
|
|
elsif (blessed $scalar) { |
150
|
2607
|
100
|
|
|
|
11917
|
return data_regexp $scalar if $scalar->isa('Regexp'); |
151
|
2603
|
|
|
|
|
4402
|
return $scalar; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# handle data types |
155
|
|
|
|
|
|
|
# ... using spaces for clarity |
156
|
|
|
|
|
|
|
else { |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
# handle references |
159
|
848
|
100
|
|
|
|
1663
|
if (ref $scalar) { |
160
|
122
|
100
|
|
|
|
634
|
return data_array $scalar if 'ARRAY' eq ref $scalar; |
161
|
34
|
100
|
|
|
|
183
|
return data_hash $scalar if 'HASH' eq ref $scalar; |
162
|
12
|
50
|
|
|
|
68
|
return data_code $scalar if 'CODE' eq ref $scalar; |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# handle non-references |
166
|
|
|
|
|
|
|
else { |
167
|
726
|
100
|
|
|
|
2124
|
if (looks_like_number $scalar) { |
168
|
592
|
100
|
|
|
|
2433
|
return data_float $scalar if $scalar =~ /\./; |
169
|
580
|
100
|
|
|
|
3660
|
return data_number $scalar if $scalar =~ /^\d+$/; |
170
|
30
|
|
|
|
|
95
|
return data_integer $scalar; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
else { |
173
|
134
|
|
|
|
|
309
|
return data_string $scalar; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
# handle unhandled |
178
|
0
|
|
|
|
|
0
|
return data_scalar $scalar; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
# fallback |
183
|
0
|
|
|
|
|
0
|
return data_undef $scalar; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
sub deduce_deep { |
187
|
446
|
|
|
446
|
1
|
3929
|
my @objects = @_; |
188
|
|
|
|
|
|
|
|
189
|
446
|
|
|
|
|
909
|
for my $object (@objects) { |
190
|
446
|
|
|
|
|
535
|
my $type; |
191
|
|
|
|
|
|
|
|
192
|
446
|
|
|
|
|
1040
|
$object = deduce($object); |
193
|
446
|
|
|
|
|
1385
|
$type = deduce_type($object); |
194
|
|
|
|
|
|
|
|
195
|
446
|
100
|
100
|
|
|
2423
|
if ($type and $type eq 'HASH') { |
196
|
34
|
|
|
|
|
171
|
for my $i (keys %$object) { |
197
|
91
|
|
|
|
|
168
|
my $val = $object->{$i}; |
198
|
91
|
100
|
|
|
|
315
|
$object->{$i} = ref($val) ? deduce_deep($val) : deduce($val); |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
446
|
100
|
100
|
|
|
3132
|
if ($type and $type eq 'ARRAY') { |
203
|
123
|
|
|
|
|
529
|
for (my $i = 0; $i < @$object; $i++) { |
204
|
493
|
|
|
|
|
678
|
my $val = $object->[$i]; |
205
|
493
|
100
|
|
|
|
1348
|
$object->[$i] = ref($val) ? deduce_deep($val) : deduce($val); |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
446
|
100
|
|
|
|
3805
|
return wantarray ? (@objects) : $objects[0]; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
sub deduce_type ($) { |
214
|
1487
|
|
|
1487
|
1
|
8822
|
my $object = deduce shift; |
215
|
|
|
|
|
|
|
|
216
|
1487
|
100
|
|
|
|
7191
|
return 'ARRAY' if $object->isa('Data::Object::Array'); |
217
|
1355
|
100
|
|
|
|
5431
|
return 'HASH' if $object->isa('Data::Object::Hash'); |
218
|
1313
|
100
|
|
|
|
5000
|
return 'CODE' if $object->isa('Data::Object::Code'); |
219
|
|
|
|
|
|
|
|
220
|
1296
|
100
|
|
|
|
4887
|
return 'FLOAT' if $object->isa('Data::Object::Float'); |
221
|
1241
|
100
|
|
|
|
4424
|
return 'NUMBER' if $object->isa('Data::Object::Number'); |
222
|
317
|
100
|
|
|
|
1255
|
return 'INTEGER' if $object->isa('Data::Object::Integer'); |
223
|
|
|
|
|
|
|
|
224
|
283
|
100
|
|
|
|
1095
|
return 'STRING' if $object->isa('Data::Object::String'); |
225
|
32
|
100
|
|
|
|
142
|
return 'SCALAR' if $object->isa('Data::Object::Scalar'); |
226
|
29
|
100
|
|
|
|
136
|
return 'REGEXP' if $object->isa('Data::Object::Regexp'); |
227
|
|
|
|
|
|
|
|
228
|
22
|
100
|
|
|
|
104
|
return 'UNDEF' if $object->isa('Data::Object::Undef'); |
229
|
6
|
100
|
|
|
|
35
|
return 'UNIVERSAL' if $object->isa('Data::Object::Universal'); |
230
|
|
|
|
|
|
|
|
231
|
3
|
|
|
|
|
7
|
return undef; |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
sub detract ($) { |
235
|
1030
|
|
|
1030
|
1
|
5697
|
my $object = deduce shift; |
236
|
1030
|
|
|
|
|
2430
|
my $type = deduce_type $object; |
237
|
|
|
|
|
|
|
|
238
|
1030
|
100
|
|
|
|
3422
|
INSPECT: |
239
|
|
|
|
|
|
|
return $object unless $type; |
240
|
|
|
|
|
|
|
|
241
|
1029
|
100
|
|
|
|
2362
|
return [@$object] if $type eq 'ARRAY'; |
242
|
1021
|
100
|
|
|
|
1938
|
return {%$object} if $type eq 'HASH'; |
243
|
1014
|
100
|
|
|
|
2133
|
return $$object if $type eq 'REGEXP'; |
244
|
1009
|
100
|
|
|
|
2443
|
return $$object if $type eq 'FLOAT'; |
245
|
962
|
100
|
|
|
|
19620
|
return $$object if $type eq 'NUMBER'; |
246
|
246
|
100
|
|
|
|
1431
|
return $$object if $type eq 'INTEGER'; |
247
|
221
|
100
|
|
|
|
5568
|
return $$object if $type eq 'STRING'; |
248
|
24
|
100
|
|
|
|
68
|
return undef if $type eq 'UNDEF'; |
249
|
|
|
|
|
|
|
|
250
|
12
|
100
|
100
|
|
|
117
|
if ($type eq 'SCALAR' or $type eq 'UNIVERSAL') { |
251
|
6
|
|
50
|
|
|
38
|
$type = reftype $object // ''; |
252
|
|
|
|
|
|
|
|
253
|
6
|
100
|
|
|
|
24
|
return [@$object] if $type eq 'ARRAY'; |
254
|
5
|
50
|
|
|
|
14
|
return {%$object} if $type eq 'HASH'; |
255
|
5
|
50
|
|
|
|
14
|
return $$object if $type eq 'FLOAT'; |
256
|
5
|
50
|
|
|
|
51
|
return $$object if $type eq 'INTEGER'; |
257
|
5
|
50
|
|
|
|
44
|
return $$object if $type eq 'NUMBER'; |
258
|
5
|
50
|
|
|
|
21
|
return $$object if $type eq 'REGEXP'; |
259
|
5
|
50
|
|
|
|
39
|
return $$object if $type eq 'SCALAR'; |
260
|
0
|
0
|
|
|
|
0
|
return $$object if $type eq 'STRING'; |
261
|
0
|
0
|
|
|
|
0
|
return undef if $type eq 'UNDEF'; |
262
|
|
|
|
|
|
|
|
263
|
0
|
0
|
|
|
|
0
|
if ($type eq 'REF') { |
264
|
0
|
0
|
|
|
|
0
|
$type = deduce_type($object = $$object) |
265
|
|
|
|
|
|
|
and goto INSPECT; |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
6
|
50
|
|
|
|
16
|
if ($type eq 'CODE') { |
270
|
6
|
|
|
3
|
|
24
|
return sub { goto &{$object} }; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
22
|
|
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
0
|
|
|
|
|
0
|
return undef; |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
sub detract_deep { |
277
|
996
|
|
|
996
|
1
|
1890
|
my @objects = @_; |
278
|
|
|
|
|
|
|
|
279
|
996
|
|
|
|
|
1741
|
for my $object (@objects) { |
280
|
996
|
|
|
|
|
1943
|
$object = detract($object); |
281
|
|
|
|
|
|
|
|
282
|
996
|
100
|
100
|
|
|
4778
|
if ($object and 'HASH' eq ref $object) { |
283
|
6
|
|
|
|
|
19
|
for my $i (keys %$object) { |
284
|
13
|
|
|
|
|
26
|
my $val = $object->{$i}; |
285
|
13
|
100
|
|
|
|
51
|
$object->{$i} = ref($val) ? detract_deep($val) : detract($val); |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
|
289
|
996
|
100
|
100
|
|
|
4912
|
if ($object and 'ARRAY' eq ref $object) { |
290
|
8
|
|
|
|
|
41
|
for (my $i = 0; $i < @$object; $i++) { |
291
|
25
|
|
|
|
|
34
|
my $val = $object->[$i]; |
292
|
25
|
100
|
|
|
|
106
|
$object->[$i] = ref($val) ? detract_deep($val) : detract($val); |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
|
297
|
996
|
100
|
|
|
|
8730
|
return wantarray ? (@objects) : $objects[0]; |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
{ |
301
|
|
|
|
|
|
|
# aliases |
302
|
219
|
|
|
219
|
|
1619
|
no warnings 'once'; |
|
219
|
|
|
|
|
1609
|
|
|
219
|
|
|
|
|
38083
|
|
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
*type_array = \&data_array; |
305
|
|
|
|
|
|
|
*type_code = \&data_code; |
306
|
|
|
|
|
|
|
*type_float = \&data_float; |
307
|
|
|
|
|
|
|
*type_hash = \&data_hash; |
308
|
|
|
|
|
|
|
*type_integer = \&data_integer; |
309
|
|
|
|
|
|
|
*type_number = \&data_number; |
310
|
|
|
|
|
|
|
*type_regexp = \&data_regexp; |
311
|
|
|
|
|
|
|
*type_scalar = \&data_scalar; |
312
|
|
|
|
|
|
|
*type_string = \&data_string; |
313
|
|
|
|
|
|
|
*type_undef = \&data_undef; |
314
|
|
|
|
|
|
|
*type_universal = \&data_universal; |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
1; |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
__END__ |