line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Lazy::Utils; |
2
|
|
|
|
|
|
|
=head1 NAME |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
Lazy::Utils - Utility functions |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
=head1 VERSION |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
version 1.21 |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=head1 SYNOPSIS |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
use Lazy::Utils; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
trim($str); |
15
|
|
|
|
|
|
|
ltrim($str); |
16
|
|
|
|
|
|
|
rtrim($str); |
17
|
|
|
|
|
|
|
file_get_contents($path, $prefs); |
18
|
|
|
|
|
|
|
file_put_contents($path, $contents, $prefs); |
19
|
|
|
|
|
|
|
shellmeta($s, $nonquoted); |
20
|
|
|
|
|
|
|
system2($cmd, @argv); |
21
|
|
|
|
|
|
|
bash_readline($prompt); |
22
|
|
|
|
|
|
|
cmdargs($prefs, @argv); |
23
|
|
|
|
|
|
|
whereis($name, $path); |
24
|
|
|
|
|
|
|
file_cache($tag, $expiry, $coderef); |
25
|
|
|
|
|
|
|
get_pod_text($file_name, $section, $exclude_section); |
26
|
|
|
|
|
|
|
array_to_hash(@array); |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
=head1 DESCRIPTION |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
Collection of utility functions all of exported by default. |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=cut |
33
|
1
|
|
|
1
|
|
13467
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
25
|
|
34
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
23
|
|
35
|
1
|
|
|
1
|
|
12
|
use v5.10.1; |
|
1
|
|
|
|
|
6
|
|
36
|
1
|
|
|
1
|
|
5
|
use feature qw(switch); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
103
|
|
37
|
1
|
|
|
1
|
|
542
|
no if ($] >= 5.018), 'warnings' => 'experimental'; |
|
1
|
|
|
|
|
11
|
|
|
1
|
|
|
|
|
5
|
|
38
|
1
|
|
|
1
|
|
430
|
use FindBin; |
|
1
|
|
|
|
|
780
|
|
|
1
|
|
|
|
|
40
|
|
39
|
1
|
|
|
1
|
|
474
|
use JSON; |
|
1
|
|
|
|
|
8820
|
|
|
1
|
|
|
|
|
5
|
|
40
|
1
|
|
|
1
|
|
486
|
use Pod::Simple::Text; |
|
1
|
|
|
|
|
25894
|
|
|
1
|
|
|
|
|
80
|
|
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
BEGIN |
44
|
|
|
|
|
|
|
{ |
45
|
1
|
|
|
1
|
|
7
|
require Exporter; |
46
|
1
|
|
|
|
|
2
|
our $VERSION = '1.21'; |
47
|
1
|
|
|
|
|
6
|
our @ISA = qw(Exporter); |
48
|
1
|
|
|
|
|
5
|
our @EXPORT = qw(trim ltrim rtrim file_get_contents file_put_contents shellmeta system2 _system |
49
|
|
|
|
|
|
|
bash_readline bashReadLine cmdargs commandArgs cmdArgs whereis whereisBin file_cache fileCache |
50
|
|
|
|
|
|
|
get_pod_text getPodText array_to_hash); |
51
|
1
|
|
|
|
|
430
|
our @EXPORT_OK = qw(); |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
=head1 FUNCTIONS |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
=head2 trim($str) |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
trims given string |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
$str: I |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
return value: I |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
=cut |
66
|
|
|
|
|
|
|
sub trim |
67
|
|
|
|
|
|
|
{ |
68
|
0
|
|
|
0
|
1
|
|
my ($s) = @_; |
69
|
0
|
|
|
|
|
|
$s =~ s/^\s+|\s+$//g; |
70
|
0
|
|
|
|
|
|
return $s |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=head2 ltrim($str) |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
trims left given string |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
$str: I |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
return value: I |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=cut |
82
|
|
|
|
|
|
|
sub ltrim |
83
|
|
|
|
|
|
|
{ |
84
|
0
|
|
|
0
|
1
|
|
my ($s) = @_; |
85
|
0
|
|
|
|
|
|
$s =~ s/^\s+//; |
86
|
0
|
|
|
|
|
|
return $s |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=head2 rtrim($str) |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
trims right given string |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
$str: I |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
return value: I |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=cut |
98
|
|
|
|
|
|
|
sub rtrim |
99
|
|
|
|
|
|
|
{ |
100
|
0
|
|
|
0
|
1
|
|
my ($s) = @_; |
101
|
0
|
|
|
|
|
|
$s =~ s/\s+$//; |
102
|
0
|
|
|
|
|
|
return $s |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
=head2 file_get_contents($path, $prefs) |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
gets all contents of file in string type |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
$path: I |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
$prefs: I |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
=over |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
utf8: I |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
=back |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
return value: I |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
=cut |
122
|
|
|
|
|
|
|
sub file_get_contents |
123
|
|
|
|
|
|
|
{ |
124
|
0
|
|
|
0
|
1
|
|
my ($path, $prefs) = @_; |
125
|
0
|
0
|
|
|
|
|
$prefs = {} unless ref($prefs) eq 'HASH'; |
126
|
|
|
|
|
|
|
my $result = do |
127
|
0
|
|
|
|
|
|
{ |
128
|
0
|
|
|
|
|
|
local $/ = undef; |
129
|
0
|
|
|
|
|
|
my $mode = ""; |
130
|
0
|
0
|
|
|
|
|
$mode .= " :utf8" if $prefs->{utf8}; |
131
|
0
|
0
|
|
|
|
|
open my $fh, "<$mode", $path or return; |
132
|
0
|
|
|
|
|
|
my $result = <$fh>; |
133
|
0
|
|
|
|
|
|
close $fh; |
134
|
0
|
|
|
|
|
|
$result; |
135
|
|
|
|
|
|
|
}; |
136
|
0
|
|
|
|
|
|
return $result; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=head2 file_put_contents($path, $contents, $prefs) |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
puts all contents of file in string type |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
$path: I |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
$contents: I |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
$prefs: I |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
=over |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
utf8: I |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
=back |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
return value: I |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
=cut |
158
|
|
|
|
|
|
|
sub file_put_contents |
159
|
|
|
|
|
|
|
{ |
160
|
0
|
|
|
0
|
1
|
|
my ($path, $contents, $prefs) = @_; |
161
|
0
|
0
|
0
|
|
|
|
return if not defined($contents) or ref($contents); |
162
|
0
|
0
|
|
|
|
|
$prefs = {} unless ref($prefs) eq 'HASH'; |
163
|
|
|
|
|
|
|
my $result = do |
164
|
0
|
|
|
|
|
|
{ |
165
|
0
|
|
|
|
|
|
local $\ = undef; |
166
|
0
|
|
|
|
|
|
my $mode = ""; |
167
|
0
|
0
|
|
|
|
|
$mode .= " :utf8" if $prefs->{utf8}; |
168
|
0
|
0
|
|
|
|
|
open my $fh, ">$mode", $path or return; |
169
|
0
|
|
|
|
|
|
my $result = print $fh $contents; |
170
|
0
|
|
|
|
|
|
close $fh; |
171
|
0
|
|
|
|
|
|
$result; |
172
|
|
|
|
|
|
|
}; |
173
|
0
|
|
|
|
|
|
return $result; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
=head2 shellmeta($s, $nonquoted) |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
escapes metacharacters of interpolated shell string |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
$s: I |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
$nonquoted: I |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
return value: I |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=cut |
187
|
|
|
|
|
|
|
sub shellmeta |
188
|
|
|
|
|
|
|
{ |
189
|
0
|
|
|
0
|
1
|
|
my ($s, $nonquoted) = @_; |
190
|
0
|
0
|
|
|
|
|
return unless defined $s; |
191
|
0
|
|
|
|
|
|
$s =~ s/(\\|\"|\$)/\\$1/g; |
192
|
0
|
0
|
|
|
|
|
$s =~ s/(\s|\*)/\\$1/g if $nonquoted; |
193
|
0
|
|
|
|
|
|
return $s; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=head2 system2($cmd, @argv) |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
B<_system($cmd, @argv)> I |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
alternative implementation of perls core system subroutine that executes a system command |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
$cmd: I |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
@argv: I |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
return value: I |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
returned $!: I |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
returned $?: I |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=cut |
213
|
|
|
|
|
|
|
sub system2 |
214
|
|
|
|
|
|
|
{ |
215
|
0
|
|
|
0
|
1
|
|
my $pid; |
216
|
0
|
0
|
|
|
|
|
return -1 unless defined($pid = fork); |
217
|
0
|
0
|
|
|
|
|
unless ($pid) |
218
|
|
|
|
|
|
|
{ |
219
|
1
|
|
|
1
|
|
6
|
no warnings FATAL => 'exec'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1492
|
|
220
|
0
|
|
|
|
|
|
exec(@_); |
221
|
0
|
|
|
|
|
|
exit 255; |
222
|
|
|
|
|
|
|
} |
223
|
0
|
0
|
|
|
|
|
return -1 unless waitpid($pid, 0) > 0; |
224
|
0
|
|
|
|
|
|
return $? >> 8; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
sub _system |
227
|
|
|
|
|
|
|
{ |
228
|
0
|
|
|
0
|
|
|
return system2(@_); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=head2 bash_readline($prompt) |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
B I |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
reads a line from STDIN using Bash |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
$prompt: I |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
return value: I |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
=cut |
242
|
|
|
|
|
|
|
sub bash_readline |
243
|
|
|
|
|
|
|
{ |
244
|
0
|
|
|
0
|
1
|
|
my ($prompt) = @_; |
245
|
0
|
0
|
|
|
|
|
$prompt = "" unless defined($prompt); |
246
|
0
|
|
|
|
|
|
my $in = \*STDIN; |
247
|
0
|
0
|
|
|
|
|
unless (-t $in) |
248
|
|
|
|
|
|
|
{ |
249
|
0
|
|
|
|
|
|
my $line = <$in>; |
250
|
0
|
0
|
|
|
|
|
chomp $line if defined $line; |
251
|
0
|
|
|
|
|
|
return $line; |
252
|
|
|
|
|
|
|
} |
253
|
0
|
|
|
|
|
|
local $/ = "\n"; |
254
|
0
|
|
|
|
|
|
my $cmd = '/usr/bin/env bash -c "read -p \"'.shellmeta(shellmeta($prompt)).'\" -r -e && echo -n \"\$REPLY\" 2>/dev/null"'; |
255
|
0
|
|
|
|
|
|
$_ = `$cmd`; |
256
|
0
|
0
|
|
|
|
|
return (not $?)? $_: undef; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
sub bashReadLine |
259
|
|
|
|
|
|
|
{ |
260
|
0
|
|
|
0
|
0
|
|
return bash_readline(@_); |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
=head2 cmdargs([$prefs, ]@argv) |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
B I |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
B I |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
resolves command line arguments |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
$prefs: I |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
=over |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
valuableArgs: I |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
noCommand: I |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
optionAtAll: I |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
=back |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
@argv: I |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
-a -b=c -d e --f g --h --i=j k l -- m n |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
by default, return value: |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
{ -a => '', -b => 'c', -d => '', --f => '', --h => '', --i => 'j', command => 'e', parameters => ['g', 'k', 'l'], late_parameters => ['m', 'n'] } |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
if valuableArgs is on, return value; |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
{ -a => '', -b => 'c', -d => 'e', --f => 'g', --h => '', --i => 'j', command => 'k', parameters => ['l'], late_parameters => ['m', 'n'] } |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
if noCommand is on, return value: |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
{ -a => '', -b => 'c', -d => '', --f => '', --h => '', --i => 'j', command => undef, parameters => ['e', 'g', 'k', 'l'], late_parameters => ['m', 'n'] } |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
if optionAtAll is off, return value: |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
{ -a => '', -b => 'c', -d => '', command => 'e', parameters => ['--f', 'g', '--h', '--i=j', 'k', 'l', '--','m', 'n'], late_parameters => [] } |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
=cut |
304
|
|
|
|
|
|
|
sub cmdargs |
305
|
|
|
|
|
|
|
{ |
306
|
0
|
|
|
0
|
1
|
|
my $prefs = {}; |
307
|
0
|
0
|
0
|
|
|
|
$prefs = shift if @_ >= 1 and ref($_[0]) eq 'HASH'; |
308
|
0
|
|
|
|
|
|
my @argv = @_; |
309
|
0
|
|
|
|
|
|
my %result; |
310
|
0
|
|
|
|
|
|
$result{command} = undef; |
311
|
0
|
|
|
|
|
|
$result{parameters} = undef; |
312
|
|
|
|
|
|
|
|
313
|
0
|
|
|
|
|
|
my @parameters; |
314
|
|
|
|
|
|
|
my @late_parameters; |
315
|
0
|
|
|
|
|
|
my $late; |
316
|
0
|
|
|
|
|
|
my $opt; |
317
|
0
|
|
|
|
|
|
while (@argv) |
318
|
|
|
|
|
|
|
{ |
319
|
0
|
|
|
|
|
|
my $argv = shift @argv; |
320
|
0
|
0
|
0
|
|
|
|
next unless defined($argv) and not ref($argv); |
321
|
|
|
|
|
|
|
|
322
|
0
|
0
|
0
|
|
|
|
if (not (not defined($prefs->{optionAtAll}) or $prefs->{optionAtAll}) and @parameters) |
|
|
|
0
|
|
|
|
|
323
|
|
|
|
|
|
|
{ |
324
|
0
|
|
|
|
|
|
push @parameters, $argv; |
325
|
0
|
|
|
|
|
|
next; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
0
|
0
|
|
|
|
|
if ($late) |
329
|
|
|
|
|
|
|
{ |
330
|
0
|
|
|
|
|
|
push @late_parameters, $argv; |
331
|
0
|
|
|
|
|
|
next; |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
0
|
0
|
|
|
|
|
if (substr($argv, 0, 2) eq '--') |
335
|
|
|
|
|
|
|
{ |
336
|
0
|
|
|
|
|
|
$opt = undef; |
337
|
0
|
0
|
|
|
|
|
if (length($argv) == 2) |
338
|
|
|
|
|
|
|
{ |
339
|
0
|
|
|
|
|
|
$late = 1; |
340
|
0
|
|
|
|
|
|
next; |
341
|
|
|
|
|
|
|
} |
342
|
0
|
|
|
|
|
|
my @arg = split('=', $argv, 2); |
343
|
0
|
|
|
|
|
|
$result{$arg[0]} = $arg[1]; |
344
|
0
|
0
|
|
|
|
|
unless (defined($result{$arg[0]})) |
345
|
|
|
|
|
|
|
{ |
346
|
0
|
|
|
|
|
|
$result{$arg[0]} = ""; |
347
|
0
|
|
|
|
|
|
$opt = $arg[0]; |
348
|
|
|
|
|
|
|
} |
349
|
0
|
|
|
|
|
|
next; |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
|
352
|
0
|
0
|
0
|
|
|
|
if (substr($argv, 0, 1) eq '-' and length($argv) != 1) |
353
|
|
|
|
|
|
|
{ |
354
|
0
|
|
|
|
|
|
$opt = undef; |
355
|
0
|
|
|
|
|
|
my @arg = split('=', $argv, 2); |
356
|
0
|
|
|
|
|
|
$result{$arg[0]} = $arg[1]; |
357
|
0
|
0
|
|
|
|
|
unless (defined($result{$arg[0]})) |
358
|
|
|
|
|
|
|
{ |
359
|
0
|
|
|
|
|
|
$result{$arg[0]} = ""; |
360
|
0
|
|
|
|
|
|
$opt = $arg[0]; |
361
|
|
|
|
|
|
|
} |
362
|
0
|
|
|
|
|
|
next; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
0
|
0
|
0
|
|
|
|
if ($prefs->{valuableArgs} and $opt) |
366
|
|
|
|
|
|
|
{ |
367
|
0
|
|
|
|
|
|
$result{$opt} = $argv; |
368
|
0
|
|
|
|
|
|
$opt = undef; |
369
|
0
|
|
|
|
|
|
next; |
370
|
|
|
|
|
|
|
} |
371
|
0
|
|
|
|
|
|
$opt = undef; |
372
|
|
|
|
|
|
|
|
373
|
0
|
|
|
|
|
|
push @parameters, $argv; |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
|
376
|
0
|
0
|
|
|
|
|
$result{command} = shift @parameters unless $prefs->{noCommand}; |
377
|
0
|
|
|
|
|
|
$result{parameters} = \@parameters; |
378
|
0
|
|
|
|
|
|
$result{late_parameters} = \@late_parameters; |
379
|
|
|
|
|
|
|
|
380
|
0
|
|
|
|
|
|
return \%result; |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
sub commandArgs |
383
|
|
|
|
|
|
|
{ |
384
|
0
|
|
|
0
|
0
|
|
return cmdargs(@_); |
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
sub cmdArgs |
387
|
|
|
|
|
|
|
{ |
388
|
0
|
|
|
0
|
0
|
|
return cmdargs(@_); |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
=head2 whereis($name, $path) |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
B I |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
searches valid binary in search path |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
$name: I |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
$path: I |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
return value: I |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
=cut |
404
|
|
|
|
|
|
|
sub whereis |
405
|
|
|
|
|
|
|
{ |
406
|
0
|
|
|
0
|
1
|
|
my ($name, $path) = @_; |
407
|
0
|
0
|
|
|
|
|
return () unless $name; |
408
|
0
|
0
|
|
|
|
|
$path = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" unless $path; |
409
|
0
|
|
|
|
|
|
return grep(-x $_, map("$_/$name", split(":", $path))); |
410
|
|
|
|
|
|
|
} |
411
|
|
|
|
|
|
|
sub whereisBin |
412
|
|
|
|
|
|
|
{ |
413
|
0
|
|
|
0
|
0
|
|
return whereis(@_); |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
=head2 file_cache($tag, $expiry, $coderef) |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
B I |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
gets most recent cached value in file cache by given tag and caller function if there is cached value in expiry period. Otherwise tries to get current value using $coderef, puts value in cache and cleanups old cache values. |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
$tag: I |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
$expiry: I |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
=over |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
E0: I |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
=0: I |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
E0: I |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
=back |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
$coderef: I |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
return value: I |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
=cut |
441
|
|
|
|
|
|
|
sub file_cache |
442
|
|
|
|
|
|
|
{ |
443
|
0
|
|
|
0
|
1
|
|
my ($tag, $expiry, $coderef) = @_; |
444
|
0
|
|
|
|
|
|
my $result; |
445
|
0
|
|
|
|
|
|
my $now = time(); |
446
|
0
|
|
|
|
|
|
my @cleanup; |
447
|
0
|
|
|
|
|
|
my $caller = (caller(1))[3]; |
448
|
0
|
0
|
|
|
|
|
$caller = (caller(0))[0] unless $caller; |
449
|
0
|
|
|
|
|
|
$caller = (caller(0))[3].",$caller"; |
450
|
0
|
|
|
|
|
|
my $tag_encoded = ""; |
451
|
0
|
|
|
|
|
|
for (0..(bytes::length($tag)-1)) |
452
|
|
|
|
|
|
|
{ |
453
|
0
|
|
|
|
|
|
my $c = bytes::substr($tag, $_, 1); |
454
|
0
|
0
|
|
|
|
|
if ($c =~ /\W/) |
455
|
|
|
|
|
|
|
{ |
456
|
0
|
|
|
|
|
|
$c = uc(sprintf("%%%x", bytes::ord($c))); |
457
|
|
|
|
|
|
|
} |
458
|
0
|
|
|
|
|
|
$tag_encoded .= $c; |
459
|
|
|
|
|
|
|
} |
460
|
0
|
|
|
|
|
|
my $tmp_base = "/tmp/"; |
461
|
0
|
|
|
|
|
|
my $tmp_prefix = $caller; |
462
|
0
|
|
|
|
|
|
$tmp_prefix =~ s/\Q::\E/-/g; |
463
|
0
|
|
|
|
|
|
$tmp_prefix .= ".$tag_encoded,"; |
464
|
0
|
|
|
|
|
|
for my $tmp_path (sort {$b cmp $a} glob("${tmp_base}$tmp_prefix*")) |
|
0
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
{ |
466
|
0
|
0
|
|
|
|
|
if (my ($epoch, $pid) = $tmp_path =~ /^\Q${tmp_base}$tmp_prefix\E(\d*)\.(\d*)/) |
467
|
|
|
|
|
|
|
{ |
468
|
0
|
0
|
0
|
|
|
|
if ($expiry < 0 or ($expiry > 0 and $now-$epoch < $expiry)) |
|
|
|
0
|
|
|
|
|
469
|
|
|
|
|
|
|
{ |
470
|
0
|
0
|
|
|
|
|
if (not defined($result)) |
471
|
|
|
|
|
|
|
{ |
472
|
0
|
|
|
|
|
|
my $tmp; |
473
|
0
|
|
|
|
|
|
$tmp = file_get_contents($tmp_path); |
474
|
0
|
0
|
|
|
|
|
if ($tmp) |
475
|
|
|
|
|
|
|
{ |
476
|
0
|
0
|
|
|
|
|
if ($tmp =~ /^SCALAR\n(.*)/) |
477
|
|
|
|
|
|
|
{ |
478
|
0
|
|
|
|
|
|
$result = $1; |
479
|
|
|
|
|
|
|
} else |
480
|
|
|
|
|
|
|
{ |
481
|
0
|
|
|
|
|
|
eval { $result = from_json($tmp, {utf8 => 1}) }; |
|
0
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
} |
485
|
0
|
|
|
|
|
|
next; |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
} |
488
|
0
|
|
|
|
|
|
unshift @cleanup, $tmp_path; |
489
|
|
|
|
|
|
|
} |
490
|
0
|
0
|
|
|
|
|
if (not defined($result)) |
491
|
|
|
|
|
|
|
{ |
492
|
0
|
0
|
|
|
|
|
$result = $coderef->() if ref($coderef) eq 'CODE'; |
493
|
0
|
0
|
|
|
|
|
if (defined($result)) |
494
|
|
|
|
|
|
|
{ |
495
|
0
|
|
|
|
|
|
my $tmp; |
496
|
0
|
0
|
|
|
|
|
unless (ref($result)) |
497
|
|
|
|
|
|
|
{ |
498
|
0
|
|
|
|
|
|
$tmp = "SCALAR\n$result"; |
499
|
|
|
|
|
|
|
} else |
500
|
|
|
|
|
|
|
{ |
501
|
0
|
0
|
0
|
|
|
|
eval { $tmp = to_json($result, {utf8 => 1, pretty => 1}) } if ref($result) eq "ARRAY" or ref($result) eq "HASH"; |
|
0
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
} |
503
|
0
|
0
|
0
|
|
|
|
if ($tmp and file_put_contents("${tmp_base}tmp.$tmp_prefix$now.$$", $tmp) and rename("${tmp_base}tmp.$tmp_prefix$now.$$", "${tmp_base}$tmp_prefix$now.$$")) |
|
|
|
0
|
|
|
|
|
504
|
|
|
|
|
|
|
{ |
505
|
0
|
|
|
|
|
|
pop @cleanup; |
506
|
0
|
|
|
|
|
|
for (@cleanup) |
507
|
|
|
|
|
|
|
{ |
508
|
0
|
|
|
|
|
|
unlink($_); |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
} |
513
|
0
|
|
|
|
|
|
return $result; |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
sub fileCache |
516
|
|
|
|
|
|
|
{ |
517
|
0
|
|
|
0
|
0
|
|
return file_cache(@_); |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
=head2 get_pod_text($file_name, $section, $exclude_section) |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
B I |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
gets a text of pod contents in given file |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
$file_name: I |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
$section: I |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
$exclude_section: I |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
return value: I |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
=cut |
535
|
|
|
|
|
|
|
sub get_pod_text |
536
|
|
|
|
|
|
|
{ |
537
|
0
|
|
|
0
|
1
|
|
my ($file_name, $section, $exclude_section) = @_; |
538
|
0
|
0
|
|
|
|
|
$file_name = "$FindBin::Bin/$FindBin::Script" unless $file_name; |
539
|
0
|
0
|
|
|
|
|
return unless -e $file_name; |
540
|
0
|
|
|
|
|
|
my $parser = Pod::Simple::Text->new(); |
541
|
0
|
|
|
|
|
|
my $text; |
542
|
0
|
|
|
|
|
|
$parser->output_string(\$text); |
543
|
0
|
|
|
|
|
|
eval { $parser->parse_file($file_name) }; |
|
0
|
|
|
|
|
|
|
544
|
0
|
0
|
|
|
|
|
return if $@; |
545
|
0
|
|
|
|
|
|
utf8::decode($text); |
546
|
0
|
0
|
|
|
|
|
$section = ltrim($section) if $section; |
547
|
0
|
|
|
|
|
|
my @text = split(/^/m, $text); |
548
|
0
|
|
|
|
|
|
my $result; |
549
|
|
|
|
|
|
|
my @result; |
550
|
0
|
|
|
|
|
|
for my $line (@text) |
551
|
|
|
|
|
|
|
{ |
552
|
0
|
|
|
|
|
|
chomp $line; |
553
|
0
|
0
|
0
|
|
|
|
if (defined($section) and not defined($result)) |
554
|
|
|
|
|
|
|
{ |
555
|
0
|
0
|
|
|
|
|
if ($line eq $section) |
556
|
|
|
|
|
|
|
{ |
557
|
0
|
0
|
|
|
|
|
unless ($exclude_section) |
558
|
|
|
|
|
|
|
{ |
559
|
0
|
|
|
|
|
|
$result = "$line\n"; |
560
|
0
|
|
|
|
|
|
push @result, $line; |
561
|
|
|
|
|
|
|
} else |
562
|
|
|
|
|
|
|
{ |
563
|
0
|
|
|
|
|
|
$result = ""; |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
} |
566
|
0
|
|
|
|
|
|
next; |
567
|
|
|
|
|
|
|
} |
568
|
0
|
0
|
0
|
|
|
|
last if defined($section) and $line =~ /^\S+/; |
569
|
0
|
0
|
|
|
|
|
$result = "" unless defined($result); |
570
|
0
|
|
|
|
|
|
$result .= "$line\n"; |
571
|
0
|
|
|
|
|
|
push @result, $line; |
572
|
|
|
|
|
|
|
} |
573
|
0
|
0
|
|
|
|
|
return @result if wantarray; |
574
|
0
|
|
|
|
|
|
return $result; |
575
|
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
sub getPodText |
577
|
|
|
|
|
|
|
{ |
578
|
0
|
|
|
0
|
0
|
|
return get_pod_text(@_); |
579
|
|
|
|
|
|
|
} |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
=head2 array_to_hash(@array) |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
returns hash with indexes for given array |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
@array: I |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
return value: I> |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
=cut |
590
|
|
|
|
|
|
|
sub array_to_hash |
591
|
|
|
|
|
|
|
{ |
592
|
0
|
|
|
0
|
1
|
|
my %h; |
593
|
0
|
|
|
|
|
|
my $i = 0; |
594
|
0
|
|
|
|
|
|
%h = map { $i++ => $_ } @_; |
|
0
|
|
|
|
|
|
|
595
|
0
|
0
|
|
|
|
|
return \%h unless wantarray; |
596
|
0
|
|
|
|
|
|
return %h; |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
1; |
601
|
|
|
|
|
|
|
__END__ |