Example : dlg_listBindings.pl

Example : dlg_listBindings.pl 1

Screenshot 2

Generated code 2

Project 2

Exported 5

Logfile 7

Generated code

Project

#!perl.exe

## ctk: description Show the list of the bindings actually set.

## ctk: title List actual bindings

## ctk: application '' ''

## ctk: strict 0

## ctk: code 0

## ctk: subroutineName dlg_listBindings

## ctk: autoExtractVariables 1

## ctk: autoExtract2Local 0

## ctk: modalDialogClassName DialogBox

## ctk: modal 1

## ctk: isolGeom 0

## ctk: version 3.099

## ctk: onDeleteWindow sub{1}

## ctk: Toplevel 1

## ctk: argList -title , '???'

## ctk: 2007 11 13 - 15:51:38

## ctk: uselib start

## ctk: uselib end

use Tk;

use Tk::Button;

use Tk::Listbox;;

$mw=MainWindow->new(-title=>'List actual bindings ');

## ctk: Globalvars

## ctk: Globalvars end

&main::init();

my $answer = &main::dlg_listBindings($mw,-title , '???' );

print "\nanswer = '$answer'";

MainLoop;

sub dlg_listBindings {

my $hwnd = shift;

my (%args) = @_;

my $rv;

## ctk: Localvars

## ctk: Localvars end

my $mw = $hwnd->DialogBox(

-title=> (exists $args{-title})? $args{-title}:'List actual bindings ',

-buttons=> (exists $args{-buttons}) ? $args{-buttons} : ['OK','Cancel']);

$mw->protocol('WM_DELETE_WINDOW',sub{1});

## ctk: code generated by ctk_w version '3.099'

## ctk: instantiate and display widgets

$wr_001 = $mw -> Scrolled ( 'Listbox' , -selectmode , 'single' , -scrollbars , 'osoe' ) -> pack(-anchor=>'nw', -side=>'top', -pady=>5, -fill=>'both', -expand=>1, -padx=>5);

$wr_001->insert('end',$wr_001->bindtags);

$wr_002 = $mw -> Button ( -background , '#ffffff' , -command , [\&listBindings , $wr_001 , $wr_001 ] , -state , 'normal' , -text , 'list bindings' ) -> pack(-anchor=>'nw', -side=>'top', -pady=>5, -fill=>'x', -expand=>1, -padx=>5);

## ctk: end of gened Tk-code

$rv = $mw->Show();

return $rv;

} ## end of dlg_listBindings

## ctk: end of dialog code

## ctk: callbacks

sub init { 1 }

sub listBindings {

my ($lb, $widget) = @_;

my @b = $widget->bindtags() if (Exists($widget));

$lb->delete(0,'end');

map {

$lb->insert('end',$_)

} @b;

$lb->insert('end'," ");

@b = &bindDump($widget);

map {

s/\n$//;

$lb->insert('end',$_)

} @b;

}

sub bindDump {

# Dump lots of good binding information. This pretty-print subroutine

# is, essentially, the following code in disguise:

# print "Binding information for $w\n";

# foreach my $tag ($w->bindtags) {

# printf "\n Binding tag '$tag' has these bindings:\n";

# foreach my $binding ($w->bind($tag)) {

# printf " $binding\n";

# }

my ($w) = @_;

my @rv;

my (@bindtags) = $w->bindtags;

my $digits = length( scalar @bindtags );

my ($spc1, $spc2) = ($digits + 33, $digits + 35);

my $format1 = "%${digits}d.";

my $format2 = ' ' x ($digits + 2);

my $n = 0;

push @rv , sprintf("## Binding information for '", $w->PathName, "', $w ##\n");

foreach my $tag (@bindtags) {

my (@bindings) = $w->bind($tag);

$n++; # count this bindtag

if ($#bindings == -1) {

push @rv , sprintf("$format1 Binding tag '$tag' has no bindings.\n", $n);

} else {

push @rv , sprintf("$format1 Binding tag '$tag' has these bindings:\n", $n);

foreach my $binding ( @bindings ) {

my $callback = $w->bind($tag, $binding);

push @rv , sprintf("$format2%27s : %-40s\n", $binding, $callback);

if ($callback =~ /SCALAR/) {

if (ref $$callback) {

push @rv , sprintf("%s %s\n", ' ' x $spc1, $$callback);

} else {

push @rv , sprintf("%s '%s'\n", ' ' x $spc1, $$callback);

}

} elsif ($callback =~ /ARRAY/) {

if (ref $callback->[0]) {

push @rv , sprintf("%s %s\n", ' ' x $spc1, $callback->[0], "\n");

} else {

push @rv , sprintf("%s '%s'\n", ' ' x $spc1, $callback->[0], "\n");

}

foreach my $arg (@$callback[1 .. $#{@$callback}]) {

if (ref $arg) {

push @rv , sprintf("%s %-40s", ' ' x $spc2, $arg);

} else {

push @rv , sprintf("%s '%s'", ' ' x $spc2, $arg);

}

if (ref $arg eq 'Tk::Ev') {

if ($arg =~ /SCALAR/) {

push @rv , sprintf(": '$$arg'");

} else {

push @rv , sprintf(": '", join("' '", @$arg), "'");

}

push @rv , sprintf("\n");

} # forend callback arguments

} # ifend callback

} # forend all bindings for one tag

} # ifend have bindings

} # forend all tags

push @rv , sprintf("\n");

return @rv;

} # end bindDump

## ctk: other code

## ctk: eof 2007 11 13 - 15:51:38

1; ## make perl compiler happy...

Exported

## ctk: description Show the list of the bindings actually set.

## ctk: title List actual bindings

## ctk: application '' ''

## ctk: strict 0

## ctk: code 0

## ctk: subroutineName dlg_listBindings

## ctk: autoExtractVariables 1

## ctk: autoExtract2Local 0

## ctk: modalDialogClassName DialogBox

## ctk: modal 1

## ctk: isolGeom 0

## ctk: version 3.099

## ctk: onDeleteWindow sub{1}

## ctk: Toplevel 1

## ctk: argList -title , '???'

## ctk: 2007 11 13 - 15:52:17

use Tk;

use Tk::Button;

use Tk::Listbox;;

sub dlg_listBindings {

my $hwnd = shift;

my (%args) = @_;

my $rv;

## ctk: Localvars

## ctk: Localvars end

my $mw = $hwnd->DialogBox(

-title=> (exists $args{-title})? $args{-title}:'List actual bindings ',

-buttons=> (exists $args{-buttons}) ? $args{-buttons} : ['OK','Cancel']);

$mw->protocol('WM_DELETE_WINDOW',sub{1});

## ctk: code generated by ctk_w version '3.099'

## ctk: instantiate and display widgets

$wr_001 = $mw -> Scrolled ( 'Listbox' , -selectmode , 'single' , -scrollbars , 'osoe' ) -> pack(-anchor=>'nw', -side=>'top', -pady=>5, -fill=>'both', -expand=>1, -padx=>5);

$wr_001->insert('end',$wr_001->bindtags);

## ctk: end of gened Tk-code

$rv = $mw->Show();

return $rv;

} ## end of dlg_listBindings

## ctk: end of dialog code

## ctk: callbacks

sub listBindings {

my ($lb, $widget) = @_;

my @b = $widget->bindtags() if (Exists($widget));

$lb->delete(0,'end');

map {

$lb->insert('end',$_)

} @b;

$lb->insert('end'," ");

@b = &bindDump($widget);

map {

s/\n$//;

$lb->insert('end',$_)

} @b;

}

sub bindDump {

# Dump lots of good binding information. This pretty-print subroutine

# is, essentially, the following code in disguise:

# print "Binding information for $w\n";

# foreach my $tag ($w->bindtags) {

# printf "\n Binding tag '$tag' has these bindings:\n";

# foreach my $binding ($w->bind($tag)) {

# printf " $binding\n";

# }

my ($w) = @_;

my @rv;

my (@bindtags) = $w->bindtags;

my $digits = length( scalar @bindtags );

my ($spc1, $spc2) = ($digits + 33, $digits + 35);

my $format1 = "%${digits}d.";

my $format2 = ' ' x ($digits + 2);

my $n = 0;

push @rv , sprintf("## Binding information for '", $w->PathName, "', $w ##\n");

foreach my $tag (@bindtags) {

my (@bindings) = $w->bind($tag);

$n++; # count this bindtag

if ($#bindings == -1) {

push @rv , sprintf("$format1 Binding tag '$tag' has no bindings.\n", $n);

} else {

push @rv , sprintf("$format1 Binding tag '$tag' has these bindings:\n", $n);

foreach my $binding ( @bindings ) {

my $callback = $w->bind($tag, $binding);

push @rv , sprintf("$format2%27s : %-40s\n", $binding, $callback);

if ($callback =~ /SCALAR/) {

if (ref $$callback) {

push @rv , sprintf("%s %s\n", ' ' x $spc1, $$callback);

} else {

push @rv , sprintf("%s '%s'\n", ' ' x $spc1, $$callback);

}

} elsif ($callback =~ /ARRAY/) {

if (ref $callback->[0]) {

push @rv , sprintf("%s %s\n", ' ' x $spc1, $callback->[0], "\n");

} else {

push @rv , sprintf("%s '%s'\n", ' ' x $spc1, $callback->[0], "\n");

}

foreach my $arg (@$callback[1 .. $#{@$callback}]) {

if (ref $arg) {

push @rv , sprintf("%s %-40s", ' ' x $spc2, $arg);

} else {

push @rv , sprintf("%s '%s'", ' ' x $spc2, $arg);

}

if (ref $arg eq 'Tk::Ev') {

if ($arg =~ /SCALAR/) {

push @rv , sprintf(": '$$arg'");

} else {

push @rv , sprintf(": '", join("' '", @$arg), "'");

}

push @rv , sprintf("\n");

} # forend callback arguments

} # ifend callback

} # forend all bindings for one tag

} # ifend have bindings

} # forend all tags

push @rv , sprintf("\n");

return @rv;

} # end bindDump

## ctk: other code

## ctk: eof 2007 11 13 - 15:52:17

1; ## make perl compiler happy...

Logfile

2007 11 13 - 16:26:49 . , perl.exe

2007 11 13 - 16:26:49 ctk_w.exe starting under 'MSWin32'

2007 11 13 - 16:26:49 Session 'Tkadmin' successfully restored.

2007 11 13 - 16:26:49 Version '3.099'

2007 11 13 - 16:26:49 Widget class Tk::Pane does not exist yet, discarded

2007 11 13 - 16:26:49 Widget class Tk::TextList does not exist yet, discarded

2007 11 13 - 16:26:58 set_selected 'mw.wr_001'

2007 11 13 - 16:26:59 set_selected 'mw.wr_001'

2007 11 13 - 16:26:59 edit_widgetOptions

2007 11 13 - 16:26:59 re_enter

2007 11 13 - 16:26:59 pr{'-background'} = 'color'

2007 11 13 - 16:26:59 pr{'-foreground'} = 'color'

2007 11 13 - 16:26:59 pr{'-width'} = 'int+'

2007 11 13 - 16:26:59 pr{'-setgrid'} = 'menu(0|1)'

2007 11 13 - 16:26:59 pr{'-borderwidth'} = 'int+'

2007 11 13 - 16:26:59 pr{'-height'} = 'int+'

2007 11 13 - 16:26:59 pr{'-selectmode'} = 'menu(single|browse|multiple|extended)'

2007 11 13 - 16:26:59 pr{'-relief'} = 'relief'

2007 11 13 - 16:26:59 pr{'-scrollbars'} = 'menu(s|os|e|oe|w|ow|n|on|se|ose|soe|osoe|sw|osw|sow|ne|one|noe|onoe|nw|onw|now|onow)'

2007 11 13 - 16:26:59 split_opt opt = 'Listbox , -background , #c0c0c0 , -selectmode , single , -scrollbars , osoe'

2007 11 13 - 16:26:59 split_opt rv = -background #c0c0c0 -selectmode single -scrollbars osoe

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 color_Picker

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 color_Picker

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 split_opt opt = '-side=>top, -anchor=>nw, -pady=>5, -fill=>both, -expand=>1, -padx=>5'

2007 11 13 - 16:26:59 split_opt rv = -side top -anchor nw -pady 5 -fill both -expand 1 -padx 5

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 SideMenu

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 side

2007 11 13 - 16:26:59

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 side

2007 11 13 - 16:26:59 left

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 side

2007 11 13 - 16:26:59 bottom

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 side

2007 11 13 - 16:26:59 top

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 side

2007 11 13 - 16:26:59 top

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 side

2007 11 13 - 16:26:59 right

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 AnchorMenu

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 anchor

2007 11 13 - 16:26:59

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 anchor

2007 11 13 - 16:26:59 nw

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 anchor

2007 11 13 - 16:26:59 nw

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 anchor

2007 11 13 - 16:26:59 w

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 anchor

2007 11 13 - 16:26:59 sw

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 anchor

2007 11 13 - 16:26:59 n

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 anchor

2007 11 13 - 16:26:59 center

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 anchor

2007 11 13 - 16:26:59 s

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 anchor

2007 11 13 - 16:26:59 ne

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 anchor

2007 11 13 - 16:26:59 e

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 anchor

2007 11 13 - 16:26:59 se

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 FillMenu

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 fill

2007 11 13 - 16:26:59

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 fill

2007 11 13 - 16:26:59 x

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 fill

2007 11 13 - 16:26:59 y

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 fill

2007 11 13 - 16:26:59 both

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 fill

2007 11 13 - 16:26:59 both

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry01

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry01

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry01

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry01

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 numEntry

2007 11 13 - 16:26:59 cnf_dlg_ballon

2007 11 13 - 16:26:59 FillMenu

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 fill

2007 11 13 - 16:26:59

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 fill

2007 11 13 - 16:26:59 x

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 fill

2007 11 13 - 16:26:59 y

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 fill

2007 11 13 - 16:26:59 both

2007 11 13 - 16:26:59 map_pic

2007 11 13 - 16:26:59 fill

2007 11 13 - 16:26:59 both