syntaxhi.pas

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

Unit SyntaxHi;

Interface

{$I XQ_FLAG.INC}
Uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  xqlex, xqyacc, StdCtrls, Inifiles, ComCtrls, Buttons, RichEdit, xquery;

Type

  TPosChangeEvent = Procedure( Sender: TObject; Row, Col: Integer ) Of Object;
  TUpdateMode = ( umCharacter, umLine );

  TColorConfig = Class; // forward declaration

  TSyntaxHighlighter = Class( TComponent )
  Private
    FEditor: TRichEdit;
    FColorConfig: TColorConfig;
    FFontFamily: String;
    FUpdateMode: TUpdateMode;
    FInternalModified, FChanging: Boolean;
    FLastLine: Integer;
    FxQuery: TCustomXQuery; // used only to hilite table names and fields

    FSaveOnChange: TNotifyEvent;
    FSaveOnSelectionChange: TNotifyEvent;
    FSaveOnExit: TNotifyEvent;
    FOnPosChange: TPosChangeEvent;
    Procedure SetEditor( Value: TRichEdit );
    Procedure SetXQuery( Value: TCustomXQuery );
    Procedure MyOnChange( Sender: TObject );
    Procedure MyOnSelectionChange( Sender: TObject );
    Procedure MyOnExit( Sender: TObject );
  Protected
    Procedure Notification( AComponent: TComponent; Operation: TOperation ); Override;
  Public
    Constructor Create( AOwner: TComponent ); Override;
    Destructor Destroy; Override;
    Procedure Execute;
{$IFNDEF BCB}
    Procedure EditColorSet;
{$ENDIF}
    Procedure FontChanged;

    Property ColorConfig: TColorConfig Read FColorConfig;
  Published
    Property UpdateMode: TUpdateMode Read FUpdateMode Write FUpdateMode;
    Property Editor: TRichEdit Read FEditor Write SetEditor;
    Property XQuery: TCustomXQuery Read FxQuery Write SetxQuery;

    Property OnPosChange: TPosChangeEvent Read FOnPosChange Write FOnPosChange;
  End;

  TElementGroup = ( idWhiteSpace,
    idComment,
    idReservedWord,
    idIdentifier,
    idTable,
    idField,
    idString,
    idNumber,
    idComma,
    idParenthesis,
    idOperator,
    idSemicolon,
    idPeriod );

  PColorElement = ^TColorElement;
  TColorElement = Record
    Elements: TList;
    Group: TElementGroup;
    ForeColor: TColor;
    BackColor: TColor;
    FontStyle: TFontStyles;
  End;

  TColorConfig = Class( TObject )
  Private
    FColorSettings: TList;
    FColorTable: TList;
    Function Get( Index: Integer ): TColorElement;
    Procedure Put( Index: Integer; Const Value: TColorElement );
  Public
    Constructor Create;
    Destructor Destroy; Override;
    Procedure Clear;
    Procedure Assign( Value: TColorConfig );
    Procedure LoadFromFile( Const FileName: String );
    Procedure SaveToFile( Const FileName: String );
    Procedure SetColorElement( Group: TElementGroup; ForeColor, BackColor: TColor;
      FontStyle: TFontStyles );
    Function Count: Integer;
{$IFNDEF BCB}
    Procedure EditColorSettings;
{$ENDIF}
    Function FindConfig( Element: Integer; Var ForeColor, BackColor: TColor;
      Var FontStyle: TFontStyles ): Boolean;
    Procedure CreateColorTable;
    Function IndexOfColor( Color: TColor ): Integer;
    Function IndexOfGroup( Group: TElementGroup ): Integer;

    Property Elements[Index: Integer]: TColorElement Read Get Write Put;
    Property ColorTable: TList Read FColorTable;
    Property ColorSettings: TList Read FColorSettings;
  End;

Implementation

Uses
  DB, xqmiscel, xqconsts
{$IFNDEF BCB}
  , ColorSet
{$ENDIF}
  ;

Const
  _TABLE = 1000;
  _FIELD = 1010;

Type
  TCustomXQueryClass = Class( TCustomXQuery );

Constructor TSyntaxHighlighter.Create( AOwner: TComponent );
Begin
  Inherited Create( AOwner );
  FColorConfig := TColorConfig.Create;
  FColorConfig.LoadFromFile( ExtractFilePath( Application.Exename ) + 'colortbl.cfg' );
  FColorConfig.CreateColorTable;

  FLastLine := -1;
End;

Destructor TSyntaxHighlighter.Destroy;
Begin
  FColorConfig.free;
  Inherited Destroy;
End;

Procedure TSyntaxHighlighter.SetEditor( Value: TRichEdit );
Begin
  If Assigned( FEditor ) Then
  Begin
    //Restore previous
    FEditor.OnChange := FSaveOnChange;
    FEditor.OnSelectionChange := FSaveOnSelectionChange;
    FEditor.OnExit := FSaveOnExit;
  End;
  FEditor := Value;
  If Assigned( FEditor ) Then
  Begin
    FSaveOnChange := FEditor.OnChange;
    FSaveOnSelectionChange := FEditor.OnSelectionChange;
    FSaveOnExit := FEditor.OnExit;

    FEditor.OnChange := MyOnChange;
    FEditor.OnSelectionChange := MyOnSelectionChange;
    FEditor.OnExit := MyOnExit;
    FontChanged; // calculate new font family

    Value.FreeNotification( Self );
    If Not ( csDesigning In ComponentState ) Then
      Execute;
  End;
End;

Procedure TSyntaxHighlighter.SetXQuery( Value: TCustomXQuery );
Begin
  FXQuery := Value;
  If Assigned( Value ) Then
    Value.FreeNotification( Self );
End;

Procedure TSyntaxHighlighter.Notification( AComponent: TComponent; Operation: TOperation );
Begin
  Inherited Notification( AComponent, Operation );
  If ( Operation = opRemove ) Then
  Begin
    If AComponent = FEditor Then
      SetEditor( Nil )
    Else If AComponent = FXQuery Then
      FXQuery := Nil;
  End;
End;

{$IFNDEF BCB}

Procedure TSyntaxHighlighter.EditColorSet;
Var
  FileName: String;
Begin
  FileName := ExtractFilePath( Application.Exename ) + 'colortbl.cfg';
  With TfrmColorSettings.Create( Application ) Do
  Begin
    Try
      If Enter( FColorConfig ) = mrOk Then
      Begin
        FColorConfig.SaveToFile( FileName );
        FColorConfig.CreateColorTable;
        Self.Execute;
      End;
    Finally
      Free;
    End;
  End;
End;
{$ENDIF}

Procedure TSyntaxHighlighter.Execute;
Var
  inputStream: TMemoryStream;
  outputStream: TMemoryStream;
  errorStream: TMemoryStream;
  s: String;
  lexer: TXQLexer;
  yychar: Integer; (* current lookahead character *)
  forecolor, backcolor: TColor;
  fontstyle: TFontStyles;
  I, token: Integer;
  atext, Reslt, RtfHeader: String;
  DataSet: TDataSet;
  Field: TField;
  ayytext : string;

  Procedure strToRichEdit( Const S: String );
  Var
    aMem: TMemoryStream;
    SelStart: Integer;
  Begin
    aMem := TMemoryStream.Create;
    FChanging := True;
    SelStart := 0; //Basri
    Try
      aMem.Write( Pointer( S )^, Length( S ) );
      aMem.Position := 0;
      If FEditor.Focused Then
        SelStart := FEditor.SelStart;
      //LockWindowUpdate( FEditor.Handle );
      FEditor.Lines.BeginUpdate;
      FEditor.Lines.LoadFromStream( aMem );    
      FEditor.Lines.EndUpdate;
      If FEditor.Focused Then
        FEditor.SelStart := SelStart;
      //LockWindowUpdate( 0 );
    Finally
      aMem.Free;
      FChanging := False;
    End;
  End;

  { converts a Delphi TColor into a RTF-color table string }
  Function ColorToRtf( aColor: TColor ): String;
  Begin
    aColor := ColorToRGB( aColor );
    Result := '\red' + IntToStr( GetRValue( aColor ) ) +
      '\green' + IntToStr( GetGValue( aColor ) ) +
      '\blue' + IntToStr( GetBValue( aColor ) ) + ';';
  End;

Begin
{$IFDEF XQDEMO}
  If Not IsDelphiRunning Then
  Begin
    ShowAbout;
    Raise Exception.Create( SDelphiIsNotRunning );
  End;
{$ENDIF}
  If Not Assigned( FEditor ) Or ( csDestroying In ComponentState ) Then
    Exit;
  s := FEditor.Text + ' ';
  inputStream := TMemoryStream.create;
  inputStream.WriteBuffer( Pointer( s )^, Length( s ) );
  inputStream.Seek( 0, 0 );
  outputStream := TMemoryStream.create;
  errorStream := TMemoryStream.create;
  lexer := TXQLexer.Create;
  lexer.yyinput := inputStream;
  lexer.yyoutput := outputStream;
  lexer.yyerrorfile := errorStream;
  If Assigned( FXQuery ) Then
    ( lexer As TXQlexer ).DateFormat := FXQuery.DateFormat
  Else
    ( lexer As TXQlexer ).DateFormat := ShortDateFormat;//SDefaultDateFormat;

  RtfHeader :=
    '{\rtf1\ansi\deff0\deftab720' +
    '{\fonttbl' +
    //format('{\f0\\fcharset0\fprq2\f%s %s;}}',[FFontFamily,FEditor.Font.Name])+
  '{\f0\fswiss Arial;}' +
    format( '{\f1\f%s %s;}', [FFontFamily, FEditor.Font.Name] ) +
    //format('{\f0\\fcharset0\fprq2\fcharset186 %s;}}',[FEditor.Font.Name])+
  '}{\colortbl;';
  // the default color
  RtfHeader := RtfHeader + ColorToRtf( FEditor.Font.Color ); // foreground
  RtfHeader := RtfHeader + ColorToRtf( FEditor.Color ); // background
  // Create a table of colors specified
  For I := 0 To FColorConfig.ColorTable.Count - 1 Do
    RtfHeader := RtfHeader + ColorToRtf( TColor( FColorConfig.ColorTable[I] ) );
  RtfHeader := RtfHeader + '}' +
    format( '\deflang1031\pard\plain\f1\fs%d', [FEditor.Font.Size * 2] );

  Reslt := ''; // resulting rtf string

  Try
    Repeat
      Try
        Lexer.IgnoreBadDates := True;
        yychar := Lexer.yylex;
      Except
        { ignore syntax errors }
      End;
      If yychar < 0 Then
        yychar := 0;
      If yychar = 0 Then
        break; // normal termination
      lexer.GetyyText (atext);
      If yychar = _ILLEGAL Then
      Begin
        // illegal token on input
        Reslt := Reslt + '{\cb2\cf1\b0\i0\ul0';
        lexer.GetyyText (atext);
        ReplaceString( atext, #10, '\line ' );
        ReplaceString( atext, #13, '' );
        Reslt := Reslt + #32 + atext + '}';
      End
      Else
      Begin
        // it is a table name or database field coming from FXQuery property?
        If Assigned( FXQuery ) And ( yychar = _IDENTIFIER ) And
          ( Not Lexer.IsKeyword( atext, token ) ) Then
        Begin
          For I := 0 To TCustomXQueryClass( FxQuery ).DataSets.Count - 1 Do
          Begin
            If AnsiCompareText( TCustomXQueryClass( FxQuery ).DataSets[I].Alias, atext ) = 0 Then
            Begin
              yychar := _TABLE;
              Break;
            End;
            DataSet := TCustomXQueryClass( FxQuery ).DataSets[I].DataSet;
            If Assigned( DataSet ) And DataSet.Active Then
            Begin
              lexer.getyytext(ayytext);
              Field := DataSet.FindField( ayytext );
              If Assigned( Field ) Then
              Begin
                yychar := _FIELD;
                Break;
              End;
            End;
          End;
        End;
        If FColorConfig.findconfig( yychar, forecolor, backcolor, fontstyle ) Then
        Else
        Begin
          forecolor := clBlack;
          backcolor := clWhite;
          fontstyle := [];
        End;
        Reslt := Reslt + Format( '{\cb%d\cf%d', [FColorConfig.IndexOfColor( backcolor ) + 3,
          FColorConfig.IndexOfColor( forecolor ) + 3] );
        // the font style
        If fsBold In fontstyle Then
          Reslt := Reslt + '\b'
        Else
          Reslt := Reslt + '\b0';
        If fsItalic In fontstyle Then
          Reslt := Reslt + '\i'
        Else
          Reslt := Reslt + '\i0';
        If fsUnderline In fontstyle Then
          Reslt := Reslt + '\ul'
        Else
          Reslt := Reslt + '\ul0';
        Case yychar Of
          _NEWLINE:
            Reslt := Reslt + #32 + '\line}';
          _TAB:
            Reslt := Reslt + #32 + '\tab}';
          _BLANK:
            Reslt := Reslt + #32 + ' }';
        Else
          Begin

            ReplaceString( atext, #10, '\line ' );
            ReplaceString( atext, #13, '' );
            Reslt := Reslt + #32 + atext + '}';
          End;
        End;
      End;
    Until false;
    Reslt := RtfHeader + Reslt + '}'; //+ '\cb2\cf1\b0\i0\ul0}';
    strToRichEdit( Reslt );
    {FEditor.DefAttributes.Assign(FEditor.Font);}
    //FEditor.SelAttributes.Assign(FEditor.Font);
    FInternalModified := False;
  Finally
    lexer.free;
    inputStream.free;
    outputStream.free;
    errorStream.free;
  End;
End;

Procedure TSyntaxHighlighter.MyOnChange( Sender: TObject );
Begin
  If FChanging Or ( csDesigning In ComponentState ) Or Not Assigned( FEditor ) Then
    Exit;
  FInternalModified := True;
  If Not FEditor.Focused Or ( FUpdateMode = umCharacter ) Then
    Execute;
  If Assigned( FSaveOnChange ) Then
    FSaveOnChange( FEditor );
End;

Procedure TSyntaxHighlighter.MyOnSelectionChange( Sender: TObject );
Var
  CharPos: TPoint;
Begin
  If FChanging Or Not Assigned( FEditor ) Then
    Exit;
  CharPos.Y := SendMessage( FEditor.Handle, EM_EXLINEFROMCHAR, 0,
    FEditor.SelStart );
  CharPos.X := ( FEditor.SelStart -
    SendMessage( FEditor.Handle, EM_LINEINDEX, CharPos.Y, 0 ) );
  Inc( CharPos.Y );
  Inc( CharPos.X );
  If ( FUpdateMode = umLine ) And FInternalModified And ( CharPos.Y <> FLastLine ) Then
  Begin
    FLastLine := CharPos.Y;
    FChanging := True;
    Execute;
    FChanging := False;
  End;
  If Assigned( FOnPosChange ) Then
    FOnPosChange( Self, CharPos.Y, CharPos.X );
  If Assigned( FSaveOnSelectionChange ) Then
    FSaveOnSelectionChange( FEditor );
End;

Procedure TSyntaxHighlighter.FontChanged;
Var
  ControlCanvas: TControlCanvas;
  FontInfo: TTextMetric; // holds the font metric information
Begin