File Coverage

blib/lib/Spp/Builtin.pm
Criterion Covered Total %
statement 107 224 47.7
branch 17 60 28.3
condition n/a
subroutine 36 66 54.5
pod 0 54 0.0
total 160 404 39.6


line stmt bran cond sub pod time code
1             package Spp::Builtin;
2              
3 2     2   27 use 5.012;
  2         4  
4 2     2   44 no warnings "experimental";
  2         3  
  2         55  
5              
6 2     2   9 use Exporter;
  2         3  
  2         150  
7             our @ISA = qw(Exporter);
8             our @EXPORT = qw(End In Out True False Qstr Qint Blank
9             clean first string strings sort_array to_json from_json
10             is_exists first_char last_char rest_str tail rest
11             is_string is_int is_array Chop add uuid
12             error read_file write_file len trim subarray
13             is_space is_upper is_lower is_digit is_xdigit
14             is_alpha is_words is_hspace is_vspace
15             start_with end_with to_end get_time change_sufix
16             get_file_mtime is_update tidy_perl find_wanted
17             to_int copy is_false is_true croak
18             estr estr_ints is_str is_bool is_estr is_blank
19             cons cons_atom is_atom);
20              
21 2     2   523 use File::Find::Wanted qw(find_wanted);
  2         410  
  2         107  
22 2     2   563 use Time::Piece;
  2         17835  
  2         10  
23 2     2   153 use File::Basename qw(fileparse);
  2         13  
  2         143  
24 2     2   6505 use Perl::Tidy;
  2         297116  
  2         261  
25 2     2   17 use File::Copy qw(copy);
  2         5  
  2         98  
26 2     2   667 use String::Random;
  2         5011  
  2         141  
27 2     2   876 use JSON::XS qw(decode_json encode_json);
  2         7320  
  2         109  
28 2     2   14 use Carp;
  2         4  
  2         145  
29              
30             use constant {
31 2         3921 End => chr(0),
32             In => chr(1),
33             Out => chr(2),
34             True => chr(3),
35             False => chr(4),
36             Qstr => chr(5),
37             Qint => chr(6),
38             Blank => (chr(1) . chr(2)),
39 2     2   11 };
  2         3  
40              
41             sub cons {
42 50     50 0 97 my @args = @_;
43 50         80 my $estr = join '', map { cons_atom($_) } @args;
  114         155  
44 50         201 return (In . $estr . Out);
45             }
46              
47             sub cons_atom {
48 114     114 0 128 my $atom = shift;
49 114 100       153 if (is_estr($atom)) { return $atom }
  69         156  
50 45 50       75 if (is_str($atom)) { return (Qstr . $atom) }
  45         100  
51 0         0 say "|$atom|";
52 0         0 croak("not estr or str or int??");
53             }
54              
55             sub estr {
56 15     15 0 19 my $estr_array = shift;
57 15 50       22 if (is_string($estr_array)) { croak('trace it...') }
  0         0  
58 15         22 return cons(@{$estr_array});
  15         24  
59             }
60              
61             sub estr_ints {
62 14     14 0 20 my $ints = shift;
63 14         28 my @estrs = map { (Qint . $_) } @{$ints};
  28         92  
  14         36  
64 14         68 return In . join('', @estrs) . Out;
65             }
66              
67             sub is_str {
68 1089     1089 0 1282 my $str = shift;
69 1089 50       1409 if (is_string($str)) {
70 1089         1524 my $char = substr($str, 0, 1);
71 1089 100       1807 if (ord($char) > 6) { return 1 }
  89         178  
72             }
73 1000         2137 return 0;
74             }
75              
76             sub is_bool {
77 131     131 0 179 my $char = shift;
78 131 100       240 if (is_false($char)) { return 1 }
  117         264  
79 14 50       39 if (is_true($char)) { return 1 }
  0         0  
80 14         33 return 0;
81             }
82              
83             sub is_estr {
84 117     117 0 128 my $str = shift;
85 117         244 return substr($str, 0, 1) eq In;
86             }
87              
88             sub is_blank {
89 0     0 0 0 my $estr = shift;
90 0         0 return $estr eq Blank;
91             }
92              
93 0     0 0 0 sub error { say @_; exit() }
  0         0  
94              
95             sub to_json {
96 0     0 0 0 my $data = shift;
97 0         0 return encode_json($data);
98             }
99              
100             sub from_json {
101 0     0 0 0 my $data = shift;
102 0         0 return decode_json($data);
103             }
104              
105             sub clean {
106 0     0 0 0 my $stack = shift;
107 0         0 @{$stack} = ();
  0         0  
108             }
109              
110             sub string {
111 0     0 0 0 my $stack = shift;
112 0         0 return join '', @{$stack};
  0         0  
113             }
114              
115             sub first {
116 0     0 0 0 my $stack = shift;
117 0 0       0 if (is_array($stack)) {
118 0         0 return $stack->[0];
119             }
120 0         0 croak("Could not first not Array");
121 0         0 return False
122             }
123              
124             sub strings {
125 0     0 0 0 my $stack = shift;
126 0         0 return $stack;
127             }
128              
129             sub sort_array {
130 0     0 0 0 my $array = shift;
131 0         0 return [reverse sort @{$array}];
  0         0  
132             }
133              
134             sub uuid {
135 0     0 0 0 my $gen = String::Random->new;
136 0         0 return $gen->randregex('[A-Z]{5}');
137             }
138              
139             sub is_exists {
140 0     0 0 0 my $file = shift;
141 0         0 return (-e $file);
142             }
143              
144             sub first_char {
145 2     2 0 4 my $data = shift;
146 2 50       4 if (is_string($data)) {
147 2         5 return substr $data, 0, 1;
148             }
149 0         0 croak("could not first No Str");
150 0         0 return True
151             }
152              
153             sub last_char {
154 2     2 0 4 my $str = shift;
155 2 50       4 if (is_string($str)) {
156 2         7 return substr $str, -1;
157             }
158 0         0 croak("Could not last-char Array");
159             }
160              
161             sub rest_str {
162 3     3 0 5 my $data = shift;
163 3 50       8 return substr($data, 1) if is_string($data);
164 0         0 croak("rest_str only could do str");
165             }
166              
167             sub tail {
168 0     0 0 0 my $data = shift;
169 0 0       0 if (is_array($data)) {
170 0         0 return $data->[-1];
171             }
172 0         0 croak("Could not tail not Array");
173             }
174              
175             sub rest {
176 3     3 0 6 my $data = shift;
177 3 50       7 if (is_array($data)) {
178 3         5 my @array = @{$data};
  3         8  
179 3         17 return [splice(@array, 1)];
180             }
181 0         0 croak("rest only could do array");
182             }
183              
184             sub is_string {
185 2090     2090 0 2254 my $x = shift;
186 2090         4124 return (ref($x) eq ref(''));
187             }
188              
189             sub is_int {
190 0     0 0 0 my $int = shift;
191 0         0 return ($int ^ $int) eq '0';
192             }
193              
194             sub is_array {
195 979     979 0 1014 my $x = shift;
196 979         1957 return (ref($x) eq ref([]));
197             }
198              
199             sub Chop {
200 1     1 0 2 my $str = shift;
201 1         5 return substr($str, 0, -1);
202             }
203              
204             sub add {
205 34     34 0 86 my @strs = @_;
206 34         135 return join '', @strs;
207             }
208              
209             sub read_file {
210 0     0 0 0 my $file = shift;
211 0 0       0 error("file: $file not exists") if not(-e $file);
212 0         0 local $/;
213 0 0       0 open my ($fh), '<:encoding(UTF-8)', $file or die $!;
214 0         0 return <$fh>;
215             }
216              
217             sub write_file {
218 0     0 0 0 my ($file, $str) = @_;
219 0 0       0 open my ($fh), '>:encoding(UTF-8)', $file or die $!;
220 0         0 print {$fh} $str;
  0         0  
221             # say "write file: $file ok!";
222 0         0 return $file;
223             }
224              
225             sub len {
226 979     979 0 1153 my $data = shift;
227 979 100       1282 return length($data) if is_string($data);
228 976 50       1440 return scalar(@{$data}) if is_array($data);
  976         2175  
229 0         0 croak("len only make array");
230             }
231              
232             sub trim {
233 0     0 0 0 my $str = shift;
234 0 0       0 if (is_string($str)) {
235 0         0 $str =~ s/^\s+|\s+$//g;
236 0         0 return $str;
237             }
238 0         0 croak("trim only make string");
239             }
240              
241             sub subarray {
242 0     0 0 0 my ($array, $from, $to) = @_;
243 0         0 my @array = @{$array};
  0         0  
244 0 0       0 if (is_array($array)) {
245 0 0       0 if ($to > 0) {
246 0         0 my $len = $to - $from + 1;
247 0         0 my $sub_array = [splice @array, $from, $len];
248 0         0 return $sub_array;
249             }
250 0 0       0 if (defined $to) {
251 0         0 return [splice @array, $from, $to];
252             }
253 0         0 return [splice @array, $from];
254             }
255 0         0 croak("subarray only could process array");
256             }
257              
258             sub is_space {
259 34     34 0 40 my $r = shift;
260 34         141 return $r ~~ ["\n", "\t", "\r", ' '];
261             }
262              
263             sub is_upper {
264 2     2 0 5 my $r = shift;
265 2         34 return $r ~~ ['A' .. 'Z'];
266             }
267              
268             sub is_lower {
269 2     2 0 4 my $r = shift;
270 2         34 return $r ~~ ['a' .. 'z'];
271             }
272              
273             sub is_digit {
274 1110     1110 0 1239 my $r = shift;
275 1110         5458 return $r ~~ ['0' .. '9'];
276             }
277              
278             sub is_xdigit {
279 0     0 0 0 my $char = shift;
280 0 0       0 return 1 if is_digit($char);
281 0 0       0 return 1 if $char ~~ ['a' .. 'f'];
282 0 0       0 return 1 if $char ~~ ['A' .. 'F'];
283 0         0 return 0;
284             }
285              
286             sub is_alpha {
287 34     34 0 65 my $r = shift;
288 34         506 return $r ~~ ['a' .. 'z', 'A' .. 'Z', '_'];
289             }
290              
291             sub is_words {
292 0     0 0 0 my $r = shift;
293 0 0       0 return 1 if is_digit($r);
294 0 0       0 return 1 if is_alpha($r);
295 0         0 return 0;
296             }
297              
298             sub is_hspace {
299 0     0 0 0 my $h = shift;
300 0         0 return $h ~~ [' ', "\t"];
301             }
302              
303             sub is_vspace {
304 0     0 0 0 my $v = shift;
305 0         0 return $v ~~ ["\r", "\n"];
306             }
307              
308             sub start_with {
309 0     0 0 0 my ($str, $start) = @_;
310 0 0       0 return 1 if index($str, $start) == 0;
311 0         0 return 0;
312             }
313              
314             sub end_with {
315 0     0 0 0 my ($str, $end) = @_;
316 0         0 my $len = length($end);
317 0         0 return substr($str, -$len) eq $end;
318             }
319              
320             sub to_end {
321 0     0 0 0 my $str = shift;
322 0         0 my $index = index($str, "\n");
323 0         0 return substr($str, 0, $index);
324             }
325              
326             sub get_time {
327 0     0 0 0 my $t = localtime;
328 0         0 return $t->hms('-');
329             }
330              
331             sub change_sufix {
332 0     0 0 0 my ($file, $from_sufix, $to_sufix) = @_;
333 0         0 my @sufix = ($from_sufix);
334 0         0 my ($name, $path) = fileparse($file, @sufix);
335 0         0 return $path . $name . $to_sufix;
336             }
337              
338             sub get_file_mtime {
339 0     0 0 0 my $file = shift;
340 0 0       0 if (not(-e $file)) {
341 0         0 say "$file is not exists!";
342             }
343             else {
344 0         0 return (stat($file))[9];
345             }
346             }
347              
348             sub is_update {
349 0     0 0 0 my ($file, $to_file) = @_;
350 0         0 my $file_mtime = get_file_mtime($file);
351 0         0 my $to_file_mtime = get_file_mtime($to_file);
352 0         0 return ($file_mtime < $to_file_mtime);
353             }
354              
355             sub to_int {
356 0     0 0 0 my $str = shift;
357 0         0 return 0 + $str;
358             }
359              
360             sub is_false {
361 672     672 0 764 my $char = shift;
362 672         1322 return $char eq False;
363             }
364              
365             sub is_true {
366 167     167 0 192 my $char = shift;
367 167         333 return $char eq True;
368             }
369              
370             sub is_atom {
371 52     52 0 71 my $estr = shift;
372 52         147 return substr($estr, 0, 2) eq (In . Qstr);
373             }
374              
375             sub tidy_perl {
376 0     0 0   my $source_string = shift;
377 0           my $dest_string;
378             my $stderr_string;
379 0           my $errorfile_string;
380 0           my $argv = "-i=2 -l=60 -vt=2 -pt=2 -bt=1 -sbt=2 -bbt=1";
381 0           my $error = Perl::Tidy::perltidy(
382             argv => $argv,
383             source => \$source_string,
384             destination => \$dest_string,
385             stderr => \$stderr_string,
386             errorfile => \$errorfile_string,
387             );
388              
389 0 0         if ($error) {
390 0           print "<<STDERR>>\n$stderr_string\n";
391             }
392 0           return $dest_string;
393             }
394              
395             1;