Tkx - bind - append binding

[kcott]

I'm currently working on a module which uses Tkx. I came across something tricky involving appending bindings. It took a while to work out and, in the process, I ran a lot of tests: the results were quite surprising. I've posted this here in case anyone else finds themselves in a similar position: hopefully, it might save them some time and effort.

Tkx is a thin wrapper around Tcl. Its documentation is minimal: it just links to the Tcl documentation and leaves you to work out how to use it. In this instance, I was looking at the bind command documentation for information on appending a binding. I've linked to all of it, here's the relevant parts for this specific post:

NAME

bind — Arrange for X events to invoke Tcl scripts

SYNOPSIS

bind tag ?sequence? ?+??script?

INTRODUCTION

... If script is prefixed with a "+", then it is appended to any existing binding for sequence; ...

That's all it says about appending bindings. I investigated this; ran some tests; and was somewhat surprised at the outcome. The module I'm currently working on now contains this documentation:

Appending Bindings

When appending bindings, using the ?+??script? format, the plus (+) isn't a separate argument. Any of the following syntax variations are valid (subname works for normal named subroutines as well as lexical subroutines).

See Update below.

    '+' . sub { ... }
    '+' . \&subname
    '+' . [\&subname]
    '+' . [\&subname, @args]
    ['+' . \&subname]
    ['+' . \&subname, @args]
    '+' . $coderef
    '+' . [$coderef]
    '+' . [$coderef, @args]
    ['+' . $coderef]
    ['+' . $coderef, @args]

The surprising part was all the different ways of concatenating a string ('+') with an anonymous coderef, a named coderef, and an anonymous arrayref, without the code blowing up in my face.

This may also be useful to those using related modules, like Tcl::Tk and Tcl::pTk; although, I could be completely wrong on that (I have little knowledge of these beyond knowing of their existence).

Update: Despite successfully running two dozen or so tests on all those syntax formats, none of them appear to be actually functional. My apologies to anyone who's been trying to get them to work.

I've spent a bit of time looking into this. I can append one binding using either

... '+' . Tkx::i::interp->create_tcl_sub( CODEREF ) ...

or

my $interp = Tkx::i::interp();
... '+' . $interp->create_tcl_sub( CODEREF ) ...

And that works for CODEREF as any of these three:

sub { ... }
\&subname
$coderef

However, whenever I attempt to append a second (or third) binding, none of the appended bindings work; although, the original binding works as expected. The only feedback I get looks like the following (there's no line numbers or other useful information):

Error: invalid command name "::perl::CODE(0x7ffef5dd34d8)"

So again, my apologies to anyone who rushed off to try what I originally posted. I will spend some more time on this: I'll let you know if that proves fruitful.

[kcott]

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