UdtOra

The Basic program runs a perl script that actually connects to the database. The perl script sends the results to stdout, which is captured by the Basic program and parsed into a dynamic array.

SUBROUTINE UDTORA(RTN,COL.HEADING,SQL.STATEMENT,OPTIONS,ERRCODE)
***************************************************************************
* Program: UDTORA
* Author : MATT CARROLL
* Date   : 
* Edited : 08:29:36 Dec 06 2001 By MCGOWAN 
* Comment: PASS SQL STATEMENT TO ORACLE DB, RETURNS DYN. ARRAY
***************************************************************************
* Date       By   Desc
* ---------- ---- ---------------------------------------------------------
* 04/11/2000 IAN  Modified perl script to return error code as follows:
                  *# Return value is
                  *# 0 no rows selected or updated
                  *# 1 success, first line of rtn = col headers, second = num rows selected/update
                  *# 2 error, see first line of RTN for description
* 07/31/2000 IAN  Escape $ chars in sql
* 04/02/2001 IAN  Pass in account (sid) to perl script
* 12/06/2001 IAN  Convert @am to " "

* RTN              RETURNED TO CALLING PROGRAM. ARRAY OF DATA RETURNED FROM SQL.STATEMENT
* COL.HEADING      RETURNED TO CALLING PROGRAM. MULTI-VALUED LIST OF FIELD NAMES OF TABLE FROM FIRST ROW
* SQL.STATEMENT    A VALID SQL STATEMENT. PASSED IN.
* OPTIONS          TO BE ITEM

COL.HEADING="" ; PERL.ERR=0 ; ERRCODE=0
SWAP "$" WITH "\$" IN SQL.STATEMENT
SWAP @AM WITH " " IN SQL.STATEMENT

ACCT = ""
<cut stuff about accounts>

IF ACCT="" THEN STOP "PLEASE ADD THIS ACCOUNT TO UDTORA"

E= \!/usr/local/bin/udora.pl \:ACCT:\ "\:SQL.STATEMENT:\" ; echo $?\\ 
EXECUTE E CAPTURING RTN
I=DCOUNT(RTN,@AM)
PERL.ERR=RTN<I-1>
DEL RTN<I>
DEL RTN<I-1>

IF PERL.ERR = 0 THEN
   * No rows selected/updated
   ERRCODE=0
   * Still get col headings
   COL.HEADING=RTN<1>
   DEL RTN<1>
END

IF PERL.ERR = 1 THEN
   * Get col headings
   COL.HEADING=RTN<1>
   DEL RTN<1>
   * Get number of rows updated/selected
   ERRCODE=RTN<1>
   DEL RTN<1>
END

IF PERL.ERR = 2 THEN
   * There was an error
   ERRCODE = -1
END

SWAP \@#@\ WITH @VM IN RTN
RETURN

And the perl script

#!/usr/bin/perl

use POSIX;
use DBI;
use DBI::DBD;   # simple test to make sure it's okay
use DBD::Oracle;

$ENV{[[ORACLE_BASE]]}="/info/app/oracle";
$ENV{[[ORACLE_HOME]]}="/info/app/oracle/product/8.1.5";
$ENV{[[NLS_LANG]]}="american_america.[[WE8ISO8859P1]]";
$ENV{[[ORA_NLS33]]}="/info/app/oracle/product/8.1.5/ocommon/nls/admin/data";
$user="oracle";
$pass="xxx";

my $db_sid='trinity';
my $rtn=0;
my $fld_delim = chr(253);
my $crlf_delim = chr(252);

if( !( $dbh = DBI->connect('dbi:Oracle:host=sunrise;sid=trinity',$user,$pass)))
{
   print "Cannot connect database\n$DBI::errstr\n";
   exit 2;
}

$statement=$ARGV[1];
$dbh->{[[LongReadLen]]}=4094;
if( !( $sth = $dbh->prepare("$statement") ) )
{
   print "Cannot prepare statement\n$DBI::errstr\n\n";
   exit 2;
}

if ($statement =~ /^select/i) {
   # Select statements return rows
   $rc=$sth->execute;
   if( ! $rc )
   {
      print "Cannot process statement\n$DBI::errstr\n\n";
      exit 2;
   }
   my $names = $sth->{NAME};

   for ($i=0 ; $i <= $#$names ; $i++)
   {
      print $names->[$i];
      if ($i != $#$names) {print $fld_delim;}
   }
   print "\n";

   $table = $sth->fetchall_arrayref;
   if( $#{$table} < 0 )
   {
      print "No rows returned\n";
      exit 0;
   }

   print $#{$table}+1,"\n";

   for $i ( 0 .. $#{$table} )
   {
      for $j ( 0 .. $#{$table->[$i]} )
      {
         $data = $table->[$i][$j];
         $data =~ s/\r\n/$crlf_delim/g;
         print $data;
         if ($j != $#{$table->[$i]}) {print $fld_delim;}
      }
      {print "\n";}
   }
} else {
   # It's an update or insert statement
   $rc=$dbh->do($statement);
   if ($rc eq "0E0") {
       print "0 rows updated\n";
       exit 0;
   } else {
      print "\n$rc\n$rc rows updated\n";
      #$dbh->commit;
   }
}

# Close our connection to the db
$sth->finish;

# Return value is
# 0 no rows selected or updated
# 1 success, first line of rtn = col headers, second = num rows selected/updated# 2 error, see first line of RTN for description
exit 1;