home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _40fae8ef3dc5022b12972a1936d4c975 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.2 KB  |  88 lines
  1. # NOTE: Derived from blib\lib\Tk\Widget.pm.
  2. # Changes made here will be lost when autosplit is run again.
  3. # See AutoSplit.pm.
  4. package Tk::Widget;
  5.  
  6. #line 1358 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\bindDump.al)"
  7. sub bindDump {
  8.  
  9.     # Dump lots of good binding information.  This pretty-print subroutine
  10.     # is, essentially, the following code in disguise:
  11.     #
  12.     # print "Binding information for $w\n";
  13.     # foreach my $tag ($w->bindtags) {
  14.     #     printf "\n Binding tag '$tag' has these bindings:\n";
  15.     #     foreach my $binding ($w->bind($tag)) {
  16.     #         printf "  $binding\n";
  17.     #     }
  18.     # }
  19.  
  20.     my ($w) = @_;
  21.  
  22.     my (@bindtags) = $w->bindtags;
  23.     my $digits = length( scalar @bindtags );
  24.     my ($spc1, $spc2) = ($digits + 33, $digits + 35);
  25.     my $format1 = "%${digits}d.";
  26.     my $format2 = ' ' x ($digits + 2);
  27.     my $n = 0;
  28.  
  29.     my @out;
  30.     push @out, sprintf( "\n## Binding information for '%s', %s ##", $w->PathName, $w );
  31.  
  32.     foreach my $tag (@bindtags) {
  33.         my (@bindings) = $w->bind($tag);
  34.         $n++;                   # count this bindtag
  35.  
  36.         if ($#bindings == -1) {
  37.             push @out, sprintf( "\n$format1 Binding tag '$tag' has no bindings.\n", $n );
  38.         } else {
  39.             push @out, sprintf( "\n$format1 Binding tag '$tag' has these bindings:\n", $n );
  40.  
  41.             foreach my $binding ( @bindings ) {
  42.                 my $callback = $w->bind($tag, $binding);
  43.                 push @out, sprintf( "$format2%27s : %-40s\n", $binding, $callback );
  44.  
  45.                 if ($callback =~ /SCALAR/) {
  46.                     if (ref $$callback) {
  47.                         push @out, sprintf( "%s %s\n", ' ' x $spc1, $$callback );
  48.                     } else {
  49.                         push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $$callback );
  50.                     }
  51.                 } elsif ($callback =~ /ARRAY/) {
  52.                     if (ref $callback->[0]) {
  53.                         push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0], "\n" );
  54.                     } else {
  55.                         push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n" );
  56.                     }
  57.                     foreach my $arg (@$callback[1 .. $#{@$callback}]) {
  58.                         if (ref $arg) {
  59.                             push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg );
  60.                         } else {
  61.                             push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg );
  62.                         }
  63.             
  64.                         if (ref $arg eq 'Tk::Ev') {
  65.                             if ($arg =~ /SCALAR/) {
  66.                                 push @out, sprintf( ": '$$arg'" );
  67.                             } else {
  68.                                 push @out, sprintf( ": '%s'", join("' '", @$arg) );
  69.                             }
  70.                         }
  71.  
  72.                         push @out, sprintf( "\n" );
  73.                     } # forend callback arguments
  74.                 } # ifend callback
  75.  
  76.             } # forend all bindings for one tag
  77.  
  78.         } # ifend have bindings
  79.  
  80.     } # forend all tags
  81.     push @out, sprintf( "\n" );
  82.     return @out;
  83.  
  84. } # end bindDump
  85.  
  86. # end of Tk::Widget::bindDump
  87. 1;
  88.