File Coverage

blib/lib/qbit/StringUtils.pm
Criterion Covered Total %
statement 28 30 93.3
branch n/a
condition n/a
subroutine 10 10 100.0
pod n/a
total 38 40 95.0


line stmt bran cond sub pod time code
1             package Exception::BadArguments::InvalidJSON;
2             $Exception::BadArguments::InvalidJSON::VERSION = '2.3';
3 8     8   36 use base qw(Exception::BadArguments);
  8         12  
  8         2882  
4              
5             =head1 Name
6              
7             qbit::StringUtils - Functions to manipulate strings.
8              
9             =cut
10              
11             package qbit::StringUtils;
12             $qbit::StringUtils::VERSION = '2.3';
13 8     8   47 use strict;
  8         13  
  8         198  
14 8     8   46 use warnings;
  8         12  
  8         207  
15 8     8   34 use utf8;
  8         13  
  8         38  
16              
17 8     8   196 use qbit::GetText;
  8         9  
  8         852  
18 8     8   41 use qbit::Exceptions;
  8         13  
  8         719  
19              
20 8     8   40 use base qw(Exporter);
  8         12  
  8         632  
21              
22 8     8   4953 use HTML::Entities;
  8         43013  
  8         754  
23 8     8   4563 use URI::Escape qw(uri_escape_utf8);
  8         9734  
  8         627  
24 8     8   10013 use Net::LibIDN qw(idn_to_unicode idn_to_ascii);
  0            
  0            
25             use JSON::XS ();
26             use POSIX qw(locale_h);
27              
28             BEGIN {
29             our (@EXPORT, @EXPORT_OK);
30              
31             @EXPORT = qw(
32             html_encode html_decode uri_escape check_email idn_to_unicode get_domain to_json from_json format_number fix_utf
33             );
34             @EXPORT_OK = @EXPORT;
35             }
36              
37             my $RFC822PAT = <<'EOF';
38             [\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\
39             xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xf
40             f\n\015()]*)*\)[\040\t]*)*(?:(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\x
41             ff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff\n\015
42             "]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[\040\t]*(?:\([^\\\x80-\
43             xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80
44             -\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*
45             )*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\
46             \\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\
47             x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x8
48             0-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff\n
49             \015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[\040\t]*(?:\([^\\\x
50             80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^
51             \x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040
52             \t]*)*)*@[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([
53             ^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\
54             \\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\
55             x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-
56             \xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()
57             ]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\
58             x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\04
59             0\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\
60             n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\
61             015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?!
62             [^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\
63             ]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\
64             x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\01
65             5()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)*|(?:[^(\040)<>@,;:".
66             \\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]
67             )|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[^
68             ()<>@,;:".\\\[\]\x80-\xff\000-\010\012-\037]*(?:(?:\([^\\\x80-\xff\n\0
69             15()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][
70             ^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)|"[^\\\x80-\xff\
71             n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[^()<>@,;:".\\\[\]\
72             x80-\xff\000-\010\012-\037]*)*<[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?
73             :(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-
74             \xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:@[\040\t]*
75             (?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015
76             ()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()
77             ]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\0
78             40)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\
79             [^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\
80             xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*
81             )*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80
82             -\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x
83             80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t
84             ]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\
85             \[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])
86             *\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x
87             80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80
88             -\xff\n\015()]*)*\)[\040\t]*)*)*(?:,[\040\t]*(?:\([^\\\x80-\xff\n\015(
89             )]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\
90             \x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*@[\040\t
91             ]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\0
92             15()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015
93             ()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(
94             \040)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|
95             \\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80
96             -\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()
97             ]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x
98             80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^
99             \x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040
100             \t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".
101             \\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff
102             ])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\
103             \x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x
104             80-\xff\n\015()]*)*\)[\040\t]*)*)*)*:[\040\t]*(?:\([^\\\x80-\xff\n\015
105             ()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\
106             \\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)?(?:[^
107             (\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-
108             \037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\
109             n\015"]*)*")[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|
110             \([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))
111             [^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff
112             \n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\x
113             ff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(
114             ?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\
115             000-\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\
116             xff\n\015"]*)*")[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\x
117             ff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)
118             *\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)*@[\040\t]*(?:\([^\\\x80-\x
119             ff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-
120             \xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)
121             *(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\
122             ]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\]
123             )[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-
124             \xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\x
125             ff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(
126             ?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80
127             -\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<
128             >@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x8
129             0-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:
130             \([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]
131             *(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)
132             *\)[\040\t]*)*)*>)
133             EOF
134             $RFC822PAT =~ s/\n//g;
135              
136             my $DOMAIN_PART_RE = '[^:\s\/\.!@#$%^&*()\[\]\{\}\?\+;\'"`\\\\]+';
137              
138             =head1 Functions
139              
140             =head2 html_encode
141              
142             B
143              
144             =over
145              
146             =item
147              
148             B<$str> - string.
149              
150             =back
151              
152             B string with encoded HTML entities.
153              
154             =cut
155              
156             sub html_encode($) {
157             return defined($_[0]) ? encode_entities($_[0]) : '';
158             }
159              
160             =head2 html_decode
161              
162             B
163              
164             =over
165              
166             =item
167              
168             B<$str> - string.
169              
170             =back
171              
172             B string with decoded HTML entities.
173              
174             =cut
175              
176             sub html_decode($) {
177             return defined($_[0]) ? decode_entities($_[0]) : '';
178             }
179              
180             =head2 uri_escape
181              
182             B
183              
184             =over
185              
186             =item
187              
188             B<$str> - string.
189              
190             =back
191              
192             B string with escaped URI entities.
193              
194             =cut
195              
196             sub uri_escape($) {
197             return uri_escape_utf8($_[0]);
198             }
199              
200             =head2 check_email
201              
202             B
203              
204             =over
205              
206             =item
207              
208             B<$email> - string, E-Mail.
209              
210             =back
211              
212             B boolean, TRUE if email is valid.
213              
214             =cut
215              
216             sub check_email($) {
217             my ($email) = @_;
218              
219             return $email =~ /^$RFC822PAT$/;
220             }
221              
222             =head2 get_domain
223              
224             B
225              
226             =over
227              
228             =item
229              
230             B<$url> - string, URL;
231              
232             =item
233              
234             B<%opts> - additional arguments:
235              
236             =over
237              
238             =item
239              
240             B - boolean, convert unicode chars to ascii;
241              
242             =item
243              
244             B - boolean, save 'www.'.
245              
246             =back
247              
248             =back
249              
250             B string if domain valid, else nothing.
251              
252             =cut
253              
254             sub get_domain($;%) {
255             my ($url, %opts) = @_;
256              
257             my $www = $opts{'www'} ? '' : '(?:www\.)?';
258              
259             $url = lc($url);
260             $url =~ s/(^\s+)|(\s+$)//g;
261              
262             if ($url =~ /^(?:https?:\/\/)?$www((?:$DOMAIN_PART_RE\.)*$DOMAIN_PART_RE)\.?($|\/|:\d+|\?)/) {
263             my $res = $opts{'ascii'} ? idn_to_ascii($1, 'utf-8') : idn_to_unicode($1, 'utf-8');
264             utf8::decode($res);
265             return $res;
266             } else {
267             return;
268             }
269             }
270              
271             =head2 to_json
272              
273             B
274              
275             =over
276              
277             =item
278              
279             B<$data> - scalar.
280              
281             =back
282              
283             B string, C<$data> as JSON.
284              
285             =cut
286              
287             sub to_json($;%) {
288             my ($data, %opts) = @_;
289              
290             my $res;
291              
292             if ($opts{'pretty'}) {
293             $res = JSON::XS->new->utf8->allow_nonref->pretty->canonical->encode($data);
294             } else {
295             $res = JSON::XS->new->utf8->allow_nonref->encode($data);
296             }
297              
298             utf8::decode($res);
299              
300             return $res;
301             }
302              
303             =head2 from_json
304              
305             B
306              
307             =over
308              
309             =item
310              
311             B<$text> - string, JSON.
312              
313             =back
314              
315             B scalar, perl structure from JSON.
316              
317             =cut
318              
319             sub from_json($) {
320             my ($text) = @_;
321              
322             my $original_text = $text;
323              
324             utf8::encode($text);
325             my $result;
326             eval {$result = JSON::XS->new->utf8->allow_nonref->decode($text);};
327              
328             if (!$@) {
329             return $result;
330             } else {
331             $text = '' if !defined $text;
332             my ($error) = ($@ =~ m'(.+) at /');
333             $error ||= $@;
334             throw Exception::BadArguments::InvalidJSON gettext("Error in from_json: %s\n" . "Input:\n" . "'%s'\n", $error,
335             $original_text,);
336             }
337             }
338              
339             =head2 format_number
340              
341             B
342              
343             =over
344              
345             =item
346              
347             B<$number> - number;
348              
349             =item
350              
351             B<%args> - hash, additional arguments:
352              
353             =over
354              
355             =item
356              
357             B: number, needed precision, if missed then frac will return as is;
358              
359             B: string, thousands separator, default gets from locale;
360              
361             B: string, decimal point, default gets from locale.
362              
363             =back
364              
365             =back
366              
367             B string, formatted number.
368              
369             =cut
370              
371             sub format_number($%) {
372             my ($number, %opts) = @_;
373              
374             my $fmt_precision = ($opts{'precision'} || 0) + 1;
375             $number = sprintf("%.${fmt_precision}f", $number)
376             if $number =~ /^(-?[\d.]+)e([+-]\d+)$/; # Convert exponent notation
377              
378             my $old_locale;
379             if (defined($ENV{'LC_ALL'})) {
380             $old_locale = setlocale(LC_NUMERIC);
381             setlocale(LC_NUMERIC, "$ENV{'LC_ALL'}.utf8");
382             }
383              
384             my $localeconv = localeconv();
385             my $half = 0.50000000000008;
386              
387             foreach my $opt (qw(thousands_sep decimal_point)) {
388             unless (defined($opts{$opt})) {
389             $opts{$opt} = $localeconv->{$opt};
390             utf8::decode($opts{$opt});
391             }
392             }
393              
394             setlocale(LC_NUMERIC, $old_locale) if $old_locale;
395              
396             my ($minus, $int, $frac_zero, $frac) =
397             $number =~ /^(-?)(\d+)(?:[^\d](0*)(\d*))?$/
398             ? ($1, int($2), $3, int($4 || 0))
399             : throw Exception::BadArguments gettext('Invalid number "%s"', $number);
400              
401             $frac_zero = '' unless defined($frac_zero);
402              
403             if (defined($opts{'precision'})) {
404             if ($opts{'precision'} == 0) {
405             ++$int if substr($frac, 0, 1) >= 5;
406             $frac = '';
407             } else {
408             $frac = int("0.$frac_zero$frac" * (10**$opts{'precision'}) + $half);
409             $frac = substr("$frac_zero$frac", 0, $opts{'precision'});
410             $frac = "$opts{'decimal_point'}$frac" . ('0' x ($opts{'precision'} - length($frac)));
411             }
412             } else {
413             $frac = $frac == 0 ? '' : "$opts{'decimal_point'}$frac_zero$frac";
414             }
415              
416             if (length($int) > 3) {
417             $int = reverse($int);
418             $int =~ s/(\d\d\d)(?!$)/$1$opts{'thousands_sep'}/g;
419             $int = reverse($int);
420             }
421              
422             return "$minus$int$frac";
423             }
424              
425             =head2 fix_utf
426              
427             B
428              
429             =over
430              
431             =item
432              
433             B<$string> - string.
434              
435             =back
436              
437             Convert $string to perl utf8 string if it is without utf8 flag;
438              
439             B string with utf8 flag.
440              
441             =cut
442              
443             sub fix_utf {
444             my ($string) = @_;
445              
446             utf8::decode($string) unless utf8::is_utf8($string);
447              
448             return $string;
449             }
450              
451             1;