Question

I’ve written a perl/tk gui. The stderr & stdout write to a popup window, but I cannot clear the text when the popup window is destroyed (it is actually withdrawn). I could not install Tk::Stderr so I appended the module to the end of my script. Below is a working example.

I have added the following line to the Print subroutine, but it is overkill:

$text->delete('0.0', 'end');

My suspicion is that something could be added to the following line in the Populate subroutine:

$mw->protocol(WM_DELETE_WINDOW => [ $mw => 'withdraw']);

but I don’t know what. I would appreciate any assistance.

#!/usr/bin/perl

use warnings;
use strict;
use Tk;
# use Tk::Stderr; << ** pasted module after main ** - honyok

# create main window
my $mw = MainWindow->new;
$mw->InitStderr;
$mw->optionAdd("*font", "-*-calibri-normal-r-*-*-*-120-*-*-*-*-*-*");
$mw->protocol('WM_DELETE_WINDOW'=> sub{exit});
$mw->geometry( "100x100");
$mw->resizable(0,0);# not resizable
# create buttons
my $button1=$mw->Button(-text=>'STDERR',-command=>[sub{print STDERR "Writing to STDERR\n";}])->pack;
my $button2=$mw->Button(-text=>'STDOUT',-command=>[sub{print STDOUT "Writing to STDOUT\n";}])->pack;

MainLoop;
# =========================== end main ==================================


##==============================================================================
## Tk::Stderr - capture program standard error output
##==============================================================================
## $Id: Stderr.pm,v 1.2 2003/04/01 03:58:42 kevin Exp $
##==============================================================================
#require 5.006;
package Tk::Stderr;
use strict;
use warnings;
use vars qw($VERSION @ISA);
($VERSION) = q$Revision: 1.2 $ =~ /Revision:\s+(\S+)/ or $VERSION = "0.0";
use base qw(Tk::Derived Tk::MainWindow);

use Tk::ROText;
use Tk::Frame;

##==============================================================================
## Populate
##==============================================================================
sub Populate {
    my ($mw, $args) = @_;
    my $private = $mw->privateData;
    $private->{ReferenceCount} = 0;
    $private->{Enabled} = 0;

    $mw->SUPER::Populate($args);

    $mw->withdraw;
    $mw->protocol(WM_DELETE_WINDOW => [ $mw => 'withdraw']);
    my $f = $mw->Frame(
        Name => 'stderr_frame',
    )->pack(-fill => 'both', -expand => 1);

    my $text = $f->Scrolled(
        'ROText',
        Name => 'stderr_text',
        -scrollbars => 'se',
        -label=>'Output/Errors',
        -wrap => 'none'
        #-background=>'slate grey'
    )->pack(-fill => 'both', -expand => 1);

    $mw->Advertise('text' => $text);
    $mw->ConfigSpecs(
        '-title' => [ qw/METHOD title Title/, "truGrid" ],
    );

    $mw->Redirect(1);
    return $mw;
}

##==============================================================================
## Redirect
##==============================================================================
sub Redirect {

    my ($mw, $boolean) = @_;
    my $private = $mw->privateData;
    my $old = $private->{Enabled};

    if ($old && !$boolean) {
        untie *STDOUT;# ** hacked this line ** - honyok
        untie *STDERR;
        $SIG{__WARN__} = 'DEFAULT';
    } elsif (!$old && $boolean) {
        tie *STDOUT, 'Tk::Stderr::Handle', $mw;# ** hacked this line ** - honyok
        tie *STDERR, 'Tk::Stderr::Handle', $mw;
        $SIG{__WARN__} = sub { print STDOUT @_ };# ** hacked this line ** - honyok
        $SIG{__WARN__} = sub { print STDERR @_ };
    }
    $private->{Enabled} = $boolean;
    return $old;
}


##==============================================================================
## DecrementReferenceCount
##==============================================================================
sub DecrementReferenceCount {
    my ($mw) = @_;
    my $private = $mw->privateData;

    if (--$private->{ReferenceCount} <= 0) {
        $mw->destroy;
    }
}

##==============================================================================
## IncrementReferenceCount
##==============================================================================
sub IncrementReferenceCount {
    my ($mw) = @_;
    my $private = $mw->privateData;

    ++$private->{ReferenceCount};
}


package MainWindow;
use strict;
use warnings;

my $error_window;

##==============================================================================
## InitStderr
##==============================================================================
sub InitStderr {
    my ($mw, $title) = @_;

    unless (defined $error_window) {
        $error_window = Tk::Stderr->new;
        $error_window->title($title) if defined $title;
    }
    $error_window->IncrementReferenceCount;
    $mw->OnDestroy([ 'DecrementReferenceCount' => $error_window ]);
    return $mw;
}

##==============================================================================
## StderrWindow
##==============================================================================
sub StderrWindow {
    return $error_window;
}

##==============================================================================
## RedirectStderr
##==============================================================================
sub RedirectStderr {
    my ($mw, $boolean) = @_;

    unless (defined $error_window) {
        $mw->InitStderr if $boolean;
        return;
    }
    return $error_window->Redirect($boolean);
}


##==============================================================================
## Define the handle that actually implements things.
##==============================================================================
BEGIN {
    package Tk::Stderr::Handle;
    use strict;
    use warnings;

    ##==========================================================================
    ## TIEHANDLE
    ##==========================================================================
    sub TIEHANDLE {
        my ($class, $window) = @_;
        bless \$window, $class;
    }

    ##==========================================================================
    ## PRINT
    ##==========================================================================
    sub PRINT {
        my $window = shift;
        my $text = $$window->Subwidget('text');
        $text->insert('end', $_) foreach (@_);
        $text->see('end');
        $$window->deiconify;
        $$window->raise;
        $$window->focus;
        $$window->update;# ** hacked this line ** - honyok
    }

    ##==========================================================================
    ## PRINTF
    ##==========================================================================
    sub PRINTF {
        my ($window, $format) = splice @_, 0, 2;

        $window->PRINT(sprintf $format, @_);
    }
}
1;
##==============================================================================
## $Log: Stderr.pm,v $
## Revision 1.2  2003/04/01 03:58:42  kevin
## Add RedirectStderr method to allow redirection to be switched on and off.
##
## Revision 1.1  2003/03/26 21:48:43  kevin
## Fix dependencies in Makefile.PL
##
## Revision 1.0  2003/03/26 19:11:32  kevin
## Initial revision
##==============================================================================

Answer 1

(Answered on another forum.)

Replace:

$mw->protocol(WM_DELETE_WINDOW => [ $mw => 'withdraw' ]);

with:

$mw->protocol(WM_DELETE_WINDOW => [ $mw => 'OnWithdraw' ]);

Define the subroutine:

sub OnWithdraw{
    my $window = shift;
    my $text   = $window->Subwidget('text');
    $text->delete('0.0', 'end');
    $window->withdraw;
    return;
}