paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 04:39:38 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ Initial implementation of Pavel Stingl

Browse Source
This commit is contained in:
michael 2000-12-02 15:14:14 +00:00
parent caee5e33c8
commit 26c80f07f4
6 changed files with 3784 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1286
packages/oracle/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

20
packages/oracle/Makefile.fpc Normal file
View File

@ -0,0 +1,20 @@
#
# Makefile.fpc for oracle units
#
[targets]
units=oraoci oraclew
examples=test01
[require]
packages=fcl
[dirs]
# in libdir variable must be path to libraries
# libclntsh.*,libnlsrtl3.*
#libdir=/usr/local/oracle8cli/lib
fpcdir=../..
[install]
packagename=oracle
examplesubdir=oracle

20
packages/oracle/README Normal file
View File

@ -0,0 +1,20 @@
These units provides interface to Oracle Call Interface.
Object workaround (TOraDatabase etc...) is on the way.
Unit oraclew contains some procedures and functions,
which makes usage of oraoci not so painfull... But -
if you wanna to program in RAW OCI, you really can ;)
To compile you need oracle server installed, these units
was tested and performed on Oracle 8.0.1.5 Standard
server. One developer license of Oracle server is free
of charge...
You need to have oracle lib directory in ldpath, too,
or you can this path set in Makefile.fpc (is commented
there)
After all this, run 'make examples' and enjoy!
Pavel Stingl
stingp1.eti@mail.cez.cz

449
packages/oracle/oraclew.pp Normal file
View File

@ -0,0 +1,449 @@
{
$Id$
Copyright (c) 1999-2000 by Pavel Stingl <stingp1.eti@mail.cez.cz>
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 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
}

1951
packages/oracle/oraoci.pp Normal file
View File

File diff suppressed because it is too large Load Diff

58
packages/oracle/test01.pp Normal file
View File

@ -0,0 +1,58 @@
{
$Id$
Copyright (c) 1999-2000 by Pavel Stingl <stingp1.eti@mail.cez.cz>
Test program for OraOCI units
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.
**********************************************************************}
program test01;
uses oraclew, oraoci,linux;
{$H+}
{
Constants user, pass & tnsc you must set by hand to values,
which you prefer.
user = username
pass = password
tnsc = TNS connect string
**********************************************************************}
const
user = 'every';
pass = 'tisova';
tnsc = 'etil.world';
var
x : integer;
p : integer;
begin
OraInit;
OraLogin(user,pass,tnsc);
OraSQLExec('select sysdate from sys.dual');
writeln(OraGetFieldName(1):20);
p := OraGetFieldCount;
for x := 1 to p do
write(OraGetFieldName(x), ';');
WriteLn;
while OraNext do
begin
for x := 1 to p do
write(OraGetFieldAsString(x), ';');
writeln;
end;
OraLogout;
OraFin;
end.