1{
2    Copyright (c) 1999-2000 by Pavel Stingl <stingp1.eti@mail.cez.cz>
3
4
5    OCI workaround
6
7    See the file COPYING.FPC, included in this distribution,
8    for details about the copyright.
9
10    This program is distributed in the hope that it will be useful,
11    but WITHOUT ANY WARRANTY; without even the implied warranty of
12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************}
15unit oraclew;
16
17interface
18
19{$H+}
20{$mode objfpc}
21
22uses OCI, oratypes,Classes, SysUtils;
23
24{ all pos parameters are indexed from 1..x! }
25
26    procedure OraInit;
27    procedure OraFin;
28    procedure OraLogin(name, pass, server: string);
29    procedure OraLogout;
30    procedure OraSQLExec(sql: string);
31    function OraGetFieldAsString(pos : integer) : string;
32    function OraGetFieldAsInteger(pos : integer) : longint;
33    function OraNext: boolean;
34    function OraGetFieldCount: integer;
35    function OraGetFieldName(pos : integer) : string;
36    function OraGetFieldType(pos : integer) : longint;
37    function IsFieldDate(Pos : integer): boolean;
38    procedure OraError(errcode: integer; err: POCIError; msg : string);
39
40const
41    cDescribeBuf = 1024;
42    cPCharBufLen = 4097;
43    cPrefetchCnt = 100;
44
45type
46
47  PDescribeRec = ^TDescribeRec;
48  TDescribeRec = record
49    dbsize      : sb4;
50    dbtype      : sb2;
51    buf         : array [0..cDescribeBuf] of char;
52    buflen      : sb4;
53    dsize       : sb4;
54    precision   : sb2;
55    scale       : sb2;
56    nullok      : sb2;
57
58    // Define part
59      valbuf    : array [0..cDescribeBuf] of char;
60      flt_buf   : double;
61      int_buf   : cardinal;
62      int64_buf : int64;
63      indp      : sb2;
64      col_retlen: ub2;
65      col_retcode: ub2;
66  end;
67
68var
69    Env : POCIEnv;
70    Err : POCIError;
71    Svc : POCISvcCtx;
72    Stmt: POCIStmt;
73    FieldList : TList;
74
75    ecode : integer;
76
77implementation
78
79  function DecodeDataType(dtype : longint): string;
80  begin
81    case dtype of
82        SQLT_CHR : DecodeDataType := '(ORANET TYPE) character string';
83        SQLT_NUM : DecodeDataType := '(ORANET TYPE) oracle numeric';
84        SQLT_INT : DecodeDataType := '(ORANET TYPE) integer';
85        SQLT_FLT : DecodeDataType := '(ORANET TYPE) Floating point number';
86        SQLT_STR : DecodeDataType := 'zero terminated string';
87        SQLT_VNU : DecodeDataType := 'NUM with preceding length byte';
88        SQLT_PDN : DecodeDataType := '(ORANET TYPE) Packed Decimal Numeric';
89        SQLT_LNG : DecodeDataType := 'long';
90        SQLT_VCS : DecodeDataType := 'Variable character string';
91        SQLT_NON : DecodeDataType := 'Null/empty PCC Descriptor entry';
92        SQLT_RID : DecodeDataType := 'rowid';
93        SQLT_DAT : DecodeDataType := 'date in oracle format';
94        SQLT_VBI : DecodeDataType := 'binary in VCS format';
95        SQLT_BIN : DecodeDataType := 'binary data(DTYBIN)';
96        SQLT_LBI : DecodeDataType := 'long binary';
97        SQLT_UIN : DecodeDataType := 'unsigned integer';
98        SQLT_SLS : DecodeDataType := 'Display sign leading separate';
99        SQLT_LVC : DecodeDataType := 'Longer longs (char)';
100        SQLT_LVB : DecodeDataType := 'Longer long binary';
101        SQLT_AFC : DecodeDataType := 'Ansi fixed char';
102        SQLT_AVC : DecodeDataType := 'Ansi Var char';
103        SQLT_CUR : DecodeDataType := 'cursor  type';
104        SQLT_RDD : DecodeDataType := 'rowid descriptor';
105        SQLT_LAB : DecodeDataType := 'label type';
106        SQLT_OSL : DecodeDataType := 'oslabel type';
107        SQLT_NTY : DecodeDataType := 'named object type';
108        SQLT_REF : DecodeDataType := 'ref type';
109        SQLT_CLOB : DecodeDataType := 'character lob';
110        SQLT_BLOB : DecodeDataType := 'binary lob';
111        SQLT_BFILEE : DecodeDataType := 'binary file lob';
112        SQLT_CFILEE : DecodeDataType := 'character file lob';
113        SQLT_RSET : DecodeDataType := 'result set type';
114        SQLT_NCO : DecodeDataType := 'named collection type (varray or nested table)';
115        SQLT_VST : DecodeDataType := 'OCIString type';
116        SQLT_ODT : DecodeDataType := 'OCIDate type';
117    else DecodeDataType := 'Unknown';
118    end;
119  end;
120
121  procedure FieldListClear;
122  var
123        x: longint;
124        PDesc: PDescribeRec;
125  begin
126        if FieldList.Count = 0 then Exit;
127        for x := 0 to FieldList.Count - 1 do
128        begin
129            PDesc := FieldList[x];
130            Dispose(PDesc);
131        end;
132        FieldList.Clear;
133  end;
134
135       procedure Describe;
136       var
137        fldc    : longint;
138        paramd  : POCIParam;
139        colname : PChar;
140        colsize : ub4;
141        Rec     : PDescribeRec;
142       begin
143        fldc := 1;
144
145        FieldListClear;
146        ecode := OCIParamGet(Stmt, OCI_HTYPE_STMT, Err, paramd, fldc);
147        if ecode <> OCI_SUCCESS then
148            ORAError(ecode, Err, 'OCIParamGetError');
149        while ecode = OCI_SUCCESS do
150        begin
151            New(Rec);
152            FillChar(Rec^.buf, sizeof(Rec^.buf), #0);
153            ecode := OCIAttrGet(paramd, OCI_DTYPE_PARAM, @Rec^.dbtype, nil,
154                OCI_ATTR_DATA_TYPE, Err);
155            if ecode <> 0 then
156            begin
157                ORAError(ecode, Err, 'Retrieving DTYPE_PARAM:');
158            end;
159            colsize := 0;
160            colname := nil;
161            ecode := OCIAttrGet(paramd, OCI_DTYPE_PARAM, @colname, @colsize,
162                OCI_ATTR_NAME, Err);
163            if ecode <> 0 then
164            begin
165                ORAError(ecode, Err, 'Retrieving DTYPE_PARAM:');
166            end;
167            Move(Colname^,Rec^.buf, colsize);
168            Rec^.buflen := colsize;
169//          WriteLn('Column: ',Rec^.buf:15,'    DataType: ',DecodeDataType(Rec^.dbtype));
170            inc(fldc);
171
172            FieldList.Add(Rec);
173            ecode := OCIParamGet(Stmt, OCI_HTYPE_STMT, Err, paramd, fldc);
174        end;
175    end;
176
177    procedure Define;
178    var
179        x : longint;
180        def: POCIDefine;
181        PDesc : PDescribeRec;
182        defptr: pointer;
183        deflen: sword;
184        deftyp: sword;
185    begin
186        def := nil;
187        for x := 0 to FieldList.Count - 1 do
188        begin
189            PDesc := FieldList[x];
190            case PDesc^.dbtype of
191                SQLT_NUM: begin
192                    if PDesc^.scale <> 0 then
193                    begin
194                        defptr := @PDesc^.flt_buf;
195                        deflen := SizeOf(PDesc^.flt_buf);
196                        deftyp := SQLT_FLT;
197                        PDesc^.dbtype := SQLT_FLT;
198                    end
199                    else begin
200              if PDesc^.dbsize > 4 then
201              begin
202                // WriteLn('BIG FAT WARNING!!!! dbsize int > 4 (',PDesc^.dbsize,')');
203                defptr := @PDesc^.int64_buf;
204                deflen := SizeOf(PDesc^.int64_buf);
205                deftyp := SQLT_INT;
206                PDesc^.dbtype := SQLT_INT;
207              end
208              else begin
209                defptr := @PDesc^.int_buf;
210                            deflen := SizeOf(PDesc^.int_buf);
211                            deftyp := SQLT_INT;
212                            PDesc^.dbtype := SQLT_INT;
213              end;
214                    end;
215                end;
216                else begin
217                    defptr := @PDesc^.valbuf;
218                    deflen := cDescribeBuf;
219                    deftyp := PDesc^.dbtype;
220                end;
221            end;
222            ecode := OCIDefineByPos(Stmt, def, Err, x + 1, defptr,
223                deflen, deftyp, @PDesc^.indp, @PDesc^.col_retlen,
224                @PDesc^.col_retcode, OCI_DEFAULT);
225            if ecode <> 0 then
226            begin
227                OraError(ecode, Err, 'OCIDefineByPos: ');
228            end;
229        end;
230    end;
231
232    procedure OraError( errcode : integer; err: POCIError; msg : string );
233    var
234        buff : array [0..1024] of char;
235
236    begin
237        if err <> nil then
238        begin
239            case errcode of
240                OCI_INVALID_HANDLE: Msg := Msg + ' OCI_INVALID_HANDLE';
241            end;
242            OCIErrorGet( err, 1, nil, errcode, @buff[0], 1024, OCI_HTYPE_ERROR);
243            writeln(stderr, msg, ' ', buff);
244        end
245        else begin
246            WriteLn(stderr, msg);
247            Halt(1);
248        end;
249    end;
250
251    procedure OraInit;
252    begin
253        ecode := OCIInitialize({OCI_DEFAULT or }OCI_OBJECT, nil, nil, nil, nil);
254        if ecode <> 0 then OraError( ecode, nil, 'Error initializing OCI');
255        ecode := OCIEnvInit(Env, OCI_DEFAULT, 0, nil);
256        if ecode <> 0 then OraError( ecode, nil, 'Error initializing OCI environment');
257        ecode := OCIHandleAlloc(Env, Err, OCI_HTYPE_ERROR, 0, nil);
258        if ecode <> 0 then OraError( ecode, nil, 'Error allocating error handle');
259        ecode := OCIHandleAlloc(Env, Stmt, OCI_HTYPE_STMT, 0, nil);
260        if ecode <> 0 then OraError( ecode, nil, 'Error allocating statement handle');
261    end;
262
263    procedure OraLogin(name, pass, server: string);
264    begin
265        ecode := OCILogon(Env, Err, Svc, @name[1], Length(name),
266            @pass[1], Length(pass), @server[1], Length(server));
267        if ecode <> 0 then OraError(ecode, Err, '');
268    end;
269
270    procedure OraLogout;
271    begin
272        ecode := OCILogoff(Svc, Err);
273        if ecode <> 0 then
274            OraError(ecode, Err, 'OCILogoff: ');
275    end;
276
277    procedure OraFin;
278    begin
279        OCIHandleFree(Stmt, OCI_HTYPE_STMT);
280        OCIHandleFree(Err, OCI_HTYPE_ERROR);
281    end;
282
283    procedure OraSQLExec(sql: string);
284    var
285        dtype: longint;
286    begin
287//    writeLn(Length(sql));
288        ecode := OCIStmtPrepare(Stmt, Err, @sql[1], Length(sql),
289            OCI_NTV_SYNTAX, OCI_DEFAULT);
290        if ecode <> 0 then
291        begin
292            OraError(ecode, Err, 'OCIStmtPrepare:');
293            Exit;
294        end;
295
296    dtype := cPrefetchCnt;
297    ecode := OCIAttrSet(Stmt, OCI_HTYPE_STMT, @dtype,
298      SizeOf(dtype), OCI_ATTR_PREFETCH_ROWS, Err);
299        if ecode <> 0 then
300        begin
301            OraError(ecode, Err, 'ociattrset:');
302            Exit;
303        end;
304
305        dtype := 0;
306        ecode := OCIAttrGet(Stmt, OCI_HTYPE_STMT, @dtype, nil,
307            OCI_ATTR_STMT_TYPE, Err);
308        if ecode <> 0 then
309        begin
310            OraError(ecode, Err, 'ociattrget:');
311            Exit;
312        end;
313
314        ecode := 0;
315        if dtype = OCI_STMT_SELECT then
316            ecode := OCIStmtExecute(Svc, Stmt, Err, 0, 0, nil, nil, OCI_DEFAULT)
317        else ecode := OCIStmtExecute(Svc, Stmt, Err, 1, 0, nil, nil, OCI_DEFAULT);
318        if ecode <> 0 then
319        begin
320            OraError(ecode, Err, 'OCIStmtExecute:');
321            Exit;
322        end;
323
324        if dtype = OCI_STMT_SELECT then
325        begin
326            Describe;
327            Define;
328        end;
329    end;
330
331    function OraGetFieldCount : integer;
332    begin
333        OraGetFieldCount := FieldList.Count;
334    end;
335
336    function IsFieldDate(Pos : integer): boolean;
337    var
338      Desc : TDescribeRec;
339    begin
340      Result := False;
341      if (Pos > FieldList.Count) or (Pos < 1) then
342        Exit;
343      Desc := TDescribeRec(FieldList[Pos-1]^);
344      Result := (Desc.dbtype = SQLT_DAT);
345    end;
346
347    function OraGetFieldAsString(pos : integer) : string;
348    var
349        Desc : TDescribeRec;
350    Date : array [0..6] of byte;
351    begin
352        if (Pos > FieldList.Count) or (Pos < 1) then
353            Exit;
354        Desc := TDescribeRec(FieldList[pos-1]^);
355    if Desc.indp < 0 then
356    begin
357      OraGetFieldAsString := 'null';
358      Exit;
359    end;
360        if Desc.dbtype = SQLT_STR then
361        begin
362            Desc.valbuf[Desc.col_retlen] := #0;
363            OraGetFieldAsString := strpas(Desc.valbuf);
364        end
365        else if Desc.dbtype = SQLT_CHR then
366        begin
367            Desc.valbuf[Desc.col_retlen] := #0;
368            OraGetFieldAsString := strpas(Desc.valbuf);
369        end
370        else if Desc.dbtype = SQLT_INT then
371    begin
372            OraGetFieldAsString := IntToStr(Desc.int_buf);
373    end
374        else if Desc.dbtype = SQLT_FLT then
375            OraGetFieldAsString := FloatToStr(Desc.flt_buf)
376        else if Desc.dbtype = SQLT_DAT then
377    begin
378        Move(Desc.valbuf,Date,SizeOf(Date));
379            OraGetFieldAsString :=
380          Format('%0.2d.%0.2d.%0.4d %0.2d:%0.2d:%0.2d',
381          [Date[3],Date[2],(((Date[0]-100)*100)+(Date[1] - 100)),
382           Date[4]-1,
383           Date[5]-1,
384           Date[6]-1]);
385    end
386        else if Desc.dbtype = SQLT_AFC then
387        begin
388            Desc.valbuf[Desc.col_retlen] := #0;
389            OraGetFieldAsString := strpas(Desc.valbuf);
390        end
391        else OraGetFieldAsString := 'dbtype not implemented ' + IntToStr(Desc.dbtype);
392    end;
393
394    function OraGetFieldAsInteger(pos : integer) : longint;
395    begin
396        OraGetFieldAsInteger := 0;
397    end;
398
399    function OraNext: boolean;
400    begin
401        ecode := OCIStmtFetch(Stmt, Err, 1, OCI_FETCH_NEXT, OCI_DEFAULT);
402        if ecode = 0 then
403            OraNext := true
404        else if ecode = OCI_SUCCESS_WITH_INFO then
405            OraNext := false
406        else if ecode = OCI_NO_DATA then
407            OraNext := false
408        else begin
409            OraNext := false;
410            OraError(ecode, err, 'OCIStmtFetch:');
411        end;
412    end;
413
414    function OraGetFieldType(pos : integer) : longint;
415    begin
416      if (Pos > FieldList.Count) or (pos < 1) then
417        Exit;
418      OraGetFieldType := TDescribeRec(FieldList[pos-1]^).dbtype;
419    end;
420
421    function OraGetFieldName(pos : integer) : string;
422    begin
423        if (Pos > FieldList.Count) or (Pos < 1) then
424            Exit;
425        OraGetFieldName := strpas(TDescribeRec(FieldList[pos-1]^).buf);
426    end;
427
428initialization
429
430    FieldList := TList.Create;
431
432finalization
433
434    FieldListClear;
435    FieldList.Free;
436
437end.
438