#!/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
##==============================================================================