sqlexpr.pas

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

  ArgParam: pSPParamDesc;
begin
  for I := 0 to ProcParams.Count -1 do
  begin
    ArgParam := ProcParams.Items[I];
    with TParam(Params.Add) do
    begin
      Name := ArgParam.szName;
      ParamType := ArgParam.iArgType;
      DataType := ArgParam.iDataType;
      if ParamType <> ptInput then
        Size := ArgParam.iLen;
    end;
  end;
end;

{ TSQLBlobStream }

constructor TSQLBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode = bmRead);
begin
  if not Field.DataSet.Active then
    DataBaseError(SDatasetClosed);
  FField := Field;
  FDataSet := FField.DataSet as TCustomSQLDataSet;
  FFieldNo := FField.FieldNo;
  ReadBlobData;
end;

destructor TSQLBlobStream.Destroy;
begin
  inherited Destroy;
end;

procedure TSQLBlobStream.ReadBlobData;
var
  BlobLength: LongInt;
begin
  Clear;
  BlobLength := GetBlobSize(FDataSet, FFieldNo);
  SetSize(BlobLength);
  if BlobLength = 0 then Exit;
  if FDataSet.GetFieldData(FField, FDataSet.FBlobBuffer, True) then
    Write(pointer(FDataSet.FBlobBuffer)^, FDataSet.FCurrentBlobSize);
  Position := 0;
end;

{ TSQLParams }

type

{ TSQLParams }

  TSQLParams = class(TParams)
  private
    FFieldName: TStrings;
    FBindAllFields: Boolean;
    function ParseSelect(SQL: string; bDeleteQuery: Boolean): string;
    function ParseUpdate(SQL: string): string;
    function ParseInsert(SQL: string): string;
  public
    constructor Create(Owner: TPersistent);
    Destructor Destroy; override;
    function GetFieldName(index: Integer): string;
    function Parse(SQL: string; DoCreate: Boolean): string;
    property BindAllFields: Boolean read FBindAllFields;
  end;

constructor TSQLParams.Create(Owner: TPersistent);
begin
  inherited;
  FBindAllFields := False;
  FFieldName := TStringList.Create;
end;

destructor TSQLParams.Destroy;
begin
  inherited;
  FreeAndNil(FFieldName);
end;

function TSQLParams.GetFieldName(index: Integer): string;
begin
   Result := FFieldName[ index ];
end;

function TSQLParams.Parse(SQL: string; DoCreate: Boolean): string;
const
  SDelete = 'delete';      { Do not localize }
  SUpdate = 'update';      { Do not localize }
  SInsert = 'insert';      { Do not localize }
var
  Start: string;
begin
  Result := ParseSQL(SQL, DoCreate);
  Start := LowerCase(copy(Result, 1, 6));
{ attempt to determine fields and fieldtypes associated with params }
  if Start = SSelect then
    Result := ParseSelect(SQL, False)
  else if Start = SDelete then
    Result := ParseSelect(SQL, True)
  else if Start = SInsert then
    Result := ParseInsert(SQL)
  else if Start = SUpdate then
    Result := ParseUpdate(SQL)
  else
    Result := '';
end;

{ no attempt to match fields clause with values clause :
    types only added if all values are inserted }
function TSQLParams.ParseInsert(SQL: string): string;
var
  Start: PChar;
  Value: string;
  CurSection: TSQLToken;
begin
  Result := '';
  if Pos(' ' + SSelect + ' ', LowerCase(SQL)) > 1 then Exit;  // can't parse sub queries
  Start := PChar(SQL);
  CurSection := stUnknown;
  { move past 'insert ' }
  NextSQLToken(Start, Value, CurSection);
  { move past 'into ' }
  NextSQLToken(Start, Value, CurSection);
  { move past <TableName> }
  NextSQLToken(Start, Value, CurSection);

  { Check for owner qualified table name }
  if Start^ = '.' then
    NextSQLToken(Start, Value, CurSection);
  Result := Value;

  { move past 'set' }
  NextSQLToken(Start, Value, CurSection);
  if (LowerCase(Value) = 'values') then
    FBindAllFields := True;
end;

function TSQLParams.ParseSelect(SQL: string; bDeleteQuery: Boolean): string;
var
  FWhereFound: Boolean;
  Start: PChar;
  FName, Value: string;
  SQLToken, CurSection, LastToken: TSQLToken;
  Params: Integer;
begin
  Result := '';
  if bDeleteQuery = False then
  begin
    if Pos(' ' + SSelect + ' ', LowerCase(string(PChar(SQL)+8))) > 1 then Exit;  // can't parse sub queries
    Start := PChar(SQL);
  end else
  begin
    if Pos(' ' + SSelect + ' ', LowerCase(SQL)) > 1 then Exit;  // can't parse sub queries
    Start := PChar(SSelectStar + Copy(SQL, 8, Length(SQL) -7));
  end;
  CurSection := stUnknown;
  LastToken := stUnknown;
  FWhereFound := False;
  Params := 0;
  repeat
    repeat
      SQLToken := NextSQLToken(Start, FName, CurSection);
      if SQLToken in [stWhere] then
      begin
        FWhereFound := True;
        LastToken := stWhere;
      end else if SQLToken in [stTableName] then
      begin
        { Check for owner qualified table name }
        if Start^ = '.' then
          NextSQLToken(Start, FName, CurSection);
        Result := FName;
      end else
      if (SQLToken = stValue) and (LastToken = stWhere) then
        SQLToken := stFieldName;
      if SQLToken in SQLSections then CurSection := SQLToken;
    until SQLToken in [stFieldName, stEnd];
    if FWhereFound and (SQLToken in [stFieldName]) then
      repeat
        SQLToken := NextSQLToken(Start, Value, CurSection);
          if SQLToken in SQLSections then CurSection := SQLToken;
      until SQLToken in [stEnd,stValue,stIsNull,stIsNotNull,stFieldName];
    if Value='?' then
    begin
      FFieldName.Add(FName);
      Inc(Params);
    end;
  until (Params = Count) or (SQLToken in [stEnd]);
  if Result = '' then Result := GetTableNameFromSql(SQL);
end;

function TSQLParams.ParseUpdate(SQL: string): string;
var
  Start: PChar;
  FName, Value: string;
  SQLToken, CurSection: TSQLToken;
  Params: Integer;
begin
  Result := '';
  if Pos(' ' + SSelect + ' ', LowerCase(SQL)) > 1 then Exit;  // can't parse sub queries
  Start := PChar(SQL);
  CurSection := stUnknown;
  { move past 'update ' }
  NextSQLToken(Start, FName, CurSection);
  { move past <TableName> }
  NextSQLToken(Start, FName, CurSection);

  { Check for owner qualified table name }
  if Start^ = '.' then
    NextSQLToken(Start, FName, CurSection);

  Result := FName;
  { move past 'set ' }
  NextSQLToken(Start, FName, CurSection);
  Params := 0;
  CurSection := stSelect;
  repeat
    repeat
      SQLToken := NextSQLToken(Start, FName, CurSection);
      if SQLToken in SQLSections then CurSection := SQLToken;
    until SQLToken in [stFieldName, stEnd];
    if Pos(LowerCase(FName), 'values(') > 0 then continue;   { do not localize }
    if Pos(LowerCase(FName), 'values (') > 0 then continue;  { do not localize }
    if SQLToken in [stFieldName] then
      repeat
        SQLToken := NextSQLToken(Start, Value, CurSection);
          if SQLToken in SQLSections then CurSection := SQLToken;
      until SQLToken in [stEnd,stValue,stIsNull,stIsNotNull,stFieldName];
    if Value='?' then
    begin
      FFieldName.Add(FName);
      Inc(Params);
    end;
  until (Params = Count) or (SQLToken in [stEnd]);
end;

{ TSQLMonitor }

constructor TSQLMonitor.Create(AOwner: TComponent);
begin
  FTraceList := TStringList.Create;
  FMaxTraceCount := -1;
  inherited;
end;

destructor TSQLMonitor.Destroy;
begin
  if Active then SetActive(False);
  SetSQLConnection(nil);
  inherited;
  FreeAndNil(FTraceList);
end;

procedure TSQLMonitor.SetFileName(const Value: String);
begin
  FFileName := Value;
end;

procedure TSQLMonitor.CheckInactive;
begin
  if FActive then
  begin
    if (csDesigning in ComponentState) or (csLoading in ComponentState) then
      SetActive(False)
    else
      DatabaseError(SMonitorActive, Self);
  end;
end;

procedure TSQLMonitor.SetSQLConnection(Value: TSQLConnection);
var
  IsActive: Boolean;
begin
  if Value <> FSQLConnection then
  begin
    IsActive := Active;
    CheckInactive;
    if Assigned(FSQLConnection) and not FKeepConnection then
      SQLConnection.UnregisterTraceMonitor(Self);
    FSQLConnection := Value;
    if Assigned(FSQLConnection) then
    begin
      FSQLConnection.RegisterTraceMonitor(Self);
      Active := IsActive;
    end;
  end;
end;

procedure TSQLMonitor.SwitchConnection(const Value: TSQLConnection);
var
  MonitorActive: Boolean;
begin
  FKeepConnection := True;
  MonitorActive := Active;
  if MonitorActive then
    SetActive(False);
  SQLConnection := Value;
  if MonitorActive and Assigned(Value) then
    SetActive(True);
  FKeepConnection := False;
end;

procedure TSQLMonitor.Trace(Desc: pSQLTraceDesc; LogTrace: Boolean);
begin
  if Assigned(FOnTrace) then
    FOnTrace(Self, Desc, LogTrace);
end;

function TSQLMonitor.InvokeCallBack(CallType: TRACECat; CBInfo: Pointer): CBRType; stdcall;
var
  Desc: pSQLTraceDesc;
  LogTrace: Boolean;
  Msg: string;
begin
  Result := cbrUSEDEF;
  if csDestroying in ComponentState then exit;
  Desc := pSQLTraceDesc(CBInfo);
  LogTrace := (TSQLTraceFlag(CallType) in FTraceFlags) or (FTraceFlags = []);
  Trace(Desc, LogTrace);
  if LogTrace then
  begin
    SetLength(Msg, StrLen(Desc.pszTrace));
    Move(Desc.pszTrace[0], PChar(Msg)[0], StrLen(Desc.pszTrace));
    if (FMaxTraceCount = -1) or (TraceCount < FMaxTraceCount) then
      FTraceList.Add(Msg);
    if Assigned(FOnLogTrace) then
      FOnLogTrace(Self, Desc);
    if FAutoSave and (FFileName <> '') then
      SaveToFile('');
  end;
end;

function SQLCallBack(CallType: TRACECat; CBInfo: Pointer): CBRType; stdcall;
begin
  Result := cbrUSEDEF;
  if CBInfo <> nil then
    Result := TSQLMonitor(PSQLTraceDesc(CBInfo).ClientData).InvokeCallback(CallType, CBInfo);
end;

procedure TSQLMonitor.SetActive(Value: Boolean);
var
  FileHandle: Integer;
begin
  if FActive <> Value then
  begin
    if (csReading in ComponentState) then
      FStreamedActive := Value
    else begin
      if not (csDestroying in ComponentState) and not Assigned(FSQLConnection) then
        DatabaseError(SConnectionNameMissing)
      else
      begin
        if Value and (FileName <> '') then
        begin
          if not FileExists(FileName) then
          begin
            FileHandle := FileCreate(FileName);
            if FileHandle = -1 then
              DatabaseErrorFmt(SCannotCreateFile, [FileName])
            else
              FileClose(FileHandle);
          end;
        end;
        if Assigned(FSQLConnection) then
        begin
          if Value then
            FSQLConnection.SetTraceCallbackEvent(SQLCallBack, Integer(Self))
          else
            FSQLConnection.SetTraceCallbackEvent(nil, Integer(0));
        end;
        FActive := Value;
      end;
    end;
  end;
end;

procedure TSQLMonitor.SetStreamedActive;
begin
  if FStreamedActive then
    SetActive(True);
end;

function TSQLMonitor.GetTraceCount: Integer;