File Coverage

blib/lib/Build/Hopen/Util/Data.pm
Criterion Covered Total %
statement 31 63 49.2
branch 8 42 19.0
condition 0 6 0.0
subroutine 8 12 66.6
pod 5 5 100.0
total 52 128 40.6


line stmt bran cond sub pod time code
1             # Build::Hopen::Util::Data - general-purpose data-manipulation functions
2             package Build::Hopen::Util::Data;
3 10     10   1278 use Build::Hopen;
  10         25  
  10         545  
4 10     10   69 use Build::Hopen::Base;
  10         23  
  10         80  
5              
6             our $VERSION = '0.000008'; # TRIAL
7              
8 10     10   2522 use parent 'Exporter';
  10         27  
  10         67  
9             our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
10             BEGIN {
11 10     10   1167 @EXPORT = qw();
12 10         42 @EXPORT_OK = qw(boolify clone dedent forward_opts identical);
13 10         326 %EXPORT_TAGS = (
14             default => [@EXPORT],
15             all => [@EXPORT, @EXPORT_OK]
16             );
17             }
18              
19 10     10   68 use Scalar::Util qw( refaddr blessed );
  10         23  
  10         4250  
20              
21             # Docs {{{1
22              
23             =head1 NAME
24              
25             Build::Hopen::Util::Data - general-purpose data-manipulation functions
26              
27             =head1 FUNCTIONS
28              
29             Nothing is exported by default --- specify C<:all> if you want it all.
30              
31             =cut
32              
33             # }}}1
34              
35             =head2 boolify
36              
37             Convert a scalar to a Boolean as Perl does, except:
38              
39             =over
40              
41             =item * Falsy
42              
43             C
44              
45             =item * Truthy
46              
47             C<"0">
48              
49             =back
50              
51             So C, C, C, empty string, C, and numeric C<0> are falsy,
52             and all other values (including string C<'0'>) are truthy.
53              
54             =cut
55              
56             sub boolify {
57 0 0   0 1 0 return false if $_[0] =~ /^(false|off|no)$/i;
58 0 0       0 return true if $_[0] =~ /^0$/;
59 0         0 return !!$_[0];
60             } #boolify()
61              
62             =head2 clone
63              
64             Clones a scalar or a reference. Thin wrapper around L.
65              
66             =cut
67              
68             sub clone {
69 1     1 1 11 my $val = shift;
70 1 50       6 return $val unless ref($val);
71 0         0 return Storable::dclone($val);
72             } #clone()
73              
74             =head2 dedent
75              
76             Yet Another routine for dedenting multiline strings. Removes the leading
77             horizontal whitespace on the first nonblank line from all lines. If the first
78             argument is a reference, also trims for use in multiline C/C.
79             Usage:
80              
81             dedent " some\n multiline string";
82             dedent [], q(
83             very indented
84             ); # [] (or any ref) means do the extra trimming.
85              
86             The extra trimming includes:
87              
88             =over
89              
90             =item *
91              
92             Removing the initial C<\n>, if any; and
93              
94             =item *
95              
96             Removing trailing horizontal whitespace between the last C<\n> and the
97             end of the string.
98              
99             =back
100              
101             =cut
102              
103             sub dedent {
104 0 0 0 0 1 0 my $extra_trim = (@_ && ref $_[0]) ? (shift, true) : false;
105 0 0       0 my $val = @_ ? $_[0] : $_;
106 0         0 my $initial_NL;
107              
108 0 0       0 if($val =~ /\A\n/) {
109 0         0 $initial_NL = true;
110 0         0 $val =~ s/^\A\n//;
111             }
112              
113 0 0       0 if($val =~ m/^(?\h+)\S/m) {
114 10     10   4665 $val =~ s/^$+{ws}//gm;
  10         3507  
  10         5403  
  0         0  
115             }
116              
117 0 0       0 $val =~ s/^\h+\z//m if $extra_trim;
118              
119 0 0 0     0 return (($initial_NL && !$extra_trim) ? "\n" : '') . $val;
120             } #dedent()
121              
122             =head2 forward_opts
123              
124             Returns a list of key-value pairs extracted from a given hashref. Usage:
125              
126             my %forwarded_opts = forward_opts(\%original_opts, [option hashref,]
127             'name'[, 'name2'...]);
128              
129             If the option hashref is given, the following can be provided:
130              
131             =over
132              
133             =item lc
134              
135             If truthy, lower-case the key names in the output
136              
137             =item '-'
138              
139             If present, add C<-> to the beginning of each name in the output.
140             This is useful with L.
141              
142             =back
143              
144             =cut
145              
146             sub forward_opts {
147 63 50   63 1 158 my $hrIn = shift or croak 'Need an input option set';
148 63 50       153 croak 'Need a hashref' unless ref $hrIn eq 'HASH';
149 63         99 my $hrOpts = {};
150 63 50       163 $hrOpts = shift if ref $_[0] eq 'HASH';
151              
152 63         94 my %result;
153 63         128 foreach my $name (@_) {
154 125 100       287 next unless exists $hrIn->{$name};
155              
156 53 50       125 my $newname = $hrOpts->{lc} ? lc($name) : $name;
157 53 50       149 $newname = "-$newname" if $hrOpts->{'-'};
158 53         142 $result{$newname} = $hrIn->{$name}
159             }
160              
161 63         275 return %result;
162             } #forward_opts()
163              
164             =head2 identical
165              
166             Return truthy if the given parameters are identical objects.
167             Taken from L by Paul Evans, which is licensed under the same
168             terms as Perl itself.
169              
170             =cut
171              
172             sub _describe
173             {
174 0     0     my ( $ref ) = @_;
175              
176 0 0         if( !defined $ref ) {
    0          
    0          
177 0           return "undef";
178             }
179             elsif( !refaddr $ref ) {
180 0           return "a non-reference";
181             }
182             elsif( blessed $ref ) {
183 0           return "a reference to a " . ref( $ref );
184             }
185             else {
186 0           return "an anonymous " . ref( $ref ) . " ref";
187             }
188             } #_describe()
189              
190             sub identical($$)
191             {
192 0     0 1   my ( $got, $expected ) = @_;
193              
194 0           my $got_desc = _describe $got;
195 0           my $exp_desc = _describe $expected;
196              
197             # TODO: Consider if undef/undef ought to do this...
198 0 0         if( $got_desc ne $exp_desc ) {
199 0           return false;
200             }
201              
202 0 0         if( !defined $got ) {
203             # Two undefs
204 0           return true;
205             }
206              
207 0           my $got_addr = refaddr $got;
208 0           my $exp_addr = refaddr $expected;
209              
210 0 0         if( $got_addr != $exp_addr ) {
211 0           return false;
212             }
213              
214 0           return true;
215             } #identical()
216              
217             1;
218             __END__