Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister

Re: Tkx after coderef problem

by huck (Parson)
on Jun 03, 2018 at 21:09 UTC ( #1215797=note: print w/replies, xml ) Need Help??

in reply to Tkx after coderef problem

Ok, i think i know what is going wrong

At line 553 you find

$interp->invoke('after',$args[1]+1000, "perl::Eval {Tcl::_code_dispose +('$interp;$id')}");
Notice that line 551-552 notes plan deleting that entry, hence Tcl command during Tcl::Code::DESTROY TODO - this +1000 is wrong... should
and at line 635 we find delete $anon_refs{$k};. That is what destroys the "majic" needed to call that perl code.

To backtrack a little, at i found a simple timer in Tk. after some heavy handed munging to Tkx i got

#!/usr/bin/env perl # # to Tkx from +mer # # This script generates a counter with start and stop buttons. # # original Tcl/Tk -> Perl translation by Stephen O. Lidie. lusol@Lehi +gh.EDU 96/01/25 require 5.002; use Tkx; use strict; use warnings; my $mw=Tkx::widget->new("."); # %tinfo: the Timer Information hash. # # Key Contents # # w Reference to MainWindow. # s Accumulated seconds. # h Accumulated hundredths of a second. # p 1 IIF paused. # t Value of $counter -textvariable. my(%tinfo) = ('w' => $mw, 's' => 0, 'h' => 0, 'p' => 1, 't' => '0.00 +'); my $w_tfrm = $mw->new_ttk__frame(); my $counter= $w_tfrm->new_label(-textvariable =>\$tinfo{'t'} ,-justify =>'left' ,-anchor =>'nw' ,-font =>'TkFixedFont' ); my $start=$w_tfrm->new_ttk__button(-text=> 'Start', -command=>sub {i +f($tinfo{'p'}) {$tinfo{'p'} = 0; tick()}} ); my $stop =$w_tfrm->new_ttk__button(-text=> 'Stop' , -command=>sub {$ +tinfo{'p'} = 1;} ); $counter->g_grid(-column=>0,-row => 0, -sticky=>'ew'); $start ->g_grid(-column=>0,-row => 1, -sticky=>'ew'); $stop ->g_grid(-column=>1,-row => 1, -sticky=>'ew'); $w_tfrm->g_pack(qw '-fill x -expand false -anchor nw'); Tkx::MainLoop; exit; sub tick { # Update the counter every 50 milliseconds, or 5 hundredths of a s +econd. return if $tinfo{'p'}; $tinfo{'h'} += 5; if ($tinfo{'h'} >= 100) { $tinfo{'h'} = 0; $tinfo{'s'}++; } $tinfo{'t'} = sprintf("%d.%02d", $tinfo{'s'}, $tinfo{'h'}); my $send_id=Tkx::after( 50 , \&tick); } # end tick
Running that, then pressing start caused the "invalid command name "::perl::CODE" error too. Ahah, something else fails too!
pressing stop , then start again makes it fail again. doing this a few times i noticed that every time the error came after 1.05 seconds of "timer on" status.

So i modified my code to have a constant rather than random delay time. And lo and behold the failures became regular, The failure occurs 1 second after the first call to Tkx::After with the scalar coderef. one second became interesting

so i modifed my test code and added

sub after_dump{ my $info0=Tkx::after_info(); if (ref($info0) ne 'Tcl::List') { print "not tkx list\n"; $info0=[Tkx::SplitList($info0)]; } for my $send_id (@$info0) { my $info1=Tkx::after_info($send_id); print 'after:'.sprintf('%-15s',$send_id).' script-'.$info1->[0].' +type-'.$info1->[1]."\n"; } }
then added   after_dump(); to the end of accept_out_cclose_after. Thats when i noticed lines like
after:after#3 script-perl::Eval {Tcl::_code_dispose('Tcl=SCALA +R(0x871eb00);after#2')} type-timer after:after#2 script-::perl::CODE(0x89f20c8) type-timer
Thats what gave me to clue(_code_dispose) to find out where the argument processing was for Tcl calls from perl, and i found that 1 second after the my Tkx::after call terminates _code_dispose was destroying the majic that allowed it to call that perl subroutine coderef, even though that coderef was a "static scalar".

See at 464, $args[$argcnt] = $interp->create_tcl_sub($arg, undef, undef, $current_r); the second undef is a non-defined $tclname, at 605-608 it stringifys the coderef as $tclname = "::perl::$sub"; then at 611 it registers that $tclname as a tcl interpreter command via $interp->CreateCommand($tclname, $sub, undef, undef, 1); and then at 620 blesses that $tclname as a Tcl::Code in $anon_refs.

Then at 545 the code is called my $id = $interp->icall(@args);, then at 549 a composite $anon_refs is made of all the $anon_refs for that call  $anon_refs{"$interp;$id"} = \@codes; then at 553 that composite is scheduled for deletion in 1 second $interp->invoke('after',$args[1]+1000, "perl::Eval {Tcl::_code_dispose('$interp;$id')}");

ok so far.

but then when the composite deletion is activated all its parts are Tcl::Code objects so they go thru the DESTROY at 652-658. now each time create_tcl_sub ran it made a new Tcl::Code object, but the first element to that object is a reference to the $sub coderef, the same $sub coderef that i will be calling again. BUT DESTROY uses that ref to $sub-coderef to create a $tclname my $tclname = "::perl::$$rsub"; that is then unregistered as a tcl command via $interp->DeleteCommand($tclname) SO once the first after has run to delete the composite list of tcl_coderefs (@codes) my sub gets unregistered, and can no longer be called again by after until l i run Tkx::after again. But i have an after event pending and i wont run Tkx::after again until it triggers, and when it does trigger Tcl is unable to process its coderef because it has been unregistered.

I kinda have a clue how to fix this, but ive been digging around so much me brain is all jumbled right now.

as for why it worked in win but not ubuntu my windows has $Tcl::VERSION = '1.02'; which was installed when i installed 5.20, but ubuntu 14.04/16.04/18.04 has $Tcl::VERSION = '1.05'; installed just a few days ago. I suspected the version were different, but still wanted to understand why it failed.

Replies are listed 'Best First'.
Re^2: Tkx after coderef problem
by huck (Parson) on Jun 04, 2018 at 06:06 UTC

    diff to 1.05

    diff /usr/local/lib/perl/5.18.2/ /usr/local/lib/perl/5.18.2/ 384a385 > use Scalar::Util qw(weaken); 560a562,567 > # this kills the weakened tclname ref leaveng the strong current_r r +ef (like before) > > if (exists($anon_refs{$current_r})){ > anon_kill($anon_refs{$current_r}[2]); > } > 594a602,607 > # kill an anon_refs name > sub anon_kill { > my $anonname=shift; > delete $anon_refs{$anonname}; > } > 618c631,639 < $anon_refs{$rname} = bless [\$sub, $interp], 'Tcl::Code'; --- > # $anon_refs{$rname} = bless [\$sub, $interp], 'Tcl::Code'; > my $isnew=0; > unless (exists $anon_refs{$tclname}) { > $anon_refs{$tclname} = bless [\$sub, $interp, $tclname], 'Tcl: +:Code'; > $isnew=1; > } > $anon_refs{$rname} = $anon_refs{$tclname}; > weaken($anon_refs{$tclname}) if ($isnew); > 652a674 > my $anonname = $_[0]->[2]; 655a678 > Tcl::anon_kill($anonname);
    Now to try to make a "bug report" via bug-Tcl [at]

      While that patch above fixes part of the problem, there is more to the real problem that the above simple patch does not address. I have been working on it, have a second tracking number at for a second problem, and hope to have my git-pull request honored. When all that is done i will update this subthread more

        Why no Test module?

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://1215797]
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (4)
As of 2020-07-07 02:47 GMT
Find Nodes?
    Voting Booth?

    No recent polls found