File Coverage

blib/lib/Data/Object/Cast.pm
Criterion Covered Total %
statement 135 137 98.5
branch 91 120 75.8
condition 11 17 64.7
subroutine 25 25 100.0
pod 5 19 26.3
total 267 318 83.9


line stmt bran cond sub pod time code
1             package Data::Object::Cast;
2              
3 1     1   39253 use 5.014;
  1         3  
4              
5 1     1   5 use strict;
  1         2  
  1         20  
6 1     1   5 use warnings;
  1         2  
  1         37  
7              
8 1     1   544 use Data::Object::Space;
  1         11112  
  1         40  
9              
10 1         1910 use Scalar::Util qw(
11             blessed
12             looks_like_number
13             reftype
14 1     1   7 );
  1         2  
15              
16             our $To = 'Data::Object';
17              
18             our $VERSION = '0.02'; # VERSION
19              
20             # FUNCTIONS
21              
22             sub Deduce {
23 82     82 1 163509 my ($data) = @_;
24              
25 82 100       189 return TypeUndef($data) if not(defined($data));
26 79 100       234 return DeduceBlessed($data) if blessed($data);
27 38         71 return DeduceDefined($data);
28             }
29              
30             sub DeduceDefined {
31 38     38 0 57 my ($data) = @_;
32              
33 38 100       99 return DeduceReferences($data) if ref($data);
34 21 100       75 return DeduceNumberlike($data) if looks_like_number($data);
35 3         9 return DeduceStringLike($data);
36             }
37              
38             sub DeduceBlessed {
39 41     41 0 66 my ($data) = @_;
40              
41 41 100       182 return TypeRegexp($data) if $data->isa('Regexp');
42 38         82 return $data;
43             }
44              
45             sub DeduceReferences {
46 17     17 0 29 my ($data) = @_;
47              
48 17 100       56 return TypeArray($data) if 'ARRAY' eq ref $data;
49 12 100       41 return TypeCode($data) if 'CODE' eq ref $data;
50 9 100       32 return TypeHash($data) if 'HASH' eq ref $data;
51 4         12 return TypeScalar($data); # glob, etc
52             }
53              
54             sub DeduceNumberlike {
55 18     18 0 29 my ($data) = @_;
56              
57 18 100       83 return TypeFloat($data) if $data =~ /\./;
58 15         31 return TypeNumber($data);
59             }
60              
61             sub DeduceStringLike {
62 3     3 0 7 my ($data) = @_;
63              
64 3         12 return TypeString($data);
65             }
66              
67             sub DeduceDeep {
68 4     4 1 28309 my @data = map Deduce($_), @_;
69              
70 4         40 for my $data (@data) {
71 4         11 my $type = TypeName($data);
72              
73 4 100 66     24 if ($type and $type eq 'HASH') {
74 2         10 for my $i (keys %$data) {
75 4         20 my $val = $data->{$i};
76 4 50       11 $data->{$i} = ref($val) ? DeduceDeep($val) : Deduce($val);
77             }
78             }
79 4 100 66     32 if ($type and $type eq 'ARRAY') {
80 2         9 for (my $i = 0; $i < @$data; $i++) {
81 8         46 my $val = $data->[$i];
82 8 50       21 $data->[$i] = ref($val) ? DeduceDeep($val) : Deduce($val);
83             }
84             }
85             }
86              
87 4 100       45 return wantarray ? (@data) : $data[0];
88             }
89              
90             sub Detract {
91 17     17 1 89 my ($data) = (Deduce($_[0]));
92 17         35 my $type = TypeName($data);
93              
94 18 50       43 INSPECT:
95             return $data unless $type;
96              
97 18 100       49 return [@$data] if $type eq 'ARRAY';
98 16 100       45 return {%$data} if $type eq 'HASH';
99              
100 14 50       28 return $$data if $type eq 'BOOLEAN';
101 14 100       36 return $$data if $type eq 'REGEXP';
102 13 100       31 return $$data if $type eq 'FLOAT';
103 12 100       37 return $$data if $type eq 'NUMBER';
104 5 100       20 return $$data if $type eq 'STRING';
105              
106 4 100       17 return undef if $type eq 'UNDEF';
107              
108 3 100 66     17 if ($type eq 'ANY' or $type eq 'SCALAR') {
109 2   50     10 $type = reftype($data) // '';
110              
111 2 50       6 return [@$data] if $type eq 'ARRAY';
112 2 50       6 return {%$data} if $type eq 'HASH';
113              
114 2 50       5 return $$data if $type eq 'BOOLEAN';
115 2 50       6 return $$data if $type eq 'FLOAT';
116 2 50       4 return $$data if $type eq 'NUMBER';
117 2 50       7 return $$data if $type eq 'REGEXP';
118 2 50       4 return $$data if $type eq 'STRING';
119              
120 2 50       5 return undef if $type eq 'UNDEF';
121              
122 2 100       5 if ($type eq 'SCALAR') {
123 1         3 return do { my $v = $$data; \$v };
  1         2  
  1         11  
124             }
125              
126 1 50       3 if ($type eq 'REF') {
127 1 50       3 $type = TypeName($data = $$data) and goto INSPECT;
128             }
129             }
130              
131 1 50       4 if ($type eq 'CODE') {
132 1     1   13 return sub { goto $data };
  1         1376  
133             }
134              
135 0         0 return undef;
136             }
137              
138             sub DetractDeep {
139 8     8 1 17 my @data = map Detract($_), @_;
140              
141 8         15 for my $data (@data) {
142 8 100 66     28 if ($data and 'HASH' eq ref $data) {
143 1         6 for my $i (keys %$data) {
144 2         5 my $val = $data->{$i};
145 2 50       7 $data->{$i} = ref($val) ? DetractDeep($val) : Detract($val);
146             }
147             }
148 8 100 66     27 if ($data and 'ARRAY' eq ref $data) {
149 1         5 for (my $i = 0; $i < @$data; $i++) {
150 4         6 my $val = $data->[$i];
151 4 50       14 $data->[$i] = ref($val) ? DetractDeep($val) : Detract($val);
152             }
153             }
154             }
155              
156 8 50       42 return wantarray ? (@data) : $data[0];
157             }
158              
159             sub TypeName {
160 31     31 1 67812 my ($data) = (Deduce($_[0]));
161              
162 31 100       203 return "ARRAY" if $data->isa("${To}::Array");
163 26 50       102 return "BOOLEAN" if $data->isa("${To}::Boolean");
164 26 100       98 return "HASH" if $data->isa("${To}::Hash");
165 21 100       81 return "CODE" if $data->isa("${To}::Code");
166 19 100       71 return "FLOAT" if $data->isa("${To}::Float");
167 17 100       113 return "NUMBER" if $data->isa("${To}::Number");
168 9 100       45 return "STRING" if $data->isa("${To}::String");
169 7 100       51 return "SCALAR" if $data->isa("${To}::Scalar");
170 4 100       26 return "REGEXP" if $data->isa("${To}::Regexp");
171 2 50       24 return "UNDEF" if $data->isa("${To}::Undef");
172              
173 0         0 return undef;
174             }
175              
176             sub TypeArray {
177 5     5 0 14 my $class = "${To}::Array";
178 5         23 my $space = Data::Object::Space->new($class);
179 5         55 my $point = $space->load->can('new');
180              
181 5 50       239 unshift @_, $class and goto $point;
182             }
183              
184             sub TypeCode {
185 3     3 0 10 my $class = "${To}::Code";
186 3         14 my $space = Data::Object::Space->new($class);
187 3         33 my $point = $space->load->can('new');
188              
189 3 50       149 unshift @_, $class and goto $point;
190             }
191              
192             sub TypeFloat {
193 3     3 0 11 my $class = "${To}::Float";
194 3         13 my $space = Data::Object::Space->new($class);
195 3         33 my $point = $space->load->can('new');
196              
197 3 50       128 unshift @_, $class and goto $point;
198             }
199              
200             sub TypeHash {
201 5     5 0 42 my $class = "${To}::Hash";
202 5         36 my $space = Data::Object::Space->new($class);
203 5         53 my $point = $space->load->can('new');
204              
205 5 50       222 unshift @_, $class and goto $point;
206             }
207              
208             sub TypeNumber {
209 15     15 0 37 my $class = "${To}::Number";
210 15         38 my $space = Data::Object::Space->new($class);
211 15         165 my $point = $space->load->can('new');
212              
213 15 50       447 unshift @_, $class and goto $point;
214             }
215              
216             sub TypeRegexp {
217 3     3 0 10 my $class = "${To}::Regexp";
218 3         11 my $space = Data::Object::Space->new($class);
219 3         33 my $point = $space->load->can('new');
220              
221 3 50       132 unshift @_, $class and goto $point;
222             }
223              
224             sub TypeScalar {
225 4     4 0 12 my $class = "${To}::Scalar";
226 4         16 my $space = Data::Object::Space->new($class);
227 4         42 my $point = $space->load->can('new');
228              
229 4 50       182 unshift @_, $class and goto $point;
230             }
231              
232             sub TypeString {
233 3     3 0 10 my $class = "${To}::String";
234 3         13 my $space = Data::Object::Space->new($class);
235 3         37 my $point = $space->load->can('new');
236              
237 3 50       143 unshift @_, $class and goto $point;
238             }
239              
240             sub TypeUndef {
241 3     3 0 14 my $class = "${To}::Undef";
242 3         14 my $space = Data::Object::Space->new($class);
243 3         35 my $point = $space->load->can('new');
244              
245 3 50       134 unshift @_, $class and goto $point;
246             }
247              
248             1;
249              
250             =encoding utf8
251              
252             =head1 NAME
253              
254             Data::Object::Cast
255              
256             =cut
257              
258             =head1 ABSTRACT
259              
260             Data Type Casting for Perl 5
261              
262             =cut
263              
264             =head1 SYNOPSIS
265              
266             package main;
267              
268             use Data::Object::Cast;
269              
270             local $Data::Object::Cast::To = 'Test::Object';
271              
272             # Data::Object::Cast::Deduce([1..4]); # Test::Object::Array
273              
274             =cut
275              
276             =head1 DESCRIPTION
277              
278             This package provides functions for casting native data types to objects and
279             the reverse.
280              
281             =cut
282              
283             =head1 LIBRARIES
284              
285             This package uses type constraints from:
286              
287             L<Types::Standard>
288              
289             =cut
290              
291             =head1 FUNCTIONS
292              
293             This package implements the following functions:
294              
295             =cut
296              
297             =head2 deduce
298              
299             Deduce(Any $value) : Object
300              
301             The Deduce function returns the argument as a data type object.
302              
303             =over 4
304              
305             =item Deduce example #1
306              
307             # given: synopsis
308              
309             Data::Object::Cast::Deduce([1..4])
310              
311             # $array
312              
313             =back
314              
315             =over 4
316              
317             =item Deduce example #2
318              
319             # given: synopsis
320              
321             Data::Object::Cast::Deduce(sub { shift })
322              
323             # $code
324              
325             =back
326              
327             =over 4
328              
329             =item Deduce example #3
330              
331             # given: synopsis
332              
333             Data::Object::Cast::Deduce(1.23)
334              
335             # $float
336              
337             =back
338              
339             =over 4
340              
341             =item Deduce example #4
342              
343             # given: synopsis
344              
345             Data::Object::Cast::Deduce({1..4})
346              
347             # $hash
348              
349             =back
350              
351             =over 4
352              
353             =item Deduce example #5
354              
355             # given: synopsis
356              
357             Data::Object::Cast::Deduce(123)
358              
359             # $number
360              
361             =back
362              
363             =over 4
364              
365             =item Deduce example #6
366              
367             # given: synopsis
368              
369             Data::Object::Cast::Deduce(qr/.*/)
370              
371             # $regexp
372              
373             =back
374              
375             =over 4
376              
377             =item Deduce example #7
378              
379             # given: synopsis
380              
381             Data::Object::Cast::Deduce(\'abc')
382              
383             # $scalar
384              
385             =back
386              
387             =over 4
388              
389             =item Deduce example #8
390              
391             # given: synopsis
392              
393             Data::Object::Cast::Deduce('abc')
394              
395             # $string
396              
397             =back
398              
399             =over 4
400              
401             =item Deduce example #9
402              
403             # given: synopsis
404              
405             Data::Object::Cast::Deduce(undef)
406              
407             # $undef
408              
409             =back
410              
411             =cut
412              
413             =head2 deducedeep
414              
415             DeduceDeep(Any @args) : (Object)
416              
417             The DeduceDeep function returns any arguments as data type objects, including
418             nested data.
419              
420             =over 4
421              
422             =item DeduceDeep example #1
423              
424             # given: synopsis
425              
426             Data::Object::Cast::DeduceDeep([1..4])
427              
428             # $array <$number>
429              
430             =back
431              
432             =over 4
433              
434             =item DeduceDeep example #2
435              
436             # given: synopsis
437              
438             Data::Object::Cast::DeduceDeep({1..4})
439              
440             # $hash <$number>
441              
442             =back
443              
444             =cut
445              
446             =head2 detract
447              
448             Detract(Any $value) : Any
449              
450             The Detract function returns the argument as native Perl data type value.
451              
452             =over 4
453              
454             =item Detract example #1
455              
456             # given: synopsis
457              
458             Data::Object::Cast::Detract(
459             Data::Object::Cast::Deduce(
460             [1..4]
461             )
462             )
463              
464             # $arrayref
465              
466             =back
467              
468             =over 4
469              
470             =item Detract example #2
471              
472             # given: synopsis
473              
474             Data::Object::Cast::Detract(
475             Data::Object::Cast::Deduce(
476             sub { shift }
477             )
478             )
479              
480             # $coderef
481              
482             =back
483              
484             =over 4
485              
486             =item Detract example #3
487              
488             # given: synopsis
489              
490             Data::Object::Cast::Detract(
491             Data::Object::Cast::Deduce(
492             1.23
493             )
494             )
495              
496             # $number
497              
498             =back
499              
500             =over 4
501              
502             =item Detract example #4
503              
504             # given: synopsis
505              
506             Data::Object::Cast::Detract(
507             Data::Object::Cast::Deduce(
508             {1..4}
509             )
510             )
511              
512             # $hashref
513              
514             =back
515              
516             =over 4
517              
518             =item Detract example #5
519              
520             # given: synopsis
521              
522             Data::Object::Cast::Detract(
523             Data::Object::Cast::Deduce(
524             123
525             )
526             )
527              
528             # $number
529              
530             =back
531              
532             =over 4
533              
534             =item Detract example #6
535              
536             # given: synopsis
537              
538             Data::Object::Cast::Detract(
539             Data::Object::Cast::Deduce(
540             qr/.*/
541             )
542             )
543              
544             # $regexp
545              
546             =back
547              
548             =over 4
549              
550             =item Detract example #7
551              
552             # given: synopsis
553              
554             Data::Object::Cast::Detract(
555             Data::Object::Cast::Deduce(
556             \'abc'
557             )
558             )
559              
560             # $scalarref
561              
562             =back
563              
564             =over 4
565              
566             =item Detract example #8
567              
568             # given: synopsis
569              
570             Data::Object::Cast::Detract(
571             Data::Object::Cast::Deduce(
572             'abc'
573             )
574             )
575              
576             # $string
577              
578             =back
579              
580             =over 4
581              
582             =item Detract example #9
583              
584             # given: synopsis
585              
586             Data::Object::Cast::Detract(
587             Data::Object::Cast::Deduce(
588             undef
589             )
590             )
591              
592             # $undef
593              
594             =back
595              
596             =cut
597              
598             =head2 detractdeep
599              
600             DetractDeep(Any @args) : (Any)
601              
602             The DetractDeep function returns any arguments as native Perl data type values,
603             including nested data.
604              
605             =over 4
606              
607             =item DetractDeep example #1
608              
609             # given: synopsis
610              
611             Data::Object::Cast::DetractDeep(
612             Data::Object::Cast::DeduceDeep(
613             [1..4]
614             )
615             )
616              
617             =back
618              
619             =over 4
620              
621             =item DetractDeep example #2
622              
623             # given: synopsis
624              
625             Data::Object::Cast::DetractDeep(
626             Data::Object::Cast::DeduceDeep(
627             {1..4}
628             )
629             )
630              
631             =back
632              
633             =cut
634              
635             =head2 typename
636              
637             TypeName(Any $value) : Maybe[Str]
638              
639             The TypeName function returns the name of the value's data type.
640              
641             =over 4
642              
643             =item TypeName example #1
644              
645             # given: synopsis
646              
647             Data::Object::Cast::TypeName([1..4])
648              
649             # 'ARRAY'
650              
651             =back
652              
653             =over 4
654              
655             =item TypeName example #2
656              
657             # given: synopsis
658              
659             Data::Object::Cast::TypeName(sub { shift })
660              
661             # 'CODE'
662              
663             =back
664              
665             =over 4
666              
667             =item TypeName example #3
668              
669             # given: synopsis
670              
671             Data::Object::Cast::TypeName(1.23)
672              
673             # 'FLOAT'
674              
675             =back
676              
677             =over 4
678              
679             =item TypeName example #4
680              
681             # given: synopsis
682              
683             Data::Object::Cast::TypeName({1..4})
684              
685             # 'HASH'
686              
687             =back
688              
689             =over 4
690              
691             =item TypeName example #5
692              
693             # given: synopsis
694              
695             Data::Object::Cast::TypeName(123)
696              
697             # 'NUMBER'
698              
699             =back
700              
701             =over 4
702              
703             =item TypeName example #6
704              
705             # given: synopsis
706              
707             Data::Object::Cast::TypeName(qr/.*/)
708              
709             # 'REGEXP'
710              
711             =back
712              
713             =over 4
714              
715             =item TypeName example #7
716              
717             # given: synopsis
718              
719             Data::Object::Cast::TypeName(\'abc')
720              
721             # 'STRING'
722              
723             =back
724              
725             =over 4
726              
727             =item TypeName example #8
728              
729             # given: synopsis
730              
731             Data::Object::Cast::TypeName('abc')
732              
733             # 'STRING'
734              
735             =back
736              
737             =over 4
738              
739             =item TypeName example #9
740              
741             # given: synopsis
742              
743             Data::Object::Cast::TypeName(undef)
744              
745             # 'UNDEF'
746              
747             =back
748              
749             =cut
750              
751             =head1 AUTHOR
752              
753             Al Newkirk, C<awncorp@cpan.org>
754              
755             =head1 LICENSE
756              
757             Copyright (C) 2011-2019, Al Newkirk, et al.
758              
759             This is free software; you can redistribute it and/or modify it under the terms
760             of the The Apache License, Version 2.0, as elucidated in the L<"license
761             file"|https://github.com/iamalnewkirk/foobar/blob/master/LICENSE>.
762              
763             =head1 PROJECT
764              
765             L<Wiki|https://github.com/iamalnewkirk/foobar/wiki>
766              
767             L<Project|https://github.com/iamalnewkirk/foobar>
768              
769             L<Initiatives|https://github.com/iamalnewkirk/foobar/projects>
770              
771             L<Milestones|https://github.com/iamalnewkirk/foobar/milestones>
772              
773             L<Contributing|https://github.com/iamalnewkirk/foobar/blob/master/CONTRIBUTE.md>
774              
775             L<Issues|https://github.com/iamalnewkirk/foobar/issues>
776              
777             =cut