home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / bindDump.al < prev    next >
Encoding:
Text File  |  2003-12-16  |  3.0 KB  |  89 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 1383 "blib\lib\Tk\Widget.pm (autosplit into blib\lib\auto\Tk\Widget\bindDump.al)"
  7. 1;
  8. __END__
  9.  
  10. sub bindDump {
  11.  
  12.     # Dump lots of good binding information.  This pretty-print subroutine
  13.     # is, essentially, the following code in disguise:
  14.     #
  15.     # print "Binding information for $w\n";
  16.     # foreach my $tag ($w->bindtags) {
  17.     #     printf "\n Binding tag '$tag' has these bindings:\n";
  18.     #     foreach my $binding ($w->bind($tag)) {
  19.     #         printf "  $binding\n";
  20.     #     }
  21.     # }
  22.  
  23.     my ($w) = @_;
  24.  
  25.     my (@bindtags) = $w->bindtags;
  26.     my $digits = length( scalar @bindtags );
  27.     my ($spc1, $spc2) = ($digits + 33, $digits + 35);
  28.     my $format1 = "%${digits}d.";
  29.     my $format2 = ' ' x ($digits + 2);
  30.     my $n = 0;
  31.  
  32.     print "\n## Binding information for '", $w->PathName, "', $w ##\n";
  33.  
  34.     foreach my $tag (@bindtags) {
  35.         my (@bindings) = $w->bind($tag);
  36.         $n++;                   # count this bindtag
  37.  
  38.         if ($#bindings == -1) {
  39.             printf "\n$format1 Binding tag '$tag' has no bindings.\n", $n;
  40.         } else {
  41.             printf "\n$format1 Binding tag '$tag' has these bindings:\n", $n;
  42.  
  43.             foreach my $binding ( @bindings ) {
  44.                 my $callback = $w->bind($tag, $binding);
  45.                 printf "$format2%27s : %-40s\n", $binding, $callback;
  46.  
  47.                 if ($callback =~ /SCALAR/) {
  48.                     if (ref $$callback) {
  49.                         printf "%s %s\n", ' ' x $spc1, $$callback;
  50.                     } else {
  51.                         printf "%s '%s'\n", ' ' x $spc1, $$callback;
  52.                     }
  53.                 } elsif ($callback =~ /ARRAY/) {
  54.                     if (ref $callback->[0]) {
  55.                         printf "%s %s\n", ' ' x $spc1, $callback->[0], "\n";
  56.                     } else {
  57.                         printf "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n";
  58.                     }
  59.                     foreach my $arg (@$callback[1 .. $#{@$callback}]) {
  60.                         if (ref $arg) {
  61.                             printf "%s %-40s", ' ' x $spc2, $arg;
  62.                         } else {
  63.                             printf "%s '%s'", ' ' x $spc2, $arg;
  64.                         }
  65.             
  66.                         if (ref $arg eq 'Tk::Ev') {
  67.                             if ($arg =~ /SCALAR/) {
  68.                                 print ": '$$arg'";
  69.                             } else {
  70.                                 print ": '", join("' '", @$arg), "'";
  71.                             }
  72.                         }
  73.  
  74.                         print "\n";
  75.                     } # forend callback arguments
  76.                 } # ifend callback
  77.  
  78.             } # forend all bindings for one tag
  79.  
  80.         } # ifend have bindings
  81.  
  82.     } # forend all tags
  83.     print "\n";
  84.  
  85. } # end bindDump
  86.  
  87. # end of Tk::Widget::bindDump
  88. 1;
  89.