PerlTk - Fwd: (fwd) binding to a derived canvas widget

Author

Fwd: (fwd) binding to a derived canvas widget

Steve Lidie

2006-04-02, 10:00 pm

>
> 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

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','i
ndfilla',
>
> 'indfilln','fontcolorn','fontcolora','sc
rollbars')
> {
> 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

est 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 majordomo@lists.stanford.edu

zentara

2006-04-03, 8:04 am

On Sun, 2 Apr 2006 21:02:02 +0000 (UTC), Steve Lidie <sol0@Lehigh.EDU>
wrote:

>
>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!

Yeah sorry about that. I removed those modules and went back directly
to opendir. See http://perlmonks.org?node_id=540439 I put it there, to
avoid redundant posting here. Originally I thought they would be
faster, but they were not.

>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 ...

.........detailed lesson on bind snipped for
brevity......................

>
>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

Wow, thanks for the detailed explanation of the bind inner workings.
I'll start working on switching to ConfigSpecs(), and bindTags fixes and
I will have to read this about 20 times for it to really sink in.

I have one question I was going to ask. I did remove the $self->{'can'},
and made $self the canvas. But now I have need to directly manipulate
the scrollbars from the object. Since this DirCantree can have a
background image, I would like to get fancy, and attempt to "slide" the
image with the scrollbars. So the image would appear to be stationary.
So how can I get to the x and y scrollbars from the canvas? When the
object is created with the scrolled method?

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

So now, how do I refer to the scrollbars from $self?

Thanks.

--
I'm not really a human, but I play one on earth.
http://zentara.net/japh.html

Ch Lamprecht

2006-04-03, 7:03 pm

Steve Lidie wrote:

> 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 ...
>
>
-snip
>
> 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.
>
-snip
> sub SetBindtags {
> my($self) = @_;
> $self->SUPER::SetBindtags;
> my( @bindtags ) = $self->bindtags;
> $self->bindtags( [ @bindtags, 'CanvasDirTree-B1' ] );
> }
>
-snip
> We can make the actual B1 binding simpler too:
>
> $self->CanvasBind( 'CanvasDirTree-B1', '<Button-1>' =>
> 'pick_one' );
>

Hi,

thanks a lot for this lesson!
There is one question I would like to ask:
Do you refer to the class-tag when recommending to leave the "standard
tag(s)" to the user? If so, shouldn't we rearrange the order of
@bindtags to make sure, that bindings to our 'class_private_tag' are
executed *before* the class-bindings - and before the instance-bindings
of course?

In cases like this, where the users binding depends on our classes
binding beeing executed first, things might not work as expected otherwise.

Christoph

--

perl -e "print scalar reverse q/ed.enilno@ergn.l.hc/"

Steve Lidie

2006-04-04, 7:00 pm

Hi Christoph;

Ch Lamprecht <christoph.lamprecht.no.spam@web.de> wrote:
> Steve Lidie wrote:
>
> -snip
> -snip
> -snip
>
> Hi,
>
> thanks a lot for this lesson!
> There is one question I would like to ask:
> Do you refer to the class-tag when recommending to leave the "standard
> tag(s)" to the user? If so, shouldn't we rearrange the order of
> @bindtags to make sure, that bindings to our 'class_private_tag' are
> executed *before* the class-bindings - and before the instance-bindings
> of course?

You make a very good point, and this is commonly done. I think one needs
to handle this on a case-by-case basis, so the phrase "leave the standard
tags to the user" shouldn't necessarily be taken to literally!

>
> In cases like this, where the users binding depends on our classes
> binding beeing executed first, things might not work as expected otherwise.
>

In other cases where there is no direct dependence I will leave that
up to the mega-widget writer to resolve :) I just wanted to point out
some bindtags usage, and how one can customize event bindings by
removing, adding, changing or overriding the list of binding tags.

*** Free account sponsored by SecureIX.com ***
*** Encrypt your Internet usage with a free VPN account from http://www.SecureIX.com ***

Nick Ing-Simmons

2006-04-05, 7:01 pm

Steve Lidie <sol0@lehigh.edu> writes:
>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] );

All that is fine. But bindtags includes the name of the class already.
This is so that one can assoicate class bindings with it.

So what I intended for one to do was:

$self->{'real_can'}->CanvasBind( ref($self), '<Button-1>' ...);

But that is I hope unnecessarily complicated - see below.
[color=darkred]

What that will do by the way is call Canvas::ClassInit.
This isn't quite a no-op - it calls XYscrollBind
Which binds mouse wheel and <Up>, <Down> etc. so that
scrolls happen (if widget has the focus for keystroke cases).

Once that has happened - and of course if you don't want
that you don't have to call it!
We can now add bindings to the class name.
Which would look like:

$mw->bind( $class, '<Button-1>', 'pick_one' );[color=darkred]

At this point $mw is _a_ widget (the MainWindow) which is all we need
to talk to core Tk. It isn't a Canvas so no spurious binds are in scope.
And it is called as a "static" method so 1st arg is the class name.
As 'pick_one' is a sub in our class we treat it as a method just use its
name in the binding.

When a particular _instance_ of the class gets a Button-1 the class binding
is called and the sub is called (as a method) passing the instance
widget as 1st arg. This achieves the same as original

... '<Button-1>' => [\&pick_one, $self] );

But with the additional advantage that if someone derives from _your_
class they can override the pick_one method if your pick_one isn't
quite what they want.

-++**==--++**==--++**==--++**==--++**==--++**==--++**==
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 majordomo@lists.stanford.edu

Sponsored Links