DBD-Oracle
view release on metacpan or search on metacpan
examples/ora_explain.pl view on Meta::CPAN
}
sub Populate
{
my ($self, $args) = @_;
$self->SUPER::Populate($args);
$self->ConfigSpecs(-b3command => [ "CALLBACK", "b3command", "B3command",
undef ]);
}
sub Button3
{
my $w = shift;
my $Ev = $w->XEvent;
my $ent = $w->GetNearest($Ev->y);
return unless (defined($ent) and length($ent));
$w->Callback(-b3command => $ent);
}
################################################################################
package main;
use vars qw($VERSION);
$VERSION = "1.1";
# Globals
# $ProgName Program name (without pathname)
# $Db Database handle
# $DbName Oracle database name
# $User Oracle user name
# $Schema Oracle schema name
# $SqlMarker String used to identify SQL generated by explain
# $OracleVersion Oracle version number
# $CharWidth Width of a character in pixels
# $Plan Current query plan as a Perl data structure
# $LoginDialog Login dialog
# $SchemaDialog Schema dialog
# $SaveDialog Save File dialog
# $OpenDialog Open File dialog
# $FileDir Current file save/open directory
# $PlanMain Query plan main window
# $PlanTitle Title of query plan main window
# $PlanTree Tree used to display the query plan
# $PlanStep ROText used to display the selected plan step details
# $PlanSql Text used to allow SQL editing
# $Balloon For balloon help
# $GrabMain SQL cache grab main window
# $GrabStatus Text label used for feedback/status info
# $GrabSelection Tag of currently selected SQL statement in the SQL cache
# $GrabSql ROText used to hold the contents of the SQL cache
# $GrabDetails ROText used to display the selected statement details
use vars qw($ProgName $Db $DbName $User $Schema $SqlMarker $OracleVersion
$CharWidth $Plan $LoginDialog $SchemaDialog $OpenDialog $SaveDialog
$FileDir $PlanMain $PlanTitle $PlanTree $PlanStep $PlanSql $Balloon
$GrabMain $GrabStatus $GrabSelection $GrabSql $GrabDetails);
$SqlMarker = "/* This statement was generated by explain */";
################################################################################
# Switch the hourglass on or off
sub busy($)
{
my ($state) = @_;
if ($state && $PlanMain->grabCurrent()) { $PlanMain->Busy(-recurse => 1); }
else { $PlanMain->Unbusy(1); }
}
################################################################################
# Display an error message in a dialog
sub error($@)
{
my ($parent, @lines) = @_;
my ($msg, $height, $width);
$msg = join("\n", @lines);
$msg =~ s/\n$//;
$msg =~ s/ \(DBD:/\n(DBD:/;
$msg =~ s/(indicator at char \d+ in) /$1\n/;
@lines = split("\n", $msg);
$height = @lines;
$width = 0;
foreach my $line (@lines)
{ my $l = length($line); $width = $l if ($l > $width); }
$width = 80 if ($width > 80);
$height = 4 if ($height < 4);
$height = 10 if ($height > 10);
busy(0);
my $dialog = $PlanMain->Toplevel(-title => "Error");
$dialog->withdraw();
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};
$Schema = $User;
# Check there is a plan_table for this user
$qry = $Db->prepare(qq(
$SqlMarker select 1 from user_tables where table_name = 'PLAN_TABLE'
));
$qry->execute();
if (! $qry->fetchrow_arrayref())
{
$qry->finish();
$Db->disconnect();
$Db = undef;
die("User $User does not have a PLAN_TABLE.\n",
"Run the script utlxplan.sql to create one.\n");
}
busy(0);
return(1);
}
################################################################################
# Clear the plan tree & details windows
sub clear_plan()
{
$PlanTitle->configure(-text => "Query Plan") if ($PlanTitle);
$PlanTree->delete("all") if ($PlanTree);
$PlanStep->delete("1.0", "end") if ($PlanStep);
}
################################################################################
# Clear the SQL editor pane
sub clear_editor()
{
$PlanTitle->configure(-text => "Query Plan") if ($PlanTitle);
$PlanTree->delete("all") if ($PlanTree);
$PlanStep->delete("1.0", "end") if ($PlanStep);
$PlanSql->delete("1.0", "end");
}
################################################################################
# Display the structure of an index
sub disp_index($$)
{
my ($owner, $index) = @_;
# Create the index definition frame
busy(1);
my $dialog = $PlanMain->Toplevel(-title => "Index");
$dialog->withdraw();
$dialog->resizable(0, 0);
my $index_fr = $dialog->Frame(-borderwidth => 3, -relief => "raised");
$index_fr->Label(-text => "$owner.$index", -relief => "ridge",
-borderwidth => 1)
->grid(-column => 0, -row => 0, -columnspan => 2, -sticky => "we",
-ipadx => 3);
$index_fr->Label(-text => "Table", -relief => "ridge", -borderwidth => 1)
->grid(-column => 0, -row => 1, -sticky => "we", -ipadx => 3);
$index_fr->Label(-text => "Column", -relief => "ridge", -borderwidth => 1)
->grid(-column => 1, -row => 1, -sticky => "we", -ipadx => 3);
# Show the table columns the index is built upon
my $qry = $Db->prepare(qq(
$SqlMarker select table_owner, table_name, column_name
from all_ind_columns
where index_owner = :1 and index_name = :2
order by column_position
));
$qry->execute($owner, $index) || die("Index columns:\n$DBI::errstr\n");
# For each column in the index, display its details
my ($tab_txt, $col_txt);
while ((my ($tab_owner, $table, $column) = $qry->fetchrow_array()))
{
$tab_txt .= "$tab_owner.$table\n";
$col_txt .= "$column\n";
}
$qry->finish();
chop($tab_txt, $col_txt);
$index_fr->Label(-text => $tab_txt, -relief => "ridge", -borderwidth => 1,
-justify => "left")
->grid(-column => 0, -row => 2, -sticky => "we", -ipadx => 3);
$index_fr->Label(-text => $col_txt, -relief => "ridge", -borderwidth => 1,
-justify => "left")
->grid(-column => 1, -row => 2, -sticky => "we", -ipadx => 3);
$index_fr->pack(-side => "top", -fill => "x");
# Pack the grid and add the close button
$dialog->Button(-text => "Close", -command => sub { $dialog->destroy(); })
->pack(-padx => 6, -pady => 6);
$dialog->Popup();
busy(0);
return(1);
}
################################################################################
# Callback for adding/removing index definitions to a table dialog
sub disp_table_cb($$$$$)
{
my ($owner, $table, $num_cols, $index_fr, $index_bn) = @_;
# If this is the first time through, fetch the index definitions
busy(1);
if (! $index_fr->children())
{
# This will retrieve the names & owners of all the indexes on the table
my $qry = $Db->prepare(qq(
$SqlMarker select owner, index_name
from all_indexes
where table_owner = :1 and table_name = :2
order by owner, index_name
));
# Build up a list of all the indexes
$qry->execute($owner, $table) || die("Table indexes:\n$DBI::errstr\n");
my (@indexes, $ind_owner, $ind_name);
while (($ind_owner, $ind_name) = $qry->fetchrow_array())
{ push(@indexes, { owner => $ind_owner, name => $ind_name }); }
$qry->finish();
# Special for no indexes
if (@indexes == 0)
{
$index_fr->Label(-text => "No\nindexes\ndefined", -relief => "ridge",
-borderwidth => 1)->pack(-ipadx => 3, -ipady => 4);
}
else
{
# Do the header label
$index_fr->Label(-text => "Index\norder", -relief => "ridge",
-borderwidth => 1)
->grid(-column => 0, -row => 0, -sticky => "we", -ipadx => 3,
-ipady => 2, -columnspan => scalar(@indexes), -rowspan => 2);
# This will retrieve (table column id, index position) for an index
$qry = $Db->prepare(qq(
$SqlMarker select atc.column_id, aic.column_position
from all_tab_columns atc, all_ind_columns aic
where aic.index_owner = :1 and aic.index_name = :2
and atc.owner = aic.table_owner and atc.table_name = aic.table_name
and atc.column_name = aic.column_name
order by aic.index_name, atc.column_id
));
# For each index, add a label describing the index
my $cb = sub { disp_index($_[1], $_[2]); };
my $grid_col = 0;
foreach my $index (@indexes)
{
($ind_owner, $ind_name) = @{$index}{qw(owner name)};
$qry->execute($ind_owner, $ind_name)
|| die("Index columns:\n$DBI::errstr\n");
my $index_txt;
my $col = 1;
while (my ($col_id, $col_pos) = $qry->fetchrow_array())
{
$index_txt .= "\n" x ($col_id - $col) . "$col_pos\n";
$col = $col_id + 1;
}
$index_txt .= "\n" x ($num_cols - ($col - 1));
chop($index_txt);
my $label = $index_fr->Label(-text => $index_txt, -relief => "ridge",
-borderwidth => 1, -justify => "left")
->grid(-column => $grid_col, -row => 2, -sticky => "w",
-ipadx => 3);
$label->bind("<1>", [ $cb, $ind_owner, $ind_name ]);
$Balloon->attach($label, -msg => "$ind_owner.$ind_name",
-balloonposition => "mouse");
$grid_col++;
}
}
}
if ($index_bn->cget(-text) eq "Indexes")
{
$index_bn->configure(-text => "Hide Indexes");
$index_fr->pack(-side => "right", -expand => 1);
}
else
{
$index_bn->configure(-text => "Indexes");
$index_fr->packForget();
}
busy(0);
return(1);
}
################################################################################
# Display a popup dialog showing the structure of a table
sub disp_table($$)
{
my ($owner, $table) = @_;
# Create the dialog for displaying the object details
busy(1);
my $dialog = $PlanMain->Toplevel(-title => "Table");
$dialog->withdraw();
$dialog->resizable(0, 0);
# Create the table definition frame
my $box1 = $dialog->Frame(-borderwidth => 3, -relief => "raised");
my $box2 = $box1->Frame(-borderwidth => 0);
my $table_fr = $box2->Frame(-borderwidth => 1, -relief => "flat");
$table_fr->Label(-text => "$owner.$table",
-relief => "ridge", -borderwidth => 1)
->grid(-column => 0, -row => 0, -columnspan => 2, -sticky => "we");
$table_fr->Label(-text => "Name", -relief => "ridge", -borderwidth => 1)
->grid(-column => 0, -row => 1, -sticky => "we", -ipadx => 3);
$table_fr->Label(-text => "Type", -relief => "ridge", -borderwidth => 1)
->grid(-column => 1, -row => 1, -sticky => "we", -ipadx => 3);
# This will get the table description
my $qry = $Db->prepare(qq(
$SqlMarker select column_name, data_type, data_length,
data_precision, data_scale
from all_tab_columns
where owner = :1 and table_name = :2
order by column_id
));
$qry->execute($owner, $table)
|| die("Table columns:\n$DBI::errstr\n");
my ($num_cols, $name_txt, $type_txt);
while ((my ($name, $type, $length, $precision, $scale)
= $qry->fetchrow_array()))
{
if ($precision)
{
$type .= "($precision";
$type .= ",$scale" if ($scale);
$type .= ")";
}
elsif ($type =~ /CHAR/)
{
$type .= "($length)";
}
$name_txt .= "$name\n";
$type_txt .= "$type\n";
$num_cols++;
}
$qry->finish();
chop($name_txt, $type_txt);
$table_fr->Label(-text => $name_txt, -relief => "ridge", -borderwidth => 1,
-justify => "left")
->grid(-column => 0, -row => 2, -sticky => "we", -ipadx => 3);
$table_fr->Label(-text => $type_txt, -relief => "ridge", -borderwidth => 1,
-justify => "left")
->grid(-column => 1, -row => 2, -sticky => "we", -ipadx => 3);
$table_fr->pack(-side => "left");
# Now create a frame for the index definition & pack the whole lot
my $index_fr = $box2->Frame(-borderwidth => 1, -relief => "flat");
$box2->pack();
$box1->pack(-side => "top", -fill => "x", -expand => 1);
# Create the buttons at the bottom
$box1 = $dialog->Frame(-borderwidth => 0);
$box1->Button(-text => "Close", -command => sub { $dialog->destroy(); })
->pack(-padx => 6, -side => "left", -expand => 1);
my $index_bn;
$index_bn = $box1->Button(-text => "Indexes")
->pack(-padx => 6, -side => "left", -expand => 1);
$index_bn->configure(-command => sub { disp_table_cb($owner, $table, $num_cols,
$index_fr, $index_bn); });
$box1->pack(-side => "bottom", -pady => 6);
$dialog->Popup();
busy(0);
return(1);
}
################################################################################
# Display the query plan tree
sub disp_plan_tree()
{
$PlanTitle->configure(-text => $Plan->{title});
$PlanTree->delete("all");
my $steps = 0;
foreach my $step (@{$Plan->{id}})
{
my $item = $PlanTree->add($step->{key}, -text => $step->{desc});
$steps++;
}
$PlanTree->autosetmode();
if ($steps)
{
$PlanTree->selectionSet("1");
disp_plan_step("1");
}
}
################################################################################
# Display the statistics for a given plan step
sub disp_plan_step($)
{
my ($key) = @_;
my $row = $Plan->{key}{$key};
$PlanStep->delete("1.0", "end");
my $info = "";
$info .= "Cost:\t\t$row->{COST}\t(Estimate of the cost of this step)\n"
. "Cardinality:\t$row->{CARDINALITY}\t"
. "(Estimated number of rows fetched by this step)\n"
. "Bytes:\t\t$row->{BYTES}\t"
. "(Estimated number of bytes fetched by this step)\n"
if ($row->{COST});
$info .= "\nPartition\nStart:\t$row->{PARTITION_START}\tStop:\t\t"
. "$row->{PARTITION_STOP}\tId:\t\t$row->{PARTITION_ID}\n"
if ($row->{PARTITION_START});
$info .= "\nSQL used by Parallel Query Slave:\n$row->{OTHER}"
if ($row->{OTHER});
$PlanStep->insert("1.0", $info);
}
################################################################################
# Display a popup dialog showing the structure of the table or index used in
# the passed plan step
sub disp_plan_step_obj($)
{
my ($key) = @_;
# Get the plan step & return if it doesn't refer to an object
my $row = $Plan->{key}{$key};
return(1) if (! $row->{OBJECT_NAME});
# Work out the type of the object - table or index
busy(1);
my $qry = $Db->prepare(qq(
$SqlMarker select object_type from all_objects
where object_name = :1 and owner = :2
));
$qry->execute($row->{OBJECT_NAME}, $row->{OBJECT_OWNER})
|| die("Object type:\n$DBI::errstr\n");
my ($object_type) = $qry->fetchrow_array();
$qry->finish();
busy(0);
if ($object_type eq "TABLE")
{
disp_table($row->{OBJECT_OWNER}, $row->{OBJECT_NAME});
}
elsif ($object_type eq "INDEX")
{
disp_index($row->{OBJECT_OWNER}, $row->{OBJECT_NAME});
}
else
{
die("Unknown object type $object_type",
"for $row->{OBJECT_OWNER}.$row->{OBJECT_NAME}\n");
}
}
################################################################################
# Display a list of available indexes on a table, and display the selected
# table definition
sub disp_index_popup($)
{
my ($key) = @_;
# Get the plan step & return if it doesn't refer to an object
my $row = $Plan->{key}{$key};
return(1) if (! $row->{OBJECT_NAME});
# Work out the type of the object - table or index
busy(1);
my $qry = $Db->prepare(qq(
$SqlMarker select object_type from all_objects
where object_name = :1 and owner = :2
));
$qry->execute($row->{OBJECT_NAME}, $row->{OBJECT_OWNER})
|| die("Object type:\n$DBI::errstr\n");
my ($object_type) = $qry->fetchrow_array();
$qry->finish();
if ($object_type ne "TABLE")
{
busy(0);
return(1);
}
# Build the popup menu
$qry = $Db->prepare(qq(
$SqlMarker select owner, index_name from all_indexes
where table_name = :1 and table_owner = :2
));
$qry->execute($row->{OBJECT_NAME}, $row->{OBJECT_OWNER})
|| die("Table indexes:\n$DBI::errstr\n");
my $menu = $PlanMain->Menu(-tearoff => 0, -disabledforeground => "#000000");
$menu->command(-label => "Indexes", -state => "disabled");
$menu->separator();
my $count = 0;
while ((my ($index_owner, $index_name) = $qry->fetchrow_array()))
{
$menu->command(-label => "$index_owner.$index_name",
-command => [ \&disp_index, $index_owner, $index_name ]);
$count++;
}
$qry->finish();
busy(0);
$menu->Popup(-popover => "cursor", -popanchor => "nw") if ($count);
return(1);
}
################################################################################
# Produce the query plan for the SQL in $PlanSql and store it in $Plan
sub _explain()
{
# Check there is some SQL
my $stmt = $PlanSql->get("1.0", "end");
$stmt =~ s/;//g;
die("You have not supplied any SQL\n") if ($stmt =~ /^\s*$/);
# Check we are logged on
die("You are not logged on to Oracle\n") if (! $Db);
# Set up the various query strings
# Note that for some reason you can't use bind variables in 'explain plan'
my $prefix = "explain plan set statement_id = '$$' for\n";
my $plan_sql = qq(
$SqlMarker select level, operation, options, object_node, object_owner,
object_name, object_instance, object_type, id, parent_id, position,
other);
if ($OracleVersion ge "7.3")
{ $plan_sql .= qq(, cost, cardinality, bytes, other_tag) };
if ($OracleVersion ge "8")
{ $plan_sql .= qq(, partition_start, partition_stop, partition_id) };
$plan_sql .= qq(
from plan_table
where statement_id = :1
connect by prior id = parent_id and statement_id = :1
start with id = 0 and statement_id = :1
);
# Clean any old stuff from the plan_table
busy(1);
$Db->do(qq($SqlMarker delete from plan_table where statement_id = :1),
undef, $$)
|| die("Delete from plan_table:\n$DBI::errstr\n");
$Db->commit();
# Switch schema if required
if ($Schema ne $User)
{
$Db->do(qq($SqlMarker alter session set current_schema = $Schema))
|| die("Cannot change schema to $Schema:\n$DBI::errstr\n");
}
# Explain the plan - need to save message if failed!
$Plan = { schema => $Schema, sql => $stmt };
my $fail;
$fail = $DBI::errstr if (!$Db->do($prefix . $stmt));
# Switch back schema if required
if ($Schema ne $User)
{
$Db->do(qq($SqlMarker alter session set current_schema = $User))
|| die("Set current schema to $User:\n$DBI::errstr\n");
}
# Now we can safely die if the exmplai plan failed
die("Explain plan:\n$fail\n") if ($fail);
# Read back the plan
my $qry = $Db->prepare($plan_sql)
|| die("Unsupported PLAN_TABLE format:\n$DBI::errstr\n");
$qry->execute($$) || die("Read plan:\n$DBI::errstr\n");
while (my $row = $qry->fetchrow_hashref())
{
if ($row->{ID} == 0)
{
$Plan->{title} = "Query Plan for " . lc($row->{OPERATION});
$Plan->{title} .= ". Cost = $row->{POSITION}" if ($row->{POSITION});
}
else
{
# Line wrap the OTHER field
$row->{OTHER} =~ s/((.{1,80})(\s+|,|$))/$1\n/g if ($row->{OTHER});
# Construct a descriptive string for the query step
my $desc = "$row->{OPERATION}";
$desc .= " $row->{OPTIONS}" if ($row->{OPTIONS});
$desc .= " $row->{OBJECT_TYPE}" if ($row->{OBJECT_TYPE});
$desc .= " of $row->{OBJECT_OWNER}.$row->{OBJECT_NAME}"
if ($row->{OBJECT_OWNER} && $row->{OBJECT_NAME});
$desc .= " using PQS $row->{OBJECT_NODE} $row->{OTHER_TAG}"
if ($row->{OBJECT_NODE});
$row->{desc} = $desc;
# Construct a hierarchical key for the query step
if (! $row->{PARENT_ID})
{
my $key = "$row->{POSITION}";
$row->{key} = $key;
$Plan->{id}[$row->{ID} - 1] = $row;
$Plan->{key}{$key} = $row;
}
else
{
my $parent = $Plan->{id}[$row->{PARENT_ID} - 1];
my $key = "$parent->{key}.$row->{POSITION}";
$row->{key} = $key;
$Plan->{id}[$row->{ID} - 1] = $row;
$Plan->{key}{$key} = $row;
$parent->{child}[$row->{POSITION} - 1] = $row;
}
}
}
# Top of the tree is step 0
$Plan->{tree} = $Plan->{id}[0];
# Clean up
$qry->finish();
$Db->do(qq($SqlMarker delete from plan_table where statement_id = :1),
undef, $$);
$Db->commit();
busy(0);
return(1);
}
################################################################################
# Wrapper for _explain - adds error handling
sub explain
{
clear_plan();
if (! eval { _explain(); }) { error($PlanMain, $@); }
else { disp_plan_tree(); }
}
################################################################################
# Display a login dialog
sub login_dialog($)
{
my ($parent) = @_;
# Create the dialog
if (! $LoginDialog)
{
my $username = "/";
my $password = "";
my $database = $ENV{TWO_TASK} || $ENV{ORACLE_SID};
$LoginDialog = $parent->Toplevel(-title => "Login to Oracle");
$LoginDialog->withdraw();
$LoginDialog->resizable(0, 0);
my $box;
# Create the entry labels & fields
$box = $LoginDialog->Frame(-borderwidth => 1, -relief => "raised");
$box->Label(-text => "Username")
->grid(-column => 0, -row => 0, -sticky => "w");
$box->Entry(-textvariable => \$username, -width => 30)
->grid(-column => 1, -row => 0, -sticky => "w");
$box->Label(-text => "Password")
->grid(-column => 0, -row => 1, -sticky => "w");
$box->Entry(-textvariable => \$password, -width => 30, -show => "*")
->grid(-column => 1, -row => 1, -sticky => "w");
$box->Label(-text => "Database")
->grid(-column => 0, -row => 2, -sticky => "w");
$box->Entry(-textvariable => \$database, -width => 30)
->grid(-column => 1, -row => 2, -sticky => "w");
$box->pack(-expand => 1, -fill => "both", -ipadx => 6, -ipady => 6);
# Create the buttons & callbacks
$box = $LoginDialog->Frame(-borderwidth => 1, -relief => "raised");
my $cb = sub
{
if (! eval { login($database, $username, $password); })
{
error($parent, $@);
$LoginDialog->raise($parent);
}
else
{
update_title();
examples/ora_explain.pl view on Meta::CPAN
$FileDir = $OpenDialog->cget(-directory);
open_file($file);
}
################################################################################
# Display a file save dialog & save the contents of the passed Text widget
sub save_dialog($$)
{
my ($parent, $text) = @_;
# Put up the dialog
require Cwd; import Cwd;
require IO::File;
require Tk::FileSelect;
$FileDir = cwd() if (! $FileDir);
if (! $SaveDialog)
{
$SaveDialog = $parent->FileSelect(-title => "Save File",
-create => 1);
}
$SaveDialog->configure(-directory => $FileDir);
my $file = $SaveDialog->Show();
return if (! $file);
$FileDir = $SaveDialog->cget(-directory);
# Save the Text widget contents to the selected file
my $fh;
if (! ($fh = IO::File->new($file, "w")))
{
error($PlanMain, "Cannot open $file:\n", $!);
return;
}
$fh->print($text->get("1.0", "end"));
$fh->close();
}
################################################################################
# Copy SQL from the grab window into the explain SQL editor
sub copy_sql($$)
{
my ($text, $tag) = @_;
return if (! defined($tag));
clear_editor();
$PlanSql->insert("end", $text->get("$tag.first", "$tag.last"));
$Schema = $text->tag("cget", $tag, -data);
update_title();
$PlanMain->deiconify();
}
################################################################################
# Display info from v$sqlarea for the selected statement in the SQL cache
sub disp_sql_cache_info($$)
{
my ($address, $puid) = @_;
# Empty the widget & prepare the SQL
$GrabDetails->delete("1.0", "end");
busy(1);
my $qry = $Db->prepare(qq(
$SqlMarker select executions, disk_reads, buffer_gets, rows_processed,
sorts, loads, parse_calls, first_load_time
from v\$sqlarea where address = :1
)) || die("Statement info:\n$DBI::errstr\n");
# Read the info. Note that the statement *may* have been purged from the cache!
$qry->execute($address);
if (! (my ($executions, $disk_reads, $buffer_gets, $rows_processed,
$sorts, $loads, $parse_calls, $first_load_time)
= $qry->fetchrow_array()))
{
$GrabDetails->insert("1.0", "This statement is no longer in the SQL cache");
}
else
{
$first_load_time =~ s!/! !;
$GrabDetails->insert("1.0", "First executed by user", "bold",
" $puid ", "",
" at", "bold", " $first_load_time\n");
$GrabDetails->insert("end", "Total ", "bold");
$GrabDetails->insert("end", sprintf("Executions: %8d\n", $executions));
my $fmt =
"Disk reads: %8d Buffer gets: %8d Rows processed: %8d\n"
. "Sorts: %8d Loads: %8d Parse calls: %8d\n";
$GrabDetails->insert("end",
sprintf($fmt, $disk_reads, $buffer_gets, $rows_processed,
$sorts, $loads, $parse_calls));
if ($executions > 0)
{
$GrabDetails->insert("end", "Average per Execution\n", "bold");
$fmt =
"Disk reads: %8.1f Buffer gets: %8.1f "
. "Rows processed: %8.1f\n"
. "Sorts: %8.1f Loads: %8.1f "
. "Parse calls: %8.1f\n";
$GrabDetails->insert("end",
sprintf($fmt, $disk_reads / $executions, $buffer_gets / $executions,
$rows_processed / $executions, $sorts / $executions,
$loads / $executions, $parse_calls / $executions));
}
}
busy(0);
# Display the formatted info
return(1);
}
################################################################################
# Callback for whenever a bit of grabbed SQL is selected
sub grab_select_cb($$)
{
my ($text, $tag) = @_;
$text->tag("configure", $GrabSelection, -background => undef)
if ($GrabSelection);
$text->tag("configure", $tag, -background => "#43ce80");
my $puid = $text->tag("cget", $tag, -data);
$GrabSelection = $tag;
if (! eval { disp_sql_cache_info($tag, $puid); })
{ error($GrabMain, $@); }
}
################################################################################
# Scan v$sqlarea for SQL statements matching the specified conditions.
# $order_by is a v$sqlarea column name used to rank the statements
# $sort_by is "asc" or "desc"
# $user is who first issued the statement (case insensitive)
# $pattern is a perl regexp used to filter the SQL
# $rows is the maximum number of rows to display
sub grab($$$$$$$)
{
my ($ordering, $order_by, $sort_by, $no_sys, $user, $pattern, $rows) = @_;
# Check we are logged on
die("You are not logged on to Oracle\n") if (! $Db);
# Munge args as necessary
$no_sys = $no_sys ? qq{and user_name not in ('SYS', 'SYSTEM')} : qq{};
$rows = -1 if ($rows !~ /^\d+$/);
$user = uc($user);
# Clear the frames
$GrabSql->delete("1.0", "end");
$GrabDetails->delete("1.0", "end");
$GrabStatus->configure(-text => "Please wait...");
# Define the callbacks for highlighting etc
my $highlight = sub
{
my ($text, $tag) = @_;
$text->tag("configure", $tag, -relief => "raised", -borderwidth => 1);
};
my $normal = sub
{
my ($text, $tag) = @_;
$text->tag("configure", $tag, -relief => "flat");
};
# Prepare the queries
busy(1);
my $qry1 = qq{$SqlMarker select address, username from v\$sqlarea, all_users};
$qry1 .= qq{ where sql_text not like '\%$SqlMarker\%'};
$qry1 .= qq{ and sql_text not like '\%insert into \%plan_table\%'};
$qry1 .= qq{ and sql_text not like '\%explain plan\%'};
$qry1 .= qq{ and user_id = parsing_user_id}; # if($user || $no_sys);
$qry1 .= qq{ and username = :1} if ($user);
$qry1 .= qq{ and username not in ('SYS', 'SYSTEM')} if ($no_sys);
if ($ordering eq "total")
{ $qry1 .= qq{ order by $order_by $sort_by}; }
elsif ($ordering eq "average")
{ $qry1 .= qq{ order by $order_by / greatest(executions, 1) $sort_by}; }
$qry1 = $Db->prepare($qry1) || die("SQL Cache capture:\n$DBI::errstr\n");
my $qry2;
if ($OracleVersion ge "7.2")
{
$qry2 = $Db->prepare(qq(
$SqlMarker select sql_text from v\$sqltext_with_newlines
where address = :1 order by piece))
|| die("SQL text:\n$DBI::errstr\n");
}
else{
$qry2 = $Db->prepare(qq(
$SqlMarker select sql_text from v\$sqltext
where address = :1 order by piece))
|| die("SQL text:\n$DBI::errstr\n");
}
# For each SQL query in the shared pool...
if ($user) { $qry1->execute($user) || die("SQL text:\n$DBI::errstr\n"); }
else { $qry1->execute() || die("SQL text:\n$DBI::errstr\n"); }
my $count = 0;
my $first_address;
while ($count != $rows && (my ($address, $puid) = $qry1->fetchrow_array()))
{
# ...glue together the components of the SQL string & print out
$qry2->execute($address) || die("SQL text:\n$DBI::errstr\n");
my ($sql_text) = "";
while (my ($sql) = $qry2->fetchrow_array())
{
$sql_text .= $sql;
}
$qry2->finish();
$sql_text =~ s/^\s+//;
$sql_text =~ s/\n\s*\n/\n/;
$sql_text =~ s/\s+$//s;
# Skip if it doesn't match the supplied pattern
next if ($pattern && eval { $sql_text !~ /$pattern/is; });
# Display the statement and set up the bindings
$GrabSql->insert("end", $sql_text, $address, "\n\n");
$GrabSql->tag("configure", $address, -data => $puid);
$GrabSql->tag("bind", $address, "<Any-Enter>" => [ $highlight, $address ]);
$GrabSql->tag("bind", $address, "<Any-Leave>" => [ $normal, $address ]);
$GrabSql->tag("bind", $address, "<Double-1>" => [ \©_sql, $address]);
$GrabSql->tag("bind", $address, "<1>" => [ \&grab_select_cb, $address ]);
$GrabSql->update();
$count++;
$first_address = $address if (! defined($first_address));
if ($rows > 0)
{ $GrabStatus->configure(-text => "$count of $rows queries grabbed"); }
else
{ $GrabStatus->configure(-text => "$count queries grabbed"); }
}
# Clean up
$qry1->finish();
grab_select_cb($GrabSql, $first_address) if ($first_address);
$GrabStatus->configure(-text => "$count queries grabbed");
busy(0);
return(1);
}
################################################################################
# Create a top-level window for getting SQL from the shared pool cache
sub grab_main
{
# If it already exists, just make it visible)
if ($GrabMain)
{
$GrabMain->deiconify();
$GrabMain->raise($PlanMain);
return;
}
# Otherwise, build the grab window
$GrabMain = $PlanMain->Toplevel(-title => "$ProgName - SQL cache");
$GrabMain->protocol("WM_DELETE_WINDOW", sub { $GrabMain->withdraw(); });
# Defaults & callbacks
my $ordering = "";
my $order_by = "";
my $sort_by = "";
my $no_sys = 1;
my $user = "";
my $pattern = "";
my $rows = 100;
my $grab_cb = sub
{
if (! eval { grab($ordering, $order_by, $sort_by, $no_sys,
$user, $pattern, $rows); })
{ error($GrabMain, $@); }
};
my (%ord_bn, %sort_bn); # For "order by" and "sort order" buttons
my $ord_bn_cb = sub
{
if ($ordering eq "")
{
$order_by = "";
$sort_by = "";
foreach my $bn (values(%ord_bn))
{ $bn->configure(-state => "disabled"); }
foreach my $bn (values(%sort_bn))
{ $bn->configure(-state => "disabled"); }
}
elsif ($ordering eq "total")
{
$order_by = "disk_reads" if ($order_by eq "");
$sort_by = "desc" if ($sort_by eq "");
foreach my $bn (values(%ord_bn))
{ $bn->configure(-state => "normal"); }
foreach my $bn (values(%sort_bn))
{ $bn->configure(-state => "normal"); }
}
else # $ordering eq "average"
{
$order_by = "disk_reads"
if ($order_by eq "" || $order_by eq "executions");
$sort_by = "desc" if ($sort_by eq "");
( run in 0.501 second using v1.01-cache-2.11-cpan-39bf76dae61 )