File Coverage

blib/lib/Script/Toolbox/Util.pm
Criterion Covered Total %
statement 263 673 39.0
branch 76 296 25.6
condition 12 40 30.0
subroutine 41 99 41.4
pod 0 24 0.0
total 392 1132 34.6


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__