<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#! /nmlprodpkgs/perl/bin/perl -w

#***************************************************************************

=head1 NAME

sqlgui - a GUI SQL processor

=head1 DESCRIPTION

This tool serves as a GUI to a database server.  Currently, only Sybase
is supported.  The GUI processes SQL statements entered by the user and
supplies an object browser by which one may view table column names and
stored procedure code.

=head1 AUTHOR

by Dr. Scott E. Aaron

=head1 COPYRIGHT

This script is Copyright (c) 2001 by Dr. Scott E. Aaron.
The script is free software; you can redistribute it and/or
modify it under the same terms as Perl itself with the exception that it
cannot be placed on a CD-ROM or similar media for commercial distribution
without the prior approval of the author.

=head1 ENVIRONMENT

The following environment variables must be set by the user before starting
the application:

=over 3

=item DSQUERY

The default data server for the user.

=item BLAZARUSER, BLAZARPASSWD, BLAZARDEFAULTDB, BLAZARDEFAULTDBTYPE

The user ID, password, default database, and data server type for
the data server indicated in DSQUERY.  B&lt;N.B.&gt; BLAZARDEFAULTDBTYPE
must be set to Sybase at this time, as that is the only data server
type currently supported.

=back

=head1 SCRIPT CATEGORIES

=head1 PREREQUISITES

The tool uses the C&lt;Tk&gt; (including the Tix extensions) and C&lt;DBI&gt; modules, 
all available from CPAN.

=head1 OSNAMES

MSWin32, any Unix

=head1 README

This script implements a graphical interface to a database server.
Currently only Sybase servers are supported, but I expect it will be 
a simple matter to extend the tool to other dataserver types.  The tool
supports an arbitrary number of simultaneous connections.

The GUI allows the following functionality

=over 3

=item Interactive SQL

The main window is divided into two main areas, one a text area in which
SQL statements may be editted and an area where query results are formatted
in a grid.

=item Object browser

One may browse the objects on a dataserver.  The tool allows one to
extract column headings and types for a table, and the SQL code for a
stored procedure.

=item Profiles

Log-in information for each dataserver the user accesses may be saved in
a profile and retrieved with the click of the mouse.

=back

=cut

#***************************************************************************

use strict;

# libraries.
use DBI; use Tk; use Tk::NoteBook; use Tk::DialogBox; use Tk::Font;
use Tk::HList; use Tk::Dialog; use Tk::FBox; use Tk::Tree; use Tk::Balloon;
use Tk::LabFrame; 
use FileHandle;

# What is the name of this wonderful system?
use constant PROGRAM_NAME =&gt; 'BlazarSQL';

# Exception handling syntax.
sub try (&amp;@);
sub catch(&amp;);
sub throw($);

# subroutines.
sub loadSQL();           # load a file to the SQL editor.
sub saveSQL();           # save the contents of the SQL editor to a file.
sub processSQL(;$@);     # process the SQL in the editor.
sub buildMainWindow();   # build the main window.
sub connectDataSource(); # call back to connect to a data source.
sub disconnectDataSource();
sub buildConnectionDescriptor($$$$$);
sub buildEditor($$);       
sub statusMessage($);    # show a status message.
sub getCurrentConnectionDesc();
sub processingErrorDialog($);
sub showObjectBrowser();

# A hash to store the bitmaps.
my %bitmaps = (
	       BlazarSQL =&gt; '/* XPM */
static char * BlazarSQL_xpm[] = {
/* width height ncolors cpp [x_hot y_hot] */
"32 32 4 1 -1 -1",
/* colors */
" 	c #EFEFA0A06F6F",
".	c #E0E0A0A06F6F",
"X	s iconColor5	m black	c blue",
"o	s iconColor4	m white	c green",
/* pixels */
" . . . . . . . . . . . . . . . .",
"  .   .   .   .   .   .   .   . ",
" . . . . . . . . . . . . . . . .",
".   .   .   .   .   .   .   .   ",
" . .XXXXX. . . . . . . . . . . .",
"  . X .  X.   .   .   .   .   . ",
" . .X. . .X. . . . . . . . . . .",
".  XX   .XX .   .   .   .   .   ",
" . X .XXXX . . . . . . . . . . .",
"  .X XXXX .   .   .   .   .   . ",
" . X . .XX . . . . . . . . . . .",
".  X.   .X  .   .   .   .   .   ",
" . X . .XX . . . . . . . . . . .",
"  X XXXXX .   .   .   .   .   . ",
" . XX. . . . . . . . . . . . . .",
".   .   .   .   .   .   .   .   ",
" . . . . . . . . . . . . . . . .",
"  .   ooooo  ooo  .   .   .   . ",
" . . o . . ooo .ooo. o . . . . .",
".   .o  .  o.   . o .o  .   .   ",
" . . .oooo o . . .o. o . . . . .",
"  .   .  ooo  . o o  o.   .   . ",
" . . . . .ooo. .oo . o . . . . .",
".   .   .o  .oooooo .o  .   .   ",
" . .ooooo. . . . . o oo. . . . .",
"  .   .   .   .   .   oooo.   . ",
" . . . . . . . . . . . . . . . .",
".   .   .   .   .   .   .   .   ",
" . . . . . . . . . . . . . . . .",
"  .   .   .   .   .   .   .   . ",
" . . . . . . . . . . . . . . . .",
".   .   .   .   .   .   .   .   "};',
      connect =&gt; '/* XPM */
static char * connect_xpm[] = {
/* width height ncolors cpp [x_hot y_hot] */
"16 16 6 1 0 0",
/* colors */
" 	c None",
".	c #EFEFAFAF7070",
"X	s iconColor7	m white	c cyan",
"o	c #E0E0A0A06F6F",
"O	s iconColor3	m black	c red",
"+	s iconColor5	m black	c blue",
/* pixels */
"                ",
"                ",
"XXXXXXXX        ",
"X      X        ",
"XXXXXXXX        ",
"X  X   X    OOO ",
"X  X   X   O   O",
"XXXXXXXX   O   O",
"    +      OOOOO",
"    +   +  O   O",
"    ++   + O   O",
"     ++++++O   O",
"         + O   O",
"        +   OOO ",
"                ",
"                "};',
      execute =&gt; '/* XPM */
static char * execute_xpm[] = {
/* width height ncolors cpp [x_hot y_hot] */
"16 16 2 1 -1 -1",
/* colors */
" 	c None",
"X	s iconColor4	m white	c green",
/* pixels */
"                ",
"                ",
"                ",
"   X            ",
"   XXX          ",
"   XXXXX        ",
"   XXXXXXX      ",
"   XXXXXXXXX    ",
"   XXXXXXXXXX   ",
"   XXXXXXXXX    ",
"   XXXXXXX      ",
"   XXXXX        ",
"   XXX          ",
"   X            ",
"                ",
"                "};',
      info =&gt; '/* XPM */
static char * info_xpm[] = {
/* width height ncolors cpp [x_hot y_hot] */
"16 16 3 1 0 0",
/* colors */
" 	c NONE",
".	c #E0E0A0A06F6F",
"X	s iconColor1	m black	c black",
/* pixels */
"       XX       ",
"      XXXX      ",
"      XXXX      ",
"                ",
"       XX       ",
"      X X       ",
"        X       ",
"        X       ",
"        X       ",
"        X       ",
"        X       ",
"        X       ",
"        X       ",
"     XXXXXXX    ",
"                ",
"                "};',
       save =&gt; '/* XPM */
static char * save_xpm[] = {
/* width height ncolors cpp [x_hot y_hot] */
"16 16 4 1 -1 -1",
/* colors */
" 	c None",
"X	s iconColor1	m black	c black",
"o	c #DFDFDFDFDFDF",
"O	c #D0D0D0D0D0D0",
/* pixels */
"                ",
"  XXXXXXXXXXXX  ",
"  XXXXXXXXXXXX  ",
"  XXoooooooX X  ",
"  XXoOoOoOoX X  ",
"  XXoooooooXXX  ",
"  XXoOoOoOoXXX  ",
"  XXoooooooXXX  ",
"  XXXXXXXXXXXX  ",
"  XXXXXXXXXXXX  ",
"  XXXXXXXXXXXX  ",
"  XXXXXXXX  XX  ",
"  XXXXXXXX  XX  ",
"    XXXXXX  XX  ",
"    XXXXXXXXXX  ",
"                "};',
       stop =&gt; '/* XPM */
static char * stop_xpm[] = {
/* width height ncolors cpp [x_hot y_hot] */
"16 16 3 1 -1 -1",
/* colors */
" 	c None",
".	c None",
"X	s iconColor3	m black	c red",
/* pixels */
" . . . . . . . .",
"  .   .   .   . ",
" . . XXXXXX. . .",
".   XXXXXXXX.   ",
" . XXXXXXXXXX. .",
"  XXXXXXXXXXXX. ",
" .XXXXXXXXXXXX .",
". XXXXXXXXXXXX  ",
" .XXXXXXXXXXXX .",
" .XXXXXXXXXXXX .",
"  XXXXXXXXXXXX. ",
" . XXXXXXXXXX. .",
".   XXXXXXXX.   ",
" . . XXXXXX. . .",
"  .   .   .   . ",
".   .   .   .   "};'
);

# globals.
my %connections = (); # a global container to store objects describing
	              # an active connection.
my $connindex = 0;

# constants, to give default connection values.
use constant DEFAULT_SERVER =&gt; $ENV{DSQUERY};
use constant DEFAULT_USER   =&gt; $ENV{BLAZARUSER} 
  || die "Please set BLAZARUSER!\n";;
use constant DEFAULT_PASSWD =&gt; $ENV{BLAZARPASSWD}
  || die "Please set BLAZARPASSWD\n";
use constant DEFAULT_DBASE  =&gt; $ENV{BLAZARDEFAULTDB}
  || die "Please set BLAZARDEFAULTDB!\n";
use constant DEFAULT_DBASE_TYPE =&gt; $ENV{BLAZARDEFAULTDBTYPE}
  || die "Please set BLAZARDEFAULTDBTYPE!\n";

# main line.
my ($gui, $mainpanel, $statuslabel) = buildMainWindow();
statusMessage('waiting....');

# Build a connection to the default server.  This is required to get
# the window layed out correctly.
buildConnectionDescriptor(DEFAULT_SERVER, DEFAULT_USER,
                          DEFAULT_PASSWD, DEFAULT_DBASE, 
			  DEFAULT_DBASE_TYPE);

# start the event handling.
MainLoop();

#***************************************************************************

sub getCurrentConnectionDesc() {
    my $panel = $mainpanel-&gt;raised();
    return undef if !defined($panel);
    return $connections{$panel};
}

#***************************************************************************

use constant RESULTS_WIDTH =&gt; 80;
use constant RESULTS_HEIGHT =&gt; 25;

sub buildResultsDisplay($$;$) {
    my ($panel, $font, $columns) = @_;

    # do we have rows and columns?
    my ($wtype, @args) = ('', ());
    if (defined $columns) {
	# build an HList object with a header.
	$wtype = 'HList';
	@args = ( -columns =&gt; $columns,
		  -header  =&gt; 1,
		  -selectmode =&gt; 'multiple' );
    } else { # just build a scrolled text area.
	$wtype = 'Text';
	@args = ( -wrap =&gt; 'none' );
    }

    # Build the desired widget.
    my $disp = $panel-&gt;Scrolled($wtype,
				-scrollbars =&gt; 'se',
				-height     =&gt; RESULTS_HEIGHT,
				-width      =&gt; RESULTS_WIDTH,
				-font       =&gt; $font,
				-exportselection =&gt; 'true',
				@args);

    $disp-&gt;pack(
		-side =&gt; 'left',
		-fill =&gt; 'both',
		-expand =&gt; 1
	       );

    # return it.
    return $disp;
}

#***************************************************************************

sub buildEditor($$) {
    my ($dserver, $dbase) = @_;

    # add a tab to the main panel.
    my $ed = $mainpanel-&gt;add(
			     $connindex,
			     -label    =&gt; $dserver
			    );

    # build the SQL editor
    my $sqled = $ed-&gt;Scrolled('Text',
			      -scrollbars =&gt; 'se',
			      -wrap       =&gt; 'none',
			      -height     =&gt; RESULTS_HEIGHT,
			      -width      =&gt; 50,
			      -exportselection =&gt; 'true'
			     )-&gt;pack( 
				      -side   =&gt; 'left',
				      -fill   =&gt; 'y',
				      -expand =&gt; 1,
				      -anchor =&gt; 'w'
				    );

    # build the results window.
    my $resultspanel = $ed-&gt;Frame()-&gt;pack( 
					   -side =&gt; 'left',
					   -fill =&gt; 'both',
					   -expand =&gt; 1,
					   -anchor =&gt; 'w'
					 );
    my $results = buildResultsDisplay($resultspanel, $sqled-&gt;cget('font'));
    return ($sqled, $resultspanel, $results);
}

#***************************************************************************

sub buildToolBarButton($$$$) {
    my ($frame, $helptxt, $routine, $img) = @_;
    my $bg = $frame-&gt;cget('-background');
    my @args = ();
    if (-f $img) {
	@args = ( -file =&gt; $img );
    } else {
	@args = ( -data =&gt; $bitmaps{$img} );
    }
    my $bitmap = $frame-&gt;Pixmap(@args);
    my $button = $frame-&gt;Button( 
				 -image   =&gt; $bitmap,
				 -command =&gt; $routine,
				 -activebackground =&gt; $bg
			       )-&gt;pack(
				       -side   =&gt; 'left',
				      );
    my $font = $button-&gt;cget('-font')-&gt;Clone(
					     -size   =&gt; 9,
					     -family =&gt; 'Times'
					    );
    my $balloon = $frame-&gt;Balloon(
				  -font       =&gt; $font,
				  -background =&gt; 'Wheat'
				 );
    $balloon-&gt;attach($button,
		     -balloonmsg =&gt; $helptxt);
    return $button;
}

#***************************************************************************

sub statusMessage($) {
    my $txt = shift();
    $statuslabel-&gt;configure(
			    -text   =&gt; $txt,
			    -anchor =&gt; 'w'
			   );
}

#***************************************************************************

my $cancel_query;  # a flag to indicate that a query should be killed.

sub cancelQuery { $cancel_query = 1; }

#***************************************************************************

sub buildMainWindow() {
    my $win = new MainWindow();
    $win-&gt;title(PROGRAM_NAME);

    # add an icon.
    my $pmap = $win-&gt;Pixmap( -data =&gt; $bitmaps{BlazarSQL} );
    $win-&gt;iconimage($pmap);

    # build the menu for the main window.
    my $menu = $win-&gt;Menu();

    # set the font to be used in the menu and cascades.
    my $menufont = $menu-&gt;cget('-font')-&gt;Clone(
					       -family =&gt; 'Helvetica',
					      );
    $menu-&gt;configure( -font =&gt; $menufont );

    # add the menu to the window
    $win-&gt;configure( 
		     -menu   =&gt; $menu,
		    );

    # add a File menu
    my $file_menu = 
	$menu-&gt;cascade(
		       -label     =&gt; 'File',
		       -tearoff   =&gt; 0,
		       -menuitems =&gt; [
				      [ command  =&gt; 'New',
					-font    =&gt; $menufont,
					-command =&gt; \&amp;newEditor ],
				      [ command  =&gt; 'Open',
					-font    =&gt; $menufont,
					-command =&gt; \&amp;loadSQL ],
				      [ command  =&gt; 'Save',
					-font    =&gt; $menufont,
					-command =&gt; \&amp;saveSQL] ,
				      '',
				      [ command  =&gt; 'Exit',
					-font    =&gt; $menufont,
					-command =&gt; [ $win =&gt; 'destroy' ]]
				     ]
		      );

    # some key bindings for the file menu.
    $win-&gt;bind('&lt;Control-n&gt;'
	       =&gt; \&amp;newEditor);

    # A menu for information about datasource connections.
    my $data_menu =
	$menu-&gt;cascade(
		       -label     =&gt; 'Datasource',
		       -tearoff   =&gt; 0,
		       -menuitems =&gt; [
				      [ command  =&gt; 'Connect',
					-font    =&gt; $menufont,
					-command =&gt; \&amp;connectDataSource ],
				      [ command  =&gt; 'Disconnect',
					-font    =&gt; $menufont,
					-command =&gt; \&amp;disconnectDataSource ],
				      [ command  =&gt; 'Connection Info',
					-font    =&gt; $menufont,
					-command =&gt; \&amp;showConnectionInfo ],
				      [ command  =&gt; 'Profiles',
					-font    =&gt; $menufont,
					-command =&gt; \&amp;manageProfiles ],
				      [ command  =&gt; 'Objects',
					-font    =&gt; $menufont,
					-command =&gt; \&amp;showObjectBrowser ]
				     ]
		      );

    # A menu for query commands.
    my $query_menu = 
	$menu-&gt;cascade(
		       -label     =&gt; 'Query',
		       -tearoff   =&gt; 0,
		       -menuitems =&gt; [
				      [ command  =&gt; "Execute",
					-font    =&gt; $menufont,
					-command =&gt; \&amp;processSQL ],
				      [ command  =&gt; 'Cancel',
					-font    =&gt; $menufont,
					-command =&gt; \&amp;cancelQuery ],
				     ]
		      );

    # bind Alt-e to the execute command.
    $win-&gt;bind('&lt;Alt-e&gt;' =&gt; sub { processSQL() });

    # a help menu.
    my $help_menu =
	$menu-&gt;cascade(
		       -label     =&gt; 'Help',
		       -tearoff   =&gt; 0,
		       -menuitems =&gt; [
				      [
				       command  =&gt; 'Guide',
				       -font    =&gt; $menufont,
				       -command =&gt; \&amp;showUserGuide
				      ],
				      [
				       command  =&gt; 'About',
				       -font    =&gt; $menufont,
				       -command =&gt; \&amp;showAboutScreen
				      ],
				     ]
		      );

    # build a tool bar.
    my $toolbarpanel = $win-&gt;Frame(
				   -relief      =&gt; 'raised',
				   -borderwidth =&gt; 1
				  )-&gt;pack(
					  -side   =&gt; 'top',
					  -anchor =&gt; 'w',
					  -expand =&gt; 0,
					  -fill   =&gt; 'x'
					  );
    my $openbutton = buildToolBarButton($toolbarpanel, 'Open SQL file',
					\&amp;loadSQL, Tk-&gt;findINC('wintext.xpm'));
    my $savebutton = buildToolBarButton($toolbarpanel, 'Save SQL file',
					\&amp;saveSQL, 'save');
    my $infobutton = buildToolBarButton($toolbarpanel, 'Connection info',
					\&amp;showConnectionInfo, 
				        'info');
    my $newconnectionbutton = 
	buildToolBarButton($toolbarpanel,
			   'Open connection',
			   \&amp;connectDataSource,
			   'connect');
    my $executebutton = buildToolBarButton($toolbarpanel,
					   'Execute SQL',
					   sub { processSQL(); },
                                           'execute');
    my $cancelbutton = buildToolBarButton($toolbarpanel,
                                          'Cancel query', 
                                          \&amp;cancelQuery, 
                                          'stop');

    # Now build the panel in which the editor and results displays will
    # be shown.
    my $mainpanel = $win-&gt;NoteBook()-&gt;pack( 
					    -side   =&gt; 'top',
					    -expand =&gt; 1,
					    -fill   =&gt; 'both',
					    -padx   =&gt; 3,
					    -pady   =&gt; 3,
					  );
    
    # build a status panel and label widget.  Use the menu font to look
    # nicer.
    my $label = $win-&gt;Label( 
			     -relief =&gt; 'sunken',
                             -font   =&gt; $menufont
			   );
    $label-&gt;pack( 
		  -side =&gt; 'bottom', 
		  -expand =&gt; 0,
		  -fill   =&gt; 'x',
                  -anchor =&gt; 's'
		);

    # return the editor, results, and label objects.
    return ($win, $mainpanel, $label);
}

#***************************************************************************

sub errorMessage($) {
    my $msg = shift();
    warn "$msg\n";
}

#***************************************************************************

sub newEditor() {
    my $desc = getCurrentConnectionDesc();
    if (!defined($desc)) {
	statusMessage('No connection currently in use');
	return 0;
    }
    buildConnectionDescriptor($desc-&gt;{server}, $desc-&gt;{user},
			      $desc-&gt;{pass}, $desc-&gt;{dbase}, 
			      $desc-&gt;{type});
    $mainpanel-&gt;raise($connindex - 1);
}

#***************************************************************************

sub disconnectDataSource() {
    my $desc = getCurrentConnectionDesc();
    if (! defined $desc) {
	statusMessage("No active connections....");
	return;
    };

    # disconnect from the server.
    statusMessage("Disconnecting from " . $desc-&gt;{server});
    $desc-&gt;{dbh}-&gt;disconnect();

    # destroy the editor and results windows.
    $mainpanel-&gt;delete($desc-&gt;{index});

    # remove from the connection list.
    delete $connections{$desc-&gt;{index}};
}

#***************************************************************************

sub labelTextPair($$$) {
    my ($p, $label, $def) = @_;
    my $l = $p-&gt;Label(
		      -text  =&gt; $label,
		      -width =&gt; 10,
		      -anchor =&gt; 'w'
		     )-&gt;pack( -side =&gt; 'left' );
    my $t = $p-&gt;Entry(
		      -width =&gt; 20
		     )-&gt;pack( -side =&gt; 'left' );
    $t-&gt;insert('end', $def);
    return $t;
}

#***************************************************************************

use constant HOME =&gt; ($^O eq 'MSWin32') ? 'c:' : $ENV{HOME};
use constant PROFILE_DIR =&gt; HOME . "/.blazar";
use constant PROFILE_FILE =&gt; PROFILE_DIR . "/profiles";
use SDBM_File;

my $profiles;
sub loadProfiles() {
    # ensure there is a directory.
    unless (-d PROFILE_DIR) {
	mkdir PROFILE_DIR, 0700 || warn "unable to mkdir:  $!";
	warn "created profile directory....\n";
    }

    # open the profile data base.
    my %hash;
    tie (%hash, 'SDBM_File', PROFILE_FILE, O_RDWR|O_CREAT, 0600)
	|| do {
	    warn "Unable to open profile file:   $!\n";
	    return undef;
	};

    # return the object.
    return \%hash;
}

BEGIN {  # load the existing profiles.
    $profiles = loadProfiles();
}

sub addProfile($$$$$) {
    my ($user, $pass, $server, $dbase, $type) = @_;

    # add the new one.
    my $key = "$server/$user";
    $profiles-&gt;{$key} = "$user/$pass/$server/$dbase/$type";
}

#***************************************************************************

sub profileManager_updateList($) {
    my $profilelist = shift();
    $profilelist-&gt;delete('0.0', 'end');
    for my $key (keys %$profiles) {
	$profilelist-&gt;insert(0, $key);
    }
}

sub profileManager_delete($) {
    my $profilelist = shift();

    # what profile have we selected?
    my $index = $profilelist-&gt;curselection();
    return unless defined($index);

    # remove the key.
    my $key = $profilelist-&gt;get($index);
    delete $profiles-&gt;{$key};

    # update the display.
    profileManager_updateList($profilelist);
}

sub manageProfiles() {
    # build a dialog window.
    my $manager = $gui-&gt;DialogBox(
				  -title   =&gt; 'Profile manager',
				  -buttons =&gt; [ 'Done' ]
				 );

    my $mainframe = $manager-&gt;add('Frame',
				  -relief =&gt; 'raised'
				 )-&gt;pack(
					 -padx =&gt; 2,
					 -pady =&gt; 2
					);

    # add a list of profiles.
    my $profilelist = $mainframe-&gt;Scrolled('Listbox',
					   -scrollbars =&gt; 'e',
					   -width  =&gt; 30,
					   -height =&gt; 5
					  )-&gt;pack( -side =&gt; 'left' );
    profileManager_updateList($profilelist);

    # add a panel for buttons.
    my $buttonpanel = $mainframe-&gt;Frame()-&gt;pack( 
						 -side =&gt; 'left',
						 -padx =&gt; 5
					       );
    my $delete = $buttonpanel-&gt;Button(
				      -text =&gt; 'delete',
				      -activebackground =&gt;
				         $manager-&gt;cget('background'),
				      -command =&gt; sub { 
					  profileManager_delete($profilelist);
				      }
				     )-&gt;pack();
    
    # show the window
    $manager-&gt;Show();
}

#***************************************************************************

sub connectDataSource() {
    # get the necessary information via a dialog box
    my $dbox = $gui-&gt;DialogBox(
			       -title =&gt; 'Open connection',
			       -buttons =&gt; [ 'Ok', 'Save', 'Cancel' ],
			       -default_button =&gt; 'Ok'
			      );

    # what type of server is this.  Currently, only Sybase is supported.
    my $server_type = 'Sybase';

    # add an option menu to include all the profiles.
    my $profilemenupanel = $dbox-&gt;add('LabFrame',
				      -label     =&gt; 'Profiles',
				      -labelside =&gt; 'acrosstop'
				     );
    $profilemenupanel-&gt;pack( 
			     -side =&gt; 'top',
			     -padx =&gt; 2,
			     -pady =&gt; 2
			   );
    my $profilemenu = $profilemenupanel-&gt;Optionmenu();
    $profilemenu-&gt;pack( 
			-side =&gt; 'top',
			-padx =&gt; 2,
			-pady =&gt; 2
		      );

    # load the profiles.
    $profilemenu-&gt;addOptions(keys %$profiles) if defined($profiles);

    # add the entry areas for the information we need.
    my ($namee, $passe, $servere, $dbasee);
    my @entries = (
		   {
		       label =&gt; 'name:',
		       'var' =&gt; \$namee,
		       defval =&gt; DEFAULT_USER,
		   },
		   {
		       label =&gt; 'password:',
		       'var' =&gt; \$passe,
		       defval =&gt; DEFAULT_PASSWD,
		   },
		   {
		       label =&gt; 'server:',
		       'var' =&gt; \$servere,
		       defval =&gt; DEFAULT_SERVER,
		   },
		   {
		       label =&gt; 'data base:',
		       'var' =&gt; \$dbasee,
		       defval =&gt; DEFAULT_DBASE
		   },
		  );

    my $lframe = $dbox-&gt;add('LabFrame',
			    -label     =&gt; 'Connection',
			    -labelside =&gt; 'acrosstop'
			   );
    $lframe-&gt;pack( 
		   -side =&gt; 'top',
		   -padx =&gt; 2,
		   -pady =&gt; 2
		 );
    for my $desc (@entries) {
	my $entry = $desc-&gt;{var};
	my $panel = $lframe-&gt;Frame()-&gt;pack( -side =&gt; 'top' );
	$panel-&gt;pack( 
		      -side =&gt; 'top',
		      -padx =&gt; 2,
		      -pady =&gt; 2
		    );
	$$entry = labelTextPair($panel, $desc-&gt;{label}, $desc-&gt;{defval});
    }

    # configure the profile option menu to fill in the blanks
    # if a profile is chosen.
    $profilemenu-&gt;configure(
			    -command =&gt; sub {
				my $key = shift();
				my ($user, $pass, $server, $dbase, $type)
				    = split('/', $profiles-&gt;{$key});
				$servere-&gt;delete('0.0', 'end');
				$servere-&gt;insert('end', $server);
				$namee-&gt;delete('0.0', 'end');
				$namee-&gt;insert('end', $user);
				$passe-&gt;delete('0.0', 'end');
				$passe-&gt;insert('end', $pass);
				$dbasee-&gt;delete('0.0', 'end');
				$dbasee-&gt;insert('end', $dbase);
				$server_type = $type || 'Sybase';
			    }
			   ) if ($profiles);

    # show the dialog and get the button chosen.
    my $choice = $dbox-&gt;Show();
    return if $choice eq 'Cancel';
    
    # if we need to save this, do so before connecting.
    if ($choice eq 'Save') {
	addProfile($namee-&gt;get(), $passe-&gt;get(), $servere-&gt;get(), 
		   $dbasee-&gt;get(), $server_type);
    }

    # get the variables.
    buildConnectionDescriptor($servere-&gt;get(), $namee-&gt;get(), 
			      $passe-&gt;get(), $dbasee-&gt;get(),
			      $server_type) || return;

    # raise the entry we just made.
    $mainpanel-&gt;raise($connindex - 1);
}

#***************************************************************************

use Net::Domain;
sub buildConnectionDescriptor($$$$$) {
    my ($dserver, $user, $pass, $dbase, $type) = @_;
    my $rc = 1;

    # Get the hostname from which we are connecting.  There is a nice
    # utility in the Net::Domain module to return this, but it doesn't
    # appear to work for Windows.  But there is another way I can do it.
    my $hname = undef;
    if ($^O eq 'MSWin32') {
	$hname = (gethostbyname('localhost'))[0];
	$hname =~ s/^(.*?)\..*?$/$1/;
    } else {
	$hname = Net::Domain::hostname();
    }

    # connect to the server.
    statusMessage("Connecting to $dserver...");
    my $constr = "dbi:$type:server=$dserver;database=$dbase;hostname=$hname;scriptName=" . PROGRAM_NAME;
    try {
	my $dbh = DBI-&gt;connect($constr, $user, $pass,
			       { RaiseError =&gt; 1, PrintError =&gt; 0 });
	statusMessage("Successfully connected!");

	# build a descriptor object.
	my $desc = {};
	$desc-&gt;{index} = $connindex;
	$desc-&gt;{dbh} = $dbh;
	$desc-&gt;{server} = $dserver;
	$desc-&gt;{user} = $user;
	$desc-&gt;{pass} = $pass;
	$desc-&gt;{dbase} = $dbase;
	$desc-&gt;{type}  = $type;

	# build a new editor and results window.
	my ($ed, $respanel, $res) = buildEditor($dserver, $dbase);
	$desc-&gt;{editor} = $ed;
	$desc-&gt;{results} = $res;
	$desc-&gt;{respanel} = $respanel;

	# insert the descriptor into the global container.
	$connections{$connindex++} = $desc;
    } catch {
	statusMessage("Unable to connect to to $dserver");
	processingErrorDialog($DBI::errstr);
	$rc = undef;
    };			
    return $rc;
}

#***************************************************************************

sub processingErrorDialog($) {
    my $msg = shift();
    my $dbox = $gui-&gt;Dialog(
			    -title =&gt; 'Processing error',
			    -bitmap =&gt; 'error',
			    -buttons =&gt; [ 'Ok' ],
			    -text    =&gt; $msg
			   );
    $dbox-&gt;Show();
}

#***************************************************************************

sub getSQLText(;$) {
    my ($checkselect) = @_;

    # If the checkselect flag is set, then try to get only the selected
    # text.  If nothing is selected, then get everything.
    my $desc = getCurrentConnectionDesc() || return undef;
    my $editor = $desc-&gt;{editor};
    my $sql = undef;
    if ($checkselect) {
      Tk::catch {
	  $sql = $editor-&gt;get('sel.first', 'sel.last');
      };
    }
    
    # if $sql is still undefined, then get everything.
    $sql = $editor-&gt;get('0.0', 'end') unless defined $sql;

    # prune whitespace.
    $sql =~ s/^\s*(.*?)\s*$/$1/s;
    return $sql
}

#***************************************************************************

my @currcursor;
sub setWaitingCursor(@) {
    my @args = @_;
    
    @currcursor = ();
    for my $widget (@args) {
	push(@currcursor, $widget-&gt;cget('cursor'));
	$widget-&gt;configure( -cursor =&gt; 'watch' );
	$widget-&gt;update();
    }
}

sub resetWaitingCursor(@) {
    my @args = @_;
    for (my $i = 0; $i &lt; @args; $i++) {
	my $w = $args[$i];
	$w-&gt;configure( -cursor =&gt; $currcursor[$i] ) if Exists($w);
    }
}
    
#***************************************************************************

sub processSQL(;$@) {
    my ($sql, @args) = @_;
    my $desc = getCurrentConnectionDesc() || do {
	statusMessage("No active connection....");
	return;
    };
    my $editor = $desc-&gt;{editor};
    statusMessage("Executing SQL...");
    $cancel_query = 0;

    # set the cursor to a watch.  Save the current setting.  Note that we
    # are storing the current results display widget in the list of widgets
    # whose cursor setting is updated.  Below, this widget is destroyed.
    # We accept this because if we take an error in the SQL processing, the
    # results display widget is the same as before.  If there are no errors
    # and we create a new display widget, it will have the default cursor
    # which we want restored (the reset code checks that the widget still
    # exists).  Either way, we're OK.
    my @widgetlist = ($gui, $desc-&gt;{editor}, $desc-&gt;{results});
    setWaitingCursor(@widgetlist);

    # Get the SQL code.
    $sql ||= getSQLText(1);
    return unless defined $sql;

    # Is there an SQL statement to execute?
    if ($sql eq "") {
	statusMessage("Error:  no SQL provided");
	resetWaitingCursor(@widgetlist);
	return;
    }

    try {
	# build a statement handle for this guy.
	my $sth = $desc-&gt;{dbh}-&gt;prepare($sql);

	# Put up a local signal handler here to handle USR1 signals by
	# cancelling the query.
	my $rcexec;
	{
	    local $SIG{USR1} = sub {
		$sth-&gt;cancel();
		cancelQuery();
	    };
	    
	    # now execute the query.
	    $rcexec = $sth-&gt;execute(@args);

	    # Take down the signal handler.
	}

	# Display the results.
	statusMessage("Formatting results....");
	$gui-&gt;update();
	my $columns;
        Tk::catch {
	    $columns = $sth-&gt;{NAME};
	};
	if (!defined($columns)) {
	    statusMessage("Query completed and returned no data ($rcexec rows affected)...");
	    return;
	}
	my $ncolumns = @$columns;

	# destroy the display object already there.
	$desc-&gt;{results}-&gt;destroy();
	$desc-&gt;{results} = buildResultsDisplay($desc-&gt;{respanel},
					       $desc-&gt;{editor}-&gt;cget('font'),
					       $ncolumns);
	my $results = $desc-&gt;{results};

	# add the column headers.
	my $i;
	for ($i = 0; $i &lt; $ncolumns; $i++) {
	    my $colhead = $columns-&gt;[$i] || "";
	    $results-&gt;header('create', $i, -text =&gt; $colhead);
	}

	# now add the data.
	my $row;
	my $rowcount = 0;
	while ( defined($row = $sth-&gt;fetchrow_arrayref) ) {
	    $rowcount++;
	    my $val = $results-&gt;addchild('');
	    for ($i = 0; $i &lt; $ncolumns; $i++) {
		my $colval = $row-&gt;[$i];
		$colval = 'NULL' if !defined($colval);
		$results-&gt;itemCreate($val, $i,
				     -itemtype =&gt; 'text',
				     -text       =&gt; $colval);
	    }

	    # update the GUI every 128 rows (easy, efficient calculation)
	    # and check for cancellation.
	    if (($rowcount &amp; 0x7F) == 0) {
		statusMessage("Formatting results, $rowcount rows processed...");
		$gui-&gt;update();
		if ($cancel_query == 1) { # cancel the query
		    $sth-&gt;cancel();
		    last;
		}
	    }
	}

	my $statmsg = "Query completed successfully, returning $rowcount rows...";
	$statmsg = "Query cancelled after $rowcount rows...."
	    if ($cancel_query == 1);
	statusMessage($statmsg);
    } catch {
	statusMessage("Error executing SQL...");
	processingErrorDialog($_);
    };

    # restore original cursor.
    resetWaitingCursor(@widgetlist);
}

#***************************************************************************

use constant FILETYPES =&gt; [
			   [ "SQL files", ".sql" ],
			   [ "All files", "*" ]
			  ];

sub loadSQL() {
    my $desc = getCurrentConnectionDesc() || do {
	statusMessage("No SQL connection currently open...");
	return;
    };
    my $editor = $desc-&gt;{editor};
    my $file = $gui-&gt;getOpenFile(
				 -filetypes =&gt; FILETYPES
				);
    if (defined $file &amp;&amp; $file ne '') {
	my $fh = new FileHandle("&lt; $file") || do {
	    statusMessage("Unable to open file $file for input");
	    return;
	};
	local $/ = undef;
	my $sql = $fh-&gt;getline();
	$fh-&gt;close();
	$editor-&gt;delete('0.0', 'end');
	$editor-&gt;insert('end', $sql);
    }
}

#***************************************************************************

sub saveSQL() {
    my $sql = getSQLText();
    if ($sql eq '') {
	statusMessage("No SQL code to save.");
	return;
    }
    my $file = $gui-&gt;getSaveFile(
				 -filetypes        =&gt; FILETYPES,
				 -defaultextension =&gt; '.sql',
				 -initialfile      =&gt; 'Untitled'
				);
    if (defined $file &amp;&amp; $file ne '') {
	my $fh = new FileHandle("&gt; $file") || do {
	    statusMessage("Unable to open file $file for output");
	    return;
	};
	$fh-&gt;print($sql);
	$fh-&gt;close();
    }
}

#***************************************************************************

sub showConnectionInfo() {
    my $desc = getCurrentConnectionDesc() || do {
	statusMessage("No connection currently active....");
	return;
    };
    my $dbox = $gui-&gt;DialogBox(
			       -title =&gt; 'Connection info',
			       -buttons =&gt; [ 'Ok' ]
			      );
    my $text = $dbox-&gt;add('Text', -height =&gt; 4, -width =&gt; 45);
    $text-&gt;pack();
    $text-&gt;insert('end', "user:     " . $desc-&gt;{user}    . "\n" .
		         "server:   " . $desc-&gt;{server}  . "\n" .
		         "database: " . $desc-&gt;{dbase}   . "\n" .
			 "type:     " . $desc-&gt;{type});
    $text-&gt;configure( -state =&gt; 'disabled' );
    $dbox-&gt;Show();
}

#***************************************************************************

use constant SYBASE_OBJECT_NAMES_SQL =&gt; "
select b.name
from sysusers a,
     sysobjects b
where a.uid = b.uid
  and a.name = ?
  and b.type = ?
order by b.name";

sub getObjectNamesByType($$$) {
    my ($dbh, $owner, $type) = @_;
    my $sth = $dbh-&gt;prepare_cached(SYBASE_OBJECT_NAMES_SQL);
    $sth-&gt;execute($owner, $type);
    return $sth;
}

#***************************************************************************

use constant SYBASE_PROCEDURE_CODE_SQL =&gt; "
select c.text
from sysusers    a,
     sysobjects  b,
     syscomments c
where a.name = ?
  and b.type = 'P'
  and b.name = ?
  and a.uid  = b.uid
  and b.id   = c.id";

sub listProcedureCode($$) {
    my ($proc, $owner) = @_;
    my $desc = getCurrentConnectionDesc() || do {
	statusMessage("No connection currently active...");
	return;
    };
    my $sth = $desc-&gt;{dbh}-&gt;prepare_cached(SYBASE_PROCEDURE_CODE_SQL);
    try {
	$sth-&gt;execute($owner, $proc);
    } catch {
	statusMessage("Unable to get code for $proc");
	processingErrorDialog($_);
	$sth = undef;
    };
    return unless defined $sth;
    statusMessage("Getting code for $owner.$proc...");
    my $text; my $code = "";
    $sth-&gt;bind_col(1, \$text);
    while ($sth-&gt;fetchrow_arrayref) {
	$code .= $text;
    }
    $desc-&gt;{results}-&gt;destroy();
    $desc-&gt;{results} = buildResultsDisplay($desc-&gt;{respanel},
					   $desc-&gt;{editor}-&gt;cget('font'));
    $desc-&gt;{results}-&gt;insert('end', $code);
    $desc-&gt;{results}-&gt;configure(-state =&gt; 'disabled');
}
                   
#***************************************************************************

use constant SYBASE_LIST_TABLE_COLUMNS_SQL =&gt; "
select 'table columns' = c.name, 'type' = d.name
from sysusers   a,
     sysobjects b,
     syscolumns c,
     systypes   d
where a.uid = b.uid
  and b.id = c.id
  and c.usertype = d.usertype
  and a.name = ?
  and b.name = ?
order by colid";

sub listTableColumns($$) {
    my ($table, $owner) = @_;

    processSQL(SYBASE_LIST_TABLE_COLUMNS_SQL, $owner, $table);
    statusMessage("Getting column list for $owner.$table....");
}

#***************************************************************************

sub buildObjectTypeLeaf($$$$$$$$) {
    my ($leaf, $path, $dbh, $tree, $name, $type, 
	$owner, $chlabel) = @_;
    my $id = $path. "." . $name;
    my $child = $tree-&gt;add($id,
			   -text =&gt; $name
			  );
    try {
	my $sth = getObjectNamesByType($dbh, $owner, $type);
	my $oname;
	$sth-&gt;bind_col(1, \$oname);
	while ($sth-&gt;fetchrow_arrayref) {
	    my $iid = "$id.$oname";
	    my $low = $tree-&gt;add($iid,
				 -text =&gt; $oname
				 );
	    $tree-&gt;setmode($low, 'open');
	    $tree-&gt;hide('entry', $low);
	    $iid .= ".$chlabel";
	    my $lowest = $tree-&gt;add($iid,
				    -text =&gt; $chlabel
				    );
	    $tree-&gt;hide('entry', $lowest);
	}
	
	$tree-&gt;setmode($child, 'open');
	$tree-&gt;hide('entry', $child);
    } catch {
	processingErrorDialog($_);
    };
}

#***************************************************************************

sub addObjectByOwnerAndType($$$$$$$$) {
    my ($leaf, $path, $dbh, $tree, $label, $type, $owner, $sublabel) = @_;
    my $branch = $owner . '.' . $label;
    buildObjectTypeLeaf($leaf, $path, $dbh, $tree, $label, $type,
			$owner, $sublabel)
	unless $tree-&gt;infoExists($branch);
}

#***************************************************************************

sub addObjectsByOwner($$$$) {
    my ($leaf, $path, $dbh, $tree) = @_;
    my $owner = (split('\.', $leaf))[0];

    # add leaf for procedures.
    addObjectByOwnerAndType($leaf, $path, $dbh, $tree,
			    'Procedures', 'P', $owner, 'Code');

    # add leaf for tables.
    addObjectByOwnerAndType($leaf, $path, $dbh, $tree,
			    'Tables', 'U', $owner, 'Columns')
}

#***************************************************************************

sub objectBrowserCallback($$) {
    my ($tree, $leaf) = @_;
    my ($owner, $type, $name, $comm) = split('\.', $leaf);
    return unless defined $comm;
    if ($comm eq 'Code') {
	listProcedureCode($name, $owner);
    } elsif ($comm eq 'Columns') {
	listTableColumns($name, $owner);
    } else {
	return;
    }
}

#***************************************************************************

sub openBrowserBranch($$$) {
    my ($tree, $branch, $dbh) = @_;
    my ($owner, $type, $name, $action) = split('\.', $branch);

    # Waiting cursor.
    my @complist = ($tree);
    setWaitingCursor(@complist);

    # If this branch has no children, it must be the owner level and
    # it hasn't been opened yet, so add all the objects for thi owner.
    addObjectsByOwner($owner, $branch, $dbh, $tree)
	unless $tree-&gt;infoChildren($branch);

    # show this branch's children.
    for my $child ($tree-&gt;infoChildren( $branch )) {
	$tree-&gt;show( -entry =&gt; $child );
    }

    # restore cursor.
    resetWaitingCursor(@complist);
}

#***************************************************************************

use constant SYBASE_USER_LIST_SQL =&gt; "
select distinct a.name 
from sysusers a, 
     sysobjects b 
where a.uid = b.uid 
order by a.name";

sub showObjectBrowser() {
    my $desc = getCurrentConnectionDesc() || do {
	statusMessage("No connection currently active....");
	return;
    };

    # build a new window with the server name in the title.
    my $browserwin = 
	$gui-&gt;Toplevel(
		       -title =&gt; "Object browser - " . $desc-&gt;{server}
 		                               . "." . $desc-&gt;{dbase}
		      );

    # make a panel in which the browser tree will be displayed.
    my $browswerpanel = $browserwin-&gt;Frame();
    $browswerpanel-&gt;pack(
			 -side   =&gt; 'top',
			 -expand =&gt; 1,
			 -fill   =&gt; 'both'
			);

    # a button to close the window.
    my $close_button = $browserwin-&gt;Button(
					   -text =&gt; 'Close',
					   -activebackground =&gt;
					       $browserwin-&gt;cget('-background'),
					   -command =&gt; [ $browserwin,
							 'destroy' ]
					  );
    $close_button-&gt;pack( -side =&gt; 'top' );

    # add the tree object.
    my $browsertree = 
	$browswerpanel-&gt;Scrolled('Tree',
				 -scrollbars =&gt; 'se',
				 -width      =&gt; 40,
				 -height     =&gt; 25,
				)-&gt;pack( 
					 -fill   =&gt; 'both',
					 -expand =&gt; 1,
				       );
    $browsertree-&gt;configure(				 
			     -command    =&gt; sub { 
				 objectBrowserCallback($browsertree,
						       shift())
				 },
			     -opencmd    =&gt; sub { 
				 openBrowserBranch($browsertree,
						   shift(), $desc-&gt;{dbh}); 
			         }
			   );


    # Get a list of users.  Do a join with the sysobjects table in
    # order to filter out those users who don't have any objects.
    statusMessage("Building object browser for " . $desc-&gt;{server});
    my $sth = $desc-&gt;{dbh}-&gt;prepare_cached(SYBASE_USER_LIST_SQL);
    try {
	$sth-&gt;execute();
    } catch {
	statusMessage('Unable to get user list...');
	processingErrorDialog($DBI::errstr);
	$browserwin-&gt;destroy();
	$sth = undef;
    };
    return unless defined $sth;

    # add the users to the tree.
    my $owner;
    $sth-&gt;bind_col(1, \$owner);
    while ( $sth-&gt;fetchrow_arrayref ) {
	my $path = $owner;
	my $o = $browsertree-&gt;add($path,
				  -text =&gt; $owner,
				 );
	$browsertree-&gt;setmode($o, 'open');
    }
}

#***************************************************************************

sub showAboutScreen() {
    # Create a dialog.
    my $dbox = $gui-&gt;DialogBox(
			       -title =&gt; 'About ' . PROGRAM_NAME,
			       -buttons =&gt; [ 'Ok' ],
			      );

    # Windows has the annoying habit of setting the background color
    # for the Text widget differently from the rest of the window.  So
    # get the dialog box background color for later use.
    my $bg = $dbox-&gt;cget('-background');

    # Insert a text widget to display the information.
    my $text = $dbox-&gt;add('Text',
			  -height =&gt; 4,
			  -width  =&gt; 25,
			  -background =&gt; $bg
			 );

    # Define some fonts.
    my $textfont = $text-&gt;cget('-font')-&gt;Clone( -family =&gt; 'Helvetica' );
    my $italicfont = $textfont-&gt;Clone( -slant =&gt; 'italic' );
    $text-&gt;tag('configure', 'italic', 
	       -font =&gt; $italicfont,
	       -justify =&gt; 'center');
    $text-&gt;tag('configure', 'normal', 
	       -font =&gt; $textfont,
	       -justify =&gt; 'center');

    # Add the about text.
    $text-&gt;insert('end', PROGRAM_NAME . " 1.1\n", 'normal');
    $text-&gt;insert('end', "by Dr. Scott E. Aaron\n", 'normal');
    $text-&gt;insert('end', "Copyright © 2001\n", 'normal');
    $text-&gt;insert('end', "dr_saaron\@yahoo.com", 'italic');
    $text-&gt;configure( -state =&gt; 'disabled' );
    $text-&gt;pack(
		-expand =&gt; 1,
		-fill   =&gt; 'both'
	       );
    $dbox-&gt;Show();
}

#***************************************************************************

sub showUserGuide() {
    my $title = "\n" . PROGRAM_NAME . " user guide";
    my $txt = "

This tool is a simplistic GUI to a dataserver.  Connections may be made to multiple data servers, each one represented by a tab on the main window.

&lt;BOLD&gt;Window&lt;/BOLD&gt;
The main window is divided into two panels:  on the left is the SQL editor where one edits SQL commands, and on the right is the results display where the results of a query are formatted.

&lt;BOLD&gt;Connections&lt;/BOLD&gt;
The GUI uses parameters specified in your environment to define a default connection.  This default connection is established when the GUI starts.  Whenever a new connection is requested, the parameters default to these values.  The key sequence control-n will establish a new connection, using the parameters of the currently active connection, if any.  This is also obtained via the File-&gt;New menu item.  There is no limit on the number of simultaneously active connections there may be.

&lt;BOLD&gt;Profiles&lt;/BOLD&gt;
The connection parameter dialog includes a list of previously saved profiles.  A profile is just the parameters for connection that you may make often.  When you have entered the parameters for a common connection, click the 'Save' button to save this information as a profile.  This button will also open the connection.  On subsequent attempts to open a connection with these parameters, open the profiles list and click on the server/user name combination appropriate for your connection.  This will fill in the parameters for you.  Then click 'Ok' to open the connection.

&lt;BOLD&gt;Object browser&lt;/BOLD&gt;
The Datasource-&gt;Objects menu item will bring up an object browser for the data server currently being accessed.  The browser displays a list of users who have objects (tables or stored procedures) on the server. One may see the code for a stored procedure or a column list for a table via this browser.

&lt;BOLD&gt;Blazars&lt;/BOLD&gt;
If you don't know what a blazar is, read my Ph.D dissertation.  I did a lot of work on Mrk 501, which is an example.
";

    # build the window
    my $hwin = $gui-&gt;Toplevel(
			      -title =&gt; 'Help for ' . PROGRAM_NAME
			     );
    my $textarea = $hwin-&gt;Scrolled('Text',
				   -scrollbars =&gt; 'e',
				   -width  =&gt; 80,
				   -height =&gt; 40,
				   -wrap   =&gt; 'word'
				  );
    $textarea-&gt;pack(
		    -side =&gt; 'top',
		    -expand =&gt; 1,
		    -fill   =&gt; 'both'
		   );
    my $ok = $hwin-&gt;Button(
			   -text =&gt; 'Ok',
			   -command =&gt; [ $hwin =&gt; 'destroy' ],
			   -activebackground =&gt;
  			      $hwin-&gt;cget('-background'),
			   )-&gt;pack( -side =&gt; 'top' );

    # define some fonts.
    my $basefont = $textarea-&gt;cget('-font')-&gt;Clone( -family =&gt; 'Helvetica' );
    my $boldfont = $basefont-&gt;Clone( -weight =&gt; 'bold', -family =&gt; 'Arial' );

    # define a tag for bold font.
    $textarea-&gt;tag('configure', 'boldtxt',
		   -font =&gt; $boldfont);
    $textarea-&gt;tag('configure', 'normaltxt',
		   -font =&gt; $basefont);
    $textarea-&gt;tag('configure', 'centertxt',
		   -font =&gt; $boldfont-&gt;Clone( -size =&gt; 12 ),
		   -justify =&gt; 'center');

    # add the help text.
    $textarea-&gt;insert('end', $title, 'centertxt');
    my $tag = 'normaltxt';
    for my $section (split(/(&lt;[^&gt;]+&gt;)/, $txt)) {
	if ($section eq '&lt;BOLD&gt;') {
	    $tag = 'boldtxt';
	} elsif ($section eq '&lt;/BOLD&gt;') {
	    $tag = 'normaltxt';
	} else {
	    $textarea-&gt;insert('end', $section, $tag);
	}
    }

    # not editable.
    $textarea-&gt;configure( -state =&gt; 'disabled' );
}

#***************************************************************************

sub try (&amp;@) {
  local $@;
  my($try,$catch) = @_;
  eval { &amp;$try };
  if ($@) {
    local $_ = $@;
    &amp;$catch;
  }
}

#***************************************************************************

sub catch (&amp;) { $_[0] }

#***************************************************************************

sub throw($) {
  my ($s) = @_;
  die $s . "\n";
}
</pre></body></html>