oradb.pas

delphi通过OCI访问ORACLE

    mystmthp:pOCIStmt;
begin
 if not FActive then exit;

 case FOraTransIsolationLevel of
  tiReadCommited   : str:='SET TRANSACTION ISOLATION LEVEL READ COMMITTED'; // don't translate
  tiRepeatableRead : str:='SET TRANSACTION ISOLATION LEVEL SERIALIZABLE';   // don't translate
  tiReadOnly       : str:='SET TRANSACTION READ ONLY';                      // don't translate
  tiDefault        : exit;
 end;

 // setting Isolation Level for current beginning transaction
 TestError('OCIHandleAlloc - ',OCIHandleAlloc(myenvhp,mystmthp,OCI_HTYPE_STMT,0,nil));

 TestError('OCIStmtPrepare - ',OCIStmtPrepare(mystmthp,dberrhp,str,strlen(str),OCI_NTV_SYNTAX,OCI_DEFAULT));

 TestError('OCIStmtExecute ',OCIStmtExecute(mysvchp,mystmthp,dberrhp,1,0,nil,nil,OCI_DEFAULT));

 TestError('OCIHandleFree - ',OCIHandleFree(mystmthp,OCI_HTYPE_STMT));
end;

procedure TOraDB.SetSQLTrace;
var str:array[0..256] of char;
    mystmthp:pOCIStmt;
begin
 if not FActive then exit;
 if FConnectAs=caSYSOPER then exit; // SYSOPER does not have privileges to execute smth like "alter session set sql_trace = true"

 case FSQLTrace of
  stTrue    : str:='alter session set sql_trace = true';    // don't translate
  stFalse   : str:='alter session set sql_trace = false';   // don't translate
  stDefault : exit;
 end;

 // setting sql_trace for current session
 TestError('OCIHandleAlloc - ',OCIHandleAlloc(myenvhp,mystmthp,OCI_HTYPE_STMT,0,nil));

 TestError('OCIStmtPrepare - ',OCIStmtPrepare(mystmthp,dberrhp,str,strlen(str),OCI_NTV_SYNTAX,OCI_DEFAULT));

 TestError('OCIStmtExecute ',OCIStmtExecute(mysvchp,mystmthp,dberrhp,1,0,nil,nil,OCI_DEFAULT));

 TestError('OCIHandleFree - ',OCIHandleFree(mystmthp,OCI_HTYPE_STMT));
end;


procedure TOraDB.Open;
var str:array[0..1023] of char;
    Accept:boolean;
    ConnAs:array[TOraConnectAs] of integer;
begin
 ConnAs[caNormal]  := OCI_DEFAULT;
 ConnAs[caSYSDBA]  := OCI_SYSDBA;
 ConnAs[caSYSOPER] := OCI_SYSOPER;

 InitOCI;

 Accept := True;
 if Assigned(FBeforeLoginEvent) then FBeforeLoginEvent(self, FServer, FName, FPassword, Accept);
 if not Accept then exit;

 if FLoginPrompt then
  if not LoginDialogEx(FServer, FName, FPassword, False) then
      ADatabaseErrorFmt(SOraErrLogin, [FServer]);

 if @OCIEnvCreate = nil then begin
  TestError('OCIInitialize ', OCIInitialize(OCI_DEFAULT {OCI_THREADED}, nil, nil, nil, nil));
  TestError('OCIEnvInit ',    OCIEnvInit(myenvhp, OCI_DEFAULT, 0, nil));
 end else
  TestError('OCIEnvCreate',   OCIEnvCreate(myenvhp, OCI_DEFAULT, nil, nil, nil, nil, 0, nil));

 // allocation of handlers
 TestError('OCIHandleAlloc ', OCIHandleAlloc(myenvhp, mysrvhp, OCI_HTYPE_SERVER, 0, nil));
 TestError('OCIHandleAlloc ', OCIHandleAlloc(myenvhp, dberrhp, OCI_HTYPE_ERROR,  0, nil));
 TestError('OCIHandleAlloc ', OCIHandleAlloc(myenvhp, mysvchp, OCI_HTYPE_SVCCTX, 0, nil));
 strpcopy(str, FServer);

 // initialization mysrvhp (server context handle)
 TestError('OCIServerAttach ', OCIServerAttach(mysrvhp, dberrhp, @str, strlen(str), OCI_DEFAULT));

 // create association between server and service context handlers
 TestError('OCIAttrSet ',     OCIAttrSet(mysvchp, OCI_HTYPE_SVCCTX, mysrvhp, 0, OCI_ATTR_SERVER, dberrhp));
 TestError('OCIHandleAlloc ', OCIHandleAlloc(myenvhp, myusrhp, OCI_HTYPE_SESSION, 0, nil));
 strpcopy(str, FName);
 TestError('OCIAttrSet ',     OCIAttrSet(myusrhp, OCI_HTYPE_SESSION, @str, strlen(str), OCI_ATTR_USERNAME, dberrhp));
 strpcopy(str, FPassword);
 TestError('OCIAttrSet ',      OCIAttrSet(myusrhp, OCI_HTYPE_SESSION, @str, strlen(str), OCI_ATTR_PASSWORD, dberrhp));
 TestError('OCISessionBegin ', OCISessionBegin(mysvchp, dberrhp, myusrhp, OCI_CRED_RDBMS, ConnAs[FConnectAs]{OCI_DEFAULT}));
 TestError('OCIAttrSet ',      OCIAttrSet(mysvchp, OCI_HTYPE_SVCCTX, myusrhp, 0, OCI_ATTR_SESSION, dberrhp));
 FActive := True;

 SetSQLTrace;
 SetSessionIsolationLevel;

 if Assigned(FAfterLoginEvent) then FAfterLoginEvent(self);
end;

procedure TOraDB.Close;
begin
 if not FActive then exit;
 CloseLinkedDataSets; // we need to close all DataSets which are linked to this OraDB.

// doing RollBack if RollbackOnDisconnect is set
 if FRollbackOnDisconnect
   then RollbackTransaction;

 //??? may be we need to add OCITransCommit here ???

 FInTransaction:=False;
 TestError('OCISessionEnd ',OCISessionEnd(mysvchp,dberrhp,myusrhp,OCI_DEFAULT));
 TestError('OCIServerDetach ',OCIServerDetach(mysrvhp,dberrhp,OCI_DEFAULT));
 TestError('OCIHandleFree ',OCIHandleFree(mysrvhp,OCI_HTYPE_SERVER));
 TestError('OCIHandleFree ',OCIHandleFree(mysvchp,OCI_HTYPE_SVCCTX));
 TestError('OCIHandleFree ',OCIHandleFree(myusrhp,OCI_HTYPE_SESSION));
 TestError('OCIHandleFree ',OCIHandleFree(dberrhp,OCI_HTYPE_ERROR));
 TestError('OCIHandleFree ',OCIHandleFree(myenvhp,OCI_HTYPE_ENV));
 FActive:=False;

 FreeLibrary(hDll);
 FStarted:=False;
end;

procedure TOraDB.Break;
begin
 TestError('OCIBreak ',OCIBreak(mysvchp,dberrhp));
end;

function TOraDB.GetActive:boolean;
begin
 Result:=FActive;
end;

procedure TOraDB.SetActive(Value:boolean);
begin
  if (csReading in ComponentState) then  begin
    if Value then FStreamedActive := True;
    exit;
  end;
 if (csDestroying in ComponentState) then exit;
 if Value and not Active then Open;
 if not Value and Active then Close;
end;

procedure TOraDB.StartTransaction;
begin
 if not Active then begin
  raise Exception.Create(sOraErrDatabaseNotActive);
 end;

 SetTransIsolationLevel;

// TestError('OCIHandleFree ',OCITransStart(mysvchp,dberrhp,30,OCI_TRANS_NEW+OCI_TRANS_SERIALIZABLE));
 FInTransaction:=True;

 if Assigned(FOnStartTransaction) then FOnStartTransaction(self);
end;

procedure TOraDB.CommitTransaction;
begin
 if not Active then begin
  raise Exception.Create(sOraErrDatabaseNotActive);
 end;

 if Assigned(FBeforeCommit) then FBeforeCommit(self);

 TestError('OCITransCommit ',OCITransCommit(mysvchp,dberrhp,OCI_DEFAULT));
 FInTransaction:=False;

 if Assigned(FAfterCommit) then FAfterCommit(self);
end;

procedure TOraDB.RollbackTransaction;
begin
 if not Active then begin
  raise Exception.Create(sOraErrDatabaseNotActive);
 end;

 if Assigned(FOnRollback) then FOnRollback(self);

 TestError('OCITransRollback ',OCITransRollback(mysvchp,dberrhp,OCI_DEFAULT));
 FInTransaction:=False;
end;

procedure TOraDB.LoadOCIPaths;
var
    s: string;
    i, n: Integer;
    reg: TRegistry;
    defhome:string;

begin
    reg := TRegistry.Create;
    try
        reg.RootKey := HKEY_LOCAL_MACHINE;
//{ $IFDEF OCI_D4}
//            if reg.OpenKeyReadOnly('\Software\Oracle\All_Homes') then begin
//{ $ELSE}
            if reg.OpenKeyReadOnly('\Software\Oracle\All_Homes'{, False}) then begin
//{ $ENDIF}
                defhome :=reg.ReadString('DEFAULT_HOME');
                s := reg.ReadString('HOME_COUNTER');
                if s = ''
                  then n := 0
                  else n := StrToInt(s);

                i := 0;
                while i<n do begin
                  s := '\Software\Oracle\Home' + IntToStr(i);
                  if reg.OpenKeyReadOnly(s) then
                    if AnsiCompareText(defhome, reg.ReadString('ORACLE_HOME_NAME'))=0 then begin
                      FOraRegKey  := s;
                      FOraHome    := reg.ReadString('ORACLE_HOME');
                      FOraDllName := reg.ReadString('ORAOCI');
                      FOraIsPO8   := (CompareText(reg.ReadString('PO8'), 'YES') = 0);
                      i := n;//break;
                    end;
                  inc(i);
               end;
            end;

        if FOraHome = '' then
             ADatabaseError(sOraErrOCINotInstalled, nil);
        if FOraDllName = '' then begin
            FOraDllName := FOraHome + '\bin\'+OraLibName;
            // single case, than things differs - 8.0.3
            if not FileExists(FOraDllName) then begin
               FOraDllName := FOraHome + '\bin\ora803.dll';
               if not FileExists(FOraDllName) then
                  ADatabaseError(sOraErrOCINotInstalled, nil);
            end;      
        end;
    finally
        reg.Free;
    end;
end;

procedure TOraDB.LoadTNSPaths;
var
    reg: TRegistry;
begin
    reg := TRegistry.Create;
    try
        reg.RootKey := HKEY_LOCAL_MACHINE;
//{ $IFDEF OCI_D4}
//        reg.OpenKeyReadOnly(FOCIKey);
//{ $ELSE}
        reg.OpenKeyReadOnly(FOraRegKey{, False});
//{ $ENDIF}
        FOraTnsNames := reg.ReadString('TNS_NAMES');
        if FOraTnsNames = '' then begin
            FOraTnsNames := CorrectPath(reg.ReadString('TNS_ADMIN'));
            if FOraTnsNames = '' then begin
                if FOraDllVersion >= OraVer81000 then
                    FOraTnsNames := CorrectPath(reg.ReadString('NETWORK'))
                else
                    FOraTnsNames := CorrectPath(reg.ReadString('NET80'));
                if FOraTnsNames = '' then begin
                    if FOraDllVersion >= OraVer81000 then
                        FOraTnsNames := FOraHome + '\Network'
                    else
                        FOraTnsNames := FOraHome + '\net80';
                end;
                FOraTnsNames := FOraTnsNames + '\ADMIN';
            end;
            FOraTnsNames := FOraTnsNames + '\tnsnames.ora';
        end;
    finally
        reg.Free;
    end;
end;

procedure TOraDB.GetOCIVersion;
const
    verstr:string = '\StringFileInfo\040904B0\FileVersion';
    undef:string = '<UNDEFINED>';
var
    hndl, sz: DWORD;
    buf: pointer;
    len: UINT;
    pStrVer, errbuf: PChar;
    s:string;
begin
    FOraDllVersion := 0;
    pStrVer := nil;
    sz := GetFileVersionInfoSize(PChar(FOraDllName), hndl);
    if sz > 0 then begin
      GetMem(buf, sz);
      try
        if GetFileVersionInfo(PChar(FOraDllName), hndl, sz, buf) then
          if VerQueryValue(buf, PChar(verstr), Pointer(pStrVer), Len)
            then FOraDllVersion := VerStr2Int(pStrVer);
      finally
        FreeMem(buf, sz);
      end;
    end
    else begin
      FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
                   nil, GetLastError(), (SUBLANG_DEFAULT shl 10) or LANG_NEUTRAL,
                   PChar(@errbuf), 0, nil);
      s := errbuf;
      LocalFree(HLOCAL(errbuf));
      ADatabaseErrorFmt(sOraErrOCIVersionInfoAbsent, [s], nil);  //OCIDBErrorFmt(msgOCINotLoaded, [s], nil);
    end;

    if FOraDllVersion < OraVer80000 then begin
      if pStrVer = nil
        then  pStrVer := PChar(undef);
      ADatabaseErrorFmt(sOraErrBadOCIVersion, [StrPas(pStrVer)], nil);
    end;
end;

procedure TOraDB.GetServicesList(AList: TStrings);
var
    InComment, InStr: Boolean;
    pCh, pStParam: PChar;
    s, buff: String;
    BraceLevel: Integer;
    f: TFileStream;
begin
    InitOCI;
    AList.Clear;
    if FOraIsPO8 then
        AList.Add('<LOCAL>');
    try
        f := TFileStream.Create(FOraTnsNames, fmOpenRead or fmShareDenyWrite);
        try
            SetLength(buff, f.Size);
            f.Read(PChar(Buff)^, f.Size);
        finally
            f.Free;
        end;
    except
        Exit;
    end;
    InComment := False;
    InStr := False;
    BraceLevel := 0;
    pCh := PChar(Buff) - 1;
    repeat
        Inc(pCh);
        case pCh^ of
        '#':
            begin
                if not InComment and not InStr then
                    InComment := True;
            end;
        '''':
            if not InComment then
                InStr := not InStr;
        '(':
            if not InComment and not InStr then
                Inc(BraceLevel);
        ')':
            if not InComment and not InStr then
                Dec(BraceLevel);
        #13, #10:
            if InComment then
                InComment := False;
        'a'..'z', 'A'..'Z', '0'..'9':
            if not InComment and not InStr and (BraceLevel = 0) then begin
                pStParam := pCh;
                while pCh^ in ['a'..'z', 'A'..'Z', '0'..'9', '#', '$', '_', '.', '-'] do
                    Inc(pCh);
                SetString(s, pStParam, pCh - pStParam);
                AList.Add(s);
                Dec(pCh);
            end;
        end;
    until (pCh^ = #0);
end;


end.