File Coverage

File:lib/Util/H2O/More.pm
Coverage:100.0%

linestmtbrancondsubpodtimecode
1
13
13
13
17
66
14
357
use strict;
2
13
13
13
13
48
16
608
use warnings;
3
4package Util::H2O::More;
5
13
13
13
13
3081
2739
55
use parent q/Exporter/;
6
13
13
13
13
4709
77485
683
use Util::H2O ();
7
8our @EXPORT_OK = (qw/baptise opt2h2o h2o o2h d2o o2d o2h2o ini2h2o ini2o h2o2ini HTTPTiny2h2o o2ini Getopt2h2o ddd dddie tr4h2o yaml2h2o yaml2o/);
9our $VERSION = q{0.4.4};
10
11
13
13
13
13
69
17
17993
use feature 'state';
12
13# quick hack to export h2o, uses proper
14# Util::H2O::h2o called with full namespace
15sub h2o {
16
134
134
1
249
    return Util::H2O::h2o @_;
17}
18
19# maintains basically a count to create non-colliding
20# unique $pkg names (basically what Util::H2O::h2o does
21# if $pkg is not specified using -class
22# monatomically increasing uuid
23sub _uuid {
24
11
11
12
    state $uuid = 0;
25
11
35
    return ++$uuid;
26}
27
28# non-recursive option
29sub baptise ($$@) {
30
11
11
1
12
    my ( $ref, $pkg, @default_accessors );
31
11
13
    my $pos0 = shift;
32
33    # check pos0 for '-recurse'
34
11
100
28
    if ( $pos0 eq q{-recurse} ) {
35
9
19
        ( $ref, $pkg, @default_accessors ) = @_;
36    }
37    else {
38
2
2
        $ref = $pos0;
39
2
3
        ( $pkg, @default_accessors ) = @_;
40    }
41
42
11
12
    my $self;
43
11
16
    my $real_pkg = sprintf qq{%s::_%s}, $pkg, _uuid;
44
45    # uses -isa to inherit from $pkg; -class to bless with a package name
46    # derived from $pkg
47
11
100
46
    if ( $pos0 eq q{-recurse} ) {
48
9
45
        $self = h2o -recurse, -isa => $pkg, -class => $real_pkg, $ref, @default_accessors;
49    }
50    else {
51
2
4
        $self = h2o -isa => $pkg, -class => $real_pkg, $ref, @default_accessors;
52    }
53
54
11
2372
    return $self;
55}
56
57# make keys legal for use as accessor, provides original keys via "__og_keys" accessor
58sub tr4h2o($) {
59
1
1
1
2
    my $hash_ref    = shift;
60
1
1
    my $new_hashref = {};
61
62    # List::Util::pairmap was not happy being require'd for some reason
63    # so iterate and replace keys explicitly; store original key in resulting
64    # hashref via __og_keys
65
1
3
    foreach my $og_k ( keys %$hash_ref ) {
66
2
5
        my $k = $og_k;
67
2
4
        $k =~ tr/a-zA-Z0-9/_/c;
68
2
3
        $new_hashref->{$k} = $hash_ref->{$og_k};
69
70        # save old key via __og_keys
71
2
4
        $new_hashref->{__og_keys}->{$k} = $og_k;
72    }
73
1
3
    return $new_hashref;
74}
75
76# preconditioner for use with Getopt::Long flags; returns just the flag name given
77# a list of option descriptors, e.g., qw/option1=s option2=i option3/;
78
79# Getopt to keys
80sub opt2h2o(@) {
81
8
8
1
11
    my @getopt_def = @_;
82
8
17
17
10
46
31
    my @flags_only = map { m/([^=!|\s]+)/g; $1 } @getopt_def;
83
8
30
    return @flags_only;
84}
85
86# wrapper around opt2h2o (yeah!)
87sub Getopt2h2o(@) {
88
7
7
1
8
    my $autoundef;
89
7
100
100
42
    if ( @_ && $_[0] && !ref$_[0] && $_[0]=~/^-autoundef/ ) {
90
1
2
      $autoundef = shift;
91    }
92
7
12
    my ( $ARGV_ref, $defaults, @opts ) = @_;
93
7
100
15
    $defaults //= {};
94
7
100
9
    if ($autoundef) {
95      $defaults->{AUTOLOAD} = sub {
96
2
2
4
        my $self = shift;
97
2
2
        our $AUTOLOAD;
98
2
10
        ( my $key = $AUTOLOAD ) =~ s/.*:://;
99
2
100
11
        die qq{Getopt2h2o: Won't set value for non-existing key. Need it? Let the module author know!\n} if @_;
100
1
3
        return undef;
101
1
4
      };
102    }
103
7
12
    my $o = h2o -meth, $defaults, opt2h2o(@opts);
104
7
634
    require Getopt::Long;
105
7
19
    Getopt::Long::GetOptionsFromArray( $ARGV_ref, $o, @opts );    # Note, @ARGV is passed by reference
106
4
2202
    return $o;
107}
108
109# general form of method used to give accessors to Config::Tiny in Util::H2O's
110# POD documentation
111sub o2h2o($) {
112
6
6
1
991
    my $ref = shift;
113
6
6
16
19
    return h2o -recurse, { %{$ref} };
114}
115
116# more specific helper app that uses Config::Tiny->read and o2h2o to get a config
117# object back from an .ini; requries Config::Tiny
118sub ini2h2o($) {
119
4
4
1
6
    my $filename = shift;
120
4
16
    require Config::Tiny;
121
4
13
    return o2h2o( Config::Tiny->read($filename) );
122}
123
124# back compat
125sub ini2o($) {
126
2
2
1
18
    return ini2h2o(shift);
127}
128
129# write out the INI file
130sub h2o2ini($$) {
131
2
2
1
5
    my ( $config, $filename ) = @_;
132
2
8
    require Config::Tiny;
133
2
5
    return Config::Tiny->new( Util::H2O::o2h $config)->write($filename);
134}
135
136# back compat
137sub o2ini($$) {
138
1
1
1
2
    return h2o2ini( shift, shift );
139}
140
141# return a dereferences hash (non-recursive); reverse of `h2o'
142sub o2h($) {
143
29
29
1
392
    $Util::H2O::_PACKAGE_REGEX = qr/::_[0-9A-Fa-f]+\z/;    # makes internal package name more generic for baptise created references
144
29
67
    my $ref = Util::H2O::o2h @_;
145
29
100
2007
    if ( ref $ref ne q{HASH} ) {
146
1
8
        die qq{o2h: Could not fully remove top-level reference. Probably an issue with \$Util::H2O_PACKAGE_REGEX\n};
147    }
148
28
87
    return $ref;
149}
150
151sub d2o(@);    # forward declaration to get rid of "too early" warning
152sub a2o($);
153
154# accepts '-autoundef' flag that will insert all keys/getters to be checked
155# i.e., if (not $myref->doesntexist) { ... } rather than if (not exists $myref->{doesntexist}) { ... }
156sub d2o(@) {
157
430
430
1
326
    my ($autoundef);
158    # basically how Util::H2O::h2o does it, if we have more options
159    # then we should use the `while` form of this ...
160
430
100
100
1397
    if ( @_ && $_[0] && !ref$_[0] && $_[0]=~/^-autoundef/ ) {
161
152
155
      $autoundef = shift;
162    }
163
430
391
    my $thing = shift;
164
165
430
404
    my $isa   = ref $thing;
166
167
430
100
100
592
    if ( $isa eq q{ARRAY} ) {
168
59
86
        a2o $thing;
169
59
243
        foreach my $element (@$thing) {
170
203
100
209
          if ($autoundef) { # 'd2o -autoundef, $hash'
171
91
79
            d2o $autoundef, $element;
172          }
173          else {
174
112
121
            d2o $element;
175          }
176        }
177    }
178    elsif ( $isa eq q{HASH} ) {
179
87
159
        foreach my $keys ( keys %$thing ) {
180
177
100
175
          if ($autoundef) { # 'd2o -autoundef, $hash'
181
51
60
            d2o $autoundef, $thing->{$keys};
182          }
183          else {
184
126
165
            d2o $thing->{$keys};
185          }
186        }
187
87
100
119
        if ($autoundef) { # 'd2o -autoundef, $hash'
188          $thing->{AUTOLOAD} = sub {
189
7
7
58
            my $self = shift;
190
7
7
            our $AUTOLOAD;
191
7
38
            ( my $key = $AUTOLOAD ) =~ s/.*:://;
192
7
100
26
            die qq{d2o: Won't set value for non-existing key. Need it? Let the module author know!\n} if @_;
193
5
14
            return undef;
194
22
63
          };
195
22
38
          h2o -meth, $thing;
196        }
197        else {           # default behavior
198
65
78
          h2o $thing;
199        }
200    }
201
430
8100
    return $thing;
202}
203
204# blesses ARRAY ref as a container and gives it some virtual methods
205# useful in the context of containing HASH refs that get objectified
206# by h2o
207sub a2o($) {
208
13
13
13
13
80
17
16500
    no strict 'refs';
209
210
59
59
1
71
    my $array_ref = shift;
211
212    # uses lexical scop of the 'if' to a bless $array_ref (an ARRAY ref)
213    # and assigns to it some virtual methods for making dealing with
214    # the "lists of C<HASH> references easier, as a container
215
216
59
283
    my $a2o_pkg = sprintf( qq{%s::__a2o_%d::vmethods}, __PACKAGE__, int rand 100_000_000 );    # internal a2o
217
218
59
316
    bless $array_ref, $a2o_pkg;
219
220    ## add vmethod to wrap around array_refs
221
222    # return item at index INDEX
223    my $GET = sub {
224
3
3
28
      my ( $self, $i ) = @_;
225
3
3
100
4
11
      return undef if $i > $#{$self}; # prevent ARRAY from growing just to get an undef back
226
2
6
      return $self->[$i];
227
59
215
    };
228
59
59
76
194
    *{"${a2o_pkg}::get"} = $GET;
229
59
59
58
149
    *{"${a2o_pkg}::i"}   = $GET;
230
231    # return rereferenced ARRAY
232
59
4
4
4
156
32
10
    my $ALL = sub { my $self = shift; return @$self; };
233
59
59
79
148
    *{"${a2o_pkg}::all"} = $ALL;
234
235    # returns value returned by the 'scalar' keyword, alias also to 'count'
236
59
30
30
30
105
221
85
    my $SCALAR = sub { my $self = shift; return scalar @$self; };
237
59
59
54
144
    *{"${a2o_pkg}::scalar"} = $SCALAR;
238
59
59
50
151
    *{"${a2o_pkg}::count"}  = $SCALAR;
239
240    # 'push' will apply "d2o" to all elements pushed
241
59
12
12
12
12
12
122
116
24
20
18
    my $PUSH = sub { my ( $self, @i ) = @_; d2o \@i; push @$self, @i; return \@i };
242
59
59
54
155
    *{"${a2o_pkg}::push"} = $PUSH;
243
244    # 'pop' intentionally does NOT apply "o2d" to anyarray_ref pop'd
245
59
8
8
8
126
426
24
    my $POP = sub { my $self = shift; return pop @$self };
246
59
59
63
170
    *{"${a2o_pkg}::pop"} = $POP;
247
248    # 'unshift' will apply "d2o" to all elements unshifted
249
59
12
12
12
12
12
137
118
27
17
21
    my $UNSHIFT = sub { my ( $self, @i ) = @_; d2o \@i; unshift @$self, @i; return \@i };
250
59
59
64
155
    *{"${a2o_pkg}::unshift"} = $UNSHIFT;
251
252    # 'shift' intentionally does NOT apply "o2d" to anyarray_ref shift'd
253
59
16
16
16
117
901
46
    my $SHIFT = sub { my $self = shift; return shift @$self };
254
59
59
58
166
    *{"${a2o_pkg}::shift"} = $SHIFT;
255
256
59
85
    return $array_ref;
257}
258
259# includes internal dereferencing so to be compatible
260# with the behavior of Util::H2O::o2h
261sub o2d($);    # forward declaration to get rid of "too early" warning
262
263sub o2d($) {
264
143
143
1
147
    my $thing = shift;
265
143
100
168
    return $thing if not $thing;
266
140
141
    my $isa = ref $thing;
267
140
100
100
225
    if ( $isa =~ m/^Util::H2O::More::__a2o/ ) {
268
18
40
        my @_thing = @$thing;
269
18
19
        $thing = \@_thing;
270
18
27
        foreach my $element (@$thing) {
271
95
102
            $element = o2d $element;
272        }
273    }
274    elsif ( $isa =~ m/^Util::H2O::_/ ) {
275
17
32
        foreach my $key ( keys %$thing ) {
276
38
315
            $thing->{$key} = o2d $thing->{$key};
277        }
278
17
151
        $thing = Util::H2O::o2h $thing;
279    }
280
140
1129
    return $thing;
281}
282
283# handy, poor man's debug wrappers
284
285sub ddd(@) {
286
1
1
1
319
    require Data::Dumper;
287
1
5965
    foreach my $ref (@_) {
288
2
77
        print STDERR Data::Dumper::Dumper($ref);
289    }
290}
291
292sub dddie(@) {
293
1
1
1
4
    require Data::Dumper;
294
1
2
    foreach my $ref (@_) {
295
1
2
        print STDERR Data::Dumper::Dumper($ref);
296    }
297
1
46
    die qq{died due to use of dddie};
298}
299
300# YAML configuration support - may return more than 1 reference
301sub yaml2h2o($) {
302
7
7
1
280
    require YAML;
303
7
5517
    my $file_or_yaml = shift; # may be a file or a string
304
7
8
    my @yaml         = ();    # yaml can have multiple objects serialized, via ---
305
306    # determine if YAML or file name
307
7
18
    my @lines = split /\n/, $file_or_yaml;
308
309    # if a file, use YAML::LoadFile
310
7
100
100
100
47
    if ( @lines == 1 and -e $file_or_yaml ) {
311
2
5
        @yaml = YAML::LoadFile($file_or_yaml);
312    }
313
314    # if not a file, assume YAML string and use YAML::Load
315    elsif ($lines[0] eq q{---}) {
316
2
4
        @yaml = YAML::Load($file_or_yaml);
317    }
318
319    # die because not supported content $file_or_yaml - it is neither
320    else {
321
3
14
        die qq{Provided parameter looks like neither a file name nor a valid YAML snippet.\n};
322    }
323
324    # iterate over 1 or more serialized objects that were deserialized
325    # from the YAML, applie C<d2o> to it due to the potential presence
326    # of ARRAY references
327
4
34303
    my @obs = ();
328
4
7
    foreach my $y (@yaml) {
329
8
10
        push @obs, d2o $y;
330    }
331
332
4
14
    return @obs;
333}
334
335# back compat
336sub yaml2o($) {
337
3
3
1
6
    return yaml2h2o(shift);
338}
339
340# NOTE: no h2o2yaml or o2yaml, but can add one if somebody needs it ... please file an issue on the tracker (GH these days)
341
342# This method assumes a response HASH reference returned by HTTP::Tiny; so
343# it looks for $ref->{content}, and if anything is found there it will attempt
344# to turn it into a Perl data structure usin JSON::XS::Maybe::decode_json; it
345# them applies "d2o -autoundef" to it; if the JSON decode fails, the error will
346# be hidden silently and the original content will be retained in the provided
347# response reference (also available via ->content by virtu of h2o being applied).
348# To force the JSON decode error to propagate up so that it may be caught, use
349# the "-autothrow" option, e.g.;
350#   HTTPTiny2h2o -autothrow, $ref_with_bad_JSON; # propagates decode_json exception from "malformed" JSON
351#   HTTPTiny2h2o $ref_with_bad_JSON;             # hides bad decode, "->content" accessor created to return original content
352#   HTTPTiny2h2o $ref_with_good_JSON;            # h2o applied to $ref, "d2o -autoundef" applied to value of ->{content}
353sub HTTPTiny2h2o(@) {
354
12
12
1
16
  my $autothrow;
355
12
100
100
76
  if ( @_ && $_[0] && !ref$_[0] && $_[0]=~/^-autothrow/ ) {
356
2
3
    $autothrow = shift;
357  }
358
12
13
  my $ref = shift;
359
12
100
100
36
  if (ref $ref eq q{HASH} and exists $ref->{content}) {
360
7
28
    require JSON::MaybeXS; # tries to load the JSON module you want, (by default, exports decode_json, encode_json)
361
7
14
    h2o $ref, qw/content/;
362
7
100
707
    if ($ref->content) {
363      # allows exception from decode_json to be raised if -autothrow
364      # and the JSON is determined to be malformed
365
6
100
36
      if ($autothrow) {
366        # the JSON decode will die on bad JSON
367
2
5
        my $JSON = JSON::MaybeXS::decode_json($ref->content);
368
1
11
        my $content= d2o -autoundef, $JSON;
369
1
3
        $ref->content($content);
370      }
371      # default is hide any malformed JSON exception, effectively
372      # leaving the ->content untouched
373      else {
374
4
4
        eval {
375          # the JSON decode will die on bad JSON
376
4
6
          my $JSON = JSON::MaybeXS::decode_json($ref->content);
377
3
35
          my $content= d2o -autoundef, $JSON;
378
3
7
          $ref->content($content);
379        }
380      }
381    }
382    else {
383
1
8
      my $content= d2o -autoundef, {};
384
1
5
      $ref->content($content);
385    }
386  }
387  else {
388
5
39
    die qq{Provided parameter must be a proper HASH reference returned by HTTP::Tiny that contains a 'content' HASH key.};
389  }
390
391
6
45
  return $ref;
392}
393
3941;
395