xquery.pas

TxQuery is an SQL engine implemented in a TDataSet descendant component, that can parse SQL syntax,

{$IFDEF level3}
    Function GetFieldData(Field: TField; Buffer: Pointer): Boolean; Override;
{$ENDIF}

    Procedure PopulateDatasets(TableList: TTableList); Virtual;
    Procedure DisposeDatasets; Virtual; { LAS : 05-30-2000 }
    Procedure PackTable(TableList: TTableList); Virtual;
    Procedure ZapTable(TableList: TTableList); Virtual;
    Procedure ReindexTable(TableList: TTableList); Virtual;

    { properties }
    Property DataSets: TxDataSets Read fDataSets Write SetDataSets;
    Property AllSequenced: Boolean Read fAllSequenced Write fAllSequenced;

    Property InMemResultSet: Boolean Read fInMemResultSet Write fInMemResultSet Default True;
    Property MapFileSize: Longint Read fMapFileSize Write fMapFileSize Default 2000000;

  Public
    { methods }
    Constructor Create(AOwner: TComponent); Override;
    Destructor Destroy; Override;

{$IFDEF LEVEL4}
    Function GetFieldData(Field: TField; Buffer: Pointer): Boolean; Override;
    Procedure SetBlockReadSize(Value: Integer); Override;
{$ENDIF}
    Function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; Override;
    Function IsSequenced: Boolean; Override;
    Function IsDataSetDisabled(DataSet: TDataSet): Boolean;
    Function Locate(Const KeyFields: String;
      Const KeyValues: Variant;
      Options: TLocateOptions): Boolean; Override;
    Function Lookup(Const KeyFields: String;
      Const KeyValues: Variant;
      Const ResultFields: String): Variant; Override;
    Function BookmarkValid(Bookmark: TBookmark): boolean; Override;
    Function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; Override;

    Procedure _ReadRecord(Buffer: PChar; IntRecNum: Integer);
    Function Find(Const Expression: String): Boolean;
    Function ResultSetIsSequenced: Boolean;
    Procedure ExecSQL;
    Procedure Disconnect;
    Procedure Prepare;
    Procedure UnPrepare;
    Function ParamByName(Const Value: String): TParam;

    { not so common procedures }
    Procedure AddDataSet(DataSet: TDataSet; Const Alias: String);
    Procedure ClearDatasets;
    Function DataSetByName(Const Name: String): TDataSet;
    Function SourceDataSet: TDataSet;
    Procedure WriteToTextFile(Const FileName: String;
      FieldDelimChar, TxtSeparator: Char; IsCSV: Boolean; FieldNames: TStringList);
    Procedure ExecSQLScript;
    Procedure SortByColumns(Const Columns: Array Of integer; Descending: Boolean);
    Function SourceBookmark: TBookmark;

    { properties }
    Property DisabledDataSets: TList read fDisabledDataSets;  { mainly used internally}
    Property ResultSet: TResultSet Read fResultSet;           { mainly used internally}
    Property ParamCount: Word Read GetParamsCount;
    Property Prepared: Boolean Read GetPrepared Write SetPrepare;
    Property ReadOnly: Boolean Read fReadOnly Write fReadOnly Default False;
    Property RecNo: Integer Read GetRecNo Write SetRecNo;
    { scripts }
    Property ScriptStatementType: TSQLStatement Read fScriptStatementType Write fScriptStatementType;
    Property ScriptIsRunning: Boolean Read fScriptIsRunning Write fScriptIsRunning;
    Property ResultSetIsDefined: Boolean Read fResultSetIsDefined Write fResultSetIsDefined;
    Property RowsAffected: Integer Read fRowsAffected Write fRowsAffected;
    Property RefFields: TStrings Read fRefFields;
    Property WithDummies: Boolean read fWithDummies write fWithDummies;

    { new events }
    Property OnIndexNeededFor: TIndexNeededForEvent Read fOnIndexNeededFor Write fOnIndexNeededFor;
    Property OnSetRange: TSetRangeEvent Read fOnSetRange Write fOnSetRange;
    Property OnCancelRange: TCancelRangeEvent Read fOnCancelRange Write fOnCancelRange;
    Property OnBlobNeeded: TBlobNeededEvent Read fOnBlobNeeded Write fOnBlobNeeded;
    Property OnCreateTable: TCreateTableEvent Read fOnCreateTable Write fOnCreateTable;
    Property OnAlterTable: TCreateTableEvent Read fOnAlterTable Write fOnAlterTable;
    Property OnCreateIndex: TCreateIndexEvent Read fOnCreateIndex Write fOnCreateIndex;
    Property OnDropTable: TDropTableEvent Read fOnDropTable Write fOnDropTable;
    Property OnDropIndex: TDropIndexEvent Read fOnDropIndex Write fOnDropIndex;
    Property OnSetFilter: TSetFilterEvent Read fOnSetFilter Write fOnSetFilter;
    Property OnCancelFilter: TCancelFilterEvent Read fOnCancelFilter Write fOnCancelFilter;

  Published
    Property DataSource: TDataSource Read GetDataSource Write SetDataSource;
    Property SQL: Tstrings Read fSQL Write SetQuery;
    Property SQLScript: Tstrings Read fSQLScript Write SetSQLScript;
    Property Params: TParams Read fParams Write SetParamsList Stored False;
    Property ParamCheck: Boolean Read fParamCheck Write fParamCheck Default True;
    Property About: String Read GetAbout Write SetAbout;
    Property AutoDisableControls: Boolean Read fAutoDisableControls Write fAutoDisableControls Default True;
    Property UseDisplayLabel: Boolean Read fUseDisplayLabel Write fUseDisplayLabel Default False;
    Property DateFormat: String Read fDateFormat Write fDateFormat;
    Property ShowWaitCursor: Boolean Read fShowWaitCursor Write fShowWaitCursor Default true;
    Property WhereOptimizeMethod: TOptimizeMethod Read fWhereOptimizeMethod Write fWhereOptimizeMethod Default omSetFilter;
    Property ParamsAsFields: TParamsAsFields read fParamsAsFields write SetParamsAsFields;
    { inherited properties }
    Property Active;
    Property Filter;
    Property Filtered;

    { new events }
    Property OnUDFCheck: TUDFCheckEvent Read fOnUDFCheck Write fOnUDFCheck;
    Property OnUDFSolve: TUDFSolveEvent Read fOnUDFSolve Write fOnUDFSolve;
    Property OnProgress: TXProgressEvent Read fOnProgress Write fOnProgress;
    Property OnBeforeQuery: TNotifyEvent Read fOnBeforeQuery Write fOnBeforeQuery;
    Property OnAfterQuery: TNotifyEvent Read fOnAfterQuery Write fOnAfterQuery;
    Property OnSyntaxError: TSyntaxErrorEvent Read fOnSyntaxError Write fOnSyntaxError;
    Property OnCancelQuery: TCancelQueryEvent Read fOnCancelQuery Write fOnCancelQuery;
    Property OnResolveDataset: TResolveDatasetEvent Read fOnResolveDataset Write fOnResolveDataset;
    Property OnScriptError: TQueryScriptErrorEvent Read fOnScriptError Write fOnScriptError;
    Property OnQueryFieldName: TQueryFieldNameEvent Read fOnQueryFieldName Write fOnQueryFieldName;
    Property OnSetUserRange: TSetUserRangeEvent Read fOnSetUserRange Write fOnSetUserRange;
    Property OnCancelUserRange: TCancelUserRangeEvent Read fOnCancelUserRange Write fOnCancelUserRange;

    { inherited events }
    Property BeforeOpen;
    Property AfterOpen;
    Property BeforeClose;
    Property AfterClose;
    Property BeforeInsert;
    Property AfterInsert;
    Property BeforeEdit;
    Property AfterEdit;
    Property BeforePost;
    Property AfterPost;
    Property BeforeCancel;
    Property AfterCancel;
    Property BeforeDelete;
    Property AfterDelete;
    Property BeforeScroll;
    Property AfterScroll;
    Property OnCalcFields;
    Property OnDeleteError;
    Property OnEditError;
    Property OnFilterRecord;
    Property OnNewRecord;
    Property OnPostError;
  End;

  {-------------------------------------------------------------------------------}
  {                  Define TxQuery                                               }
  {-------------------------------------------------------------------------------}

  TxQuery = Class(TCustomXQuery)
  Published
    { properties }
    Property DataSets;

    { events }
    Property OnIndexNeededFor;
    Property OnSetRange;
    Property OnCancelRange;
    Property OnBlobNeeded;
    Property OnCreateTable;
    Property OnAlterTable;
    Property OnCreateIndex;
    Property OnDropTable;
    Property OnDropIndex;
    Property OnSetFilter;
    Property OnCancelFilter;
  End;

{$IFDEF XQDEMO}
Procedure ShowAbout;
{$ENDIF}

{$IFDEF DELPHI3}
Const
  ftNonTextTypes = [ftBytes, ftvarBytes, ftBlob, ftMemo, ftGraphic, ftFmtMemo,
    ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor];
{$ENDIF}

Implementation

{ zip file password: A01DB36C-7D13-4331-825A-11C5F7D83225 }

Uses
{$IFDEF XQDEMO}
  DemoReg,
{$ENDIF}
  xqLex, xqYacc, xqConsts, CnvStrUtils;

Function VarTypeToExprType(Const Value: Variant): TExprType;
Begin
  Case VarType(Value) Of
    varSingle, varDouble, varCurrency, varDate: result := ttFloat;
    varSmallint, varByte, varInteger: result := ttInteger;
    varBoolean: result := ttBoolean;
  Else
    result := ttstring;
  End;
End;

{-------------------------------------------------------------------------------}
{                  Define as a demo section                                     }
{-------------------------------------------------------------------------------}

{$IFDEF xqdemo}
Var
  IsFirstTime: Boolean = True;

Procedure ShowAbout;
Begin
  With TfrmRegister.Create(Nil) Do
  Begin
    Try
      ShowModal;
    Finally
      free;
    End;
  End;
End;
{$ENDIF}

{-------------------------------------------------------------------------------}
{                  Implements TxqField                                          }
{-------------------------------------------------------------------------------}

Constructor TxqField.Create(Fields: TxqFields; FieldNo: Integer);
Begin
  Inherited Create;
  fFields := Fields;
  fFieldNo := FieldNo;
End;

Function TxqField.GetData(Buffer: Pointer): Boolean;
Begin
  Result := fFields.ResultSet.GetFieldData(Self, Buffer);
End;

Procedure TxqField.SetData(Buffer: Pointer);
Begin
  fFields.ResultSet.SetFieldData(Self, Buffer);
End;

Procedure TxqField.SetDataType(Value: TExprType);
Begin
  fDataType := Value;
End;

Function TxqField.GetIsNull: Boolean;
Begin
  Result := fFields.ResultSet.GetIsNull(Self);
End;

{ LAS : 5/JUN/2002 }
Procedure TxqField.SetIsNull;
Begin
  fFields.ResultSet.SetIsNull(Self);
End;

Function TxqField.GetAsBoolean: Boolean;
Begin
  Raise ExQueryError.Create(SReadBooleanField);
End;

Function TxqField.GetAsFloat: double;
Begin
  Raise ExQueryError.Create(SReadFloatField);
End;

Function TxqField.GetAsInteger: Longint;
Begin
  Raise ExQueryError.Create(SReadIntegerField);
End;

Function TxqField.GetAsstring: String;
Begin
  Raise ExQueryError.Create(SReadstringField);
End;

Procedure TxqField.SetAsstring(Const Value: String);
Begin
  Raise ExQueryError.Create(SwritestringField);
End;

Function TxqField.GetAsVariant: Variant;
Begin
  Raise ExQueryError.Create(SReadstringField);
End;

Procedure TxqField.SetAsVariant(Const Value: Variant);
Begin
  If VarIsNull(Value) Then
    Clear
  Else
    SetVarValue(Value);
End;

Procedure TxqField.SetAsFloat(Value: double);
Begin
  Raise ExQueryError.Create(SwriteFloatField);
End;

Procedure TxqField.SetAsInteger(Value: Longint);
Begin
  Raise ExQueryError.Create(SwriteIntegerField);
End;

Procedure TxqField.SetAsBoolean(Value: Boolean);
Begin
  Raise ExQueryError.Create(SwriteBooleanField);
End;

Function TxqField.GetColWidth: Integer;
Begin
  If Assigned(fSourceField) Then
  Begin
    If fSourceField.DataType In [ftstring{$IFDEF LEVEL4}, ftFixedChar,
    ftWidestring{$ENDIF}
{$IFDEF LEVEL5}, ftGUID{$ENDIF}] Then
      Result := fSourceField.Size
    Else
      Result := fSourceField.DataSize;
  End
  Else
    Result := fDataSize;
End;

{-------------------------------------------------------------------------------}
{                  Implements TxqStringField                                    }
{-------------------------------------------------------------------------------}

Constructor TxqStringField.Create(Fields: TxqFields; FieldNo: Integer);
Begin
  Inherited Create(Fields, FieldNo);
  SetDataType(ttstring);
End;

Procedure TxqStringField.Clear;
Begin
  SetAsstring('');
  SetIsNull;
End;

Function TxqStringField.GetValue(Var Value: String): Boolean;
Var
  Buffer: Array[0..dsMaxstringSize] Of Char;
Begin
  Result := GetData(@Buffer);
  If Result Then
    Value := Buffer;
End;

Function TxqStringField.GetAsstring: String;
Begin
  If Not GetValue(Result) Then
    Result := '';
End;

Function TxqStringField.GetAsFloat: double;
Begin
  Result := StrToFloat(GetAsstring);
End;

Function TxqStringField.GetAsVariant: Variant;
Var
  S: String;
Begin
  If GetValue(S) Then Result:= S Else Result:= Null;
End;

Procedure TxqStringField.SetVarValue(const Value: Variant);
Begin
  SetAsString(Value);
End;

Function TxqStringField.GetAsInteger: Longint;
Begin
  Result := StrToInt(GetAsstring);
End;

Function TxqStringField.GetAsBoolean: Boolean;
Var
  S: String;