Subject: Patch: FVWM::Module::Tk::show{Debug,Message}

From: Scott Smedley <[email-masked]>
Date: Sat, 14 Jun 2003 13:47:19 +1000

? perllib/FVWM/.Module.pm.swp
? perllib/FVWM/Module/.Gtk.pm.swp
? perllib/FVWM/Module/.Tk.pm.swp
Index: perllib/FVWM/Module/Tk.pm
===================================================================
RCS file: /home/cvs/fvwm/fvwm/perllib/FVWM/Module/Tk.pm,v
retrieving revision 1.9
diff -u -r1.9 Tk.pm
--- perllib/FVWM/Module/Tk.pm	10 Jun 2003 00:00:17 -0000	1.9
+++ perllib/FVWM/Module/Tk.pm	14 Jun 2003 03:45:17 -0000
@@ -17,7 +17,7 @@
 use 5.004;
 use strict;
 
-use FVWM::Module::Toolkit qw(base Tk Tk::Dialog);
+use FVWM::Module::Toolkit qw(base Tk Tk::Dialog Tk::ROText);
 
 sub new ($$@) {
 	my $class = shift;
@@ -75,6 +75,72 @@
 	$self->send("All ('$title') Close") if $btn eq 'Close All Errors';
 }
 
+sub showMessage ($$;$)
+{
+	my $self = shift;
+	my $msg = shift;
+	my $title = shift || ($self->name . " Message");
+
+	$self->topLevel()->messageBox(-icon => 'info',
+		-type => 'ok',
+		-title => $title,
+		-message => $msg);
+}
+
+sub showDebug ($$;$)
+{
+	my $self = shift;
+	my $msg = shift;
+	my $title = shift || ($self->name . " Debug");
+
+	if (!$self->{tkDebugDialog})
+	{
+		if (!defined $self->topLevel())
+		{
+			# App hasn't been fully created - too early to popup a dialog.
+			$self->FVWM::Module::showDebug($msg);
+			return;
+		}
+
+		# # Tk's Dialog widgets are too damn inflexible. It's less
+		# hassle to build one from scratch.
+		my $tl = $self->topLevel()->Toplevel(-title => $title);
+		my $top = $tl->Frame()->pack(-expand => 1, -fill => 'both');
+		my $bottom = $tl->Frame()->pack(-expand => 1, -fill => 'x');
+		my $t = $top->Scrolled('ROText',
+			-bg => 'white',
+			-wrap => 'word',
+			-scrollbars => 'oe')->pack();
+
+		$tl->protocol('WM_DELETE_WINDOW', sub { $tl->withdraw(); });
+		my (@pl) = (-side => 'left', -expand => 1, -fill => 'both');
+		$bottom->Button(-text => 'Close', -command => sub {
+			$tl->withdraw(); })->pack(@pl);
+		$bottom->Button(-text => 'Clear', -command => sub {
+			$t->delete('0.0', 'end'); })->pack(@pl);
+		$bottom->Button(-text => 'Save', -command => sub {
+			my $f = $tl->getSaveFile(-title => 'Save' . $title);
+			return if (!defined $f);
+			if (!open(OUT, ">$f"))
+			{
+				$self->showError("Couldn't save $f: $!", 'Save Error');
+				return;
+			}
+
+			print OUT $t->get('0.0', 'end');
+			close(OUT); })->pack(@pl);
+
+		$self->{tkDebugDialog} = $tl;
+		$self->{tkDebugTextW} = $t;
+	}
+	else
+	{
+		$self->{tkDebugDialog}->deiconify();
+	}
+	$self->{tkDebugTextW}->insert('end', $msg . "\n");
+	$self->{tkDebugTextW}->see('end');
+}
+
 sub topLevel ($) {
 	return shift->{topLevel};
 }
@@ -108,8 +174,9 @@
 =head1 DESCRIPTION
 
 The B<FVWM::Module::Tk> package is a sub-class of B<FVWM::Module> that
-overloads the methods B<new>, B<eventLoop> and B<showError> to manage
-Tk objects as well. It also adds new methods B<topLevel> and B<winId>.
+overloads the methods B<new>, B<eventLoop>, B<showMessage>, B<showDebug> and
+B<showError> to manage Tk objects as well. It also adds new methods
+B<topLevel> and B<winId>.
 
 This manual page details only those differences. For details on the
 API itself, see L<FVWM::Module>.
@@ -146,6 +213,21 @@
 "Exit Module" terminates your entire module.
 
 Good for diagnostics of a Tk based module.
+
+=item B<showMessage> I<msg> [I<title>]
+
+Creates a message window with one "Ok" button.
+
+=item B<showDebug> I<msg> [I<title>]
+
+Creates a debug window with 3 buttons - Close, Clear & Save.
+All debug messages are added to the debug window.
+
+"Close" will withdraw the window until the next debug message arrives.
+"Clear" erases the current contents of the debug window.
+"Save" will dump the current contents of the debug window to the selected file.
+
+Useful for debugging Tk based modules.
 
 =item B<topLevel>