diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 15:53:26 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 15:53:26 +0000 |
commit | 2acf4c9396e980e00adbdc02f5a70eefc7122b55 (patch) | |
tree | f0dd76ad4357b54e9b97cf618554cefadea99d48 /Master/tlpkg/tlperl/lib/auto/Tk/Widget/bindDump.al | |
parent | 2de20e5e6fe9f53f36acef44253e9e0b19a4bdb8 (diff) |
New tlperl part VI
git-svn-id: svn://tug.org/texlive/trunk@21428 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/auto/Tk/Widget/bindDump.al')
-rw-r--r-- | Master/tlpkg/tlperl/lib/auto/Tk/Widget/bindDump.al | 87 |
1 files changed, 87 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/auto/Tk/Widget/bindDump.al b/Master/tlpkg/tlperl/lib/auto/Tk/Widget/bindDump.al new file mode 100644 index 00000000000..a11fd56468d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/auto/Tk/Widget/bindDump.al @@ -0,0 +1,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], "\n" ); + } else { + push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n" ); + } + 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; |