Atomic operations in perl and Tk::IO

[rinceWind]

I'm having some difficulty with a process monitoring application written in Tk, which reads the output of tail asynchronously. My first attempt at this worked well until the application being monitored spewed lots of text to the log file, which caused the GUI to freeze.

sub component_window {
    my ($prch,$pid) = @_;

    if (!exists $prch->{window}) {
        my ($title) = $prch->{log} =~ m(/(\w+)/logFile);
        $prch->{window} = my $newwin = $prch->{widget}->Toplevel( -tit
+le => $title );
        my $fr1 = $newwin->Frame;
        $fr1->pack( -side => 'top');
        $fr1->Label( -text => 'Log File: ')->pack( -side => 'left');
        $fr1->Label( -text => $prch->{log})->pack( -side => 'left');
        my $fr2 = $newwin->Frame;
        $fr2->pack( -side => 'top');
        $fr2->Button( -text => 'Close', -command => [$newwin => 'destr
+oy'])
                    ->pack( -side => 'left');
        $fr2->Button( -text => 'Kill', -command => sub {system("kill $
+pid")})
                    ->pack( -side => 'left');
        $newwin->bind( '<Destroy>' => sub {delete $prch->{window}});
        my $txt = $newwin->Scrolled('ROText',
                -scrollbars => 'e',
                -height => 20,
                -setgrid => 'true',
        );
        $txt->pack( -side => 'top');
        $prch->{tailwin} = $txt;
        my $tail = Tk::IO->new( -linecommand => sub { tail_lines($prch
+, $_[0]) });
        $tail->exec("tail -f $prch->{log}");
    }
}

sub tail_lines {
        my ($proc,$text) = @_;

        print "tail_lines $text" if $debug;

        $proc->{tailwin}->insert('end' => $outstr);
        $proc->{tailwin}->see('end');
}

My first thought was that the insert and see methods are being called excessively, so I decided to make the program buffer up the text and print it at a convenient point in my polling cycle.

sub tail_lines {
        my ($proc,$text) = @_;

        print "tail_lines $text" if $debug;

        push @{$proc->{tailbuf}},$text;
}

sub check_log {
    my $this = shift;
    return unless exists $this->{log};

# ... other code here to do with log files

    if (exists $this->{tailbuf}) {
        my $outstr = '';
        $outstr .= shift @{$this->{tailbuf}} while @{$this->{tailbuf}}
+;

        $this->{tailwin}->insert('end' => $outstr);
        $this->{tailwin}->see('end');
    }
}

My application now does not freeze, but instead I get chunks of the log file missing. check_log is called via Tk::repeat.

In Tk's threading model, we thus have two asynchronous threads, one called via Tk::IO that is pushing to the array, and one called from repeat on a polling cycle, which is shifting the text out.

I would expect that shift and push operations on the same array to be atomic, but they are not. Unless I have done something silly in my code :).

Any of you any idea how to achieve what I want? Any suggestions welcome.

Thanks in advance,

rinceWind

[pg]

It is quite “normal” to see a Perl module is not thread-safe. Considering the factors:
1. To support multi-thread by default might increase load unnecessary, so usually, the threading part would be left to the users’ hands
2. Most of those modules are older than threading support in Perl
Said that, now it would be your responsibility to lock shared variables, in this case, your tail buffer.

Better to have a buffer, which is fully under your control (you are almost on the right track with this), so you can lock/unlock at the right timing (locking is what missing here, do it yourself, don’t expect Tk to do it for you.).

Be careful not try to share Tk component/widget over threads, as far as Perl 5.8 goes, this is not supported (as bless is not thread-safe). Expect this to be straightened in future versions.

[rinceWind]

I feel a new module coming on, as in Tie::Atomic.

Please let me know if this wheel has already been invented.

--rW

[hiseldl]

Update: <homer_simpson_voice>DOH! cloooosures</homer_simpson_voice>
-- I'll leave the text here so that no else who reads this makes the same mistake. :-)

In your call to component_window(), you assign $pcrh and $pid a la     my ($prch,$pid) = @_; now, I don't see a shift nor a pop nor any other @_ manipulations, which makes your call to tail_lines() incorrect:

sub component_window {
    my ($prch,$pid) = @_;
    ...
    my $tail = Tk::IO->new( 
       -linecommand => sub { tail_lines($prch, $_[0]) });
    ...
}

sub tail_lines {
    my ($proc,$text) = @_;
    ...
}

because $_[0] is the same as $prch when you call tail_lines($prch, $_[0]), and this seems to be not what you want.

You should be able to either pass the third element directly or get the third element in a var at the top of your sub (i.e.

sub component_window {
    my ($prch,$pid,$text)=@_;
    ...

and pass that...

    ...
    my $tail = Tk::IO->new( 
       -linecommand => sub { tail_lines($prch, $text) });
    ...
}

--
hiseldl
What time is it? It's Camel Time!

[rinceWind]

because $_[0] is the same as $prch when you call tail_lines($prch, $_[0]), and this seems to be not what you want.

Sorry, hiseldl, you are not correct. The call to tail_lines is in an anonymous sub, which is a closure, which is passed a line of text by the Tk::IO mechanism.

See Tk::IO for more details

[hiseldl]

I've been writing Tk scripts for over a year now, and I temporarily forgot about closures as callbacks, oops, sorry. I'll leave the post as it is to maintain continuity of the thread and as a reminder to other's using Tk to watch for closures in the callbacks. :-)

Cheers!

--
hiseldl
What time is it? It's Camel Time!