#!/usr/local/bin/perl
################################################################################
# Copyright (c) 1998,1999 Andy Duncan
#
# You may distribute under the terms of either the GNU General Public License
# or the Artistic License,as specified in the Perl README file,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.
#
# This code is provided with no warranty of any kind,and is used entirely at
# your own risk. This code was written by the author as a private individual,
# and is in no way endorsed or warrantied.
#
# Support questions and suggestions can be directed to andy_j_duncan@yahoo.com
# Download from CPAN/authors/id/A/AN/ANDYDUNC
################################################################################

# Pick up all the standard modules necessary to run the program

use Tk;
use strict;
use Carp;
use FileHandle;
use Cwd;
use Time::Local;
use DBI;
use Tk::DialogBox;
use Tk::Pretty;
use Tk::HList;
require Tk::BrowseEntry;

# Pick up our specialised modules, plus some special
# flags for various database use.

use orac_Base;
use orac_QuickSQL;
use orac_Shell;

use orac_Oracle;
use orac_Informix;

# Read the menu/English.txt file to pick up all text
# for use with the rest of the program

main::read_language();

# Set up a few defaults, such as the lovely Steelblue2
# for the background colour

main::pick_up_defaults();

$main::hc = $main::lg{bar_col};
$main::ssq = $main::lg{see_sql};
$main::ec = $main::lg{def_fill_fld_col};
$main::fc = $main::lg{def_fg_col};

# Debugging flag for developers?
# for kevinb :)
# and now for thomasl too :)

$main::debug = exists($ENV{ORAC_DEBUG}) ? int($ENV{ORAC_DEBUG}) : 0;
$main::do_shell = exists( $ENV{DBI_SHELL} ) ? 1:0;

# Bring up the main "Worksheet" window

$main::mw = MainWindow->new();

# Start work on the menu, with the Orac badge,
# and then build up the menu buttons

my(@layout_mb) = qw/-side top -padx 5 -expand no -fill both/;
$main::mb = $main::mw->Frame->pack(@layout_mb);

my $orac_li = $main::mw->Pixmap(-file=>'img/orac.bmp');

$main::conn_ball{green} = $main::mw->Photo( -file => "img/grn_ball.gif" );
$main::conn_ball{red} = $main::mw->Photo( -file => "img/red_ball.gif" );

$main::mb->Label(-image=>$orac_li,
                 -borderwidth=>2,
                 -relief=>'flat'
                )->pack(-side=>'left',
                        -anchor=>'w');

# First of all, provide the only hard-coded menu that we
# do, for functions across all databases

my $file_mb = $main::mb->Menubutton(-text=>$main::lg{file},
                          )->pack(-side=>'left',
                                  -padx=>2);

$file_mb->command(-label=>$main::lg{reconn},
                  -command=>sub{main::get_db()});

$file_mb->command(-label=>$main::lg{about_orac},
                  -command=>
                      sub{ main::bz();
                           $main::current_db->f_clr($main::v_clr);
                           $main::current_db->about_orac('README');
                           main::ubz()
                         }
                 );

$file_mb->command(-label=>$main::lg{menu_config},
                  -command=>
                     sub{  main::bz();
                           $main::current_db->f_clr($main::v_clr);
                           $main::current_db->about_orac('txt/menu_config.txt');
                           main::ubz()
                        }
                 );
$file_mb->separator();

# Build up the colour options, so
# a nice lemonchiffon is possible as a backdrop

$main::bc_txt = $main::lg{back_col_menu};
$file_mb->cascade(-label=>$main::bc_txt);
$main::bc_men = $file_mb->cget(-menu);
$main::bc_cols = $main::bc_men->Menu;

# Now pick up all the lovely colours and build a radiobutton

$file_mb->entryconfigure($main::bc_txt,-menu=>$main::bc_cols);
open(COLOUR_FILE, "txt/colours.txt");
while(<COLOUR_FILE>){
   chomp;
   eval {
      $main::bc_cols->radiobutton(
         -label=>$_,-background=>$_,
         -command=>[ sub {main::bc_upd()}],
         -variable=>\$main::bc,
         -value=>$_);
   };
}
close(COLOUR_FILE);

# Now give them the 'Exit Orac' option

$file_mb->separator();
$file_mb->command(-label=>$main::lg{exit},-command=>sub{main::back_orac()});

# Let them know the state of play, on connections

$main::l_top_t = $main::lg{not_conn};
$main::mb->Label(-textvariable => \$main::l_top_t,
                 -padx=>2,
                 -pady=>2,
                )->pack(-side=>'right',
                        -anchor=>'e');
my $main_label = $main::mb->Label( -image => $main::conn_ball{red},
                                   -padx=>2,
                                   -pady=>2,
                                 )->pack(-side=>'right',
                                         -anchor=>'e');

(@layout_mb) = qw/-side top -expand yes -fill both/;
my $middle_box = $main::mw->Frame->pack(@layout_mb);

$main::v_text = $middle_box->Scrolled(  'Text',
                                        -wrap=>'none',
                                        -cursor=>undef,
                                        -foreground=>$main::fc,
                                        -background=>$main::bc
                                     );

$main::v_text->pack(-expand=>1,-fil=>'both');
tie (*TEXT,'Tk::Text',$main::v_text);

# Sort out the options to clear the screen on
# each report

my $bb = $main::mw->Frame->pack(-side=>'bottom',
                                -padx=>5,
                                -expand=>'no',
                                -fill=>'both',
                                -anchor=>'s',
                                -before=>$middle_box);

$bb->Button(-text=>$main::lg{clear},
            -command=>sub{main::bz();
                          $main::current_db->must_f_clr();
                          main::ubz()}
           )->pack(side=>'left');

$main::v_clr = 'Y';
$bb->Radiobutton(-variable=>\$main::v_clr,
                 -text=>$main::lg{man_clear},
                 -value=>'N'
                )->pack (side=>'left');

$bb->Radiobutton(-variable=>\$main::v_clr,
                 -text=>$main::lg{auto_clear},
                 -value=>'Y'
                )->pack (side=>'left');

$bb->Button(-text=>$main::lg{reconn},
            -command=>sub{main::bz();
                          main::get_db();
                          main::ubz()}
           )->pack(side=>'right');

# Set main window title and set window icon

$main::mw->title( $main::lg{orac_pan} );
main::iconize($main::mw);

# Sort out which database we're going to be working with
# Once this is done, connect to a database.

$main::orac_orig_db = 'XXXXXXXXXX'; # I just love kludging :)

# If no default database type selected,
# pick it up.

if ((!defined($main::orac_curr_db_typ)) || 
    (length($main::orac_curr_db_typ) == 0)){

   $main::orac_curr_db_typ = main::select_dbtyp(1);
}

main::get_db();

$main::sub_win_but_hand{dbish}->[0]->invoke('GUI Dbish') if $main::do_shell;

# Here we go, lights, cameras, action!

MainLoop();

# Clear out everything before exiting, and then draw
# those curtains

main::back_orac();

#################### Sub functions begin ####################

sub back_orac {

   # Back out of program nicely, and save any chosen
   # options in the main configuration file

   if (defined($main::current_db)){
      my $rc  = $main::dbh->disconnect;
   }
   main::fill_defaults(  $main::orac_curr_db_typ, 
                         $main::sys_user, 
                         $main::bc, 
                         $main::v_db
                      );
   exit 0;
}
sub fill_defaults {

   # Make sure defaults the way the user likes 'em.

   my($db_typ, $dba, $loc_bc, $db) = @_;

   open(DB_FIL,'>config/what_db.txt');

   print DB_FIL $db_typ . 
                '^' . 
                $dba . 
                '^' . 
                $loc_bc . 
                '^' . 
                $db . 
                '^' . 
                "\n";

   close(DB_FIL);
}
sub get_connected {

   # Put up dialogue to pick a new database.
   # Allow user to change database type,
   # if they wish.  Also, set flag
   # to help prevent connection
   # error messages, except on the
   # last attempt at connection.

   my $ps_u;
   my $ps_e;
   my $auto_log = 1;

   my $dn = 0;
   $main::conn_comm_flag = 0;

   if (defined($main::current_db)){

      $main::current_db->must_f_clr();
      $main_label->configure( -image => $main::conn_ball{red} );
      $main::l_top_t = $main::lg{disconn};
      my $rc = $main::dbh->disconnect;
      undef $main::current_db;
      $auto_log = 0;
   }

   do {
      # Create the new object

      if($main::orac_curr_db_typ eq 'Oracle'){

         print STDERR "New Oracle object\n" if ($main::debug > 0);
         $main::current_db = orac_Oracle->new( $main::mw, $main::v_text );

      }
      elsif($main::orac_curr_db_typ eq 'Informix'){

         $main::current_db = orac_Informix->new( $main::mw, $main::v_text );

      }
      else {

         $main::current_db = 
            orac_Base->new( 'Base', $main::mw, $main::v_text );

      }

      print STDERR "After New object\n" if ($main::debug > 0);

      my $c_d = 
       $main::mw->DialogBox(-title=>$main::lg{login_txt},
                            -buttons=>[ $main::lg{connect}, 
                                        $main::lg{change_dbtyp}, 
                                        $main::lg{exit} ]
                           );

      my $l1 = $c_d->Label(-text=>$main::lg{db} . ':',
                           -anchor=>'e',
                           -justify=>'right');

      my $db_list = 
                 $c_d->BrowseEntry(-cursor=>undef,
                                   -variable=>\$main::v_db,
                                   -foreground=>$main::fc,
                                   -background=>$main::ec);
      my %ls_db;

      # Pick up all the databases currently available to this user
      # directly from here

      my @h = DBI->data_sources('dbi:' . $main::orac_curr_db_typ . ':');
      my $h = @h;
      my @ic;
      my $ic;
      my $i;
      for ($i = 1;$i < $h;$i++){
         @ic = split(/:/,$h[$i]);
         $ic = @ic;
         $ls_db{$ic[($ic - 1)]} = 101;
      }
      
      # Supplement these, with stored database to which they've
      # successfully connected in the past 

      open(DBFILE,"txt/" . $main::orac_curr_db_typ . "/orac_db_list.txt");
      while(<DBFILE>){
         chomp;
         $ls_db{$_} = 102;
      }
      close(DBFILE);

      my $key;
      my @hd;
      undef @hd;
      $i = 0;
      foreach $key (keys %ls_db) {
         $hd[$i] = "$key";
         $i++;
      }
      my @hd2;
      @hd2 = sort @hd;

      foreach(@hd2){
         $db_list->insert('end',$_);
      }

      # Now put up the rest of the widgets with this Dialogue

      my $l2 = $c_d->Label(-text=>$main::lg{sys_user} . ':',
                           -anchor=>'e',
                           -justify=>'right');

      $ps_u = $c_d->add("Entry",
                        -cursor=>undef,
                        -textvariable=>\$main::sys_user,
                        -foreground=>$main::fc,
                        -background=>$main::ec
                       )->pack(side=>'right');

      my $l3 = $c_d->Label(-text=>$main::lg{sys_pass} . ':',
                           -anchor=>'e',
                           -justify=>'right');

      $ps_e = $c_d->add("Entry",
                        -cursor=>undef,
                        -show=>'*',
                        -foreground=>$main::fc,
                        -background=>$main::ec
                       )->pack(side=>'right');

      my $l4 = $c_d->Label(-text=>$main::lg{db_type} . ':',
                           -anchor=>'e',
                           -justify=>'right');

      my $l4a = $c_d->Label(-text=>$main::orac_curr_db_typ,
                            -anchor=>'w',
                            -justify=>'left');


      # Go Grid crazy!  Assign the widgets to starting 
      # racetrack postitions

      Tk::grid($l1,-row=>0,-column=>0,-sticky=>'e');
      Tk::grid($db_list,-row=>0,-column=>1,-sticky=>'ew');
      Tk::grid($l2,-row=>1,-column=>0,-sticky=>'e');
      Tk::grid($ps_u,-row=>1,-column=>1,-sticky=>'ew');
      Tk::grid($l3,-row=>2,-column=>0,-sticky=>'e');   # Schumacher!!!
      Tk::grid($ps_e,-row=>2,-column=>1,-sticky=>'ew');
      Tk::grid($l4,-row=>3,-column=>0,-sticky=>'e');
      Tk::grid($l4a,-row=>3,-column=>1,-sticky=>'ew');

      # Now put up the dialogue on the main screen
      # Determine if auto log on will work. If the env
      # variables are not set, no auto log.

      $auto_log = ( defined($ENV{DBI_DSN}) &&
                    defined($ENV{DBI_USER}) &&
                    defined($ENV{DBI_PASS}) ) && $auto_log;
  
      my $mn_b;

      if(!$auto_log) {

         $c_d->gridRowconfigure(1,-weight=>1);
         $db_list->focusForce;
         $mn_b = $c_d->Show;

      } else {
         $mn_b = $main::lg{connect};

         $ps_u->delete( 0, 'end' );
         $ps_e->delete( 0, 'end' );

         $ps_u->insert( 'end', $ENV{DBI_USER} );
         $ps_e->insert( 'end', $ENV{DBI_PASS} );

         $main::v_db = (split(/:/,$ENV{DBI_DSN}))[2];
      }
  
      # Now verify all input and attempt connection to chosen database
  
      if ($mn_b eq $main::lg{connect}) {

         $main::v_sys = $ps_u->get;

         if ( ( $main::current_db->need_sys ) || 
              (  defined($main::v_sys) && length($main::v_sys) )
            )
         {
            my $v_ps = $ps_e->get;
            if ( $main::current_db->need_ps || 
                 ( defined($v_ps) && length($v_ps)
                 )
               )
            {
               # Build up Primary database independent initialisation
               # and set all environmental variables required for 
               # this database type

               $main::current_db->init1( $main::v_db );

               # Now attempt connection, first tell user what we're doing

               $main_label->configure( -image => $main::conn_ball{red} );
               $main::l_top_t = $main::lg{connecting};
               main::bz();

               # Try a double whammy on connecting, to help out
               # various operating systems. Set a flag
               # to later suppress connection errors,
               # except on the last one.  Try the full connection
               # option first, the one needed for NT.

               my $data_source_1 = 'dbi:' . 
                                   $main::orac_curr_db_typ . 
                                   ':';

               my $data_source_2 = 'dbi:' . 
                                   $main::orac_curr_db_typ . 
                                   ':' . 
                                   $main::v_db;

               $main::conn_comm_flag = 1;

               main::connector($data_source_2, $main::v_sys, $v_ps);

               if (defined($DBI::errstr)){

                  # Set flag, to now allow proper warnings, on the last
                  # attempted connection

                  $main::conn_comm_flag = 0;
                  main::connector($data_source_1, $main::v_sys, $v_ps);
               }

               $main::conn_comm_flag = 0;

               if (!defined($DBI::errstr)){

                  $dn = 1;

                  if ((!defined($ls_db{$main::v_db})) || 
                      ($ls_db{$main::v_db} != 102)){

                     # If we connected successfully to a new 
                     # database, store this fact, and put it 
                     # in the browse option for later use

                     open(DBFILE,
                          ">>txt/" . 
                          $main::orac_curr_db_typ . 
                          "/orac_db_list.txt");

                     print DBFILE "$main::v_db\n";
                     close(DBFILE);
                  }
                  $main_label->configure( -image => $main::conn_ball{green} );
                  $main::l_top_t = "$main::v_db";
                  $main::sys_user = $main::v_sys;
               } else {
                  $main_label->configure( -image => $main::conn_ball{red} );
                  $main::l_top_t = $main::lg{not_conn};
               }
               main::ubz();
            } else {
               # Various error messages for invalid input

               main::mes($main::mw, $main::lg{system_please});
            }
         } else {
            main::mes($main::mw,$main::lg{user_please});
         }
      } elsif ($mn_b eq $main::lg{change_dbtyp}) {
         
         # User may have decided to change database type 

         $main::orac_curr_db_typ = main::select_dbtyp(2);
      } else {
       
         undef $main::current_db;
         $dn = 1;
      }
   } until $dn;

   # Ok, we're done here.  Now Orac can start work.  Stand by your beds.
}
sub connector {
   print STDERR "connecting: $_[0], $_[1], $_[2]\n" if ($main::debug > 0);
   $main::dbh = DBI->connect($_[0], $_[1], $_[2]);
   $main::current_db->set_db_handle($main::dbh);
}
sub select_dbtyp {

   # User may either be picking default database type for the first
   # time, or changing database type.  Either way, build up
   # dialogue to allow them to do this.

   my ($option) = @_;
   my $mess;
   my $tit;
   my $loc_db;
   if ($option == 1){
      $mess = $main::lg{please_pick_db};
      $tit = $main::lg{new_dbtyp};
   } else {
      $mess = $main::lg{db_change_mess};
      $tit = $main::lg{change_dbtyp};
      $loc_db = $main::orac_curr_db_typ;
   }
   my $dn = 0;
   do {
      my $d = $main::mw->DialogBox(-title=>$tit);

      my $l1 = $d->Label(-text=>$mess,
                         -anchor=>'n'
                         )->pack(-side=>'top');

      my $l2 = $d->Label(-text=>$main::lg{db_type} . ':',
                         -anchor=>'e',
                         -justify=>'right'
                        );

      my $b_d = $d->BrowseEntry(-cursor=>undef,
                                -variable=>\$loc_db,
                                -foreground=>$main::fc,
                                -background=>$main::ec,
                                -width=>40
                               );
   
      # Check out which DBs we're currently allowed to pick from

      open(DB_FIL,'config/all_dbs.txt');
      my $i = 0;
      while(<DB_FIL>){
         my @hold = split(/\^/, $_);
         if (($option == 1) && ($i == 0)) {
            $loc_db = $hold[0];
            $i++;
         }
         $b_d->insert('end', $hold[0]);
      }
      close(DB_FIL);
      
      # It's grid crazy time again.  Don't ya love it!

      Tk::grid($l1,-row=>0,-column=>1,-sticky=>'e');
      Tk::grid($l2,-row=>1,-column=>0,-sticky=>'e');
      Tk::grid($b_d,-row=>1,-column=>1,-sticky=>'ew');  # Eddie Irvine!!!
      $d->gridRowconfigure(1,-weight=>1);
      $d->Show;
   
      # Check out that that they the correct DBI module loaded.
      # If not, give them a politically correct virtual slap!

      my $db_init_command = 'DBI->data_sources(\'dbi:' . $loc_db . ':\');';
      eval $db_init_command;
      if ($@) {
         warn $@;
         main::mes($main::mw,$main::lg{wrong_dbi});
      } else {
         $dn = 1;
      }
   } until $dn;

   # A successful connection means we store the variable for later

   # Pick up the standard DBA user for the particular database
   ($main::sys_user,$main::v_db) = get_dba_user($loc_db);
   main::fill_defaults($loc_db, $main::sys_user, $main::bc, $main::v_db);

   return $loc_db;
}
sub get_dba_user {
   my($db) = @_;
   my $dba_user;
   my $new_db;

   # Picks up the typical DBA user for the particular database

   open(DB_FIL,'config/all_dbs.txt');
   while(<DB_FIL>){
      my @hold = split(/\^/, $_);
      if ($db eq $hold[0]){
         $dba_user = $hold[1];
         $new_db = $hold[2];
      }
   }
   close(DB_FIL);
   return ($dba_user,$new_db);
}
sub get_db {
   # Picks up database, and then configures menus accordingly

   main::get_connected();
   unless (defined($main::current_db)){
     main::back_orac();
   }

   # Run the second initialisation routine 
   $main::current_db->init2( $main::dbh );

   # Now sort out Jared's tools and configurable menus
   if ($main::orac_orig_db ne $main::orac_curr_db_typ){

      # We do this, if either we're into the program for the first time,
      # or the user has changed the database type

      main::del_Jareds_tools();
      main::config_menu();
      main::Jareds_tools();
      $main::orac_orig_db = $main::orac_curr_db_typ;
   }
}

sub bz {
   # Make the main GUI pointer go busy
   $main::mw->Busy;
}
sub ubz {
   # Make the main GUI pointer normalise to unbusy
   $main::mw->Unbusy;
}
sub get_Jared_sql {

   # Takes pointers to which cascade and button the user
   # wishes to run, and sucks SQL info out of the appropriate
   # file, before returning as a Perl string variable

   my($casc,$butt) = @_;
   my $filename = 'tools/sql/' . $casc . '.' . $butt . '.sql';
   my $cm = '';
   open(JARED_FILE, "$filename");
   while(<JARED_FILE>){
      $cm = $cm . $_;
   }
   close(JARED_FILE);
   return $cm;
}
sub mes {

   # Orac messaging Dialogue function.  Have you
   # ever seen a program without one of these?

   my $d = $_[0]->DialogBox();
   $d->Label(text=>$_[1])->pack();
   $d->Show;
}
sub orac_Show {

   # The standard Dialogue "Show" functionality is a bit
   # too clumsy for Orac.  Here we refine it's operation
   # a little, to make window sizing a little nicer
   # for Orac users, especially Czech ones :)

   my($d) = @_;
   my $old_focus = $d->focusSave;
   my $old_grab = $d->grabSave;
   my $e = $d->Subwidget("top")->pack(side=>'top',fill=>'both',expand=>'y');
   $d->Subwidget("bottom")->pack(side=>'bottom',before=>$e,expand=>'n');
   $d->Popup();
   $d->grab;
   $d->waitVisibility;
   $d->focus;
   $d->waitVariable(\$d->{"selected_button"});
   $d->grabRelease;
   $d->withdraw;
   &$old_focus;
   &$old_grab;
}
sub bc_upd {

   # Change the background colour on all open windows.
   # This is where all those text and window handles
   # come in useful.

   eval {
      $main::v_text->configure(-background=>$main::bc);
   };
   my $comp_str = "";
   my $i;

   my $f;
   foreach $f (keys(%main::swc))
   {
      if (defined($main::swc{$f})){

         print STDERR "main swc f state >" . $main::swc{$f}->state . "< \n" if ($main::debug > 0);

         my $comp_str = $main::swc{$f}->state;

         if("$comp_str" ne 'withdrawn'){
            eval {
               $main::swc{$f}->{text}->configure(-background=>$main::bc);
            }
         }
      }
   }
}
sub read_language {

   # Open up the main configurable
   # language file, and pick up all
   # the strings required by Orac

   open(TITLES_FILE, "txt/English.txt");
   my $lhand;
   my $rhand;
   while(<TITLES_FILE>){
      ($lhand,$rhand) = split(/\^/, $_);
      $main::lg{$lhand} = $rhand;
   }
   close(TITLES_FILE);
}

#############################################################
# new language stuff!
# use keys(%main::languages) to populate the drop down

sub get_language_data {

   # Open up the main configurable
   # language file, and pick up all
   # the strings required by Orac

   open(TITLES_FILE, "txt/languages.txt") or die "can't open txt/languages.txt";
   # expect to find:  language_label,language_file
   my $lhand;
   my $rhand;
   undef %main::languages;
   while(<TITLES_FILE>){
      ($lhand,$rhand) = split(/,/);
      $main::languages{$lhand} = $rhand;
   }
   close(TITLES_FILE);
}
sub read_language_file {
   # ARG1 = language_label picked
   my $file = "txt/$main::languages{$_[0]}";
   open(TITLES_FILE, "<$file") or die "can't open language file $file";
   my $lhand;
   my $rhand;
   while(<TITLES_FILE>){
      ($lhand,$rhand) = split(/\^/, $_);
      $main::lg{$lhand} = $rhand;
   }
   close(TITLES_FILE);
}
#############################################################

sub config_menu {

   # Read the database dependent menu configuration
   # file, and build up menus.

   my $i;
   my $func_line_ct;
   my $menu_command = "";

   # Does a configurable menu currently exist?
   # If so, destroy it.

   $main::tm_but_ct = 0;
   if(defined(@main::tm_but)){
      my $i;
      my $ct = @main::tm_but;
      for ($i = ($ct - 1);$i >= 0;$i--){
         $main::tm_but[$i]->destroy();
      }
      @main::tm_but = undef;
   }
   $main::tm_but_ct = -1;

   # Initialize variables to prevent
   # warnings

   my $file = "menu/$main::orac_curr_db_typ/menu.txt";
   open(MENU_F, $file);
   while(<MENU_F>){

      chomp;
      my $chop_bit = $_;
      my @menu_line = split(/\^/, $chop_bit);

      if ($menu_line[0] eq 'Menubutton'){
         $menu_command = 
            $menu_command . 
            ' $main::tm_but_ct++; ' . "\n" .
            ' $main::tm_but[$main::tm_but_ct] = ' . "\n" .
            ' $main::mb->Menubutton(-text=>$main::lg{' . 
            $menu_line[1] . '},' . "\n" .
            ' )->pack(-side=>\'left\',-padx=>2); ' . "\n";
      }

      if (($menu_line[0] eq 'command') || 
          ($menu_line[0] eq 'casc_command')){

         if ($menu_line[1] ne '0'){

            $menu_command = $menu_command . ' $main::sub_win_but_hand{' . 
                            $menu_line[1] . '} = ';
         }

         if ($menu_line[0] eq 'command'){

            $menu_command = 
               $menu_command . 
               ' $main::tm_but[$main::tm_but_ct]->command(-label=>$main::lg{' . 
               $menu_line[3] . '},' . 
               ' -command=>sub{main::bz();';

         } elsif ($menu_line[0] eq 'casc_command'){

            $menu_command = $menu_command . 
                            ' $main::casc_item->command(-label=>$main::lg{' . 
                            $menu_line[3] . '},' . 
                            ' -command=>sub{main::bz();';

         }
         if ($menu_line[2] == 1){
            $menu_command = $menu_command . 
                            ' $main::current_db->f_clr($main::v_clr); ';
         }
         $menu_command = $menu_command . $menu_line[4] . '(';

         if(defined($menu_line[5])){

            # Now build the function's parameters we're going to run.
            # (if any parameters exist)

            my @func_line = split(/\+/, $menu_line[5]);
            $func_line_ct = @func_line;
   
            for ($i = 0;$i < $func_line_ct;$i++){
               $menu_command = $menu_command . $func_line[$i];
               if (($i + 1) < $func_line_ct){
                  $menu_command = $menu_command . ', ';
               }
            }
         }
         $menu_command = $menu_command . ');main::ubz()}); ' . "\n";
      }
      if ($menu_line[0] eq 'separator'){
         $menu_command = $menu_command . 
                         ' $main::tm_but[$main::tm_but_ct]->separator(); ' . 
                         "\n";
      }
      if ($menu_line[0] eq 'cascade'){
 
         # Ok, it ain't pretty, but then are you first thing
         # of a morning?  :)

         $menu_command = 
            $menu_command . 
            ' $main::tm_but[$main::tm_but_ct]->cascade(-label=>$main::lg{' . 
            $menu_line[1] . '}); ' . 
            "\n" .
            ' $main::casc = $main::tm_but[$main::tm_but_ct]->cget(-menu); ' . 
            "\n" .
            ' $main::casc_item = $main::casc->Menu; ' . 
            "\n" .
            ' $main::tm_but[$main::tm_but_ct]->entryconfigure($main::lg{' . 
            $menu_line[1] . 
            '}, -menu => $main::casc_item); ' . 
            "\n";
      }
   }
   close(MENU_F);

   # Here we go!  Slap up those menus.

   print STDERR "config_menu: menu_command >\n$menu_command\n<\n" 
      if ($main::debug > 0);

   eval $menu_command ; warn $@ if $@;

   $main::tm_but_ct++;
   $main::tm_but[$main::tm_but_ct] = 
                   $main::mb->Menubutton(-text=>$main::lg{sql_menu},
                                        )->pack(-side=>'left',
                                                -padx=>2);
   $main::sub_win_but_hand{quick_sql} =
      $main::tm_but[$main::tm_but_ct]->command(
                         -label=>$main::lg{quick_sql},

                         -command=>sub{  main::bz();
                                         orac_QuickSQL::quick_sql();
                                         main::ubz()
                                      }
                                              );
   $main::sub_win_but_hand{dbish} =
      $main::tm_but[$main::tm_but_ct]->command(
                         -label=>$main::lg{dbish},

                         -command=>sub{  main::bz();

         print STDERR "mw >$main::mw<,  dbh >$main::dbh< \n" if ($main::debug > 0);

                                         $main::shell = orac_Shell->new( $main::mw, $main::dbh );
                                         $main::shell->dbish_open();
                                         main::ubz()
                                      }
                                              );
   return;
}
sub Jareds_tools {

   # Build up the 'My Tools' menu option.

   if(!defined($main::jt)){

      # Monster coming up.  You'll cope.

      my $comm_str = 
          ' $main::jt = $main::mb->Menubutton( ' . "\n" . 
          ' -text=>$main::lg{my_tools},' . "\n" .
          ' -menuitems=> ' . "\n" .
          ' [[Button=>$main::lg{help_with_tools},' .
          ' -command=>sub{main::bz();' . "\n" .
          ' $main::current_db->f_clr($main::v_clr);' . "\n" .
          ' $main::current_db->about_orac(\'txt/help_with_tools.txt\');' . 
          "\n" .
          ' main::ubz()}], ' . "\n" .
          '  [Cascade=>$main::lg{config_tools},-menuitems => ' . "\n" .
          '   [[Button=>$main::lg{config_add_casc},' . "\n" .
          '      -command=>sub{' . "\n" .
          '      main::bz();' . "\n" .
          '      main::config_Jared_tools(1);' . "\n" .
          '      main::ubz()},], ' . "\n" .
          '    [Button=>$main::lg{config_edit_casc},-command=>sub{' . "\n" .
          '      main::bz();' . "\n" .
          '      main::config_Jared_tools(6);' . "\n" .
          '      main::ubz()},], ' . "\n" .
          '    [Button=>$main::lg{config_del_casc},-command=>sub{' . "\n" .
          '      main::bz();' . "\n" .
          '      main::config_Jared_tools(2);' . "\n" .
          '      main::ubz()},], ' . "\n" .
          '    [Separator=>\'\'], ' . "\n" .
          '    [Button=>$main::lg{config_add_butt},-command=>sub{' . "\n" .
          '      main::bz();' . "\n" .
          '      main::config_Jared_tools(3);' . "\n" .
          '      main::ubz()},], ' . "\n" .
          '    [Button=>$main::lg{config_edit_butt},-command=>sub{' . "\n" .
          '      main::bz();' . "\n" .
          '      main::config_Jared_tools(7);' . "\n" .
          '      main::ubz()},], ' . "\n" .
          '    [Button=>$main::lg{config_del_butt},-command=>sub{' . "\n" .
          '      main::bz();' . "\n" .
          '      main::config_Jared_tools(4);' . "\n" .
          '      main::ubz()},], ' . "\n" .
          '    [Separator=>\'\'], ' . "\n" .
          '    [Button=>$main::lg{config_edit_sql},-command=>sub{' . "\n" .
          '      main::bz();' . "\n" .
          '      main::config_Jared_tools(5);' . "\n" .
          '      main::ubz()},],], ' . "\n" .
          '  ], ' . "\n" .
          '  [Separator=>\'\'], ' . "\n";

      if(open(JT_CASC,'tools/config.tools')){
         while(<JT_CASC>){
            my @jt_casc = split(/\^/, $_);
            if ($jt_casc[0] eq 'C'){

               $comm_str = $comm_str . 
                           ' [Cascade  =>\'' . 
                           $jt_casc[2] . 
                           '\',-menuitems => [ ' . "\n";

               open(JT_CASC_BUTTS,'tools/config.tools');
               while(<JT_CASC_BUTTS>){
                  my @jt_casc_butts = split(/\^/, $_);
                  if (($jt_casc_butts[0] eq 'B') && 
                      ($jt_casc_butts[1] eq $jt_casc[1])){

                     # Bit of a pig below, but you'll get through it
                     # if you have a quick lager

                     $comm_str = 
                        $comm_str . 
                        ' [Button=>\'' . 
                        $jt_casc_butts[3] . 
                        '\',' .
                        '-command=>sub{main::bz(); ' .
                        '$main::current_db->f_clr($main::v_clr); ' . 
                        "\n" .
                        ' main::run_Jareds_tool(\'' . 
                        $jt_casc[1] . 
                        '\',\'' . 
                        $jt_casc_butts[2] . 
                        '\');main::ubz()}], ' . "\n";
                  }
               }
               close(JT_CASC_BUTTS);
               $comm_str = $comm_str . ' ],], ' . "\n";
            }
         }
         close(JT_CASC);
      }
      $comm_str = $comm_str . 
                  ' ])->pack(-side=>\'left\',-padx=>2) ; ';

      eval $comm_str ; warn $@ if $@;
   }
}
sub save_sql {

   # Pick up the SQL the user has entered, and
   # save it into the appropriate file

   my($filename) = @_;
   main::orac_copy($filename,"${filename}.old");

   open(SAV_SQL,">$filename");
   print SAV_SQL $main::swc{ed_butt_win}->{text}->get("1.0", "end");
   close(SAV_SQL);

   return $filename;
}
sub ed_butt {

   # Allow configuration of 'My Tools' menus, buttons, cascades, etc

   my($casc,$butt) = @_;
   my $ed_fl_txt = main::get_butt_text($casc,$butt);
   my $sql_file = 'tools/sql/' . $casc . '.' . $butt . '.sql';
   
   $main::swc{ed_butt_win} = MainWindow->new();

   $main::swc{ed_butt_win}->title(  "$main::lg{cascade} $casc, 
                                    $main::lg{button} $butt");

   my $ed_sql_txt = "$ed_fl_txt: $main::lg{ed_sql_txt}";
   my $ed_sql_txt_cnt = 0;

   $main::swc{ed_butt_win}->Label( 
                                  -textvariable  => \$ed_sql_txt, 
                                  -anchor=>'n', 
                                  -relief=>'groove'
                                )->pack(-expand=>'no');

   $main::swc{ed_butt_win}->{text} = 
      $main::swc{ed_butt_win}->Scrolled('Text',
                                  -wrap=>'none',
                                  -cursor=>undef,
                                  -foreground=>$main::fc,
                                  -background=>$main::bc
   
                                 )->pack(-expand=>'yes',
                                         -fill=>'both');
   
   my(@lay) = qw/-side bottom -padx 5 -fill both -expand no/;

   my $f = $main::swc{ed_butt_win}->Frame->pack(@lay);

   $f->Button(
      -text=>$main::lg{exit},
      -command=>sub{ $main::swc{ed_butt_win}->withdraw() }

             )->pack(-side=>'right',
                     -anchor=>'e');

   $f->Button(
      -text=>$main::lg{save},
      -command=>

          sub{ my $file_name = main::save_sql($sql_file, $ed_fl_txt);
               $ed_sql_txt_cnt++;
               $ed_sql_txt = "$ed_fl_txt: $file_name $main::lg{saved}" . 
                             ' #' . 
                             $ed_sql_txt_cnt;
             }

             )->pack(-side=>'right',
                     -anchor=>'e');

   $f->Label(-text=>$main::lg{no_semi_colon},
             -relief=>'sunken'
            )->pack(-side=>'left',
                    -anchor=>'w');

   main::iconize($main::swc{ed_butt_win});

   if(open(SQL_SAV,$sql_file)){

      while(<SQL_SAV>){ 
         $main::swc{ed_butt_win}->{text}->insert("end", $_); 
      }
      close(SQL_SAV);

   }
}
sub config_Jared_tools {

   # More functionality required to allow on-the-fly configuration
   # of the 'My Tools' options.

   # This function is fairly overloaded, and may require some
   # detailed analysis, before it becomes clearer what it's doing.

   my($param,$loc_casc,$loc_butt) = @_;
   my $main_check;
   my $title;
   my $action;
   my $inp_text;
   my $sec_check;

   if(($param == 1)||($param == 99)||($param == 69)||($param == 49)){

      $main_check = 'C';
      $title = $main::lg{add_cascade};
      my $main_field = 1;
      my $main_inp_value;
      my $add_text = $main::lg{casc_text};
      $action = $main::lg{add};

      if($param == 69){

         $title = $main::lg{upd_cascade};
         $action = $main::lg{upd};

      } elsif($param == 49) {

         $main_check = 'B';
         $title = "$main::lg{cascade} $loc_casc, $main::lg{button}";
         $add_text = $main::lg{upd_button};
         $action = $main::lg{upd};

      } elsif($param == 99) {

         $main_field = 2;
         $main_check = 'B';
         $title = "$main::lg{cascade} $loc_casc: $main::lg{add_button}";
         $add_text = $main::lg{butt_text};
      }

      if(($param == 69)||($param == 49)){

         $main_inp_value = $loc_casc;

      } else {

         my @inp_value;
         my $inp_count = 0;
         if(open(JT_CONFIG,'tools/config.tools')){
            while(<JT_CONFIG>){
               my @hold = split(/\^/, $_);

               # Jesus, I can't believe I wrote the 'if' statement
               # below.  If you can figure it out, can you let me know
               # what it's doing?  ;-)

               if ((($param == 1) && 
                    ($hold[0] eq $main_check)) ||
                   (($param == 99) && 
                    ($hold[0] eq $main_check) && 
                    ($hold[1] eq $loc_casc))) {
      
                  $inp_value[ $inp_count ] = $hold[ $main_field ];
                  $inp_count++;
               }
            }
            close(JT_CONFIG);
         }
         if($inp_count > 0){
            $inp_count--;
            my $flag = 0;
            my $flag2 = 0;
            $main_inp_value = 1;
            while($flag == 0){
               my $i;
               $flag2 = 0;
               for ($i = 0;$i <= $inp_count;$i++){
                  if($main_inp_value == $inp_value[$i]){
                     $main_inp_value++;
                     $flag2 = 1;
                     last;
                  }
               }
               if ($flag2 == 0){
                  $flag = 1;
               }
            }
         } else {
            $main_inp_value = 1;
         }
         $main_inp_value = sprintf("%03d", $main_inp_value);
      }

      # Now get to main dialogue and pick up the reqd. info

      my $d = $main::mw->DialogBox(-title=>"$title $main_inp_value",
                             -buttons=>[ $action,
                                         $main::lg{cancel} ]
                            );

      my $l = $d->Label(-text=>$add_text . ':',
                        -anchor=>'e',
                        -justify=>'right'
                       );

      $inp_text = '';

      if(($param == 69)||
         ($param == 49)){

         open(JT_CONFIG_READ,'tools/config.tools');

         while(<JT_CONFIG_READ>){

            my @hold = split(/\^/, $_);

            if($param == 69){

               if (($hold[0] eq $main_check) && 
                   ($hold[1] eq $loc_casc)){

                  $inp_text = $hold[2];
               }
            } elsif($param == 49){

               if (($hold[0] eq $main_check) && 
                   ($hold[1] eq $loc_casc) && 
                   ($hold[2] = $loc_butt)){

                  $inp_text = $hold[3];
               }
            }
         }
         close(JT_CONFIG_READ);
      }

      my $cs = $d->add("Entry",
                       -textvariable=>\$inp_text,
                       -cursor=>undef,
                       -foreground=>$main::fc,
                       -background=>$main::ec,
                       -width=>40

                      )->pack(side=>'right');

      # Stand by your grids!

      Tk::grid($l,-row=>0,-column=>0,-sticky=>'e');
      Tk::grid($cs,-row=>0,-column=>1,-sticky=>'ew');

      $d->gridRowconfigure(1,-weight=>1);
      my $rp = $d->Show;
      if ($rp eq $action) {
         if (defined($inp_text) && length($inp_text)){
            if(($param == 69)||($param == 49)){
               return (1,$inp_text);
            } else {

               open(JT_CONFIG_APPEND,'>>tools/config.tools');
               if($param == 1){

                  print JT_CONFIG_APPEND $main_check . 
                                         '^' . 
                                         $main_inp_value . 
                                         '^' . 
                                         $inp_text . 
                                         '^' . 
                                         "\n";

               } elsif($param == 99) {

                  print JT_CONFIG_APPEND $main_check . 
                                         '^' . 
                                         $loc_casc . 
                                         '^' . 
                                         $main_inp_value . 
                                         '^' . 
                                         $inp_text . 
                                         '^' . 
                                         "\n";
               }
               close(JT_CONFIG_APPEND);

               main::sort_Jareds_file();

               if($param == 99){
                  main::ed_butt($loc_casc,$main_inp_value);
               }
            }
         } else {
            main::mes($d,$main::lg{no_val_def});
            if($param == 69){
               return (0,$inp_text);
            }
         }
      }
   } elsif(($param == 2)||
           ($param == 3)||
           ($param == 4)||
           ($param == 5)||
           ($param == 6)||
           ($param == 7)||
           ($param == 59)||
           ($param == 79)||
           ($param == 89)){
      my $d_inp;
      my $b_d;
      my $tl;
      my $l;
      my @casc1;
      my @casc2;
      my $d;
      my $message;

      $main_check = 'C';
      my $del_text = $main::lg{casc_text};

      if($param == 2){

         $title = $main::lg{del_cascade};
         $action = $main::lg{del};
         $message = $main::lg{del_message};

      } elsif($param == 3) {

         $title = $main::lg{add_button};
         $action = $main::lg{next};
         $message = $main::lg{add_butt_mess};

      } elsif($param == 4) {

         $title = $main::lg{del_button};
         $action = $main::lg{next};
         $message = $main::lg{del_butt_mess};

      } elsif($param == 5) {

         $title = $main::lg{config_edit_sql};
         $action = $main::lg{next};
         $message = $main::lg{ed_sql_mess};

      } elsif($param == 6){

         $title = $main::lg{config_edit_casc};
         $action = $main::lg{next};
         $message = $main::lg{choose_casc};

      } elsif($param == 7){

         $sec_check = 'B';
         $title = $main::lg{config_edit_butt};
         $action = $main::lg{next};
         $message = $main::lg{choose_casc};

      } elsif($param == 59) {

         $main_check = 'B';
         $title = $main::lg{config_edit_butt};
         $action = $main::lg{next};
         $message = "$main::lg{cascade} $loc_casc: $main::lg{choose_butt}";
         $del_text = $main::lg{choose_butt};

      } elsif($param == 79) {

         $main_check = 'B';
         $title = $main::lg{config_edit_sql};
         $action = $main::lg{next};
         $message = $main::lg{ed_sql_mess2};

      } elsif($param == 89) {

         $main_check = 'B';
         $title = $main::lg{del_button};
         $action = $main::lg{del};
         $message = "$main::lg{cascade} $loc_casc: $main::lg{del_butt_mess2}";
         $del_text = $main::lg{del_butt_text};
      }

      my $i_count = 0;

      if(open(JT_CONFIG,'tools/config.tools')){

         while(<JT_CONFIG>){
            my @hold = split(/\^/, $_);

            if(($param != 89) && 
               ($param != 79) && 
               ($param != 59)){

               if ($hold[0] eq $main_check){

                  $casc1[$i_count] = sprintf("%03d",$hold[1]) . ":$hold[2]";
                  $i_count++;
               }

            } else {
               if (($hold[0] eq $main_check) && 
                   ($hold[1] eq $loc_casc)){

                  $casc1[$i_count] = sprintf("%03d",$hold[2]) . ":$hold[3]";
                  $i_count++;
               }
            }
         }
      }
      if ($i_count > 0){
         @casc2 = sort @casc1;
         $i_count = 0;

         my $t_l;

         foreach(@casc2){

            if($i_count == 0){

               $d = $main::mw->DialogBox(-title=>$title,
                                   -buttons=>[ $action,
                                               $main::lg{cancel} ]
                                  );

               $t_l = $d->Label(-text=>$message,
                                -anchor=>'n'
                               )->pack(-side=>'top');

               $l = $d->Label(-text=>$del_text . ':',
                              -anchor=>'e',
                              -justify=>'right'
                             );

               $d_inp = $casc2[$i_count];

               $b_d = $d->BrowseEntry( -cursor=>undef,
                                       -variable=>\$d_inp,
                                       -foreground=>$main::fc,
                                       -background=>$main::ec,
                                       -width=>40
                                     );
            }
            $b_d->insert('end', $casc2[$i_count]);
            $i_count++;
         }
         close(JT_CONFIG);
   
         # Let's do a chessboard, or is that a cheeseboard?

         Tk::grid($t_l,-row=>0,-column=>1,-sticky=>'e');
         Tk::grid($l,-row=>1,-column=>0,-sticky=>'e');
         Tk::grid($b_d,-row=>1,-column=>1,-sticky=>'ew');
         $d->gridRowconfigure(1,-weight=>1);

         my $rp = $d->Show;
         if ($rp eq $action) {
            my $fin_inp = sprintf("%03d", split(/:/,$d_inp));
            my $sec_inp;
            my $ed_txt;

            if (defined($fin_inp) && length($fin_inp)){

               if(($param == 2)     ||
                  ($param == 59)    ||
                  ($param == 89)    ||
                  ($param == 6)     ||
                  ($param == 7)) {

                  my $safe_flag = 0;

                  if($param == 6) {

                     ($safe_flag,$ed_txt) = 
                        main::config_Jared_tools(69,$fin_inp);

                  } elsif($param == 7) {

                     ($safe_flag,$sec_inp) = 
                        main::config_Jared_tools(59,$fin_inp);

                     if ((defined($safe_flag)) && 
                         (length($safe_flag)) && 
                         ($safe_flag == 1)){

                        ($safe_flag,$ed_txt) = 
                           main::config_Jared_tools(49,$fin_inp,$sec_inp);
                     }

                  } elsif($param == 59) {

                     $safe_flag = 0;
                     return (1,$fin_inp);

                  } else {

                     $safe_flag = 1;

                  }

                  # OK, Ok, I've forgotten how this works too, but it
                  # seemed to make sense at the time?

                  if ((defined($safe_flag)) && 
                      (length($safe_flag)) && 
                      ($safe_flag == 1)){

                     main::orac_copy('tools/config.tools',
                                     'tools/config.tools.old');

                     open(JT_CONFIG_READ,'tools/config.tools.old');
                     open(JT_CONFIG_WRITE,'>tools/config.tools');

                     while(<JT_CONFIG_READ>){
                        chomp;
                        my @hold = split(/\^/, $_);
                        if($param == 2){
                           unless ($hold[1] eq $fin_inp){
                              print JT_CONFIG_WRITE "$_\n";
                           }
                        } elsif($param == 6){

                           unless (($hold[0] eq $main_check) && 
                                   ($hold[1] eq $fin_inp)){

                              print JT_CONFIG_WRITE "$_\n";

                           } else {

                              print JT_CONFIG_WRITE $hold[0] . 
                                                    '^' . 
                                                    $hold[1] . 
                                                    '^' . 
                                                    $ed_txt . 
                                                    '^' . 
                                                    "\n";
                           }
                        } elsif($param == 7){

                           unless (($hold[0] eq $sec_check) && 
                                   ($hold[1] eq $fin_inp) && 
                                   ($hold[2] eq $sec_inp)){

                              print JT_CONFIG_WRITE "$_\n";

                           } else {

                              print JT_CONFIG_WRITE $hold[0] . 
                                                    '^' . 
                                                    $hold[1] . 
                                                    '^' . 
                                                    $hold[2] . 
                                                    '^' . 
                                                    $ed_txt . 
                                                    '^' . 
                                                    "\n";
                           }

                        } else {

                           unless (($hold[0] eq $main_check) && 
                                   ($hold[1] eq $loc_casc) && 
                                   ($hold[2] eq $fin_inp)){ 

                              print JT_CONFIG_WRITE "$_\n";

                           }
                        }
                     }
                     close(JT_CONFIG_READ);
                     close(JT_CONFIG_WRITE);
                     main::sort_Jareds_file();
                  }

               } elsif($param == 3) {

                  main::config_Jared_tools(99,$fin_inp);

               } elsif($param == 5) {

                  main::config_Jared_tools(79,$fin_inp);

               } elsif($param == 79) {

                  my $filename = 'tools/sql/' . 
                                 $loc_casc . 
                                 '.' . 
                                 $fin_inp . 
                                 '.sql';

                  main::ed_butt($loc_casc,$fin_inp);

               } else {

                  main::config_Jared_tools(89,$fin_inp);

               }

            } else {

               main::mes($d,$main::lg{no_val_def});

            }
         }

      } else {

         main::mes($main::mw,$main::lg{no_cascs});

         if ($param == 59){
            return (0,'');
         }
      }
   }
   main::del_Jareds_tools();
   main::Jareds_tools();
}
sub sort_Jareds_file {
   main::orac_copy('tools/config.tools','tools/config.tools.sort');
   open(JT_CONFIG_READ,'tools/config.tools.sort');
   my @file_read;
   my @file_write;
   my $i_count = 0;
   while(<JT_CONFIG_READ>){
      chomp;
      $file_read[$i_count] = $_;
      $i_count++;
   }
   close(JT_CONFIG_READ);

   open(JT_CONFIG_WRITE,'>tools/config.tools');
   @file_write = sort @file_read;
   $i_count = 0;
   foreach(@file_write){
      print JT_CONFIG_WRITE "$file_write[$i_count]\n";
      $i_count++;
   }
   close(JT_CONFIG_WRITE);
}
sub get_butt_text {

   # Pick up more information on the configurable buttons

   my($casc,$butt) = @_;
   my $title = '';
   open(JARED_FILE,'tools/config.tools');
   while(<JARED_FILE>){
      my @hold = split(/\^/, $_);
      if(($hold[0] eq 'B') && ($hold[1] eq $casc) && ($hold[2] eq $butt)){
         $title = $hold[3];
      }
   }
   close(JARED_FILE);
   return $title;
}

sub run_Jareds_tool {

   # When user selects their own button, run the 
   # associated report

   my($casc,$butt) = @_;

   $main::current_db->show_sql ( main::get_Jared_sql( $casc, $butt ),
                                 main::get_butt_text( $casc, $butt )
                               );
}

sub del_Jareds_tools {

   # If the 'My Tools' menu currently exists, then
   # destroy it

   if(defined($main::jt)){
      $main::jt->destroy();
      $main::jt = undef;
   }
}
sub orac_copy {

   # This is to avoid Orac becoming OS dependent.
   # Obviously, on UNIX it would be easy to write
   # system("cp $file1 $file2");, but this would
   # make us dependent on UNIX.  Hopefully, this
   # function provided file copying functionality
   # without tying Orac down to the OS.

   my($ammo,$target) = @_;
   if(open(ORAC_AMMO,"$ammo")){
      if(open(ORAC_TARGET,">${target}")){
         while(<ORAC_AMMO>){
            print ORAC_TARGET $_;
         }
         close(ORAC_TARGET);
      }
      close(ORAC_AMMO);
   }
}
sub iconize {

   # Take a Window handle, and tie an icon 
   # to it.

   my($w) = @_;
   my $icon_img = $w->Photo('-file' => 'img/orac_med.gif');
   $w->Icon('-image' => $icon_img);
}
sub pick_up_defaults {

   # This allows user to select main database type.
   # Also allows selection of pre-defined background
   # colour.  Assign some pre-defined values in case
   # the config file not yet available.

   $main::bc = $main::lg{def_backgr_col};

   my $i = 0;
   my $file = 'config/what_db.txt';
   if(-e $file){
      open(DB_FIL,$file);
      while(<DB_FIL>){
         my @hold = split(/\^/, $_);
         $main::orac_curr_db_typ = $hold[0];
         $main::sys_user = $hold[1];
         $main::bc = $hold[2];
         $main::v_db = $hold[3];
         $i = 1;
      }
      close(DB_FIL);
   }
   return;
}
BEGIN {

   # If any non-fatal warnings/errors are detected by
   # Orac, this should ensure they come up in "look-and-feel"
   # window.  Particularly useful for reporting back
   # database error messages.

   # We have one program flag for suppressing error messages
   # on database connection, until the last variation
   # on database connection is attempted.

   $SIG{__WARN__} = sub{
      if ((!defined($main::conn_comm_flag)) || ($main::conn_comm_flag == 0)){
         if (defined $main::mw) {
            main::mes($main::mw,$_[0]);
         } else {
            print STDOUT join("\n",@_),"n";
         }
      }
   };
}
