Example
: xHList.pl
Screenshot
Options
Generated
code
Project
## ctk: description Extended HlLst , Test & Demo
## ctk: title xHList - extended HList
## ctk: application '' ''
## ctk: strict
1
## ctk: code 2
## ctk: testCode
1
## ctk: subroutineName thisDialog
## ctk: autoExtractVariables 1
## ctk: autoExtract2Local 1
## ctk: modal 0
## ctk: buttons
## ctk: baseClass
Tk::HList
## ctk: isolGeom 0
## ctk: version 4.11
## ctk: onDeleteWindow sub{$mw->destroy}
## ctk: Toplevel
1
## ctk: argList -itemtype => 'text',-separator => '/',-data , $data
## ctk: treewalk D
## ctk: 2010 08 04 - 00:07:18
## ctk: uselib start
## ctk: uselib end
use strict;
use Tk;
my
$mw=MainWindow->new(-title=>'xHList - extended HList');
package xHList;
use vars qw($VERSION);
$VERSION = '1.01';
require Tk::HList;
require Tk::Derived;
@xHList::ISA = qw(Tk::Derived Tk::HList);
Construct Tk::Widget 'xHList';
## ctk: Globalvars
my ($data,$options,$path);
## ctk: Globalvars end
sub ClassInit {
my $self =
shift;
##
## init class
##
$self->SUPER::ClassInit(@_);
}
sub Populate {
my ($self,$args) = @_;
##
## ctk: Localvars
## ctk: Localvars end
## move args
to local variables
##
$self->SUPER::Populate($self->arglist($args));
##
## set up ConfigSpecs (optional)
##
my $mw =
$self;
## ctk: code generated by ctk_w version '4.11'
## ctk: lexically scoped variables for widgets
## no 'my' widget list
## ctk: instantiate and display widgets
## ctk: widgets generated using treewalk D
## ctk: end of gened Tk-code
##
return
$self;
}
## ctk: methods
sub arglist {
my $self =
shift;
my $args =
shift;
$data =
delete $args->{-data} if exists $args->{-data};
$path =
'';
return
$args
}
sub configureSomeOptions {
my $self =
shift;
$self->configure(-drawbranch,1);
$self->configure(-indent,10);
$self->configure(-indicator,1);
return 1;
}
sub _addTextItem {
my $self =
shift;
while ( @_
) {
my
$key = shift;
my
$text = shift;
$self->add($key,
-text," '$text'");
}
}
sub displayHash {
my $self =
shift;
my $hash =
shift;
$hash =
$data unless defined $hash;
$self->configureSomeOptions();
my $spath
= $path;
foreach
(sort keys %$hash) {
if(ref($hash->{$_})
=~/HASH/) {
$self->_addTextItem("$path$_","$_");
$path
.= "$_/";
$self->displayHash($hash->{$_})
;
$path
= $spath;
}
else {
$self->_addTextItem("$path$_",$_
.'='.$hash->{$_});
}
}
}
sub displayArray {
my $self =
shift;
my $array
= shift;
$array =
$data unless defined $array;
$self->configureSomeOptions();
for (my $i
= 0; $i < @$array;$i++) {
my
$spath = $path;
if
(ref($array->[$i]) =~/HASH/) {
$self->_addTextItem("$path$i","$i
hash");
$path
.="$i/";
$self->displayHash($array->[$i]);
$path
= $spath;
}
elsif (ref($array->[$i]) =~/ARRAY/) {
$self->_addTextItem("$path$i","$i
array");
$path
.="$i/";
$self->displayArray($array->[$i]);
$path
= $spath;
}
else {
$self->_addTextItem("$path$i",$array->[$i])
}
}
}
sub displayStructure {
my $self =
shift;
my
$structure = shift;
$structure
= $data unless defined $structure;
$self->configureSomeOptions();
if
(ref($structure) =~ /ARRAY/) {
$self->displayArray($structure)
} else {
$self->_addTextItem("0","$structure")
}
}
sub displayFamilyTree {
my $self =
shift;
my $family
= shift;
$family =
$data unless defined $family;
$self->configureSomeOptions();
}
## ctk: methods end
## ctk: testCode
# -----------------------------------------------
##
package main;
&main::init();
my (%args) =(-itemtype => 'text',-separator
=> '/', -data, $data);
my $toplevel = $mw->Toplevel();
my $instance = $toplevel->xHList(%args)->pack();
$toplevel->protocol('WM_DELETE_WINDOW',sub{$mw->destroy});
$mw->protocol('WM_DELETE_WINDOW',sub{$mw->destroy});
&main::test_1($instance);
MainLoop;
##
## ctk: testCode
## ctk: callbacks
sub init {
my
$hData = {-position1, {'-x',1,'-y',2,'-z',3},-position2,
{'-x',{-x1,41,-y1,42,-z1,43},'-y',5,'-z',6}};
$data = ["1 element", [qw/22 23
24/],$hData,"ende"];
}
sub test_1 {
my
$instance = shift;
$instance->displayStructure();
## display passed data
}
## ctk: other code
## ctk: eof 2010 08 04 - 00:07:18
1; ## make
perl compiler happy...
Exported
derived widget
## ctk: description Extended HlLst , Test & Demo
## ctk: title xHList - extended HList
## ctk: application '' ''
## ctk: strict
1
## ctk: code 2
## ctk: testCode
0
## ctk: subroutineName thisDialog
## ctk: autoExtractVariables 1
## ctk: autoExtract2Local 1
## ctk: modal 0
## ctk: buttons
## ctk: baseClass
Tk::HList
## ctk: isolGeom 0
## ctk: version 4.11
## ctk: onDeleteWindow sub{$mw->destroy}
## ctk: Toplevel
1
## ctk: argList -itemtype => 'text',-separator => '/',-data , $data
## ctk: treewalk D
## ctk: 2010 08 04 - 00:30:34
use strict;
use Tk;
package xHList;
use vars qw($VERSION);
$VERSION = '1.01';
require Tk::HList;
require Tk::Derived;
@xHList::ISA = qw(Tk::Derived Tk::HList);
Construct Tk::Widget 'xHList';
## ctk: Globalvars
my ($data,$options,$path);
## ctk: Globalvars end
sub ClassInit {
my $self =
shift;
##
## init class
##
$self->SUPER::ClassInit(@_);
}
sub Populate {
my
($self,$args) = @_;
##
## ctk: Localvars
## ctk: Localvars end
## move args
to local variables
##
$self->SUPER::Populate($self->arglist($args));
##
## set up ConfigSpecs (optional)
##
my $mw =
$self;
## ctk: code generated by ctk_w version '4.11'
## ctk: lexically scoped variables for widgets
## no 'my' widget list
## ctk: instantiate and display widgets
## ctk: widgets generated using treewalk D
## ctk: end of gened Tk-code
##
return
$self;
}
## ctk: methods
sub arglist {
my $self =
shift;
my $args =
shift;
$data =
delete $args->{-data} if exists $args->{-data};
$path =
'';
return
$args
}
sub configureSomeOptions {
my $self =
shift;
$self->configure(-drawbranch,1);
$self->configure(-indent,10);
$self->configure(-indicator,1);
return 1;
}
sub _addTextItem {
my $self =
shift;
while ( @_
) {
my
$key = shift;
my
$text = shift;
$self->add($key,
-text," '$text'");
}
}
sub displayHash {
my $self =
shift;
my $hash =
shift;
$hash =
$data unless defined $hash;
$self->configureSomeOptions();
my $spath
= $path;
foreach
(sort keys %$hash) {
if(ref($hash->{$_})
=~/HASH/) {
$self->_addTextItem("$path$_","$_");
$path
.= "$_/";
$self->displayHash($hash->{$_})
;
$path
= $spath;
}
else {
$self->_addTextItem("$path$_",$_
.'='.$hash->{$_});
}
}
}
sub displayArray {
my $self =
shift;
my $array
= shift;
$array =
$data unless defined $array;
$self->configureSomeOptions();
for (my $i
= 0; $i < @$array;$i++) {
my
$spath = $path;
if
(ref($array->[$i]) =~/HASH/) {
$self->_addTextItem("$path$i","$i
hash");
$path
.="$i/";
$self->displayHash($array->[$i]);
$path
= $spath;
}
elsif (ref($array->[$i]) =~/ARRAY/) {
$self->_addTextItem("$path$i","$i
array");
$path
.="$i/";
$self->displayArray($array->[$i]);
$path
= $spath;
}
else {
$self->_addTextItem("$path$i",$array->[$i])
}
}
}
sub displayStructure {
my $self =
shift;
my
$structure = shift;
$structure
= $data unless defined $structure;
$self->configureSomeOptions();
if
(ref($structure) =~ /ARRAY/) {
$self->displayArray($structure)
} else {
$self->_addTextItem("0","$structure")
}
}
sub displayFamilyTree {
my $self =
shift;
my $family
= shift;
$family =
$data unless defined $family;
$self->configureSomeOptions();
}
## ctk: methods end
## ctk: other code
## ctk: eof 2010 08 04 - 00:30:34
1; ## make
perl compiler happy...
Application
code and test run
