File Coverage

blib/lib/Script/Toolbox/Util/Menues.pm

Criterion	Covered	Total	%
statement	6	173	3.4
branch	0	76	0.0
condition	0	3	0.0
subroutine	2	29	6.9
pod	0	19	0.0
total	8	300	2.6

package Script::Toolbox::Util::Menues;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;

@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.
@EXPORT = qw(

);
#$VERSION = '0.03';


# Preloaded methods go here.

#-----------------------------------------------------------------------------
# {'menueName>' =>[{label=>,value=>,jump=>,argv=>},...]}
#-----------------------------------------------------------------------------
sub new
{
	my $classname = shift;
	my $self      = {};
	bless( $self, $classname );
	$self->_init( @_ );
	return $self;
}

#-----------------------------------------------------------------------------
# {'' =>[{label=>,value=>,jump=>,argv=>},...]}
#-----------------------------------------------------------------------------
sub _init
{
	my ($self, $newDef) = @_;

    $self->{'def'} = {};
    return  if( ref $newDef ne 'HASH' );
    $self->addMenue($newDef);
}

#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _getHead($){
    my ($self,$def) = @_;
    my $s = '';
    foreach my $k ( @{$def} ) {
        next    if( ! defined $k->{'header'} );
        $s .= sprintf "%s", $k->{'header'};
    }
    return $s ne '' ? $s : undef;
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _getFoot($){
    my ($self,$def) = @_;
    my $s = '';
    foreach my $k ( @{$def} ) {
        next    if( ! defined $k->{'footer'} );
        $s .= sprintf "%s", $k->{'footer'};
    }
    return $s ne '' ? $s : undef;
}

#------------------------------------------------------------------------------
# ...
# {'label'=>'Call the submenue 1','jump'=>'SubMenue1'}
# SubMenue1: is the name of a previous defined menue in the same menues container
#------------------------------------------------------------------------------
sub _resolveSubmenue($){
    my ($self,$opt) = @_;

    return  if( !defined $opt->{'jump'} );
    return  if( ref \$opt->{'jump'} ne 'SCALAR' );

    my $subName = $opt->{'jump'};
    $opt->{'jump'} = \&Script::Toolbox::Util::Menues::run;
    $opt->{'argv'} = [$self,$subName];
    return;
}

#------------------------------------------------------------------------------
# [{label=>,value=>,jump=>,argv=>},...]}
#------------------------------------------------------------------------------
sub _getOpts($){
    my ($self,$def) = @_;
    my @s;
    foreach my $k ( @{$def} ) {
        next    if( ! defined $k->{'label'} );
        $self->_resolveSubmenue($k);
        push @s, $k;
    }
    return \@s;
}

#------------------------------------------------------------------------------
# , [{label=>,value=>,jump=>,argv=>},...]}
#------------------------------------------------------------------------------
sub addMenue($){
    my ($self,$newDef) = @_;

    return  if( ref $newDef ne 'HASH' );

    foreach my $name ( keys %{$newDef} ){
        my $def                       = $newDef->{$name};
        $self->{'def'}{$name}{'head'} = $self->_getHead($def);
        $self->{'def'}{$name}{'foot'} = $self->_getFoot($def);
        $self->{'def'}{$name}{'opts'} = $self->_getOpts($def);
    }
    return;
}

#------------------------------------------------------------------------------
# ,
#------------------------------------------------------------------------------
sub setHeader($$){
    my ($self,$name,$head) = @_;

    $self->{'def'}{$name}{'head'} = $head;
    return;
}


#------------------------------------------------------------------------------
# ,
#------------------------------------------------------------------------------
sub setAutoHeader($){
    my ($self,$name) = @_;

    if( defined $name) {
        $self->{'def'}{$name}{'autohead'} = 1;
        return;
    }
    foreach my $n (keys %{$self->{'def'}} ){
        $self->{'def'}{$n}{'autohead'} = 1;
    }
}

#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _delAutoHead($){
    my ($ah) = @_;
    delete $ah->{'autohead'} if( defined $ah->{'autohead'} );
}

#------------------------------------------------------------------------------
# ,
#------------------------------------------------------------------------------
sub delAutoHeader($){
    my ($self,$name) = @_;

    if( defined $name) {
        _delAutoHead( $self->{'def'}{$name} );
        return;
    }
    foreach my $n (keys %{$self->{'def'}} ){
        _delAutoHead( $self->{'def'}{$n}  );
    }
}

#------------------------------------------------------------------------------
# ,
#------------------------------------------------------------------------------
sub getHeader($){
    my ($self,$name) = @_;

    my $autoHead = $self->{'def'}{$name}{'autohead'};
    my $H;
    my $h = $self->{'def'}{$name}{'head'};
       $h = "Menue: $name"      if(!defined $h && defined $autoHead);
       $H = {'header' => $h}    if( defined $h );

    return $H;
}

#------------------------------------------------------------------------------
# ,
#------------------------------------------------------------------------------
sub setFooter($$){
    my ($self,$name,$foot) = @_;

    $self->{'def'}{$name}{'foot'} = $foot;
    return;
}

#------------------------------------------------------------------------------
# ,
#------------------------------------------------------------------------------
sub getFooter($){
    my ($self,$name) = @_;

    my $foot = $self->{'def'}{$name}{'foot'} ;
    return {'footer'=> $foot}   if(defined $foot);
    return undef;
}

#------------------------------------------------------------------------------
# , {label=>,value=>,jump=>,argv=>}
#------------------------------------------------------------------------------
sub addOption($$){
    my ($self,$name,$opt) = @_;

    $self->{'def'}{$name}{'opts'} = []  if( ! defined $self->{'def'}{$name}{'opts'} );

    $self->_resolveSubmenue($opt);
    push @{$self->{'def'}{$name}{'opts'}}, $opt;
    return;
}

#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _getParams($){
    my ($self,$name) = @_;

    my @p;
    my $s = $self->getHeader($name); push @p, $s if( defined $s );
       $s = $self->getFooter($name); push @p, $s if( defined $s );
    push @p, {'label'=>'RETURN'};
    map {
        push @p, $_;
    } @{$self->{'def'}{$name}{'opts'}};

    return \@p;
}

#------------------------------------------------------------------------------
# Validate parameters and rearrange parameters in case of internal menue call
# ( submenue call by name).
# Return 0 if parameters invalid.
#------------------------------------------------------------------------------
sub validateParams($$){
    my ($self,$name) = @_;
    return 0      if( ! defined $$self );
    if( ref $$self eq 'ARRAY' ) {
       return 0   if( ref $$self->[0] ne  'Script::Toolbox::Util::Menues' );
       $$name = $$self->[1];
       $$self = $$self->[0];
    }
    return 1      if( defined $$self->{'def'}{$$name} );
    Script::Toolbox::Util::Log("\nWARNING: Submenue $$name is not defined!");
    sleep  5;
    return 0;
}

#------------------------------------------------------------------------------
# Run the named menue as long as $cnt is true. $cnt will be decremented by each
# loop. That means if $cnt starts with 0 we have an endless loop.
# Return the number of the last selected option.
# The option 'RETURN' will be created automaticly and has option number 0 by
# default.
#------------------------------------------------------------------------------
sub run($$){
    my ($self,$name,$cnt) = @_;

    return      if( ! validateParams(\$self,\$name) );
    $cnt = 1    if( ! defined $cnt);
    $cnt = 1    if( $cnt !~ /^[-]?\d+$/ );
    $cnt =-1    if( $cnt == 0 );
    my $o; my $m;
    while($cnt--) {
        my $p   = $self->_getParams($name);
        ($o,$m) = Script::Toolbox::Util::Menue($p);
        $self->{'def'}{$name}{'selected'}{'num'} = $o;
        $self->{'def'}{$name}{'selected'}{'opt'} = $m->[$o];
        return $o   if( $o == 0 );
    }
    return $o;
}

#------------------------------------------------------------------------------
# Return current nmber of selected option.
#------------------------------------------------------------------------------
sub currNumber($){
    my ($self,$name) = @_;
    return $self->{'def'}{$name}{'selected'}{'num'};
}

#------------------------------------------------------------------------------
# Return current label of selected option.
#------------------------------------------------------------------------------
sub currLabel($){
    my ($self,$name) = @_;
    return $self->{'def'}{$name}{'selected'}{'opt'}{'label'};
}

#------------------------------------------------------------------------------
# Return current value of selected option.
#------------------------------------------------------------------------------
sub currValue($){
    my ($self,$name) = @_;
    return $self->{'def'}{$name}{'selected'}{'opt'}{'value'};
}

#------------------------------------------------------------------------------
# Return the callback address and argv address of selected option.
#------------------------------------------------------------------------------
sub currJump($){
    my ($self,$name) = @_;

    my $call = $self->{'def'}{$name}{'selected'}{'opt'}{'jump'};
    my $args = $self->{'def'}{$name}{'selected'}{'opt'}{'argv'};

    return $call,$args;
}

#------------------------------------------------------------------------------
# Set a new label for current selected option. Return old label.
#------------------------------------------------------------------------------
sub setCurrLabel($$){
    my ($self,$name,$newLabel) = @_;

    my $cn = $self->currNumber($name) -1;
    my $ol = $self->{'def'}{$name}{'opts'}[$cn]{'label'};
             $self->{'def'}{$name}{'opts'}[$cn]{'label'} = $newLabel;
    return $ol;
}

#------------------------------------------------------------------------------
# Set a new value for current selected option. Return old value.
#------------------------------------------------------------------------------
sub setCurrValue($$){
    my ($self,$name,$newValue) = @_;

    my $cn = $self->currNumber($name) -1;
    my $ov = $self->{'def'}{$name}{'opts'}[$cn]{'value'};
             $self->{'def'}{$name}{'opts'}[$cn]{'value'} = $newValue;
    return $ov;
}

#------------------------------------------------------------------------------
# Set new callback address und argv for the current selected option.
#------------------------------------------------------------------------------
sub setCurrJump($$$){
    my ($self,$name,$callBack,$argv) = @_;

    my $cn = $self->currNumber($name) -1;
    $self->{'def'}{$name}{'opts'}[$cn]{'jump'} = $callBack;
    $self->{'def'}{$name}{'opts'}[$cn]{'argv'} = $argv;
    return $callBack,$argv;
}

#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
sub _invalidParam($$$$$){
    my ($self,$name,$pattern,$search,$return) = @_;
    return  1  if( !defined $pattern );
    return  1  if( !defined $search  );
    return  1  if( !defined $return  );
    return  1  if( !defined $self->{'def'}{$name}{'opts'});
    return  1  if( $search !~ /(number|value|label)/ );
    return  1  if( $return !~ /(number|value|label)/ );
    return  0;
}

#------------------------------------------------------------------------------
# Search the labels array for $pattern matching in $search. If matching return
# value of type return.
# $pattern='[Mm]ax' $search='value' $return='label'
# => returns all labels where value column matching Max or max.
# search: /(label,number,value)/
# return: /(label,number,value)/
#------------------------------------------------------------------------------
sub getMatching($$$$){
    my ($self,$name,$pattern,$search,$return) = @_;
    return '' if( _invalidParam($self,$name,$pattern,$search,$return));

    my $L = $self->{'def'}{$name}{'opts'};
    my @R;
    my $i=1;
    foreach my $l ( @{$L} ){
        if( $search eq 'number' ){
            push @R, $l->{$return}  if( $i =~ /$pattern/);
            $i++;
        }else{
            next    if( !defined $l->{$search} );
            next    if( $l->{$search} !~ /$pattern/ );
            push @R, $l->{$return};
        }
    }
    return \@R;
}


1;
__END__