dbtables.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

function GetParamDataSize(Param: TParam): Integer;
begin
  with Param do
    if ((DataType in [ftString, ftFixedChar]) and (Length(VarToStr(Value)) > 255)) or
       (DataType in [ftBlob..ftTypedBinary,ftOraBlob,ftOraClob]) then
      Result := SizeOf(BlobParamDesc) else
      Result := GetDataSize;
end;

procedure GetParamData(Param: TParam; Buffer: Pointer; const DrvLocale: TLocale);

  function GetNativeStr: PChar;
  begin
    Param.NativeStr := VarToStr(Param.Value);
    Result := PChar(Param.NativeStr);
    if DrvLocale <> nil then
      AnsiToNativeBuf(DrvLocale, Result, Result, StrLen(Result));
  end;

begin
  with Param do
    if DataType in [ftString, ftFixedChar, ftMemo]  then
    begin
      NativeStr := VarToStr(Value);
      if (Length(NativeStr) > 255) or (DataType = ftMemo) then
      begin
        with BlobParamDesc(Buffer^) do
        begin
          if DrvLocale <> nil then
            AnsiToNativeBuf(DrvLocale, PChar(NativeStr), PChar(NativeStr), Length(NativeStr));
          pBlobBuffer := PChar(NativeStr);
          ulBlobLen := StrLen(pBlobBuffer);
        end;
      end else
      begin
        if (DrvLocale <> nil) then
          AnsiToNativeBuf(DrvLocale, PChar(NativeStr), Buffer, Length(NativeStr) + 1) else
          GetData(Buffer);
      end;
    end
    else if (DataType in [ftBlob..ftTypedBinary,ftOraBlob,ftOraClob]) then
    begin
      with BlobParamDesc(Buffer^) do
      begin
        NativeStr := VarToStr(Value);
        ulBlobLen := Length(NativeStr);
        pBlobBuffer := PChar(NativeStr);
      end;
    end else
      GetData(Buffer);
end;

function GetStatementLocale(StmtHandle: HDBIStmt): TLocale;
var
  DrvName: DBINAME;
  NumBytes: Word;
begin
  DrvName[0] := #0;
  Result := nil;
  DbiGetProp(HDBIOBJ(StmtHandle), stmtLANGDRVNAME, @DrvName, SizeOf(DrvName), NumBytes);
  if StrLen(DrvName) > 0 then OsLdLoadBySymbName(DrvName, Result);
end;

procedure FreeStatementLocale(var Value: TLocale);
begin
  if Value <> nil then OsLdUnloadObj(Value);
  Value := nil;
end;

{ Any fixes made to this utility procedure should also be investigated for the
  TStoredProcedure. }
procedure SetQueryParams(Sender: TComponent; StmtHandle: HDBIStmt; Params: TParams);
var
  I: Integer;
  NumBytes: Word;
  FieldDescs: TFieldDescList;
  RecBuffer: PChar;
  CurPtr, NullPtr: PChar;
  DrvLocale: TLocale;
begin
  SetLength(FieldDescs, Params.Count);
  NumBytes := SizeOf(SmallInt);
  for I := 0 to Params.Count - 1 do
    Inc(NumBytes, GetParamDataSize(Params[I]));
  RecBuffer := AllocMem(NumBytes);
  NullPtr := RecBuffer + NumBytes - SizeOf(SmallInt);
  Smallint(Pointer(NullPtr)^) := -1;
  CurPtr := RecBuffer;
  try
    DrvLocale := GetStatementLocale(StmtHandle);
    try
      for I := 0 to Params.Count - 1 do
        with FieldDescs[I], Params[I] do
        begin
          iFldType := FldTypeMap[DataType];
          if iFldType in [fldBlob, fldZString] then
            iSubType := FldSubTypeMap[DataType]
          else if iFldType = fldUNKNOWN then
            DatabaseErrorFmt(SNoParameterValue, [Name], Sender);
          iFldNum := I + 1;
          iLen := GetParamDataSize(Params[I]);
          GetParamData(Params[i], CurPtr, DrvLocale);
          iOffset := CurPtr - RecBuffer;
          if IsNull then
            iNullOffset := NullPtr - RecBuffer
          else if iFldType = fldZString then
            iUnits1 := GetDataSize - 1 {Do not include null terminator}
          else if iFldType = fldBYTES then
            iUnits1 := GetDataSize
          else if iFldType = fldVARBYTES then
            iUnits1 := GetDataSize - 2
          else if iFldType = fldBlob then
            iSubType := FldSubTypeMap[DataType];
          Inc(CurPtr, iLen);
        end;
      Check(DbiQSetParams(StmtHandle, High(FieldDescs)+1,
        PFLDDesc(FieldDescs), RecBuffer));
    finally
      FreeStatementLocale(DrvLocale);
    end;
  finally
    FreeMem(RecBuffer);
  end;
end;

{ Timer callback function }

procedure FreeTimer(ForceKill: Boolean = False);
begin
  if (TimerID <> 0) and (ForceKill or (GetTickCount - StartTime > SQLDelay)) then
  begin
    KillTimer(0, TimerID);
    TimerID := 0;
    StartTime := 0;
    if Assigned(DBScreen) then
      DBScreen.Cursor := dcrDefault;
  end;
end;

procedure TimerCallBack(hWnd: HWND; Message: Word; TimerID: Word;
  SysTime: LongInt); stdcall;
begin
  FreeTimer;
end;

{ BdeCallbacks }

function BdeCallBack(CallType: CBType; Data: Longint;
  CBInfo: Pointer): CBRType; stdcall;
begin
  if (Data <> 0) then
    Result := TBDECallback(Data).Invoke(CallType, CBInfo) else
    Result := cbrUSEDEF;
end;

function DLLDetachCallBack(CallType: CBType; Data: Longint;
  CBInfo: Pointer): CBRType; stdcall;
begin
  Session.FDLLDetach := True;
  Sessions.CloseAll;
  Result := cbrUSEDEF
end;

constructor TBDECallback.Create(AOwner: TObject; Handle: hDBICur; CBType: CBType;
  CBBuf: Pointer; CBBufSize: Integer; CallbackEvent: TBDECallbackEvent;
  Chain: Boolean);
begin
  FOwner := AOwner;
  FHandle := Handle;
  FCBType := CBType;
  FCallbackEvent := CallbackEvent;
  DbiGetCallBack(Handle, FCBType, @FOldCBData, @FOldCBBufLen, @FOldCBBuf, FOldCBFunc);
  if not Assigned(FOldCBFunc) or Chain then
  begin
    Check(DbiRegisterCallback(FHandle, FCBType, Longint(Self), CBBufSize,
      CBBuf, BdeCallBack));
    FInstalled := True;
  end;
end;

destructor TBDECallback.Destroy;
begin
  if FInstalled then
  begin
    if Assigned(FOldCBFunc) then
    try
      DbiRegisterCallback(FHandle, FCBType, FOldCBData, FOldCBBufLen,
        FOldCBBuf, FOldCBFunc);
    except
    end
    else
      DbiRegisterCallback(FHandle, FCBType, 0, 0, nil, nil);
  end;
end;

function TBDECallback.Invoke(CallType: CBType; CBInfo: Pointer): CBRType;
begin
  if CallType = FCBType then
    Result := FCallbackEvent(CBInfo) else
    Result := cbrUSEDEF;
  if Assigned(FOldCBFunc)
    then Result := FOldCBFunc(CallType, FOldCBData, CBInfo);
end;

{ Utility routines }

function StrToOem(const AnsiStr: string): string;
begin
  SetLength(Result, Length(AnsiStr));
  if Length(Result) > 0 then
    CharToOem(PChar(AnsiStr), PChar(Result));
end;

function AnsiToNative(Locale: TLocale; const AnsiStr: string;
  NativeStr: PChar; MaxLen: Integer): PChar;
var
  Len: Integer;
begin
  Len := Length(AnsiStr);
  if Len > MaxLen then
  begin
    Len := MaxLen;
    if SysLocale.FarEast and (ByteType(AnsiStr, Len) = mbLeadByte) then
      Dec(Len);
  end;
  NativeStr[Len] := #0;
  if Len > 0 then AnsiToNativeBuf(Locale, Pointer(AnsiStr), NativeStr, Len);
  Result := NativeStr;
end;

procedure NativeToAnsi(Locale: TLocale; NativeStr: PChar;
  var AnsiStr: string);
var
  Len: Integer;
begin
  Len := StrLen(NativeStr);
  SetString(AnsiStr, nil, Len);
  if Len > 0 then NativeToAnsiBuf(Locale, NativeStr, Pointer(AnsiStr), Len);
end;

procedure AnsiToNativeBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);
var
  DataLoss: LongBool;
begin
  if Len > 0 then
    if Locale <> nil then
    begin
      EnterCriticalSection(CSAnsiToNative);
      try
        DbiAnsiToNative(Locale, Dest, Source, Len, DataLoss);
      finally
        LeaveCriticalSection(CSAnsiToNative);
      end;
    end else
      CharToOemBuff(Source, Dest, Len);
end;

procedure NativeToAnsiBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);
var
  DataLoss: LongBool;
begin
  if Len > 0 then
    if Locale <> nil then
    begin
      EnterCriticalSection(CSNativeToAnsi);
      try
        DbiNativeToAnsi(Locale, Dest, Source, Len, DataLoss);
      finally
        LeaveCriticalSection(CSNativeToAnsi);
      end;
    end else
      OemToCharBuff(Source, Dest, Len)
end;

function NativeCompareStr(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
begin
  Result := NativeCompareStrBuf(Locale, PChar(S1), PChar(S2), Len);
end;

function NativeCompareStrBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;
begin
  if Len > 0 then
    Result := OsLdStrnCmp(Locale, S1, S2, Len) else
    Result := OsLdStrCmp(Locale, S1, S2);
end;

function NativeCompareText(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
begin
  Result := NativeCompareTextBuf(Locale, PChar(S1), PChar(S2), Len);
end;

function NativeCompareTextBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;
begin
  if Len > 0 then
    Result := OsLdStrnCmpi(Locale, S1, S2, Len) else
    Result := OsLdStrCmpi(Locale, S1, S2);
end;

function IsDirectory(const DatabaseName: string): Boolean;
var
  I: Integer;
begin
  Result := True;
  if (DatabaseName = '') then Exit;
  I := 1;
  while I <= Length(DatabaseName) do
  begin
    if DatabaseName[I] in [':','\'] then Exit;
    if DatabaseName[I] in LeadBytes then Inc(I, 2)
    else Inc(I);
  end;
  Result := False;
end;

function IsStandardType(AType: PChar): Boolean;
begin
  Result := (StrIComp(AType, szPARADOX) = 0) or
    (StrIComp(AType, szDBASE) = 0) or
    (StrIComp(AType, szFOXPRO) = 0);
    { Note: szASCII not included }
end;

function GetIntProp(const Handle: Pointer; PropName: Integer): Integer;
var
  Length: Word;
  Value: Integer;
begin
  Value := 0;
  if DbiGetProp(HDBIObj(Handle), PropName, @Value, SizeOf(Value), Length) = DBIERR_NONE then
    Result := Value
  else
    Result := 0;
end;

function SetBoolProp(const Handle: Pointer; PropName: Integer; Value: Bool): Boolean;
begin
  Result := DbiSetProp(HDBIObj(Handle), PropName, Abs(Integer(Value))) = DBIERR_NONE;
end;

function StringListToParams(List: TStrings): string;
var
  S: String;
  P, I: Integer;
begin
  for I := 0 to List.Count - 1 do
  begin
    S := List[I];
    P := Pos('=', S);
    if (P >= 0) and (P < Length(S)) then
      Result := Format('%s%s:"%s";', [Result, Copy(S, 1, P-1), Copy(S, P+1, 255)]);
  end