line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Script::Toolbox::Util; |
2
|
|
|
|
|
|
|
|
3
|
10
|
|
|
10
|
|
163
|
use 5.006; |
|
10
|
|
|
|
|
34
|
|
4
|
10
|
|
|
10
|
|
56
|
use strict; |
|
10
|
|
|
|
|
17
|
|
|
10
|
|
|
|
|
218
|
|
5
|
10
|
|
|
10
|
|
4695
|
use Script::Toolbox::Util::Opt; |
|
10
|
|
|
|
|
27
|
|
|
10
|
|
|
|
|
524
|
|
6
|
10
|
|
|
10
|
|
5339
|
use Script::Toolbox::Util::Formatter; |
|
10
|
|
|
|
|
32
|
|
|
10
|
|
|
|
|
506
|
|
7
|
10
|
|
|
10
|
|
5132
|
use Script::Toolbox::Util::Menues; |
|
10
|
|
|
|
|
41
|
|
|
10
|
|
|
|
|
485
|
|
8
|
10
|
|
|
10
|
|
5288
|
use Script::Toolbox::Util::Menus; |
|
10
|
|
|
|
|
31
|
|
|
10
|
|
|
|
|
520
|
|
9
|
10
|
|
|
10
|
|
4404
|
use Script::Toolbox::TableO; |
|
10
|
|
|
|
|
29
|
|
|
10
|
|
|
|
|
482
|
|
10
|
10
|
|
|
10
|
|
74
|
use IO::File; |
|
10
|
|
|
|
|
23
|
|
|
10
|
|
|
|
|
1268
|
|
11
|
10
|
|
|
10
|
|
4798
|
use IO::Dir; |
|
10
|
|
|
|
|
103044
|
|
|
10
|
|
|
|
|
513
|
|
12
|
10
|
|
|
10
|
|
6739
|
use Data::Dumper; |
|
10
|
|
|
|
|
69200
|
|
|
10
|
|
|
|
|
666
|
|
13
|
10
|
|
|
10
|
|
6444
|
use Fatal qw(open close); |
|
10
|
|
|
|
|
128020
|
|
|
10
|
|
|
|
|
53
|
|
14
|
10
|
|
|
10
|
|
17727
|
use POSIX qw(strftime); |
|
10
|
|
|
|
|
50398
|
|
|
10
|
|
|
|
|
91
|
|
15
|
10
|
|
|
10
|
|
20388
|
use Time::ParseDate; |
|
10
|
|
|
|
|
109526
|
|
|
10
|
|
|
|
|
14449
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
require Exporter; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
our @ISA = qw(Exporter); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# Items to export into callers namespace by default. Note: do not export |
22
|
|
|
|
|
|
|
# names by default without a very good reason. Use EXPORT_OK instead. |
23
|
|
|
|
|
|
|
# Do not simply export all your public functions/methods/constants. |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# This allows declaration use Script::Toolbox::Util ':all'; |
26
|
|
|
|
|
|
|
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK |
27
|
|
|
|
|
|
|
# will save memory. |
28
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( 'all' => [ qw(Open Log Exit Table Usage Dir |
29
|
|
|
|
|
|
|
File FileC System Now Menu KeyMap |
30
|
|
|
|
|
|
|
Stat TmpFile DataMenu Menue DataMenue |
31
|
|
|
|
|
|
|
CheckBox RadioButton |
32
|
|
|
|
|
|
|
)] ); |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
our @EXPORT = qw( |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
); |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# Preloaded methods go here. |
41
|
|
|
|
|
|
|
sub _getKV(@); |
42
|
|
|
|
|
|
|
sub _getCSV(@); |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
45
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
46
|
|
|
|
|
|
|
sub new |
47
|
|
|
|
|
|
|
{ |
48
|
8
|
|
|
8
|
0
|
2304
|
my $classname = shift; |
49
|
8
|
|
|
|
|
22
|
my $optDef = shift; # options definition |
50
|
8
|
|
|
|
|
21
|
my $self = {}; |
51
|
8
|
|
|
|
|
23
|
bless( $self, $classname ); |
52
|
|
|
|
|
|
|
|
53
|
8
|
|
|
|
|
38
|
@Script::Toolbox::Util::caller = caller(); |
54
|
8
|
|
|
|
|
63
|
$self->_init( $optDef, \@Script::Toolbox::Util::caller, @_ ); |
55
|
|
|
|
|
|
|
|
56
|
8
|
|
|
|
|
502
|
return $self; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
60
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
61
|
|
|
|
|
|
|
sub _init($) |
62
|
|
|
|
|
|
|
{ |
63
|
8
|
|
|
8
|
|
27
|
my ($self,$ops,$caller,$args) = @_; |
64
|
|
|
|
|
|
|
|
65
|
8
|
|
|
|
|
26
|
my $log = $caller->[1]; |
66
|
8
|
|
|
|
|
55
|
$log =~ s|^.*/||; |
67
|
8
|
|
|
|
|
38
|
$log =~ s/[.].*$//; |
68
|
8
|
|
|
|
|
28
|
$Script::Toolbox::Util{'_logFH'} = undef; # use default STDERR |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# Install signal handler |
71
|
8
|
|
|
|
|
64
|
$self->_installSigHandlers(); |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
# install options |
74
|
8
|
|
|
|
|
65
|
$self->_installOps( $ops ); |
75
|
|
|
|
|
|
|
Exit( 1, "Invalid option definition, 'opsDef' => {} invalid." ) |
76
|
8
|
50
|
66
|
|
|
78
|
if( defined $ops && !defined $self->{'ops'}); |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
# init log file |
79
|
8
|
|
|
|
|
65
|
my $logdir = $self->GetOpt('logdir'); |
80
|
8
|
100
|
|
|
|
31
|
if( defined $logdir ) |
81
|
|
|
|
|
|
|
{ |
82
|
3
|
|
|
|
|
13922
|
system( "mkdir -p $logdir" ); |
83
|
3
|
|
|
|
|
220
|
$Script::Toolbox::Util{'_logFH'} = Open( ">> $logdir/$log.log" ); |
84
|
3
|
|
|
|
|
95
|
$Script::Toolbox::Util{'_logFH'}->autoflush(); |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
89
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
90
|
|
|
|
|
|
|
sub _installOps($) |
91
|
|
|
|
|
|
|
{ |
92
|
8
|
|
|
8
|
|
27
|
my ($self, $opsDef) = @_; |
93
|
|
|
|
|
|
|
|
94
|
8
|
|
|
|
|
75
|
$self->{'ops'} = Script::Toolbox::Util::Opt->new( $opsDef, \@Script::Toolbox::Util::caller ); |
95
|
8
|
50
|
|
|
|
36
|
return if( !defined $self->{'ops'} ); |
96
|
|
|
|
|
|
|
|
97
|
8
|
|
|
|
|
18
|
foreach my $key ( keys %{$self->{'ops'}} ) |
|
8
|
|
|
|
|
37
|
|
98
|
|
|
|
|
|
|
{ |
99
|
28
|
50
|
|
|
|
90
|
if( defined $self->{$key} ) |
100
|
|
|
|
|
|
|
{ |
101
|
0
|
|
|
|
|
0
|
print STDERR "Script::Toolbox internal error. "; |
102
|
0
|
|
|
|
|
0
|
print STDERR "Can't use command line option $key (internal used)\n"; |
103
|
0
|
|
|
|
|
0
|
next; |
104
|
|
|
|
|
|
|
} |
105
|
28
|
|
|
|
|
84
|
$self->{$key} = $self->{'ops'}->get($key); |
106
|
|
|
|
|
|
|
} |
107
|
8
|
|
|
|
|
18
|
return; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
111
|
|
|
|
|
|
|
# Signal handler. |
112
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
113
|
|
|
|
|
|
|
sub _sigExit($) |
114
|
|
|
|
|
|
|
{ |
115
|
0
|
|
|
0
|
|
0
|
my ($sig) = @_; |
116
|
0
|
|
|
|
|
0
|
Exit( 1, "program aborted by signal SIG$sig." ); |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
120
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
121
|
|
|
|
|
|
|
sub _installSigHandlers() |
122
|
|
|
|
|
|
|
{ |
123
|
8
|
|
|
8
|
|
25
|
my ($self) = @_; |
124
|
8
|
|
|
|
|
235
|
$SIG{'INT'} = \&_sigExit; |
125
|
8
|
|
|
|
|
107
|
$SIG{'HUP'} = \&_sigExit; |
126
|
8
|
|
|
|
|
110
|
$SIG{'QUIT'}= \&_sigExit; |
127
|
8
|
|
|
|
|
144
|
$SIG{'TERM'}= \&_sigExit; |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
132
|
|
|
|
|
|
|
# Log a message and exit the programm with the given error code. |
133
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
134
|
|
|
|
|
|
|
sub Exit(@) |
135
|
|
|
|
|
|
|
{ |
136
|
0
|
|
|
0
|
0
|
0
|
my ($exitCode, $message, $file, $line) = _getParam(@_); |
137
|
|
|
|
|
|
|
|
138
|
0
|
0
|
0
|
|
|
0
|
$message .= sprintf "\n\tSource:%s:%s", $file, $line if( defined $line && |
139
|
|
|
|
|
|
|
defined $file ); |
140
|
0
|
|
|
|
|
0
|
Log( $message ); |
141
|
0
|
|
|
|
|
0
|
exit $exitCode; |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
145
|
|
|
|
|
|
|
# Write 'die' messages via Log(). |
146
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
147
|
|
|
|
|
|
|
sub _dieHook |
148
|
|
|
|
|
|
|
{ |
149
|
0
|
0
|
|
0
|
|
0
|
die @_ if $^S; |
150
|
|
|
|
|
|
|
|
151
|
0
|
|
|
|
|
0
|
my @y = split /\n/, $_[0]; |
152
|
0
|
|
|
|
|
0
|
map { Log( $_ ); } @y; |
|
0
|
|
|
|
|
0
|
|
153
|
|
|
|
|
|
|
}; |
154
|
|
|
|
|
|
|
$main::SIG{'__DIE__'} = \&_dieHook; # install die hook |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
158
|
|
|
|
|
|
|
# Write a log message with time stamp to a channel. |
159
|
|
|
|
|
|
|
# $severity, $logtag only required for syslog. |
160
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
161
|
|
|
|
|
|
|
sub Log(@) |
162
|
|
|
|
|
|
|
{ |
163
|
0
|
|
|
0
|
0
|
0
|
my ($message, $canal, $severity, $logtag) = _getParam(@_); |
164
|
|
|
|
|
|
|
|
165
|
0
|
|
|
|
|
0
|
my $prog = $0; |
166
|
0
|
|
|
|
|
0
|
$prog =~ s|^.*/||; |
167
|
0
|
|
|
|
|
0
|
my $msg = sprintf "%s: %s: %s\n", $prog, scalar localtime(), $message; |
168
|
|
|
|
|
|
|
|
169
|
0
|
|
|
|
|
0
|
my $fh; |
170
|
0
|
|
|
|
|
0
|
my $can = *STDERR; |
171
|
|
|
|
|
|
|
|
172
|
0
|
0
|
|
|
|
0
|
if ( !defined $canal ) |
173
|
|
|
|
|
|
|
{ |
174
|
0
|
0
|
|
|
|
0
|
if( defined $Script::Toolbox::Util{'_logFH'}) { $can = $Script::Toolbox::Util{'_logFH'}; } |
|
0
|
|
|
|
|
0
|
|
175
|
|
|
|
|
|
|
}else{ |
176
|
|
|
|
|
|
|
# canel is defined here |
177
|
0
|
0
|
|
|
|
0
|
if ( ref($canal) eq 'IO::File' ){ $can = $canal; } |
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
178
|
0
|
|
|
|
|
0
|
elsif ( $canal eq 'STDERR') { $can = *STDERR; } |
179
|
0
|
|
|
|
|
0
|
elsif ( $canal eq 'STDOUT') { $can = *STDOUT; } |
180
|
0
|
|
|
|
|
0
|
elsif ( $canal eq 'syslog') { $can = new IO::File "| logger -p '$severity' -t '$logtag'"; } |
181
|
0
|
|
|
|
|
0
|
else { $can = _openFromString($canal); } |
182
|
|
|
|
|
|
|
} |
183
|
0
|
|
|
|
|
0
|
print $can $msg; |
184
|
0
|
|
|
|
|
0
|
return $msg; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
188
|
|
|
|
|
|
|
# We got a string like "/tmp/x", ">> /tmp/x" or "| someProgram". |
189
|
|
|
|
|
|
|
# Try to open it as a log canal. If it fails open STDERR instead. |
190
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
191
|
|
|
|
|
|
|
sub _openFromString($) |
192
|
|
|
|
|
|
|
{ |
193
|
0
|
|
|
0
|
|
0
|
my ($canal) = @_; |
194
|
|
|
|
|
|
|
|
195
|
0
|
0
|
0
|
|
|
0
|
if( $canal !~ /^\s*>/ && $canal !~ /^\s*[|]/ ) { $canal = '>>' . $canal; } |
|
0
|
|
|
|
|
0
|
|
196
|
|
|
|
|
|
|
|
197
|
0
|
|
|
|
|
0
|
my $can; |
198
|
0
|
|
|
|
|
0
|
my $fh = new IO::File "$canal"; |
199
|
0
|
0
|
|
|
|
0
|
if( !defined $fh ) |
200
|
|
|
|
|
|
|
{ |
201
|
0
|
|
|
|
|
0
|
$can = *STDERR; |
202
|
0
|
|
|
|
|
0
|
printf $can "%s: %s: %s %s\n", |
203
|
|
|
|
|
|
|
$0, scalar localtime(), "WARNING: can't write to", $canal; |
204
|
|
|
|
|
|
|
}else{ |
205
|
0
|
|
|
|
|
0
|
$can = $fh; |
206
|
|
|
|
|
|
|
} |
207
|
0
|
|
|
|
|
0
|
return $can; |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
211
|
|
|
|
|
|
|
# Open a file via IO::File with Fatal handling |
212
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
213
|
|
|
|
|
|
|
sub Open(@) |
214
|
|
|
|
|
|
|
{ |
215
|
19
|
|
|
19
|
0
|
1434
|
my ($file, $iolayer) = _getParam(@_); |
216
|
19
|
|
|
|
|
408
|
my $fh = new IO::File "$file"; |
217
|
19
|
|
|
|
|
8331
|
return $fh; |
218
|
|
|
|
|
|
|
} |
219
|
10
|
|
|
10
|
|
101
|
use Fatal qw(IO::File::open); |
|
10
|
|
|
|
|
30
|
|
|
10
|
|
|
|
|
78
|
|
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
223
|
|
|
|
|
|
|
# Format $param as table and return a reference to the result array. |
224
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
225
|
|
|
|
|
|
|
sub Table(@) |
226
|
|
|
|
|
|
|
{ |
227
|
10
|
|
|
10
|
0
|
13102
|
my ($self, $param, $separator) = @_; |
228
|
10
|
50
|
|
|
|
49
|
if( ref $self ne 'Script::Toolbox') { # only for compatibility |
229
|
0
|
|
|
|
|
0
|
$separator = $param; # to versions befor 0.50 |
230
|
0
|
|
|
|
|
0
|
$param = $self; |
231
|
0
|
|
|
|
|
0
|
$self = undef; |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
10
|
|
|
|
|
84
|
my $t = Script::Toolbox::TableO->new($param, $separator); |
235
|
10
|
|
|
|
|
43
|
my @T = $t->asArray(); |
236
|
10
|
|
|
|
|
71
|
return \@T; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
240
|
|
|
|
|
|
|
# $param must be a hash reference. This Hash must have a key "data". |
241
|
|
|
|
|
|
|
# This key may point to: |
242
|
|
|
|
|
|
|
# arrayref |
243
|
|
|
|
|
|
|
# hashref |
244
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
245
|
|
|
|
|
|
|
sub _noData($) |
246
|
|
|
|
|
|
|
{ |
247
|
0
|
|
|
0
|
|
0
|
my ($param) = @_; |
248
|
|
|
|
|
|
|
|
249
|
0
|
0
|
|
|
|
0
|
return 0 if( ref $param ne 'HASH' ); |
250
|
0
|
0
|
|
|
|
0
|
return 0 if( ref $param->{'data'} eq 'HASH' ); |
251
|
0
|
0
|
|
|
|
0
|
return 0 if( ref $param->{'data'} eq 'ARRAY'); |
252
|
|
|
|
|
|
|
|
253
|
0
|
0
|
|
|
|
0
|
if( !defined $param->{'data'}[0] ) |
254
|
|
|
|
|
|
|
{ |
255
|
0
|
|
|
|
|
0
|
Log( "WARNING: no input data for Table()." ); |
256
|
0
|
|
|
|
|
0
|
return 1; |
257
|
|
|
|
|
|
|
} |
258
|
0
|
|
|
|
|
0
|
return 0; |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
262
|
|
|
|
|
|
|
# Valid Calls: |
263
|
|
|
|
|
|
|
# [ "csvString", "csvString",...], undef |
264
|
|
|
|
|
|
|
# [ "csvString", "csvString",...], separatorString |
265
|
|
|
|
|
|
|
# [ "TitelString", [headArray], [dataArray],...], undef |
266
|
|
|
|
|
|
|
# [ [dataArray],...], undef |
267
|
|
|
|
|
|
|
# {title=>"", head=>[], data=>[[],[],...] }, undef |
268
|
|
|
|
|
|
|
# {title=>"", head=>[], data=>[{},{},...] }, undef |
269
|
|
|
|
|
|
|
# {title=>"", head=>[], data=>{r1=>{c1=>,c2=>,},r2=>{c1=>,c2=>,},}, undef |
270
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
271
|
|
|
|
|
|
|
sub _normParam($$) |
272
|
|
|
|
|
|
|
{ |
273
|
0
|
|
|
0
|
|
0
|
my ($param, $separator) = @_; |
274
|
|
|
|
|
|
|
|
275
|
0
|
0
|
|
|
|
0
|
if( ref $param eq 'HASH' ) |
276
|
|
|
|
|
|
|
{ |
277
|
|
|
|
|
|
|
# keine Ahnung wozu: return _sepHash($param, $separator) if( _isCSV($param->{'data'}) ); |
278
|
0
|
|
|
|
|
0
|
return $param; |
279
|
|
|
|
|
|
|
} |
280
|
0
|
0
|
|
|
|
0
|
return _sepTitleHead($param) if( _isTitleHead($param) ); |
281
|
0
|
0
|
|
|
|
0
|
return _sepCSV($param, $separator) if( _isCSV($param, $separator) ); |
282
|
0
|
|
|
|
|
0
|
return { 'data' => $param }; |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
286
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
287
|
|
|
|
|
|
|
sub _sepHash($$) |
288
|
|
|
|
|
|
|
{ |
289
|
0
|
|
|
0
|
|
0
|
my ($param,$separator) = @_; |
290
|
|
|
|
|
|
|
|
291
|
0
|
|
|
|
|
0
|
my $d = _sepCSV($param->{'data'}, $separator); |
292
|
0
|
|
|
|
|
0
|
$param->{'data'} = $d->{'data'}; |
293
|
0
|
|
|
|
|
0
|
return $param; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
297
|
|
|
|
|
|
|
# Check if we found the special data array format. |
298
|
|
|
|
|
|
|
# ["TitleString", [headString,headString,...],[data,...],...] |
299
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
300
|
|
|
|
|
|
|
sub _isTitleHead($) |
301
|
|
|
|
|
|
|
{ |
302
|
0
|
|
|
0
|
|
0
|
my ($param) = @_; |
303
|
|
|
|
|
|
|
|
304
|
0
|
0
|
0
|
|
|
0
|
return 1 if( ref \$param->[0] eq 'SCALAR' && ref $param->[1] eq 'ARRAY' ); |
305
|
0
|
|
|
|
|
0
|
return 0; |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
309
|
|
|
|
|
|
|
# Transform the special data array |
310
|
|
|
|
|
|
|
# ["TitleString", [headString,headString,...],[data,...],...] |
311
|
|
|
|
|
|
|
# into hash format. |
312
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
313
|
|
|
|
|
|
|
sub _sepTitleHead($) |
314
|
|
|
|
|
|
|
{ |
315
|
0
|
|
|
0
|
|
0
|
my ($param) = @_; |
316
|
|
|
|
|
|
|
|
317
|
0
|
|
|
|
|
0
|
my $title= splice @{$param}, 0,1; |
|
0
|
|
|
|
|
0
|
|
318
|
0
|
|
|
|
|
0
|
my $head = splice @{$param}, 0,1; |
|
0
|
|
|
|
|
0
|
|
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
return { |
321
|
0
|
|
|
|
|
0
|
'title' => $title, |
322
|
|
|
|
|
|
|
'head' => $head, |
323
|
|
|
|
|
|
|
'data' => $param |
324
|
|
|
|
|
|
|
}; |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
329
|
|
|
|
|
|
|
# [[],[],...] |
330
|
|
|
|
|
|
|
# [{},{},...] |
331
|
|
|
|
|
|
|
# {r1=>{c1=>,c2=>,},r2=>{c1=>,c2=>,},} |
332
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
333
|
|
|
|
|
|
|
sub _isCSV($$) |
334
|
|
|
|
|
|
|
{ |
335
|
0
|
|
|
0
|
|
0
|
my ($param, $separator) = @_; |
336
|
|
|
|
|
|
|
|
337
|
0
|
0
|
|
|
|
0
|
return 0 if( ref $param ne 'ARRAY' ); |
338
|
|
|
|
|
|
|
|
339
|
0
|
0
|
|
|
|
0
|
$separator = ';' unless defined $separator; #FIXME default sep |
340
|
0
|
0
|
|
|
|
0
|
return 1 if( $param->[0] =~ /$separator/ ); #assume it's a CSV record |
341
|
0
|
|
|
|
|
0
|
return 0; |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
345
|
|
|
|
|
|
|
# Convert an array of CSV strings into an array of arrays. |
346
|
|
|
|
|
|
|
# |
347
|
|
|
|
|
|
|
# [ "a;b","c,d"] becomes |
348
|
|
|
|
|
|
|
# [[a,b], [c,d]] |
349
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
350
|
|
|
|
|
|
|
sub _sepCSV($$) |
351
|
|
|
|
|
|
|
{ |
352
|
0
|
|
|
0
|
|
0
|
my ($param, $separator) = @_; |
353
|
|
|
|
|
|
|
|
354
|
0
|
0
|
|
|
|
0
|
$separator = ';' if( !defined $separator); |
355
|
0
|
|
|
|
|
0
|
my @R; |
356
|
0
|
|
|
|
|
0
|
foreach my $l ( @{$param} ) |
|
0
|
|
|
|
|
0
|
|
357
|
|
|
|
|
|
|
{ |
358
|
0
|
|
|
|
|
0
|
my @r = split /$separator/, $l; |
359
|
0
|
|
|
|
|
0
|
push @R, \@r; |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
0
|
|
|
|
|
0
|
return { 'data' => \@R }; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
366
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
367
|
|
|
|
|
|
|
sub SetOpsDef($) |
368
|
|
|
|
|
|
|
{ |
369
|
1
|
|
|
1
|
0
|
851
|
my ($self,$opsDef) = @_; |
370
|
1
|
|
|
|
|
3
|
my $old = $self->{'ops'}; |
371
|
1
|
|
|
|
|
5
|
$self->{'ops'} = Script::Toolbox::Util::Opt->new( $opsDef ); |
372
|
1
|
|
|
|
|
5
|
return ($self->{'ops'}, $old); |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
376
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
377
|
|
|
|
|
|
|
sub GetOpt($) |
378
|
|
|
|
|
|
|
{ |
379
|
10
|
|
|
10
|
0
|
589
|
my ($self,$opt) = @_; |
380
|
10
|
50
|
|
|
|
55
|
return undef if( ! defined $self->{'ops'} ); |
381
|
10
|
|
|
|
|
36
|
return $self->{'ops'}->get($opt); |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
385
|
|
|
|
|
|
|
# Read the entire file into an array. |
386
|
|
|
|
|
|
|
# File can be a file name or an IO::File handle. |
387
|
|
|
|
|
|
|
# Chomp all array elements. |
388
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
389
|
|
|
|
|
|
|
sub FileC(@) |
390
|
|
|
|
|
|
|
{ |
391
|
0
|
|
|
0
|
0
|
0
|
my ($filename,$newContent) = _getParam(@_); |
392
|
|
|
|
|
|
|
|
393
|
0
|
|
|
|
|
0
|
my $f = undef; |
394
|
0
|
0
|
|
|
|
0
|
if( !defined $newContent) { $f = _ReadFile($filename); } |
|
0
|
0
|
|
|
|
0
|
|
395
|
0
|
|
|
|
|
0
|
elsif( ref $newContent eq 'CODE'){ $f = _ReadFile($filename,$newContent);} |
396
|
0
|
|
|
|
|
0
|
else { return undef; } |
397
|
|
|
|
|
|
|
|
398
|
0
|
0
|
|
|
|
0
|
chomp @{$f} if( defined $f ); |
|
0
|
|
|
|
|
0
|
|
399
|
0
|
|
|
|
|
0
|
return $f; |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
403
|
|
|
|
|
|
|
# Read the entire file into an array or write the new content to the file. |
404
|
|
|
|
|
|
|
# File can be a file name or an IO::File handle. |
405
|
|
|
|
|
|
|
# Newcontent may be a SCALAR value, an ARRAY reference, a HASH reference or |
406
|
|
|
|
|
|
|
# a reference to a callback function. |
407
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
408
|
|
|
|
|
|
|
sub File(@) |
409
|
|
|
|
|
|
|
{ |
410
|
14
|
|
|
14
|
0
|
80330
|
my ($filename,$newContent,$recSep,$fieldSep) = _getParam(@_); |
411
|
|
|
|
|
|
|
|
412
|
14
|
100
|
|
|
|
93
|
if( !defined $newContent) { return _ReadFile($filename); } |
|
4
|
100
|
|
|
|
45
|
|
413
|
1
|
|
|
|
|
4
|
elsif( ref $newContent eq 'CODE'){ return _ReadFile($filename,$newContent);} |
414
|
9
|
|
|
|
|
61
|
else { _WriteFile($filename,$newContent,$recSep,$fieldSep); } |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
418
|
|
|
|
|
|
|
# Read the entire file into a hash or write the new content to the file. |
419
|
|
|
|
|
|
|
# File can be a file name or an IO::File handle. |
420
|
|
|
|
|
|
|
# Newcontent may be a reference to a keyMap HASH or a reference to a callback |
421
|
|
|
|
|
|
|
# function. |
422
|
|
|
|
|
|
|
# The Hash looks like: |
423
|
|
|
|
|
|
|
# keyA1 => keyB1 ... =>keyN1 => value1 |
424
|
|
|
|
|
|
|
# keyA2 => keyB2 ... =>keyN2 => value2 |
425
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
426
|
|
|
|
|
|
|
sub KeyMap(@) |
427
|
|
|
|
|
|
|
{ |
428
|
2
|
|
|
2
|
0
|
578
|
my ($filename,$fieldSep,$newContent) = _getParam(@_); |
429
|
|
|
|
|
|
|
|
430
|
2
|
50
|
|
|
|
7
|
if( !defined $newContent) |
|
|
0
|
|
|
|
|
|
431
|
2
|
|
|
|
|
7
|
{ return _ReadKeyMap($filename, $fieldSep); } |
432
|
|
|
|
|
|
|
elsif( ref $newContent eq 'CODE' ) |
433
|
0
|
|
|
|
|
0
|
{ return _ReadKeyMap($filename, $fieldSep, $newContent); } |
434
|
0
|
|
|
|
|
0
|
else { _WriteKeyMap($filename,$fieldSep,$newContent); } |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
438
|
|
|
|
|
|
|
# The Hash looks like: |
439
|
|
|
|
|
|
|
# keyA1 => keyB1 ... =>keyN1 => value1 |
440
|
|
|
|
|
|
|
# keyA2 => keyB2 ... =>keyN2 => value2 |
441
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
442
|
|
|
|
|
|
|
sub _WriteKeyMap($$$) |
443
|
|
|
|
|
|
|
{ |
444
|
0
|
|
|
0
|
|
0
|
my ($filename,$fieldSep,$newContent) = @_; |
445
|
|
|
|
|
|
|
|
446
|
0
|
0
|
|
|
|
0
|
$fieldSep = ',' if( !defined $fieldSep ); |
447
|
|
|
|
|
|
|
|
448
|
0
|
|
|
|
|
0
|
my $TXT = ''; |
449
|
0
|
|
|
|
|
0
|
_getCSV( \$TXT, '', $newContent, $fieldSep ); |
450
|
|
|
|
|
|
|
|
451
|
0
|
|
|
|
|
0
|
File( "> $filename", $TXT ); |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
455
|
|
|
|
|
|
|
# Write a KeyMap (HASH) to a file. |
456
|
|
|
|
|
|
|
# |
457
|
|
|
|
|
|
|
# The Hash looks like: |
458
|
|
|
|
|
|
|
# keyA1 => keyB1 ... =>keyN1 => value1 |
459
|
|
|
|
|
|
|
# keyA2 => keyB2 ... =>keyN2 => value2 |
460
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
461
|
|
|
|
|
|
|
sub _getCSV(@) |
462
|
|
|
|
|
|
|
{ |
463
|
0
|
|
|
0
|
|
0
|
my ($txt, $prev, $newContent,$fieldSep) = @_; |
464
|
|
|
|
|
|
|
|
465
|
0
|
|
|
|
|
0
|
my $prefix = ''; |
466
|
0
|
|
|
|
|
0
|
foreach my $k ( sort keys %{$newContent} ) |
|
0
|
|
|
|
|
0
|
|
467
|
|
|
|
|
|
|
{ |
468
|
0
|
|
|
|
|
0
|
$$txt .= $prefix .$k . $fieldSep; |
469
|
0
|
0
|
|
|
|
0
|
if( ref $newContent->{$k} ne 'HASH' ) |
470
|
|
|
|
|
|
|
{ |
471
|
0
|
|
|
|
|
0
|
$$txt .= $newContent->{$k} . "\n"; |
472
|
0
|
|
|
|
|
0
|
$prefix = $prev; |
473
|
0
|
|
|
|
|
0
|
next; |
474
|
|
|
|
|
|
|
} |
475
|
0
|
|
|
|
|
0
|
_getCSV($txt, "$prev$k$fieldSep", $newContent->{$k}, $fieldSep); |
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
480
|
|
|
|
|
|
|
# |
481
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
482
|
|
|
|
|
|
|
sub _checkParam($$) |
483
|
|
|
|
|
|
|
{ |
484
|
2
|
|
|
2
|
|
5
|
my ( $fieldSep, $callBack) = @_; |
485
|
|
|
|
|
|
|
|
486
|
2
|
|
|
|
|
3
|
my $def=','; |
487
|
2
|
100
|
|
|
|
6
|
$$fieldSep = $def if( !defined $$fieldSep ); |
488
|
|
|
|
|
|
|
|
489
|
2
|
|
|
|
|
5
|
my ( $fs, $cb ) = ( $$fieldSep, $$callBack); |
490
|
2
|
|
|
|
|
5
|
my $rfs = ref $fs; my $rcb = ref $cb; |
|
2
|
|
|
|
|
3
|
|
491
|
|
|
|
|
|
|
|
492
|
2
|
|
66
|
|
|
9
|
my $scalar_code = ref $fs eq '' && ref $cb eq 'CODE'; |
493
|
2
|
|
66
|
|
|
8
|
my $scalar_undef= ref $fs eq '' && !defined $cb; |
494
|
2
|
|
66
|
|
|
11
|
my $code_scalar = ref $fs eq 'CODE' && ref $cb eq '' && defined $cb; |
495
|
2
|
|
66
|
|
|
10
|
my $code_undef = ref $fs eq 'CODE' && !defined $cb; |
496
|
|
|
|
|
|
|
|
497
|
2
|
50
|
|
|
|
9
|
if ( $scalar_code ){return;} |
|
0
|
100
|
|
|
|
0
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
498
|
1
|
|
|
|
|
2
|
elsif( $scalar_undef){return;} |
499
|
0
|
|
|
|
|
0
|
elsif( $code_scalar ){$$fieldSep = $cb; $$callBack = $fs;} |
|
0
|
|
|
|
|
0
|
|
500
|
1
|
|
|
|
|
3
|
elsif( $code_undef ){$$fieldSep = $def;$$callBack = $fs;} |
|
1
|
|
|
|
|
3
|
|
501
|
0
|
|
|
|
|
0
|
else { $$fieldSep = $def; $$callBack = undef;} |
|
0
|
|
|
|
|
0
|
|
502
|
|
|
|
|
|
|
} |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
505
|
|
|
|
|
|
|
# Read a CSV file into a hash. The lines of the CSV files are "\n" separated. |
506
|
|
|
|
|
|
|
# Default field separator is ",". |
507
|
|
|
|
|
|
|
# The Hash looks like: |
508
|
|
|
|
|
|
|
# keyA1 => keyB1 ... =>keyN1 => value1 |
509
|
|
|
|
|
|
|
# keyA2 => keyB2 ... =>keyN2 => value2 |
510
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
511
|
|
|
|
|
|
|
sub _ReadKeyMap($$$) |
512
|
|
|
|
|
|
|
{ |
513
|
2
|
|
|
2
|
|
5
|
my ($file, $fieldSep, $callBack) = @_; |
514
|
|
|
|
|
|
|
|
515
|
2
|
|
|
|
|
8
|
_checkParam(\$fieldSep, \$callBack); |
516
|
|
|
|
|
|
|
|
517
|
2
|
|
|
|
|
4
|
my $f; |
518
|
2
|
100
|
|
|
|
4
|
if( defined $callBack ) { $f = File( $file,$callBack, $fieldSep ); } |
|
1
|
|
|
|
|
4
|
|
519
|
1
|
|
|
|
|
3
|
else { $f = File( $file ); } |
520
|
2
|
|
|
|
|
5
|
chomp( @{$f} ); |
|
2
|
|
|
|
|
7
|
|
521
|
|
|
|
|
|
|
|
522
|
2
|
|
|
|
|
3
|
my %P; |
523
|
2
|
|
|
|
|
4
|
foreach my $line ( @{$f} ) |
|
2
|
|
|
|
|
5
|
|
524
|
|
|
|
|
|
|
{ |
525
|
4
|
|
|
|
|
22
|
my @L = split /$fieldSep/, $line; |
526
|
4
|
|
|
|
|
11
|
_getKV( \%P, @L ); |
527
|
|
|
|
|
|
|
} |
528
|
2
|
|
|
|
|
7
|
return \%P; |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
532
|
|
|
|
|
|
|
# Add one line (from @_ array) to the hash. Hash looks like: |
533
|
|
|
|
|
|
|
# key1 => key2 ... =>keyN => value1 |
534
|
|
|
|
|
|
|
# key1 => key2 ... =>keyX => value2 |
535
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
536
|
|
|
|
|
|
|
sub _getKV(@) |
537
|
|
|
|
|
|
|
{ |
538
|
8
|
|
|
8
|
|
21
|
my ($P, $k, @v) = @_; |
539
|
|
|
|
|
|
|
|
540
|
8
|
50
|
|
|
|
16
|
return if( ! defined $k ); |
541
|
8
|
100
|
|
|
|
19
|
if( ref $P->{$k} eq 'HASH' ){ |
542
|
2
|
|
|
|
|
6
|
_getKV( $P->{$k}, @v ); |
543
|
2
|
|
|
|
|
6
|
return; |
544
|
|
|
|
|
|
|
} |
545
|
6
|
100
|
|
|
|
13
|
if( @v == 1 ){ |
546
|
4
|
|
|
|
|
9
|
$P->{$k} = $v[0]; |
547
|
4
|
|
|
|
|
9
|
return; |
548
|
|
|
|
|
|
|
}else{ |
549
|
2
|
|
|
|
|
4
|
my $x = {}; |
550
|
2
|
|
|
|
|
6
|
$P->{$k} = $x; |
551
|
2
|
|
|
|
|
6
|
_getKV( $x, @v ); |
552
|
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
557
|
|
|
|
|
|
|
# Open the file in required write mode (default append mode) and write the new |
558
|
|
|
|
|
|
|
# content to the file. |
559
|
|
|
|
|
|
|
# Newcontent can be any kind of data structure. |
560
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
561
|
|
|
|
|
|
|
sub _WriteFile($$) |
562
|
|
|
|
|
|
|
{ |
563
|
9
|
|
|
9
|
|
41
|
my($file,$newContent,$recSep,$fieldSep) =@_; |
564
|
|
|
|
|
|
|
|
565
|
9
|
|
|
|
|
22
|
my $fh; |
566
|
9
|
50
|
|
|
|
39
|
if( ref $file eq 'IO::File' ) |
567
|
|
|
|
|
|
|
{ |
568
|
0
|
|
|
|
|
0
|
$fh = $file; |
569
|
|
|
|
|
|
|
}else{ |
570
|
9
|
|
|
|
|
105
|
$file =~ s/^\s+//; |
571
|
9
|
|
|
|
|
33
|
$file =~ s/^<+//; # write mode only |
572
|
9
|
100
|
|
|
|
60
|
$file = '>>' . $file if( $file !~ /^[|>]/ ); |
573
|
9
|
|
50
|
|
|
83
|
$fh = Open( $file ) || return undef; |
574
|
|
|
|
|
|
|
} |
575
|
9
|
100
|
|
|
|
103
|
if( ref $newContent eq '' ) {print $fh $newContent;} |
|
6
|
100
|
|
|
|
2167
|
|
|
|
100
|
|
|
|
|
|
576
|
|
|
|
|
|
|
elsif( _simpleArray( $newContent)) |
577
|
1
|
|
|
|
|
8
|
{ _printSimpleArray($newContent, $fh, $recSep)} |
578
|
|
|
|
|
|
|
elsif( _simpleHash( $newContent )) |
579
|
1
|
|
|
|
|
12
|
{ _printSimpleHash($newContent, $fh, $recSep,$fieldSep)} |
580
|
1
|
|
|
|
|
35
|
else { print $fh Dumper $newContent; } |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
584
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
585
|
|
|
|
|
|
|
sub _printSimpleArray($$$) |
586
|
|
|
|
|
|
|
{ |
587
|
1
|
|
|
1
|
|
8
|
my ($content,$fh,$recSep) = @_; |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
map |
590
|
|
|
|
|
|
|
{ |
591
|
3
|
50
|
|
|
|
13
|
my $rs = defined $recSep ? $recSep : ''; |
592
|
3
|
|
|
|
|
60
|
print $fh "$_$rs"; |
593
|
1
|
|
|
|
|
7
|
} @{$content}; |
|
1
|
|
|
|
|
9
|
|
594
|
|
|
|
|
|
|
} |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
597
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
598
|
|
|
|
|
|
|
sub _printSimpleHash($$$$) |
599
|
|
|
|
|
|
|
{ |
600
|
1
|
|
|
1
|
|
4
|
my ($content,$fh,$recSep,$fieldSep) = @_; |
601
|
1
|
|
|
|
|
4
|
foreach my $key (sort keys %{$content}) |
|
1
|
|
|
|
|
10
|
|
602
|
|
|
|
|
|
|
{ |
603
|
3
|
50
|
|
|
|
17
|
my $rs = defined $recSep ? $recSep : ''; |
604
|
3
|
50
|
|
|
|
8
|
my $fs = defined $fieldSep ? $fieldSep : ':'; |
605
|
3
|
|
|
|
|
33
|
printf $fh "%s%s%s%s", $key, $fs, $content->{$key},$rs; |
606
|
|
|
|
|
|
|
} |
607
|
1
|
|
|
|
|
59
|
return; |
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
611
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
612
|
|
|
|
|
|
|
sub _simpleHash($) |
613
|
|
|
|
|
|
|
{ |
614
|
2
|
|
|
2
|
|
15
|
my ($content) = @_; |
615
|
|
|
|
|
|
|
|
616
|
2
|
50
|
|
|
|
19
|
return 0 if( ref $content ne 'HASH'); |
617
|
2
|
|
|
|
|
11
|
foreach my $key ( keys %{$content} ) |
|
2
|
|
|
|
|
19
|
|
618
|
|
|
|
|
|
|
{ |
619
|
5
|
100
|
|
|
|
32
|
return 0 if( ref $content->{$key} ne '' ); # scalar estimated |
620
|
|
|
|
|
|
|
} |
621
|
1
|
|
|
|
|
5
|
return 1; |
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
625
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
626
|
|
|
|
|
|
|
sub _simpleArray($) |
627
|
|
|
|
|
|
|
{ |
628
|
3
|
|
|
3
|
|
14
|
my ($content) = @_; |
629
|
|
|
|
|
|
|
|
630
|
3
|
100
|
|
|
|
39
|
return 0 if( ref $content ne 'ARRAY'); |
631
|
1
|
|
|
|
|
7
|
foreach my $line ( @{$content} ) |
|
1
|
|
|
|
|
11
|
|
632
|
|
|
|
|
|
|
{ |
633
|
3
|
50
|
|
|
|
9
|
return 0 if( ref $line ne '' ); # scalar estimated |
634
|
|
|
|
|
|
|
} |
635
|
1
|
|
|
|
|
9
|
return 1; |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
639
|
|
|
|
|
|
|
# Read the file content into an array and return a referenz to this array. |
640
|
|
|
|
|
|
|
# Return undef if the file isn't readable. |
641
|
|
|
|
|
|
|
# File can be a file name or an IO::File handle. |
642
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
643
|
|
|
|
|
|
|
sub _ReadFile($$) |
644
|
|
|
|
|
|
|
{ |
645
|
5
|
|
|
5
|
|
32
|
my($file,$callBack) =@_; |
646
|
|
|
|
|
|
|
|
647
|
5
|
|
|
|
|
19
|
my ($fh,@F); |
648
|
5
|
50
|
|
|
|
28
|
if( ref $file eq 'IO::File' ) |
649
|
|
|
|
|
|
|
{ |
650
|
0
|
|
|
|
|
0
|
$fh = $file; |
651
|
|
|
|
|
|
|
}else{ |
652
|
5
|
|
|
|
|
30
|
$file =~ s/^\s*>+\s*//; # read only mode |
653
|
5
|
|
50
|
|
|
45
|
$fh= Open( $file ) || return undef; |
654
|
|
|
|
|
|
|
} |
655
|
5
|
|
|
|
|
6394
|
@F = <$fh>; my $rf = \@F; |
|
5
|
|
|
|
|
26
|
|
656
|
5
|
100
|
|
|
|
21
|
$rf = &{$callBack}( \@F ) if( defined $callBack ); |
|
1
|
|
|
|
|
4
|
|
657
|
5
|
50
|
|
|
|
34
|
$rf = \@F if(!defined $rf ); |
658
|
5
|
|
|
|
|
226
|
return $rf; |
659
|
|
|
|
|
|
|
} |
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
662
|
|
|
|
|
|
|
# Without an input argument TmpFile() returns an file handle to an new |
663
|
|
|
|
|
|
|
# temporary file. |
664
|
|
|
|
|
|
|
# Otherwise read the tempfile into an array and return a reference to it. |
665
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
666
|
|
|
|
|
|
|
sub TmpFile(@) |
667
|
|
|
|
|
|
|
{ |
668
|
2
|
|
|
2
|
0
|
55410
|
my ($file) = _getParam(@_); |
669
|
|
|
|
|
|
|
|
670
|
2
|
|
|
|
|
13
|
my ($f,@F); |
671
|
2
|
100
|
|
|
|
20
|
if( ref $file eq 'IO::File' ) { $file->seek(0,0); @F = <$file>; $f=\@F; } |
|
1
|
|
|
|
|
44
|
|
|
1
|
|
|
|
|
69
|
|
|
1
|
|
|
|
|
5
|
|
672
|
1
|
|
|
|
|
237
|
else { $f = IO::File::new_tmpfile; } |
673
|
2
|
|
|
|
|
25
|
return $f; |
674
|
|
|
|
|
|
|
} |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
678
|
|
|
|
|
|
|
# Return the filenames of a directory as array reference. |
679
|
|
|
|
|
|
|
# Skip '.','..' and all filenames not matching search pattern if a search |
680
|
|
|
|
|
|
|
# pattern is defined. |
681
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
682
|
|
|
|
|
|
|
sub Dir(@) |
683
|
|
|
|
|
|
|
{ |
684
|
7
|
|
|
7
|
0
|
12123
|
my ($dirPath,$searchPattern) = _getParam(@_); |
685
|
|
|
|
|
|
|
|
686
|
7
|
|
|
|
|
75
|
my $d = IO::Dir->new($dirPath); |
687
|
7
|
50
|
|
|
|
695
|
return undef if( !defined $d ); |
688
|
|
|
|
|
|
|
|
689
|
7
|
|
|
|
|
18
|
my @D; |
690
|
7
|
|
|
|
|
31
|
while( defined($_ = $d->read)) |
691
|
|
|
|
|
|
|
{ |
692
|
67
|
100
|
|
|
|
1104
|
next if( _toSkip( $_, $searchPattern )); |
693
|
37
|
|
|
|
|
118
|
push @D, $_; |
694
|
|
|
|
|
|
|
} |
695
|
7
|
|
|
|
|
127
|
@D = sort @D; |
696
|
7
|
|
|
|
|
64
|
return \@D; |
697
|
|
|
|
|
|
|
} |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
700
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
701
|
|
|
|
|
|
|
sub _toSkip($$) |
702
|
|
|
|
|
|
|
{ |
703
|
67
|
|
|
67
|
|
115
|
my ($line,$pattern) = @_; |
704
|
|
|
|
|
|
|
|
705
|
67
|
100
|
|
|
|
189
|
return 1 if( $line =~ /^[.]{1,2}$/ ); |
706
|
53
|
100
|
|
|
|
131
|
return 0 if( !defined $pattern ); |
707
|
|
|
|
|
|
|
|
708
|
22
|
100
|
|
|
|
69
|
if( $pattern =~ /^\s*!/ ) |
709
|
|
|
|
|
|
|
{ |
710
|
4
|
|
|
|
|
20
|
$pattern = substr($pattern, 1 ); |
711
|
4
|
100
|
|
|
|
48
|
return 1 if( $line =~ /$pattern/ ); |
712
|
|
|
|
|
|
|
}else{ |
713
|
18
|
100
|
|
|
|
124
|
return 1 if( $line !~ /$pattern/ ); |
714
|
|
|
|
|
|
|
} |
715
|
|
|
|
|
|
|
} |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
718
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
719
|
|
|
|
|
|
|
sub Usage($$) |
720
|
|
|
|
|
|
|
{ |
721
|
0
|
|
|
0
|
0
|
0
|
my ($self, $add) = @_; |
722
|
|
|
|
|
|
|
|
723
|
0
|
|
|
|
|
0
|
return $self->{'ops'}->usage($add); |
724
|
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
727
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
728
|
|
|
|
|
|
|
sub SetOpt($$$) |
729
|
|
|
|
|
|
|
{ |
730
|
1
|
|
|
1
|
0
|
4
|
my ($self,$opt,$value) = @_; |
731
|
1
|
50
|
|
|
|
5
|
return undef unless defined $self->{'ops'}; |
732
|
1
|
50
|
|
|
|
5
|
return undef unless ref($self->{'ops'}) eq 'Script::Toolbox::Util::Opt'; |
733
|
1
|
|
|
|
|
5
|
my $old = $self->{'ops'}->set($opt,$value); |
734
|
1
|
|
|
|
|
3
|
$self->{$opt} = $value; |
735
|
1
|
|
|
|
|
4
|
return $old; |
736
|
|
|
|
|
|
|
} |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
739
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
740
|
|
|
|
|
|
|
sub _getParam(@) |
741
|
|
|
|
|
|
|
{ |
742
|
|
|
|
|
|
|
#if( isa( $_[0], "Script::Toolbox::Util" )) |
743
|
54
|
|
|
54
|
|
250
|
my $x = ref $_[0]; |
744
|
54
|
100
|
|
|
|
331
|
if( $x =~ /Script::Toolbox/ ) |
745
|
|
|
|
|
|
|
{ |
746
|
26
|
50
|
|
|
|
297
|
shift @_ if( $_[0]->isa("Script::Toolbox::Util" )); |
747
|
|
|
|
|
|
|
} |
748
|
54
|
|
|
|
|
277
|
return @_; |
749
|
|
|
|
|
|
|
} |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
752
|
|
|
|
|
|
|
# Start a shell command with logging. |
753
|
|
|
|
|
|
|
# Return 0 if shell command failed otherwise 1. |
754
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
755
|
|
|
|
|
|
|
sub System($) |
756
|
|
|
|
|
|
|
{ |
757
|
0
|
|
|
0
|
0
|
0
|
my( $cmd ) = _getParam(@_); |
758
|
|
|
|
|
|
|
|
759
|
0
|
|
|
|
|
0
|
my $fh = new IO::File; |
760
|
0
|
|
|
|
|
0
|
my $pid = $fh->open("$cmd ". '2>&1; echo __RC__$? |' ); |
761
|
|
|
|
|
|
|
|
762
|
0
|
|
|
|
|
0
|
my $rc; |
763
|
0
|
|
|
|
|
0
|
while( <$fh> ) |
764
|
|
|
|
|
|
|
{ |
765
|
0
|
|
|
|
|
0
|
chomp; |
766
|
0
|
0
|
|
|
|
0
|
$rc = $_, next if( /^__RC__/ ); |
767
|
0
|
0
|
|
|
|
0
|
next if( /^\s*$/ ); |
768
|
0
|
|
|
|
|
0
|
Log( " $_" ); |
769
|
|
|
|
|
|
|
} |
770
|
|
|
|
|
|
|
|
771
|
0
|
|
|
|
|
0
|
$rc =~ s/__RC__//; |
772
|
|
|
|
|
|
|
|
773
|
0
|
0
|
|
|
|
0
|
return 1 if( $rc == 0 ); |
774
|
0
|
|
|
|
|
0
|
return 0; |
775
|
|
|
|
|
|
|
} |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
778
|
|
|
|
|
|
|
# Compute the difference between NOW[+offset] and the time value given as |
779
|
|
|
|
|
|
|
# second parameter. Return a hash reference holding the difference in seconds, |
780
|
|
|
|
|
|
|
# minutes, hours and days. Every value as a floating point number. |
781
|
|
|
|
|
|
|
# |
782
|
|
|
|
|
|
|
# The referenz time (rtime) may be an epoch value or any string parsable by |
783
|
|
|
|
|
|
|
# Time::ParseDate. |
784
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
785
|
|
|
|
|
|
|
sub _nowDiff($$) |
786
|
|
|
|
|
|
|
{ |
787
|
3
|
|
|
3
|
|
7
|
my ($now,$rtime) = @_; |
788
|
|
|
|
|
|
|
|
789
|
3
|
100
|
|
|
|
20
|
$rtime = parsedate( $rtime ) if( $rtime !~ /^[0-9]+$/ ); |
790
|
|
|
|
|
|
|
|
791
|
3
|
|
|
|
|
1135
|
my $secDiff= $now - $rtime; |
792
|
3
|
|
|
|
|
10
|
my $D = int $secDiff / 86400; my $x = $secDiff % 86400; |
|
3
|
|
|
|
|
7
|
|
793
|
3
|
|
|
|
|
7
|
my $H = int $x / 3600; $x = $x % 3600; |
|
3
|
|
|
|
|
4
|
|
794
|
3
|
|
|
|
|
5
|
my $M = int $x / 60; $x = $x % 60; |
|
3
|
|
|
|
|
7
|
|
795
|
3
|
|
|
|
|
4
|
my $S = $x; |
796
|
|
|
|
|
|
|
|
797
|
3
|
|
|
|
|
5
|
my %R; |
798
|
3
|
|
|
|
|
41
|
$R{seconds}= $secDiff; |
799
|
3
|
|
|
|
|
7
|
$R{minutes}= $R{seconds} / 60.0; |
800
|
3
|
|
|
|
|
7
|
$R{hours} = $R{seconds} / 3600.0; |
801
|
3
|
|
|
|
|
25
|
$R{days} = $R{seconds} / 86400.0; |
802
|
3
|
|
|
|
|
14
|
$R{DHMS} = sprintf "%dd %.2d:%.2d:%.2d", $D,$H,$M,$S; |
803
|
3
|
|
|
|
|
19
|
return \%R; |
804
|
|
|
|
|
|
|
} |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
808
|
|
|
|
|
|
|
# Return the actual date and time. If $format is undef the result is a hash |
809
|
|
|
|
|
|
|
# ref with keys sec,min,hour,mday,mon,year,wday,yday,isdst,epoch. |
810
|
|
|
|
|
|
|
# Mon and year are corrected. Epoch is the time in seconds since 1.1.1970. |
811
|
|
|
|
|
|
|
# If $format is not undef it must be a strftime() format string. The result |
812
|
|
|
|
|
|
|
# of Now() is then the strftime() formated string. |
813
|
|
|
|
|
|
|
# $opt may be {format=><'strftime-format'>, offset=><+-seconds>, diff=> |
814
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
815
|
|
|
|
|
|
|
sub Now(@) |
816
|
|
|
|
|
|
|
{ |
817
|
7
|
|
|
7
|
0
|
5131
|
my( $opt ) = _getParam(@_); |
818
|
|
|
|
|
|
|
|
819
|
7
|
100
|
|
|
|
19
|
my $offset = defined $opt->{offset} ? $opt->{offset}+0 : 0; |
820
|
7
|
|
|
|
|
13
|
my $epoch = time+$offset; |
821
|
|
|
|
|
|
|
|
822
|
7
|
100
|
|
|
|
20
|
return _nowDiff( $epoch, $opt->{diff} ) if( $opt->{diff} ); |
823
|
|
|
|
|
|
|
|
824
|
4
|
|
|
|
|
109
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($epoch); |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
return strftime $opt->{format}, |
827
|
|
|
|
|
|
|
$sec,$min,$hour,$mday,$mon, $year,$wday,$yday,$isdst |
828
|
4
|
100
|
|
|
|
85
|
if( defined $opt->{format} ); |
829
|
|
|
|
|
|
|
|
830
|
2
|
|
|
|
|
4
|
$mon++; |
831
|
2
|
|
|
|
|
5
|
$year+=1900; |
832
|
2
|
|
|
|
|
22
|
return {sec=>$sec,min=>$min,hour=>$hour, mday=>$mday,mon=>$mon,year=>$year, |
833
|
|
|
|
|
|
|
wday=>$wday,yday=>$yday,isdst=>$isdst,epoch=>$epoch}; |
834
|
|
|
|
|
|
|
} |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
837
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
838
|
|
|
|
|
|
|
sub _printMenuHeader($) { |
839
|
0
|
|
|
0
|
|
0
|
my ($head) = @_; |
840
|
0
|
0
|
|
|
|
0
|
return if( ! defined $head ); |
841
|
0
|
|
|
|
|
0
|
printf "%s", $head; |
842
|
|
|
|
|
|
|
} |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
845
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
846
|
|
|
|
|
|
|
sub _printMenuFooter($) { |
847
|
0
|
|
|
0
|
|
0
|
my ($foot) = @_; |
848
|
0
|
0
|
|
|
|
0
|
return if( ! defined $foot ); |
849
|
0
|
|
|
|
|
0
|
printf "%s", $foot; |
850
|
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
|
|
852
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
853
|
|
|
|
|
|
|
# Compute real index if we have NON-Lable lines in the opts-array. |
854
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
855
|
|
|
|
|
|
|
sub _getRealIndex($$) { |
856
|
0
|
|
|
0
|
|
0
|
my ($o, $opts) = @_; |
857
|
|
|
|
|
|
|
|
858
|
0
|
|
|
|
|
0
|
my $real = 0; |
859
|
0
|
|
|
|
|
0
|
my $curr = 0; |
860
|
0
|
|
|
|
|
0
|
foreach my $op ( @{$opts} ) |
|
0
|
|
|
|
|
0
|
|
861
|
|
|
|
|
|
|
{ |
862
|
0
|
0
|
|
|
|
0
|
$real++ if( ! $op->{'label'} ); |
863
|
0
|
0
|
|
|
|
0
|
return $real if( $o == $curr ); |
864
|
0
|
|
|
|
|
0
|
$real++; |
865
|
0
|
|
|
|
|
0
|
$curr++; |
866
|
|
|
|
|
|
|
} |
867
|
0
|
|
|
|
|
0
|
return $real; |
868
|
|
|
|
|
|
|
} |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
871
|
|
|
|
|
|
|
# Concatenate several header/footer options into header/footer strings. |
872
|
|
|
|
|
|
|
# Return original options array-ref and header/footer strings. |
873
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
874
|
|
|
|
|
|
|
sub _normMenuOpts($){ |
875
|
0
|
|
|
0
|
|
0
|
my ($opts) = @_; |
876
|
|
|
|
|
|
|
|
877
|
0
|
|
|
|
|
0
|
my $head = ''; |
878
|
0
|
|
|
|
|
0
|
my $foot = ''; |
879
|
0
|
|
|
|
|
0
|
my @OPTS; |
880
|
0
|
|
|
|
|
0
|
foreach my $l ( @{$opts} ){ |
|
0
|
|
|
|
|
0
|
|
881
|
0
|
0
|
|
|
|
0
|
$head .= sprintf "%s\n", $l->{'header'} if( defined $l->{'header'} ); |
882
|
0
|
0
|
|
|
|
0
|
$foot .= sprintf "%s\n", $l->{'footer'} if( defined $l->{'footer'} ); |
883
|
0
|
0
|
|
|
|
0
|
push @OPTS, $l if( defined $l->{'label'} ); |
884
|
|
|
|
|
|
|
} |
885
|
0
|
0
|
|
|
|
0
|
$head = $head eq '' ? undef : $head; |
886
|
0
|
0
|
|
|
|
0
|
$foot = $foot eq '' ? undef : $foot; |
887
|
|
|
|
|
|
|
|
888
|
0
|
|
|
|
|
0
|
return \@OPTS, $head, $foot; |
889
|
|
|
|
|
|
|
} |
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
892
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
893
|
|
|
|
|
|
|
sub _printOption($$$) { |
894
|
0
|
|
|
0
|
|
0
|
my ($op,$form1,$i) = @_; |
895
|
|
|
|
|
|
|
|
896
|
0
|
|
|
|
|
0
|
my ($def,$form)=_getDefForm($form1,$op); |
897
|
0
|
0
|
|
|
|
0
|
if( defined $def ) { |
898
|
0
|
|
|
|
|
0
|
printf $form, $i,$op->{'label'},$def; |
899
|
0
|
|
|
|
|
0
|
return; |
900
|
|
|
|
|
|
|
} |
901
|
0
|
|
|
|
|
0
|
printf $form, $i,$op->{'label'}; |
902
|
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
904
|
|
|
|
|
|
|
# Display a menu, return the selected index number and the menu data structure. |
905
|
|
|
|
|
|
|
# If a VALUE or DEFAULT key of a menu option points to a value this value can |
906
|
|
|
|
|
|
|
# be changed. |
907
|
|
|
|
|
|
|
# If a jump target is defined, the corresponding function will be called with |
908
|
|
|
|
|
|
|
# argv=> as arguments. |
909
|
|
|
|
|
|
|
# Data structure: [{label=>,value=>,jump=>,argv=>},...] |
910
|
|
|
|
|
|
|
# - label=> must be defined all other keys are optinal |
911
|
|
|
|
|
|
|
# - jump=> must point to a subroutine if set |
912
|
|
|
|
|
|
|
# - argv=> arguments for the subroutine jump points to |
913
|
|
|
|
|
|
|
# - header=> an optional head line |
914
|
|
|
|
|
|
|
# - footer=> an optional footer line |
915
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
916
|
|
|
|
|
|
|
sub Menu($) { |
917
|
0
|
|
|
0
|
0
|
0
|
my ($OPTS) = @_; |
918
|
|
|
|
|
|
|
|
919
|
0
|
|
|
|
|
0
|
my ($opts,$head,$foot) = _normMenuOpts($OPTS); |
920
|
0
|
|
|
|
|
0
|
my ($i,$o) = (0,0); |
921
|
0
|
|
|
|
|
0
|
my $maxLen = _maxLabelLength($opts); |
922
|
0
|
|
|
|
|
0
|
my $form1 = "%3d %-${maxLen}s "; |
923
|
0
|
|
|
|
|
0
|
system("clear"); |
924
|
0
|
|
|
|
|
0
|
_printMenuHeader($head); |
925
|
0
|
|
|
|
|
0
|
($i,$o) = (0,0); |
926
|
0
|
|
|
|
|
0
|
foreach my $op ( @{$opts} ) |
|
0
|
|
|
|
|
0
|
|
927
|
|
|
|
|
|
|
{ |
928
|
0
|
0
|
|
|
|
0
|
next if( ! $op->{'label'} ); |
929
|
0
|
|
|
|
|
0
|
_printOption($op,$form1,$i++); |
930
|
|
|
|
|
|
|
} |
931
|
0
|
|
|
|
|
0
|
_printMenuFooter($foot); |
932
|
0
|
|
|
|
|
0
|
printf "\nSelect: "; |
933
|
0
|
|
|
|
|
0
|
$o = _getNumber( $i-1); |
934
|
0
|
|
|
|
|
0
|
_setValue($o, $opts); |
935
|
0
|
|
|
|
|
0
|
_jump($o, $opts); # jump to callback if defined |
936
|
0
|
|
|
|
|
0
|
return $o,$opts; |
937
|
|
|
|
|
|
|
} |
938
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
939
|
|
|
|
|
|
|
# Deprecated Menu function. Only for compatibility with legacy software. |
940
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
941
|
|
|
|
|
|
|
sub Menue($){ |
942
|
0
|
|
|
0
|
0
|
0
|
return Menu($_[0]); |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
946
|
|
|
|
|
|
|
# Prepare input for Data Menu. Allowed input formats: |
947
|
|
|
|
|
|
|
# INPUT2: [{'label'=>'Max','value'=>'foo'},{'label'=>'Tim','value'=>99}] |
948
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
949
|
|
|
|
|
|
|
sub _arrayHandler($$) { |
950
|
0
|
|
|
0
|
|
0
|
my ($dataMenu,$opts) = @_; |
951
|
|
|
|
|
|
|
|
952
|
0
|
|
|
|
|
0
|
foreach my $line ( @{$opts} ) { |
|
0
|
|
|
|
|
0
|
|
953
|
0
|
0
|
|
|
|
0
|
next if( ref $line ne 'HASH' ); |
954
|
0
|
0
|
|
|
|
0
|
next if( ! defined $line-{'label'} ); |
955
|
0
|
0
|
|
|
|
0
|
next if( ! defined $line-{'value'} ); |
956
|
0
|
|
|
|
|
0
|
push @{$dataMenu}, $line, |
|
0
|
|
|
|
|
0
|
|
957
|
|
|
|
|
|
|
} |
958
|
0
|
|
|
|
|
0
|
return 'ARRAY'; |
959
|
|
|
|
|
|
|
} |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
962
|
|
|
|
|
|
|
# Prepare input for Data Menu. Allowed input formats: |
963
|
|
|
|
|
|
|
# INPUT3: {}[, {'header'=>'','footer'=>''}] |
964
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
965
|
|
|
|
|
|
|
sub _hashHandler($$$) { |
966
|
0
|
|
|
0
|
|
0
|
my ($dataMenu,$opts,$frame) = @_; |
967
|
|
|
|
|
|
|
|
968
|
0
|
|
|
|
|
0
|
foreach my $l ( sort keys %{$opts} ) { |
|
0
|
|
|
|
|
0
|
|
969
|
0
|
0
|
|
|
|
0
|
next if( ref $opts->{$l} ne '' ); |
970
|
0
|
|
|
|
|
0
|
my $line = {'label' => $l, 'value' => $opts->{$l}}; |
971
|
0
|
|
|
|
|
0
|
push @{$dataMenu}, $line, |
|
0
|
|
|
|
|
0
|
|
972
|
|
|
|
|
|
|
} |
973
|
0
|
0
|
|
|
|
0
|
return 'HASH' if( ! defined $frame ); |
974
|
|
|
|
|
|
|
|
975
|
0
|
0
|
|
|
|
0
|
push @{$dataMenu}, {'header' => $frame->{'header'}} if( defined $frame->{'header'}); |
|
0
|
|
|
|
|
0
|
|
976
|
0
|
0
|
|
|
|
0
|
push @{$dataMenu}, {'footer' => $frame->{'footer'}} if( defined $frame->{'footer'}); |
|
0
|
|
|
|
|
0
|
|
977
|
0
|
|
|
|
|
0
|
return 'HASH'; |
978
|
|
|
|
|
|
|
} |
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
982
|
|
|
|
|
|
|
# Prepare input for Data Menu. Allowed input formats: |
983
|
|
|
|
|
|
|
# INPUT1: 'value1 value2 ..'[, {'header'=>'','footer'=>''}] |
984
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
985
|
|
|
|
|
|
|
sub _scalarHandler($$$) { |
986
|
0
|
|
|
0
|
|
0
|
my ($dataMenu,$opts,$frame) = @_; |
987
|
|
|
|
|
|
|
|
988
|
0
|
|
|
|
|
0
|
my $i=1; |
989
|
0
|
|
|
|
|
0
|
foreach my $l ( split /\s+/, $opts ) { |
990
|
0
|
|
|
|
|
0
|
my $line = {'label' => 'V'.$i++, 'value' => $l}; |
991
|
0
|
|
|
|
|
0
|
push @{$dataMenu}, $line, |
|
0
|
|
|
|
|
0
|
|
992
|
|
|
|
|
|
|
} |
993
|
0
|
0
|
|
|
|
0
|
return 'SCALAR' if( ! defined $frame ); |
994
|
0
|
0
|
|
|
|
0
|
push @{$dataMenu}, {'header' => $frame->{'header'}} if( defined $frame->{'header'}); |
|
0
|
|
|
|
|
0
|
|
995
|
0
|
0
|
|
|
|
0
|
push @{$dataMenu}, {'footer' => $frame->{'footer'}} if( defined $frame->{'footer'}); |
|
0
|
|
|
|
|
0
|
|
996
|
0
|
|
|
|
|
0
|
return 'SCALAR'; |
997
|
|
|
|
|
|
|
} |
998
|
|
|
|
|
|
|
|
999
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1000
|
|
|
|
|
|
|
# Prepare input for Data Menu. Allowed input formats: |
1001
|
|
|
|
|
|
|
# INPUT1: 'value1 value2 ..'[, {'header'=>'','footer'=>''}] |
1002
|
|
|
|
|
|
|
# INPUT2: [{'label'=>'Max','value'=>'foo'},{'label'=>'Tim','value'=>99}] |
1003
|
|
|
|
|
|
|
# INPUT3: {}[, {'header'=>'','footer'=>''}] |
1004
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1005
|
|
|
|
|
|
|
sub _addData($$$) |
1006
|
|
|
|
|
|
|
{ |
1007
|
0
|
|
|
0
|
|
0
|
my ($dataMenu,$opts,$frame) = @_; |
1008
|
|
|
|
|
|
|
|
1009
|
0
|
0
|
|
|
|
0
|
return _arrayHandler ($dataMenu,$opts) if(ref $opts eq 'ARRAY'); |
1010
|
0
|
0
|
|
|
|
0
|
return _hashHandler ($dataMenu,$opts,$frame) if(ref $opts eq 'HASH' ); |
1011
|
0
|
0
|
|
|
|
0
|
return _scalarHandler($dataMenu,$opts,$frame) if(ref $opts eq '' ); |
1012
|
|
|
|
|
|
|
} |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1015
|
|
|
|
|
|
|
# Remove {label=>"EXIT"} line. |
1016
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1017
|
|
|
|
|
|
|
sub _returnArray($) { |
1018
|
0
|
|
|
0
|
|
0
|
my ($dataMenu) = @_; |
1019
|
0
|
|
|
|
|
0
|
splice @{$dataMenu},0,1; |
|
0
|
|
|
|
|
0
|
|
1020
|
0
|
|
|
|
|
0
|
return $dataMenu; |
1021
|
|
|
|
|
|
|
} |
1022
|
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1024
|
|
|
|
|
|
|
# Remove {label=>"EXIT"} line. Return values as white space separated string. |
1025
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1026
|
|
|
|
|
|
|
sub _returnScalar($) { |
1027
|
0
|
|
|
0
|
|
0
|
my ($dataMenu) = @_; |
1028
|
|
|
|
|
|
|
|
1029
|
0
|
|
|
|
|
0
|
splice @{$dataMenu},0,1; |
|
0
|
|
|
|
|
0
|
|
1030
|
0
|
|
|
|
|
0
|
my $data=''; |
1031
|
0
|
0
|
|
|
|
0
|
map { $data .= $_->{'value'} .' ' if( defined $_->{'value'})} @{$dataMenu}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1032
|
0
|
|
|
|
|
0
|
chop $data; |
1033
|
0
|
|
|
|
|
0
|
return $data; |
1034
|
|
|
|
|
|
|
} |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1037
|
|
|
|
|
|
|
# Remove {label=>"EXIT"}, header and footer lines. |
1038
|
|
|
|
|
|
|
# Return values as white hash ref with 'label' as key and 'value' as value. |
1039
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1040
|
|
|
|
|
|
|
sub _returnHash($) { |
1041
|
0
|
|
|
0
|
|
0
|
my ($dataMenu) = @_; |
1042
|
|
|
|
|
|
|
|
1043
|
0
|
|
|
|
|
0
|
splice @{$dataMenu},0,1; |
|
0
|
|
|
|
|
0
|
|
1044
|
0
|
|
|
|
|
0
|
my %data; |
1045
|
0
|
0
|
0
|
|
|
0
|
map { if( defined $_->{'value'} && defined $_->{'label'} ){ |
1046
|
0
|
|
|
|
|
0
|
my $k = $_->{'label'}; |
1047
|
0
|
|
|
|
|
0
|
my $v = $_->{'value'}; |
1048
|
0
|
|
|
|
|
0
|
$data{$k} = $v; |
1049
|
|
|
|
|
|
|
} |
1050
|
0
|
|
|
|
|
0
|
} @{$dataMenu}; |
|
0
|
|
|
|
|
0
|
|
1051
|
0
|
|
|
|
|
0
|
return \%data; |
1052
|
|
|
|
|
|
|
} |
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1055
|
|
|
|
|
|
|
# Use Menu to edit small data sets. Two input formats allowed. |
1056
|
|
|
|
|
|
|
# INPUT1: 'value1 value2 ..' |
1057
|
|
|
|
|
|
|
# INPUT2: [{'label'=>'Max','value'=>'foo'},{'label'=>'Tim','value'=>99}] |
1058
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1059
|
|
|
|
|
|
|
sub DataMenu(@) { |
1060
|
0
|
|
|
0
|
0
|
0
|
my ($opts,$head) = @_; |
1061
|
|
|
|
|
|
|
|
1062
|
0
|
|
|
|
|
0
|
my $dataMenu = [{label=>"RETURN"}]; |
1063
|
0
|
|
|
|
|
0
|
my $format = _addData($dataMenu, $opts,$head); |
1064
|
|
|
|
|
|
|
|
1065
|
0
|
|
|
|
|
0
|
while( 1 ) { |
1066
|
0
|
|
|
|
|
0
|
my ($o,$dataMenu) = Menu($dataMenu); |
1067
|
0
|
0
|
|
|
|
0
|
last if( $o == 0 ); |
1068
|
|
|
|
|
|
|
} |
1069
|
0
|
0
|
|
|
|
0
|
return _returnArray ( $dataMenu) if( $format eq 'ARRAY' ); |
1070
|
0
|
0
|
|
|
|
0
|
return _returnScalar($dataMenu) if( $format eq 'SCALAR'); |
1071
|
0
|
0
|
|
|
|
0
|
return _returnHash ($dataMenu) if( $format eq 'HASH' ); |
1072
|
|
|
|
|
|
|
} |
1073
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1074
|
|
|
|
|
|
|
# Deprecated Menu function. Only for compatibility with legacy software. |
1075
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1076
|
|
|
|
|
|
|
sub DataMenue(@){ |
1077
|
0
|
|
|
0
|
0
|
0
|
return DataMenu(@_); |
1078
|
|
|
|
|
|
|
} |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1081
|
|
|
|
|
|
|
# Read a directory and return a hash with filenames stat() structure infos |
1082
|
|
|
|
|
|
|
# for every file. An optional pattern (regexp) may be used for selecting files. |
1083
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1084
|
|
|
|
|
|
|
sub Stat($@) |
1085
|
|
|
|
|
|
|
{ |
1086
|
3
|
|
|
3
|
0
|
4039
|
my ($path,$patt) = _getParam( @_ ); |
1087
|
|
|
|
|
|
|
|
1088
|
3
|
|
|
|
|
9
|
my $dir = Dir($path,$patt); |
1089
|
|
|
|
|
|
|
|
1090
|
3
|
|
|
|
|
96
|
my $stat; |
1091
|
3
|
|
|
|
|
6
|
foreach my $f ( @{$dir} ) |
|
3
|
|
|
|
|
8
|
|
1092
|
|
|
|
|
|
|
{ |
1093
|
28
|
|
|
|
|
345
|
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
1094
|
|
|
|
|
|
|
$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat("$path/$f"); |
1095
|
|
|
|
|
|
|
|
1096
|
28
|
|
|
|
|
136
|
$stat->{$f}{'dev'} = $dev; |
1097
|
28
|
|
|
|
|
51
|
$stat->{$f}{'ino'} = $ino; |
1098
|
28
|
|
|
|
|
45
|
$stat->{$f}{'mode'} = $mode; |
1099
|
28
|
|
|
|
|
44
|
$stat->{$f}{'nlink'}= $nlink; |
1100
|
28
|
|
|
|
|
42
|
$stat->{$f}{'uid'} = $uid; |
1101
|
28
|
|
|
|
|
45
|
$stat->{$f}{'gid'} = $gid; |
1102
|
28
|
|
|
|
|
43
|
$stat->{$f}{'rdev'} = $rdev; |
1103
|
28
|
|
|
|
|
54
|
$stat->{$f}{'size'} = $size; |
1104
|
28
|
|
|
|
|
44
|
$stat->{$f}{'atime'}= $atime; |
1105
|
28
|
|
|
|
|
37
|
$stat->{$f}{'mtime'}= $mtime; |
1106
|
28
|
|
|
|
|
45
|
$stat->{$f}{'ctime'}= $ctime; |
1107
|
28
|
|
|
|
|
48
|
$stat->{$f}{'blksize'} = $blksize; |
1108
|
28
|
|
|
|
|
56
|
$stat->{$f}{'blocks'} = $blocks; |
1109
|
|
|
|
|
|
|
} |
1110
|
3
|
|
|
|
|
32
|
return $stat; |
1111
|
|
|
|
|
|
|
} |
1112
|
|
|
|
|
|
|
|
1113
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1114
|
|
|
|
|
|
|
# Jump to a callback function of a menu option. |
1115
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1116
|
|
|
|
|
|
|
sub _jump($$) |
1117
|
|
|
|
|
|
|
{ |
1118
|
0
|
|
|
0
|
|
|
my ($o,$menu) = @_; |
1119
|
|
|
|
|
|
|
|
1120
|
0
|
0
|
|
|
|
|
return if( !defined $menu->[$o]->{'jump'} ); #option has no callback |
1121
|
|
|
|
|
|
|
|
1122
|
0
|
|
|
|
|
|
my $call = $menu->[$o]->{'jump'}; |
1123
|
0
|
0
|
|
|
|
|
my $args = defined $menu->[$o]->{'argv'} ? $menu->[$o]->{'argv'} : undef; |
1124
|
|
|
|
|
|
|
|
1125
|
0
|
0
|
|
|
|
|
if( ref $call eq 'CODE' ) { return $call->($args) } |
|
0
|
|
|
|
|
|
|
1126
|
0
|
|
|
|
|
|
Log("\nERROR: Can't call function $call(). It's not a code reference."); |
1127
|
0
|
|
|
|
|
|
sleep 5; |
1128
|
|
|
|
|
|
|
} |
1129
|
|
|
|
|
|
|
|
1130
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1131
|
|
|
|
|
|
|
# Compute the maximum length of all labels found in the menu array @{$opts}. |
1132
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1133
|
|
|
|
|
|
|
sub _maxLabelLength($) |
1134
|
|
|
|
|
|
|
{ |
1135
|
0
|
|
|
0
|
|
|
my ($opts) = @_; |
1136
|
0
|
|
|
|
|
|
my $len=0; |
1137
|
0
|
|
|
|
|
|
foreach my $op ( @{$opts} ) |
|
0
|
|
|
|
|
|
|
1138
|
|
|
|
|
|
|
{ |
1139
|
0
|
0
|
|
|
|
|
next if( ! defined $op->{'label'}); |
1140
|
0
|
|
|
|
|
|
my $l = length($op->{'label'}); |
1141
|
0
|
0
|
|
|
|
|
$len = $len < $l ? $l : $len; |
1142
|
|
|
|
|
|
|
} |
1143
|
0
|
|
|
|
|
|
return $len; |
1144
|
|
|
|
|
|
|
} |
1145
|
|
|
|
|
|
|
|
1146
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1147
|
|
|
|
|
|
|
# Compute the default value and the format string. |
1148
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1149
|
|
|
|
|
|
|
sub _getDefForm($$) |
1150
|
|
|
|
|
|
|
{ |
1151
|
0
|
|
|
0
|
|
|
my ($form1,$op) = @_; |
1152
|
|
|
|
|
|
|
|
1153
|
0
|
|
|
|
|
|
my $def; |
1154
|
0
|
0
|
|
|
|
|
$def = $op->{'value'} if( defined $op->{'value'} ); |
1155
|
0
|
|
|
|
|
|
my $form; |
1156
|
0
|
0
|
|
|
|
|
if( $op->{'readOnly'} ) { $form = defined $def ? "$form1 <%s>" : $form1 } |
|
0
|
0
|
|
|
|
|
|
1157
|
0
|
0
|
|
|
|
|
else { $form = defined $def ? "$form1 [%s]" : $form1 } |
1158
|
|
|
|
|
|
|
|
1159
|
0
|
|
|
|
|
|
return $def,"$form\n"; |
1160
|
|
|
|
|
|
|
} |
1161
|
|
|
|
|
|
|
|
1162
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1163
|
|
|
|
|
|
|
# Remove last entered character from input. Move cursor one position backward. |
1164
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1165
|
|
|
|
|
|
|
sub _delLastChar(){ |
1166
|
0
|
|
|
0
|
|
|
printf "%c %c", 0x08, 0x08; # backspace,blank,backspace |
1167
|
|
|
|
|
|
|
} |
1168
|
|
|
|
|
|
|
|
1169
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1170
|
|
|
|
|
|
|
# Print one character to STDOUT without buffering. |
1171
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1172
|
|
|
|
|
|
|
sub _flushChar($){ |
1173
|
0
|
|
|
0
|
|
|
my ($char) = @_; |
1174
|
0
|
|
|
|
|
|
my $old = $|; |
1175
|
0
|
|
|
|
|
|
$| = 1; |
1176
|
0
|
|
|
|
|
|
printf "%s", $char; |
1177
|
0
|
|
|
|
|
|
$| = $old; |
1178
|
0
|
|
|
|
|
|
return; |
1179
|
|
|
|
|
|
|
} |
1180
|
|
|
|
|
|
|
|
1181
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1182
|
|
|
|
|
|
|
# Check if first digit exeeds the range if used on ten-spot position. In this |
1183
|
|
|
|
|
|
|
# case we got a valid number in the range of 0-9. |
1184
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1185
|
|
|
|
|
|
|
sub _unique($$){ |
1186
|
0
|
|
|
0
|
|
|
my ($o,$maxNum) = @_; |
1187
|
0
|
0
|
|
|
|
|
return 1 if( $$o =~ s/^\n$/0/ ); # set default option 0 if we got ENTER |
1188
|
0
|
0
|
|
|
|
|
return 1 if( $$o*10 > $maxNum); |
1189
|
|
|
|
|
|
|
} |
1190
|
|
|
|
|
|
|
|
1191
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1192
|
|
|
|
|
|
|
# Check if first digit is in range. \n is valid for special handling later. |
1193
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1194
|
|
|
|
|
|
|
sub _invalid($$){ |
1195
|
0
|
|
|
0
|
|
|
my ($o,$maxNum) = @_; |
1196
|
0
|
0
|
|
|
|
|
return 0 if( $o =~ /^\n$/ ); |
1197
|
0
|
0
|
|
|
|
|
return 0 if( $o <= $maxNum); |
1198
|
0
|
|
|
|
|
|
return 1; |
1199
|
|
|
|
|
|
|
} |
1200
|
|
|
|
|
|
|
|
1201
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1202
|
|
|
|
|
|
|
# Read the next number from STDIN. Return 0 if given character is not a digit. |
1203
|
|
|
|
|
|
|
# Read two characters if max option number is greater than 9. |
1204
|
|
|
|
|
|
|
# Valid option numbers are 0...99. |
1205
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1206
|
|
|
|
|
|
|
sub _getNumber($) { |
1207
|
0
|
|
|
0
|
|
|
my ($maxNum) = @_; |
1208
|
|
|
|
|
|
|
|
1209
|
0
|
|
|
|
|
|
my $o; |
1210
|
0
|
|
|
|
|
|
while( 1 ) { |
1211
|
0
|
|
|
|
|
|
$o=_getChar('^\d+$'); |
1212
|
0
|
0
|
|
|
|
|
next if( _invalid($o,$maxNum) ); |
1213
|
0
|
0
|
|
|
|
|
last if( _unique(\$o,$maxNum) ); |
1214
|
|
|
|
|
|
|
|
1215
|
0
|
0
|
|
|
|
|
if( $maxNum > 9 ) { |
1216
|
0
|
|
|
|
|
|
_flushChar($o); |
1217
|
0
|
|
|
|
|
|
my $oo=_getChar('^\d+$'); |
1218
|
0
|
0
|
|
|
|
|
last if( $oo eq "\n" ); |
1219
|
0
|
|
|
|
|
|
$o=10*$o+$oo; |
1220
|
|
|
|
|
|
|
} |
1221
|
0
|
0
|
0
|
|
|
|
last if( $o <= $maxNum && $o > -1 ); |
1222
|
0
|
|
|
|
|
|
_delLastChar(); |
1223
|
|
|
|
|
|
|
} |
1224
|
0
|
|
|
|
|
|
_delLastChar(); |
1225
|
0
|
|
|
|
|
|
_flushChar($o); |
1226
|
0
|
|
|
|
|
|
return $o; |
1227
|
|
|
|
|
|
|
} |
1228
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1229
|
|
|
|
|
|
|
# Read one character from STDIN. FIXME: stty method is not portable |
1230
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1231
|
|
|
|
|
|
|
sub _getChar($) |
1232
|
|
|
|
|
|
|
{ |
1233
|
0
|
|
|
0
|
|
|
my ($patt) = @_; |
1234
|
|
|
|
|
|
|
|
1235
|
0
|
|
|
|
|
|
while( 1 ) { |
1236
|
0
|
|
|
|
|
|
system "stty", '-echo', '-icanon', 'eol', "\001"; |
1237
|
0
|
|
|
|
|
|
my $key = getc(STDIN); |
1238
|
0
|
|
|
|
|
|
system "stty", 'echo', 'icanon', 'eol', '^@'; # ASCII null |
1239
|
0
|
0
|
|
|
|
|
return $key if( $key =~ /$patt/ ); |
1240
|
0
|
0
|
|
|
|
|
return $key if( $key =~ /\n/ ); # use default |
1241
|
|
|
|
|
|
|
} |
1242
|
|
|
|
|
|
|
} |
1243
|
|
|
|
|
|
|
|
1244
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1245
|
|
|
|
|
|
|
# Read a line from STDIN and assign it to the "value" key of an menu option. |
1246
|
|
|
|
|
|
|
# Data structure: [{label=>,value=>,readOnly=>,jump=>,argv=>},...] |
1247
|
|
|
|
|
|
|
# After this function value=> has one of the following values: |
1248
|
|
|
|
|
|
|
# - the read line if not empty |
1249
|
|
|
|
|
|
|
# - the old value if read an empty line and an old value exists |
1250
|
|
|
|
|
|
|
# - the value is not changeable if the key readOnly is defined |
1251
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1252
|
|
|
|
|
|
|
sub _setValue($) |
1253
|
|
|
|
|
|
|
{ |
1254
|
0
|
|
|
0
|
|
|
my ($o,$opts) = @_; |
1255
|
|
|
|
|
|
|
|
1256
|
0
|
0
|
|
|
|
|
return undef if( !defined $opts->[$o]{'value'} ); |
1257
|
|
|
|
|
|
|
|
1258
|
0
|
|
|
|
|
|
my $op = $opts->[$o]; |
1259
|
0
|
0
|
|
|
|
|
my $def = defined $op->{'value'} ? $op->{'value'} : ''; |
1260
|
|
|
|
|
|
|
|
1261
|
0
|
0
|
|
|
|
|
return $def if( $op->{'readOnly'} ); |
1262
|
0
|
|
|
|
|
|
printf "\n%s [%s]:", $op->{'label'}, $def; |
1263
|
|
|
|
|
|
|
|
1264
|
0
|
|
|
|
|
|
my $resp = ; |
1265
|
0
|
|
|
|
|
|
chomp $resp; |
1266
|
|
|
|
|
|
|
|
1267
|
0
|
0
|
|
|
|
|
$resp = $def if( $resp eq '' ); |
1268
|
0
|
0
|
0
|
|
|
|
$resp = $op->{'default'} if( defined $op->{'default'} && $resp eq ' ' ); |
1269
|
0
|
|
|
|
|
|
$op->{'value'} = $resp; |
1270
|
0
|
|
|
|
|
|
return $resp; |
1271
|
|
|
|
|
|
|
} |
1272
|
|
|
|
|
|
|
|
1273
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1274
|
|
|
|
|
|
|
# Return the options as array reference. |
1275
|
|
|
|
|
|
|
# If $opt is not already an array reference, it mut be a string like: |
1276
|
|
|
|
|
|
|
# '...' |
1277
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1278
|
|
|
|
|
|
|
sub _checkOptions($){ |
1279
|
0
|
|
|
0
|
|
|
my ($opt) = @_; |
1280
|
|
|
|
|
|
|
|
1281
|
0
|
0
|
|
|
|
|
return $opt if( ref $opt eq 'ARRAY'); |
1282
|
0
|
|
|
|
|
|
my ($sep,$opstr) = $opt =~ m/(.)(.*)/; |
1283
|
0
|
|
|
|
|
|
my @Ops = split /[$sep]/, $opstr; |
1284
|
0
|
|
|
|
|
|
return \@Ops; |
1285
|
|
|
|
|
|
|
} |
1286
|
|
|
|
|
|
|
|
1287
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1288
|
|
|
|
|
|
|
# Add given $options as read only menu options to the menu with name $menuName |
1289
|
|
|
|
|
|
|
# in menu-container $m. |
1290
|
|
|
|
|
|
|
# $options: an array reference |
1291
|
|
|
|
|
|
|
# or a CSV like string (first character is the separator). |
1292
|
|
|
|
|
|
|
# Such as: ',opt1,opt2,opt3' |
1293
|
|
|
|
|
|
|
# $defaults: a regular expression. If it matches against an option, this |
1294
|
|
|
|
|
|
|
# option gets into selected state. |
1295
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1296
|
|
|
|
|
|
|
sub _ops2CheckBox($$$$){ |
1297
|
0
|
|
|
0
|
|
|
my ($m,$menuName,$options,$defaults) = @_; |
1298
|
|
|
|
|
|
|
|
1299
|
0
|
|
|
|
|
|
$options = _checkOptions($options); |
1300
|
0
|
|
|
|
|
|
foreach my $x (@{$options}) { |
|
0
|
|
|
|
|
|
|
1301
|
0
|
|
|
|
|
|
my $v = ''; |
1302
|
0
|
0
|
|
|
|
|
$v = $x =~ /$defaults/ ? 'x' : '' if(defined $defaults); |
|
|
0
|
|
|
|
|
|
1303
|
0
|
|
|
|
|
|
$m->addOption($menuName =>{'label'=>$x, 'value'=>$v, 'readOnly'=>1}); |
1304
|
|
|
|
|
|
|
} |
1305
|
0
|
|
|
|
|
|
return; |
1306
|
|
|
|
|
|
|
} |
1307
|
|
|
|
|
|
|
|
1308
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1309
|
|
|
|
|
|
|
# Add the check box menu to the menus container $m. |
1310
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1311
|
|
|
|
|
|
|
sub _ckeckBox2Container($$$){ |
1312
|
0
|
|
|
0
|
|
|
my ($m,$menuName,$header) = @_; |
1313
|
|
|
|
|
|
|
|
1314
|
0
|
|
|
|
|
|
$m->addMenu( {$menuName =>[{'header'=>$header}]}); |
1315
|
0
|
|
|
|
|
|
return; |
1316
|
|
|
|
|
|
|
} |
1317
|
|
|
|
|
|
|
|
1318
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1319
|
|
|
|
|
|
|
# Return the menuname if defined or a random number between 0 and 10000. |
1320
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1321
|
|
|
|
|
|
|
sub _checkMenuName($){ |
1322
|
0
|
|
|
0
|
|
|
my ($name) = @_; |
1323
|
|
|
|
|
|
|
|
1324
|
0
|
0
|
|
|
|
|
return $name if( defined $name ); |
1325
|
0
|
|
|
|
|
|
return sprintf "TMP_%d", int(rand(10000)); |
1326
|
|
|
|
|
|
|
} |
1327
|
|
|
|
|
|
|
|
1328
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1329
|
|
|
|
|
|
|
# Is $m pointing to a menus container? If yes, do nothig otherwise return |
1330
|
|
|
|
|
|
|
# an empty menus container. |
1331
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1332
|
|
|
|
|
|
|
sub _checkMenuContainer($){ |
1333
|
0
|
|
|
0
|
|
|
my ($m) = @_; |
1334
|
0
|
0
|
|
|
|
|
return $m if( ref $m eq 'Script::Toolbox::Util::Menus' ); |
1335
|
0
|
|
|
|
|
|
return Script::Toolbox::Util::Menus->new(); |
1336
|
|
|
|
|
|
|
} |
1337
|
|
|
|
|
|
|
|
1338
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1339
|
|
|
|
|
|
|
# Return the labels of all selected and unselected options. |
1340
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1341
|
|
|
|
|
|
|
sub _getOptStates($$){ |
1342
|
0
|
|
|
0
|
|
|
my ($m,$name) = @_; |
1343
|
|
|
|
|
|
|
|
1344
|
0
|
|
|
|
|
|
my $on = $m->getMatching($name,'.+','value','label'); |
1345
|
0
|
|
|
|
|
|
my $off= $m->getMatching($name,'^$','value','label'); |
1346
|
0
|
|
|
|
|
|
return {'on'=>$on,'off'=>$off}; |
1347
|
|
|
|
|
|
|
} |
1348
|
|
|
|
|
|
|
|
1349
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1350
|
|
|
|
|
|
|
# Clear all option values of menu $menuName in container $m. |
1351
|
|
|
|
|
|
|
# Set the option with $label in selected state. |
1352
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1353
|
|
|
|
|
|
|
sub _setRadioButton($$$){ |
1354
|
0
|
|
|
0
|
|
|
my ($m,$menuName,$label) = @_; |
1355
|
|
|
|
|
|
|
|
1356
|
0
|
|
|
|
|
|
my $lv = $m->getLabelValueHash($menuName); |
1357
|
0
|
|
|
|
|
|
map { $lv->{$_} = '' } keys %{$lv}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1358
|
0
|
|
|
|
|
|
$lv->{$label} = 'x'; |
1359
|
0
|
|
|
|
|
|
$m->setValues($menuName,$lv); |
1360
|
0
|
|
|
|
|
|
return; |
1361
|
|
|
|
|
|
|
} |
1362
|
|
|
|
|
|
|
|
1363
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1364
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1365
|
|
|
|
|
|
|
sub _isOneSelected($$){ |
1366
|
0
|
|
|
0
|
|
|
my ($m,$name) = @_; |
1367
|
|
|
|
|
|
|
|
1368
|
0
|
|
|
|
|
|
my $l = $m->getMatching($name,'^[^\s]+$','value','number'); |
1369
|
|
|
|
|
|
|
|
1370
|
0
|
0
|
|
|
|
|
return 1 if( @{$l} > 0); |
|
0
|
|
|
|
|
|
|
1371
|
0
|
|
|
|
|
|
return 0; |
1372
|
|
|
|
|
|
|
} |
1373
|
|
|
|
|
|
|
|
1374
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1375
|
|
|
|
|
|
|
# Set all option value to of-state except for the selected. |
1376
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1377
|
|
|
|
|
|
|
sub _radioButton($$){ |
1378
|
0
|
|
|
0
|
|
|
my ($m,$name) = @_; |
1379
|
|
|
|
|
|
|
|
1380
|
0
|
|
|
|
|
|
while(1) { |
1381
|
0
|
|
|
|
|
|
my $op = $m->run($name,1); |
1382
|
0
|
|
|
|
|
|
my $cl = $m->currLabel($name); |
1383
|
0
|
0
|
0
|
|
|
|
last if( $cl eq 'RETURN' && _isOneSelected($m,$name)); |
1384
|
0
|
|
|
|
|
|
_setRadioButton($m,$name,$cl); |
1385
|
|
|
|
|
|
|
} |
1386
|
0
|
|
|
|
|
|
return; |
1387
|
|
|
|
|
|
|
} |
1388
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1389
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1390
|
|
|
|
|
|
|
sub _cleanUpTmps($){ |
1391
|
0
|
|
|
0
|
|
|
my ($m) = @_; |
1392
|
|
|
|
|
|
|
|
1393
|
0
|
|
|
|
|
|
my $def = $m->{'def'}; |
1394
|
0
|
|
|
|
|
|
foreach my $x (sort keys %{$def}) { |
|
0
|
|
|
|
|
|
|
1395
|
0
|
0
|
|
|
|
|
next if( $x !~ /^TMP_[0-9]+/ ); |
1396
|
0
|
|
|
|
|
|
delete $m->{'def'}{$x}; |
1397
|
|
|
|
|
|
|
} |
1398
|
0
|
|
|
|
|
|
return; |
1399
|
|
|
|
|
|
|
} |
1400
|
|
|
|
|
|
|
|
1401
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1402
|
|
|
|
|
|
|
# If no radio button checkbox accept all default patterns. |
1403
|
|
|
|
|
|
|
# If it's a radio button checkbox accept only the first pattern (asume |
1404
|
|
|
|
|
|
|
# we have patterns like 'a|b|c'). Otherwise clear all defaults. |
1405
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1406
|
|
|
|
|
|
|
sub _checkDefaults($$$){ |
1407
|
0
|
|
|
0
|
|
|
my ($m,$menuName,$defaults) = @_; |
1408
|
|
|
|
|
|
|
|
1409
|
0
|
|
|
|
|
|
my @x = split /[|]/, $defaults; |
1410
|
0
|
|
|
|
|
|
_setRadioButton($m,$menuName,$x[0]); |
1411
|
|
|
|
|
|
|
} |
1412
|
|
|
|
|
|
|
|
1413
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1414
|
|
|
|
|
|
|
# Grep options array for defaults regex. Return first match if one. Otherwise |
1415
|
|
|
|
|
|
|
# return first label in $options. |
1416
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1417
|
|
|
|
|
|
|
sub getDefaultLabel($$){ |
1418
|
0
|
|
|
0
|
0
|
|
my ($options,$defaults) = @_; |
1419
|
|
|
|
|
|
|
|
1420
|
0
|
0
|
|
|
|
|
if( ref $options eq 'ARRAY' ) { |
1421
|
0
|
|
|
|
|
|
my @label = grep(/$defaults/,@{$options}); |
|
0
|
|
|
|
|
|
|
1422
|
|
|
|
|
|
|
|
1423
|
0
|
0
|
|
|
|
|
return $label[0] if( @label +0 ); |
1424
|
0
|
|
|
|
|
|
return $options->[0]; |
1425
|
|
|
|
|
|
|
} |
1426
|
0
|
|
|
|
|
|
return $defaults; |
1427
|
|
|
|
|
|
|
} |
1428
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1429
|
|
|
|
|
|
|
# Display some options via menu. |
1430
|
|
|
|
|
|
|
# defaults (like me|dk|ek) are preselected |
1431
|
|
|
|
|
|
|
# Return a hash with two keys 'on' and 'off'. These keys points to arrays |
1432
|
|
|
|
|
|
|
# with option labels. 'on' means the value of this option is not an empty |
1433
|
|
|
|
|
|
|
# string. |
1434
|
|
|
|
|
|
|
# Radio flag switches to radio button mode. |
1435
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1436
|
|
|
|
|
|
|
sub _CheckBox($$@){ |
1437
|
0
|
|
|
0
|
|
|
my ($header,$options,$defaults,$radio,$m,$menuName) = @_; |
1438
|
|
|
|
|
|
|
|
1439
|
0
|
|
|
|
|
|
$menuName = _checkMenuName($menuName); |
1440
|
0
|
|
|
|
|
|
$m = _checkMenuContainer($m); |
1441
|
0
|
0
|
|
|
|
|
if( ! defined $m->{'def'}{$menuName} ) { |
1442
|
0
|
|
|
|
|
|
_ckeckBox2Container($m,$menuName,$header); |
1443
|
0
|
|
|
|
|
|
_ops2CheckBox($m,$menuName,$options,$defaults); |
1444
|
|
|
|
|
|
|
} |
1445
|
0
|
|
|
|
|
|
my $defaultLabel = getDefaultLabel($options,$defaults); |
1446
|
0
|
0
|
|
|
|
|
_checkDefaults($m, $menuName, $defaultLabel) if($radio); |
1447
|
0
|
|
|
|
|
|
$m->setHeader($menuName,$header); |
1448
|
0
|
0
|
|
|
|
|
if($radio) { _radioButton($m,$menuName) } |
|
0
|
|
|
|
|
|
|
1449
|
0
|
|
|
|
|
|
else { $m->run($menuName,0) } |
1450
|
|
|
|
|
|
|
|
1451
|
0
|
|
|
|
|
|
my $ret = _getOptStates($m,$menuName); #{selected,unselected} |
1452
|
0
|
|
|
|
|
|
_cleanUpTmps($m); |
1453
|
0
|
|
|
|
|
|
return $ret; |
1454
|
|
|
|
|
|
|
} |
1455
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1456
|
|
|
|
|
|
|
# Multiple selections possible. |
1457
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1458
|
|
|
|
|
|
|
sub CheckBox($$@){ |
1459
|
0
|
|
|
0
|
0
|
|
my ($header,$options,$defaults,$m,$menuName) = @_; |
1460
|
|
|
|
|
|
|
|
1461
|
0
|
|
|
|
|
|
return( _CheckBox($header,$options,$defaults,0,$m,$menuName)); |
1462
|
|
|
|
|
|
|
} |
1463
|
|
|
|
|
|
|
|
1464
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1465
|
|
|
|
|
|
|
# Only one option may and must be selected. |
1466
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1467
|
|
|
|
|
|
|
sub RadioButton($$@){ |
1468
|
0
|
|
|
0
|
0
|
|
my ($header,$options,$defaults,$m,$menuName) = @_; |
1469
|
|
|
|
|
|
|
|
1470
|
0
|
|
|
|
|
|
return( _CheckBox($header,$options,$defaults,1,$m,$menuName)); |
1471
|
|
|
|
|
|
|
} |
1472
|
|
|
|
|
|
|
|
1473
|
|
|
|
|
|
|
1; |
1474
|
|
|
|
|
|
|
__END__ |