Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

Tkx after coderef problem

by huck (Vicar)
on Jun 02, 2018 at 07:53 UTC ( #1215721=perlquestion: print w/replies, xml ) Need Help??
huck has asked for the wisdom of the Perl Monks concerning the following question:

Given the following code

use strict; use warnings; use Tkx; my $esub =0; use Getopt::Long; my %optdef=("esub=i" => \$esub); GetOptions (%optdef) or die("Error in command line arguments\n"); print "encapulated sub=$esub\n"; my $mw=Tkx::widget->new("."); my $connct=0; my $tkxfsr={}; $tkxfsr->{server}{port}=123; my $buf='hi'; my $remote='1234'; $connct++; my $id=time.'_'.$tkxfsr->{server}{port}.'_c'.$connct; my $afterid='serverq-'.$id; print 'SCMD '.$id.' '.$buf."\n"; $tkxfsr->{after}{$afterid}{q}=[]; for my $i (1..10){ push @{$tkxfsr->{after}{$afterid}{q}},$id.' '.$bu +f.' '.$i.('-'x10);} $tkxfsr->{after}{$afterid}{sub}=sub{ return unless ($tkxfsr->{after} && $tkxfsr->{after} +{$afterid} && $tkxfsr->{after}{$afterid}{q}); if (scalar(@{$tkxfsr->{after}{$afterid}{q}})) { accept_out_cclose_after($tkxfsr,$afterid,int(ra +nd(2000))); my $msg=shift @{$tkxfsr->{after}{$afterid}{q}}; + print 'LIST '.$msg."\n"; } else { print 'DONE '.$id.' 0'."\n"; delete $tkxfsr->{after}{$afterid}; } }; accept_out_cclose_after($tkxfsr,$afterid,500); my $d_id=Tkx::after( 20000 , sub{$mw->g_destroy}); sub accept_out_cclose_after { my $tkxfsr=shift; my $afterid=shift; my $delay=shift; my $send_id; if ($esub) { $send_id=Tkx::after( $delay , sub{&{$tkxfsr->{after}{$a +fterid}{sub}}});} else { $send_id=Tkx::after( $delay , $tkxfsr->{after}{$a +fterid}{sub} ); } $tkxfsr->{after}{$afterid}{eventid}=$send_id; $tkxfsr->{after}{$afterid}{delay}=$delay; } Tkx::MainLoop; if ( $tkxfsr->{after}{$afterid}{sub}) { print 'sub:'.$tkxfsr->{after}{$afterid}{sub}."\n"; }
on win-xp (This is perl 5, version 20, subversion 1 (v5.20.1) built for MSWin32-x86-multi-thread-64int) the folowing two commands work just fine
perl huh-after.pl -esub 0 perl huh-after.pl -esub 1
but on ubuntu -14.04 (This is perl 5, version 18, subversion 2 (v5.18.2) built for i686-linux-gnu-thread-multi-64int) while -esub 1 works just fine, running -esub 0 results in an error (in tk box)
invalid command name "::perl::CODE(0x96f045c)" invalid command name "::perl::CODE(0x96f045c)" while executing "::perl::CODE(0x96f045c)" ("after" script)
And the ending debug statement shows the address listed is that of the perl code and it still exists after the failure window. Sometimes it fails after line 1, sometimes after line 5, or somewhere in between.

Anyone have any idea why the difference between the platforms, or what may be going on. My workaround is to just run the encapsulation but it seems odd to me to HAVE to do that. It took a lot of debugging and testing before i figured out to try the encapsulated method even.

Edit:add

The same thing happens under ubuntu 18.04 (This is perl 5, version 26, subversion 1 (v5.26.1) built for i686-linux-gnu-thread-multi-64int) as under ubuntu 14-04

Replies are listed 'Best First'.
Re: Tkx after coderef problem
by huck (Vicar) on Jun 02, 2018 at 18:49 UTC

    I have also discovered that the following syntax also works.

    sub accept_out_cclose_after { my $tkxfsr=shift; my $afterid=shift; my $delay=shift; my $send_id; if ($esub==1) { $send_id=Tkx::after( $delay , sub{&{$tkxfsr->{aft +er}{$afterid}{sub}}()});} elsif ($esub==2) { $send_id=Tkx::after( $delay , [$tkxfsr->{after}{$ +afterid}{sub}] );} else { $send_id=Tkx::after( $delay , $tkxfsr->{aft +er}{$afterid}{sub} ); } $tkxfsr->{after}{$afterid}{eventid}=$send_id; $tkxfsr->{after}{$afterid}{delay}=$delay; }
    perl huh-after.pl -esub 2
    And i suspect that the [] notation in the Tkx::after call is doing the same thing i did with the sub {}, creating a one use anonymous subroutine reference.

      >>And i suspect that the [] notation in the Tkx::after call is doing the same thing i did with the sub {}, creating a one use anonymous subroutine reference.

      no it doesnt create an anonymous sub it doesnt need to

        Sorry, yes it does. Found it!

        https://github.com/gisle/tcl.pm/blob/master/Tcl.pm lines 502-518

        elsif ($ref eq 'ARRAY' && ref($arg->[0]) eq 'CODE') { # We have been passed something like [\&subroutine, $arg1, ...] # Create a proc in Tcl that invokes this subroutine with args my $events; # Look for Tcl::Ev objects as the first arg - these must be # passed through for Tcl to evaluate. Used primarily for %-subs # This could check for any arg ref being Tcl::Ev obj, but it # currently doesn't. if ($#$arg >= 1 && ref($arg->[1]) eq 'Tcl::Ev') { $events = splice(@$arg, 1, 1); } $args[$argcnt] = $interp->create_tcl_sub(sub { $arg->[0]->(@_, @$arg[1..$#$arg]); }, $events, undef, $current_r); push @codes, $anon_refs{$current_r}; }
        Notice how lines 514-516 create a **perl** anon-sub

        Sorry, better luck next time!

        "no it doesnt create an anonymous sub it doesnt need to

        If you are so sure of that then prove it, show me a link to the arrayref processing of Tkx:after calls, or tell me where to look for the code. Till then my thought that processing of a arrayref in the callback position creates a single use anon-coderef still holds as it explains why that call method works, like the the sub{...} method does, but the static coderef fails. (well at least on unix).

        There is deep autoload magic going on in Tkx that i still dont understand and i have yet to find out where the parameter munging actually takes place to move across the perl<->Tk/Tcl boundary. Ive even tried to look for it.

Re: Tkx after coderef problem
by kcott (Chancellor) on Jun 04, 2018 at 11:36 UTC

    G'day huck,

    I don't have Tkx or Tcl/Tk installed at my current location, so I can't really provide any code feedback; however, scanning through this thread, I thought there were a lot of similarities to "Tkx - bind - append binding" which I wrote about a year ago.

    It could be a red herring, but might provide some insight. Sorry I can't be more helpful: my current resources are somewhat limited at the moment.

    Update (very minor typo fix): s/I thought the were/I thought there were/

    — Ken

      Thanks, i did see that, but at the time i skipped it because i wasnt involved in the '+' format

      Now looking again i find i need to remember my $interp = Tkx::i::interp(); as at once point i wondered how to do that, but settled on using Tkx::info rather than the $interp->call('info','commands','::perl::*') i had seen somewhere(edit:add https://github.com/gisle/tcl.pm/blob/master/t/disposal-subs.t).

      This issue is only related to after, and involves code modified in code disposal works, only 1 question remains; perl::Eval now in Tcl__new and added in the version 1.03 release as of 2016-02-20 https://metacpan.org/changes/release/VKON/Tcl-1.05. I suspect someone (vadrer?) saw that the commands-table/$anon_refs were filling up with address to single use anon-subrefs from the "after command" and wanted to clean them up. His approach while admirable hosed calls where the subref passed into after was not a single use anon-subref (or of the [$coderef] variety, since those generated a single use anon coderef too) because it prematurely discarded them from the Commands-table/$anon_refs.

      While i have faith in my patch, and think it will solve the introduced problem while retaining the needed "code disposal", patching code is never as simple as it looks. What it does is introduce a "weakened" version of the coderef in the anon_refs table under the $tclname key it used to have pre v1.03 and copies that entry into a "strong" newer $current_r style name when needed, so it can be used in the "consolidated" $anon_refs that get scheduled for deletion. Now further "after" calls will be able to create their own consolidated entries for deletion but since the refcount will be greater than one for a "static" coderef since there will be multiple copies in multiple "consolidated" $anon_refs, when _code_disposal is called the Tcl::Code::DESTROY that purges that entry from the command table wont be invoked until the last consolidated $anon_refs entry has been destroyed.

      Since code disposal is only invoked on "after" calls, for non-after calls i dispose of the weakened $tclname key right away, and those coderefs continue to live in the commands-table/$anon_refs "forever", just like they used to pre v1.03 and still currently do.

Re: Tkx after coderef problem
by huck (Vicar) on Jun 03, 2018 at 21:09 UTC

    Ok, i think i know what is going wrong

    At https://github.com/gisle/tcl.pm/blob/master/Tcl.pm 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 https://st.aticpan.org/source/SREZIC/Tk-804.034/demos/timer i found a simple timer in Tk. after some heavy handed munging to Tkx i got

    #!/usr/bin/env perl # # to Tkx from https://st.aticpan.org/source/SREZIC/Tk-804.034/demos/ti +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.

      diff to 1.05

      diff /usr/local/lib/perl/5.18.2/Tcl.pm.bak /usr/local/lib/perl/5.18.2/ +Tcl.pm 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] rt.cpan.org.

        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 https://rt.cpan.org/Public/Bug/Display.html?id=125577 for a second problem, and hope to have my git-pull request honored. When all that is done i will update this subthread more

Re: Tkx after coderef problem
by Anonymous Monk on Jun 03, 2018 at 16:10 UTC

    I don't have Tkx installed, my guess is Tkx::after() might be checking the argument type.

    What does the following print?

    print ref $tkxfsr->{after}{$afterid}{sub};

      CODE

        Uh-uh. Well, looking at your code now: I see you are re-entering Tkx::MainLoop from a callback! Is that even allowed? Secondly, you are capturing the top-level data structure in your callback. That is some questionable design as well. Better make it the smallest relevant work unit that you use in a callback.

Re: Tkx after coderef problem
by Anonymous Monk on Jun 02, 2018 at 11:58 UTC
    What do you think amperstand operator does ? You're to call subs that dont exist

      Im not sure id call my use of ampersand an operator here. If i have the following

      my $code=sub{print "hi\n";}; &{$code};
      the &{} part references the code section of its contents and calls it, much like if i have
      my $var='hi'; my $ref=\$var; ${$ref}='there'; print "$var\n";
      the ${}part references the scalar section of its contents allowing me to set it with the assign statement.

      as for subs not existing, remember that for at least 1 and up to 5 times the call succeeded and the sub/coderef did exist, and at the end of MainLoop the sub/coderef still exists.

      To show that the coderef still exists and is valid if i changed the "debug" statment at the end to

      if ( $tkxfsr->{after}{$afterid}{sub}) { print 'sub:'.$tkxfsr->{after}{$afterid}{sub}."\n"; &{$tkxfsr->{after}{$afterid}{sub}}(); &{$tkxfsr->{after}{$afterid}{sub}}; }
      on ubuntu it still fails as it did before but now it prints out the next two items in the queue after printing 'sub:'.....

      Edit:add output

      encapulated sub=0 SCMD 1527954135_123_c1 hi LIST 1527954135_123_c1 hi 1---------- LIST 1527954135_123_c1 hi 2---------- LIST 1527954135_123_c1 hi 3---------- sub:CODE(0x9cdda24) LIST 1527954135_123_c1 hi 4---------- LIST 1527954135_123_c1 hi 5----------

        which sub is rAising invalid command? What command where? What is undefinex at time of sub call?

        The word is operator. If it's not an operator what is it a puppy?

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://1215721]
Front-paged by Corion
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others surveying the Monastery: (6)
As of 2018-10-15 16:50 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    When I need money for a bigger acquisition, I usually ...














    Results (82 votes). Check out past polls.

    Notices?