PerlTk - binding to a derived canvas widget

Author

binding to a derived canvas widget

zentara

2006-03-29, 7: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. :-)

I'm working on a canvas based module to simulate the
gtk2 style tree widget. This basically will show directories
in a scrolled Canvas, with a little rotating indicator to open and
close directories. It will also allow a background image, from
file or a Tk::Photo object from the script.

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.

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.

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.

#!/usr/bin/perl
use warnings;
use strict;
use Tk;

########################################
##################
package CanvasDirTree;
use warnings;
use strict;
use Tk::widgets qw/Canvas/;
use base qw/Tk::Derived Tk::Canvas/;
use File::Spec;
use Tk::JPEG;
use Tk::PNG;
use File::Find::Rule;
use File::Slurp::Tree;

Construct Tk::Widget 'CanvasDirTree';

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

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

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

$self->SUPER::Populate($args);

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

# $self->{'real_can'} = $self->{'can'}->Subwidget('scrolled');

if( length $self->{'backimage'} > 0 ){
$self->set_background(
$self->{'backimage'},$self->{'imx'}, $self->{'imy'}
);
}

$self->{'can'}->pack( -fill =>'both', -expand => 1);

$self->{'font'} ||= 'system';

#---determine font spacing by making a capital W---
my $fonttest = $self->{can}->createText(0,0,
-fill => 'black',
-text => 'W',
-font => $self->{'font'},
);

my ($bx,$by,$bx1,$by1) = $self->{'can'}->bbox($fonttest);
$self->{'f_width'} = $bx1 - $bx;
$self->{'f_height'} = $by1 - $by;
$self->{'can'}->delete($fonttest);
#--------------------------------------------------

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

# find all the subdirectories of a given directory
$self->{'rule1'} = File::Find::Rule->new;
$self->{'rule1'}->directory;
$self->{'rule1'}->maxdepth(2);

# find the files in a directory
$self->{'rule2'} = File::Find::Rule->new;
$self->{'rule2'}->file;

$self->SetBindtags();

$self->make_trunk('.', 0);

} # end Populate

########################################
#####################

sub adjust_background{
my ($self, $photo_obj ) = @_;

$self->{'can'}->delete( $self->{'background'} );

$self->{'bimage'} = $photo_obj;
$self->{'bimg_w'} = $self->{'bimage'}->width;
$self->{'bimg_h'} = $self->{'bimage'}->height;

$self->{'background'} = $self->{'can'}->createImage(

$self->{'imx'}, $self->{'imy'},
-anchor => 'nw',
-image => $self->{'bimage'},
);
}
########################################
####################
sub set_background{
my( $self, $image ,$xim, $yim) = @_;

$self->{'backimage'} = $image;
$self->{'imx'} = $xim;
$self->{'imy'} = $yim;

if( ref $image eq 'Tk::Photo'){
$self->adjust_background($image)
}else{
my $photo_obj = $self->{'can'}->Photo( -file =>
$self->{'backimage'} );
$self->adjust_background( $photo_obj );
}
}
########################################
######################
sub make_trunk{

my ($self, $dir, $level) = @_;
my $x = 5; my $y = $self->{'f_height'};

my $tree = slurp_tree($dir, 'rule' => $self->{'rule1'} );
my $abs_root = File::Spec->rel2abs( $dir );

#for windows compat
$abs_root =~ tr#\\#/#;

$self->{'root_depth'} = ( $abs_root =~ tr#/#/# );

my $max = scalar keys %{$tree};
my $count = 0;

foreach my $subdir (sort keys %{$tree} ){

my $abs_path = "$abs_root/$subdir";
my $subdir_count = scalar keys %{ $tree->{$subdir} };

#make open indicator---------------------------------------------
if( $subdir_count > 0 ){
my $ind = $self->{can}->createPolygon(
$x + .1 * $self->{'f_width'} , $y + $y * $count - .3
* $self->{'f_height'},
$x + .5 * $self->{'f_width'}, $y + $y * $count,
$x + .1 * $self->{'f_width'}, $y + $y * $count + .3
* $self->{'f_height'} ,

-fill => $self->{'indfilln'},
-activefill => 'yellow',
-outline => 'black',
-width => 1,
-activewidth => 2,
-tags => ['ind', $abs_path],
);
}
#------------------------------------------------------------
my $id = $self->{can}->createText(
$x + .8 * $self->{'f_width'}, $y + $y * $count + (.5
*$self->{'f_height'}),
-fill => $self->{'fontcolorn'},
-activefill => $self->{'fontcolora'},
-text => $subdir,
-font => $self->{'font'},
-anchor => 'sw',
-tags => ['list', $abs_path],
);
$count++;
}

my ($bx,$by,$bx1,$by1)= $self->{'can'}->bbox('all');
$self->{'can'}->configure(
-scrollregion =>[0,0,$bx1,$by1],
);

} # end make_trunk
########################################
####################################
sub pick_one {
my ($canvas, $self) = @_;

my $item = $self->{'can'}->find('withtag','current'); #returns aref
my @tags = $self->{'can'}->gettags($item->[0]);
$item = $item->[0];

$self->{'selected'} = ''; #default is no selection

if( grep { $_ eq 'ind' } @tags ){

@tags = grep { $_ ne 'ind' and $_ ne 'current'} @tags;
my $dir = $tags[0];

if( $self->{'can'}->itemcget($item, 'fill') eq
$self->{'indfilla'}){
$self->rotate_poly($item, -90, undef,undef);
$self->{'can'}->itemconfigure($item, 'fill' =>
$self->{'indfilln'} );
$self->close_branch($dir,$item);
}else{
$self->rotate_poly($item, 90, undef,undef);
$self->{'can'}->itemconfigure($item, 'fill' =>
$self->{'indfilla'} );
$self->add_branch($dir);
}
}else{
#picked up an indicator click by this point
#clicks on list items will be handled by get_selected
@tags = grep { $_ ne 'list' and $_ ne 'current'} @tags;
$self->{'selected'} = $tags[0];
}

} # end pick_one
########################################
############################
sub get_selected{
my ($self) = @_;

return $self->{'selected'};
}
########################################
###########################
sub add_branch{

my ($self, $abs_path) = @_;

#for windows compat
$abs_path =~ tr#\\#/#;

my $depth = ( $abs_path =~ tr#/#/# );
$depth = $depth - $self->{'root_depth'} + 2;

my $item;
foreach my $it( $self->{'can'}->find('withtag', $abs_path) ){
my @tags = $self->{'can'}->gettags($it);
if( grep { $_ eq 'list'} @tags ){ $item = $it }
}

my ($bx,$by,$bx1,$by1)= $self->{'can'}->bbox($item);
my $x = $bx + $self->{'f_width'};
my $y_edge = ($by + $by1)/2;
my $y = $by1;
my $count = 0;

$self->{'rule1'}->maxdepth( $depth );

my $rel_path = File::Spec->abs2rel( $abs_path );

#for windows compat
$rel_path =~ tr#\\#/#;

my $tree = slurp_tree( $rel_path, 'rule' => $self->{'rule1'} );

my $max = scalar keys %{$tree};
my $max_add = $max * $self->{'f_height'};

$self->make_space($y_edge,$max_add);

# add sub entries
foreach my $subdir (sort keys %{$tree} ){

my $abs_path1 = File::Spec->rel2abs("$abs_path/$subdir");
my $subdir_count = scalar keys %{ $tree->{$subdir} };

#for windows compat
$abs_path1 =~ tr#\\#/#;

#make open indicator---------------------------------------------
if( $subdir_count > 0 ){
my $ind = $self->{can}->createPolygon(
$x - .9 * $self->{'f_width'} , .5*$self->{'f_height'}+
$y + $self->{'f_height'}* $count - .3 * $self->{'f_height'},
$x - .5 * $self->{'f_width'}, .5*$self->{'f_height'}+
$y + $self->{'f_height'}* $count,
$x - .9 * $self->{'f_width'}, .5*$self->{'f_height'}+
$y + $self->{'f_height'}* $count + .3 * $self->{'f_height'} ,

-fill => $self->{'indfilln'},
-activefill => 'yellow',
-outline => 'black',
-width => 1,
-activewidth => 2,
-tags => ['ind', $abs_path1],
);

}
#------------------------------------------------------------
my $id = $self->{can}->createText(
$x , $y + $self->{'f_height'} * ($count + 1),
-fill => $self->{'fontcolorn'},
-activefill => $self->{'fontcolora'},
-text => $subdir,
-font => $self->{'font'},
-anchor => 'sw',
# -tags => ['list',$abs_path, $abs_path1],
-tags => ['list', $abs_path1],
);

#add tag to upstream indicator

$count++;
}

($bx,$by,$bx1,$by1)= $self->{'can'}->bbox('list');
$self->{'can'}->configure(
-scrollregion =>[0,0,$bx1,$by1],
);

} # end add_branch
########################################
####################################
sub close_branch{
my($self, $abs_path, $ind ) = @_;

my @y; my $x;

foreach my $it( $self->{'can'}->find('all') ){

my @tags = $self->{'can'}->gettags($it);

if( grep { $_ eq 'current'} @tags ){next}
if( grep { $_ eq $abs_path } @tags ){next}
if( grep { $_ =~ /^$abs_path(.*)/ } @tags ){
shift @tags; #shift off ind or list tag

if(scalar @tags > 0 ){
my ($bx,$by,$bx1,$by1)= $self->{'can'}->bbox( $tags[0]
);
push @y,$by;
push @y,$by1;
$self->{'can'}->delete($it);
}
}
}

my @sorted = sort {$a<=>$b} @y ;
my $amount = $sorted[-1] - $sorted[0];
my ($bx,$by,$bx1,$by1)= $self->{'can'}->bbox('all');

my @items = $self->{'can'}->find('enclosed',
$bx, $sorted[-1] - $self->{'f_height'} ,
$bx1, $by1 + $self->{'f_height'} );

foreach my $move (@items){
$self->{'can'}->move($move,0, -$amount);
}

#adjust scroll region
($bx,$by,$bx1,$by1)= $self->{'can'}->bbox('list');
$self->{'can'}->configure(
-scrollregion =>[0,0,$bx1,$by1],
);

}
########################################
######################################
sub make_space{
my ($self, $y, $amount) = @_;

my ($bx,$by,$bx1,$by1)= $self->{'can'}->bbox('all');

my @items = $self->{'can'}->find('enclosed',$bx,$y,$bx1,$by1 +
$self->{'f_height'});

foreach my $move (@items){
$self->{'can'}->move($move,0,$amount);
}

}
########################################
######################################

sub rotate_poly {
my ($self, $id, $angle, $midx, $midy) = @_;

# Get the old coordinates.
my @coords = $self->{'can'}->coords($id);

# Get the center of the poly. We use this to translate the
# above coords back to the origin, and then rotate about
# the origin, then translate back. (old)

($midx, $midy) = _get_CM(@coords) unless defined $midx;

my @new;

# Precalculate the sin/cos of the angle, since we'll call
# them a few times.
my $rad = 3.1416*$angle/180;
my $sin = sin $rad;
my $cos = cos $rad;

# Calculate the new coordinates of the line.
while (my ($x, $y) = splice @coords, 0, 2) {
my $x1 = $x - $midx;
my $y1 = $y - $midy;

push @new => $midx + ($x1 * $cos - $y1 * $sin);
push @new => $midy + ($x1 * $sin + $y1 * $cos);
}

# Redraw the poly.
$self->{'can'}->coords($id, @new);
}
########################################
#########################
# Slaven said:
# This sub finds the center of mass of a polygon.
# I grabbed the algorithm somewhere from the web.
# I grabbed it from Slaven Reszic's RotCanvas :-)
sub _get_CM {
my ($x, $y, $area);
my $i = 0;
while ($i < $#_) {
my $x0 = $_[$i];
my $y0 = $_[$i+1];

my ($x1, $y1);
if ($i+2 > $#_) {
$x1 = $_[0];
$y1 = $_[1];
} else {
$x1 = $_[$i+2];
$y1 = $_[$i+3];
}

$i += 2;

my $a1 = 0.5*($x0 + $x1);
my $a2 = ($x0**2 + $x0*$x1 + $x1**2)/6;
my $a3 = ($x0*$y1 + $y0*$x1 + 2*($x1*$y1 + $x0*$y0))/6;
my $b0 = $y1 - $y0;

$area += $a1 * $b0;
$x += $a2 * $b0;
$y += $a3 * $b0;
}

return split ' ', sprintf "%.0f %0.f" => $x/$area, $y/$area;
}

1;
########################################
###############################
package main;

my $mw = MainWindow->new();

$mw->fontCreate('big',
-family=>'arial',
-weight=>'bold',
-size=>int(-18*18/14));

my $frame = $mw->Frame()->pack(-expand=>1,-fill=>'both');

# base64encoded png
my $bunny = $mw->Photo(-data =>
'iVBORw0KGgoAAAANSUhEUgAAAB4AAAAjEAIAAAB
cJvHFAAAACXBIWXMAAAsSAAALEgHS3X78AAAD
F0lEQVR42u1YL+yqUBj1vfcLbhY3C44is8BIREYS
G9FoNBqNkok2aFhp2BhJDWyadCZN/ilOGxan
jRdOuRsPxl/f+23vJKfX7x6+73znu5dK5RviV9QPDMMwDIPP7/f7/X6XTWU0Go1Go06n0+l0PM/z
PC91CNu2bduWZVmW5bLpjsfj8XgcBEEQBJPJZDKZ
ZAw0n8/n8zkCGYZhGIYgCIIgFEt3OBwOh8OA
gKZpmqZlDDedTqfTKRnO933f95GVer1er9fz0BVF
URRFxCR3QfyMQfv9fr/fDyLgOI7jONmo419k
JUkMBoPBYJCRNBrxdrvdbrco6qvVarVaIWdFpQO/5tIcFBbE4nQ6nU6nJIpHjlGlEklTFEVRFDIa
T32/3+/ 3+3jqHMdxHBcfB2sK6HFFURRFeb1er9crfksoNUr
r0GvUfxGfnA+FmX+QALDItGLDA6O2
pQyCJFkPqxMDK2p9LodOAhQaLRjfoKRGo2wObl3G
8PoDsA0Gb5Q5oonjfSNKTh96AOh+u91ut1uS
FuZrONPJ7bJ06tA9TDDsD6QkCnDltEDRkV1Q9AnE
Nyuk8hcyChkkcZKo5uv1er1er3S6cAPkFXSx
MQodPrXFg2zTEsVANhO2JNdEmVo80ub7K/ lSDHPyLkNaXrVarVar2W46LMuyLFsKaZ7neZ4nvw
FR
NGKeGjYajUajkXz9z+RLn8/n8/ms/ANIQXq5XC6Xy/v9fr/fvw3p9Xq9Xq9VVVVV9fF4PB6Pokhc
r9fr9Vr6s6Lf4dNpbS6/exQA3BHDt/ fkPl3wwT85wlcEcrCHZyHO1tmOSl95iGLcQN80Td
M0jTa1
LMuyLF3XdV03TdM0zWaz2Ww2Xdd1XRenDlDHgTbt
vj/ykMZpDm/6LpfL5XLBmGi32+12G6Th5RAA
Pne73W63iwfGYFosFovF4kOZrtVqtVoN16TD4XA4
HPAAKDp5yZUkSZIk1GGz2Ww2m91ut9vt0Mof
lcfxeDwej7PZbDaboRFbrVar1SJfIsLdYZfn8/l8Pue3y1zyiH9VAMFElb5Yp/+PcvAbH/25ox5S
PYYAAAAASUVORK5CYII=');

my $ztree = $frame->CanvasDirTree(
-bg =>'white',
-width =>300, #will be overriden in the object
-height =>300, #to photo width
# -backimage => 'bridget-5a.jpg', #either a file
-backimage => $bunny, #or Tk::Photo object data
-imx => 150, # position relative to nw corner
-imy => 150, # to place nw corner of image
-font => 'big',
-fontcolorn => 'black',
-fontcolora => 'red',
-dir => '.',
-indfilln => 'blue',
-indfilla => 'red',
-scrollbars =>'osw',
)->pack(-side=>'left',-fill=>'both', -expand=>1);

my $text = $frame->Scrolled('Text',
-bg=>'white',
-width => 40,
-scrollbars =>'osoe',
)->pack(-side=>'right',-fill=>'both',-expand=>1);

my $button = $mw->Button(-text=>'Exit',-command=>sub{exit})->pack();

########################################
##############################
################# PROBLEM HERE
########################################
####
#$ztree->bind( '<Button-1>', sub{
$mw->bind( '<Button-1>', sub{
my $selected = $ztree->get_selected();
print "1\n";
if(defined $selected){
$text->insert('end',"$selected\n");
$text->see('end');
}
});

MainLoop;
__END__

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

Ch Lamprecht

2006-03-29, 7:00 pm

zentara wrote:
> Hi,
> Generally I avoid these problems, by not using objects and
> modules, but I wanted to try and put this in a module form. :-)
>
> I'm working on a canvas based module to simulate the
> gtk2 style tree widget. This basically will show directories
> in a scrolled Canvas, with a little rotating indicator to open and
> close directories. It will also allow a background image, from
> file or a Tk::Photo object from the script.
>
> 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.
>
> 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.
>
> 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

HI Zentara,

why don't you bind to the canvas items in your class:

$self->{can}->bind('all','<1>',[\&pick_one, $self]);

So you should be able to create a binding to '<1>' for your widget
without overriding the one you set up in the class.

Christoph

--

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

Ch Lamprecht

2006-03-30, 7:59 am

Ch Lamprecht wrote:
> zentara wrote:

[color=darkred]
> why don't you bind to the canvas items in your class:
>
> $self->{can}->bind('all','<1>',[\&pick_one, $self]);
>
> So you should be able to create a binding to '<1>' for your widget
> without overriding the one you set up in the class.
>
> Christoph
>
Hi ,

found some time to run your script and check it:

Line 90:

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

#-----------------------^^^^^^^^^^^^^^^^ changed

....

########################################
##############################
################ PROBLEM HERE
########################################
####

$ztree->{can}->CanvasBind( '<Button-1>', sub{

#^^^^^^^^^^^^^^^^^^^^^^^^changed

my $selected = $ztree->get_selected();
print "1\n";
if(defined $selected){
$text->insert('end',"$selected\n");
$text->see('end');
}
});

MainLoop;
__END__

That way it works...

I didn't understand your class design:
Shouldn't your instances be 'Canvases' as you inherit from 'Canvas'?

Why do you construct an additional canvas in Line 63?

Line 63:
$self->{'can'} = $self->Scrolled('Canvas',
-scrollbars => $self->{'scrollbars'},
);

I think that's the reason, why $ztree->CanvasBind does not work as
expected.

HTH, Christoph

--

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

zentara

2006-03-30, 7:59 am

On Wed, 29 Mar 2006 23:17:03 +0200, Ch Lamprecht
<christoph.lamprecht.no.spam@web.de> wrote:

>zentara wrote:
[color=darkred]
>HI Zentara,
>
>why don't you bind to the canvas items in your class:
>
>$self->{can}->bind('all','<1>',[\&pick_one, $self]);
>
> So you should be able to create a binding to '<1>' for your widget
>without overriding the one you set up in the class.
>
>Christoph

Yeah, I think that is what I tried. I can get the derived widgets
animation to work OK, the problem is getting the "selected"
item out to the main script. This is needed so I can use the
selected item to do something with it, outside of the derived widget.

The widget seems "dead" to bindings from the main script.
For instance, if I put a binding in the main script to my derived widget
like:

$ztree->bind('all','<Button-1>', sub{
print "@_\n";
print "5\n";
});

5 is never printed.

If I bind to the {'can'} derived widget from main
like:

$ztree->{'can'}->bind('all','<Button-1>', sub{
print "@_\n";
print "5\n";

});

5 is printed, but the internal widget binding to <Button-1>
gets broken, and the animation stops.

So I am facing 2 problems here.
1. Why do I need to bind to $ztree->{'can'} from main?
Why is binding to $ztree by itself, dead?

2. Why does binding to $ztree->{'can'} in main, stop
the internal widgets binding to the same mouse press?

If anyone knows a better way to do this? Does anyone know how to
setup a <Selected> binding in the derived widget.

I've tried all ( and combinations) of the solutions presented in
Tk::mega, like SetBindtags, and putting bindings to <1>
in ClassInit. But it seems that there is a special combination
of things needed, to make the $ztree be responsive to mouse
clicks from the main script level.

I can't find that right combination. I'm sure it there.

So in a more general question, how do you bind the same
mouse click, internally in a derived widget, and from the main script,
and have them fire their callbacks in the order specified in Tk::bind.
......first the class callback is done, then the main script callback is
done?

All clues welcome.

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

thundergnat

2006-03-30, 7:00 pm

zentara wrote:

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

Hmm. That is perplexing. I don't really see why it ignores bindings
to the object in Main.

You could side step the issue by undefing the $object->{'selected'}
value when the pointer leaves the the object so that clicks outside
the object won't be significant to it.

Add the line

$self->{'can'}->Tk::bind( '<Leave>' => sub{ undef $self->{'selected'} } );

somewhere in the Populate sub. Kind of half-assed perhaps, but it
yields behavior closer to what I would expect.

zentara

2006-03-30, 7:00 pm

On Thu, 30 Mar 2006 13:51:44 +0200, Ch Lamprecht
<christoph.lamprecht.no.spam@web.de> wrote:

>Ch Lamprecht wrote:

>found some time to run your script and check it:
Thanks.

>
>Line 90:
>
> $self->{'can'}->bind( 'all','<Button-1>' => [\&pick_one, $self] );
>
>#-----------------------^^^^^^^^^^^^^^^^ changed
>
> ########################################
##############################
>################ PROBLEM HERE
> ########################################
####
>
>$ztree->{can}->CanvasBind( '<Button-1>', sub{
>
>#^^^^^^^^^^^^^^^^^^^^^^^^changed
>
> my $selected = $ztree->get_selected();
> print "1\n";
> if(defined $selected){
> $text->insert('end',"$selected\n");
> $text->see('end');
> }
> });
>
>MainLoop;
>__END__
>

>That way it works...
It dosn't for me. As soon as I add a binding to Button-1 in the
main script, the internal class bindings stop working, i.e. I lose
the animation.

>
>I didn't understand your class design:
>Shouldn't your instances be 'Canvases' as you inherit from 'Canvas'?
>
>Why do you construct an additional canvas in Line 63?
>
>Line 63:
> $self->{'can'} = $self->Scrolled('Canvas',
> -scrollbars => $self->{'scrollbars'},
> );
>
>I think that's the reason, why $ztree->CanvasBind does not work as
>expected.
>HTH, Christoph

I think you may have found the flaw in my object. I did it that way to
make it a Scrolled Canvas. How else can I make the derived canvas a
scrolled object? Do I manually need to build the scrollbars? Or make
it scrolled from main, like

my $ztree = $frame->Scrolled('CanDirTree',......) ??

I think you have set me on the right track. I will try to rewrite it
without the Scrollbars and see what I come up with.,

I'm hoping to be able to get this down pat, so I can make any type
of custom canvas based widget.

Thanks again. That explains why my widget seems dead from main.

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

Ala Qumsieh

2006-03-31, 6:59 pm

zentara wrote:

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

I didn't try to run your script, but the problem might be in this line:

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

Here, the CanvasBind is applied to $self->{'can'}. So, if you CanvasBind to
'<Button-1>' again, it will override this one. Change this to:

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

By doing that, any future bindings to your object will not collide with this
one. So this should work now:

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

--Ala

zentara

2006-04-01, 7:59 am

On Fri, 31 Mar 2006 17:08:39 GMT, Ala Qumsieh <noreply@invalid.net>
wrote:

>zentara wrote:
>
>
>I didn't try to run your script, but the problem might be in this line:
>
>
>Here, the CanvasBind is applied to $self->{'can'}. So, if you CanvasBind to
>'<Button-1>' again, it will override this one. Change this to:
>
> $self->{'can'}->CanvasBind( ref($self->{can}), '<Button-1>', =>
>[\&pick_one, $self] );
>
>By doing that, any future bindings to your object will not collide with this
>one. So this should work now:
>
> $ztree->CanvasBind( '<Button-1>', sub{ ... });
>
>--Ala

Very useful information Ala, revealing the hidden workings.

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

Sponsored Links