fpc/packages/base/oracle/example/oraclew.pp

{
    $Id$
    Copyright (c) 1999-2000 by Pavel Stingl <[email protected]>


    OCI workaround

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
unit oraclew;

interface

{$H+}
{$mode objfpc}

uses OraOCI, Classes, SysUtils;

{ all pos parameters are indexed from 1..x! }

    procedure OraInit;
    procedure OraFin;
    procedure OraLogin(name, pass, server: string);
    procedure OraLogout;
    procedure OraSQLExec(sql: string);
    function OraGetFieldAsString(pos : integer) : string;
    function OraGetFieldAsInteger(pos : integer) : longint;
    function OraNext: boolean;
    function OraGetFieldCount: integer;
    function OraGetFieldName(pos : integer) : string;
    function OraGetFieldType(pos : integer) : longint;
    function IsFieldDate(Pos : integer): boolean;
    procedure OraError(errcode: integer; err: OCIError; msg : string);
    
const
    cDescribeBuf = 1024;
    cPCharBufLen = 4097;
    cPrefetchCnt = 100;

type

  PDescribeRec = ^TDescribeRec;
  TDescribeRec = record
    dbsize	: sb4;
    dbtype	: sb2;
    buf		: array [0..cDescribeBuf] of char;
    buflen	: sb4;
    dsize 	: sb4;
    precision 	: sb2;
    scale 	: sb2;
    nullok 	: sb2;
    
    // Define part
      valbuf	: array [0..cDescribeBuf] of char;
      flt_buf	: double;
      int_buf	: cardinal;
      int64_buf : int64;
      indp	: sb2;
      col_retlen: ub2;
      col_retcode: ub2;
  end;
  
var
    Env : OCIEnv; 
    Err : OCIError;
    Svc : OCISvcCtx;
    Stmt: OCIStmt;
    FieldList : TList;
    
    ecode : integer;

implementation

  function DecodeDataType(dtype : longint): string;
  begin
    case dtype of
	SQLT_CHR : DecodeDataType := '(ORANET TYPE) character string';
	SQLT_NUM : DecodeDataType := '(ORANET TYPE) oracle numeric';
   	SQLT_INT : DecodeDataType := '(ORANET TYPE) integer';
   	SQLT_FLT : DecodeDataType := '(ORANET TYPE) Floating point number';
   	SQLT_STR : DecodeDataType := 'zero terminated string';
   	SQLT_VNU : DecodeDataType := 'NUM with preceding length byte';
   	SQLT_PDN : DecodeDataType := '(ORANET TYPE) Packed Decimal Numeric';
   	SQLT_LNG : DecodeDataType := 'long';
   	SQLT_VCS : DecodeDataType := 'Variable character string';
   	SQLT_NON : DecodeDataType := 'Null/empty PCC Descriptor entry';
	SQLT_RID : DecodeDataType := 'rowid';
	SQLT_DAT : DecodeDataType := 'date in oracle format';
	SQLT_VBI : DecodeDataType := 'binary in VCS format';
	SQLT_BIN : DecodeDataType := 'binary data(DTYBIN)';
	SQLT_LBI : DecodeDataType := 'long binary';
	SQLT_UIN : DecodeDataType := 'unsigned integer';
	SQLT_SLS : DecodeDataType := 'Display sign leading separate';
	SQLT_LVC : DecodeDataType := 'Longer longs (char)';
	SQLT_LVB : DecodeDataType := 'Longer long binary';
	SQLT_AFC : DecodeDataType := 'Ansi fixed char';
	SQLT_AVC : DecodeDataType := 'Ansi Var char';
	SQLT_CUR : DecodeDataType := 'cursor  type';
	SQLT_RDD : DecodeDataType := 'rowid descriptor'; 
	SQLT_LAB : DecodeDataType := 'label type'; 
	SQLT_OSL : DecodeDataType := 'oslabel type'; 
	SQLT_NTY : DecodeDataType := 'named object type'; 
	SQLT_REF : DecodeDataType := 'ref type'; 
	SQLT_CLOB : DecodeDataType := 'character lob'; 
	SQLT_BLOB : DecodeDataType := 'binary lob'; 
	SQLT_BFILEE : DecodeDataType := 'binary file lob';
	SQLT_CFILEE : DecodeDataType := 'character file lob'; 
	SQLT_RSET : DecodeDataType := 'result set type'; 
	SQLT_NCO : DecodeDataType := 'named collection type (varray or nested table)';
	SQLT_VST : DecodeDataType := 'OCIString type'; 
	SQLT_ODT : DecodeDataType := 'OCIDate type'; 
    else DecodeDataType := 'Unknown';
    end;
  end;
    
  procedure FieldListClear;
  var
   	x: longint;
   	PDesc: PDescribeRec;
  begin
   	if FieldList.Count = 0 then Exit;
   	for x := 0 to FieldList.Count - 1 do
   	begin
   	    PDesc := FieldList[x];
   	    Dispose(PDesc);
   	end;
   	FieldList.Clear;
  end;
   
       procedure Describe;
       var
   	fldc	: longint;
   	paramd	: OCIParam;
   	colname : PChar;
   	colsize : ub4;
   	Rec	: PDescribeRec;
       begin
   	fldc := 1;
   	
   	FieldListClear;
   	ecode := OCIParamGet(Stmt, OCI_HTYPE_STMT, Err, @paramd, fldc);
   	if ecode <> OCI_SUCCESS then
   	    ORAError(ecode, Err, 'OCIParamGetError');
   	while ecode = OCI_SUCCESS do
   	begin
   	    New(Rec);
   	    FillChar(Rec^.buf, sizeof(Rec^.buf), #0);
   	    ecode := OCIAttrGet(paramd, OCI_DTYPE_PARAM, @Rec^.dbtype, 0, 
   		OCI_ATTR_DATA_TYPE, Err);
   	    if ecode <> 0 then
   	    begin
   		ORAError(ecode, Err, 'Retrieving DTYPE_PARAM:');
   	    end;
   	    colsize := 0;
   	    colname := nil;
   	    ecode := OCIAttrGet(paramd, OCI_DTYPE_PARAM, @colname, @colsize, 
   		OCI_ATTR_NAME, Err);
   	    if ecode <> 0 then
   	    begin
   		ORAError(ecode, Err, 'Retrieving DTYPE_PARAM:');
   	    end;
   	    Move(Colname^,Rec^.buf, colsize);
   	    Rec^.buflen := colsize;
//   	    WriteLn('Column: ',Rec^.buf:15,'	DataType: ',DecodeDataType(Rec^.dbtype));
   	    inc(fldc);
   	    
   	    FieldList.Add(Rec);
   	    ecode := OCIParamGet(Stmt, OCI_HTYPE_STMT, Err, @paramd, fldc);
   	end;
    end;
    
    procedure Define;
    var
	x : longint;
	def: OCIDefine;
	PDesc : PDescribeRec;
	defptr: pointer;
	deflen: sword;
	deftyp: sword;
    begin
	def := nil;
	for x := 0 to FieldList.Count - 1 do
	begin
	    PDesc := FieldList[x];
	    case PDesc^.dbtype of
		NUMBER_TYPE: begin
		    if PDesc^.scale <> 0 then
		    begin
			defptr := @PDesc^.flt_buf;
			deflen := SizeOf(PDesc^.flt_buf);
			deftyp := FLOAT_TYPE;
			PDesc^.dbtype := FLOAT_TYPE;
		    end
		    else begin
              if PDesc^.dbsize > 4 then
              begin
                // WriteLn('BIG FAT WARNING!!!! dbsize int > 4 (',PDesc^.dbsize,')');
                defptr := @PDesc^.int64_buf;
                deflen := SizeOf(PDesc^.int64_buf);
                deftyp := INT_TYPE;
                PDesc^.dbtype := INT_TYPE;
              end
              else begin
                defptr := @PDesc^.int_buf;
			    deflen := SizeOf(PDesc^.int_buf);
			    deftyp := INT_TYPE;
			    PDesc^.dbtype := INT_TYPE;
              end;
		    end;
		end;
		else begin
		    defptr := @PDesc^.valbuf;
		    deflen := cDescribeBuf;
		    deftyp := PDesc^.dbtype;
		end;
	    end;
	    ecode := OCIDefineByPos(Stmt, @def, Err, x + 1, defptr, 
		deflen,	deftyp, @PDesc^.indp, @PDesc^.col_retlen, 
		@PDesc^.col_retcode, OCI_DEFAULT);
	    if ecode <> 0 then
	    begin
		OraError(ecode, Err, 'OCIDefineByPos: ');
	    end;
	end;
    end;

    procedure OraError( errcode : integer; err: OCIError; msg : string );
    var
	buff : array [0..1024] of char;
	xp : PLongint;
    begin
	if err <> nil then
	begin
	    case errcode of
		OCI_INVALID_HANDLE: Msg := Msg + ' OCI_INVALID_HANDLE';
	    end;
	    xp := @errcode;
	    OCIErrorGet( err, 1, nil, xp, @buff[0], 1024, OCI_HTYPE_ERROR);
	    writeln(stderr, msg, ' ', buff);
	end
	else begin
	    WriteLn(stderr, msg);
	    Halt(1);
	end;
    end;

    procedure OraInit;
    begin
	ecode := OCIInitialize({OCI_DEFAULT or }OCI_OBJECT, nil, nil, nil, nil);
	if ecode <> 0 then OraError( ecode, nil, 'Error initializing OCI');
	ecode := OCIEnvInit(Env, OCI_DEFAULT, 0, nil);
	if ecode <> 0 then OraError( ecode, nil, 'Error initializing OCI environment');
	ecode := OCIHandleAlloc(Env, Err, OCI_HTYPE_ERROR, 0, nil);
	if ecode <> 0 then OraError( ecode, nil, 'Error allocating error handle');
	ecode := OCIHandleAlloc(Env, Stmt, OCI_HTYPE_STMT, 0, nil);
	if ecode <> 0 then OraError( ecode, nil, 'Error allocating statement handle');
    end;
    
    procedure OraLogin(name, pass, server: string);
    begin
	ecode := OCILogon(Env, Err, Svc, @name[1], Length(name),
	    @pass[1], Length(pass), @server[1], Length(server));
	if ecode <> 0 then OraError(ecode, Err, ''); 	
    end;
    
    procedure OraLogout;
    begin
	ecode := OCILogoff(Svc, Err);
	if ecode <> 0 then
	    OraError(ecode, Err, 'OCILogoff: ');
    end;
    
    procedure OraFin;
    begin
	OCIHandleFree(Stmt, OCI_HTYPE_STMT);
	OCIHandleFree(Err, OCI_HTYPE_ERROR);
    end;
    
    procedure OraSQLExec(sql: string);
    var
	dtype: longint;
    begin
//    writeLn(Length(sql));
	ecode := OCIStmtPrepare(Stmt, Err, @sql[1], Length(sql),
	    OCI_NTV_SYNTAX, OCI_DEFAULT);
	if ecode <> 0 then 
	begin
	    OraError(ecode, Err, 'OCIStmtPrepare:');
	    Exit;
	end;
    
    dtype := cPrefetchCnt;
    ecode := OCIAttrSet(Stmt, OCI_HTYPE_STMT, @dtype, 
      SizeOf(dtype), OCI_ATTR_PREFETCH_ROWS, Err);
	if ecode <> 0 then 
	begin
	    OraError(ecode, Err, 'ociattrset:');
	    Exit;
	end;

	dtype := 0;
	ecode := OCIAttrGet(Stmt, OCI_HTYPE_STMT, @dtype, 4, 
	    OCI_ATTR_STMT_TYPE, Err);
	if ecode <> 0 then 
	begin
	    OraError(ecode, Err, 'ociattrget:');
	    Exit;
	end;
    
	ecode := 0;
	if dtype = OCI_STMT_SELECT then
	    ecode := OCIStmtExecute(Svc, Stmt, Err, 0, 0, nil, nil, OCI_DEFAULT)
	else ecode := OCIStmtExecute(Svc, Stmt, Err, 1, 0, nil, nil, OCI_DEFAULT);
	if ecode <> 0 then
	begin
	    OraError(ecode, Err, 'OCIStmtExecute:');
	    Exit;
	end;
	
	if dtype = OCI_STMT_SELECT then
	begin
	    Describe;
	    Define;
	end;
    end;
    
    function OraGetFieldCount : integer;
    begin
	OraGetFieldCount := FieldList.Count;
    end;

    function IsFieldDate(Pos : integer): boolean;
    var
      Desc : TDescribeRec;      
    begin
      Result := False;
      if (Pos > FieldList.Count) or (Pos < 1) then
        Exit;
      Desc := TDescribeRec(FieldList[Pos-1]^);
      Result := (Desc.dbtype = DATE_TYPE);
    end;
    
    function OraGetFieldAsString(pos : integer) : string;
    var
	Desc : TDescribeRec;
    Date : array [0..6] of byte;
    begin
	if (Pos > FieldList.Count) or (Pos < 1) then
	    Exit;
	Desc := TDescribeRec(FieldList[pos-1]^);
    if Desc.indp < 0 then
    begin
      OraGetFieldAsString := 'null';
      Exit;
    end;
	if Desc.dbtype = STRING_TYPE then
	begin
	    Desc.valbuf[Desc.col_retlen] := #0;
	    OraGetFieldAsString := Desc.valbuf;
	end
	else if Desc.dbtype = VARCHAR2_TYPE then
	begin
	    Desc.valbuf[Desc.col_retlen] := #0;
	    OraGetFieldAsString := Desc.valbuf;
	end
  	else if Desc.dbtype = INT_TYPE then
    begin
	    OraGetFieldAsString := IntToStr(Desc.int_buf);
    end
	else if Desc.dbtype = FLOAT_TYPE then
	    OraGetFieldAsString := FloatToStr(Desc.flt_buf)
	else if Desc.dbtype = DATE_TYPE then
    begin
        Move(Desc.valbuf,Date,SizeOf(Date));
	    OraGetFieldAsString := 
          Format('%0.2d.%0.2d.%0.4d %0.2d:%0.2d:%0.2d',
          [Date[3],Date[2],(((Date[0]-100)*100)+(Date[1] - 100)),
           Date[4]-1,
           Date[5]-1,
           Date[6]-1]);
    end
	else if Desc.dbtype = SQLT_AFC then
	begin
	    Desc.valbuf[Desc.col_retlen] := #0;
	    OraGetFieldAsString := Desc.valbuf;
	end
	else OraGetFieldAsString := 'dbtype not implemented ' + IntToStr(Desc.dbtype);
    end;
    
    function OraGetFieldAsInteger(pos : integer) : longint;
    begin
	OraGetFieldAsInteger := 0;
    end;
    
    function OraNext: boolean;
    begin
	ecode := OCIStmtFetch(Stmt, Err, 1, OCI_FETCH_NEXT, OCI_DEFAULT);
	if ecode = 0 then
	    OraNext := true
	else if ecode = OCI_SUCCESS_WITH_INFO then
	    OraNext := false
	else if ecode = OCI_NO_DATA then
	    OraNext := false
	else begin
	    OraNext := false;
	    OraError(ecode, err, 'OCIStmtFetch:');
	end;
    end;
    
    function OraGetFieldType(pos : integer) : longint;
    begin
      if (Pos > FieldList.Count) or (pos < 1) then
        Exit;
      OraGetFieldType := TDescribeRec(FieldList[pos-1]^).dbtype;    
    end;

    function OraGetFieldName(pos : integer) : string;
    begin
	if (Pos > FieldList.Count) or (Pos < 1) then
	    Exit;
	OraGetFieldName := TDescribeRec(FieldList[pos-1]^).buf;	
    end;
    
initialization
    
    FieldList := TList.Create;

finalization

    FieldListClear;
    FieldList.Free;

end.

{
  $Log$
  Revision 1.1  2002-01-29 17:54:54  peter
    * splitted to base and extra

  Revision 1.1  2001/04/08 12:23:49  peter
    * moved oraclew and test01 to example subdir to remove the dependency
      on the fcl. This dependency is now only required when building the
      examples

  Revision 1.1  2000/12/02 15:14:14  michael
  + Initial implementation of Pavel Stingl

  Revision 1.1.1.1  2000/10/11 07:48:28  stingp1
    * Import to cvs

}