use strict; use Tk; use Tk::FooButton; my $MW = new MainWindow; # 1. callback using anonymous sub (also known as a # "closure") -- the arguments are embedded in # the closure. my $a_obj = new Foo (1); my $a = $MW->Button(-text => 'A', -command => sub { $a_obj->callback("pushed 'A'") } ) ->pack; # 2. callback using sub reference (looked up using # Perl's object-oriented "can" method) -- the # arguments are passed through the array reference. my $b_obj = new Foo (2); my $b = $MW->Button(-text => 'B', -command => [ $b_obj->can('callback'), $b_obj, "pushed 'B'" ] ) ->pack; # 3. callback using a custom (derived) Tk::Button -- # the arguments are stored as properties on the # button itself. my $c_obj = new Foo (3); my $c = $MW->FooButton(-text => 'C', -object => $c_obj, -message => "pushed 'C'") ->pack; MainLoop; # --------------------------------------------------------- package Foo; use strict; sub new { my ($class, $i) = @_; my $self = { -id => $i }; return bless($self, $class) } sub callback { my ($self, $message) = @_; print "$message using object #$self->{-id}\n"; } # --------------------------------------------------------- # SAVE THIS CODE AS "Tk/FooButton.pm" package Tk::FooButton; use strict; use base qw(Tk::Derived Tk::Button); Construct Tk::Widget 'FooButton'; sub Populate { my ($self, $args) = @_; $self->SUPER::Populate($args); $self->ConfigSpecs(-object => [ "PASSIVE", undef, undef, undef ], -message => [ "PASSIVE", undef, undef, undef ]) } sub invoke { my ($self) = @_; my $object = $self->cget(-object); my $message = $self->cget(-message); $object->callback($message) if ($object) } 1;