{ *************************************************************************** }
{                                                                             }
{ EControl Syntax Editor SDK                                                  }
{                                                                             }
{ Copyright (c) 2004 - 2008 EControl Ltd., Zaharov Michael                    }
{     www.econtrol.ru                                                         }
{     support@econtrol.ru                                                     }
{                                                                             }
{ *************************************************************************** }
{$I ecSyntEdit.INC}

unit ecExtHighlight;

interface

uses Windows, Classes, Graphics, Controls, ExtCtrls, {$IFDEF EC_DOTNET} Types,{$ENDIF}
     ecSyntMemo, ecStrUtils, ecLists, ecSyntAnal, ecZRegExpr;

type

  THltRange = class(TRange)
  private
    FStyleIdx: integer;
  public
    property StyleIdx: integer read FStyleIdx;
  end;

  TCustomHighlighter = class(TComponent, {$IFNDEF EC_DOTNET}IUnknown,{$ENDIF}
                             IecTextClient, IecSyntMemoPlugIn, IecExternalFormatter)
  private
    FStyle: TSyntaxFormat;
    FEditor: TCustomSyntaxMemo;
    FActive: Boolean;
    FHighlighting: Boolean;
    FTimer: TTimer;
    FChecking: Boolean;
    FProcessDelta: integer;
    FAutoRun: Boolean;
    FStyles: TSyntStyles; // Characters to process at a time
    procedure SetErrorStyle(const Value: TSyntaxFormat);
    procedure SetEditor(const Value: TCustomSyntaxMemo);
    procedure SetActive(const Value: Boolean);
    procedure SetHighlighting(const Value: Boolean);
    function GetCompleted: Boolean;
    procedure OnTimer(Sender: TObject);
    procedure SetAutoRun(const Value: Boolean);
    procedure SetStyles(const Value: TSyntStyles);
  protected
    FRanges: TRangeList;   // Results of anaysis
    FToCheck: TRangeList;  // Ranges to re-check
    FCheckPos: integer;    // Curent check position
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    // IecTextClient
    procedure TextChanged(Sender: TObject; Pos, Count, LineChange: integer); virtual;
    // IecExternalFormatter
    procedure AnalyzeToPos(APos: integer); virtual;
    // IecSyntMemoPlugIn
    function HandleKeyStroke(AShortCut: TShortCut): Boolean; virtual;
    function HandleMouse(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; virtual;
    procedure UpdateCursor(X, Y: Integer; Shift: TShiftState; var Cursor: TCursor);

    // Processes only specified range
    function ValidateRange(const AText: ecString; AStart, AEnd: integer): integer; virtual;

    property Style: TSyntaxFormat read FStyle write SetErrorStyle;
    property Styles: TSyntStyles read FStyles write SetStyles;
    property Editor: TCustomSyntaxMemo read FEditor write SetEditor;
    property Active: Boolean read FActive write SetActive;
    property Highlighting: Boolean read FHighlighting write SetHighlighting default True;
    property Completed: Boolean read GetCompleted;
    property AutoRun: Boolean read FAutoRun write SetAutoRun default True;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Clear; virtual;
    function GetStyleList(CurPos: integer; List: TStyleEntries): integer; virtual;
    // Immediate analysis
    procedure Analyze(BackGround: Boolean = True); virtual;
    // Delayed analysis
    procedure RunAnalysis; virtual;

    function HltRangeObjAt(Pos: integer): THltRange;
    function HltRangeAt(Pos: integer): ecString;
    function HltRangeBndAt(Pos: integer): TPoint;
    procedure AddHltRange(AStart, AEnd: integer; AStyleIdx: integer = -1);
  end;

  // Token identification rule
  THyperlinkRule = class(TSyntCollectionItem)
  private
    FRegExpr: TecRegExpr;
    FShellCommand: ecString;
    FStyleIndex: integer;
    function GetExpression: ecString;
    procedure SetExpression(const Value: ecString);
    procedure SetShellCommand(const Value: ecString);
    procedure SetStyleIndex(const Value: integer);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    function Match(const Source: ecString; Pos: integer): integer; virtual;
  published
    property Expression: ecString read GetExpression write SetExpression;
    property ShellCommand: ecString read FShellCommand write SetShellCommand;
    property StyleIndex: integer read FStyleIndex write SetStyleIndex default -1;
  end;

  THyperlinkRuleCollection = class(TSyntCollection)
  private
    FOwner: TComponent;
    function GetItem(Index: integer): THyperlinkRule;
  protected
    procedure Update(Item: TCollectionItem); override;
    function  GetOwner: TPersistent; override;
  public
    constructor Create(AOwner: TComponent);
    function Add: THyperlinkRule;
    property Items[Index: integer]: THyperlinkRule read GetItem; default;
  end;

  THyperlinkRange = class(THltRange)
  private
    FShellCommand: string;
    FRule: THyperlinkRule;
  public
    property ShellCommand: string read FShellCommand;
    property Rule: THyperlinkRule read FRule;
  end;

  TExecuteHltRule = procedure(Sender: TObject; Range: THyperlinkRange; Handled: Boolean) of object;

  THyperlinkHighlighter = class(TCustomHighlighter)
  private
    FRules: THyperlinkRuleCollection;
    FOnExecute: TExecuteHltRule;
    procedure SetRules(const Value: THyperlinkRuleCollection);
  protected
    function ValidateRange(const AText: ecString; AStart, AEnd: integer): integer; override;
    function HandleMouse(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; override;
    procedure CreateStandardRules;
    function ExecuteRule(Range: THyperlinkRange): Boolean; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Rules: THyperlinkRuleCollection read FRules write SetRules;
    property Style;
    property Styles;
    property Editor;
    property Active default True;
    property AutoRun;
    property Highlighting default True;
    property OnExecute: TExecuteHltRule read FOnExecute write FOnExecute;
  end;


implementation

uses Forms, ShellApi, ecSysUtils;

{ TCustomHighlighter }

constructor TCustomHighlighter.Create(AOwner: TComponent);
begin
  inherited;
  FStyle := TSyntaxFormat.Create(nil);
  FRanges := TRangeList.Create(False);
  FHighlighting := True;
  FActive := True;
  FToCheck := TRangeList.Create;
  FTimer := TTimer.Create(Self);
  FTimer.Interval := 200;
  FTimer.OnTimer := OnTimer;
  FProcessDelta := 200;
  FAutoRun := True;
end;

destructor TCustomHighlighter.Destroy;
begin
  SafeDestroying(Self);
  FStyle.Free;
  FRanges.Free;
  FToCheck.Free;
  FTimer.Free;
  inherited;
end;

procedure TCustomHighlighter.Clear;
begin
  FCheckPos := 0;
  FToCheck.Clear;
  FRanges.Clear;
  if FEditor <> nil then FEditor.Invalidate;
end;

procedure TCustomHighlighter.RunAnalysis;
begin
  FTimer.Enabled := False;
  FTimer.Enabled := True;
end;

procedure TCustomHighlighter.OnTimer(Sender: TObject);
begin
  FTimer.Enabled := False;
  Analyze;
end;

procedure TCustomHighlighter.AnalyzeToPos(APos: integer);
begin
//  Analyze;
end;

function TCustomHighlighter.GetStyleList(CurPos: integer;
  List: TStyleEntries): integer;
var idx: integer;
begin
  Result := -1;
  if not FHighlighting then Exit;
  idx := FRanges.NextAt(CurPos);
  if idx <> -1 then
   with THltRange(FRanges[idx]) do
   if StartPos > CurPos then Result := StartPos else
     begin
       if (StyleIdx >= 0) and Assigned(FStyles) and (FStyles.Styles.Count > StyleIdx) then
         List.Add(FStyles.Styles[StyleIdx], StartPos, EndPos)
       else
         List.Add(FStyle, StartPos, EndPos);
       Result := EndPos;
     end;
end;

procedure TCustomHighlighter.SetEditor(const Value: TCustomSyntaxMemo);
begin
  if FEditor <> Value then
   begin
     Clear;
     if FEditor <> nil then
       FEditor.RemoveClient(Self);
     FEditor := Value;
     if FEditor <> nil then
      begin
       FEditor.AddClient(Self);
       if FAutoRun then
         RunAnalysis;
      end;
   end;
end;

procedure TCustomHighlighter.SetErrorStyle(const Value: TSyntaxFormat);
begin
  FStyle.Assign(Value);
end;

procedure TCustomHighlighter.TextChanged(Sender: TObject; Pos, Count,
  LineChange: integer);
var AStart, AEnd, Len: integer;
begin
  if not Active or (Pos < 0) then
   begin
    Clear;
    if FAutoRun then
      RunAnalysis;
    Exit;
   end;

  FRanges.ContentChanged(Pos, Count);
  if Editor <> nil then
   begin
     AStart := Pos;
     if Count > 0 then AEnd := AStart + Count
       else AEnd := AStart;
     while (AStart > 0) and not IsSpaceChar(Editor.Lines.FText[AStart]) do
      Dec(AStart);
     Len := Editor.Lines.TextLength;
     while (AEnd < Len) and not IsSpaceChar(Editor.Lines.FText[AEnd + 1]) do
      Inc(AEnd);

     if AStart < FCheckPos then
      if AEnd >= FCheckPos then FCheckPos := AStart
       else FToCheck.Add(TRange.Create(AStart, AEnd));
   end;
  if FAutoRun then
     RunAnalysis;
end;

procedure TCustomHighlighter.SetActive(const Value: Boolean);
begin
  if FActive <> Value then
   begin
    FActive := Value;
    if FActive then
      begin
       if FAutoRun then
          RunAnalysis;
      end
     else Clear;
   end;
end;

procedure TCustomHighlighter.SetHighlighting(const Value: Boolean);
begin
  if FHighlighting <> Value then
   begin
    FHighlighting := Value;
    if FEditor <> nil then
      FEditor.Invalidate;
   end;
end;

procedure TCustomHighlighter.SetStyles(const Value: TSyntStyles);
begin
  if FStyles <> Value then
    begin
      FStyles := Value;
      if Assigned(FStyles) then
        FStyles.FreeNotification(Self);
    end;
end;

procedure TCustomHighlighter.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if Operation = opRemove then
    if AComponent = FEditor then
      FEditor := nil else
    if AComponent = FStyles then
      FStyles := nil;
end;

function TCustomHighlighter.HltRangeObjAt(Pos: integer): THltRange;
var idx: integer;
begin
  idx := FRanges.RangeAt(Pos);
  if idx <> -1 then
    Result := THltRange(FRanges[idx])
  else
    Result := nil;
end;

function TCustomHighlighter.HltRangeAt(Pos: integer): ecString;
var R: THltRange;
begin
  R := HltRangeObjAt(Pos);
  if Assigned(Editor) and Assigned(R) and (R.EndPos <= Editor.Lines.TextLength) then
    with R do
      Result := Copy(Editor.Lines.FText, StartPos + 1, EndPos - StartPos)
  else
    Result := '';
end;

procedure TCustomHighlighter.AddHltRange(AStart, AEnd, AStyleIdx: integer);
var R: THltRange;
begin
  if AEnd <> AStart then
    begin
      R := THltRange.Create(AStart, AEnd);
      R.FStyleIdx := AStyleIdx;
      FRanges.Add(R);
    end;
end;

function TCustomHighlighter.GetCompleted: Boolean;
begin
  Result := (Editor = nil) or
            (FCheckPos >= Editor.Lines.TextLength) and (FToCheck.Count = 0);
end;

function TCustomHighlighter.HandleKeyStroke(AShortCut: TShortCut): Boolean;
begin
  Result := False;
end;

function TCustomHighlighter.HandleMouse(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer): Boolean;
begin
  Result := False;
end;

procedure TCustomHighlighter.Analyze(BackGround: Boolean);
var AEnd: integer;
    R: TRange;
    IdleRes: DWORD;
begin
  if FChecking or not Active or (Editor = nil) then Exit;
  FChecking := True;
  IdleRes := 0;
  try
    while (FCheckPos < Editor.Lines.TextLength) or (FToCheck.Count > 0) do
     begin
       if FToCheck.Count > 0 then
        begin
          R := FToCheck[0];
          if (R.EndPos - R.StartPos <= FProcessDelta) or not BackGround then
           begin
            ValidateRange(Editor.Lines.FText, R.StartPos + 1, R.EndPos + 1);
            FToCheck.Delete(0);
           end else
           begin
            THltRange(R).FStartPos := ValidateRange(Editor.Lines.FText, R.StartPos + 1, R.StartPos + FProcessDelta + 1);
            if R.StartPos >= R.EndPos then
             FToCheck.Delete(0);
           end;
        end
       else
        begin
         AEnd := FCheckPos + FProcessDelta;
         if AEnd > Editor.Lines.TextLength then
           AEnd := Editor.Lines.TextLength;
         FCheckPos := ValidateRange(Editor.Lines.FText, FCheckPos + 1, AEnd + 1);
        end;
       if BackGround then
         begin
          IdleRes := SafeProcessMessages(Self);
          if IdleRes <> 0 then Exit;
         end;
     end;
  finally
    FChecking := False;
    if (FEditor <> nil) and (IdleRes = 0) then
      FEditor.Invalidate;
  end;
end;

function TCustomHighlighter.ValidateRange(const AText: ecString; AStart,
  AEnd: integer): integer;
begin
  Result := AEnd;
end;

procedure TCustomHighlighter.UpdateCursor(X, Y: Integer;
  Shift: TShiftState; var Cursor: TCursor);
var cp: TPoint;
    pos: integer;
begin
  if (ssCtrl in Shift) and FActive and (Editor <> nil) then
   begin
     cp := Editor.MouseToCaret(X, Y);
     if (cp.Y >= 0) and (cp.Y < Editor.Lines.Count) and (cp.X < Editor.Lines.LineLength(cp.Y)) then
      begin
        pos := Editor.CaretPosToStrPos(cp);
        if FRanges.RangeAt(pos)<> -1 then
          Cursor := crHandPoint;
      end;
   end;
end;

procedure TCustomHighlighter.SetAutoRun(const Value: Boolean);
begin
  FAutoRun := Value;
end;

function TCustomHighlighter.HltRangeBndAt(Pos: integer): TPoint;
var R: THltRange;
begin
  R := HltRangeObjAt(Pos);
  if R <> nil then
    with R do
      Result := Point(StartPos, EndPos)
  else
    Result := Point(0, 0);
end;

{ THyperlinkRule }

constructor THyperlinkRule.Create(Collection: TCollection);
begin
  inherited;
  FRegExpr := TecRegExpr.Create;
  FRegExpr.ModifierI := True;
  FRegExpr.ModifierG := True;
  FRegExpr.ModifierS := False;
  FRegExpr.ModifierM := True;
  FRegExpr.ModifierX := True;
  FRegExpr.ModifierR := False;
  FStyleIndex := -1;
end;

destructor THyperlinkRule.Destroy;
begin
  FRegExpr.Free;
  inherited;
end;

procedure THyperlinkRule.AssignTo(Dest: TPersistent);
begin
  if Dest is THyperlinkRule then
   with Dest as THyperlinkRule do
    begin
     FRegExpr.Expression := Self.Expression;
     FShellCommand := Self.ShellCommand;
    end;
end;

function THyperlinkRule.GetExpression: ecString;
begin
  Result := FRegExpr.Expression;
end;

function THyperlinkRule.Match(const Source: ecString;
  Pos: integer): integer;
begin
 try
  Result := FRegExpr.MatchLength(Source, Pos);
 except
  Result := 0;
 end;
end;

procedure THyperlinkRule.SetExpression(const Value: ecString);
begin
  try
    FRegExpr.Expression := Value;
  except
    Application.HandleException(Self);
  end;
  Changed(False);
end;

procedure THyperlinkRule.SetShellCommand(const Value: ecString);
begin
  FShellCommand := Value;
  Changed(False);
end;

procedure THyperlinkRule.SetStyleIndex(const Value: integer);
begin
  if FStyleIndex <> Value then
    begin
      FStyleIndex := Value;
      Changed(False);
    end;
end;

{ THyperlinkRuleCollection }

function THyperlinkRuleCollection.Add: THyperlinkRule;
begin
  Result := THyperlinkRule(inherited Add);
end;

constructor THyperlinkRuleCollection.Create(AOwner: TComponent);
begin
  inherited Create(THyperlinkRule);
  FOwner := AOwner;
end;

function THyperlinkRuleCollection.GetItem(Index: integer): THyperlinkRule;
begin
  Result := THyperlinkRule(inherited Items[Index]);
end;

function THyperlinkRuleCollection.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

procedure THyperlinkRuleCollection.Update(Item: TCollectionItem);
begin
  THyperlinkHighlighter(GetOwner).Clear;
end;

{ THyperlinkHighlighter }

constructor THyperlinkHighlighter.Create(AOwner: TComponent);
begin
  inherited;
  FRules := THyperlinkRuleCollection.Create(Self);
  Style.FormatType := ftFontAttr;
  Style.BgColor := clNone;
  Style.Font.Color := clBlue;
  Style.Font.Style := [fsUnderline];
  if csDesigning in ComponentState then
    CreateStandardRules;
end;

procedure THyperlinkHighlighter.CreateStandardRules;
var Rule: THyperlinkRule;
begin
  // HTTP link 1
  Rule := FRules.Add;
  Rule.Expression := '(https?|ftp)://[\w\d\-]+(\.[\w\d\-]+)+'
                   + '(:\d\d?\d?\d?\d?)?'        // port number
                   + '(((/[%+\w\d\-\\\.]*)+)*)'  // unix path
                   + '(\?[^\s=&"'#39']+=[^\s=&"'#39']+(&[^\s=&"'#39']+=[^\s=&"'#39']+)*)?'
                   + '(\#[\w\d\-=,%+]+)?';          // bookmark
  Rule.ShellCommand := '\0';
  Rule.DisplayName := 'http & ftp';

  // HTTP link 2
  Rule := FRules.Add;
  Rule.Expression := 'www(\.[\w\d\-]+)+'
                   + '(:\d\d?\d?\d?\d?)?'        // port number
                   + '(((/[%+\w\d\-\\\.]*)+)*)'  // unix path
                   + '(\?[^\s=&"]+=[^\s=&"'#39']+(&[^\s=&"'#39']+=[^\s=&"'#39']+)*)?'
                   + '(\#[\w\d\-=,%+]+)?';          // bookmark
  Rule.ShellCommand := 'http://\0';
  Rule.DisplayName := 'http (www)';

  // e-mail link 1
  Rule := FRules.Add;
  Rule.Expression := 'mailto:\s*[_a-z\d\-\.]+@[_a-z\d\-]+(\.[_a-z\d\-]+)+';
  Rule.ShellCommand := '\0';
  Rule.DisplayName := 'e-mail (mailto)';

  // e-mail link 2
  Rule := FRules.Add;
  Rule.Expression := '\b[_a-z\d\-\.]+@[_a-z\d\-]+(\.[_a-z\d\-]+)+';
  Rule.ShellCommand := 'mailto:\0';
  Rule.DisplayName := 'e-mail';
end;

destructor THyperlinkHighlighter.Destroy;
begin
  FRules.Free;
  inherited;
end;

procedure THyperlinkHighlighter.SetRules(const Value: THyperlinkRuleCollection);
begin
  FRules.Assign(Value);
end;

function THyperlinkHighlighter.HandleMouse(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer): Boolean;
var idx: integer;
begin
  Result := False;
  if FActive and (ssCtrl in Shift) then
   begin
     idx := FRanges.RangeAt(Editor.CaretStrPos);
     if idx <> -1 then
       Result := ExecuteRule(THyperlinkRange(FRanges[idx]));
   end;
end;

function THyperlinkHighlighter.ValidateRange(const AText: ecString; AStart,
  AEnd: integer): integer;
  function DoAnalysis(Pos: integer): integer;
  var i: integer;
      Range: THyperlinkRange;
  begin
    for i := 0 to FRules.Count - 1 do
     if FRules[i].Enabled then
     begin
       Result := FRules[i].Match(Editor.Lines.FText, Pos);
       if Result > 0 then
        begin
          Range := THyperlinkRange.Create(Pos - 1, Pos + Result - 1);
          Range.FRule := FRules[i];
          Range.FStyleIdx := FRules[i].StyleIndex;
          if FRules[i].ShellCommand <> '' then
           begin
             Range.FShellCommand :=
               FRules[i].FRegExpr.Substitute(Editor.Lines.FText, FRules[i].FShellCommand);
           end;
          FRanges.Add(Range);
          Exit;
        end;
     end;
    Result := 1;
  end;
begin
  Result := AStart;
  while Result < AEnd  do
   Inc(Result, DoAnalysis(Result) );
end;

function THyperlinkHighlighter.ExecuteRule(Range: THyperlinkRange): Boolean;
var wnd: HWND;
begin
  Result := False;
  if Assigned(FOnExecute) then
   begin
    FOnExecute(Self, Range, Result);
    if Result then Exit;
   end;
  if Range.Rule.ShellCommand <> '' then
   begin
     Result := True;
     if Application.MainForm <> nil then
       wnd := Application.MainForm.Handle
     else if Editor <> nil then
       wnd := Editor.Handle
     else
       wnd := Application.Handle;
     ShellExecute( wnd, 'open',
           {$IFDEF EC_DOTNET}Range.FShellCommand{$ELSE}PChar(Range.FShellCommand){$ENDIF},
           '', '', SW_SHOWNORMAL);
   end;
end;

end.
