jvhleditor.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvHLEditor.PAS, released on 2002-07-04.

The Initial Developers of the Original Code are: Andrei Prygounkov <a dott prygounkov att gmx dott de>
Copyright (c) 1999, 2002 Andrei Prygounkov
All Rights Reserved.

Contributor(s):

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

component   : TJvHLEditor
description : JvEditor with built-in highlighting for:
              pascal, cbuilder, sql, python, jscript,
              vbscript, perl, ini, html, not quite c

Known Issues:
  (rom) source cleaning incomplete
  (rom) GetAttr should be broken up further
-----------------------------------------------------------------------------}
// $Id: JvHLEditor.pas,v 1.31 2005/02/24 12:26:10 ahuser Exp $

{ history
 (JVCL Library versions) :
  1.03:
    - first release;
  1.11:
    - improvements in custom reserved words support;
    - comments works better in custom reserved words;
  1.17:
    - python highlighting by Rafal Smotrzyk - rsmotrzyk att mikroplan dott com dott pl;
  1.17.2:
    - jscript, vbscript highlighting by Rafal Smotrzyk - rsmotrzyk att mikroplan dott com dott pl;
  1.17.6:
    - html highlighting;
  1.12.2:
    - fixed bug with pressing End-key if CursorBeoyondEOF enabled
      (greetings to Andre N Belokon)
  1.23:
    - fixed another bug in comment checking (range check error)
    (greetings to Willo vd Merwe)
  1.23.1:
    - first version of perl highlighter;
  1.41:
    - fixed another bug in comment checking;
  1.51.3 (JVCL Library 1.51 with Update 3):
    - fixed bug: exception on comments in "c++, java, sql" - mode;
  1.51.4 (JVCL Library 1.51 with Update 4):
    - ini-file highlighter;
    - fixed bug: custom reserved words not working;
  1.61:
    - new: in html-highlighter unknown (not html) tag highlighted with
      "statement" color. This allows to use html-highlighter to display
      xml-files.
  2.10.2: (changes by Andreas Hausladen)
    - C/C++ line continuation symbol '\' extends the highlight colors to the
      next line (LongToken=True)
    - "Not Quite C" highlighter (C similar, for programming LEGO MindStorm(R) robots)
    - fixed bug: SetBlockColor raise an exception (AV) if iEnd becomes greater than
      MAX_X
    - in TRAHLEditor.GetAttr all IsXxxKeyWord get a CONST string, so no compiler
      magic LStrAddRef is needed.
    - some speed optimations
    - new property DelphiColors: Boolean
    - renamed all "Identifer" to "Identifier". published property "Identifer"
      still exists but uses "FIdentifier"
    - added some new DelphiKeyWord
    - fixed bug: RescanLong() may exceed FLongDesc[] dimension
  2.10.3: (changes by Andreas Hausladen
    - faster RescanLong
    - faster KeyWord search for drawing
  3.0:
    - added TJvEditorHighlighter component

}

unit JvHLEditor;

{$I jvcl.inc}

interface

uses
  Windows,
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  SysUtils, Classes, Graphics,
  JvEditor, JvEditorCommon, JvHLParser;

type
  TJvHLEditor = class;

  TOnReservedWord = procedure(Sender: TObject; Token: string;
    var Reserved: Boolean) of object;

  TJvEditorHighlighter = class(TComponent)
  protected
    procedure GetAttr(Editor: TJvHLEditor; Lines: TStrings; Line, ColBeg, ColEnd: Integer;
      LongToken: TLongTokenType; var LineAttrs: TLineAttrs); virtual; abstract;
    procedure ScanLongTokens(Editor: TJvHLEditor; Lines: TStrings; Line: Integer;
      var FLong: TLongTokenType); virtual; abstract;
    function GetRescanLongKeys(Editor: TJvHLEditor; Action: TModifiedAction;
      ACaretX, ACaretY: Integer; const Text: string): Boolean; virtual; abstract;
  end;

  TJvHLEditor = class(TJvEditor, IJvHLEditor)
  private
    Parser: TJvIParser;
    FHighlighter: TJvHighlighter;
    FColors: TJvColors;
    FLine: string;
    FLineNum: Integer;
    FLong: TLongTokenType;
    FLongTokens: Boolean;
    FLongDesc: array {[0..Max_Line]} of TLongTokenType;
    FSyntaxHighlighting: Boolean;
    FSyntaxHighlighter: TJvEditorHighlighter;
    FOnReservedWord: TOnReservedWord;

    // Coco/R
    ProductionsLine: Integer;
    function RescanLong(iLine: Integer): Boolean;
    procedure CheckInLong;
    function FindLongEnd: Integer;
    procedure SetHighlighter(const Value: TJvHighlighter);
    function GetDelphiColors: Boolean;
    procedure SetDelphiColors(Value: Boolean);
    function GetColors: TJvColors;
    procedure SetColors(const Value: TJvColors);
    function GetSyntaxHighlighting: Boolean;
    procedure SetSyntaxHighlighting(Value: Boolean);
    function GetHighlighter: TJvHighlighter;
  protected
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure GetAttr(Line, ColBeg, ColEnd: Integer); override;
    procedure TextModified(ACaretX, ACaretY: Integer; Action: TModifiedAction;
      const Text: string); override;
    function GetReservedWord(const Token: string; var Reserved: Boolean): Boolean; virtual;
    function UserReservedWords: Boolean; virtual;
    procedure SetSyntaxHighlighter(const Value: TJvEditorHighlighter);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Highlighter: TJvHighlighter read GetHighlighter write SetHighlighter default hlPascal;
    property Colors: TJvColors read GetColors write SetColors;
    property DelphiColors: Boolean read GetDelphiColors write SetDelphiColors stored False;
    property LongTokens: Boolean read FLongTokens write FLongTokens default True;
    property OnReservedWord: TOnReservedWord read FOnReservedWord write FOnReservedWord;
    property SyntaxHighlighting: Boolean read GetSyntaxHighlighting write SetSyntaxHighlighting stored False;
    property SyntaxHighlighter: TJvEditorHighlighter read FSyntaxHighlighter write SetSyntaxHighlighter;
  end;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvHLEditor.pas,v $';
    Revision: '$Revision: 1.31 $';
    Date: '$Date: 2005/02/24 12:26:10 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  Math,
  JvConsts, JvJCLUtils;

function LastNonSpaceChar(const S: string): Char;
var
  I: Integer;
begin
  Result := #0;
  I := Length(S);
  while (I > 0) and (S[I] = ' ') do
    Dec(I);
  if I > 0 then
    Result := S[I];
end;

function GetTrimChar(const S: string; Index: Integer): Char;
var
  LS, L: Integer;
begin
  LS := Length(S);
  if LS <> 0 then
  begin
    L := 1;
    while (L <= LS) and (S[L] = ' ') do
      Inc(L);
    if L <= LS then
      Result := S[L - 1 + Index]
    else
      Result := S[Index];
  end
  else
    Result := #0;
end;

function HasStringOpenEnd(Lines: TStrings; iLine: Integer): Boolean;
{ find C/C++ "line breaker" '\' }
var
  I: Integer;
  IsOpen: Boolean;
  P, F: PChar;
  S: string;
begin
  Result := False;
  if (iLine < 0) or (iLine >= Lines.Count) then
    Exit;
  I := iLine - 1;
  IsOpen := False;
  if (I >= 0) and (LastNonSpaceChar(Lines[I]) = '\') then // check prior lines
    IsOpen := HasStringOpenEnd(Lines, I);
  S := Lines[iLine];
  F := PChar(S);
  P := F;
  repeat
    P := StrScan(P, Char('"'));
    if P <> nil then
    begin
      if (P = F) or (P[-1] <> '\') then
        IsOpen := not IsOpen
      else
      begin
       // count the backslashes
        I := 1;
        while (P-1-I > F) and (P[-1-I] = '\') do
          Inc(I);
        if I mod 2 = 0 then
          IsOpen := not IsOpen;
      end;
      Inc(P);
    end;
  until P = nil;
  Result := IsOpen;
end;

function StrScan(P: PChar; Ch: Char): PChar;
begin
  Result := P;
  while True do
  begin
    while Result[0] in LeadBytes do
      Inc(Result); // mbcs
    if Result[0] = Ch then
      Exit
    else
    if Result[0] = #0 then
    begin
      Result := nil;
      Exit;
    end;
    Inc(Result);
  end;
end;

//=== { TJvHLEditor } ========================================================

constructor TJvHLEditor.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Parser := TJvIParser.Create;
  Parser.ReturnComments := True;
  FHighlighter := hlPascal;
  FColors := TJvColors.Create;
  FLongTokens := True;
  FSyntaxHighlighting := True;
  ProductionsLine := High(Integer);
end;

destructor TJvHLEditor.Destroy;
begin
  Parser.Free;
  FColors.Free;
  inherited Destroy;
end;

procedure TJvHLEditor.Notification(AComponent: TComponent; Operation: TOperation);
begin
  if (Operation = opRemove) and (AComponent = FSyntaxHighlighter) then
    SyntaxHighlighter := nil;
  inherited Notification(AComponent, Operation);
end;

procedure TJvHLEditor.Loaded;
begin
  inherited Loaded;
  RescanLong(0);
end;

procedure TJvHLEditor.SetHighlighter(const Value: TJvHighlighter);
begin
  if FHighlighter <> Value then
  begin
    FHighlighter := Value;
    case FHighlighter of
      hlPascal:
        Parser.Style := psPascal;
      hlCBuilder, hlSql, hlJava, hlNQC, hlCSharp:
        Parser.Style := psCpp;
      hlPython:
        Parser.Style := psPython;
      hlVB:
        Parser.Style := psVB;
      hlHtml:
        Parser.Style := psHtml;
      hlPerl:
        Parser.Style := psPerl;
      hlIni:
        Parser.Style := psPascal;
      hlCocoR:
        Parser.Style := psCocoR;
      hlPhp:
        Parser.Style := psPhp;
    end;
    RescanLong(0);
    Invalidate;
  end;
end;

procedure TJvHLEditor.GetAttr(Line, ColBeg, ColEnd: Integer);
const
  Symbols = [',', ':', ';', '.', '[', ']', '(', ')', '=', '+',
    '-', '/', '<', '>', '%', '*', '~', '''', '\', '^', '@', '{', '}',
    '#', '|', '&'];

const
  DelphiKeyWords =
    ' constructor destructor string record procedure with of' +
    ' repeat until try finally except for to downto case' +
    ' type interface implementation initialization finalization' +
    ' default private public protected published automated property' +
    ' program read write override object nil raise' +
    ' on set xor shr shl begin end args if then else' +
    ' endif goto while do var or and not mod div unit' +
    ' function uses external const class inherited' +
    ' register stdcall cdecl safecall pascal is as package program' +
    ' external overload platform deprecated implements export contains' +
    ' requires resourcestring message dispid assembler asm abstract absolute' +
    ' dispinterface file threadvar library' +
    // TurboPascal
    ' interrupt inline near far' +
    // Delphi 8
    ' operator strict final unsafe sealed static ';

  BuilderKeyWords =
    ' __asm _asm asm auto __automated break bool case catch __cdecl' +
    ' _cdecl cdecl char class __classid __closure const const_cast' +
    ' continue __declspec default delete __dispid do double dynamic_cast' +
    ' else enum __except explicit _export __export extern false __fastcall' +
    ' _fastcall __finally float for friend goto if __import _import inline' +
    ' int __int8 __int16 __int32 __int64 long mutable namespace new operator' +
    ' __pascal _pascal pascal private protected __property public __published' +
    ' register reinterpret_cast return __rtti short signed sizeof static static_cast' +
    ' __stdcall _stdcall struct switch template this __thread throw true __try' +
    ' try typedef typename typeid union using unsigned virtual void volatile' +
    ' wchar_t while ';

  NQCKeyWords = {Not Quite C - a C similar language for programming LEGO MindStorm(R) robots }
    ' __event_src __type acquire break __sensor abs asm case catch const' +
    ' continue default do else false for if inline' +
    ' int monitor repeat return signed start stop sub switch task true' +
    ' until void while ';

  SQLKeyWords =
    ' active as add asc after ascending all at alter auto' +
    ' and autoddl any avg based between basename blob' +
    ' base_name blobedit before buffer begin by cache  compiletime' +
    ' cast  computed char  close character  conditional character_length  connect' +
    ' char_length  constraint check  containing check_point_len  continue check_point_length  count' +
    ' collate  create collation  cstring column  current commit  cursor' +
    ' committed database  descending date  describe db_key  descriptor debug  disconnect' +
    ' dec  display decimal distinct declare do default  domain' +
    ' delete  double desc drop echo exception edit execute' +
    ' else  exists end  exit entry_point  extern escape  external' +
    ' event  extract fetch foreign file  found filter  from' +
    ' float  full for  function gdscode grant generator group' +
    ' gen_id commit_group_wait global group_commit_wait_time goto' +
    ' having help if  input_type immediate  insert in int' +
    ' inactive  integer index into indicator  is init  isolation' +
    ' inner isql input join key' +
    ' lc_messages  like lc_type  logfile left log_buffer_size length log_buf_size' +
    ' lev  long level manual  merge max  message' +
    ' maximum  min maximum_segment minimum max_segment  module_name names not' +
    ' national  null natural  numeric nchar num_log_bufs no num_log_buffers' +
    ' noauto octet_length or of  order on  outer only output' +
    ' open output_type option overflow page post_event pagelength  precision' +
    ' pages  prepare page_size procedure parameter  protected password  primary' +
    ' plan  privileges position  public quit' +
    ' raw_partitions  retain rdb db_key  return read  returning_values real  returns' +
    ' record_version revoke references  right release  rollback reserv runtime' +
    ' reserving schema  sql segment  sqlcode select  sqlerror set  sqlwarning' +
    ' shadow  stability shared  starting shell  starts show  statement' +
    ' singular  static size  statistics smallint  sub_type snapshot  sum' +
    ' some suspend sort table  translate terminator  translation then  trigger to  trim' +
    ' transaction uncommitted upper union  user unique using update' +
    ' value varying values version varchar view variable' +
    ' wait while when with whenever work where write' +
    ' term new old ';

  PythonKeyWords =
    ' and del for is raise' +
    ' assert elif from lambda return' +
    ' break else global not try' +
    ' class except if or while' +
    ' continue exec import pass' +
    ' def finally in print ';

  JavaKeyWords =
    ' abstract delegate if boolean do implements break double import' +
    ' byte else instanceof case extends int catch false interface' +
    ' char final long class finally multicast continue float' +
    ' default for native short transient new static true' +
    ' null super try package switch void private synchronized volatile' +
    ' protected this while public throw return throws ';

  VBKeyWords =
    ' as and base binary byref byval call case class compare const date debug declare deftype dim do each else elseif ' +
    ' empty end endif enum eqv erase error event execute exit explicit false for friend function get' +
    ' global gosub goto if imp implements input is kill len let line load lock loop lset me mid mod name new next not nothing null on open option optional' +
    ' or paramarray preserve print private property public raiseevent randomize redim rem' +
    ' resume return seek select set static step' +
    ' string sub then time to true unlock until wend while with withevents xor ';

  VBStatements =
    ' access alias any beep ccur cdbl chdir chdrive choose' +
    ' chr cint clear clng clone close cls command compare' +
    ' cos csng cstr curdir currency cvar cvdate ' +
    ' defcur defdbl defint deflng defsng defstr deftype defvar delete deletesetting' +
    ' doevents double dynaset edit environ eof erl err exp fix format ' +
    ' hex int integer isdate isempty isnull isnumeric lbound lcase' +
    ' lib like loc local lof long mkdir oct output pset put' +
    ' random read refresh reset restore rmdir rnd rset savesetting ' +
    ' sendkeys shared single stop system text type typeof ubound unload ' +
    ' using variant vartype write';

  HTMLTags =
    ' doctype a address applet area b base basefont bgsound big blink ' +
    ' blockquote body br caption center cite code col colgroup comment ' +
    ' dfn dir li div dl dt dd em embed font form frame frameset h align ' +
    ' h1 h2 h3 h4 h5 h6 head hr html i iframe img input isindex kbd link ' +
    ' listing map marquee menu meta multicol nextid nobr noframes noscript ' +
    ' object ol option p plaintext pre s samp script select small sound ' +
    ' spacer span strike strong style sub sup table tbody td textarea tfoot' +