package Script::Toolbox::Util;
use 5.006;
use strict;
use Script::Toolbox::Util::Opt;
use Script::Toolbox::Util::Formatter;
use IO::File;
use IO::Dir;
use Data::Dumper;
use Fatal qw(open close);
use POSIX qw(strftime);
use Time::ParseDate;
require Exporter;
our @ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
# This allows declaration use Script::Toolbox::Util ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(Open Log Exit Table Usage Dir File System Now Menue KeyMap Stat TmpFile DataMenue) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
);
our $VERSION = '0.47';
# Preloaded methods go here.
sub _getKV(@);
sub _getCSV(@);
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub new
{
my $classname = shift;
my $optDef = shift; # options definition
my $self = {};
bless( $self, $classname );
@Script::Toolbox::Util::caller = caller();
$self->_init( $optDef, \@Script::Toolbox::Util::caller, @_ );
return $self;
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _init($)
{
my ($self,$ops,$caller,$args) = @_;
my $log = $caller->[1];
$log =~ s|^.*/||;
$log =~ s/[.].*$//;
$Script::Toolbox::Util{'_logFH'} = undef; # use default STDERR
# Install signal handler
$self->_installSigHandlers();
# install options
$self->_installOps( $ops );
Exit( 1, "Invalid option definition, 'opsDef' => {} invalid." )
if( defined $ops && !defined $self->{'ops'});
# init log file
my $logdir = $self->GetOpt('logdir');
if( defined $logdir )
{
system( "mkdir -p $logdir" );
$Script::Toolbox::Util{'_logFH'} = Open( ">> $logdir/$log.log" );
$Script::Toolbox::Util{'_logFH'}->autoflush();
}
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _installOps($)
{
my ($self, $opsDef) = @_;
$self->{'ops'} = Script::Toolbox::Util::Opt->new( $opsDef, \@Script::Toolbox::Util::caller );
return if( !defined $self->{'ops'} );
foreach my $key ( keys %{$self->{'ops'}} )
{
if( defined $self->{$key} )
{
print STDERR "Script::Toolbox internal error. ";
print STDERR "Can't use command line option $key (internal used)\n";
next;
}
$self->{$key} = $self->{'ops'}->get($key);
}
return;
}
#------------------------------------------------------------------------------
# Signal handler.
#------------------------------------------------------------------------------
sub _sigExit($)
{
my ($sig) = @_;
Exit( 1, "program aborted by signal SIG$sig." );
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _installSigHandlers()
{
my ($self) = @_;
$SIG{'INT'} = \&_sigExit;
$SIG{'HUP'} = \&_sigExit;
$SIG{'QUIT'}= \&_sigExit;
$SIG{'TERM'}= \&_sigExit;
}
#------------------------------------------------------------------------------
# Log a message and exit the programm with the given error code.
#------------------------------------------------------------------------------
sub Exit($$)
{
my ($exitCode, $message) = _getParam(@_);
Log( $message );
exit $exitCode;
}
#------------------------------------------------------------------------------
# Write 'die' messages via Log().
#------------------------------------------------------------------------------
sub _dieHook
{
die @_ if $^S;
my @y = split /\n/, $_[0];
map { Log( $_ ); } @y;
};
$main::SIG{'__DIE__'} = \&_dieHook; # install die hook
#------------------------------------------------------------------------------
# Write a log message with time stamp to a channel.
# $severity, $logtag only required for syslog.
#------------------------------------------------------------------------------
sub Log(@)
{
my ($message, $canal, $severity, $logtag) = _getParam(@_);
my $prog = $0;
$prog =~ s|^.*/||;
my $msg = sprintf "%s: %s: %s\n", $prog, scalar localtime(), $message;
my $fh;
my $can = *STDERR;
if ( !defined $canal )
{
if( defined $Script::Toolbox::Util{'_logFH'}) { $can = $Script::Toolbox::Util{'_logFH'}; }
}else{
# canel is defined here
if ( ref($canal) eq 'IO::File' ){ $can = $canal; }
elsif ( $canal eq 'STDERR') { $can = *STDERR; }
elsif ( $canal eq 'STDOUT') { $can = *STDOUT; }
elsif ( $canal eq 'syslog') { $can = new IO::File "| logger -p '$severity' -t '$logtag'"; }
else { $can = _openFromString($canal); }
}
print $can $msg;
return $msg;
}
#------------------------------------------------------------------------------
# We got a string like "/tmp/x", ">> /tmp/x" or "| someProgram".
# Try to open it as a log canal. If it fails open STDERR instead.
#------------------------------------------------------------------------------
sub _openFromString($)
{
my ($canal) = @_;
if( $canal !~ /^\s*>/ && $canal !~ /^\s*[|]/ ) { $canal = '>>' . $canal; }
my $can;
my $fh = new IO::File "$canal";
if( !defined $fh )
{
$can = *STDERR;
printf $can "%s: %s: %s %s\n",
$0, scalar localtime(), "WARNING: can't write to", $canal;
}else{
$can = $fh;
}
return $can;
}
#------------------------------------------------------------------------------
# Open a file via IO::File with Fatal handling
#------------------------------------------------------------------------------
sub Open(@)
{
my ($file, $iolayer) = _getParam(@_);
my $fh = new IO::File;
$fh->open( "$file" );
#$fh->open( "$file" ) || return undef;
return $fh;
}
use Fatal qw(IO::File::open);
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub Table(@)
{
my ($self, $param, $separator) = @_;
return undef if( _noData( $param ) );
my $para = $self->_normParam($param, $separator);
my $form = Script::Toolbox::Util::Formatter->new( $para );
my $result= $form->matrix();
return $result if( ref $param eq 'ARRAY' || !defined $param->{'sumCols'} );
return $form->sumBy($result, $param->{'sumCols'}, $param->{'notGroupBy'});
}
#------------------------------------------------------------------------------
# $param must be a hash reference. This Hash must have a key "data".
# This key may point to:
# arrayref
# hashref
#------------------------------------------------------------------------------
sub _noData($)
{
my ($param) = @_;
return 0 if( ref $param ne 'HASH' );
return 0 if( ref $param->{'data'} eq 'HASH' );
return 0 if( ref $param->{'data'} eq 'ARRAY');
if( !defined $param->{'data'}[0] )
{
Log( "WARNING: no input data for Table()." );
return 1;
}
return 0;
}
#------------------------------------------------------------------------------
# Valid Calls:
# [ "csvString", "csvString",...], undef
# [ "csvString", "csvString",...], separatorString
# [ "TitelString", [headArray], [dataArray],...], undef
# [ [dataArray],...], undef
# {title=>"", head=>[], data=>[[],[],...] }, undef
# {title=>"", head=>[], data=>[{},{},...] }, undef
# {title=>"", head=>[], data=>{r1=>{c1=>,c2=>,},r2=>{c1=>,c2=>,},}, undef
#------------------------------------------------------------------------------
sub _normParam($$)
{
my ($self, $param, $separator) = @_;
if( ref $param eq 'HASH' )
{
# keine Ahnung wozu: return _sepHash($param, $separator) if( _isCSV($param->{'data'}) );
return $param;
}
return _sepTitleHead($param) if( _isTitleHead($param) );
return _sepCSV($param, $separator) if( _isCSV($param, $separator) );
return { 'data' => $param };
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _sepHash($$)
{
my ($param,$separator) = @_;
my $d = _sepCSV($param->{'data'}, $separator);
$param->{'data'} = $d->{'data'};
return $param;
}
# ------------------------------------------------------------------------------
# Check if we found the special data array format.
# ["TitleString", [headString,headString,...],[data,...],...]
#------------------------------------------------------------------------------
sub _isTitleHead($)
{
my ($param) = @_;
return 1 if( ref \$param->[0] eq 'SCALAR' && ref $param->[1] eq 'ARRAY' );
return 0;
}
#------------------------------------------------------------------------------
# Transform the special data array
# ["TitleString", [headString,headString,...],[data,...],...]
# into hash format.
#------------------------------------------------------------------------------
sub _sepTitleHead($)
{
my ($param) = @_;
my $title= splice @{$param}, 0,1;
my $head = splice @{$param}, 0,1;
return {
'title' => $title,
'head' => $head,
'data' => $param
};
}
#------------------------------------------------------------------------------
# [[],[],...]
# [{},{},...]
# {r1=>{c1=>,c2=>,},r2=>{c1=>,c2=>,},}
#------------------------------------------------------------------------------
sub _isCSV($$)
{
my ($param, $separator) = @_;
return 0 if( ref $param ne 'ARRAY' );
$separator = ';' unless defined $separator; #FIXME default sep
return 1 if( $param->[0] =~ /$separator/ ); #assume it's a CSV record
return 0;
}
#------------------------------------------------------------------------------
# Convert an array of CSV strings into an array of arrays.
#
# [ "a;b","c,d"] becomes
# [[a,b], [c,d]]
#------------------------------------------------------------------------------
sub _sepCSV($$)
{
my ($param, $separator) = @_;
$separator = ';' if( !defined $separator);
my @R;
foreach my $l ( @{$param} )
{
my @r = split /$separator/, $l;
push @R, \@r;
}
return { 'data' => \@R };
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub SetOpsDef($)
{
my ($self,$opsDef) = @_;
my $old = $self->{'ops'};
$self->{'ops'} = Script::Toolbox::Util::Opt->new( $opsDef );
return ($self->{'ops'}, $old);
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub GetOpt($)
{
my ($self,$opt) = @_;
return undef if( ! defined $self->{'ops'} );
return $self->{'ops'}->get($opt);
}
#------------------------------------------------------------------------------
# Read the entire file into an array or write the new content to the file.
# File can be a file name or an IO::File handle.
# Newcontent may be a SCALAR value, an ARRAY reference, a HASH reference or
# a reference to a callback function.
#------------------------------------------------------------------------------
sub File(@)
{
my ($filename,$newContent,$recSep,$fieldSep) = _getParam(@_);
if( !defined $newContent) { return _ReadFile($filename); }
elsif( ref $newContent eq 'CODE'){ return _ReadFile($filename,$newContent);}
else { _WriteFile($filename,$newContent,$recSep,$fieldSep); }
}
#------------------------------------------------------------------------------
# Read the entire file into a hash or write the new content to the file.
# File can be a file name or an IO::File handle.
# Newcontent may be a reference to a keyMap HASH or a reference to a callback
# function.
# The Hash looks like:
# keyA1 => keyB1 ... =>keyN1 => value1
# keyA2 => keyB2 ... =>keyN2 => value2
#------------------------------------------------------------------------------
sub KeyMap(@)
{
my ($filename,$fieldSep,$newContent) = _getParam(@_);
if( !defined $newContent)
{ return _ReadKeyMap($filename, $fieldSep); }
elsif( ref $newContent eq 'CODE' )
{ return _ReadKeyMap($filename, $fieldSep, $newContent); }
else { _WriteKeyMap($filename,$fieldSep,$newContent); }
}
#------------------------------------------------------------------------------
# The Hash looks like:
# keyA1 => keyB1 ... =>keyN1 => value1
# keyA2 => keyB2 ... =>keyN2 => value2
#------------------------------------------------------------------------------
sub _WriteKeyMap($$$)
{
my ($filename,$fieldSep,$newContent) = @_;
$fieldSep = ',' if( !defined $fieldSep );
my $TXT = '';
_getCSV( \$TXT, '', $newContent, $fieldSep );
File( "> $filename", $TXT );
}
#------------------------------------------------------------------------------
# Write a KeyMap (HASH) to a file.
#
# The Hash looks like:
# keyA1 => keyB1 ... =>keyN1 => value1
# keyA2 => keyB2 ... =>keyN2 => value2
#------------------------------------------------------------------------------
sub _getCSV(@)
{
my ($txt, $prev, $newContent,$fieldSep) = @_;
my $prefix = '';
foreach my $k ( sort keys %{$newContent} )
{
$$txt .= $prefix .$k . $fieldSep;
if( ref $newContent->{$k} ne 'HASH' )
{
$$txt .= $newContent->{$k} . "\n";
$prefix = $prev;
next;
}
_getCSV($txt, "$prev$k$fieldSep", $newContent->{$k}, $fieldSep);
}
}
#------------------------------------------------------------------------------
#
#------------------------------------------------------------------------------
sub _checkParam($$)
{
my ( $fieldSep, $callBack) = @_;
my $def=',';
$$fieldSep = $def if( !defined $$fieldSep );
my ( $fs, $cb ) = ( $$fieldSep, $$callBack);
my $rfs = ref $fs; my $rcb = ref $cb;
my $scalar_code = ref $fs eq '' && ref $cb eq 'CODE';
my $scalar_undef= ref $fs eq '' && !defined $cb;
my $code_scalar = ref $fs eq 'CODE' && ref $cb eq '' && defined $cb;
my $code_undef = ref $fs eq 'CODE' && !defined $cb;
if ( $scalar_code ){return;}
elsif( $scalar_undef){return;}
elsif( $code_scalar ){$$fieldSep = $cb; $$callBack = $fs;}
elsif( $code_undef ){$$fieldSep = $def;$$callBack = $fs;}
else { $$fieldSep = $def; $$callBack = undef;}
}
#------------------------------------------------------------------------------
# Read a CSV file into a hash. The lines of the CSV files are "\n" separated.
# Default field separator is ",".
# The Hash looks like:
# keyA1 => keyB1 ... =>keyN1 => value1
# keyA2 => keyB2 ... =>keyN2 => value2
#------------------------------------------------------------------------------
sub _ReadKeyMap($$$)
{
my ($file, $fieldSep, $callBack) = @_;
_checkParam(\$fieldSep, \$callBack);
my $f;
if( defined $callBack ) { $f = File( $file,$callBack, $fieldSep ); }
else { $f = File( $file ); }
chomp( @{$f} );
my %P;
foreach my $line ( @{$f} )
{
my @L = split /$fieldSep/, $line;
_getKV( \%P, @L );
}
return \%P;
}
#------------------------------------------------------------------------------
# Add one line (from @_ array) to the hash. Hash looks like:
# key1 => key2 ... =>keyN => value1
# key1 => key2 ... =>keyX => value2
#------------------------------------------------------------------------------
sub _getKV(@)
{
my ($P, $k, @v) = @_;
return if( ! defined $k );
if( ref $P->{$k} eq 'HASH' ){
_getKV( $P->{$k}, @v );
return;
}
if( @v == 1 ){
$P->{$k} = $v[0];
return;
}else{
my $x = {};
$P->{$k} = $x;
_getKV( $x, @v );
}
}
#------------------------------------------------------------------------------
# Open the file in required write mode (default append mode) and write the new
# content to the file.
# Newcontent can be any kind of data structure.
#------------------------------------------------------------------------------
sub _WriteFile($$)
{
my($file,$newContent,$recSep,$fieldSep) =@_;
my $fh;
if( ref $file eq 'IO::File' )
{
$fh = $file;
}else{
$file =~ s/^\s+//;
$file =~ s/^<+//; # write mode only
$file = '>>' . $file if( $file !~ /^[|>]/ );
$fh = Open( $file ) || return undef;
}
if( ref $newContent eq '' ) {print $fh $newContent;}
elsif( _simpleArray( $newContent))
{ _printSimpleArray($newContent, $fh, $recSep)}
elsif( _simpleHash( $newContent ))
{ _printSimpleHash($newContent, $fh, $recSep,$fieldSep)}
else { print $fh Dumper $newContent; }
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _printSimpleArray($$$)
{
my ($content,$fh,$recSep) = @_;
map
{
my $rs = defined $recSep ? $recSep : '';
print $fh "$_$rs";
} @{$content};
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _printSimpleHash($$$$)
{
my ($content,$fh,$recSep,$fieldSep) = @_;
foreach my $key (sort keys %{$content})
{
my $rs = defined $recSep ? $recSep : '';
my $fs = defined $fieldSep ? $fieldSep : ':';
printf $fh "%s%s%s%s", $key, $fs, $content->{$key},$rs;
}
return;
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _simpleHash($)
{
my ($content) = @_;
return 0 if( ref $content ne 'HASH');
foreach my $key ( keys %{$content} )
{
return 0 if( ref $content->{$key} ne '' ); # scalar estimated
}
return 1;
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _simpleArray($)
{
my ($content) = @_;
return 0 if( ref $content ne 'ARRAY');
foreach my $line ( @{$content} )
{
return 0 if( ref $line ne '' ); # scalar estimated
}
return 1;
}
#------------------------------------------------------------------------------
# Read the file content into an array and return a referenz to this array.
# Return undef if the file isn't readable.
# File can be a file name or an IO::File handle.
#------------------------------------------------------------------------------
sub _ReadFile($$)
{
my($file,$callBack) =@_;
my ($fh,@F);
if( ref $file eq 'IO::File' )
{
$fh = $file;
}else{
$file =~ s/^\s*>+\s*//; # read only mode
$fh= Open( $file ) || return undef;
}
@F = <$fh>; my $rf = \@F;
$rf = &{$callBack}( \@F ) if( defined $callBack );
$rf = \@F if(!defined $rf );
return $rf;
}
#------------------------------------------------------------------------------
# Without an input argument TmpFile() returns an file handle to an new
# temporary file.
# Otherwise read the tempfile into an array and return a reference to it.
#------------------------------------------------------------------------------
sub TmpFile(@)
{
my ($file) = _getParam(@_);
my ($f,@F);
if( ref $file eq 'IO::File' ) { $file->seek(0,0); @F = <$file>; $f=\@F; }
else { $f = IO::File::new_tmpfile; }
return $f;
}
#------------------------------------------------------------------------------
# Return the filenames of a directory as array reference.
# Skip '.','..' and all filenames not matching search pattern if a search
# pattern is defined.
#------------------------------------------------------------------------------
sub Dir(@)
{
my ($dirPath,$searchPattern) = _getParam(@_);
my $d = IO::Dir->new($dirPath);
return undef if( !defined $d );
my @D;
while( defined($_ = $d->read))
{
next if( _toSkip( $_, $searchPattern ));
push @D, $_;
}
@D = sort @D;
return \@D;
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _toSkip($$)
{
my ($line,$pattern) = @_;
return 1 if( $line =~ /^[.]{1,2}$/ );
return 0 if( !defined $pattern );
if( $pattern =~ /^\s*!/ )
{
$pattern = substr($pattern, 1 );
return 1 if( $line =~ /$pattern/ );
}else{
return 1 if( $line !~ /$pattern/ );
}
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub Usage($$)
{
my ($self, $add) = @_;
return $self->{'ops'}->usage($add);
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub SetOpt($$$)
{
my ($self,$opt,$value) = @_;
return undef unless defined $self->{'ops'};
return undef unless ref($self->{'ops'}) eq 'Script::Toolbox::Util::Opt';
my $old = $self->{'ops'}->set($opt,$value);
$self->{$opt} = $value;
return $old;
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _getParam(@)
{
#if( isa( $_[0], "Script::Toolbox::Util" ))
my $x = ref $_[0];
if( $x =~ /Script::Toolbox/ )
{
shift @_ if( $_[0]->isa("Script::Toolbox::Util" ));
}
return @_;
}
#------------------------------------------------------------------------------
# Start a shell command with logging.
# Return 0 if shell command failed otherwise 1.
#------------------------------------------------------------------------------
sub System($)
{
my( $cmd ) = _getParam(@_);
my $fh = new IO::File;
my $pid = $fh->open("$cmd ". '2>&1; echo __RC__$? |' );
my $rc;
while( <$fh> )
{
chomp;
$rc = $_, next if( /^__RC__/ );
next if( /^\s*$/ );
Log( " $_" );
}
$rc =~ s/__RC__//;
return 1 if( $rc == 0 );
return 0;
}
#------------------------------------------------------------------------------
# Compute the difference between NOW[+offset] and the time value given as
# second parameter. Return a hash reference holding the difference in seconds,
# minutes, hours and days. Every value as a floating point number.
#
# The referenz time (rtime) may be an epoch value or any string parsable by
# Time::ParseDate.
#------------------------------------------------------------------------------
sub _nowDiff($$)
{
my ($now,$rtime) = @_;
$rtime = parsedate( $rtime ) if( $rtime !~ /^[0-9]+$/ );
my $secDiff= $now - $rtime;
my $D = int $secDiff / 86400; my $x = $secDiff % 86400;
my $H = int $x / 3600; $x = $x % 3600;
my $M = int $x / 60; $x = $x % 60;
my $S = $x;
my %R;
$R{seconds}= $secDiff;
$R{minutes}= $R{seconds} / 60.0;
$R{hours} = $R{seconds} / 3600.0;
$R{days} = $R{seconds} / 86400.0;
$R{DHMS} = sprintf "%dd %.2d:%.2d:%.2d", $D,$H,$M,$S;
return \%R;
}
#------------------------------------------------------------------------------
# Return the actual date and time. If $format is undef the result is a hash
# ref with keys sec,min,hour,mday,mon,year,wday,yday,isdst,epoch.
# Mon and year are corrected. Epoch is the time in seconds since 1.1.1970.
# If $format is not undef it must be a strftime() format string. The result
# of Now() is then the strftime() formated string.
# $opt may be {format=><'strftime-format'>, offset=><+-seconds>, diff=><time>}
#------------------------------------------------------------------------------
sub Now(@)
{
my( $opt ) = _getParam(@_);
my $offset = defined $opt->{offset} ? $opt->{offset}+0 : 0;
my $epoch = time+$offset;
return _nowDiff( $epoch, $opt->{diff} ) if( $opt->{diff} );
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($epoch);
return strftime $opt->{format},
$sec,$min,$hour,$mday,$mon, $year,$wday,$yday,$isdst
if( defined $opt->{format} );
$mon++;
$year+=1900;
return {sec=>$sec,min=>$min,hour=>$hour, mday=>$mday,mon=>$mon,year=>$year,
wday=>$wday,yday=>$yday,isdst=>$isdst,epoch=>$epoch};
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _printMenueHeader($) {
my ($opts) = @_;
foreach my $op ( @{$opts} ){
next if( ! $op->{'header'} );
printf "%s\n", $op->{'header'};
}
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _printMenueFooter($) {
my ($opts) = @_;
foreach my $op ( @{$opts} ){
next if( ! $op->{'footer'} );
printf "%s\n", $op->{'footer'};
}
}
#------------------------------------------------------------------------------
# Compute real index if we have NON-Lable lines in the opts-array.
#------------------------------------------------------------------------------
sub _getRealIndex($$) {
my ($o, $opts) = @_;
my $real = 0;
my $curr = 0;
foreach my $op ( @{$opts} )
{
$real++ if( ! $op->{'label'} );
return $real if( $o == $curr );
$real++;
$curr++;
}
return $real;
}
#------------------------------------------------------------------------------
# Display a menue, return the selected index number and the menue data structure.
# If a VALUE or DEFAULT key of a menue option points to a value this value can
# be changed.
# If a jump target is defined, the corresponding function will be called with
# argv=> as arguments.
# Data structure: [{label=>,value=>,jump=>,argv=>},...]
# - label=> must be defined all other keys are optinal
# - jump=> must point to a subroutine if set
# - argv=> arguments for the subroutine jump points to
# - header=> an optional head line
# - footer=> an optional footer line
#------------------------------------------------------------------------------
sub Menue($)
{
my ($opts) = @_;
my ($i,$o) = (0,0);
my $maxLen = _maxLabelLength($opts);
my $form1 = "%3d %-${maxLen}s ";
system("clear");
_printMenueHeader($opts);
($i,$o) = (0,0);
foreach my $op ( @{$opts} )
{
next if( ! $op->{'label'} );
my ($def,$form)=_getDefForm($form1,$op);
printf $form, $i++,$op->{'label'},$def;
}
_printMenueFooter($opts);
printf "\nSelect: ";
$o = _getNumber( $i-1);
if( $o < $i && $o > -1 )
{
my $oo = _getRealIndex($o, $opts);
_setValue($oo, $opts);
_jump($oo, $opts); # jump to callback if defined
}
return $o,$opts;
}
#------------------------------------------------------------------------------
# Prepare input for Data Menue. Allowed input formats:
# INPUT1: 'value1 value2 ..'
# INPUT2: [{'label'=>'Max','value'=>'foo'},{'label'=>'Tim','value'=>99}]
#------------------------------------------------------------------------------
sub _addData($$$)
{
my ($dataMenue,$opts,$frame) = @_;
if(ref $opts eq 'ARRAY') {
foreach my $line ( @{$opts} ) {
next if( ref $line ne 'HASH' );
next if( ! defined $line-{'label'} );
next if( ! defined $line-{'value'} );
push @{$dataMenue}, $line,
}
return 'ARRAY';
}elsif(ref $opts eq '' ) {
my $i=1;
foreach my $l ( split /\s+/, $opts ) {
my $line = {'label' => 'V'.$i++, 'value' => $l};
push @{$dataMenue}, $line,
}
return 'SCALAR' if( ! defined $frame );
push @{$dataMenue}, {'header' => $frame->{'header'}} if( defined $frame->{'header'});
push @{$dataMenue}, {'footer' => $frame->{'footer'}} if( defined $frame->{'footer'});
return 'SCALAR';
}
}
#------------------------------------------------------------------------------
# Remove {label=>"EXIT"} line.
#------------------------------------------------------------------------------
sub _returnArray($) {
my ($dataMenue) = @_;
splice @{$dataMenue},0,1;
return $dataMenue;
}
#------------------------------------------------------------------------------
# Remove {label=>"EXIT"} line. Return values as white space concatenated string.
#------------------------------------------------------------------------------
sub _returnScalar($) {
my ($dataMenue) = @_;
splice @{$dataMenue},0,1;
my $data;
map { $data .= $_->{'value'} .' '} @{$dataMenue};
chop $data;
return $data;
}
#------------------------------------------------------------------------------
# Use Menue to edit small data sets. Two input formats allowed.
# INPUT1: 'value1 value2 ..'
# INPUT2: [{'label'=>'Max','value'=>'foo'},{'label'=>'Tim','value'=>99}]
#------------------------------------------------------------------------------
sub DataMenue(@) {
my ($opts,$head) = @_;
my $dataMenue = [{label=>"EXIT"}];
my $format = _addData($dataMenue, $opts,$head);
while( 1 ) {
my ($o,$dataMenue) = Menue($dataMenue);
last if( $o == 0 );
}
return _returnArray( $dataMenue) if( $format eq 'ARRAY' );
return _returnScalar($dataMenue) if( $format eq 'SCALAR');
}
#------------------------------------------------------------------------------
# Read a directory and return a hash with filenames stat() structure infos
# for every file. An optional pattern (regexp) may be used for selecting files.
#------------------------------------------------------------------------------
sub Stat($$)
{
my ($path,$patt) = _getParam( @_ );
my $dir = Dir($path,$patt);
my $stat;
foreach my $f ( @{$dir} )
{
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat("$path/$f");
$stat->{$f}{'dev'} = $dev;
$stat->{$f}{'ino'} = $ino;
$stat->{$f}{'mode'} = $mode;
$stat->{$f}{'nlink'}= $nlink;
$stat->{$f}{'uid'} = $uid;
$stat->{$f}{'gid'} = $gid;
$stat->{$f}{'rdev'} = $rdev;
$stat->{$f}{'size'} = $size;
$stat->{$f}{'atime'}= $atime;
$stat->{$f}{'mtime'}= $mtime;
$stat->{$f}{'ctime'}= $ctime;
$stat->{$f}{'blksize'} = $blksize;
$stat->{$f}{'blocks'} = $blocks;
}
return $stat;
}
#------------------------------------------------------------------------------
# Jump to a callback function of a menue option.
#------------------------------------------------------------------------------
sub _jump($$)
{
my ($o,$menue) = @_;
return if( !defined $menue->[$o]->{'jump'} ); #option has no callback
my $call = $menue->[$o]->{'jump'};
my $args = defined $menue->[$o]->{'argv'} ? $menue->[$o]->{'argv'} : undef;
$call->($args);
return;
}
#------------------------------------------------------------------------------
# Compute the maximum length of all labels found in the menu array @{$opts}.
#------------------------------------------------------------------------------
sub _maxLabelLength($)
{
my ($opts) = @_;
my $len=0;
foreach my $op ( @{$opts} )
{
next if( ! defined $op->{'label'});
my $l = length($op->{'label'});
$len = $len < $l ? $l : $len;
}
return $len;
}
#------------------------------------------------------------------------------
# Compute the default value and the format string.
#------------------------------------------------------------------------------
sub _getDefForm($$)
{
my ($form1,$op) = @_;
my $def;
$def = $op->{'value'} if( defined $op->{'value'} );
my $form = defined $def ? "$form1 [%s]" : $form1;
return $def,"$form\n";
}
#------------------------------------------------------------------------------
# Read the next number from STDIN. Return 0 if given character is not a digit.
# Read two characters if max option number is greater than 9.
# Valid option numbers are 0...99.
#------------------------------------------------------------------------------
sub _getNumber($)
{
my ($maxNum) = @_;
my $o=_getChar();
if( $maxNum > 9 )
{
my $oo=_getChar();
$o=10*$o+$oo if( $oo =~ /^\d$/ );
}
return 0 if( $o !~ /^\d+$/ );
return $o;
}
#------------------------------------------------------------------------------
# Read one character from STDIN. FIXME: stty method is not portable
#------------------------------------------------------------------------------
sub _getChar()
{
system "stty", '-icanon', 'eol', "\001";
my $key = getc(STDIN);
system "stty", 'icanon', 'eol', '^@'; # ASCII null
return $key;
}
#------------------------------------------------------------------------------
# Read a line from STDIN and assign it to the "value" key of an menue option.
# Data structure: [{label=>,value=>,jump=>,argv=>},...]
# After this function value=> has one of the following values:
# - the read line if not empty
# - the old value if read an empty line and an old value exists
#------------------------------------------------------------------------------
sub _setValue($)
{
my ($o,$opts) = @_;
return undef if( !defined $opts->[$o]{'value'} );
my $op = $opts->[$o];
my $def = defined $op->{'value'} ? $op->{'value'} : '';
printf "\n%s [%s]:", $op->{'label'}, $def;
my $resp = <STDIN>;
chomp $resp;
$resp = $def if( $resp eq '' );
$op->{'value'} = $resp;
return $resp;
}
1;
__END__
=head1 NAME
Script::Toolbox::Util - see documentaion of Script::Toolbox
=cut
# vim: ts=4 sw=4 ai