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

# File Coverage

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

line | stmt | bran | cond | sub | pod | time | code
--- | --- | --- | --- | --- | --- | --- | ---
1 | 13 13 13 |  |  | 17 |  | 66 14 357 | use strict;
2 | 13 13 13 |  |  | 13 |  | 48 16 608 | use warnings;
3 |
4 |  |  |  |  |  |  | package 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 |
8 |  |  |  |  |  |  | our @EXPORT_OK = (qw/baptise opt2h2o h2o o2h d2o o2d o2h2o ini2h2o ini2o h2o2ini HTTPTiny2h2o o2ini Getopt2h2o ddd dddie tr4h2o yaml2h2o yaml2o/);
9 |  |  |  |  |  |  | our $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
15 |  |  |  |  |  |  | sub 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
23 |  |  |  |  |  |  | sub _uuid {
24 | 11 |  |  | 11 |  | 12 | state $uuid = 0;
25 | 11 |  |  |  |  | 35 | return ++$uuid;
26 |  |  |  |  |  |  | }
27 |
28 |  |  |  |  |  |  | # non-recursive option
29 |  |  |  |  |  |  | sub 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
58 |  |  |  |  |  |  | sub 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
80 |  |  |  |  |  |  | sub 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!)
87 |  |  |  |  |  |  | sub 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
111 |  |  |  |  |  |  | sub 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
118 |  |  |  |  |  |  | sub 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
125 |  |  |  |  |  |  | sub ini2o($) {
126 | 2 |  |  | 2 | 1 | 18 | return ini2h2o(shift);
127 |  |  |  |  |  |  | }
128 |
129 |  |  |  |  |  |  | # write out the INI file
130 |  |  |  |  |  |  | sub 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
137 |  |  |  |  |  |  | sub o2ini($$) {
138 | 1 |  |  | 1 | 1 | 2 | return h2o2ini( shift, shift );
139 |  |  |  |  |  |  | }
140 |
141 |  |  |  |  |  |  | # return a dereferences hash (non-recursive); reverse of `h2o'
142 |  |  |  |  |  |  | sub 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 |
151 |  |  |  |  |  |  | sub d2o(@); # forward declaration to get rid of "too early" warning
152 |  |  |  |  |  |  | sub 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}) { ... }
156 |  |  |  |  |  |  | sub 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
207 |  |  |  |  |  |  | sub 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
261 |  |  |  |  |  |  | sub o2d($); # forward declaration to get rid of "too early" warning
262 |
263 |  |  |  |  |  |  | sub 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 |
285 |  |  |  |  |  |  | sub 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 |
292 |  |  |  |  |  |  | sub 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
301 |  |  |  |  |  |  | sub 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
336 |  |  |  |  |  |  | sub 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}
353 |  |  |  |  |  |  | sub 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 |
394 |  |  |  |  |  |  | 1;
395 |