File Coverage

blib/lib/Catmandu/Util.pm
Criterion Covered Total %
statement 319 340 93.8
branch 141 186 75.8
condition 44 98 44.9
subroutine 70 73 95.8
pod 46 53 86.7
total 620 750 82.6


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