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     359   983042 use strict;
  109         375  
  109         3177  
4 109     109   563 use warnings;
  109         210  
  109         4561  
5             our $VERSION = '0.29';
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   613 use Carp;
  109         227  
  109         6679  
23 109     109   52728 use MIME::Base64 3.11;
  109         73419  
  109         6375  
24 109     109   820 use Scalar::Util qw( openhandle );
  109         279  
  109         4859  
25              
26 109     109   8945 use parent qw(Exporter);
  109         5741  
  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 205 my $level = 0;
64 40         96 my @caller;
65             {
66             # code stolen from Carp.
67             # it's just a while(1) with fancy next/last conditionals.
68 40         67 @caller = caller($level++);
  268         1365  
69 268 50       2980 last unless defined $caller[0];
70 268 100       882 redo if $caller[0] =~ /^MVC::Neaf/;
71 41 100       657 redo if $caller[0]->isa('MVC::Neaf::Util::Base');
72             };
73              
74 40 100       270 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 2108 my ($path, $want_slash) = @_;
86              
87 916         2028 $path =~ s#//+#/#g;
88 916 100       1865 if ($want_slash) {
89 15         70 $path =~ s#/$##;
90 15         67 $path =~ s#^/*#/#;
91             } else {
92 901         3834 $path =~ s#^/*#/#;
93 901         2562 $path =~ s#/$##;
94             };
95              
96 916         2882 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 760 if ( grep { $_ =~ $re_path_not } @_ ) {
  289         2390  
116 1         4 local @CARP_NOT = caller;
117 1         54 carp "NEAF Characters outside [$path_allow] in path are DEPRECATED until 0.30";
118             };
119 282 100       2299 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 14 my $str = shift;
133              
134 6         19 $str =~ tr#-_#+/#;
135 6         36 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 588 my ($input, $allowed, $required) = @_;
162              
163 148 50       834 my @extra = $allowed ? grep { !$allowed->{$_} } keys %$input : ();
  27         104  
164 148 50       620 my @missing = $required ? grep { !defined $input->{$_} } @$required : ();
  0         0  
165              
166 148 50       850 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 8359 my $t = shift;
198 150         688 my @date = gmtime($t);
199 150         1830 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 697 my %which = @_;
233              
234 94         333 my $pkg = caller;
235              
236 94         1070 foreach (keys %which) {
237 1598         2499 my $method = $_;
238 1598         2127 my $key = $which{$method};
239 1598 50 33     7048 $key = $method unless defined $key and $key =~ /^[a-z_][a-z_0-9]*$/i;
240              
241             my $sub = sub {
242 2756     2756   11344 $_[0]->{$key};
243 1598         4682 };
244              
245 109     109   109994 use warnings FATAL => 'all';
  109         338  
  109         5942  
246 109     109   710 no strict 'refs'; ## no critic
  109         291  
  109         70324  
247              
248 1598         2270 *{ $pkg."::".$method } = $sub;
  1598         6876  
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 1346 my $item = shift;
266              
267 508 50       1280 confess "Useless use of maybe_list in void context, file a bug in NEAF"
268             unless defined wantarray;
269              
270 508 100       1974 my @ret = defined $item ? (
    100          
271             ref $item eq 'ARRAY' ? @$item : ($item)
272             ) : @_;
273              
274 508 100       1884 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 734 my ($str, $rev) = @_;
285              
286 302         929 $str =~ s#^/*##;
287 302         651 $str =~ s#/+$##;
288 302         2189 my @dir = split qr#/+#, $str;
289 302         1045 my @ret = ('');
290 302         543 my $temp = '';
291              
292 302         1206 push @ret, $temp .= "/$_" for @dir;
293              
294 302         1027 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 8 my $in = shift;
305 4 50       11 $in = '' unless defined $in;
306 4         70 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 59 my $list = shift;
317              
318 26         140 foreach my $sub (@$list) {
319 37         246 $sub->(@_);
320             };
321 24         121 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 50 my ($list, $on_error, @args) = @_;
336              
337 13         23 my $dead = 0;
338 13         40 foreach my $sub (@$list) {
339 21 100       69 eval { $sub->(@args); 1; } and next;
  21         107  
  20         146  
340 1         20 $dead++;
341 1         3 $on_error->( $@ );
342             };
343              
344 13         92 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 1413 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   50931 my $luck = eval "use JSON::MaybeXS; 1"; ## no critic
  109         813137  
  109         5579  
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 366 my $n = shift;
391              
392 174         1241 my @caller = caller($n);
393              
394 174         1862 my $fh = do {
395 109     109   946 no strict 'refs'; ## no critic
  109         307  
  109         4134  
396 109     109   699 no warnings 'once'; ## no critic
  109         250  
  109         29023  
397 174         310 \*{ $caller[0].'::DATA' };
  174         1066  
398             };
399 174 100 66     1365 return unless openhandle $fh and !eof $fh;
400              
401 3         15 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 8 my $str = shift;
421 3         61 $str =~ s/($entity_rex)/$entity{$1}/g;
422 3         13 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;