File Coverage

blib/lib/MVC/Neaf/Util.pm
Criterion Covered Total %
statement 114 123 92.6
branch 29 40 72.5
condition 3 6 50.0
subroutine 27 27 100.0
pod 15 15 100.0
total 188 211 89.1


line stmt bran cond sub pod time code
1             package MVC::Neaf::Util;
2              
3 109     340   978360 use strict;
  109         374  
  109         3226  
4 109     109   579 use warnings;
  109         221  
  109         4493  
5             our $VERSION = '0.2901';
6              
7             =head1 NAME
8              
9             MVC::Neaf::Util - Some static functions for Not Even A Framework
10              
11             =head1 DESCRIPTION
12              
13             This is utility class.
14             Nothing to see here unless one intends to work on L itself.
15              
16             =head1 EXPORT
17              
18             This module optionally exports anything it has.
19              
20             =cut
21              
22 109     109   646 use Carp;
  109         278  
  109         6986  
23 109     109   53093 use MIME::Base64 3.11;
  109         73033  
  109         6390  
24 109     109   778 use Scalar::Util qw( openhandle );
  109         214  
  109         4748  
25              
26 109     109   9121 use parent qw(Exporter);
  109         5923  
  109         599  
27             our @EXPORT_OK = qw(
28             bare_html_escape
29             caller_info
30             canonize_path
31             check_path
32             data_fh
33             decode_json
34             encode_b64 decode_b64
35             encode_json
36             extra_missing
37             http_date
38             JSON
39             make_getters
40             maybe_list
41             path_prefixes
42             rex
43             run_all
44             run_all_nodie
45             supported_methods
46             );
47             our @CARP_NOT;
48              
49             # use JSON::MaybeXS; # not now, see JSON() below
50              
51             # Alphabetic order, please
52              
53             =head2 caller_info()
54              
55             Returns first caller(n) that is not inside MVC::Neaf itself.
56              
57             This is implemented inside L
58             but we can't rely on Carp's internals.
59              
60             =cut
61              
62             sub caller_info {
63 40     40 1 243 my $level = 0;
64 40         84 my @caller;
65             {
66             # code stolen from Carp.
67             # it's just a while(1) with fancy next/last conditionals.
68 40         73 @caller = caller($level++);
  268         1261  
69 268 50       2775 last unless defined $caller[0];
70 268 100       844 redo if $caller[0] =~ /^MVC::Neaf/;
71 41 100       631 redo if $caller[0]->isa('MVC::Neaf::Util::Base');
72             };
73              
74 40 100       266 return wantarray ? @caller : \@caller;
75             };
76              
77             =head2 canonize_path( path, want_slash )
78              
79             Convert '////fooo//bar/' to '/foo/bar' and '//////' to either '' or '/'.
80              
81             =cut
82              
83             # Search for CANONIZE for ad-hoc implementations of this (for speed etc)
84             sub canonize_path {
85 916     916 1 2079 my ($path, $want_slash) = @_;
86              
87 916         1989 $path =~ s#//+#/#g;
88 916 100       1876 if ($want_slash) {
89 15         72 $path =~ s#/$##;
90 15         77 $path =~ s#^/*#/#;
91             } else {
92 901         3781 $path =~ s#^/*#/#;
93 901         2467 $path =~ s#/$##;
94             };
95              
96 916         2825 return $path;
97             };
98              
99             =head2 check_path
100              
101             @array = check_path @array
102              
103             Check a list of path for bad characters in path spec.
104             Will issue a warning if something strange is present.
105             Most notably, forbids C<:> in order to allow for future C
106              
107             Returns unmodified list.
108             This as well as prototype is done so for simpler integration with map.
109              
110             =cut
111              
112             my $path_allow = q{-/A-Za-z_0-9~.,!+'()*@};
113             my $re_path_not = qr#[^$path_allow]#;
114             sub check_path(@) { ## no critic # need proto for simpler wrapping around map
115 282 100   282 1 764 if ( grep { $_ =~ $re_path_not } @_ ) {
  289         2314  
116 1         6 local @CARP_NOT = caller;
117 1         60 carp "NEAF Characters outside [$path_allow] in path are DEPRECATED until 0.30";
118             };
119 282 100       2334 return wantarray ? @_ : shift;
120             };
121              
122             =head2 decode_b64
123              
124             Decode unpadded URL-friendly base64.
125             Also works on normal one.
126              
127             See L.
128              
129             =cut
130              
131             sub decode_b64 {
132 6     6 1 18 my $str = shift;
133              
134 6         21 $str =~ tr#-_#+/#;
135 6         34 return MIME::Base64::decode_base64($str);
136             };
137              
138             =head2 encode_b64
139              
140             Encode data as unpadded URL-friendly base64 - with C<-> for 62 and C<_> for 63.
141             C<=> signs are removed.
142              
143             See L.
144              
145             =cut
146              
147             sub encode_b64;
148             *encode_b64 = \&MIME::Base64::encode_base64url;
149              
150             =head2 extra_missing
151              
152             extra_missing( \%input, \%allowed, \@required )
153              
154             Dies if %input doesn't pass validation.
155             Only definedness is checked.
156              
157             =cut
158              
159             # Now this MUST be an existing module, right?
160             sub extra_missing {
161 148     148 1 552 my ($input, $allowed, $required) = @_;
162              
163 148 50       822 my @extra = $allowed ? grep { !$allowed->{$_} } keys %$input : ();
  27         87  
164 148 50       601 my @missing = $required ? grep { !defined $input->{$_} } @$required : ();
  0         0  
165              
166 148 50       789 if (@extra+@missing) {
167 0         0 my @stack = caller(1);
168 0         0 my @msg;
169 0 0       0 push @msg, "missing required fields: ".join ",", @missing
170             if @missing;
171 0 0       0 push @msg, "unknown fields present: ".join ",", @extra
172             if @extra;
173              
174 0         0 my $fun = $stack[3];
175 0         0 $fun =~ s/^(.*)::/$1->/;
176              
177 0         0 local @CARP_NOT = $stack[0];
178 0         0 croak "$fun: ".join "; ", @msg;
179             };
180             };
181              
182             =head2 http_date
183              
184             Return a date in format required by HTTP standard for cookies
185             and cache expiration.
186              
187             Expires=Wed, 13 Jan 2021 22:23:01 GMT;
188              
189             =cut
190              
191             # Yay premature optimization - use ad-hoc weekdays because locale is so botched
192             # The "proper" way to do it is to set locale to C, call strftime,
193             # and reset locale to whatever it was.
194             my @week = qw( Sun Mon Tue Wed Thu Fri Sat );
195             my @month = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
196             sub http_date {
197 150     150 1 10142 my $t = shift;
198 150         697 my @date = gmtime($t);
199 150         1897 return sprintf( "%s, %02d %s %04d %02d:%02d:%02d GMT"
200             , $week[$date[6]], $date[3], $month[$date[4]], 1900+$date[5], @date[2,1,0]);
201             };
202              
203             =head2 make_getters
204              
205             Create dumb accessors in the calling class from hash.
206             Keys are method names.
207              
208             Key in the object is hash value if it's an identifier,
209             or just method name otherwise:
210              
211             package My::Class;
212              
213             # (declare constructor somehow)
214             make_getters (
215             foo => bar,
216             baz => 1,
217             quux => '',
218             );
219              
220             # ...
221              
222             my $obj = My::Class->new;
223              
224             $obj->foo; # {bar}
225             $obj->baz; # {baz}
226             $obj->quux; # {quux}
227              
228             =cut
229              
230             # TODO 0.30 use Class::XSAccessor or smth
231             sub make_getters {
232 94     94 1 631 my %which = @_;
233              
234 94         384 my $pkg = caller;
235              
236 94         1007 foreach (keys %which) {
237 1598         2506 my $method = $_;
238 1598         2198 my $key = $which{$method};
239 1598 50 33     7263 $key = $method unless defined $key and $key =~ /^[a-z_][a-z_0-9]*$/i;
240              
241             my $sub = sub {
242 2756     2756   11410 $_[0]->{$key};
243 1598         4864 };
244              
245 109     109   109758 use warnings FATAL => 'all';
  109         304  
  109         6073  
246 109     109   785 no strict 'refs'; ## no critic
  109         232  
  109         71949  
247              
248 1598         2409 *{ $pkg."::".$method } = $sub;
  1598         6900  
249             };
250             };
251              
252             =head2 maybe_list
253              
254             maybe_list( $value, @defaults )
255              
256             If C<$value> is C, return a copy of \@defaults.
257              
258             If C<$value> is a list, return a copy of it.
259              
260             Otherwise, return C<[ $value ]>.
261              
262             =cut
263              
264             sub maybe_list {
265 508     508 1 1303 my $item = shift;
266              
267 508 50       1325 confess "Useless use of maybe_list in void context, file a bug in NEAF"
268             unless defined wantarray;
269              
270 508 100       1959 my @ret = defined $item ? (
    100          
271             ref $item eq 'ARRAY' ? @$item : ($item)
272             ) : @_;
273              
274 508 100       1929 return wantarray ? @ret : \@ret;
275             };
276              
277             =head2 path_prefixes ($path)
278              
279             List ('', '/foo', '/foo/bar') for '/foo/bar'
280              
281             =cut
282              
283             sub path_prefixes {
284 302     302 1 679 my ($str, $rev) = @_;
285              
286 302         1010 $str =~ s#^/*##;
287 302         633 $str =~ s#/+$##;
288 302         2200 my @dir = split qr#/+#, $str;
289 302         1051 my @ret = ('');
290 302         531 my $temp = '';
291              
292 302         1089 push @ret, $temp .= "/$_" for @dir;
293              
294 302         1036 return @ret;
295             };
296              
297             =head2 rex( $string || qr/r.e.g.e.x/ )
298              
299             Convert string or regex to an I regex.
300              
301             =cut
302              
303             sub rex ($) { ## no critic
304 4     4 1 9 my $in = shift;
305 4 50       10 $in = '' unless defined $in;
306 4         79 return qr/^$in$/;
307             };
308              
309             =head2 run_all( [CODE, ...], @args )
310              
311             Run all subroutines in array. Exceptions not handled. Return nothing.
312              
313             =cut
314              
315             sub run_all {
316 26     26 1 65 my $list = shift;
317              
318 26         130 foreach my $sub (@$list) {
319 37         229 $sub->(@_);
320             };
321 24         119 return;
322             };
323              
324             =head2 run_all_nodie( [CODE, ...], $on_error, @args )
325              
326             Run all subroutines in array, even if some die.
327              
328             Execute on_error in such cases.
329              
330             Return number of failed callbacks.
331              
332             =cut
333              
334             sub run_all_nodie {
335 13     13 1 46 my ($list, $on_error, @args) = @_;
336              
337 13         27 my $dead = 0;
338 13         37 foreach my $sub (@$list) {
339 21 100       88 eval { $sub->(@args); 1; } and next;
  21         114  
  20         145  
340 1         11 $dead++;
341 1         3 $on_error->( $@ );
342             };
343              
344 13         94 return $dead;
345             };
346              
347             =head2 supported_methods
348              
349             =cut
350              
351             # TODO 0.90 configurable or somthing
352             @MVC::Neaf::supported_methods = qw( GET HEAD POST PATCH PUT DELETE );
353             sub supported_methods {
354 198     198 1 1416 return @MVC::Neaf::supported_methods;
355             };
356              
357             =head2 JSON()
358              
359             Because JSON::MaybeXS is not available on all systems, try to load it
360             or emulate it.
361              
362             =head2 encode_json
363              
364             =head2 decode_json
365              
366             These two are reexported from whatever JSON module we were lucky enough
367             to load.
368              
369             =cut
370              
371             sub JSON(); ## no critic
372              
373 109     109   53283 my $luck = eval "use JSON::MaybeXS; 1"; ## no critic
  109         811528  
  109         5200  
374             my $err = $@;
375              
376             if (!$luck) {
377             require JSON::PP;
378             JSON::PP->import;
379             *JSON = sub () { "JSON::PP" };
380             };
381              
382             =head2 data_fh($n)
383              
384             Get C filehandle in the calling package $n levels up the stack,
385             together with the file name (so that we don't read the same __DATA__ twice).
386              
387             =cut
388              
389             sub data_fh {
390 174     174 1 341 my $n = shift;
391              
392 174         1213 my @caller = caller($n);
393              
394 174         1775 my $fh = do {
395 109     109   868 no strict 'refs'; ## no critic
  109         271  
  109         4172  
396 109     109   704 no warnings 'once'; ## no critic
  109         237  
  109         26410  
397 174         293 \*{ $caller[0].'::DATA' };
  174         1046  
398             };
399 174 100 66     1318 return unless openhandle $fh and !eof $fh;
400              
401 3         18 return ($caller[1], $fh);
402             };
403              
404             =head2 bare_html_escape( $dangerous )
405              
406             A crude html-entities escaper.
407             Should be replaced by something real.
408              
409             =cut
410              
411             # TODO 0.40 replace with a normal module
412             my %entity = (
413             '&' => '&',
414             '<' => '<',
415             '>' => '>',
416             '"' => '"',
417             );
418             my $entity_rex = qr([&<>"]);
419             sub bare_html_escape {
420 3     3 1 6 my $str = shift;
421 3         66 $str =~ s/($entity_rex)/$entity{$1}/g;
422 3         14 return $str;
423             };
424              
425             =head1 LICENSE AND COPYRIGHT
426              
427             This module is part of L suite.
428              
429             Copyright 2016-2023 Konstantin S. Uvarin C.
430              
431             This program is free software; you can redistribute it and/or modify it
432             under the terms of either: the GNU General Public License as published
433             by the Free Software Foundation; or the Artistic License.
434              
435             See L for more information.
436              
437             =cut
438              
439             1;