Apache-OWA
view release on metacpan or search on metacpan
elsif ( $r->dir_config('DB_PROC_AUTH') ) {
my ( $proc ) = $r->dir_config('DB_PROC_AUTH');
$dbh = DBI->connect("dbi:Oracle:$dbinfo[0]",$dbinfo[1],$dbinfo[2],
{ PrintError => 0, RaiseError => 0, AutoCommit => 1 })
|| return SERVER_ERROR;
my $rv;
$sql = 'begin :rv := $proc (:user, :pw); end;';
$sth = $dbh->prepare($sql);
#$sth = $dbh->prepare_cached($sql);
$sth->bind_param(':user', $user);
$sth->bind_param(':pw', $sent_pw);
$sth->bind_param_inout(':rv', \$rv, 2);
$sth->execute || return SERVER_ERROR ;
$sth->finish;
$dbh->disconnect;
return AUTH_REQUIRED if $rv != 0;
}
# support for owa.auth_scheme and owa.protection_realm
# would pobably go here if i didn't think they were stupid...
}
# pass handling to the content handler
$r->handler('perl-script');
# reset package, get owa toolkit version
$sql = '
BEGIN
dbms_session.reset_package;
:version := owa.initialize;
END;
';
$sth = $dbh->prepare($sql);
$sth->bind_param_inout(':version', \$owa_version{$uri}, 1);
$owa_mapping{$uri} = $plsql;
$r->warn("executing: $sql") if ($DEBUG > 1);
$sth->execute || &error($DBI::errstr, $sql);
$r->warn("executed OK") if ($DEBUG > 1);
# setup CGI environment in Oracle
my (@args, @bind_vars, $envVarCount);
my ($declares, $defines);
$declares .= " cgi_var_val owa.vc_arr;\n";
$declares .= " cgi_var_name owa.vc_arr;\n";
# what variables to pass to Oracle.
# these are sort of standard, i think...
# you can change them to whatever you like.
# for example:
#(@pass_vars) = (keys %{ $r->subprocess_env });
'REMOTE_HOST', 'REMOTE_ADDR', 'AUTH_TYPE',
'REMOTE_USER', 'HTTP_ACCEPT',
'HTTP_USER_AGENT','SERVER_PROTOCOL','SERVER_PORT',
'SCRIPT_NAME', 'PATH_INFO', 'PATH_TRANSLATED',
'HTTP_REFERER', 'HTTP_COOKIE');
foreach (@pass_vars) {
$defines .=
' cgi_var_val(' .++$envVarCount . "):=?;\t" .
' cgi_var_name(' . $envVarCount ."):='". $_ ."';\n";
push @bind_vars, $r->subprocess_env($_) ;
}
push @bind_vars, $envVarCount;
$sql = "\nDECLARE\n" . $declares;
$sql .= "BEGIN\n" . $defines;
$sql .= " owa.init_cgi_env(?, cgi_var_name, cgi_var_val);\n";
$sql .= "END;\n";
$sth = $dbh->prepare($sql);
$r->warn("executing: $sql") if ($DEBUG > 1);
$sth->execute(@bind_vars) || &error($dbh->errstr, $sql);
$r->warn("executed OK") if ($DEBUG > 1);
$sth->finish;
# reusing variables.
@args=(); @bind_vars=(); $declares = ""; $defines = "";
# start putting together procedure arguments, if there are any.
if ( $r->param() ) {
my %arg_name_type = &check_var_types( $plsql )
unless ( $r->dir_config('NEVER_USE_WEIRD_TYPES'));
# loop through each arg, constructing SQL snippets as we go
my @names = $r->param();
foreach my $name ( @names ) {
# only declare basename once
unless ($declares =~ /$basename/) {
$declares .= " $basename owa_image.point;\n";
push @args, $basename . ' => ' . $basename;
}
# x or y?
if ($coord =~ /x/i) {
$defines .= " " . $basename . "(1) := ?;\n";
push @bind_vars, $values[0];
} else {
$defines .= " " . $basename . "(2) := ?;\n";
push @bind_vars, $values[0];
}
}
# is it an array?
# the only way to know if it is an array is to do the check
# in &check_var_types
elsif ( $arg_name_type{$name} ) {
# we can not assume it is a owa_util.ident_arr,
# the only way to know the array type is to do the check above.
$defines .= ' ' . $name . "($j) := \'$values[$j-1]\' ;\n";
}
}
# regular attr=value pair
else {
$declares .= " $name varchar2(4096);\n";
push @args, $name .' => '. $name;
$values[0] =~ s/'/''/g;
$defines .= ' ' . $name . " := ?;\n";
push @bind_vars, $values[0];
}
}
}
$sql = "\nDECLARE\n" . $declares;
$sql .= "BEGIN\n" . $defines;
$sql .= "\n " . $plsql ;
($sql .= '(' . join(',', @args) . ')') if ( @args );
$sql .= ";\nEND;\n";
$sth = $dbh->prepare($sql);
$r->warn("executing: $sql") if ($DEBUG > 1);
$sth->execute(@bind_vars);
$r->warn("executed OK") if ( ($DEBUG > 1) &! $dbh->err );
if ( $dbh->err && $DEBUG ) {
&helpful_error($dbh->err, $dbh->errstr, $sql, $plsql, \@args, \@bind_vars);
}
elsif ($dbh->err == 6550) {
$r->log_error( $r->subprocess_env('REMOTE_ADDR') . " " . $r->uri . " NOT FOUND");
return NOT_FOUND;
}
elsif ( $dbh->err ) {
$r->log_error( $r->subprocess_env('REMOTE_ADDR') . " " . $r->uri . " SERVER_SERROR");
return SERVER_ERROR;
}
else {
error('Unknown PL/SQL Toolkit version!');
}
my $content;
my $pos = 1;
my $rows = 0;
my $numgets = 0;
$sth = $dbh->prepare($sql);
$sth->bind_param_inout(':rows', \$rows, 1);
$sth->bind_param_inout(':pos', \$pos, 1);
$sth->bind_param_inout(':content', \$content, { TYPE => 24 } ); # varchar2
$r->content_type('text/html');
$r->warn("executing: $sql") if ($DEBUG > 1);
while ( $pos > 0) {
$r->warn("executing: rows = $rows pos = $pos numgets = $numgets")
if ($DEBUG > 1);
$r->warn("executing again: rows = $rows pos = $pos numgets = $numgets")
if ( ($DEBUG > 1) && ($numgets > 0) );
$sth->execute || &error($dbh->err,$sql);
$numgets++;
. '<hr><b>Request data: </b><br>'
. '<pre>' . $r->as_string . '</pre><br>'
. '</pre><hr></BODY</HTML>';
$r->custom_response(SERVER_ERROR,$msg);
$dbh->disconnect;
die;
}
#########################################################################
sub helpful_error {
my ($err,$errstr,$old_sql,$plsql,$args,$bind_vars) = @_;
# funky error checking
#
# error 6550 could mean that
# 1 - the procedure doesn't exist
# 2 - the arguments are wrong
# 3 - no execute grant??
# 4 - ??
# try to find procedure and arguments in all_arguments
# so we can get some nice debug-info.
$got_args .= $_ . ' = ' . $r->param($_) ."\n";
$i++;
}
my $msg = "$errstr\n\n";
$msg .= "You may need to remove \"PerlSetVar NEVER_USE_WEIRD_TYPES\" from httpd.conf\n\n"
if ( $r->dir_config('NEVER_USE_WEIRD_TYPES'));
$msg .= "Expected ". $sth->rows ." argument(s):\n" . $exp_args . "\n"
. "Got " . $i ." argument(s):\n" . $got_args . "\n"
. "Sql: \n" . $old_sql . "\n"
. "args: \n" . join("\n", @{$args}) . "\n"
. "vars: \n" . join("\n", @{$bind_vars}) . "\n";
&error($msg,$old_sql);
}
}
#################################################################
# nasty stuff we need to do to check for weird PL/SQL Table datatypes.
# thanks to Slava Kalashnikov <slava@intes.odessa.ua>
# if you don't ever use PL/SQL Table datatypes,
# turn it off with "PerlSetVar NEVER_USE_WEIRD_TYPES 1"
sub check_var_types ($) {
( run in 3.389 seconds using v1.01-cache-2.11-cpan-2398b32b56e )