Beefy Boxes and Bandwidth Generously Provided by pair Networks DiBona
more useful options
 
PerlMonks  

Tk::Stderr flush

by honyok (Sexton)
on Sep 14, 2012 at 02:36 UTC ( #993623=perlquestion: print w/ replies, xml ) Need Help??
honyok has asked for the wisdom of the Perl Monks concerning the following question:

Church, I have written a GUI using perl/tk that opens a popup window when anything is written to STDOUT or STDERR. However I did not have install privileges so I had to append the Tk::Stderr module to the end of the code (and hacked the STDOUT into it). It works, but I would like to flush (or empty) the stderr text array when the popup window is destroyed. Currently when it is reopened, the previous messages or errors are still in the text box. I am fuzzy on what exactly is happening in the code and haven't lucked upon any solution. Below is a minimized example. Thanks for 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 "W
+riting to STDERR\n";}])->pack;
my $button2=$mw->Button(-text=>'STDOUT',-command=>[sub{print STDOUT "W
+riting 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 an
+d 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
##====================================================================
+==========


[download]
questions are the engines of reason - epictetus

Comment on Tk::Stderr flush
Download Code
Re: Tk::Stderr flush
by Anonymous Monk on Sep 14, 2012 at 03:06 UTC

    However I did not have install privileges so I had to append the Tk::Stderr module to the end of the code (and hacked the STDOUT into it)

    If it works without your hacking, with an installed Tk::Stderr, grab fatpack and let it do the appending

[reply]
      It works without hacking, but I cannot install any other packages. Thank you but this does not help me.
      we are the music makers and we are the dreamers of dreams - ww
[reply]
[reply]
Re: Tk::Stderr flush
by Athanasius (Vicar) on Sep 15, 2012 at 04:32 UTC

    Add a delete line to the sub PRINT in Tk::Stderr::Handle:

        sub PRINT
    {
        my $window = shift;
        my $text   = $$window->Subwidget('text');

        $text->delete('0.0', 'end');        # <= Add this line
        $text->insert('end', $_) foreach (@_);
        $text->see('end');
        $$window->deiconify;
        $$window->raise;
        $$window->focus;
        $$window->update;                   # ** hacked this line ** -
+ honyok
    }

    [download]

    With this line added, each new press of a button writes a message replacing the previous message in the popup window.

    Hope that helps,

    Athanasius <°(((>< contra mundum

[reply]
[d/l]
      Thanks, but that deletes the text every time print is called. I only need to clear the text when the popup window is destroyed. I cannot tell why the data persist when the popup is destroyed, or where it is stored.
      we are the music makers and we are the dreamers of dreams - ww
[reply]
        Maybe look for "OnDestroy" , all that "privateData" and "DecrementReferenceCount" stuff
[reply]
Re: Tk::Stderr flush
by Anonymous Monk on Sep 17, 2012 at 20:11 UTC
    sub OnWithdraw{
    my $window = shift;
    my $text   = $window->Subwidget('text');
    $text->delete('0.0', 'end');
    $window->withdraw;
    return;
}


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

    [download]
[reply]
[d/l]

      That is anonymously it! You are a monk among monks!

      we are the music makers and we are the dreamers of dreams - ww
[reply]

Back to Seekers of Perl Wisdom

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://993623]
Approved by kcott
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others avoiding work at the Monastery: (8)
As of 2013-06-19 23:51 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How many continents have you visited?









    Results (675 votes), past polls