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