view release on metacpan or  search on metacpan

examples/ora_explain.pl  view on Meta::CPAN

my $text = $dialog->Scrolled("ROText", -height => $height, -width => $width,
                             -borderwidth => 3, -relief => "raised",
                             -wrap => "word", -scrollbars => "oe")
   ->pack(-padx => 6, -pady => 6, -expand => 1, -fill => "both");
$text->insert("1.0", $msg);

my $ok_cb = sub { $dialog->destroy() };
$dialog->Button(-text => "OK", -default => "active", -command => $ok_cb)
   ->pack(-padx => 6, -pady => 6);
$dialog->bind("<KeyPress-Return>", $ok_cb);
$dialog->Popup;
}

################################################################################

sub about($;$)
{
my ($parent, $win) = @_;
my $msg = <<EOM;

                               $ProgName version $VERSION
                        Copyright (c) 1998 Alan Burlison
                            Alan.Burlison\@uk.sun.com

 You may distribute under the terms of either the GNU General Public License
 or the Artistic License, as specified in the Perl README file.

 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 by Sun Microsystems.

EOM

my $dialog;
$dialog = $parent->Toplevel(-title => "About $ProgName");
$dialog->withdraw();
$dialog->resizable(0, 0);
my $text = $dialog->Text(-borderwidth => 3, -width => 80, -height => 16,
                         -relief => "raised")
   ->pack(-padx => 6, -pady => 6);
$text->insert("1.0", $msg);
my $cb;
if ($win)
   {
   $$win = $dialog;
   $cb = sub { $dialog->destroy(); undef($$win); };
   }
else
   {
   $cb = sub { $dialog->destroy(); };
   }
$dialog->Button(-text => "OK", -command => $cb)->pack(-padx => 6, -pady => 6);
$dialog->Popup();
return($dialog);
}

################################################################################

sub update_title()
{
$PlanMain->configure(-title =>
   $User
      ? $User eq $Schema
         ? "$ProgName - connected to $DbName as $User"
         : "$ProgName - connected to $DbName as $User [schema $Schema]"
      : "$ProgName - not connected"
   );
}

################################################################################

sub help($)
{
my ($parent) = @_;
require Tk::Pod;
$parent->Pod(-file => $0, -scrollbars => "e");
}

################################################################################
# Login to the database.  The new database handle is put into $Db, and the
# Oracle version number is put into $OracleVersion

sub login($$$)
{
my ($database, $username, $password) = @_;

busy(1);
# Close any existing handle
if ($Db)
   {
   $Db->disconnect();
   $Db = undef;
   $DbName = $User = $Schema = undef;
   update_title();
   }

# Connect and initialise
$Db = DBI->connect("dbi:Oracle:$database", $username, $password,
                          { AutoCommit => 0, PrintError => 0})
   || die("Can't login to Oracle:\n$DBI::errstr\n");
$Db->{LongReadLen} = 4096;
$Db->{LongTruncOk} = 1;

# Get the user name and check the Oracle version
my $qry = $Db->prepare(qq(
   $SqlMarker select user, version from product_component_version
   where lower(product) like '%oracle%'
));
if (! $qry->execute())
   {
   my $err = $DBI::errstr;
   $qry->finish();
   $Db->disconnect();
   $Db = undef;
   die("Can't fetch Oracle version:\n$err\n");
   }
($User, $OracleVersion) = $qry->fetchrow_array();
$qry->finish();
$DbName = $database || $ENV{TWO_TASK} || $ENV{ORACLE_SID};