tntadodb.pas

TntExUpdate 是 流行的 TntUnicodeControls控件的扩展包.包括很难找到的 TntJVCL 也在里面. TntSysUtils2.pas/TntSysUtilsEx.pa

{ 03/12/2006
  solved a bug StrMoveW, etc. when Delphi7 and up versions
  add TntADOSB.dcr }

unit TntADODB;

interface

{$I TntCompilers.INC}

uses
  Classes, SysUtils, TntClasses, DB, ADODB, ADOInt, TntDB;

const
  DefaultMacroChar = '%';

type
  TTntCustomADODataSet = class(TCustomADODataSet)
  private
    procedure UpdateIndexDefs_FixedForAdo27;
    function SetFieldData_IsNeeded(Field: TField; Buffer: Pointer; NativeFormat: Boolean):
      Boolean;
  private
    FLookupCursor: _Recordset;
    function LocateRecord(const KeyFields: AnsiString;
      const KeyValues: OleVariant; Options: TLocateOptions;
      SyncCursor: Boolean): Boolean;
  protected
    procedure OpenCursor(InfoQuery: Boolean); override;
    function GetFieldClass(FieldType: TFieldType): TFieldClass; override;
    procedure InternalInitFieldDefs; override;
    procedure UpdateIndexDefs; override;
    procedure DoBeforeOpen; override;
    procedure DoAfterOpen; override;
    procedure DoAfterClose; override;
    procedure DoAfterInsert; override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); override;
    procedure DestroyLookupCursor; override;
    procedure DataEvent(Event: TDataEvent; Info: Longint); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
    function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean;
      override;
    function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; override;
    function Locate(const KeyFields: AnsiString; const KeyValues: Variant;
      Options: TLocateOptions): Boolean; override;
    function Lookup(const KeyFields: AnsiString; const KeyValues: Variant;
      const ResultFields: AnsiString): Variant; override;
  end;

  TTntADOQuery = class(TTntCustomADODataSet)
  private
    FSQL: TTntStrings;
    FRowsAffected: Integer;
    FMacros: TParams;
    FMacroChar: Char;
    FStreamPatternChanged: Boolean;
    FPatternChanged: Boolean;

    function GetSQL: TTntStrings;
    procedure SetSQL(const Value: TTntStrings);
    function GetMacroCount: Word;
    function GetMacros: TParams;
    procedure SetMacroChar(const Value: Char);
    procedure SetMacros(const Value: TParams);
    procedure CreateMacros(List: TParams; const Value: PWideChar);
    procedure PatternChanged(Sender: TObject);
    function GetCommandText: WideString;
  protected
    procedure Expand(ToSQL: TTntStrings); virtual;
    procedure RecreateMacros;
    procedure Loaded; override;
    procedure OpenCursor(InfoQuery: Boolean); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ExecSQL: Integer; {for TQuery compatibility}
    procedure ExpandMacros;
    function MacroByName(const Value: string): TParam;

    property RowsAffected: Integer read FRowsAffected;
    property MacroCount: Word read GetMacroCount;
  published
    property CommandText: WideString read GetCommandText;
    property MacroChar: Char read FMacroChar write SetMacroChar default DefaultMacroChar;
    property CommandTimeout;
    property DataSource;
    property EnableBCD;
    property ParamCheck;
    property Parameters;
    property Prepared;
    property SQL: TTntStrings read GetSQL write SetSQL;
    property Macros: TParams read GetMacros write SetMacros;
  end;

  TTntADOStoredProc = class(TTntCustomADODataSet)
  public
    constructor Create(AOwner: TComponent); override;
    procedure ExecProc;
  published
    property CommandTimeout;
    property DataSource;
    property EnableBCD;
    property ProcedureName: WideString read GetCommandText write SetCommandText;
    property Parameters;
    property Prepared;
  end;


implementation

{ TTntADOQuery }

uses
  TntSysUtils{$IFDEF COMPILER_6_UP}, Variants{$ENDIF},
  {$IFNDEF COMPILER_9_UP}TntWideStrUtils,{$ENDIF} ActiveX;

type
  TAccessADOCommand = class(TADOCommand)
  end;

  TAccessCustomADODataSet = class(TCustomADODataSet)
  end;

function NameDelimiter(C: WideChar; Delims: TSysCharSet): Boolean;
begin
  Result := (Word(C) < 256) and ((Char(C) in [' ', ',', ';', ')', #13, #10]) or (Char(C) in
    Delims));
end;

function IsLiteral(C: WideChar): Boolean;
begin
  Result := (C = '''') or (c = '"');
end;

procedure CreateQueryParams(List: TParams; const Value: PWideChar; Macro: Boolean;
  SpecialChar: WideChar; Delims: TSysCharSet);
var
  CurPos, StartPos: PWideChar;
  CurChar: WideChar;
  Literal: Boolean;
  EmbeddedLiteral: Boolean;
  Name: string;

  function StripLiterals(Buffer: PWideChar): WideString;
  var
    Len: Word;
    TempBuf: PWideChar;

    procedure StripChar(Value: WideChar);
    begin
      if TempBuf^ = Value then
       {$IFDEF COMPILER_10_UP}
        StrMoveW(TempBuf, TempBuf + 1, Len - 1);
       {$ELSE}
        WStrMove(TempBuf, TempBuf + 1, Len - 1);
       {$ENDIF}
     {$IFDEF COMPILER_9_UP}
      if TempBuf[StrLenW(TempBuf) - 1] = Value then
        TempBuf[StrLenW(TempBuf) - 1] := #0;
     {$ELSE}
      if TempBuf[WStrLen(TempBuf) - 1] = Value then
        TempBuf[WStrLen(TempBuf) - 1] := #0;
     {$ENDIF}
    end;

  begin
   {$IFDEF COMPILER_9_UP}
    Len := (StrLenW(Buffer) + 1) * 2;
   {$ELSE}
    Len := (WStrLen(Buffer) + 1) * 2;
   {$ENDIF}
    TempBuf := AllocMem(Len);
    Result := '';
    try
     {$IFDEF COMPILER_9_UP}
      StrCopyW(TempBuf, Buffer);
     {$ELSE}
      WStrCopy(TempBuf, Buffer);
     {$ENDIF}
      StripChar('''');
      StripChar('"');
      Result := WStrPas(TempBuf);
    finally
      FreeMem(TempBuf, Len);
    end;
  end;

begin
  if SpecialChar = #0 then
    Exit;
  CurPos := Value;
  Literal := False;
  EmbeddedLiteral := False;
  repeat
    CurChar := CurPos^;
    if (CurChar = SpecialChar) and not Literal and ((CurPos + 1)^ <> SpecialChar) then
    begin
      StartPos := CurPos;
      while (CurChar <> #0) and (Literal or not NameDelimiter(CurChar, Delims)) do
      begin
        Inc(CurPos);
        CurChar := CurPos^;
        if IsLiteral(CurChar) then
        begin
          Literal := not Literal;
          if CurPos = StartPos + 1 then
            EmbeddedLiteral := True;
        end;
      end;
      CurPos^ := #0;
      if EmbeddedLiteral then
      begin
        Name := StripLiterals(StartPos + 1);
        EmbeddedLiteral := False;
      end
      else
        Name := WStrPas(StartPos + 1);
      if Assigned(List) then
      begin
        if List.FindParam(Name) = nil then
        begin
          if Macro then
            List.CreateParam(ftWideString, Name, ptInput).Value := '(0=0)'
          else
            List.CreateParam(ftUnknown, Name, ptUnknown);
        end;
      end;
      CurPos^ := CurChar;
      StartPos^ := '?';
      Inc(StartPos);
     {$IFDEF COMPILER_10_UP}
      StrMoveW(StartPos, CurPos, StrLenW(CurPos) + 1);
     {$ELSE}
      WStrMove(StartPos, CurPos,
       {$IFDEF COMPILER_9_UP}
        StrLenW(CurPos) + 1);
       {$ELSE}
        WStrLen(CurPos) + 1);
       {$ENDIF}
     {$ENDIF}
      CurPos := StartPos;
    end
    else
      if (CurChar = SpecialChar) and not Literal and ((CurPos + 1)^ = SpecialChar) then
       {$IFDEF COMPILER_10_UP}
        StrMoveW(CurPos, CurPos + 1, StrLenW(CurPos) + 1)
       {$ELSE}
        WStrMove(CurPos, CurPos + 1,
         {$IFDEF COMPILER_9_UP}
          StrLenW(CurPos) + 1)
         {$ELSE}
          WStrLen(CurPos) + 1)
         {$ENDIF}
       {$ENDIF}
      else
        if IsLiteral(CurChar) then
          Literal := Literal xor True;
    Inc(CurPos);
  until CurChar = #0;
end;

//-----------------------------------------------

function GetFilterStr(Field: TField; Value: Variant; Partial: Boolean = False): WideString;
var
  Operator,
    FieldName,
    QuoteCh: WideString;
begin
  QuoteCh := '';
  Operator := '=';
  FieldName := Field.FieldName;
  if Pos(' ', FieldName) > 0 then
    FieldName := WideFormat('[%s]', [FieldName]);
  if VarIsNull(Value) or VarIsClear(Value) then
    Value := 'Null'
  else
    case Field.DataType of
      ftDate, ftTime, ftDateTime:
        QuoteCh := '#';
      ftString, ftFixedChar, ftWideString:
        begin
          if Partial and (Value <> '') then
          begin
            Value := Value + '*';
            Operator := ' like '; { Do not localize }
          end;
          if Pos('''', Value) > 0 then
            QuoteCh := '#' else
            QuoteCh := '''';
        end;
    end;
  Result := WideFormat('(%s%s%s%s%2:s)', [FieldName, Operator, QuoteCh, VarToWideStr(Value)]);
end;

procedure TTntCustomADODataSet.DestroyLookupCursor;
begin
  FLookupCursor := nil;
  inherited;
end;

function TTntCustomADODataSet.LocateRecord(const KeyFields: AnsiString;
  const KeyValues: OleVariant; Options: TLocateOptions;
  SyncCursor: Boolean): Boolean;
var
  Fields: TList;
  Buffer: PAnsiChar;
  I, FieldCount: Integer;
  Partial: Boolean;
  SortList, FieldExpr, LocateFilter: WideString;
  SizeOfTRecInfo: Integer;
begin
  Result := False;
  CheckBrowseMode;
  UpdateCursorPos;
  CursorPosChanged;
  Buffer := TempBuffer;
  Partial := loPartialKey in Options;
  Fields := TList.Create;
  DoBeforeScroll;
  try
    try
      GetFieldList(Fields, KeyFields);
      if not Assigned(FLookupCursor) then
        FLookupCursor := Recordset.Clone(adLockReadOnly);
      if CursorLocation = clUseClient then
      begin
        for I := 0 to Fields.Count - 1 do
          with TField(Fields[I]) do
            if Pos(' ', FieldName) > 0 then
              SortList := WideFormat('%s[%s],', [SortList, FieldName]) else
              SortList := WideFormat('%s%s,', [SortList, FieldName]);
        SetLength(SortList, Length(SortList) - 1);
        if FLookupCursor.Sort <> SortList then
          FLookupCursor.Sort := SortList;
      end;
      FLookupCursor.Filter := '';
      InitRecord(Buffer);
      FieldCount := Fields.Count;
      if FieldCount = 1 then begin
        if (VarIsNull(KeyValues))
          and (TField(Fields[0]).Required)
          and (CursorLocation = clUseClient) then begin
          result := False;
          exit;
        end else
          FLookupCursor.Find(GetFilterStr(FieldByName(KeyFields), KeyValues, Partial), 0,
            adSearchForward, EmptyParam)
      end else
      begin
        for I := 0 to FieldCount - 1 do
        begin
          FieldExpr := GetFilterStr(Fields[I], KeyValues[I], (Partial and (I = FieldCount -
            1)));
          if LocateFilter <> '' then
            LocateFilter := LocateFilter + ' AND ' + FieldExpr else { Do not localize }
            LocateFilter := FieldExpr;
        end;
        FLookupCursor.Filter := LocateFilter;
      end;
    finally
      Fields.Free;
    end;
    Result := not FLookupCursor.EOF;
    if Result then
      if SyncCursor then
      begin
        Recordset.Bookmark := FLookupCursor.Bookmark;
        if Recordset.EOF or Recordset.BOF then
        begin
          Result := False;
          CursorPosChanged;
        end
      end
      else
        { For lookups, read all field values into the temp buffer }
        for I := 0 to Self.Fields.Count - 1 do
          with Self.Fields[I] do
            if FieldKind = fkData then begin
              SizeOfTRecInfo := GetRecordSize - (Self.Fields.Count * SizeOf(OleVariant));
{$IFOPT R+}
{$RANGECHECKS OFF}
              PVariantList(Buffer + SizeOfTRecInfo)[Index] := FLookupCursor.Fields[FieldNo -
                1].Value;
{$RANGECHECKS ON}
{$ELSE}
              PVariantList(Buffer + SizeOfTRecInfo)[Index] := FLookupCursor.Fields[FieldNo -
                1].Value;
{$ENDIF}
            end;
  except
    Result := False;
  end;
end;

function TTntCustomADODataSet.Lookup(const KeyFields: AnsiString; const KeyValues: Variant;
  const ResultFields: AnsiString): Variant;
begin
  Result := Null;
  if LocateRecord(KeyFields, KeyValues, [], False) then
  begin
    SetTempState(dsCalcFields);
    try
      CalculateFields(TempBuffer);
      Result := FieldValues[ResultFields];
    finally
      RestoreState(dsBrowse);
    end;
  end;
end;

function TTntCustomADODataSet.Locate(const KeyFields: AnsiString; const KeyValues: Variant;
  Options: TLocateOptions): Boolean;

  function IndexFieldsMatch(const KeyFields: AnsiString): Boolean;
  var
    i: Integer;
    FieldList: TList;
  begin
    result := False;
    // seek might be possible
    if WideSameText(IndexName, KeyFields) then
      // pretty good guess!
      result := True
    else if IndexFieldCount = 1 then
      result := WideSameText(IndexFields[0].FieldName, KeyFields)
    else if IndexFieldCount > 1 then begin
      // compare field list
      FieldList := TList.create;
      try
        GetFieldList(FieldList, KeyFields);
        if FieldList.Count = IndexFieldCount then begin
          // same number of fields
          result := True; {prove it wrong}
          for i := 0 to FieldList.Count - 1 do begin
            if FieldList[i] <> IndexFields[i] then begin
              result := False;
              break; { found one that didn't match }
            end;
          end;
        end;
      finally
        FieldList.Free;
      end;
    end;
  end;

begin
  if (not (loPartialKey in Options))
    and (not Filtered)
    and Supports([coSeek])
    and IndexFieldsMatch(KeyFields) then begin
    { seek is much faster }
    Result := Seek(KeyValues, soFirstEQ)
  end else begin
    { normal locate }
    DoBeforeScroll;
    Result := LocateRecord(KeyFields, KeyValues, Options, True);
    if Result then
    begin
      Resync([rmExact, rmCenter]);
      DoAfterScroll;
    end;
  end;
end;

procedure TTntCustomADODataSet.DataEvent(Event: TDataEvent; Info: Integer);
begin
{$IFDEF COMPILER_7} // Bug fix for Delphi 7 TDataSet.DisableControls
  if (Event = deUpdateState) and ControlsDisabled then
    inherited DataEvent(deDisabledStateChange, Info)
  else
{$ENDIF}
    inherited;
end;

{ TTntCustomADODataSet }

constructor TTntCustomADODataSet.Create(AOwner: TComponent);
begin
  inherited;
end;

destructor TTntCustomADODataSet.Destroy;
begin
  inherited;
end;

function TTntCustomADODataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
begin
  Result := GetTntFieldClass(inherited GetFieldClass(FieldType));
  // ADO has TWideStringField, use that if you want Unicode
  if Result = TTntStringField then
    Result := TStringField {TNT-ALLOW TStringField};
end;

procedure TTntCustomADODataSet.InternalInitFieldDefs;
var
  f: Integer;