File Coverage

blib/lib/Catmandu/Util.pm
Criterion Covered Total %
statement 324 345 93.9
branch 144 190 75.7
condition 42 95 44.2
subroutine 70 73 95.8
pod 46 53 86.7
total 626 756 82.8


line stmt bran cond sub pod time code
1              
2             use Catmandu::Sane;
3 177     177   564434  
  177         355  
  177         7108  
4             our $VERSION = '1.2019';
5              
6             use Exporter qw(import);
7 177     177   1015 use Sub::Quote ();
  177         397  
  177         4926  
8 177     177   70510 use Scalar::Util ();
  177         686434  
  177         3482  
9 177     177   1061 use List::Util ();
  177         323  
  177         2035  
10 177     177   760 use Data::Util ();
  177         343  
  177         2279  
11 177     177   73523 use Data::Compare ();
  177         121509  
  177         4191  
12 177     177   70502 use IO::File;
  177         2109842  
  177         4426  
13 177     177   1482 use IO::Handle::Util ();
  177         357  
  177         22858  
14 177     177   80587 use File::Spec;
  177         2472634  
  177         5600  
15 177     177   1352 use YAML::XS ();
  177         321  
  177         3344  
16 177     177   71168 use Cpanel::JSON::XS ();
  177         420981  
  177         3558  
17 177     177   136056 use Hash::Merge::Simple ();
  177         512275  
  177         3811  
18 177     177   67624 use MIME::Types;
  177         74080  
  177         3987  
19 177     177   67560 use POSIX ();
  177         627402  
  177         8999  
20 177     177   4601 use Time::HiRes ();
  177         39171  
  177         2487  
21 177     177   3710  
  177         8332  
  177         689158  
22             our %EXPORT_TAGS = (
23             io => [
24             qw(io read_file read_io write_file read_yaml read_json join_path
25             normalize_path segmented_path content_type)
26             ],
27             data => [qw(parse_data_path get_data set_data delete_data data_at)],
28             array => [
29             qw(array_exists array_group_by array_pluck array_to_sentence
30             array_sum array_includes array_any array_rest array_uniq array_split)
31             ],
32             hash => [qw(hash_merge)],
33             string => [qw(as_utf8 trim capitalize)],
34             is => [qw(is_same is_different)],
35             check => [qw(check_same check_different)],
36             human => [qw(human_number human_content_type human_byte_size)],
37             xml => [qw(xml_declaration xml_escape)],
38             misc => [qw(require_package use_lib pod_section)],
39             date => [qw(now)],
40             );
41              
42             our @EXPORT_OK = map {@$_} values %EXPORT_TAGS;
43              
44             $EXPORT_TAGS{all} = \@EXPORT_OK;
45              
46             my $HUMAN_CONTENT_TYPES = {
47              
48             # txt
49             'text/plain' => 'Text',
50             'application/txt' => 'Text',
51              
52             # pdf
53             'application/pdf' => 'PDF',
54             'application/x-pdf' => 'PDF',
55             'application/acrobat' => 'PDF',
56             'applications/vnd.pdf' => 'PDF',
57             'text/pdf' => 'PDF',
58             'text/x-pdf' => 'PDF',
59              
60             # doc
61             'application/doc' => 'Word',
62             'application/vnd.msword' => 'Word',
63             'application/vnd.ms-word' => 'Word',
64             'application/winword' => 'Word',
65             'application/word' => 'Word',
66             'application/x-msw6' => 'Word',
67             'application/x-msword' => 'Word',
68              
69             # docx
70             'application/vnd.openxmlformats-officedocument.wordprocessingml.document'
71             => 'Word',
72              
73             # xls
74             'application/vnd.ms-excel' => 'Excel',
75             'application/msexcel' => 'Excel',
76             'application/x-msexcel' => 'Excel',
77             'application/x-ms-excel' => 'Excel',
78             'application/vnd.ms-excel' => 'Excel',
79             'application/x-excel' => 'Excel',
80             'application/x-dos_ms_excel' => 'Excel',
81             'application/xls' => 'Excel',
82              
83             # xlsx
84             'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet' =>
85             'Excel',
86              
87             # ppt
88             'application/vnd.ms-powerpoint' => 'PowerPoint',
89             'application/mspowerpoint' => 'PowerPoint',
90             'application/ms-powerpoint' => 'PowerPoint',
91             'application/mspowerpnt' => 'PowerPoint',
92             'application/vnd-mspowerpoint' => 'PowerPoint',
93             'application/powerpoint' => 'PowerPoint',
94             'application/x-powerpoint' => 'PowerPoint',
95              
96             # pptx
97             'application/vnd.openxmlformats-officedocument.presentationml.presentation'
98             => 'PowerPoint',
99              
100             # csv
101             'text/comma-separated-values' => 'CSV',
102             'text/csv' => 'CSV',
103             'application/csv' => 'CSV',
104              
105             # zip
106             'application/zip' => 'ZIP archive',
107             };
108              
109             my $XML_DECLARATION = qq(<?xml version="1.0" encoding="UTF-8"?>\n);
110              
111              
112       0     my ($arg, %opts) = @_;
113             my $binmode = $opts{binmode} || $opts{encoding} || ':encoding(UTF-8)';
114             my $mode = $opts{mode} || 'r';
115 113     113 1 39377 my $io;
116 113   50     490  
117 113   100     328 if (is_scalar_ref($arg)) {
118 113         170 $io = IO::Handle::Util::io_from_scalar_ref($arg);
119             defined($io) && binmode $io, $binmode;
120 113 100 66     709 }
    100 100        
    100 66        
    100          
    100          
    50          
121 71         307 elsif (is_glob_ref(\$arg) || is_glob_ref($arg)) {
122 71 50       51833 $io = IO::Handle->new_from_fd($arg, $mode) // $arg;
123             defined($io) && binmode $io, $binmode;
124             }
125 17   66     143 elsif (is_string($arg)) {
126 17 50       2067 $io = IO::File->new($arg, $mode);
127             defined($io) && binmode $io, $binmode;
128             }
129 22         153 elsif (is_code_ref($arg) && $mode eq 'r') {
130 22 50       2642 $io = IO::Handle::Util::io_from_getline($arg);
131             }
132             elsif (is_code_ref($arg) && $mode eq 'w') {
133 1         7 $io = IO::Handle::Util::io_from_write_cb($arg);
134             }
135             elsif (is_instance($arg, 'IO::Handle')) {
136 1         4 $io = $arg;
137             defined($io) && binmode $io, $binmode;
138             }
139 1         2 else {
140 1 50       24 Catmandu::BadArg->throw("can't make io from argument");
141             }
142              
143 0         0 $io;
144             }
145              
146 113         24417 # Deprecated use tools like File::Slurp::Tiny
147             my ($path) = @_;
148             local $/;
149             open my $fh, "<:encoding(UTF-8)", $path
150             or Catmandu::Error->throw(qq(can't open "$path" for reading));
151 3     3 1 372 my $str = <$fh>;
152 3         10 close $fh;
153 3 50       139 $str;
154             }
155 3         1365  
156 3         109 my ($io) = @_;
157 3         26 $io->binmode("encoding(UTF-8)") if ($io->can('binmode'));
158             my @lines = ();
159             while (<$io>) {
160             push @lines, $_;
161 3     3 1 660 }
162 3 100       36 $io->close();
163 3         127 join "", @lines;
164 3         65 }
165 15         104  
166             # Deprecated use tools like File::Slurp::Tiny
167 3         22 my ($path, $str) = @_;
168 3         64 open my $fh, ">:encoding(UTF-8)", $path
169             or Catmandu::Error->throw(qq(can't open "$path" for writing));
170             print $fh $str;
171             close $fh;
172             $path;
173 1     1 1 546 }
174 1 50       81  
175              
176 1         66 # dies on error
177 1         77 YAML::XS::LoadFile($_[0]);
178 1         11 }
179              
180             my $text = read_file($_[0]);
181              
182             # dies on error
183             Cpanel::JSON::XS->new->decode($text);
184 1     1 1 6 }
185              
186             ##
187             # Split a path on . or /, but not on \/ or \.
188 1     1 1 1244 my ($path) = @_;
189             $path = trim($path);
190             $path =~ s/^\$[\.\/]//;
191 1         25 return [map {s/\\(?=[\.\/])//g; $_} split /(?<!\\)[\.\/]/, $path];
192             }
193              
194             my $path = File::Spec->catfile(@_);
195             $path =~ s!/\./!/!g;
196             while ($path =~ s![^/]*/\.\./!!) { }
197 22     22 0 39 $path;
198 22         43 }
199 22         43  
200 22         81 my ($path) = @_;
  35         52  
  35         92  
201             $path =~ s!/\./!/!g;
202             while ($path =~ s![^/]*/\.\./!!) { }
203             File::Spec->catfile($path);
204 1     1 1 499 }
205 1         6  
206 1         22 my ($id, %opts) = @_;
207 1         6 my $segment_size = $opts{segment_size} || 3;
208             my $base_path = $opts{base_path};
209             $id =~ s/[^0-9a-zA-Z]+//g;
210             my @path = unpack "(A$segment_size)*", $id;
211 1     1 1 3 defined $base_path
212 1         3 ? File::Spec->catdir($base_path, @path)
213 1         20 : File::Spec->catdir(@path);
214 1         10 }
215              
216             my $MIME_TYPES;
217              
218 1     1 1 5 my ($filename) = @_;
219 1   50     7  
220 1         2 $MIME_TYPES ||= MIME::Types->new(only_complete => 1);
221 1         4  
222 1         8 return undef unless $filename;
223 1 50       15  
224             my ($ext) = $filename =~ /\.(.+?)$/;
225              
226             my $type = 'application/octet-stream';
227              
228             my $mime = $MIME_TYPES->mimeTypeOf($ext);
229              
230             # Require explicit stringification!
231 0     0 1 0 $type = sprintf "%s", $mime->type if $mime;
232              
233 0   0     0 $type;
234             }
235 0 0       0  
236             my ($path) = @_;
237 0         0 check_string($path);
238             $path = split_path($path);
239 0         0 my $key = pop @$path;
240             return $path, $key;
241 0         0 }
242              
243             my ($data, $key) = @_;
244 0 0       0 if (is_array_ref($data)) {
245             if ($key eq '$first') {return unless @$data; $key = 0}
246 0         0 elsif ($key eq '$last') {return unless @$data; $key = @$data - 1}
247             elsif ($key eq '*') {return @$data}
248             if (array_exists($data, $key)) {
249             return $data->[$key];
250 1     1 0 2 }
251 1         6 return;
252 1         425 }
253 1         3 if (is_hash_ref($data) && exists $data->{$key}) {
254 1         6 return $data->{$key};
255             }
256             return;
257             }
258 7     7 0 15  
259 7 100       24 my ($data, $key, @vals) = @_;
260 5 50       18 return unless @vals;
  1 100       4  
  1 100       2  
    100          
261 1 50       4 if (is_array_ref($data)) {
  1         2  
262 1         7 if ($key eq '$first') {return unless @$data; $key = 0}
263 4 100       9 elsif ($key eq '$last') {return unless @$data; $key = @$data - 1}
264 3         14 elsif ($key eq '$prepend') {
265             unshift @$data, $vals[0];
266 1         5 return $vals[0];
267             }
268 2 100 66     12 elsif ($key eq '$append') {push @$data, $vals[0]; return $vals[0]}
269 1         5 elsif ($key eq '*') {return splice @$data, 0, @$data, @vals}
270             return $data->[$key] = $vals[0] if is_natural($key);
271 1         4 return;
272             }
273             if (is_hash_ref($data)) {
274             return $data->{$key} = $vals[0];
275 15     15 0 6307 }
276 15 50       32 return;
277 15 100       35 }
278 12 50       40  
  2 100       6  
  2 100       4  
    100          
    100          
    100          
279 2 50       5 my ($data, $key) = @_;
  2         3  
280             if (is_array_ref($data)) {
281 2         5 if ($key eq '$first') {return unless @$data; $key = 0}
282 2         5 elsif ($key eq '$last') {return unless @$data; $key = @$data - 1}
283             elsif ($key eq '*') {return splice @$data, 0, @$data}
284 2         5 if (array_exists($data, $key)) {
  2         5  
285 1         5 return splice @$data, $key, 1;
286 7 100       14 }
287 1         3 return;
288             }
289 3 100       7 if (is_hash_ref($data) && exists $data->{$key}) {
290 2         6 return delete $data->{$key};
291             }
292 1         2  
293             return;
294             }
295              
296 7     7 0 3119 my ($path, $data, %opts) = @_;
297 7 100       22 if (ref $path) {
298 5 50       18 $path = [map {split_path($_)} @$path];
  1 100       3  
  1 100       43  
    100          
299 1 50       4 }
  1         2  
300 1         4 else {
301 4 100       11 $path = split_path($path);
302 3         9 }
303             my $create = $opts{create};
304 1         3 my $_key = $opts{_key} // $opts{key};
305             if (defined $opts{key} && $create && @$path) {
306 2 50 66     10 push @$path, $_key;
307 1         3 }
308             my $key;
309             while (defined(my $key = shift @$path)) {
310 1         2 is_ref($data) || return;
311             if (is_array_ref($data)) {
312             if ($key eq '*') {
313             return
314 13     13 0 1004 map {data_at($path, $_, create => $create, _key => $_key)}
315 13 50       32 @$data;
316 0         0 }
  0         0  
317             else {
318             if ($key eq '$first') {$key = 0}
319 13         32 elsif ($key eq '$last') {$key = -1}
320             elsif ($key eq '$prepend') {unshift @$data, undef; $key = 0}
321 13         25 elsif ($key eq '$append') {push @$data, undef; $key = @$data}
322 13   33     78 is_integer($key) || return;
323 13 0 33     36 if ($create && @$path) {
      33        
324 0         0 $data = $data->[$key] ||= is_integer($path->[0])
325             || ord($path->[0]) == ord('$') ? [] : {};
326 13         18 }
327 13         39 else {
328 18 50       38 $data = $data->[$key];
329 18 100 33     60 }
    50          
330 5 50       11 }
331             }
332 0         0 elsif ($create && @$path) {
  0         0  
333             $data = $data->{$key} ||= is_integer($path->[0])
334             || ord($path->[0]) == ord('$') ? [] : {};
335             }
336 5 100       22 else {
  1 100       2  
    100          
    100          
337 1         3 $data = $data->{$key};
338 1         3 }
  1         2  
339 1         3 if ($create && @$path == 1) {
  1         2  
340 5 50       7 last;
341 5 50 33     12 }
342 0 0 0     0 }
      0        
343             $data;
344             }
345              
346 5         9 my ($arr, $i) = @_;
347             is_natural($i) && $i < @$arr;
348             }
349              
350             my ($arr, $key) = @_;
351 0 0 0     0 List::Util::reduce {
      0        
352             my $k = $b->{$key};
353             push @{$a->{$k} ||= []}, $b if defined $k;
354             $a
355 13         22 }
356             {}, @$arr;
357 18 50 33     58 }
358 0         0  
359             my ($arr, $key) = @_;
360             my @vals = map {$_->{$key}} @$arr;
361 13         146 \@vals;
362             }
363              
364             my ($arr, $join, $join_last) = @_;
365 10     10 1 595 $join //= ', ';
366 10 50       18 $join_last //= ' and ';
367             my $size = scalar @$arr;
368             $size > 2
369             ? join($join_last, join($join, @$arr[0 .. $size - 2]), $arr->[-1])
370 1     1 1 3 : join($join_last, @$arr);
371             }
372 4     4   6  
373 4 100 50     7 List::Util::sum(0, @{$_[0]});
  3         11  
374 4         22 }
375              
376 1         11 my ($arr, $val) = @_;
377             is_same($val, $_) && return 1 for @$arr;
378             0;
379             }
380 1     1 1 4  
381 1         2 my ($arr, $sub) = @_;
  3         6  
382 1         5 $sub->($_) && return 1 for @$arr;
383             0;
384             }
385              
386 7     7 1 15 my ($arr) = @_;
387 7   50     32 @$arr < 2 ? [] : [@$arr[1 .. (@$arr - 1)]];
388 7   50     25 }
389 7         10  
390 7 100       60 my ($arr) = @_;
391             my %seen = ();
392             my @vals = grep {not $seen{$_}++} @$arr;
393             \@vals;
394             }
395              
396 1     1 1 2 my ($arr) = @_;
  1         8  
397             is_array_ref($arr) ? $arr : [split ',', $arr];
398             }
399              
400 2     2 1 4 my $str = $_[0];
401 2   100     9 utf8::upgrade($str);
402 1         167 $str;
403             }
404              
405             my $str = $_[0];
406 2     2 1 5 if ($str) {
407 2   100     5 $str =~ s/^[\h\v]+//s;
408 1         11 $str =~ s/[\h\v]+$//s;
409             }
410             $str;
411             }
412 1     1 1 4  
413 1 50       8 my $str = $_[0];
414             utf8::upgrade($str);
415             ucfirst lc $str;
416             }
417 1     1 1 3  
418 1         2 !is_same(@_);
419 1         2 }
  10         19  
420 1         4  
421             is_same(@_) || Catmandu::BadVal->throw('should be same');
422             $_[0];
423             }
424 20     20 1 289  
425 20 100       313 is_same(@_) && Catmandu::BadVal->throw('should be different');
426             $_[0];
427             }
428              
429 31     31 1 681 my $obj = $_[0];
430 31         84 Scalar::Util::blessed($obj) || return 0;
431 31         478 eval {
432             $obj->isa('boolean')
433             || $obj->isa('Types::Serialiser::Boolean')
434             || $obj->isa('JSON::XS::Boolean')
435 655     655 1 1020 || $obj->isa('Cpanel::JSON::XS::Boolean')
436 655 100       1271 || $obj->isa('JSON::PP::Boolean');
437 648         1537 } // 0;
438 648         1406 }
439              
440 655         1421 Data::Util::is_integer($_[0]) && $_[0] !~ /^0[0-9]/;
441             }
442              
443             is_integer($_[0]) && $_[0] >= 0;
444 1     1 1 2 }
445 1         3  
446 1         7 is_integer($_[0]) && $_[0] >= 1;
447             }
448              
449             is_value($_[0])
450 1     1 1 458 && $_[0] =~ /^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$/
451             && $_[0] !~ /^0[0-9]/;
452             }
453              
454 2 100   2 1 510 ref $_[0] ? 1 : 0;
455 1         194 }
456              
457             my $obj = shift;
458             is_invocant($obj) || return 0;
459 2 100   2 1 60 $obj->can($_) || return 0 for @_;
460 1         178 1;
461             }
462              
463             my $obj = shift;
464 22     22 0 32 return $obj if is_able($obj, @_);
465 22 100       400 Catmandu::BadVal->throw('should be able to ' . array_to_sentence(\@_));
466 8   50     17 }
467 8 50 33     266  
      33        
      33        
468             my $obj = shift;
469             return $obj if is_maybe_able($obj, @_);
470             Catmandu::BadVal->throw(
471             'should be undef or able to ' . array_to_sentence(\@_));
472             }
473              
474             my $obj = shift;
475             Scalar::Util::blessed($obj) || return 0;
476 879 100   879 1 64139 for my $pkg (@_) {
477             eval {$obj->isa($pkg)} || return 0;
478             }
479             1;
480 852 100   852 1 8361 }
481              
482             my $obj = shift;
483             return $obj if is_instance($obj, @_);
484 21 100   21 1 6870 Catmandu::BadVal->throw(
485             'should be instance of ' . array_to_sentence(\@_));
486             }
487              
488 0 0 0 0 1 0 my $obj = shift;
489             return $obj if is_maybe_instance($obj, @_);
490             Catmandu::BadVal->throw(
491             'should be undef or instance of ' . array_to_sentence(\@_));
492             }
493              
494 981 100   981 1 15721 Data::Util::install_subroutine(__PACKAGE__,
495             hash_merge => \&Hash::Merge::Simple::merge,
496             is_same => \&Data::Compare::Compare,
497             is_invocant => \&Data::Util::is_invocant,
498 56     56 1 11815 is_scalar_ref => \&Data::Util::is_scalar_ref,
499 56 100       224 is_array_ref => \&Data::Util::is_array_ref,
500 43   100     292 is_hash_ref => \&Data::Util::is_hash_ref,
501 40         310 is_code_ref => \&Data::Util::is_code_ref,
502             is_regex_ref => \&Data::Util::is_rx,
503             is_glob_ref => \&Data::Util::is_glob_ref,
504             is_value => \&Data::Util::is_value,
505 24     24 1 107 is_string => \&Data::Util::is_string,
506 24 100       70 is_number => \&Data::Util::is_number,
507 2         11 );
508              
509             for my $sym (
510             qw(able instance invocant ref
511 2     2 1 41 scalar_ref array_ref hash_ref code_ref regex_ref glob_ref
512 2 100       6 bool value string number integer natural positive float)
513 1         6 )
514             {
515             my $err_name = $sym;
516             $err_name =~ s/_/ /;
517              
518 185     185 1 6430 push @EXPORT_OK, "is_$sym", "is_maybe_$sym", "check_$sym",
519 185 100       961 "check_maybe_$sym";
520 41         110 push @{$EXPORT_TAGS{is}}, "is_$sym", "is_maybe_$sym";
521 30 100       45 push @{$EXPORT_TAGS{check}}, "check_$sym", "check_maybe_$sym";
  30         209  
522              
523 36         236 unless (Data::Util::get_code_ref(__PACKAGE__, "is_maybe_$sym")) {
524             my $sub
525             = Sub::Quote::quote_sub("!defined(\$_[0]) || is_$sym(\$_[0])");
526             Data::Util::install_subroutine(__PACKAGE__, "is_maybe_$sym" => $sub);
527 2     2 1 42 }
528 2 100       3  
529 1         3 unless (Data::Util::get_code_ref(__PACKAGE__, "check_$sym")) {
530             my $sub
531             = Sub::Quote::quote_sub(
532             "is_$sym(\$_[0]) || Catmandu::BadVal->throw('should be $err_name'); \$_[0]"
533             );
534 2     2 1 39 Data::Util::install_subroutine(__PACKAGE__, "check_$sym" => $sub);
535 2 100       7 }
536 1         4  
537             unless (Data::Util::get_code_ref(__PACKAGE__, "check_maybe_$sym")) {
538             my $sub
539             = Sub::Quote::quote_sub(
540             "is_maybe_$sym(\$_[0]) || Catmandu::BadVal->throw('should be undef or $err_name'); \$_[0]"
541             );
542             Data::Util::install_subroutine(__PACKAGE__,
543             "check_maybe_$sym" => $sub);
544             }
545             }
546              
547             my $num = $_[0];
548              
549             # add leading 0's so length($num) is divisible by 3
550             $num = '0' x (3 - (length($num) % 3)) . $num;
551              
552             # split $num into groups of 3 characters and insert commas
553             $num = join ',', grep {$_ ne ''} split /(...)/, $num;
554              
555             # strip off leading zeroes and/or comma
556             $num =~ s/^0+,?//;
557             length $num ? $num : '0';
558             }
559              
560             my ($size) = @_;
561             if ($size > 1000000000) {
562             return sprintf("%.2f GB", $size / 1000000000);
563             }
564             elsif ($size > 1000000) {
565             return sprintf("%.2f MB", $size / 1000000);
566             }
567             elsif ($size > 1000) {
568             return sprintf("%.2f KB", $size / 1000);
569             }
570             "$size bytes";
571             }
572              
573             my ($content_type, $default) = @_;
574             my ($key) = $content_type =~ /^([^;]+)/;
575             $HUMAN_CONTENT_TYPES->{$key} // $default // $content_type;
576             }
577              
578             $XML_DECLARATION;
579             }
580              
581             my ($str) = @_;
582             utf8::upgrade($str);
583              
584             $str =~ s/&/&amp;/go;
585             $str =~ s/</&lt;/go;
586             $str =~ s/>/&gt;/go;
587             $str =~ s/"/&quot;/go;
588             $str =~ s/'/&apos;/go;
589              
590             # remove control chars
591             $str
592             =~ s/[^\x09\x0A\x0D\x20-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFF}]//go;
593              
594 1     1 1 2 $str;
595             }
596              
597 1         5 my (@dirs) = @_;
598              
599             use lib;
600 1         5 local $@;
  4         9  
601             lib->import(@dirs);
602             Catmandu::Error->throw($@) if $@;
603 1         4  
604 1 50       7 1;
605             }
606              
607             my $class = is_ref($_[0]) ? ref(shift) : shift;
608 4     4 1 8 my $section = uc(shift);
609 4 100       14  
    100          
    100          
610 1         11 unless (-r $class) {
611             $class =~ s!::!/!g;
612             $class .= '.pm';
613 1         11 $class = $INC{$class} or return '';
614             }
615              
616 1         13 my $text = "";
617             open my $input, "<", $class or return '';
618 1         5 open my $output, ">", \$text;
619              
620             require Pod::Usage; # lazy load only if needed
621             Pod::Usage::pod2usage(
622 1     1 1 3 -input => $input,
623 1         6 -output => $output,
624 1   33     8 -sections => $section,
      33        
625             -exit => "NOEXIT",
626             -verbose => 99,
627             -indent => 0,
628 1     1 1 4 -utf8 => 1,
629             @_
630             );
631             $section = ucfirst(lc($section));
632 1     1 1 3 $text =~ s/$section:\n//m;
633 1         4 chomp $text;
634              
635 1         6 $text;
636 1         4 }
637 1         4  
638 1         3 my ($pkg, $ns) = @_;
639 1         3  
640             if ($ns) {
641             unless ($pkg =~ s/^\+// || $pkg =~ /^$ns/) {
642 1         3 $pkg = "${ns}::$pkg";
643             }
644             }
645 1         4  
646             return $pkg if is_invocant($pkg);
647              
648             eval "require $pkg;1;"
649 2     2 1 7 or Catmandu::NoSuchPackage->throw(
650             message => "No such package: $pkg",
651 177     177   76665 package_name => $pkg
  177         98060  
  177         1483  
652 2         3 );
653 2         15  
654 2 50       265 $pkg;
655             }
656 2         7  
657             my $format = $_[0];
658             my $now;
659              
660 962 50   962 1 3093 if (!defined $format || $format eq 'iso_date_time') {
661 962         2494 $now = POSIX::strftime('%Y-%m-%dT%H:%M:%SZ', gmtime(time));
662             }
663 962 50       14586 elsif ($format eq 'iso_date_time_millis') {
664 0         0 my $t = Time::HiRes::time;
665 0         0 $now = POSIX::strftime('%Y-%m-%dT%H:%M:%S', gmtime($t));
666 0 0       0 $now .= sprintf('.%03d', ($t - int($t)) * 1000);
667             $now .= 'Z';
668             }
669 962         2624 else {
670 962 50       29322 $now = POSIX::strftime($format, gmtime(time));
671 962     3   10488 }
  3         19  
  3         5  
  3         18  
672             }
673 962         9098  
674 962         73615 1;
675              
676              
677             =pod
678              
679             =head1 NAME
680              
681             Catmandu::Util - A collection of utility functions
682              
683             =head1 SYNOPSIS
684 962         5745075  
685 962         6128 use Catmandu::Util qw(:string);
686 962         2548  
687             $str = trim($str);
688 962         25979  
689             =head1 FUNCTIONS
690              
691             =head2 IO functions
692 881     881 1 1957  
693             use Catmandu::Util qw(:io);
694 881 100       2050  
695 809 50 33     11419 =over 4
696 809         2493  
697             =item io($io, %opts)
698              
699             Takes a file path, glob, glob reference, scalar reference or L<IO::Handle>
700 881 100       6427 object and returns an opened L<IO::Handle> object.
701              
702 267 100       17052 my $fh = io '/path/to/file';
703              
704             my $fh = io *STDIN;
705              
706             my $fh = io \*STDOUT, mode => 'w', binmode => ':crlf';
707              
708 261         1757 my $write_cb = sub { my $str = $_[0]; ... };
709              
710             my $fh = io $write_cb, mode => 'w';
711              
712 7     7 1 41 my $scalar = "";
713 7         13 my $fh = io \$scalar, mode => 'w';
714             $fh->print("some text");
715 7 100 100     34  
    100          
716 5         391 Options are:
717              
718             =over 12
719 1         5  
720 1         34 =item mode
721 1         11  
722 1         5 Default is C<"r">.
723              
724             =item binmode
725 1         38  
726             Default is C<":encoding(UTF-8)">.
727              
728             =item encoding
729              
730             Alias for C<binmode>.
731              
732             =back
733              
734             =item read_file($path);
735              
736             [deprecated]: use tools like Path::Tiny instead.
737              
738             Reads the file at C<$path> into a string.
739              
740             my $str = read_file('/path/to/file.txt');
741              
742             Throws a Catmandu::Error on failure.
743              
744             =item read_io($io)
745              
746             Reads an IO::Handle into a string.
747              
748             my $str = read_file($fh);
749              
750             =item write_file($path, $str);
751              
752             [deprecated]: use tools like use tools like File::Slurp::Tiny instead.
753              
754             Writes the string C<$str> to a file at C<$path>.
755              
756             write_file('/path/to/file.txt', "contents");
757              
758             Throws a Catmandu::Error on failure.
759              
760             =item read_yaml($path);
761              
762             Reads the YAML file at C<$path> into a Perl hash.
763              
764             my $cfg = read_yaml($path);
765              
766             Dies on failure reading the file or parsing the YAML.
767              
768             =item read_json($path);
769              
770             Reads the JSON file at C<$path> into a Perl hash.
771              
772             my $cfg = read_json($path);
773              
774             Dies on failure reading the file or parsing the JSON.
775              
776             =item join_path(@path);
777              
778             Joins relative paths into an absolute path.
779              
780             join_path('/path/..', './to', 'file.txt');
781             # => "/to/file.txt"
782              
783             =item normalize_path($path);
784              
785             Normalizes a relative path to an absolute path.
786              
787             normalize_path('/path/../to/./file.txt');
788             # => "/to/file.txt"
789              
790             =item segmented_path($path);
791              
792             my $id = "FB41144C-F0ED-11E1-A9DE-61C894A0A6B4";
793             segmented_path($id, segment_size => 4);
794             # => "FB41/144C/F0ED/11E1/A9DE/61C8/94A0/A6B4"
795             segmented_path($id, segment_size => 2, base_path => "/files");
796             # => "/files/FB/41/14/4C/F0/ED/11/E1/A9/DE/61/C8/94/A0/A6/B4"
797              
798             =item content_type($filename);
799              
800             Guess the content type of a file name.
801              
802             content_type("book.pdf");
803             # => "application/pdf"
804              
805             =back
806              
807             =head2 Hash functions
808              
809             use Catmandu::Util qw(:hash);
810              
811             A collection of functions that operate on hash references.
812              
813             =over 4
814              
815             =item hash_merge($hash1, $hash2, ... , $hashN)
816              
817             Merge <hash1> through <hashN>, with the nth-most (rightmost) hash taking precedence.
818             Returns a new hash reference representing the merge.
819              
820             hash_merge({a => 1}, {b => 2}, {a => 3});
821             # => { a => 3 , b => 2}
822              
823             =back
824              
825             =head2 Array functions
826              
827             use Catmandu::Util qw(:array);
828              
829             A collection of functions that operate on array references.
830              
831             =over 4
832              
833             =item array_exists($array, $index)
834              
835             Returns C<1> if C<$index> is in the bounds of C<$array>
836              
837             array_exists(["a", "b"], 2);
838             # => 0
839             array_exists(["a", "b"], 1);
840             # => 1
841              
842             =item array_group_by($array, $key)
843              
844             my $list = [{color => 'black', id => 1},
845             {color => 'white', id => 2},
846             {id => 3},
847             {color => 'black', id => 4}];
848             array_group_by($list, 'color');
849             # => {black => [{color => 'black', id => 1}, {color => 'black', id => 4}],
850             # white => [{color => 'white', id => 2}]}
851              
852             =item array_pluck($array, $key)
853              
854             my $list = [{id => 1}, {}, {id => 3}];
855             array_pluck($list, 'id');
856             # => [1, undef, 3]
857              
858             =item array_to_sentence($array)
859              
860             =item array_to_sentence($array, $join)
861              
862             =item array_to_sentence($array, $join, $join_last)
863              
864             array_to_sentence([1,2,3]);
865             # => "1, 2 and 3"
866             array_to_sentence([1,2,3], ",");
867             # => "1,2 and 3"
868             array_to_sentence([1,2,3], ",", " & ");
869             # => "1,2 & 3"
870              
871             =item array_sum($array)
872              
873             array_sum([1,2,3]);
874             # => 6
875              
876             =item array_includes($array, $val)
877              
878             Returns 1 if C<$array> includes a value that is deeply equal to C<$val>, 0
879             otherwise. Comparison is done with C<is_same()>.
880              
881             array_includes([{color => 'black'}], {color => 'white'});
882             # => 0
883             array_includes([{color => 'black'}], {color => 'black'});
884             # => 1
885              
886             =item array_any($array, \&sub)
887              
888             array_any(["green", "blue"], sub { my $color = $_[0]; $color eq "blue" });
889             # => 1
890              
891             =item array_rest($array)
892              
893             Returns a copy of C<$array> without the head.
894              
895             array_rest([1,2,3,4]);
896             # => [2,3,4]
897             array_rest([1]);
898             # => []
899              
900             =item array_uniq($array)
901              
902             Returns a copy of C<$array> with all duplicates removed.
903              
904             =item array_split($array | $string)
905              
906             Returns C<$array> or a new array by splitting C<$string> at commas.
907              
908             =back
909              
910             =head2 String functions
911              
912             use Catmandu::Util qw(:string);
913              
914             =over 4
915              
916             =item as_utf8($str)
917              
918             Returns a copy of C<$str> flagged as UTF-8.
919              
920             =item trim($str)
921              
922             Returns a copy of C<$str> with leading and trailing whitespace removed.
923              
924             =item capitalize($str)
925              
926             Equivalent to C<< ucfirst lc as_utf8 $str >>.
927              
928             =back
929              
930             =head2 Is functions
931              
932             use Catmandu::Util qw(:is);
933              
934             is_number(42) ? "it's numeric" : "it's not numeric";
935              
936             is_maybe_hash_ref({});
937             # => 1
938             is_maybe_hash_ref(undef);
939             # => 1
940             is_maybe_hash_ref([]);
941             # => 0
942              
943             A collection of predicate functions that test the type or value of argument
944             C<$val>. Each function (except C<is_same()> and C<is_different>) also has a
945             I<maybe> variant that also tests true if C<$val> is undefined.
946             Returns C<1> or C<0>.
947              
948             =over 4
949              
950             =item is_invocant($val)
951              
952             =item is_maybe_invocant($val)
953              
954             Tests if C<$val> is callable (is an existing package or blessed object).
955              
956             =item is_able($val, @method_names)
957              
958             =item is_maybe_able($val, @method_names)
959              
960             Tests if C<$val> is callable and has all methods in C<@method_names>.
961              
962             =item is_instance($val, @class_names)
963              
964             =item is_maybe_instance($val, @class_names)
965              
966             Tests if C<$val> is a blessed object and an instance of all the classes
967             in C<@class_names>.
968              
969             =item is_ref($val)
970              
971             =item is_maybe_ref($val)
972              
973             Tests if C<$val> is a reference. Equivalent to C<< ref $val ? 1 : 0 >>.
974              
975             =item is_scalar_ref($val)
976              
977             =item is_maybe_scalar_ref($val)
978              
979             Tests if C<$val> is a scalar reference.
980              
981             =item is_array_ref($val)
982              
983             =item is_maybe_array_ref($val)
984              
985             Tests if C<$val> is an array reference.
986              
987             =item is_hash_ref($val)
988              
989             =item is_maybe_hash_ref($val)
990              
991             Tests if C<$val> is a hash reference.
992              
993             =item is_code_ref($val)
994              
995             =item is_maybe_code_ref($val)
996              
997             Tests if C<$val> is a subroutine reference.
998              
999             =item is_regex_ref($val)
1000              
1001             =item is_maybe_regex_ref($val)
1002              
1003             Tests if C<$val> is a regular expression reference generated by the C<qr//>
1004             operator.
1005              
1006             =item is_glob_ref($val)
1007              
1008             =item is_maybe_glob_ref($val)
1009              
1010             Tests if C<$val> is a glob reference.
1011              
1012             =item is_value($val)
1013              
1014             =item is_maybe_value($val)
1015              
1016             Tests if C<$val> is a real value (defined, not a reference and not a
1017             glob.
1018              
1019             =item is_string($val)
1020              
1021             =item is_maybe_string($val)
1022              
1023             Tests if C<$val> is a non-empty string.
1024             Equivalent to C<< is_value($val) && length($val) > 0 >>.
1025              
1026             =item is_number($val)
1027              
1028             =item is_maybe_number($val)
1029              
1030             Tests if C<$val> is a number.
1031              
1032             =item is_integer($val)
1033              
1034             =item is_maybe_integer($val)
1035              
1036             Tests if C<$val> is an integer.
1037              
1038             =item is_natural($val)
1039              
1040             =item is_maybe_natural($val)
1041              
1042             Tests if C<$val> is a non-negative integer.
1043             Equivalent to C<< is_integer($val) && $val >= 0 >>.
1044              
1045             =item is_positive($val)
1046              
1047             =item is_maybe_positive($val)
1048              
1049             Tests if C<$val> is a positive integer.
1050             Equivalent to C<< is_integer($val) && $val >= 1 >>.
1051              
1052             =item is_float($val)
1053              
1054             =item is_maybe_float($val)
1055              
1056             Tests if C<$val> is a floating point number.
1057              
1058             =item is_same($val, $other_val)
1059              
1060             Tests if C<$val> is deeply equal to C<$other_val>.
1061              
1062             =item is_different($val, $other_val)
1063              
1064             The opposite of C<is_same()>.
1065              
1066             =back
1067              
1068             =head2 Check functions
1069              
1070             use Catmandu::Util qw(:check);
1071              
1072             check_hash_ref({color => 'red'});
1073             # => {color => 'red'}
1074             check_hash_ref([]);
1075             # dies
1076              
1077             A group of assert functions similar to the C<:is> group, but instead of
1078             returning true or false they return their argument or die.
1079              
1080             =over 4
1081              
1082             =item check_invocant($val)
1083              
1084             =item check_maybe_invocant($val)
1085              
1086             =item check_able($val, @method_names)
1087              
1088             =item check_maybe_able($val, @method_names)
1089              
1090             =item check_instance($val, @class_names)
1091              
1092             =item check_maybe_instance($val, @class_names)
1093              
1094             =item check_ref($val)
1095              
1096             =item check_maybe_ref($val)
1097              
1098             =item check_scalar_ref($val)
1099              
1100             =item check_maybe_scalar_ref($val)
1101              
1102             =item check_array_ref($val)
1103              
1104             =item check_maybe_array_ref($val)
1105              
1106             =item check_hash_ref($val)
1107              
1108             =item check_maybe_hash_ref($val)
1109              
1110             =item check_code_ref($val)
1111              
1112             =item check_maybe_code_ref($val)
1113              
1114             =item check_regex_ref($val)
1115              
1116             =item check_maybe_regex_ref($val)
1117              
1118             =item check_glob_ref($val)
1119              
1120             =item check_maybe_glob_ref($val)
1121              
1122             =item check_value($val)
1123              
1124             =item check_maybe_value($val)
1125              
1126             =item check_string($val)
1127              
1128             =item check_maybe_string($val)
1129              
1130             =item check_number($val)
1131              
1132             =item check_maybe_number($val)
1133              
1134             =item check_integer($val)
1135              
1136             =item check_maybe_integer($val)
1137              
1138             =item check_natural($val)
1139              
1140             =item check_maybe_natural($val)
1141              
1142             =item check_positive($val)
1143              
1144             =item check_maybe_positive($val)
1145              
1146             =item check_float($val)
1147              
1148             =item check_maybe_float($val)
1149              
1150             =item check_same($val, $other_val)
1151              
1152             =item check_different($val, $other_val)
1153              
1154             =back
1155              
1156             =head2 Human output functions
1157              
1158             use Catmandu::Util qw(:human);
1159              
1160             =over 4
1161              
1162             =item human_number($num)
1163              
1164             Insert a comma a 3-digit intervals to make C<$num> more readable. Only works
1165             with I<integers> for now.
1166              
1167             human_number(64354);
1168             # => "64,354"
1169              
1170             =item human_byte_size($size)
1171              
1172             human_byte_size(64);
1173             # => "64 bytes"
1174             human_byte_size(10005000);
1175             # => "10.01 MB"
1176              
1177             =item human_content_type($content_type)
1178              
1179             =item human_content_type($content_type, $default)
1180              
1181             human_content_type('application/x-dos_ms_excel');
1182             # => "Excel"
1183             human_content_type('application/zip');
1184             # => "ZIP archive"
1185             human_content_type('foo/x-unknown');
1186             # => "foo/x-unknown"
1187             human_content_type('foo/x-unknown', 'Unknown');
1188             # => "Unknown"
1189              
1190             =back
1191              
1192             =head2 XML functions
1193              
1194             use Catmandu::Util qw(:xml);
1195              
1196             =over 4
1197              
1198             =item xml_declaration()
1199              
1200             Returns C<< qq(<?xml version="1.0" encoding="UTF-8"?>\n) >>.
1201              
1202             =item xml_escape($str)
1203              
1204             Returns an XML escaped copy of C<$str>.
1205              
1206             =back
1207              
1208             =head2 Miscellaneous functions
1209              
1210             =over 4
1211              
1212             =item require_package($pkg)
1213              
1214             =item require_package($pkg, $namespace)
1215              
1216             Load package C<$pkg> at runtime with C<require> and return it's full name.
1217              
1218             my $pkg = require_package('File::Spec');
1219             my $dir = $pkg->tmpdir();
1220              
1221             require_package('Util', 'Catmandu');
1222             # => "Catmandu::Util"
1223             require_package('Catmandu::Util', 'Catmandu');
1224             # => "Catmandu::Util"
1225              
1226             Throws a Catmandu::Error on failure.
1227              
1228             =item use_lib(@dirs)
1229              
1230             Add directories to C<@INC> at runtime.
1231              
1232             Throws a Catmandu::Error on failure.
1233              
1234             =item pod_section($package_or_file, $section [, @options] )
1235              
1236             Get documentation of a package for a selected section. Additional options are
1237             passed to L<Pod::Usage>.
1238              
1239             =item now($format)
1240              
1241             Returns the current datetime as a string. C<$format>can be any
1242             C<strftime> format. There are also 2 builtin formats, C<iso_date_time>
1243             and C<iso_date_time_millis>. C<iso_date_time> is equivalent to
1244             C<%Y-%m-%dT%H:%M:%SZ>. C<iso_date_time_millis> is the same, but with
1245             added milliseconds.
1246              
1247             now('%Y/%m/%d');
1248             now('iso_date_time_millis');
1249              
1250             The default format is C<iso_date_time>;
1251              
1252             =back
1253              
1254             =cut