$Tk::bindDump::VERSION = '1.0';

package Tk::bindDump;

use Exporter;

use base qw/Exporter/;
@EXPORT = qw/bindDump/;
use strict;

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 (@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;

    print "\n## Binding information for '", $w->PathName, "', $w ##\n";

    foreach my $tag (@bindtags) {
        my (@bindings) = $w->bind($tag);
        $n++;                   # count this bindtag

        if ($#bindings == -1) {
            printf "\n$format1 Binding tag '$tag' has no bindings.\n", $n;
        } else {
            printf "\n$format1 Binding tag '$tag' has these bindings:\n", $n;

            foreach my $binding ( @bindings ) {
                my $callback = $w->bind($tag, $binding);
                printf "$format2%27s : %-40s\n", $binding, $callback;

                if ($callback =~ /SCALAR/) {
                    if (ref $$callback) {
                        printf "%s %s\n", ' ' x $spc1, $$callback;
                    } else {
                        printf "%s '%s'\n", ' ' x $spc1, $$callback;
                    }
                } elsif ($callback =~ /ARRAY/) {
                    if (ref $callback->[0]) {
                        printf "%s %s\n", ' ' x $spc1, $callback->[0], "\n";
                    } else {
                        printf "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n";
                    }
                    foreach my $arg (@$callback[1 .. $#{@$callback}]) {
                        if (ref $arg) {
                            printf "%s %-40s", ' ' x $spc2, $arg;
                        } else {
                            printf "%s '%s'", ' ' x $spc2, $arg;
                        }
			
                        if (ref $arg eq 'Tk::Ev') {
                            if ($arg =~ /SCALAR/) {
                                print ": '$$arg'";
                            } else {
                                print ": '", join("' '", @$arg), "'";
                            }
                        }

                        print "\n";
                    } # forend callback arguments
                } # ifend callback

            } # forend all bindings for one tag

        } # ifend have bindings

    } # forend all tags
    print "\n";

} # end bindDump

1;
__END__

=head1 NAME

Tk::bindDump - dump detailed binding information for a widget.

=head1 SYNOPSIS

 use Tk::bindDump;

 $splash->bindDump;

=head1 DESCRIPTION

This subroutine prints a widget's bindtags.  For each binding tag it
prints all the bindings, comprised of the event descriptor and the
callback.  Callback arguments are printed, and Tk::Ev objects are
expanded.

=head1 COPYRIGHT

Copyright (C) 2000 - 2001 Stephen O. Lidie. All rights reserved.

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut
