Fwd: (fwd) binding to a derived canvas widget

>
> Hi,
> Generally I avoid these problems, by not using objects and
> modules, but I wanted to try and put this in a module form. :-)

Great, properly packaged, a mega-widget "module" can be easily reused  
by the average Perl/Tk programmer. You spend the time and effort up  
front and we all take advantage of that later on :)

Hmm, orange smoke ... mumble, mumble ... installing File- 
Slurp-9999.12, File-Slurp-Tree, Number-Compare-0.01, Text-Glob-0.06,  
File-Find-Rule-0.28 .., ah, now I can begin testing! Okay, ready or  
not, let's talk about bindings, bindtags, mega-widgets (Scrolled, no  
less) and maybe more stuff.  This is just how I see things and what  
I'd likely do ...

>
> I'm working on a canvas based module to simulate the

Technically you are writing a derived mega-widget, in this case, you  
are extending the capabilities of the Canvas widget. You started with  
this code:

    package Tk::CanvasDirTree;
    use base  qw/Tk::Derived Tk::Canvas/;
    Construct Tk::Widget 'CanvasDirTree';

which just created a new CanvasDirTree widget, derived from a Canvas,  
that behaves *exactly* line a Canvas widget.  And in 3 lines of code,  
pretty amazing, I'd say.

>
> My problem is how to bind to the widget, from a main script with
> a Button-1 click.  Internally, in the object,  I use Canvasbind to
> bind Button-1, to activate the animation, and select a sub-directory.

That works because you wrote this in Populate(), the place where  
CanvasDirTree mega-widgets are instantiated:

    $self->{'can'}->CanvasBind( '<Button-1>' => [\&pick_one, $self] );

You have bound B1 to the actual Canvas widget (more on the apparent  
need for $self->{'can'} as we proceed).  So far, so good, when the  
user clicks B1 they invoke your callback code, the behavior you added  
that extends the capabilities of the standard Canvas widget.

>
> But when I try to bind Button-1  from the main script, to get the
> selected directory, it only works if I bind from $mw, and not from
> the $ztree. This presents problems, because I'm binding to everything
> in the mainwindow, and just shouldn't be done that way.

Correct, the act of clicking B1 sends the event to the window that  
the pointer is in. When you actually made the binding, in your main  
code outside the mega-widget, like this:

    $ztree->bind( '<Button-1>', sub{ ... } );

because $ztree ISA Canvas (you're writing a derived mega-widget), the  
Canvas bind() method was invoked instead of the "real" bind()  
method.  In Tcl, the bind command cannot be confused with the Canvas  
widget's bind subcommand.

Enter Tk::bind.  Tk::bind was externalized precisely to disambiguate  
the two bind() methods, so you could create bindings on Canvas  
widgets.  Thus, if you write $canvas->bind() you're calling the  
Canvas bind() method, but if you write $canvas->Tk::bind() you're  
calling the normal bind() method that every other widget uses to  
create bindings. Later on in Perl/Tk's development the Canvas method  
CanvasBind() was added as syntactic sugar for Tk::bind.

The command Tk::bindDump is really helpful in debugging binding  
oddities.  Strangely enough, I found a bug in it when examining your  
mega-widget: I needed to use Tk::bind in one place!  Oh, and it  
doesn't dump Canvas item bindings, that would be a nice addition if  
anyone is interested. The corrected version is at http:// 
www.lehigh.edu/~sol0/ptk/bindDump.pm.

>
> So run this script in a directory with some subdirs in it. I have it
> setup to work (almost) the way I want, but I'm binding Button-1
> to $mw, and I want to bind it only to $ztree.  (The bind statements
> are at the bottom, about 10 lines from the end).
>
> It has to be something simple, but I've already tried a bunch of
> different things, and figure that I am missing the trick on how to
> handle multiple binding.  I've read perldoc Tk::bind, and it said that
> if multiple bindings are made to say Button-1, the callback from the
> class will be called first, then the one from main. BUT the main isn't
> being called in this example.....that is the problem.

So, how do we fix the problem?  A first stab might be to use Tk::bind  
in the main code, and while that actually creates a binding on the  
Tk::CanvasDirTree object, it's not very useful because the only  
widget visible to click on is the Canvas! (The Delegates() method  
might be useful, but that's another discussion.)  And if a user went  
digging around the object and found the actual Canvas reference and  
then set her B1 binding to the Canvas, it would clobber the mega- 
widget's B1 binding.

We want the user to do the "natural" thing and be able to place  
standard bindings on the mega-widget, but that means we (well, you,  
the mega-widget developer) have to work a little bit harder.

The first thing you want to do (probably) is override the Tk::Canvas  
bind() method - that your derived Tk::CanvasDirTree mega-widget  
inherits -  with one that calls Tk::bind (or CanvasBind), like this:

    sub bind {
        my( $self, @args ) = @_;
        $self->{'real_can'}->Tk::bind( @args );
    }

Notice the use of self->{'real_can'}, more on that later.  I  
mentioned I also had something to say about $self->{'can'}.  The  
topics are related! The important point to realize is that this  
intercepts the user's bind() call on the Tk::CanvasDirTree widget and  
redirects it to the Canvas widget, rather than attempting to create a  
binding on a Canvas item.

Implicit in all this is the realization that, from a user of this  
mega-widget's perspective, a CanvasDirTree widget is in fact not a  
Canvas, and they have no need to do structured graphics using it.   
Thus, they will not be creating Canvas items, nor placing bindings on  
those items. Hey, perhaps a name change is required?

So, where do we stand?  Well, the user can now bind to your new mega- 
widget in the standard manner and it will work:

    $ztree->bind( '<Button-1>', sub{..));

But the class B1 binding, below, that you created, no longer works  
because it's been replaced:

    $self->{'can'}->CanvasBind( '<Button-1>' => [\&pick_one, $self] );

Here's that little bit of extra work you need to do: use binding  
tags.  Create a new, class-private tag, and bind B1 to the new tag.  
Leave the "standard tag(s)" to the user.

Here's how to do it (in Populate):

    $self->{'real_can'} = $self->{'can'}->Subwidget('scrolled');  
######## more on this later
    my( @bindtags ) = $self->{'real_can'}->bindtags;
    $self->{'real_can'}->bindtags( [ @bindtags, 'CanvasDirTree-B1' ] );
    $self->{'real_can'}->CanvasBind( 'CanvasDirTree-B1', '<Button-1>'  
=> [\&pick_one, $self] );

What the above code does is simply add a new bindtag named  
'CanvasDirTree-B1' to the list of bindtags associated with the widget  
(the "real canvas"), then sets a B1 button binding.  The result?   
When B1 is clicked over the Canvas both the class callback and user  
callback are executed, simply because Tk traverses the bindtags list,  
executing callbacks in bindtags order.

So, problem solved, with 8-ish lines of code, and a boatload of  
internals knowledge :)  My explanation was fast-paced, I hope it made  
sense.

But, there's one more thing .... I have suggestions for improving the  
fine structure of your mega-widget. I can simplify it and bring it  
inline with Perl/Tk conventions, if you do not mind.


------------------ Intermission ------------------


> package CanvasDirTree;
> use base  qw/Tk::Derived Tk::Canvas/;
> Construct Tk::Widget 'CanvasDirTree';

Your prolog, above, is fine, as we've seen.

Below, we come to various methods that the mega-widget writer may  
provide, that will override place-holders in a base class. We'll look  
at only three:  ClassInit(), SetBindtags(), and Populate().

>
> sub ClassInit
> {
>     my ($class, $mw) = @_;
>     $class->SUPER::ClassInit($mw);
> }

No problem with the above. So what if it doesn't do anything now, it  
might in the future.  It initializes the class (Tk::CanvasDirTree),  
and is called exactly once.

>
> sub SetBindtags {
>     my($self) = @_;
>     $self->SUPER::SetBindtags;
> }

Another place holder that does nothing.  Yet, we have a need to set  
bindtags.  Unlike ClassInit(), this method is called as each object  
(Tk::CanvasDirTree) is instantiated.  We'll need to make a few  
changes to the original CanvasDirTree code to take advantage of this.

>
> ######################################################
> sub Populate {
>    my ($self, $args) = @_;

Subroutine/method Populate() adds behavior and/or widgets that extend  
the basic Canvas.  By adding behavior - bindings and/or other widgets  
- it makes a CanvasDirTree what it is.

>
>   #-------------------------------------------------------------------
>    #take care of args which don't belong to the SUPER, see Tk::Derived
>    foreach my $extra ('backimage','imx','imy','dir','font','indfilla',
>                        
> 'indfilln','fontcolorn','fontcolora','scrollbars')
> {
>        my $xtra_arg = delete $args->{ "-$extra" };  #delete and read
> same time
>      if( defined $xtra_arg ) { $self->{$extra} = $xtra_arg }
>    }
>    #-----------------------------------------------------------------
>     #set some defaults
>     $self->{'indfilla'} ||= 'red';
>     $self->{'indfilln'} ||= 'pink';
>     $self->{'fontcolorn'} ||= 'black';
>     $self->{'fontcolora'} ||= 'red';
>     $self->{'scrollbars'} ||= 'osw';
>     $self->{'backimage'} ||= '';
>     $self->{'bimage'} ||= '';
>     $self->{'imx'} ||= 0;
>     $self->{'imy'} ||= 0;

For the above, I'd use ConfigSpecs(), it's the standard way of  
handling options.

>
>    $self->{'can'} = $self->Scrolled('Canvas',
>                     -scrollbars => $self->{'scrollbars'},
>                 );
>
>    $self->{'real_can'} = $self->{'can'}->Subwidget('scrolled');


OK, here's where I'd do things very differently.  First, because  
Tk::CanvasDirTree ISA Canvas, by definition $self ISA Canvas.  It's  
important to realize that you do not need to explicitly create a new  
Canvas - you already are a Canvas! At this point in mega-widget  
creation you are a Canvas and can invoke any Canvas method you'd like  
upon $self. Remember that 3-line code preamble I showed?  That's the  
magic that makes all this possible!

What we have now is a second - Scrolled! - Canvas inside another (the  
original, derived) Canvas. And now let the complications begin.

The Scrolled method is the coolest thing around, it automatically  
scrolls widgets in the X and Y directions.  Scrollbars can be  
entirely optional, popping into existence only when needed, or always  
present.  Scrolled works by first creating a Frame, and packing  
within the Frame the desired widget and its requisite Scrollbars. The  
widget reference returned by the Scrolled() method points to the  
enclosing Frame, not the scrolled widget.

So a Tk::CanvasDirTree widget hierarchy, as currently defined, looks  
something like this:

Tk::CanvasDirTree EQU Tk::Canvas
   Tk::Frame
     Tk::Canvas

So we have a Canvas underneath a Frame enclosing another Canvas  
(ignoring any Scrollbars). And now we come back to $self->{can}  
versus $self->{'real_can'}, as promised.

$self->{'can'} references the outer scrolled Frame, not the Canvas.   
So you use Subwidget() to get the actual object that's being scrolled  
and save that as $self->{'real_can'}. Now some code uses $self-> 
{'can'}, but other code needs to use $self->{'real_can'}, and things  
become confusing fast!

Simply by removing the unneeded Scrolled widget we'll see how things  
become much simpler.  For instance, here's what the new overridden  
bind command now looks like:

    sub bind {
        my( $self, @args ) = @_;
        $self->CanvasBind( @args );
    }

What's more, we can move the bindtags code out of Populate and make  
use of SetBindTags:

    sub SetBindtags {
        my($self) = @_;
        $self->SUPER::SetBindtags;
        my( @bindtags ) = $self->bindtags;
        $self->bindtags( [ @bindtags, 'CanvasDirTree-B1' ] );
    }

We couldn't do this before because SetBindTags() is called before  
Populate(), before the Scrolled Canvas is created, so the instance  
variable $self->{'real_can'} is undefined. Plus, the 40-ish places  
where the {'can'} and {'real_can'} instance variable are used can all  
be thrown away - $self is sufficient.

>
>    $self->SetBindtags();

The above explicit call to SetBindTags() in not needed, as Perl/Tk  
calls out to it automatically when instantiating a mega-widget.

We can make the actual B1 binding simpler too:

     $self->CanvasBind( 'CanvasDirTree-B1', '<Button-1>' =>  
'pick_one' );



> ###################################################################### 
> ######
> sub pick_one {
>      my ($canvas, $self) = @_;
>      my $item = $self->{'can'}->find('withtag','current'); #returns  
> aref

Which also makes pick_one simpler:

     sub pick_one {
          my ($self) = @_;
          my $item = $self->find('withtag','current'); #returns aref


In summary, if you remove the (really unneeded) Scrolled Canvas you:

. carry less baggage around because the widget hierarchy goes from  
Canvas/Frame/Canvas to just Canvas
. simplify the code and make it more readable
. conform to the mega-widget coding scheme, ensuring your new class  
behaves consistently

And if I want scrollbars on my Tk::CanvasDirTree widget, then by  
golly I can just do this:

my $ztree = $mw->Scrolled( 'CanvasDirTree', -scrollbars =>'osw' );

Don't forget the pod documentation :)

Steve


-++**==--++**==--++**==--++**==--++**==--++**==--++**==
This message was posted through the Stanford campus mailing list
server.  If you wish to unsubscribe from this mailing list, send the
message body of "unsubscribe ptk" to [email protected]