1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
# NOTE: Derived from blib\lib\Tk\Widget.pm.
# Changes made here will be lost when autosplit is run again.
# See AutoSplit.pm.
package Tk::Widget;
#line 1432 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\bindDump.al)"
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->Tk::bind($tag)) {
# printf " $binding\n";
# }
# }
my ($w) = @_;
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;
my @out;
push @out, sprintf( "\n## Binding information for '%s', %s ##", $w->PathName, $w );
foreach my $tag (@bindtags) {
my (@bindings) = $w->Tk::bind($tag);
$n++; # count this bindtag
if ($#bindings == -1) {
push @out, sprintf( "\n$format1 Binding tag '$tag' has no bindings.\n", $n );
} else {
push @out, sprintf( "\n$format1 Binding tag '$tag' has these bindings:\n", $n );
foreach my $binding ( @bindings ) {
my $callback = $w->Tk::bind($tag, $binding);
push @out, sprintf( "$format2%27s : %-40s\n", $binding, $callback );
if ($callback =~ /SCALAR/) {
if (ref $$callback) {
push @out, sprintf( "%s %s\n", ' ' x $spc1, $$callback );
} else {
push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $$callback );
}
} elsif ($callback =~ /ARRAY/) {
if (ref $callback->[0]) {
push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0] );
} else {
push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0] );
}
foreach my $arg (@$callback[1 .. $#$callback]) {
if (ref $arg) {
push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg );
} else {
push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg );
}
if (ref $arg eq 'Tk::Ev') {
if ($arg =~ /SCALAR/) {
push @out, sprintf( ": '$$arg'" );
} else {
push @out, sprintf( ": '%s'", join("' '", @$arg) );
}
}
push @out, sprintf( "\n" );
} # forend callback arguments
} # ifend callback
} # forend all bindings for one tag
} # ifend have bindings
} # forend all tags
push @out, sprintf( "\n" );
return @out;
} # end bindDump
# end of Tk::Widget::bindDump
1;
|
