ex1u.pas

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

  {if not RadioGroupSQLExamples.ItemIndex in [33] then
     SyntaxHighlighter1.Editor := RichEdit1; }
  if Longint(Selected.Data)-1<>34 then   // "\" CHAR IS CAUSING PROBLEM TO THE TRichEdit
    SyntaxHighlighter1.Editor := RichEdit1;
  ButtonRunSQL.Enabled := True;

end;

procedure TfrmTest.TreeView1Change(Sender: TObject; Node: TTreeNode);
begin
  SelectionChange;
end;

procedure TfrmTest.ChkParseClick(Sender: TObject);
begin
  Panel12.Visible:= ChkParse.Checked;
  Splitter1.Visible:= ChkParse.Checked;
end;

procedure TfrmTest.ParseSQL;
var
  ErrLine, ErrCol: Integer;
  ErrMsg, Errtxt: string;
  Node: TTreeNode;

  procedure RecursePopulate(A: TSqlAnalizer; ParentNode: TTreeNode);
  var
    I: Integer;
    TempA: TSqlAnalizer;
    Node: TTreeNode;
  begin
    for I:= 0 to A.SubqueryList.Count-1 do
    begin
      TempA:= TSqlAnalizer(A.SubQueryList[0]);
      Node:= TreeView2.Items.AddChildObject(ParentNode, 'Subquery ' + IntToStr(I),  TempA);
      RecursePopulate(TempA, Node);
    end;
  end;

begin
  if Assigned(FAnalizer) then
  begin
    FAnalizer.Free;
    FAnalizer:= nil;
  end;
  FAnalizer:= TSqlAnalizer.Create(nil, xQuery1);
  if FAnalizer.parser.yyparse = 1 then
  begin
    ErrLine:= fAnalizer.lexer.yylineno;
    ErrCol:= fAnalizer.lexer.yycolno - fAnalizer.lexer.yyTextLen - 1;
    ErrMsg:= fAnalizer.parser.yyerrormsg;
    fAnalizer.lexer.GetyyText(ErrTxt);
    if Assigned(xQuery1.OnSyntaxError) then
    begin
      xQuery1.OnSyntaxError(Self, ErrMsg, ErrTxt, ErrLine, ErrCol, Length(ErrTxt));
      Exit;
    end
    else
      { if not raised an error, will raise here }
      raise Exception.CreateFmt(' %s at line : %d, Column: %d, token: %s',
        [ErrMsg, ErrLine, ErrCol, ErrTxt]);
  end;
  with TreeView2.Items do
  begin
    Clear;
    Node:= AddObject(nil, 'Top SQL', fAnalizer);
    RecursePopulate(fAnalizer, Node);
  end;
end;

procedure TfrmTest.TreeView2Click(Sender: TObject);
begin
  AnalizerChange;
end;

procedure TfrmTest.AnalizerChange;
var
  A: TSqlAnalizer;
  Selected: TTreeNode;
  s: string;
  I, J: Integer;
begin
  Selected := TreeView2.Selected;
  if (Selected=nil) or (Selected.Data=nil) then exit;
  A:= TSqlAnalizer(Selected.Data);
  { show all parameters for A }
  with MemoParse.Lines do
  begin
    clear;
    case A.Statement of
      ssSelect: s:= 'SELECT';
      ssUpdate: s:= 'UPDATE';
      ssDelete: s:= 'DELETE';
      ssInsert: s:= 'INSERT';
      ssUnion:  s:= 'UNION';
      ssCreateTable: s:= 'CREATETABLE';
      ssAlterTable:  s:= 'ALTERTABLE';
      ssCreateIndex: s:= 'CREATEINDEX';
      ssDropTable:   s:= 'DROPTABLE';
      ssDropIndex:   s:= 'DROPINDEX';
      ssPackTable:   s:= 'PACKTABLE';
      ssZapTable:    s:= 'ZAPTABLE';
      ssReindexTable: s:= 'REINDEXTABLE';
    end;
    Add(Format('Statement is : %s', [s]));

    if A.IsDistinct then
      Add('SELECT DISTINCT issued');
    if A.DoSelectAll then
      Add('SELECT * issued');
    if A.TableAllFields.Count> 0 then
    begin
      Add('The following tables include all fields');
      for I:= 0 to A.TableAllFields.Count-1 do
        Add(A.TableAllFields[I]);
    end;
    if A.ColumnList.Count>0 then
      Add('Columns follows :');
    for I:= 0 to A.ColumnList.Count-1 do
      with A.ColumnList[I] do
      begin
        Add(format('Column %d expression :%s', [I, ColumnExpr]));
        if Length(AsAlias) > 0 then
          Add(format('Alias %d: %s',[i, AsAlias]));
      end;
    if A.TableList.Count>0 then
      Add('Tables follows :');
    for I:= 0 to A.TableList.Count-1 do
      with A.TableList[I] do
      begin
        Add(format('Table %d Name :%s', [i,TableName]));
        if Length(Alias) > 0 then
          Add(format('Alias %d: %s', [i,Alias]));
      end;
    if A.JoinList.Count > 0 then
      Add('JOIN information follows:');
    for I:= 0 to A.JoinList.Count-1 do
      with A.JoinList[I] do
      begin
        for J:= 0 to Count-1 do
          Add('JOIN ON Expression :'+JoinExpression);
      end;

    if Length(A.WhereStr) > 0 then
      Add('WHERE expression: ' + A.WhereStr);

    if A.OrderByList.Count > 0 then
      for I:= 0 to A.OrderByList.Count-1 do
        with A.OrderByList[I] do
        begin
          if ColIndex > 0 then
            Add(format('Column %d index to order: %d',[ I, ColIndex]))
          else
            Add(format('ORDER BY %d expression: %s', [I, Alias]));
        end;

    if A.GroupByList.Count > 0 then
      for I:= 0 to A.GroupByList.Count-1 do
        with A.GroupByList[I] do
        begin
          if ColIndex > 0 then
            Add(format('Column %d index to group: %d', [I,ColIndex]))
          else
            Add(format('GROUP BY %d expression: %s',[I, Alias]));
        end;

    { other statements are not showed here: UPDATE, DELETE, INSERT, etc.
      but it is the same:

      A.UpdateColumnList for UPDATE
      A.InsertList for INSERT
      A.CreateTableList for CREATE TABLE
      A.AlterTableList for ALTER TABLE
      if Length(A.PivotStr) > 0 then   TRANSFORM...PIVOT issued
        A.PivotInList contains the pivots
        A.TransformColumnList contains the columns to pivot
      if Length(A.IntoTable)>0 then
        sintax: SELECT * FROM CUSTOMER INTO TABLE x
      if A.FromWithSubquery then
        sintax: SELECT * FROM (SELECT * FROM customer);
    }
  end;
end;

procedure TfrmTest.XQuery1SetRange(Sender: TObject;
  RelOperator: TRelationalOperator; DataSet: TDataSet; const FieldNames,
  StartValues, EndValues: String; IsJoining: Boolean);
Var
  F: TField;
Begin
  If RelOperator = ropBETWEEN Then Begin // Warning: this will fail with multiple fields "OrderNo;ItemNo"
    With DataSet As TTable Do Begin
      SetRangeStart;
      FieldByName(FieldNames).AsString := StartValues;
      SetRangeEnd;
      FieldByName(FieldNames).AsString := EndValues;
      ApplyRange;
    End;
  End Else If RelOperator In [ropGT, ropGE, ropLT, ropLE, ropNEQ] Then Begin // instead, will use a filter
    With DataSet As TTable Do Begin
      F := FindField(FieldNames);
      Case F.DataType Of
        FtString{$IFDEF LEVEL4}, FtFixedChar, FtWideString{$ENDIF}
           {$IFDEF LEVEL5}, FtGUID{$ENDIF}: Begin
            Case RelOperator Of
              ropGT: Filter := Format('%s > ''%s''', [FieldNames, StartValues]);
              ropGE: Filter := Format('%s >= ''%s''', [FieldNames, StartValues]);
              ropLT: Filter := Format('%s < ''%s''', [FieldNames, StartValues]);
              ropLE: Filter := Format('%s <= ''%s''', [FieldNames, StartValues]);
              ropNEQ: Filter := Format('%s <> ''%s''', [FieldNames, StartValues]);
            End;
            Filtered := True;
          End;
        FtFloat, FtCurrency, FtBCD, FtDate, FtTime, FtDateTime,
          FtAutoInc, FtSmallint, FtInteger, FtWord
          {$IFNDEF LEVEL3}, FtLargeInt{$ENDIF}, FtBoolean: Begin
            Case RelOperator Of
              ropGT: Filter := Format('%s > %s', [FieldNames, StartValues]);
              ropGE: Filter := Format('%s >= %s', [FieldNames, StartValues]);
              ropLT: Filter := Format('%s < %s', [FieldNames, StartValues]);
              ropLE: Filter := Format('%s <= %s', [FieldNames, StartValues]);
              ropNEQ: Filter := Format('%s <> %s', [FieldNames, StartValues]);
            End;
            Filtered := True;
          End;
      End;
    End;
  End;
end;

procedure TfrmTest.XQuery1CancelRange(Sender: TObject; DataSet: TDataSet;
  IsJoining: Boolean);
begin
  (DataSet As TTable).CancelRange; // if a range was set
  (DataSet As TTable).Filtered := False; // if was filtered
end;

procedure TfrmTest.XQuery1IndexNeededFor(Sender: TObject;
  DataSet: TDataSet; const FieldNames: String; ActivateIndex,
  IsJoining: Boolean; var Accept: Boolean);
begin
  if IsJoining then Exit;
  if not (Dataset is TTable) then
  Begin
    Accept:= False;
    Exit;
  End;
  If DataSet = Table1 Then Accept := (AnsiCompareText(FieldNames, 'CustNo') = 0)
  Else If DataSet = Table2 Then Accept := (AnsiCompareText(FieldNames, 'CustNo') = 0) Or (AnsiCompareText(FieldNames, 'OrderNo') = 0)
  Else If DataSet = Table3 Then Accept := (AnsiCompareText(FieldNames, 'OrderNo') = 0)
    Or (AnsiCompareText(FieldNames, 'OrderNo;ItemNo') = 0)
      Or (AnsiCompareText(FieldNames, 'PartNo') = 0)
  Else If DataSet = Table4 Then Accept := (AnsiCompareText(FieldNames, 'PartNo') = 0)
    Or (AnsiCompareText(FieldNames, 'Description') = 0)
      Or (AnsiCompareText(FieldNames, 'VendorNo') = 0);

  If Accept And ActivateIndex Then (DataSet As TTable).IndexFieldNames := FieldNames;
end;

procedure TfrmTest.XQuery1CancelFilter(Sender: TObject; DataSet: TDataSet;
  IsJoining: Boolean);
begin
  //ShowMessage('Filter canceled on dataset ' + Dataset.name);
  if not IsJoining then Exit;
  (DataSet as TTable).Filtered := False;
   (DataSet as TTable).Filter := '';
end;

procedure TfrmTest.XQuery1SetFilter(Sender: TObject; DataSet: TDataSet;
  const Filter: String; IsJoining: Boolean; var Handled: Boolean);
begin
  //ShowMessage(Format('Dataset name %s; Filter : %s', [Dataset.Name, Filter]));
  { Note: in this case, filters now needed, they are set in OnSetRange this is only to illustrate how to }
  //ShowMessage(Filter);
  if not IsJoining then Exit;
  { can this filter be set ?}
  try
     (DataSet as TTable).Filtered := False;
     (DataSet as TTable).Filter   := Filter;
     (DataSet as TTable).Filtered := True;
     Handled := True;
  except
     Handled := False;
     (DataSet as TTable).Filtered := False;
     raise;
  end;
end;

procedure TfrmTest.xQuery4BeforeInsert(DataSet: TDataSet);
begin
  SysUtils.Abort;
end;

procedure TfrmTest.XQuery1UDFCheck(Sender: TObject;
  const Identifier: String; Params: TParameterList;
  var DataType: TExprType; var MaxLen: Integer; var Accept: Boolean);
var
  I: Integer;  
begin
  If AnsiCompareText(Identifier, 'DTOS') = 0 Then Begin
    Accept := True;
    Datatype:= ttString;
    MaxLen:= 50;
    Exit;
  End Else If AnsiCompareText(Identifier, 'AVGOF') = 0 Then Begin
    {this function will take a list of parameters and will calculate the
      average of the integer or float parameters }
    If Not (Assigned(Params) And (Params.Count > 1)) Then Begin
      Accept := False;
      Exit;
    End;
    { check that the function have only integers and float parameters }
    For I := 0 To Params.Count - 1 Do Begin
      If Not (Params.ExprType[I] In [TtFloat, TtInteger]) Then Begin
        Accept := False;
        Exit;
      End;
    End;
    Accept := True;
    Datatype:= ttFloat;
    Exit;
  End Else If AnsiCompareText(Identifier, 'TRIMDC') = 0 Then Begin
    {this function will trim all "$" and "," from a string
     and will return a float
     example of use SELECT TRIMDC("$10,000.45") FROM MyTable }
    If Not (Assigned(Params) And (Params.Count = 1)) Then Begin
      Accept := False;
      Exit;
    End;
    {check that the function have only string parameters}
    If Not (Params.ExprType[0] = TtString) Then Begin
      Accept := False;
      Exit;
    End;
    Accept:= True;
    Datatype:= ttFloat;
    Exit;
  End;
end;

procedure TfrmTest.XQuery1UDFSolve(Sender: TObject;
  const Identifier: String; Params: TParameterList; var Value: Variant);
Var
  I: Integer;
  Temp: Double;
  TempS, S: String;
Begin
  If AnsiCompareText(Identifier, 'DTOS') = 0 Then
  Begin
    Value := DateToStr( Value );
  End
  Else If AnsiCompareText(Identifier, 'AVGOF') = 0 Then
  Begin
    Temp := Params.AsFloat[0];
    For I := 1 To Params.Count - 1 Do // start from second param of function
      Temp := Temp + Params.AsFloat[I];
    Value := Temp / Params.Count;
  End
  Else If AnsiCompareText(Identifier, 'TRIMDC') = 0 Then
  Begin
    S := Params.AsString[0];
    TempS := '';
    For I := 1 To Length(S) Do Begin
      If Not (S[I] In ['$', ',']) Then TempS := TempS + S[I]; // discard "$" and ","
    End;
    Value := StrToFloat(TempS);
  End;

end;

procedure TfrmTest.Button1Click(Sender: TObject);
begin
  xquery1.delete;
end;

procedure TfrmTest.XQuery1CancelQuery(Sender: TObject;
  var Cancel: Boolean);
begin
  If (GetAsyncKeyState( VK_ESCAPE ) shr 1 ) <> 0 then
  begin
    ShowMessage('user canceled');
    cancel:=true;
  end;
end;

End.