Oracle::Debug - A Perl (perldb-like) interface to the Oracle DBMS_DEBUG package for debugging PL/SQL programs.

	./oradb

# $Id: Debug.pm,v 1.46 2003/07/30 15:25:11 oradb Exp $

package Oracle::Debug;

use 5.008;
use strict;
use warnings;
use Carp qw(carp croak);
use Data::Dumper;
use DBI;
use Term::ReadKey;

use vars qw($VERSION);
$VERSION = do { my @r = (q$Revision: 1.46 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

my $DEBUG = $ENV{Oracle_Debug} || 0;

sub new {
	my $proto = shift;
	my $class = ref($proto) ? ref($proto) : $proto;
	my $self  = bless({
		'_config'		=> do 'scripts/config', # $h_conf,
		'_connect'	=> {
			'debugpid'	=> '',
			'primed'    => 0,
			'sessionid'	=> '',
			'targetid'	=> '',
			'connected' => 0,
			'synched'   => 0,
			'syncs'   	=> 7,
		},
		'_dbh'			=> {},
		'_unit'			=> {
			'owner'			=> '',
			'type'			=> '',
			'name'			=> '',
			'namespace'	=> '',
		},
	}, $class);
	$self->_prime;
	# $self->log($self.' '.Dumper($self)) if $DEBUG;
	return $self; 
}

sub _prime {
	my $self  = shift;
	my $h_ref = $self->{_config};
	unless (ref($h_ref) eq 'HASH') {
		$self->fatal("invalid db priming data hash ref: ".Dumper($h_ref));
	} else {
		# $self->{_dbh} = $self->dbh;
		$self->{_dbh}->{$$} = $self->_connect($h_ref);
		$self->{_connect}{primed}++ if $self->{_dbh}->{$$};
		$self->dbh->func(20000, 'dbms_output_enable');
		$self->self_check();
	}
	return ref($self->{_dbh}->{$$}) ? $self : undef;
}

# =============================================================================
# dbh and sql methods
# =============================================================================

sub dbh {
	my $self = shift;
	# my $type = $self->{_config}->{type}; # debug-target
	return ref($self->{_dbh}->{$$}) ? $self->{_dbh}->{$$} : $self->_connect($self->{_config});
}

sub _connect {
	my $self   = shift;
	my $h_conf = $self->{_config};

	my $dbh = DBI->connect(
		$h_conf->{datasrc},	$h_conf->{user}, $h_conf->{pass}, $h_conf->{params} 
	) || $self->fatal("Can't connect to database: $DBI::errstr");

	$self->{_connect}{connected}++;
	$self->log("connected: $dbh") if $DEBUG;

	return $dbh; #$id eq 'Debug' ? $dbh : 1;
}

sub getarow {
	my $self  = shift;
	my $sql   = shift;
	my @res;

	eval { @res = $self->dbh->selectrow_array($sql) };
#	my @res = $self->dbh->selectrow_array($sql) || $self->error("failed <$sql>");
	
	if ($DEBUG) {
		$self->log("failed to getarow: $sql $DBI::errstr") unless @res >= 1;
	}

	return @res;
}

sub getahash {
	my $self  = shift;
	my $sql   = shift;
	my @res;

	eval { @res = $self->dbh->selectrow_hash($sql) };
#	my @res = $self->dbh->selectrow_array($sql) || $self->error("failed <$sql>");
	
	if ($DEBUG) {
		$self->log("failed to getahash: $sql $DBI::errstr") unless @res >= 1;
	}

	return @res;
}


# =============================================================================
# parse and control
# =============================================================================

my %HISTORY = ();
my %TYPES   = (
	'CU' => 'CURSOR',
	'FU' => 'FUNCTION',
	'PA' => 'PACKAGE',
	'PR' => 'PROCEDURE',
	'TR' => 'TRIGGER',
	'TY' => 'TYPE',
);
my %NAMESPACES = (
	'BO' => 'Namespace_pkg_body', 
	'CU' => 'Namespace_cursor',
	'FU' => 'Namespace_pkgspec_or_toplevel', 
	'PA' => 'Namespace_pkgspec_or_toplevel', 
	'PK' => 'Namespace_pkgspec_or_toplevel', 
	'PR' => 'Namespace_pkgspec_or_toplevel', 
	'SP' => 'Namespace_pkgspec_or_toplevel', 
	'TR' => 'Namespace_trigger',
);
my %GROUPS  = (
	+0	=> [qw()],
	+1	=> [qw(b c n r s)],
	+3	=> [qw(l L v T)],
	+5	=> [qw(h H ! q)],
	+6	=> [qw(context err perl rc sync sql shell info)],
	+8	=> [qw(abort ping check test is_running)],
);
my $COMMANDS= join('|', @{$GROUPS{1}}, @{$GROUPS{3}}, @{$GROUPS{5}}, @{$GROUPS{6}}, @{$GROUPS{8}});
my %COMMAND = (
	'abort'		=> {
		'long'		=> 'abortexecution',
		'handle'	=> 'abort',
		'syntax'	=> 'abort[execution]',
		'simple'	=> 'abort target', 
		'detail'	=> 'abort currently running program in target session',
	},
	'b'		=> {
		'long'		=> 'setbreakpoint',
		'handle'	=> 'break',
		'syntax'	=> 'b [lineno] || setbreakpoint [lineno]',
		'simple'	=> 'set breakpoint', 
		'detail'	=> 'set breakpoint on given line of code identified by unit name',
	},
	'c'	  => {
		'long'		=> 'continue',
		'handle'	=> 'continue',
		'syntax'	=> 'c',
		'simple'	=> 'continue',
		'detail'	=> 'continue to breakpoint or other reason to stop',
	},
	'check'=> {
		'long'		=> 'selfcheck',
		'handle'	=> 'self_check',
		'syntax'	=> 'check || selfcheck',
		'simple'	=> 'run a self_check',
		'detail'	=> 'run a self_check against dbms_debug and probe communications',
	},
	'context'	  => {
		'long'		=> 'context',
		'handle'	=> 'runtime', # context
		'syntax'	=> 'context key[=val] [key[=val]]+',
		'simple'	=> 'get/set context',
		'detail'	=> 'get/set context for this instance: unit name, type, namespace etc.',
	},
	'err'	  => {
		'long'		=> 'errorstring',
		'handle'	=> 'plsql_errstr',
		'syntax'	=> 'err',
		'simple'	=> 'print plsql_errstr',
		'detail'	=> 'display the DBI->plsql_errstr (if set)',
	},
	'info'	  => {
		'long'		=> 'information',
		'handle'	=> 'info',
		'syntax'	=> 'info',
		'simple'	=> 'info on current environment',
		'detail'	=> 'display information on current programs and db(NYI)',
	},
	'help'	  => {
		'long'		=> 'help',
		'handle'	=> 'help',
		'syntax'	=> 'h [cmd|h|syntax]',
		'simple'	=> 'help listing - h h for more',
		'detail'	=> 'you can also give a command as an argument (eg: h b)',
	},
	'H'	  => {
		'long'		=> 'historylist',
		'handle'	=> 'history',
		'syntax'	=> 'H',
		'simple'	=> 'command history',
		'detail'	=> 'history listing not including single character commands',
	},
	'l'	  => {
		'long'		=> 'listsourcecode',
		'handle'	=> 'list_source',
		'syntax'	=> 'l unitname [PROC|PACK|TRIG|...]',
		'simple'	=> 'list source code',
		'detail'	=> 'list source code given with library type',
	},
	'L'	  => {
		'long'		=> 'listbreakpoints',
		'handle'	=> 'list_breakpoints',
		'syntax'	=> 'L',
		'simple'	=> 'list breakpoints',
		'detail'	=> 'on which line breakpoints exist',
	},
	'n'	  => {
		'long'		=> 'next',
		'handle'	=> 'next',
		'syntax'	=> 'n',
		'simple'	=> 'next line',
		'detail'	=> 'continue until the next line',
	},
	'perl'=> {
		'long'		=> 'perlcommand',
		'handle'	=> 'perl',
		'syntax'	=> 'perl <valid perl command>',
		'simple'	=> 'perl command',
		'detail'	=> 'execute a perl command',
	},
	'q'   => {
		'long'		=> 'quit',
		'handle'	=> 'quit',
		'syntax'	=> 'q(uit)',
		'simple'	=> 'exit',
		'detail'	=> 'quit the oradb',
	},
	'r'	  => {
		'long'		=> 'return',
		'handle'	=> 'return',
		'syntax'	=> 'r',
		'simple'	=> 'return',
		'detail'	=> 'return from the current block',
	},
	'rc'  => {
		'long'		=> 'recompilecode',
		'handle'	=> 'recompile',
		'syntax'	=> 'rc unitname',
		'simple'	=> 'recompile',
		'detail'	=> 'recompile the program/s given ',
	},
	's'	  => {
		'long'		=> 'stepintosubroutine',
		'handle'	=> 'step',
		'syntax'	=> 's',
		'simple'	=> 'step into',
		'detail'	=> 'step into the next function or method call',
	},
	'shell'	=> {
		'long'		=> 'shellcommand',
		'handle'	=> 'shell',
		'syntax'	=> 'shell <valid shell command>',
		'simple'	=> 'shell command',
		'detail'	=> 'execute a shell command',
	},
	'sql' => {
		'long'		=> 'sqlcommand',
		'handle'	=> 'sql',
		'syntax'	=> 'sql <valid SQL>',
		'simple'	=> 'SQL select',
		'detail'	=> 'execute a SQL SELECT statement',
	},
	'sync'	  => {
		'long'		=> 'synchronize',
		'handle'	=> 'sync',
		'syntax'	=> 'sync',
		'simple'	=> 'sync',
		'detail'	=> 'syncronize the sessions - '.
                 '(note that this session _should_ hang until the procedure is executed in the target session)'
	},
	'test'=> {
		'long'		=> 'testconnection',
		'handle'	=> 'test',
		'syntax'	=> 'test',
		'simple'	=> 'ping and check and if target is running',
		'detail'	=> 'ping, run a self_check and test whether target session is currently running and responding',
	},
	'is_running'=> {
		'long'		=> 'isrunning',
		'handle'	=> 'is_running',
		'syntax'	=> 'is_running',
		'simple'	=> 'check target is_running',
		'detail'	=> 'check whether target session is currently running and responding',
	},
	'ping'=> {
		'long'		=> 'pingthedatabase',
		'handle'	=> 'ping',
		'syntax'	=> 'ping',
		'simple'	=> 'ping target',
		'detail'	=> 'ping target session',
	},
	'T'=> {
		'long'		=> 'backtrace',
		'handle'	=> 'backtrace',
		'syntax'	=> 'T',
		'simple'	=> 'display backtrace',
		'detail'	=> 'backtrace listings',
	},
	'v'	  => {
		'long'		=> 'variablevalue',
		'handle'	=> 'value',
		'syntax'	=> 'v varname[=value]',
		'simple'	=> 'get/set variable',
		'detail'	=> 'get or set the value of a variable, (use double quotes to contain spaces)',
	},
	'!'   => {
		'long'		=> 'runhistorycommand',
		'handle'	=> 'rerun',
		'syntax'	=> '! (!|historyno)',
		'simple'	=> 'run history command',
		'detail'	=> 'run a command from the history list',
	},
	'x'   => {
		'long'		=> 'execute',
		'handle'	=> 'execute',
		'syntax'	=> 'x sql',
		'simple'	=> 'execute sql command',
		'detail'	=> 'execute a sql command in the target session',
	},
);

sub help {
	my $self = shift;
	my $levl = shift || '';

	my $help = '';
	if (grep(/^$levl$/, keys %COMMAND)) {
			$help .= "\tsyntax: $COMMAND{$levl}{syntax}\n\t$COMMAND{$levl}{detail}\n";
	} else {
		$levl = 'simple' unless $levl =~ /^(simple|detail|syntax|handle)$/io;
		my (@help, @left, @right) = ();
		foreach my $grp (sort { $a <=> $b } keys %GROUPS) {
			foreach my $char (@{$GROUPS{$grp}}) {
				# $help .= "\t".($levl ne 'syntax' ? "$char\t" : '')."$COMMAND{$char}{$levl}\n";
				my $myhelp = '    '.($levl ne 'syntax' ? sprintf('%-10s', $char) : '').($COMMAND{$char}{$levl}||'');
				if ($grp =~ /^[13579]$/) {
					push(@left, $myhelp);
				} else {
					push(@right, $myhelp);
				}
			}
		}
		$#left = $#right if $#left < $#right;
		$help = "oradb help:\n\n";
		while (@left) {
			no warnings; # empty right values
			local $^W=0;
			$help .= sprintf('%-45s', shift(@left) || '').shift(@right)."\n";
		}
		$help .= "\n";
	}

	return $help;
}

sub preparse {
	my $self = shift;
	my $cmd  = shift;
	my $comm = '';

	my @comms = sort keys %COMMAND;
	print "preparsing cmd($cmd) against comms(@comms)\n";

	my $i_cnt = my ($found) = grep(/^$cmd/, @comms);
	if ($i_cnt == 1) {
		$comm = $found;
		print "found($found) comm($comm)\n";
	} else {
		my @longs = sort map { $COMMAND{$_}{long} } keys %COMMAND;
		print "preparsing cmd($cmd) against longs(@longs)\n";
		my $i_cnt = my ($found) = grep(/^$cmd/, @longs);
		if ($i_cnt == 1) {
			$comm = $found;
			print "long($found) comm($comm)\n";
		}
	}
	print "returning comm($comm)\n";
	@comms = ();
	
	return $comm;
}

sub parse {
	my $self = shift;
	my $cmd  = shift;
	my $input= shift;

	$DB::single=2;
	my $xcmd = $self->preparse($cmd);
	unless (defined($COMMAND{$cmd}{handle})) {
	unless ($self->can($COMMAND{$cmd}{handle})) {
		$self->error("command '$cmd' not understood");
		print $self->help;
	} else {
		my $handler = $COMMAND{$cmd}{handle} || 'help';
		$self->log("cmd($cmd) input($input) handler($handler)") if $DEBUG;
		$DB::single=2;
		my @res = $self->$handler($input);
		$self->log("handler($handler) returned(@res)") if $DEBUG;
		print @res;
	}
	}
}

# =============================================================================
# run and exec methods
# =============================================================================

sub do {
	my $self = shift;
	my $exec = shift;
	my $i_res;

	$self->log("*** incoming pl/sql: self($self) $exec args(@_)") if $DEBUG;
	my $csr  = $self->dbh->prepare($exec);
	unless ($csr) {
		$self->error("Failed to prepare $exec - $DBI::errstr\n") unless $csr;
	} else {
		eval {
			($i_res) = $csr->execute; # returning 0E0 is true/ok/good
		};

		if ($@) {
			$self->error("Failure: $@ while evaling $exec - $DBI::errstr\n");
		}

		unless ($i_res) {
			$self->error("Failed to execute $exec - $DBI::errstr\n");
		}
	}

	$self->log("do($exec)->res($i_res)") if $DEBUG;
	
	return $self;
}

sub recompile {
	my $self = shift;
	my $args = shift;
	my @res  = ();

	my @names = split(/\s+/, $args);
	foreach my $name (@names) {
		my %data = $self->unitdata('name'=>$name);
		if ($data{name} && $data{type}) {
				$data{type} =~ s/BODY//;
				my $exec = qq|ALTER $data{type} $data{name} COMPILE Debug|; $exec .= ' BODY' if $data{type} =~ /^PACKAGE|TYPE$/o;
				my @msg = $self->do($exec)->get_msg;
				print (@msg >= 1 ? "$data{name} recompiled\n" : "$data{name} failed recompilation!\n");
				push(@res, @msg);
		}
	}

	return @res;
}

sub xsynchronize {
	my $self = shift;
	my $args = shift;
	my @res  = ();

	print "Synching - once this hangs, execute the code in the target session\n"; 
	print "\t(if this does not hang, (it SHOULD), check the connection (with 'test'), and retry)\n";
	@res = $self->sync;
	$self->{_connect}{synched}++;
	# print "Synched (if we hung - above - setting some breakpoints might be an idea...\n";

	return @res;
}

sub unitdata {
	my $self = shift;
	my %args = (
		'name'	=> '',
		'type'	=> '',
		'owner'	=> '',
	@_);
	map { $args{$_} = '' unless $args{$_} } keys %args;
	my %res  = ();

	unless ($args{name} =~ /^\w+$/o) { # rjsf
		$self->error("unit name($args{name}) is required");
	} else {
		my $sql = qq#SELECT DISTINCT(name || ':' || type || ':' || owner) FROM all_source 
																		WHERE UPPER(name) = UPPER('$args{name}')#;
		$sql .= qq# AND UPPER(type) LIKE UPPER('$args{type}%')# if $args{type};
		my ($data) = my @data = $self->getarow($sql);
		my $input = join(', ', map { $_.'='.$args{$_} } sort keys %args);
		unless (scalar(@data) == 1) {
			$self->error("invalid or unambiguated data found via input($input)");
		} else {
			my ($name, $type, $owner) = split(':', $data);
			unless ($name =~ /^\w+$/o) {
				$self->error("invalid data($data) found via input($input)");
			} else {
				%res = (
					'name'	=> $name, 
					'type'	=> $type,
					'owner'	=> $owner,
				);
				map { $self->{_unit}{lc($_)} = $res{$_} } keys %res;
			} 
		} 
	}

	return %res;
}

sub perl {
		my $self = shift;
		my $perl = shift;
		
		eval $perl;
		if ($@) {
			$self->error("failed perl expression($perl) - $@");
		}
		return "\n";
}

sub shell {
		my $self  = shift;
		my $shell = shift;
		
		system($shell);
		if ($@) {
			$self->error("failed shell command($shell) - $@");
		}
		return "\n";
}

sub sql {
		my $self = shift;
		my $xsql = shift;
		my @res  = ();

		unless ($xsql =~ /^\s*\w+\s+/io) {
			$self->error("SQL statements only please: <$xsql>");
		} else {
			$xsql =~ s/\s*;\s*$//;
			@res = ($self->getarow($xsql), "\n");
		}

		return @res;
}

sub _run { # INTERNAL
      my $self = shift;
      my $xsql = shift;

      my $exec = qq#
                            BEGIN
                                            $xsql;
                            END;
            #;

      return $self->do($exec)->get_msg;
}


# =============================================================================
# start debug and target methods
# =============================================================================

sub target {
	my $self = shift;

	my $dbid = $self->start_target('rfi_oradb_sessionid');
	if ($dbid) {
		ReadMode 0;
		print "orasql> enter a PL/SQL command to debug (debugger session must be running...)\n";
		while (1) {
			print "orasql>";
			chomp(my $input = ReadLine(0));
			$self->log("processing input($input)") if $DEBUG;
			if ($input =~ /^\s*(q\s*|quit\s*)$/io) {
				$self->quit;
			} elsif ($input =~ /^\s*(h\s*|help\s*)$/io) {
				print qq|No help menus for target session - simply enter code to debug (which will un-hang the debug session...)\n|;
				$self->help;
			} else {
				$self->_run($input); 
			}
		}
	}

	return $self;
}

sub start_target {
	my $self = shift;
	my $dbid = shift;

	if ($self->{_connect}{debugid}) {
		$self->fatal("debug process may not run as a target instance");
	}

	$self->{_connect}{targetpid} = $dbid;
	my $x_res = $self->do('DELETE FROM '.$self->{_config}{table}); # currently we only allow a single session at a time

	my $init = qq#
				DECLARE 
						xret VARCHAR2(32); 
				BEGIN 
						xret := dbms_debug.initialize('$dbid'); 
						-- dbms_debug.debug_on(TRUE, FALSE); -- wait
						dbms_debug.debug_on(TRUE, TRUE); -- immediate
				END;
		#;
	$x_res = $self->do($init);

	$self->log("target started: $dbid") if $DEBUG;

	return $dbid;
}

sub debugger {
	my $self = shift;

	my $dbid = $self->start_debug('rfi_oradb_sessionid');
	
	ReadMode 0;
	print "Welcome to the oradb (type h for help)\n";
	my $i_cnt = 0;
	while (1) {
		print "oradb> ";
		chomp(my $input = ReadLine(0)); 
		$self->log("processing command($input)") if $DEBUG;
		$input .= ' ';
		#if ($input =~ /^\s*($COMMANDS)\s+(.*)\s*$/o) {
		if ($input =~ /^\s*(\w+)\s+(.*)\s*$/o) {
			my ($cmd, $args) = ($1, $2); 
			$cmd =~ s/\s+$//; $args =~ s/^\s+//; $args =~ s/\s+$//;
			$self->log("input($input) -> cmd($cmd) args($args)") if $DEBUG;
			my $res = $cmd.' '.$args;
			$HISTORY{++$i_cnt} = $res unless $input =~ /^\s*(.|!.*)\s*$/o || grep(/^$res$/, map { $HISTORY{$_} } keys %HISTORY);
			$self->parse($cmd, $args); # + process
		} else {
			$self->error("oradb> command ($input) not understood");	
		}
	}

	return $self; 
}

sub start_debug {
	my $self = shift;
	my $dbid = shift;
	my $pid  = shift;

	# my $x_res = $self->do('UPDATE '.$self->{_config}{table}." SET debugpid = $pid");
	if ($self->{_connect}{targetid}) {
		$self->fatal("target process may not run as a debug instance");
	}
	$self->{_connect}{debugpid} = $dbid;

	# SET serveroutput ON;                  -- done via dbi
	my $x_res = $self->do(qq#ALTER session SET plsql_debug=TRUE#)->get_msg;
	# ALTER session SET plsql_debug = TRUE; -- done per proc.

	my $exec = qq#
				BEGIN 
						dbms_debug.attach_session('$dbid'); 
						dbms_output.put_line('attached');
				END;
		#;

	return $self->do($exec)->get_msg;
}

sub sync {
	my $self = shift;
	my @res  = ();

	print "Synching - once this hangs, execute the code in the target session\n"; 
	print "\t(if this does not hang, (it SHOULD), check the connection (with 'test'), and retry)\n";
	
	my $exec = qq#
				DECLARE	
						xec     binary_integer;
						runtime dbms_debug.runtime_info;
				BEGIN	
						xec := dbms_debug.synchronize(runtime);
						IF xec = dbms_debug.success THEN
								NULL;
								dbms_output.put_line('...synched ' || runtime.program.name);
						ELSE
								dbms_output.put_line('Error: ' || oradb.errorcode(xec));
						END IF;
				END;
		#;

	my $test  = '';
	my $i_cnt = 0;
	while (1) {
		$i_cnt++;
		@res = $self->do($exec)->get_msg;
		chomp($test = $self->is_running);
		print ".";
		last if ($i_cnt >= $self->{_connect}{syncs} || $test eq 'target is currently running');
		sleep 1;
	}
	$self->{_connect}{synched}++;
	print "\n$test\n";

	return @res;
}

# ============================================================================= 
# b c n s r exec
# =============================================================================

sub execute {
	my $self = shift;
	my $xsql = shift;

	$xsql =~ s/[\s\;]*$//;

	my $exec = qq#
				DECLARE 
						col1 sys.dbms_debug_vc2coll;
						errm VARCHAR2(100);
				BEGIN 
						dbms_debug.execute('BEGIN $xsql; END;', 
								-1, 0, col1, errm); 
						IF (errm IS NOT NULL) THEN
								DBMS_OUTPUT.put_line('Error($xsql): ' || errm);
						END IF;
				END;
		#;

	return $self->do($exec)->get_msg;
}

sub break {
	my $self = shift;
	my $args = shift;
	my @res  = ();

	my ($line, $name) = split(/\s+/, $args);
	# unless ($line =~ /^(\d+|\*)$/o) { <- fuzzy
	unless ($line =~ /^(\d+)$/o) {
		$self->error("must supply a valid line number($line) to set a breakpoint via($args)");
	} else {
	  my $name = $name || $self->{_unit}{name} || '';
		unless ($name =~ /^(\w+)$/o) { 
			$self->error("library unit($name) must be given");
		} else {
			my $exec = qq|
								BEGIN 
										oradb.b('$name', $line); 
								END;
						|;
			@res = $self->do($exec)->get_msg;
		}
	}

	return @res;
}

sub continue {
	my $self = shift;

	my $exec = qq#
				BEGIN 
    	    	oradb.continue_(dbms_debug.break_any_call);
				END;
		#;

	return $self->do($exec)->get_msg;
}

sub next {
	my $self = shift;

	my $exec = qq#
				BEGIN 
    	    	oradb.continue_(dbms_debug.break_next_line);
				END;
		#;

	return $self->do($exec)->get_msg;
}

sub step {
	my $self = shift;

	my $exec = qq#
				BEGIN 
    	    	oradb.continue_(dbms_debug.break_any_call);
				END;
		#;

	return $self->do($exec)->get_msg;
}

sub return {
	my $self = shift;

	my $exec = qq#
				BEGIN 
    	    	oradb.continue_(dbms_debug.break_return);
				END;
		#;

	return $self->do($exec)->get_msg;
}

# =============================================================================
# runtime_info and source listing methods
# =============================================================================

sub runtime {
	my $self = shift;
	my $sep = '-' x 80;
	my @msg = ();

	unless ($self->{_connect}{synched}) {
		$self->error('not running yet');
	} else {

	my $exec = qq/
				DECLARE 
						runinfo dbms_debug.runtime_info; 
						xinf BINARY_INTEGER DEFAULT dbms_debug.info_getBreakpoint + dbms_debug.info_getLineinfo + dbms_debug.info_getOerInfo;
						xec  BINARY_INTEGER;
				BEGIN 
						xec := dbms_debug.get_runtime_info(xinf, runinfo);
						IF xec = 0 THEN
								dbms_output.put_line('Runtime Info:');
								dbms_output.put_line('  Name:          ' || runinfo.program.name);
								dbms_output.put_line('  Line:          ' || runinfo.line#);
								dbms_output.put_line('  Owner:         ' || runinfo.program.owner);
								dbms_output.put_line('  Unit:          ' || oradb.libunittype(runinfo.program.libunittype));
								dbms_output.put_line('  Namespace:     ' || oradb.namespace(runinfo.program.namespace));
						ELSE
								dbms_output.put_line('   Error: ' || oradb.errorcode(xec));
						END IF;
				END;
		/;

		@msg = $self->do($exec)->get_msg;
	}

	return @msg >= 1 ? "\n".join("\n", $sep, @msg, $sep)."\n" : '...';
}

   

sub backtrace {
	my $self = shift;

	my $exec = qq#
				DECLARE 
						tracing VARCHAR2(2000);
				BEGIN 
						dbms_debug.print_backtrace(tracing); 
						dbms_output.put_line(tracing);
				END;
		#;

	my @msg = $self->do($exec)->get_msg;

	return @msg;
}

sub list_source {
	my $self = shift;
	my $args = shift;
	my @res  = ();

	my ($name, $type) = split(/\s+/, $args); 
	my %data = $self->unitdata('name'=>$name, 'type'=>$type);

	if ($data{name} && $data{type}) {
		my $exec = qq#
						DECLARE
								xsrc VARCHAR2(4000);
								CURSOR src IS
										SELECT line, text FROM all_source WHERE name = '$data{name}' 
					   					   AND type LIKE '$data{type}%' AND type != 'PACKAGE' ORDER BY name, line;
						BEGIN
								FOR rec IN src LOOP
										xsrc := rec.line || ': ' || rec.text;
										dbms_output.put_line(SUBSTR(xsrc, 1, LENGTH(xsrc) -1));
								END LOOP;
						END;
				#;
		@res = $self->do($exec)->get_msg;
		my $res = join('', @res);
		unless ($res =~ /\w+/o) {
			$self->error("no source($res) found with unit($data{name}) type($data{type})");
		}
	} 

	return @res;
}

sub list_breakpoints {
	my $self = shift;

	my $exec = qq/
				DECLARE
    	    	brkpts dbms_debug.breakpoint_table;
    	    	i      number;
  	  	BEGIN	
						dbms_debug.show_breakpoints(brkpts); 
						i := brkpts.first();
						dbms_output.put_line('breakpoints: ');
						while i is not null loop
								dbms_output.put_line('  ' || i || ': ' || brkpts(i).name || ' (' || brkpts(i).line# ||')');
								i := brkpts.next(i);
						end loop;
				END;
		/;

	return $self->do($exec)->get_msg;
}

sub history {
	my $self = shift;

	my @hist = map { "$_: $HISTORY{$_}\n" } sort { $a <=> $b } grep(!/\!/, keys %HISTORY);

	return @hist;
}

sub rerun {
	my $self = shift;
	my $hist = shift || 0;

	if ($hist =~ /!/o) {
		($hist) = reverse sort { $a <=> $b } keys %HISTORY;
	}
	unless ($HISTORY{$hist} =~ /^(\S+)\s(.*)$/o) {
		$self->error("invalid history key($hist) - try using 'H'");
	} else {
		my ($cmd, $args) = ($1, $2);
		$self->parse($cmd, $args); # + process
	}

	return ();
}

# =============================================================================
# check and ping methods
# =============================================================================

sub info {
	my $self = shift;

	my $src = $self->{_config}{datasrc} || '';
	$src =~ s/^\w+:\w+://;
	my @src = split(';', $src);
	my %src = map { split('=', $_) } @src;
	my ($probe, $version) = split(/:\s+/, $self->probe_version);
	chomp($version);

	my %data = (
		'host'			=> $src{host},
		'instance'	=> uc($src{sid}),
		'oradb'			=> $Oracle::Debug::VERSION,
		'port'			=> $src{port},
		'user'			=> $self->{_config}{user},
		$probe			=> $version,
	);
	my ($i_max) = sort { $b <=> $a } map { length($_) } keys %data;

	my @res = ("\n", (map { $_.(' 'x($i_max-length($_))).' = '.$data{$_}."\n" } sort keys %data), "\n");

	return @res;
}

sub context {
	my $self = shift;
	my $args = shift || '';
	my @args = my %args = ();
	my @res  = ();

	my ($i_max) = sort { $b <=> $a } map { length($_) } keys %{$self->{_unit}};

	if (%args = ($args =~ /\G\s*(\w+)\s*=\s*(\w+)/go)) { # set
		foreach (sort sort keys %args) {
			my $call = "_$_";
			push(@res, $_.(' 'x($i_max-length($_))).' = '.$self->$call($args{$_})."\n") if $self->can($call);
		}
	} elsif (@args = ($args =~ /\G\s*(\w+)\s*/go)) {     # get
		foreach (sort @args) {
			my $call = "_$_";
			push(@res, $_.(' 'x($i_max-length($_))).' = '.$self->$call()."\n") if $self->can($call);
		}
	} else {                                             # all
		@res = map { $_.(' 'x($i_max-length($_))).' = '.$self->{_unit}{$_}."\n" } sort keys %{$self->{_unit}};
	}

	return @res;
}

sub probe_version {
	my $self = shift;

	my $exec = qq#
				DECLARE 
						i_maj BINARY_INTEGER; 
						i_min BINARY_INTEGER; 
				BEGIN 
						dbms_debug.probe_version(i_maj, i_min); 
						dbms_output.put_line('probe version: ' || i_maj || '.' || i_min); 
				END;
				#;

	return $self->do($exec)->get_msg;
}

sub test {
	my $self = shift;
	my @res  = ();

	push(@res, $self->self_check, $self->ping, $self->is_running);
	
	return @res;
}

sub self_check {
	my $self = shift;

	my $exec = qq#
				BEGIN 
						dbms_debug.self_check(10);
						dbms_output.put_line('checked');
				END;
				#;

	return $self->do($exec)->get_msg;
}

sub ping {
	my $self = shift;

	my $exec = qq#
				BEGIN 
						dbms_debug.ping();
						dbms_output.put_line('pinged');
				END;
				#;

	return $self->do($exec)->get_msg;
}

sub is_running {
	my $self = shift;

	my $exec = qq#
				BEGIN 
						IF dbms_debug.target_program_running THEN
								dbms_output.put_line('target is currently running');
						ELSE 
								dbms_output.put_line('target is not currently running');
						END IF;
				END;
				#;

	return $self->do($exec)->get_msg;
}

# =============================================================================
# get and put msg methods
# =============================================================================

sub plsql_errstr {
	my $self  = shift;

	return $self->dbh->func('plsql_errstr');
}

sub put_msg {
	my $self  = shift;

	return $self->dbh->func(@_, 'dbms_output_put');
}

sub get_msg {
	my $self  = shift;

	my @msg = (); {
		no warnings;
		@msg = grep(/./, $self->dbh->func('dbms_output_get'));
	}

	return (@msg >= 1 ? join("\n", @msg)."\n" : "\n"); 
}

sub value {
	my $self = shift;
	my $args = shift || '';
	my @res  = ();

	my ($var, $getset) = ('', '', '');

	if ($args =~ /^\s*(\w[\.\w]*)\s*:{0,1}=\s*(\S.+)?\s*$/o) {	# set
		$var = "$1 := $2;";
		$getset = '_set_val';
	} elsif ($args =~ /^\s*(\w[\.\w]*)\s*$/) {        					# get
		$var = $1;
		$getset = '_get_val';
	} else {																							# err
		$self->error("unable to get or set variable - incorrect syntax: v $args");
	}

	if ($getset) {
		@res = $self->$getset($var);
	}

	return @res;
}

sub _get_val {
	my $self = shift;
	my $xvar = shift;

	my $exec = qq#
				DECLARE
						program dbms_debug.program_info;
						runinfo dbms_debug.runtime_info; 
						xinf BINARY_INTEGER DEFAULT dbms_debug.info_getBreakpoint + dbms_debug.info_getLineinfo + dbms_debug.info_getOerInfo;
						xec  BINARY_INTEGER;
						buff   VARCHAR2(500);
				BEGIN
						xec := dbms_debug.get_runtime_info(xinf, runinfo);
						IF runinfo.program.namespace = 2 THEN 
								/*
										program := runinfo.program;
	 					 				program.namespace  := dbms_debug.namespace_pkgspec_or_toplevel; -- as per docs...
										program.Owner      := runinfo.program.owner;
										program.Name       := runinfo.program.name;
										xec := dbms_debug.get_value('$xvar', program, buff, NULL);
								*/
								xec := dbms_debug.get_value('$xvar', 0, buff, NULL);
						ELSE
								xec := dbms_debug.get_value('$xvar', 0, buff, NULL);
						END IF; 
						IF xec = dbms_debug.success THEN
								dbms_output.put_line('$xvar = ' || buff);
						ELSE
								dbms_output.put_line('Error: ' || oradb.errorcode(xec));
						END IF;
				END;
		#;

	my @res = $self->do($exec)->get_msg;

	return @res;
}

sub _set_val {
	my $self = shift;
	my $xset = shift;

	# $self->error("unimplemented");

	my $exec = qq#
				DECLARE
						xec BINARY_INTEGER;
				BEGIN
						xec := dbms_debug.set_value(0, '$xset');

						IF xec = dbms_debug.success THEN
								dbms_output.put_line('$xset succeeded');
						ELSE
								dbms_output.put_line('Error: ' || oradb.errorcode(xec));
						END IF;
				END;
		#;
	
	my @res = $self->do($exec)->get_msg;

	return @res;
}

sub audit {
	my $self  = shift;

	my $sql   = qq#
				SELECT audsid || '-' || sid || '-' || osuser || '-' || username FROM v\$session WHERE audsid = userenv('SESSIONID')
		#;

	my ($res) = $self->dbh->selectrow_array($sql);

	$self->error("failed to audit: $sql $DBI::errstr") unless $res;

	return $res." $$";
}

# =============================================================================
# get and put context methods
# =============================================================================

sub _check {
	my $self = shift;
	my $targ = lc(shift);
	my $i_ok = 0;
	
	unless ($targ =~ /^\w+$/o) {
		$self->error("require a valid plsql target($targ) to check: ".join(', ', sort keys %{$self->{_unit}}));
	} else {
		$i_ok++ if $self->{_unit}{$targ} =~ /./o;
	}

	return $i_ok;
}

sub _unit {
	my $self = shift;
	my $args = shift || $self->{_unit}{name} || '';

	unless ($args =~ /^\s*(\w+)\s*$/o) {
		$self->error("valid alphanumeric unit($args) is required");
	} else {
		$self->{_unit}{name} = uc($args);
	}
	
	$self->{_unit}{name};
}

sub _type {
	my $self = shift;
	my $args = shift || $self->{_unit}{type} || '';

	my $xx = uc(substr($args, 0, 2));
	unless ($TYPES{$xx} =~ /^(\w+)$/o) {
		$self->error("invalid type($args) - the following are allowed: ".join(', ', sort VALUES %TYPES));
	} else {
		$self->{_unit}{type} = uc($1);
	}
	
	$self->{_unit}{type};
}

sub _namespace {
	my $self = shift;
	my $args = shift || $self->{_unit}{namespace} || '';

	my $xx = uc(substr($args, 0, 2));
	unless ($NAMESPACES{$xx} =~ /^(\w+)$/o) {
		$self->error("invalid namespace($args) - the following are allowed: ".join(', ', sort VALUES %NAMESPACES));
	} else {
		$self->{_unit}{namespace} = uc($1);
	}
	
	return $self->{_unit}{namespace};
}

sub _owner {
	my $self = shift;
	my $args = shift || $self->{_unit}{owner} || '';

	unless ($args =~ /^\s*(\w+)\s*$/o) {
		$self->error("valid alphanumeric owner($args) is required");
	} else {
		$self->{_unit}{owner} = uc($1);
	}
	
	return $self->{_unit}{owner};
}

# =============================================================================
# error, log and cleanup methods
# =============================================================================

sub feedback {
	my $self = shift;
	my $msgs = join(' ', @_);
	print STDOUT 'ORADB> '."$msgs\n";
	return $msgs;
}

sub log {
	my $self = shift;
	my $msgs = join(' ', @_);
	print STDERR 'oradb: '."$msgs\n";
	return $msgs;
}

sub quit {
	my $self = shift;
	$self->abort();
	print "oradb detaching...\n";
	# $self->detach;
	exit;
}

sub error {
	my $self = shift;
	$DB::errstr = $DB::errstr;
	my $errs = join(' ', 'Error:', @_).($DB::errstr || '')."\n";
	print $errs;
	# carp($errs);
	return $errs;
}

sub fatal {
	my $self = shift;
	croak(ref($self).' FATAL ERROR: ', @_);
}

sub abort {
	my $self = shift;

	my $exec = qq#
				DECLARE 
						runinfo dbms_debug.runtime_info; 
						ret BINARY_INTEGER;
				BEGIN 
    	    	-- oradb.continue_(dbms_debug.abort_execution);
    	    	ret := dbms_debug.continue(runinfo, dbms_debug.abort_execution, 0);
				END;
		#;

	$self->do($exec)->get_msg;
}

sub detach {
	my $self = shift;

	my $exec = qq#
				BEGIN 
						dbms_debug.detach_session; 
				END;
		#;
	$self->do($exec)->get_msg;

	# autonomous transaction
	# $self->do('DELETE FROM '.$self->{_config}{table});
	# $self->do('COMMIT');
}

sub DESTROY {
	my $self = shift;
	my $dbh  = $self->{_dbh}->{$$};
	if (ref($dbh)) {
		$dbh->disconnect;
	}
}

1;