in reply to Tkx - bind - append binding
"I will spend some more time on this: I'll let you know if that proves fruitful."
After some delving into the source code for Tkx.pm and Tcl.pm, I've now got this working pretty much the way I wanted. Here's an extract of the module code:
... use 5.026; ... use constant { ... ERR_CALLBACK_NOT_CODEREF => 'Callback is not a coderef.', }; ... use Scalar::Util 'reftype'; ... use Tkx; ... { use constant BINDPLUS_REF_BASE => 'bindplus_ref_base_'; my ($tcl_interp, $tcl_sub_ref_id); BEGIN { $tcl_interp = Tkx::i::interp(); $tcl_sub_ref_id = 0; } sub bindplus { my ($tag, $seq, $callback) = @_; my $callback_ref = reftype $callback; if ($callback_ref eq 'CODE') { Tkx::bind($tag, $seq, '+' . $tcl_interp->create_tcl_sub( $callback, undef, undef, BINDPLUS_REF_BASE . $tcl_sub_ +ref_id++ )); } elsif ($callback_ref eq 'ARRAY') { if (reftype $callback->[0] eq 'CODE') { Tkx::bind($tag, $seq, '+' . $tcl_interp->create_tcl_su +b( sub { $callback->[0]->($callback->@[1 .. $callback +->$#*]) }, undef, undef, BINDPLUS_REF_BASE . $tcl_sub_ref_id+ ++ )); } else { croak ERR_CALLBACK_NOT_CODEREF; } } else { croak ERR_CALLBACK_NOT_CODEREF; } } }
The trick to appending multiple times, was to use a unique identifier for the fourth create_tcl_sub() argument:
$callback, undef, undef, BINDPLUS_REF_BASE . $tcl_sub_ref_id++
In my tests, I created an initial binding in the normal way (with Tkx::bind()); I then appended a further eleven bindings using the function above. That was nine tests (one for each of the callback forms shown below) plus two that were somewhat more involved (using tk_messageBox). All were called in the correct order.
This works for callbacks in any of these forms:
sub { ... } \&subname $coderef [sub { ... }] [sub { ... }, @args] [\&subname] [\&subname, @args] [$coderef] [$coderef, @args]
One thing this code doesn't do is handle Tkx::Ev() calls in the @args. That's not a current requirement for me: perhaps I'll look into it at a later date.
— Ken
|
---|