#! /opt/perl/bin/perl -w

use constant rcs_id =>
    '$Id: sqlgui.pl,v 1.77 2001/11/21 15:11:25 aar1069 Exp $ ';

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

=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<N.B.> 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<Tk> (including the Tix extensions), HTML::TreeBuilder, 
and C<DBI> 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.  The query results may be saved to an HTML file via the 
Query->Save results menu option.

=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; use HTML::TreeBuilder; use UNIVERSAL;

#***************************************************************************
# Tk widget to provide password entry.
#***************************************************************************

=head1 NAME

Tk::PasswordEntry - a C<Tk::Entry> widget for passwords

=head1 DESCRIPTION

This is a widget to allow secure entering of passwords.
Whenever a character is entered, an asterisk is displayed rather than
the character. 

=head1 METHODS

=over 3

=cut

#***************************************************************************
package Tk::PasswordEntry;

# OO.
require Tk::Entry; require Tk::Derived;
use base qw(Tk::Derived Tk::Entry);
Tk::Widget->Construct('PasswordEntry');

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

sub Populate {
    my ($w, $args) = @_;
    $w->SUPER::Populate($w, $args);
    $w->{pword} = '';
}

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

=item B<clear>

Clear the GUI and the password.  The C<delete> method is currently
not supported.

=cut

sub clear {
    my $w = shift();
    $w->delete('0.0', 'end');
    $w->{pword} = '';
}

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

=item B<Insert>

Insert a character or string into the entry.  Users should use this
method rather than the C<insert> method to specify an I<a priori> password.

=cut

sub Insert {
    my ($w, $s) = @_;
    return unless (defined $s && $s ne '');

    # Has the user highlighted some text?
    my $insert = $w->index('insert');
    if ($w->selectionPresent()) {
	my $start = $w->index('sel.first');
	my $end   = $w->index('sel.last');
	my $diff  = $end - $start;
	$w->{pword} =~ s/^(.{$start}).{$diff}(.*)$/$1$2/;
	$insert = $start;
    }

    # call the parent class version to handle the GUI.
    $w->SUPER::Insert('*' x length($s));

    # insert the text at the insert mark.
    $w->{pword} =~ s/^(.{$insert})/$1$s/;
}

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

=item B<get>

Returns the current password.

=cut

sub get {
    return shift()->{pword}
}

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

# Override the Backspace method to delete characters from the password
sub Backspace {
    my $w = shift();

    # do we have selection?
    my $start = $w->index('insert') - 1;
    my $length = 1;
    if ($w->selectionPresent()) {
	$start = $w->index('sel.first');
	$length = $w->index('sel.last') - $start;
    }

    # parent class for GUI stuff.
    $w->SUPER::Backspace();

    # now get rid of stuff.
    $w->{pword} =~ s/^(.{$start}).{$length}(.*)$/$1$2/;
}

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

# Handle the delete key.
sub Delete {
    my $w = shift();

    # is there selection?
    my $start = $w->index('insert');
    my $length = 1;
    if ($w->selectionPresent()) {
	$start = $w->index('sel.first');
	$length = $w->index('sel.last') - $start;
    }

    # parent class for GUI.
    $w->SUPER::Delete();

    # goodbye.
    $w->{pword} =~ s/^(.{$start}).{$length}(.*)$/$1$2/;
}

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

package main;

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

# Exception handling syntax.
sub try (&@);
sub catch(&);
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 default USR1 signal handler that will just ignore the signal.  This is
# needed because while we're executing a query, a special USR1 handler is
# put up to cancel the request.  Outside of that block, the signal will
# kill the program, which we do not want.
$SIG{USR1} = sub { print "tolerating SIGUSER1\n"; } unless ($^O eq 'MSWin32');

# A hash to store the bitmaps.
my %bitmaps = (
	       BlazarSQL => '/* 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 => '/* 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 => '/* 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 => '/* 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 => '/* 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 => '/* 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 => $ENV{DSQUERY};
use constant DEFAULT_USER   => $ENV{BLAZARUSER} 
  || die "Please set BLAZARUSER!\n";;
use constant DEFAULT_PASSWD => $ENV{BLAZARPASSWD}
  || die "Please set BLAZARPASSWD\n";
use constant DEFAULT_DBASE  => $ENV{BLAZARDEFAULTDB}
  || die "Please set BLAZARDEFAULTDB!\n";
use constant DEFAULT_DBASE_TYPE => $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->raised();
    return undef if !defined($panel);
    return $connections{$panel};
}

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

use constant RESULTS_WIDTH => 80;
use constant RESULTS_HEIGHT => 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 => $columns,
		  -header  => 1,
		  -selectmode => 'multiple' );
    } else { # just build a scrolled text area.
	$wtype = 'Text';
	@args = ( -wrap => 'none' );
    }

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

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

    # return it.
    return $disp;
}

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

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

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

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

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

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

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

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

sub statusMessage($) {
    my $txt = shift();
    $statuslabel->configure(
			    -text   => $txt,
			    -anchor => '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->title(PROGRAM_NAME);

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

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

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

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

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

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

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

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

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

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

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

    # Now build the panel in which the editor and results displays will
    # be shown.
    my $mainpanel = $win->NoteBook()->pack( 
					    -side   => 'top',
					    -expand => 1,
					    -fill   => 'both',
					    -padx   => 3,
					    -pady   => 3,
					  );
    
    # build a status panel and label widget.  Use the menu font to look
    # nicer.
    my $label = $win->Label( 
			     -relief => 'sunken',
                             -font   => $menufont
			   );
    $label->pack( 
		  -side => 'bottom', 
		  -expand => 0,
		  -fill   => 'x',
                  -anchor => '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->{server}, $desc->{user},
			      $desc->{pass}, $desc->{dbase}, 
			      $desc->{type});
    $mainpanel->raise($connindex - 1);
}

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

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

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

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

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

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

sub labelTextPair($$$$) {
    my ($p, $label, $def, $type) = @_;
    my $l = $p->Label(
		      -text  => $label,
		      -width => 10,
		      -anchor => 'w'
		     )->pack( -side => 'left' );
    my $t = $p->$type(
		      -width => 20
		     )->pack( -side => 'left' );
    if ($type eq 'PasswordEntry') {
	$t->Insert($def);
    } else {
	$t->insert('end', $def);
    }
    return $t;
}

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

use constant HOME => ($^O eq 'MSWin32') ? 'c:' : $ENV{HOME};
use constant PROFILE_DIR => HOME . "/.blazar";
use constant PROFILE_FILE => 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->{$key} = "$user/$pass/$server/$dbase/$type";
}

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

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

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

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

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

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

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

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

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

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

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

sub connectDataSource() {
    # get the necessary information via a dialog box
    my $dbox = $gui->DialogBox(
			       -title => 'Open connection',
			       -buttons => [ 'Ok', 'Save', 'Cancel' ],
			       -default_button => '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->add('LabFrame',
				      -label     => 'Profiles',
				      -labelside => 'acrosstop'
				     );
    $profilemenupanel->pack( 
			     -side => 'top',
			     -padx => 2,
			     -pady => 2
			   );
    my $profilemenu = $profilemenupanel->Optionmenu();
    $profilemenu->pack( 
			-side => 'top',
			-padx => 2,
			-pady => 2
		      );

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

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

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

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

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

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

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

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

sub initializeLastQueryResultsDescriptor($) {
    my $desc = shift();
    $desc->{last_query} = 
	{
	    columns => undef,
	    data    => undef,
	    query   => undef,
	};
}

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

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->connect($constr, $user, $pass,
			       { RaiseError => 1, PrintError => 0 });
	statusMessage("Successfully connected!");

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

	# Store a place for the last run query results.
	initializeLastQueryResultsDescriptor($desc);

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

	# insert the descriptor into the global container.
	$connections{$connindex++} = $desc;

	# Have the editor take the focus.
	$ed->focus();
    } catch {
	statusMessage("Unable to connect to to $dserver");
	processingErrorDialog($DBI::errstr);
	$rc = undef;
    };			
    return $rc;
}

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

sub processingErrorDialog($) {
    my $msg = shift();
    my $dbox = $gui->Dialog(
			    -title => 'Processing error',
			    -bitmap => 'error',
			    -buttons => [ 'Ok' ],
			    -text    => $msg
			   );
    $dbox->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->{editor};
    my $sql = undef;
    if ($checkselect) {
      Tk::catch {
	  $sql = $editor->get('sel.first', 'sel.last');
      };
    }
    
    # if $sql is still undefined, then get everything.
    $sql = $editor->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->cget('cursor'));
	$widget->configure( -cursor => 'watch' );
	$widget->update();
    }
}

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

sub processSQL(;$@) {
    my ($sql, @args) = @_;
    my $desc = getCurrentConnectionDesc() || do {
	statusMessage("No active connection....");
	return;
    };
    my $editor = $desc->{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->{editor}, $desc->{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->{dbh}->prepare($sql);

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

	    # Take down the signal handler.
	}

	# Clear the last run results.
	initializeLastQueryResultsDescriptor($desc);
	my $last_query = $desc->{last_query};
	$last_query->{data} = [];
	$last_query->{query} = $sql;
	$last_query->{query} .= "\n\nArgs:  " . join(', ', @args) if @args;
	my $lqresults = $last_query->{data};

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

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

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

	# now add the data.
	my $row;
	my $rowcount = 0;
	while ( defined($row = $sth->fetchrow_arrayref) ) {
	    my @cprow = @$row;
	    push(@$lqresults, \@cprow);

	    $rowcount++;
	    my $val = $results->addchild('');
	    for ($i = 0; $i < $ncolumns; $i++) {
		my $colval = $row->[$i];
		$colval = 'NULL' if !defined($colval);
		$results->itemCreate($val, $i,
				     -itemtype => 'text',
				     -text       => $colval);
	    }

	    # update the GUI every 128 rows (easy, efficient calculation)
	    # and check for cancellation.
	    if (($rowcount & 0x7F) == 0) {
		statusMessage("Formatting results, $rowcount rows processed...");
		$gui->update();
		if ($cancel_query == 1) { # cancel the query
		    $sth->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 => [
			   [ "SQL files", ".sql" ],
			   [ "All files", "*" ]
			  ];

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

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

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

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

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

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

use constant SYBASE_OBJECT_NAMES_SQL => "
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->prepare_cached(SYBASE_OBJECT_NAMES_SQL);
    $sth->execute($owner, $type);
    return $sth;
}

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

use constant SYBASE_PROCEDURE_CODE_SQL => "
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->{dbh}->prepare_cached(SYBASE_PROCEDURE_CODE_SQL);
    try {
	$sth->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->bind_col(1, \$text);
    while ($sth->fetchrow_arrayref) {
	$code .= $text;
    }
    $desc->{results}->destroy();
    $desc->{results} = buildResultsDisplay($desc->{respanel},
					   $desc->{editor}->cget('font'));
    $desc->{results}->insert('end', $code);
    $desc->{results}->configure(-state => 'disabled');
}
                   
#***************************************************************************

use constant SYBASE_LIST_TABLE_COLUMNS_SQL => "
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->add($id,
			   -text => $name
			  );
    try {
	my $sth = getObjectNamesByType($dbh, $owner, $type);
	my $oname;
	$sth->bind_col(1, \$oname);
	while ($sth->fetchrow_arrayref) {
	    my $iid = "$id.$oname";
	    my $low = $tree->add($iid,
				 -text => $oname
				 );
	    $tree->setmode($low, 'open');
	    $tree->hide('entry', $low);
	    $iid .= ".$chlabel";
	    my $lowest = $tree->add($iid,
				    -text => $chlabel
				    );
	    $tree->hide('entry', $lowest);
	}
	
	$tree->setmode($child, 'open');
	$tree->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->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->infoChildren($branch);

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

    # restore cursor.
    resetWaitingCursor(@complist);
}

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

use constant SYBASE_USER_LIST_SQL => "
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->Toplevel(
		       -title => "Object browser - " . $desc->{server}
 		                               . "." . $desc->{dbase}
		      );

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

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

    # add the tree object.
    my $browsertree = 
	$browswerpanel->Scrolled('Tree',
				 -scrollbars => 'se',
				 -width      => 40,
				 -height     => 25,
				)->pack( 
					 -fill   => 'both',
					 -expand => 1,
				       );
    $browsertree->configure(				 
			     -command    => sub { 
				 objectBrowserCallback($browsertree,
						       shift())
				 },
			     -opencmd    => sub { 
				 openBrowserBranch($browsertree,
						   shift(), $desc->{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->{server});
    my $sth = $desc->{dbh}->prepare_cached(SYBASE_USER_LIST_SQL);
    try {
	$sth->execute();
    } catch {
	statusMessage('Unable to get user list...');
	processingErrorDialog($DBI::errstr);
	$browserwin->destroy();
	$sth = undef;
    };
    return unless defined $sth;

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

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

# This code uses the HTML::TreeBuilder module to process simple HTML.
# The code is far from perfect, but it is sufficient for the uses here.
use constant HTML_INSERT_TAG => 'htmlInsertTag';
my $icount=0;
sub processHTMLTreeNode($$$) {
    my ($node, $text, $win) = @_;
    return unless $node;
    my $addParagraph = 0;

    # Get the current insert descriptor.
    my $idesc = {
	'-font'    => $text->tagCget(HTML_INSERT_TAG, '-font'),
	'-justify' => $text->tagCget(HTML_INSERT_TAG, '-justify'),
    };

    # Process the current node.
    if (UNIVERSAL::isa($node, 'HTML::Element')) {
	my $tag = $node->tag();

	# process the tag.
	if ($tag eq 'b') {
	    $text->tagConfigure(HTML_INSERT_TAG,
				-font => $idesc->{-font}
				               ->Clone(
						       -weight => 'bold'
						      )
			       );
	} elsif ($tag eq 'p') {
	    $addParagraph = 1;
	} elsif ($tag eq 'center') {
	    $text->tagConfigure(HTML_INSERT_TAG,
				-justify => 'center');
	} elsif ($tag eq 'i') {
	    $text->tagConfigure(HTML_INSERT_TAG,
				-font => $idesc->{-font}
				               ->Clone(
						       -slant => 'italic'
						      )
			       );
	} elsif ($tag eq 'br') {
	    $text->insert('insert', "\n");
	} elsif ($tag eq 'font') {
	    my $size = $node->attr('size');
	    my $face = $node->attr('face');
	    my $cfont = $idesc->{-font}->Clone();
	    my $csize = $cfont->Size();
	    my %args = ();
	    $args{-size} = $size + $csize if defined $size;
	    $args{-family} = $face if $face;
	    $text->tagConfigure(HTML_INSERT_TAG,
				-font => $cfont->Clone(%args)
			       );
	} elsif ($tag =~ m/^(head|body|html)$/) {
	    # just tolerate
	} elsif ($tag eq 'title') {
	    $win->title($node->content()->[0]);
	    return;
	} else {
	    warn "unknown tag $tag\n";
	}
    } else { # just plain text.
	$node =~ s/^\s*//s;
	if (length($node) > 0) {
	    my $t = 'htmlTextInsert' . $icount++;
	    $text->tagConfigure($t, %$idesc);
	    $text->insert('end', $node, $t)
	}
	return;
    }

    # Now process the children.
    my $content = $node->content();
    if ($content && UNIVERSAL::isa($content, 'ARRAY')) {
	for my $child (@$content) {
	    processHTMLTreeNode($child, $text, $win);
	}
    }

    # Handle the paragraph.
    $text->insert('end', "\n\n") if $addParagraph;

    # Reset the insert tag to its original statee.
    $text->tagConfigure(HTML_INSERT_TAG, %$idesc);
}

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

sub showHTML($$$) {
    my ($html, $text, $win) = @_;
    my $tree = new HTML::TreeBuilder;
    $tree->parse($html);
    
    # initialize the insert tag.
    $text->tagConfigure(HTML_INSERT_TAG,
			-font    => $text->cget('-font'),
			-justify => 'left'
		       );

    # Now process the HTML tree.
    processHTMLTreeNode($tree, $text, $win);
}

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

use constant COPYRIGHT_RANGE => '2000 - ' . (split("/", (split(" ", rcs_id))[3]))[0];
sub showAboutScreen() {
    # Create a dialog.
    my $dbox = $gui->DialogBox(
			       -title => 'About ' . PROGRAM_NAME,
			       -buttons => [ '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->cget('-background');

    # Insert a flat relief text widget.
    my $text = $dbox->add('Text',
			  -height => 3,
			  -width  => 25,
			  -background => $bg
			 );

    # Define the HTML for the about text.
    my $pname = PROGRAM_NAME;    
    my $version = "1.2";
    my $crange = COPYRIGHT_RANGE;
    my $aboutHTML = "
<html>
<body>
<center><font face=Helvetica>
$pname, v. $version<br>
by Dr. Scott E. Aaron<br>
<i>Copyright © $crange</i>
</font>
</center>
</body>
</html>";

    # Display this HTML.
    showHTML($aboutHTML, $text, $dbox);

    # Make the display disabled.
    $text->configure( -state => 'disabled' );
    $text->pack(
		-expand => 1,
		-fill   => 'both'
	       );
    $dbox->Show();
}

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

sub showUserGuide() {
    my $guideHTML = "
<html>
<title>BlazarSQL User Manual</title>

<body>
<center><b><font size=+2><i>BlazarSQL user guide</i></font></b></center>

<p>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.

<p><b>Window</b>
<br>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.

<p><b>Connections</b>
<br>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->New menu item.  There is no 
limit on the number of simultaneously active connections there may be.

<p><b>Profiles</b>
<br>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.

<p><b>Object browser</b>
<br>The Datasource->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.

<p><b>Blazars</b>
<br>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.

</body>
</html>";

    # build the window
    my $hwin = $gui->Toplevel();
    my $textarea = $hwin->Scrolled('Text',
				   -scrollbars => 'e',
				   -width  => 80,
				   -height => 40,
				   -wrap   => 'word'
				  );
    my $font = $textarea->cget('-font')->Clone( -family => 'Helvetica' );
    $textarea->configure(-font => $font);
    $textarea->pack(
		    -side => 'top',
		    -expand => 1,
		    -fill   => 'both'
		   );
    my $ok = $hwin->Button(
			   -text => 'Ok',
			   -command => [ $hwin => 'destroy' ],
			   -font    => $font,
			   -activebackground =>
  			      $hwin->cget('-background'),
			   )->pack( -side => 'top' );

    # Show the guide HTML.
    showHTML($guideHTML, $textarea, $hwin);

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

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

sub saveResults() {
    my $desc = getCurrentConnectionDesc();
    if (!defined($desc)) {
	statusMessage("No connection currently in use!");
	return 0;
    }

    # get the results of the last query.
    my $last_query = $desc->{last_query};

    # If there are no columns, then goodbye.
    if ($last_query->{columns} && @{$last_query->{columns}})
    {}
    else {
	statusMessage("No query results to save!");
	return 0;
    }

    # Get the file to save the results to.
    my $filetypes = FILETYPES;
    my @filetypes = @$filetypes;
    unshift(@filetypes, [ "HTML files", ".html" ]);
    my $file = $gui->getSaveFile(
				 -filetypes        => \@filetypes,
				 -defaultextension => '.html',
				 -initialfile      => 'query'
				);

    # Open the file.
    if ($file) {
	my $fh = new FileHandle("> $file") || do {
	    processingErrorDialog("Unable to open $file -> $!");
	    return 0;
	};

	# initialize the HTML.
	$fh->print("<html><title>Query results, from " . PROGRAM_NAME . "</title>\n");
	$fh->print("<!-- Created by " . PROGRAM_NAME . 
		   ", &copy; " . COPYRIGHT_RANGE . 
		   " by Dr. Scott E. Aaron, at " . 
		   scalar localtime() . "-->\n");

	# Save the query as a comment.
	$fh->print("<!-- Query: (user = " . $desc->{user} . 
		   ", server = " . $desc->{server} . 
		   ")\n\n" . $last_query->{query} . "\n-->\n\n");

	# Create a table.
	$fh->print("<body><table border=1>\n<tr bgColor=#ccccff>");

	# dump the column headers
	for my $header (@{$last_query->{columns}}) {
	    $header ||= "";
	    $fh->print("<td><b>$header</b>");
	}
	$fh->print("</tr>\n");

	# Now dump the data.
	for my $row (@{$last_query->{data}}) {
	    $fh->print("<tr bgColor=lemonchiffon>");
	    for my $val (@$row) {
		$val = 'NULL' unless defined $val;
		$fh->print("<td>$val");
	    }
	    $fh->print("</tr>\n");
	}

	# close the table.
	$fh->print("</table></body></html>");

	# close the file.
	$fh->close();
    }
}

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

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

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

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

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

sub throw($) {
  my ($s) = @_;
  die $s . "\n";
}