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

unit ecZRegExpr;

interface

uses Classes, ecStrUtils {$IFDEF RE_DEBUG},ComCtrls{$ENDIF};

const
  MaskModI = 1;  // modifier /i bit in fModifiers
  MaskModR = 2;  // -"- /r
  MaskModS = 4;  // -"- /s
  MaskModG = 8;  // -"- /g
  MaskModM = 16; // -"- /m
  MaskModX = 32; // -"- /x

type
  TecRegExpr = class(TPersistent)
  private
    FExpression: ecString;
    FProgRoot: TObject;
    FModifiers: Word;
    FMatchOK: Boolean;
    procedure SetExpression(const Value: ecString);
    procedure SetModifiers(const Value: Word);
    function GetModifier(const Index: Integer): boolean;
    function GetModifierStr: ecString;
    procedure SetModifier(const Index: Integer; const Value: boolean);
    procedure SetModifierStr(const Value: ecString);
    function GetIsInvalid: Boolean;
    function GetMatchLen(Idx: integer): integer;
    function GetMatchPos(Idx: integer): integer;
    function GetSubExprMatchCount: integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;

    procedure Compile;
    function Match(const InputString: ecString; var aPos: integer; Back: Boolean = False): Boolean;
    function MatchLength(const InputString: ecString; aPos: integer; Back: Boolean = False): integer;
    function GetMatch(const InputString: ecString; SubIdx: integer): ecString;
    function Substitute (const InputString, ATemplate : ecString) : ecString;

    property ModifierMask: Word read FModifiers write SetModifiers;
    property ModifierI: boolean index MaskModI read GetModifier write SetModifier;
    property ModifierR: boolean index MaskModR read GetModifier write SetModifier;
    property ModifierS: boolean index MaskModS read GetModifier write SetModifier;
    property ModifierG: boolean index MaskModG read GetModifier write SetModifier;
    property ModifierM: boolean index MaskModM read GetModifier write SetModifier;
    property ModifierX: boolean index MaskModX read GetModifier write SetModifier;
    property IsInvalid: Boolean read GetIsInvalid;

    property MatchPos[Idx: integer]: integer read GetMatchPos;
    property MatchLen[Idx: integer]: integer read GetMatchLen;
    property SubExprMatchCount: integer read GetSubExprMatchCount;
  published
    property Expression: ecString read FExpression write SetExpression;
    property ModifierStr: ecString read GetModifierStr write SetModifierStr;
  end;


const
  // Error messages
  zreUnexpectedEnd = 'Unexpected end of expression';
  zreUnexpectedModifier = 'Unexpected modifier';
  zreUnexpectedBracket = 'Unexpected bracket';

{$IFDEF RE_DEBUG}
type
  TREDebugOnMatchProc = procedure(const TraceStr: string) of object;
var
  REDebugOnMatchProc: TREDebugOnMatchProc = nil;

procedure REDebugCompiledBuildTree(RE: TecRegExpr; TV: TTreeView);
{$ENDIF}


implementation

{$IFNDEF EC_UNICODE}
  {$IFNDEF EC_DOTNET}
    {$DEFINE USE_CHARSET}
  {$ENDIF}
{$ENDIF}

uses Windows, SysUtils, Contnrs;

type

  TreRootNode = class;
  TreSubExpr = class;
  TreBranchNode = class;

  TzSubExprPos = class
  public
    StartPos, Length: integer;
  end;

  TRENodeBase = class
  private
    {$IFDEF RE_DEBUG}
    FNodeId: integer;
    {$ENDIF}
    FLoopMin: integer; // repeat at least
    FLoopMax: integer; // not more than
    FNonGreedy: Boolean;  // is greedy
    FNext: TRENodeBase;
    FOwner: TreSubExpr;
    function GetRoot: TreRootNode;
  public
    constructor Create(AOwner: TreSubExpr); virtual;
    function Match(const InputString: ecString; var aPos: integer): integer; virtual; abstract;
    function BackMatch(const InputString: ecString; var aPos: integer): integer; virtual; abstract;
    procedure SetNext(const Value: TRENodeBase); virtual;
    property Next: TRENodeBase read FNext write SetNext;
    property Owner: TreSubExpr read FOwner;
    property Root: TreRootNode read GetRoot;
  end;

  // Char set & String
  TCharSetNode = class(TRENodeBase)
  private
    FIgnoreCase: Boolean;
    FInvert: Boolean;
    FCharRanges: ecString;
    FCharSets: ecString;
    {$IFNDEF USE_CHARSET}
    FCharArray: ecString;
    {$ELSE}
    FCharArray: set of Char;
    {$ENDIF}
    procedure AddChar(C: ecChar);
    procedure AddRange(st, en: ecChar);
    procedure AddSet(C: ecChar); // \w, \d ...
    function HasChar(C: ecChar): Boolean;
  public
    function Match(const InputString: ecString; var aPos: integer): integer; override;
    function BackMatch(const InputString: ecString; var aPos: integer): integer; override;
  end;

  // Simple text
  TCharSeqNode = class(TRENodeBase)
  private
    FIgnoreCase: Boolean;
    FChar: ecChar;
  public
    function Match(const InputString: ecString; var aPos: integer): integer; override;
    function BackMatch(const InputString: ecString; var aPos: integer): integer; override;
  end;

  // Special ckecking
  TSpecCheckNode = class(TRENodeBase)
  private
    FCheckType: ecChar;
  public
    function Match(const InputString: ecString; var aPos: integer): integer; override;
    function BackMatch(const InputString: ecString; var aPos: integer): integer; override;
  end;

  // Reference to sub expression
  TRefNode = class(TRENodeBase)
  private
    FRef: integer;
    FIgnoreCase: Boolean;
    FOwner: TreBranchNode;
  public
    function Match(const InputString: ecString; var aPos: integer): integer; override;
    function BackMatch(const InputString: ecString; var aPos: integer): integer; override;
  end;

  // Base class of containers
  TreListNodeBase = class(TRENodeBase)
  private
    FList: TList;
  public
    constructor Create(AOwner: TreSubExpr); override;
    destructor Destroy; override;
    procedure Clear; virtual;
  end;

  // Branch of sub expression
  TreBranchNode = class(TreListNodeBase)
  public
    procedure Add(Node: TRENodeBase);
    procedure Compile(const Expression: ecString; var aPos: integer; Modifiers: integer);
    function Match(const InputString: ecString; var aPos: integer): integer; override;
    function BackMatch(const InputString: ecString; var aPos: integer): integer; override;
  end;

  // Select operation (list of TreListNodeBase) => sub expression
  TreSubExpr = class(TreListNodeBase)
  private
    FStart: integer; // first char of sub expression
    FEnd: integer; // first char after sub expression
  public
    constructor Create(AOwner: TreSubExpr); override;
    procedure Compile(const Expression: ecString; var aPos: integer; Modifiers: integer);
    function Match(const InputString: ecString; var aPos: integer): integer; override;
    function BackMatch(const InputString: ecString; var aPos: integer): integer; override;
  end;

  // Root node
  TreRootNode = class(TreSubExpr)
  private
    FSubExpr: TList;
  public
    constructor Create(AOwner: TreSubExpr); override;
    destructor Destroy; override;
    procedure Clear; override;
    function MatchStr(const InputString: ecString; var aPos: integer; Back: Boolean = False): Boolean;
  end;

{$IFDEF RE_DEBUG}
var
  LastNodeID: integer;

// Fill tree with compiled nodes {debug purpose}
procedure REDebugCompiledBuildTree(RE: TecRegExpr; TV: TTreeView);
  function GetNodeCaption(Node: TRENodeBase): string;
  {$IFDEF USE_CHARSET}
  var c: Char;
  {$ENDIF}
  begin
   if Node.ClassType = TCharSeqNode then
    Result := TCharSeqNode(Node).FChar else
   if Node.ClassType = TCharSetNode then
    begin
      {$IFDEF USE_CHARSET}
      Result := '';
      for c := #1 to #255 do
       if c in TCharSetNode(Node).FCharArray then
         Result := Result + c;
      {$ELSE}
      Result := TCharSetNode(Node).FCharArray;
      {$ENDIF}
      Result := '[' + Result + ']';
    end else
   if Node.ClassType = TSpecCheckNode then
    Result := '! '+ TSpecCheckNode(Node).FCheckType + ' !'
   else
    Result := '<' + Node.ClassName + '>';
   Result := IntToStr(Node.FNodeId) + '  ' + Result + Format(' {%d, %d}', [Node.FLoopMin, Node.FLoopMax]);
  end;

  procedure AddNode(Node: TRENodeBase; Prn: TTreeNode);
  var tn: TTreeNode;
      i: integer;
  begin
   tn := TV.Items.AddChild(Prn, GetNodeCaption(Node));
   if Node is TreListNodeBase then
    for i := 0 to TreListNodeBase(Node).FList.Count - 1 do
     AddNode(TRENodeBase(TreListNodeBase(Node).FList[i]), tn);
  end;
begin
  TV.Items.Clear;
  AddNode(TreRootNode(RE.FProgRoot), nil);
end;
{$ENDIF}

procedure ParseModifiers(const S: ecString; var aPos, Modifiers: integer);
var IsOn : boolean;
  procedure SetModif(m: integer);
  begin
    if IsOn then Modifiers := Modifiers or m
     else Modifiers := Modifiers and not m;
  end;
begin
  IsOn := true;
  while (aPos <= Length(S)) and (S[aPos] <> ')') do
   begin
    case S[aPos] of
    '-': IsOn := false;
    'i','I': SetModif(MaskModI);
    'r','R': SetModif(MaskModR);
    's','S': SetModif(MaskModS);
    'g','G': SetModif(MaskModG);
    'm','M': SetModif(MaskModM);
    'x','X': SetModif(MaskModX);
    else
      raise Exception.Create(zreUnexpectedModifier);
    end;
    inc(aPos);
   end;
end;

function GetEscape(const Expression: ecString; var aPos: integer): ecChar;
var strt: integer;
begin
  Result := #0;
  case Expression[aPos] of
    't': Result := #$9;
    'n': Result := #$A;
    'r': Result := #$D;
    'f': Result := #$C;
    'a': Result := #$7;
    'e': Result := #$1B;
    'x': begin
          inc(aPos);
          if aPos > Length(Expression) then
             raise Exception.Create('Invalid escape char');
          if Expression[aPos] = '{' then
           begin
             inc(aPos);
             strt := aPos;
             while (aPos < Length(Expression)) and (Expression[aPos] <> '}') do inc(aPos);
             Result := ecChar(StrToInt('$' + Trim(Copy(Expression, strt, aPos - strt))));
           end else
            begin
             Result := ecChar(StrToInt('$' + Copy(Expression, aPos, 2)));
             Inc(aPos);
            end;
          if Result = #0 then
            raise Exception.Create('Invalid HEX char');
         end;
  end;
end;

function IsInRange(const RngType, C: ecChar): Boolean;
begin
  case RngType of
    'w': Result := IsWordChar(C);
    'W': Result := not IsWordChar(C);
    'd': Result := IsDigitChar(C);
    'D': Result := not IsDigitChar(C);
    's': Result := IsSpaceChar(C);
    'S': Result := not IsSpaceChar(C);
    'h': Result := IsHexDigitChar(C);
    'H': Result := not IsHexDigitChar(C);
    'l': Result := IsAlphaChar(C);
    'L': Result := not IsAlphaChar(C);
    'c': Result := IsIdentChar(C);
    'C': Result := not IsIdentChar(C);
    'g': Result := IsIdentLetterChar(C);
    'G': Result := not IsIdentLetterChar(C);
    'k': Result := IsIdentDigitChar(C);
    'K': Result := not IsIdentDigitChar(C);
    else Result := False;
  end;
end;

{ TRENodeBase }

constructor TRENodeBase.Create(AOwner: TreSubExpr);
begin
  inherited Create;
  FOwner := AOwner;
  FLoopMin := 1;
  FLoopMax := 1;
  {$IFDEF RE_DEBUG}
  Inc(LastNodeID);
  FNodeId := LastNodeID;
  {$ENDIF}
end;

function TRENodeBase.GetRoot: TreRootNode;
var p: TreSubExpr;
begin
  if Owner = nil then Result := Self as TreRootNode else
   begin
    p := Owner;
    while p.Owner <> nil do
     p := p.Owner;
    Result := p as TreRootNode;
   end;
end;

procedure TRENodeBase.SetNext(const Value: TRENodeBase);
begin
  FNext := Value;
end;

{ TCharSetNode }

function TCharSetNode.HasChar(C: ecChar): Boolean;
var i, N, k: integer;
begin
  N := Length(FCharRanges);
  if N > 0 then
   for i := 1 to N shr 1 do
    begin
     k := i shl 1;
     if (Ord(FCharRanges[k]) >= Ord(C)) and
        (Ord(FCharRanges[k - 1]) <= Ord(C)) then
      begin
        Result := True;
        Exit;
      end;
    end;
  for i := 1 to Length(FCharSets) do
   if IsInRange(FCharSets[i], C) then
    begin
     Result := True;
     Exit;
    end;
  {$IFNDEF USE_CHARSET}
  Result := Pos(C, FCharArray) <> 0;
  {$ELSE}
  Result := C in FCharArray;
  {$ENDIF}
end;

procedure TCharSetNode.AddChar(C: ecChar);
begin
  if FIgnoreCase then
    C := ecUpCase(C);
  {$IFNDEF USE_CHARSET}
  if Pos(C, FCharArray) = 0 then
    FCharArray := FCharArray + C;
  {$ELSE}
  Include(FCharArray, C);
  {$ENDIF}
end;

procedure TCharSetNode.AddRange(st, en: ecChar);
begin
  if FIgnoreCase then
   begin
    st := ecUpCase(st);
    en := ecUpCase(en);
   end;
  FCharRanges := FCharRanges + st + en;
end;

procedure TCharSetNode.AddSet(C: ecChar);
begin
  FCharSets := FCharSets + C;
end;

function TCharSetNode.Match(const InputString: ecString; var aPos: integer): integer;
var C: ecChar;
    b: Boolean;
begin
  if aPos > Length(InputString) then
    begin
      Result := 0;
      Exit;
    end;

  C := InputString[aPos];
  if FIgnoreCase then C := ecUpCase(C);
  b := HasChar(C);
  if FInvert then
    b := not b;
  if b then Inc(aPos);
  if b then Result := 1 else Result := 0;
end;

function TCharSetNode.BackMatch(const InputString: ecString; var aPos: integer): integer;
var C: ecChar;
    b: Boolean;
begin
  if aPos <= 1 then
    begin
      Result := 0;
      Exit;
    end;

  C := InputString[aPos - 1];
  if FIgnoreCase then C := ecUpCase(C);
  b := HasChar(C);
  if FInvert then
    b := not b;
  if b then Dec(aPos);
  if b then Result := 1 else Result := 0;
end;

{ TCharSeqNode }

function TCharSeqNode.BackMatch(const InputString: ecString; var aPos: integer): integer;
var C: ecChar;
    b: Boolean;
begin
  if aPos <= 1 then
    begin
      Result := 0;
      Exit;
    end;

  C := InputString[aPos - 1];
  if FIgnoreCase then b := ecUpCase(C) = FChar
                 else b := C = FChar;
  if b then Dec(aPos);
  if b then Result := 1 else Result := 0;
end;

function TCharSeqNode.Match(const InputString: ecString; var aPos: integer): integer;
var b: Boolean;
begin
  if aPos > Length(InputString) then
    begin
      Result := 0;
      Exit;
    end;
  if FIgnoreCase then b := ecUpCase(InputString[aPos]) = FChar
                 else b := InputString[aPos] = FChar;
  if b then Inc(aPos);
  if b then Result := 1 else Result := 0;
end;

{ TSpecCheckNode }

function TSpecCheckNode.BackMatch(const InputString: ecString; var aPos: integer): integer;
var C: ecChar;
    b: Boolean;
begin
  b := False;
  if aPos <= 1 then
   begin
    if aPos < 1 then
      begin
        Result := 0;
        Exit;
      end;
    C := #0;
   end
  else C := InputString[aPos - 1];

  case FCheckType of
    '^': b := (C = #0) or (C = #10) or
                   (C = #13) and (aPos <= Length(InputString)) and (InputString[aPos] <> #10);
    '$': b := (aPos > Length(InputString)) or (InputString[aPos] = #13) or
                   (InputString[aPos] = #10) and (C <> #13);
    'A': b := C = #0;
    'Z': b := aPos > Length(InputString);
    'b': b := IsWordBreak(aPos, InputString);
    'B': b := not IsWordBreak(aPos, InputString);
    'z': begin
           b := IsLineBreakChar(C);
           if b then
             begin
               Dec(aPos);
               if (C = #10) and (aPos > 0) and (InputString[aPos] = #13) then
                 Dec(aPos);
             end;
         end;
  else if C<> #0 then
   begin
     case FCheckType of
      '.': b := True;
      ':': b := not IsLineBreakChar(C);
      else b := IsInRange(FCheckType, C);
     end;
     if b then Dec(aPos);
   end;
  end;
  if b then Result := 1 else Result := 0;
end;

function TSpecCheckNode.Match(const InputString: ecString; var aPos: integer): integer;
var C: ecChar;
    b: Boolean;
begin
  b := False;
  if aPos > Length(InputString) then
   begin
    if aPos - 1 > Length(InputString) then
      begin
        Result := 0;
        Exit;
      end;
    C := #0;
   end
  else C := InputString[aPos];

  case FCheckType of
    '^': b := (aPos = 1) or (InputString[aPos - 1] = #10) or
                   (InputString[aPos - 1] = #13) and (C <> #10);
    '$': b := (C = #13) or (C = #10) and (aPos > 1) and (InputString[aPos - 1] <> #13) or (C = #0);
    'A': b := aPos = 1;
    'Z': b := C = #0;
    'b': b := IsWordBreak(aPos, InputString);//(aPos = 1) or (IsWordChar(C) xor IsWordChar(InputString[aPos - 1]));
    'B': b := not IsWordBreak(aPos, InputString);//((aPos > 1) and (IsWordChar(C) xor IsWordChar(InputString[aPos - 1])));
    'z': begin
           b := IsLineBreakChar(C);
           if b then
             begin
               Inc(aPos);
               if (C = #13) and (aPos <= Length(InputString)) and (InputString[aPos] = #10) then
                 Inc(aPos);
             end;
         end;
  else if C<> #0 then
   begin
     case FCheckType of
      '.': b := True;
      ':': b := not IsLineBreakChar(C);
      else b := IsInRange(FCheckType, C);
     end;
     if b then Inc(aPos);
   end;
  end;
  if b then Result := 1 else Result := 0;
end;

{ TRefNode }

function TRefNode.BackMatch(const InputString: ecString; var aPos: integer): integer;
var S, S1: ecString;
    se: TreSubExpr;
    l: integer;
    b: Boolean;
  function Min(a, b: integer): integer;
  begin
    if a < b then Result := a else Result := b;
  end;
begin
  Result := 0;
  with Root do
   if FSubExpr.Count > FRef then
    begin
     se := TreSubExpr(FSubExpr[FRef]);
     l := abs(se.FEnd - se.FStart);
     if (se.FStart > 0) and (se.FEnd > 0) and (l < aPos) then
      begin
        S := Copy(InputString, Min(se.FStart, se.FEnd), l);
        S1 := Copy(InputString, aPos - l, l);
        if FIgnoreCase then b := SameText(S, S1)
         else b := S = S1;
        if b then Dec(aPos, l);
        if b then Result := 1;
      end;
    end;
end;

function TRefNode.Match(const InputString: ecString; var aPos: integer): integer;
var S, S1: ecString;
    se: TreSubExpr;
    Len, l: integer;
    b: Boolean;
begin
  Result := 0;
  Len := Length(InputString);
  with Root do
   if FSubExpr.Count > FRef then
    begin
     se := TreSubExpr(FSubExpr[FRef]);
     l := se.FEnd - se.FStart;
     if (se.FStart > 0) and (se.FEnd > 0) and (se.FEnd <= Len + 1) and
        (l <= Len - aPos + 1) then
      begin
        S := Copy(InputString, se.FStart, l);
        S1 := Copy(InputString, aPos, l);
        if FIgnoreCase then b := SameText(S, S1)
         else b := S = S1;
        if b then Inc(aPos, l);
        if b then Result := 1;
      end;
    end;
end;

{ TzContainerNode }

procedure TreListNodeBase.Clear;
begin
  FList.Clear;
end;

constructor TreListNodeBase.Create(AOwner: TreSubExpr);
begin
  inherited;
  FList := TObjectList.Create;
end;

destructor TreListNodeBase.Destroy;
begin
  FList.Free;
  inherited;
end;

{ TreBranchNode }

procedure TreBranchNode.Add(Node: TRENodeBase);
begin
  if FList.Count > 0 then
   TRENodeBase(FList.Last).Next := Node;
  FList.Add(Node);
end;

procedure TreBranchNode.Compile(const Expression: ecString; var aPos: integer;
  Modifiers: integer);
var Len: integer;
    sub: TreSubExpr;
    C: ecChar;

    function SafeInc(RaiseEx: Boolean = False): ecChar; // Increment position to the next significant char
    begin
      inc(aPos);
      // Skip spaces and comments
      if (Modifiers and MaskModX) <> 0 then
        while (aPos <= Len) and (IsSpaceChar(Expression[aPos]) or (Expression[aPos] = '#')) do
         begin
          if Expression[aPos] = '#' then
           begin
            Inc(aPos);
            while (aPos <= Len) and not IsLineBreakChar(Expression[aPos]) do
              Inc(aPos);
           end;
          Inc(aPos);
         end;

      if aPos <= Len then Result := Expression[aPos] else
       begin
         Result := #0;
         if RaiseEx then
           raise Exception.Create(zreUnexpectedEnd);
       end;
    end;

    function ReadNumber: integer;
    var strt: integer;
    begin
      strt := aPos;
      while (aPos <= Len) and (Expression[aPos] >= '0') and (Expression[aPos] <= '9') do
       Inc(aPos);
      if strt = aPos then
       raise Exception.Create('Number is expected');
      Result := StrToInt(Copy(Expression, strt, aPos - strt));
      Dec(aPos);
    end;

    // Read repeaters for node
    procedure ReadRepeaters(Node: TRENodeBase);
    begin
      if aPos > Len then Exit;// repeaters are optional
      case SafeInc of
        '+': Node.FLoopMax := -1;
        '?': Node.FLoopMin := 0;
        '*': begin
               Node.FLoopMax := -1;
               Node.FLoopMin := 0;
             end;
        '{': begin
              SafeInc;
              Node.FLoopMin := ReadNumber;
              case SafeInc of
                ',': if SafeInc <> '}' then
                       begin
                        Node.FLoopMax := ReadNumber;
                        if SafeInc <> '}' then
                          raise Exception.Create('There is no closing "}"');
                       end
                     else
                       Node.FLoopMax := -1;
                '}': Node.FLoopMax := Node.FLoopMin;
                else raise Exception.Create('Invalid loop specifier');
              end;
              if (Node.FLoopMax >= 0) and (Node.FLoopMax < Node.FLoopMin) then
                raise Exception.Create('Loop minimum must be less then loop maximum');
             end;
        else begin
              Dec(aPos);
              Exit;
             end
      end;
      if SafeInc = '?' then Node.FNonGreedy := True else
       begin
        Node.FNonGreedy := (Modifiers and MaskModG) = 0;
        Dec(aPos);
       end;
    end;

    procedure AddCharSeq(const C: ecChar);
    var csNode: TCharSeqNode;
    begin
      csNode := TCharSeqNode.Create(Owner);
      csNode.FIgnoreCase := (Modifiers and MaskModI) <> 0;
      if csNode.FIgnoreCase then csNode.FChar := ecUpCase(C)
                            else csNode.FChar := C;
      Add(csNode);
      ReadRepeaters(csNode);
    end;

    procedure AddSpecNode(const C: ecChar; WithRepeat: Boolean = True);
    var sn: TSpecCheckNode;
    begin
      sn := TSpecCheckNode.Create(Owner);
      sn.FCheckType := C;
      Add(sn);
      if WithRepeat then ReadRepeaters(sn);
    end;

    function GetClassChar(C: ecChar): ecChar;
    begin
      if (MaskModR and Modifiers) = 0 then
      case C of
        'w': Result := 'c';
        'W': Result := 'C';
        'd': Result := 'k';
        'D': Result := 'K';
        'l': Result := 'g';
        'L': Result := 'G';
        's', 'S', 'h', 'H', 'c', 'C', 'g', 'G', 'k', 'K': Result := C;
        else Result := #0;
      end else
      case C of
        'w', 'W', 'd', 'D', 'l', 'L',
        's', 'S', 'h', 'H', 'c', 'C', 'g', 'G', 'k', 'K': Result := C;
        else Result := #0;
      end;
    end;

    function PickSetChar(cs: TCharSetNode): ecChar;
    begin
      Result := Expression[aPos];
      if Result = '\' then
       begin
         Inc(aPos);
         if aPos > Length(Expression) then
          Exit;
         Result := GetEscape(Expression, aPos);
         if Result = #0 then
          begin
            Result := GetClassChar(Expression[aPos]);
            if Result = #0 then Result := Expression[aPos]
              else
                begin
                  cs.AddSet(Result);
                  Result := #0;
                end;
          end;
       end;
    end;

    procedure ReadCharSet;
    var cs: TCharSetNode;
        Cstrt, Cend: ecChar;
    begin
      cs := TCharSetNode.Create(Owner);
      cs.FIgnoreCase := (Modifiers and MaskModI) <> 0;
      Add(cs);
      Cstrt := #0;
      if SafeInc(True) = '^' then cs.FInvert := True
        else Cstrt := PickSetChar(cs);
      while SafeInc(True) <> ']' do
       begin
         if (Expression[aPos] = '-') and (Cstrt <> #0) then // Add Range
          if SafeInc = ']' then
           begin
            cs.AddChar(Cstrt);
            Cstrt := '-';
            Break;
           end else
           begin
            Cend := PickSetChar(cs);
            if Cend = #0 then
             begin
              cs.AddChar(Cstrt);
              Cstrt := '-';
             end else
             if Ord(Cend) < Ord(Cstrt) then
              raise Exception.Create('Invalid set range') else
              begin
               // Extended russian support
               cs.AddRange(Cstrt, Cend);
               Cstrt := #0;
               if SafeInc(True) = ']' then Break;
              end;
           end;
         if Cstrt <> #0 then cs.AddChar(Cstrt);
         Cstrt := PickSetChar(cs);
       end;
      if Cstrt <> #0 then cs.AddChar(Cstrt);
      ReadRepeaters(cs);
    end;

    procedure AddRefNode(RefIdx: integer);
    var rn: TRefNode;
    begin
      if Root.FSubExpr.Count <= RefIdx then
       raise Exception.Create('Invalid reference');
      rn := TRefNode.Create(Owner);
      rn.FRef := RefIdx;
      rn.FIgnoreCase := (Modifiers and MaskModI) <> 0;
      rn.FOwner := Self;
      Add(rn);
      ReadRepeaters(rn);
    end;
begin
  Clear;
  Len := Length(Expression);
  Dec(aPos);
  while aPos <= Len do
   begin
     case SafeInc of
       ')', '|', #0: Exit; // end of branch
       '(': begin
             if SafeInc = '?' then
              begin // Change modifiers
                SafeInc(True); // skip '?'
                if Expression[aPos] <> '#' then
                  ParseModifiers(Expression, aPos, Modifiers)
                else
                 repeat // skip comment
                  Inc(aPos);
                 until (aPos > Len) or (Expression[aPos] = ')');
              end else
              begin // sub expression
                sub := TreSubExpr.Create(Owner);
                Add(sub);
                sub.Compile(Expression, aPos, Modifiers);
                if (aPos > Len) or (Expression[aPos] <> ')') then
                 raise Exception.Create('Do not closed sub expression');
                ReadRepeaters(sub);
              end;
            end;
       '[': begin    // char set node
              ReadCharSet;
            end;
       '^': if (Modifiers and MaskModM) = 0 then AddSpecNode('A', False)  // begin of text
                                            else AddSpecNode('^', False); // begin of line
       '$': if (Modifiers and MaskModM) = 0 then AddSpecNode('Z', False)  // end of text
                                            else AddSpecNode('$', False); // end of line
       '.': if (Modifiers and MaskModS) <> 0  then AddSpecNode('.')  // all
                                             else AddSpecNode(':'); // all without line separators
       '\': begin
              Inc(aPos);
              if aPos > Len then C := '\'
               else C := GetEscape(Expression, aPos);
              if C <> #0 then AddCharSeq(C) else
               begin
                 C := GetClassChar(Expression[aPos]);
                 if C <> #0 then AddSpecNode(C) else
                 case Expression[aPos] of
                   'A', 'Z', 'b', 'B', 'z': AddSpecNode(Expression[aPos]);
                   '1'..'9': AddRefNode(Ord(Expression[aPos])-Ord('0'));
                   else      AddCharSeq(Expression[aPos]);
                 end;
               end;
            end;
       else AddCharSeq(Expression[aPos]); // Simple char
     end;
   end;
end;

// Main mtaching routine (recursive)
// Returns:
//  0 - does not match
//  1 - match the Node
//  2 - match The Node and all next nodes
function MatchNode(Node: TreNodeBase; const InputString: ecString; var aPos: integer): integer;
var save, k, sv, LastSucc, total, Success: integer;
    IsBrEnd: Boolean;
begin
  if Node = nil then
    begin
      Result := 2;
      Exit;
    end;
  Result := 0;

  // required minimum repeat
  save := aPos;
  for k := 1 to node.FLoopMin do
   if Node.Match(InputString, aPos) = 0 then
    begin
     aPos := save;
     {$IFDEF RE_DEBUG}
     if Assigned(REDebugOnMatchProc) then
       REDebugOnMatchProc(Format('Node: %d; Position: %d; Result: %d',[Node.FNodeID, aPos, 0]));
     {$ENDIF}
     Exit;
    end;

  k := node.FLoopMin - 1;
  LastSucc := 0;
  total := 0;

  IsBrEnd := Assigned(Node.Owner) and
             ((Node.Next = nil) or (Node.Next.Owner <> Node.Owner));
  repeat
    Inc(k);
    sv := aPos;
    if IsBrEnd then Node.Owner.FEnd := aPos;
    if Node is TreSubExpr then
      Success := MatchNode(Node.Next, InputString, aPos){TreSubExpr(Node).FSuccessNext} else
    if Node.Next <> nil then
      Success := MatchNode(Node.Next, InputString, aPos) else
    if IsBrEnd then
      Success := MatchNode(Node.Owner.Next, InputString, aPos) else
      Success := 2;

    if Success = 2 then // success all next nodes
     begin
       {$IFDEF RE_DEBUG}
       if Assigned(REDebugOnMatchProc) then
          REDebugOnMatchProc(Format('Success at %d;  Node: %d; NextRes: %s',[sv, Node.FNodeID, IntToStr(Success)]));
       {$ENDIF}
       total := aPos;
       LastSucc := sv;
       aPos := LastSucc;
       Result := Success;
       if node.FNonGreedy then Break; // for non GREEDY mode
     end else
    if IsBrEnd then
      begin
       total := sv;
       Result := 1;
      end else
    if Success = 1 then
      begin
        aPos := sv;
        total := sv;
        Result := 1;
      end;

    if (node.FLoopMax > 0) and (k >= node.FLoopMax) then // check max limit
      begin
        if not IsBrEnd then  //v2.36
          Result := Success; //v2.33
        Break;
      end;

    sv := aPos;
    Success := Node.Match(InputString, aPos);
  until (Success = 0) or (aPos = sv);

{$IFDEF RE_DEBUG}
  if Assigned(REDebugOnMatchProc) then
    REDebugOnMatchProc(Format('Node: %d; Position: %d; Result: %d',[Node.FNodeID, aPos, integer(Result)]));
{$ENDIF}
  if Result > 0 then
   begin
    aPos := total;
    // Save sub-expression result
    if IsBrEnd and (LastSucc > 0) then
      Node.Owner.FEnd := LastSucc;
   end else
   begin
    aPos := save;
    if IsBrEnd then Node.Owner.FEnd := 0;
   end;
end;
(*function MatchNode(Node: TreNodeBase; const InputString: ecString; var aPos: integer): Boolean;
var save, k, sv, LastSucc, total: integer;
    IsBrEnd, Success: Boolean;
begin
  Result := Node = nil;
  if Result then Exit;
  Result := False;

  // required minimum repeat
  save := aPos;
  for k := 1 to node.FLoopMin do
   if not Node.Match(InputString, aPos) then
    begin
     aPos := save;
     {$IFDEF RE_DEBUG}
     if Assigned(REDebugOnMatchProc) then
       REDebugOnMatchProc(Format('Node: %d; Position: %d; Result: %d',[Node.FNodeID, aPos, 0]));
     {$ENDIF}
     Exit;
    end;

  k := node.FLoopMin - 1;
  LastSucc := 0;
  total := 0;

  IsBrEnd := Assigned(Node.Owner) and
             ((Node.Next = nil) or (Node.Next.Owner <> Node.Owner));
  repeat
    Inc(k);
    sv := aPos;
    if IsBrEnd then Node.Owner.FEnd := aPos;
    if Node is TreSubExpr then
      Success := MatchNode(Node.Next, InputString, aPos){TreSubExpr(Node).FSuccessNext} else
    if Node.Next <> nil then
      Success := MatchNode(Node.Next, InputString, aPos) else
    if IsBrEnd then
      Success := MatchNode(Node.Owner.Next, InputString, aPos) else
      Success := True;

    if Success then
     begin
       {$IFDEF RE_DEBUG}
       if Assigned(REDebugOnMatchProc) then
          REDebugOnMatchProc(Format('Success at %d;  Node: %d; NextRes: %s',[sv, Node.FNodeID, BoolToStr(Success)]));
       {$ENDIF}
       total := aPos;
       LastSucc := sv;
       aPos := LastSucc;
       Result := True;
       if node.FNonGreedy then Break; // for non GREEDY mode
     end else
    if IsBrEnd then
      begin
       total := sv;
       Result := True;
      end;
    if (node.FLoopMax > 0) and (k >= node.FLoopMax) then // check max limit
      begin
        if not IsBrEnd then  //v2.36
          Result := Success; //v2.33
        Break;
      end;

    sv := aPos;
    Success := Node.Match(InputString, aPos);
  until not Success or (aPos = sv);

{$IFDEF RE_DEBUG}
  if Assigned(REDebugOnMatchProc) then
    REDebugOnMatchProc(Format('Node: %d; Position: %d; Result: %d',[Node.FNodeID, aPos, integer(Result)]));
{$ENDIF}
  if Result then
   begin
    aPos := total;
    // Save sub-expression result
    if IsBrEnd and (LastSucc > 0) then
      Node.Owner.FEnd := LastSucc;
   end else
   begin
    aPos := save;
    if IsBrEnd then Node.Owner.FEnd := 0;
   end;
end;               *)

// Main mtaching routine (recursive)
function BackMatchNode(Node: TreNodeBase; const InputString: ecString; var aPos: integer): integer;
var save, k, sv, LastSucc, total, Success: integer;
    IsBrEnd: Boolean;
begin
  if Node = nil then
    begin
      Result := 2;
      Exit;
    end;
  Result := 0;

  // required minimum repeat
  save := aPos;
  for k := 1 to node.FLoopMin do
   if Node.BackMatch(InputString, aPos) = 0 then
    begin
     aPos := save;
     {$IFDEF RE_DEBUG}
     if Assigned(REDebugOnMatchProc) then
       REDebugOnMatchProc(Format('Node: %d; Position: %d; Result: %d',[Node.FNodeID, aPos, 0]));
     {$ENDIF}
     Exit;
    end;

  k := node.FLoopMin - 1;
  LastSucc := 0;
  total := 0;

  IsBrEnd := Assigned(Node.Owner) and
             ((Node.Next = nil) or (Node.Next.Owner <> Node.Owner));
  repeat
    Inc(k);
    sv := aPos;
    if IsBrEnd then Node.Owner.FStart := aPos;
    if Node is TreSubExpr then
      Success := BackMatchNode(Node.Next, InputString, aPos) else
    if Node.Next <> nil then
      Success := BackMatchNode(Node.Next, InputString, aPos) else
    if IsBrEnd then
      Success := BackMatchNode(Node.Owner.Next, InputString, aPos) else
      Success := 2;

    if Success = 2 then
     begin
       {$IFDEF RE_DEBUG}
       if Assigned(REDebugOnMatchProc) then
          REDebugOnMatchProc(Format('Success at %d;  Node: %d; NextRes: %s',[sv, Node.FNodeID, IntToStr(Success)]));
       {$ENDIF}
       total := aPos;
       LastSucc := sv;
       aPos := LastSucc;
       Result := Success;
       if node.FNonGreedy then Break; // for non GREEDY mode
     end else
    if IsBrEnd then
      begin
       total := sv;
       Result := 1;
      end else
    if Success = 1 then
      begin
        aPos := sv;
        total := sv;
        Result := 1;
      end;
      
    if (node.FLoopMax > 0) and (k >= node.FLoopMax) then // check max limit
      begin
        if not IsBrEnd then  //v2.36
          Result := Success; //v2.33
        Break;
      end;

    sv := aPos;
    Success := Node.BackMatch(InputString, aPos);
  until (Success = 0) or (aPos = sv);

{$IFDEF RE_DEBUG}
  if Assigned(REDebugOnMatchProc) then
    REDebugOnMatchProc(Format('Node: %d; Position: %d; Result: %d',[Node.FNodeID, aPos, integer(Result)]));
{$ENDIF}
  if Result > 0 then
   begin
    aPos := total;
    // Save sub-expression result
    if IsBrEnd and (LastSucc > 0) then
      Node.Owner.FStart := LastSucc;
   end else
   begin
    aPos := save;
    if IsBrEnd then Node.Owner.FStart := 0;
   end;
end;

function TreBranchNode.Match(const InputString: ecString; var aPos: integer): integer;
begin
{$IFDEF RE_DEBUG}
  if Assigned(REDebugOnMatchProc) then
    REDebugOnMatchProc(Format('Branch<: %d; Position: %d; Result: %d',[FNodeID, aPos, integer(Result)]));
{$ENDIF}
  if FList.Count = 0 then Result := 1
    else Result := MatchNode(TreNodeBase(FList.First), InputString, aPos);
{$IFDEF RE_DEBUG}
  if Assigned(REDebugOnMatchProc) then
    REDebugOnMatchProc(Format('Branch>: %d; Position: %d; Result: %d',[FNodeID, aPos, integer(Result)]));
{$ENDIF}
end;

function TreBranchNode.BackMatch(const InputString: ecString; var aPos: integer): integer;
begin
{$IFDEF RE_DEBUG}
  if Assigned(REDebugOnMatchProc) then
    REDebugOnMatchProc(Format('Branch<: %d; Position: %d; Result: %d',[FNodeID, aPos, integer(Result)]));
{$ENDIF}
  if FList.Count = 0 then Result := 1
    else Result := BackMatchNode(TreNodeBase(FList.First), InputString, aPos);
{$IFDEF RE_DEBUG}
  if Assigned(REDebugOnMatchProc) then
    REDebugOnMatchProc(Format('Branch>: %d; Position: %d; Result: %d',[FNodeID, aPos, integer(Result)]));
{$ENDIF}
end;

{ TreSubExpr }

procedure TreSubExpr.Compile(const Expression: ecString; var aPos: integer;
  Modifiers: integer);
var Br: TreBranchNode;
begin
  Dec(aPos);
  repeat
    Inc(aPos);
    Br := TreBranchNode.Create(Self);
    FList.Add(Br);
    Br.Compile(Expression, aPos, Modifiers);
    if Br.FList.Count = 0 then FList.Remove(Br);
  until (aPos > Length(Expression)) or (Expression[aPos] = ')');
end;

constructor TreSubExpr.Create(AOwner: TreSubExpr);
begin
  inherited;
  if Owner <> nil then
    Root.FSubExpr.Add(Self);
end;

function TreSubExpr.Match(const InputString: ecString; var aPos: integer): integer;
var i: integer;
    OldEnd, OldStart, CurRes, svPos: integer;
begin
  OldEnd := FEnd;
  OldStart := FStart;
  FStart := aPos;
  FEnd := 0;
  Result := 0;
  svPos := aPos;
  for i := 0 to FList.Count - 1 do
    begin
      CurRes := TreBranchNode(FList[i]).Match(InputString, aPos);
      if CurRes > Result then
        begin
          OldEnd := FEnd;
          OldStart := FStart;
          Result := CurRes;
          aPos := svPos;
          if Result = 2 then
            Break;
        end;
    end;
  FEnd := OldEnd;
  FStart := OldStart;
  if (FEnd > 0) and (Result > 0) then
    aPos := FEnd;
end;

function TreSubExpr.BackMatch(const InputString: ecString; var aPos: integer): integer;
var i: integer;
    OldEnd, OldStart, CurRes, svPos: integer;
begin
  OldEnd := FEnd;
  OldStart := FStart;
  FStart := 0;
  FEnd := aPos;
  Result := 0;
  svPos := aPos;
  for i := 0 to FList.Count - 1 do
    begin
     CurRes := TreBranchNode(FList[i]).BackMatch(InputString, aPos);
      if CurRes > Result then
        begin
          OldEnd := FEnd;
          OldStart := FStart;
          Result := CurRes;
          aPos := svPos;
          if Result = 2 then
            Break;
        end;
    end;
  FEnd := OldEnd;
  FStart := OldStart;
  if (FStart > 0) and (Result > 0) then
    aPos := FStart;
end;

{ TreRootNode }

procedure TreRootNode.Clear;
begin
  inherited;
  FSubExpr.Clear;
  FSubExpr.Add(Self);
end;

constructor TreRootNode.Create(AOwner: TreSubExpr);
begin
  inherited Create(nil);
  FSubExpr := TList.Create;
  FSubExpr.Add(Self)
end;

destructor TreRootNode.Destroy;
begin
  FSubExpr.Free;
  inherited;
end;

function TreRootNode.MatchStr(const InputString: ecString;
  var aPos: integer; Back: Boolean): Boolean;
var i: integer;
begin
  for i := 0 to FSubExpr.Count - 1 do
   begin
     TreSubExpr(FSubExpr[i]).FStart := -1;
     TreSubExpr(FSubExpr[i]).FEnd := -1;
   end;
  if Back then
    Result := BackMatchNode(Self, InputString, aPos) <> 0
  else
    Result := MatchNode(Self, InputString, aPos) <> 0;
end;

{ TecRegExpr }

// =============================================================================
//   Application Level
// =============================================================================

procedure TecRegExpr.Compile;
var FPos, Modifiers: integer;
begin
 {$IFDEF RE_DEBUG}
 LastNodeID := 0;
 {$ENDIF}
 FPos := 1;
 Modifiers := FModifiers;
 FMatchOK := False;
 try
   TreRootNode(FProgRoot).Clear;
   if Expression <> '' then
     TreRootNode(FProgRoot).Compile(FExpression, FPos, Modifiers);
 except
   TreRootNode(FProgRoot).Clear;
   raise;
 end;
end;

constructor TecRegExpr.Create;
begin
  inherited;
  FProgRoot := TreRootNode.Create(nil);
  FModifiers := MaskModI or MaskModR or MaskModG or MaskModM or MaskModX;
end;

destructor TecRegExpr.Destroy;
begin
  FProgRoot.Free;
  inherited;
end;

function TecRegExpr.GetIsInvalid: Boolean;
begin
  try
   if TreRootNode(FProgRoot).FList.Count = 0 then Compile;
  except
  end;
  Result := TreRootNode(FProgRoot).FList.Count = 0;
end;

function TecRegExpr.GetModifier(const Index: Integer): boolean;
begin
  Result := (FModifiers and Index) <> 0;
end;

function TecRegExpr.GetModifierStr: ecString;
const ModLet: ecString = 'irsgmx';
var s1, s2: string;
    i: integer;
begin
  s1 := ''; s2 := '';
  for i := 0 to 5 do
   if (FModifiers and (1 shl i)) <> 0 then
    s1 := s1 + ModLet[i + 1]
   else
    s2 := s2 + ModLet[i + 1];

  Result := '(?' + s1;
  if s2 <> '' then
   Result := Result + '-' + s2;
  Result := Result + ')';
end;

function TecRegExpr.Match(const InputString: ecString; var aPos: integer; Back: Boolean): Boolean;
begin
  if FProgRoot = nil then
   begin
    Result := False;
    Exit;
   end;
  if TreRootNode(FProgRoot).FList.Count = 0 then Compile;
  if aPos < 1 then
    aPos := 1;
  Result := TreRootNode(FProgRoot).MatchStr(InputString, aPos, Back);
  FMatchOK := Result;
end;

function TecRegExpr.MatchLength(const InputString: ecString;
  aPos: integer; Back: Boolean): integer;
begin
  Result := aPos;
  if Match(InputString, aPos, Back) then
    begin
     if Back then
       Result := Result - aPos
     else
       Result := aPos - Result;
    end
  else
    Result := 0;
end;

procedure TecRegExpr.SetExpression(const Value: ecString);
begin
  FExpression := Value;
  TreRootNode(FProgRoot).Clear;
end;

procedure TecRegExpr.SetModifier(const Index: Integer;
  const Value: boolean);
begin
  if Value then FModifiers := FModifiers or Index
   else FModifiers := FModifiers and not Index;
  TreRootNode(FProgRoot).Clear;
end;

procedure TecRegExpr.SetModifiers(const Value: Word);
begin
  FModifiers := Value;
  TreRootNode(FProgRoot).Clear;
end;

procedure TecRegExpr.SetModifierStr(const Value: ecString);
var aPos, md: integer;
begin
  aPos := 3;
  md := FModifiers;
  if (Length(Value) >= 3) and (Copy(Value, 1, 2) = '(?') then
   begin
    ParseModifiers(Value, aPos, md);
    FModifiers := md;
   end;
end;

function TecRegExpr.GetMatchLen(Idx: integer): integer;
begin
  Result := -1;
  if FMatchOK then
   if (idx < TreRootNode(FProgRoot).FSubExpr.Count) then
    with TreSubExpr(TreRootNode(FProgRoot).FSubExpr[Idx]) do
     if (FStart <> -1) and (FEnd <> -1) then
      Result := FEnd - FStart;
end;

function TecRegExpr.GetMatchPos(Idx: integer): integer;
begin
  Result := -1;
  if FMatchOK then
   if (idx < TreRootNode(FProgRoot).FSubExpr.Count) then
    with TreSubExpr(TreRootNode(FProgRoot).FSubExpr[Idx]) do
     Result := FStart;
end;

function TecRegExpr.GetSubExprMatchCount: integer;
var i: integer;
begin
  Result := -1;
  if FMatchOK then
  for i := 0 to TreRootNode(FProgRoot).FSubExpr.Count - 1 do
   with TreSubExpr(TreRootNode(FProgRoot).FSubExpr[i]) do
    if (FStart <> -1) and (FEnd <> -1) then
     Inc(Result);
end;

function TecRegExpr.GetMatch(const InputString: ecString;
  SubIdx: integer): ecString;
begin
  Result := '';
  if (SubIdx < TreRootNode(FProgRoot).FSubExpr.Count) then
   with TreSubExpr(TreRootNode(FProgRoot).FSubExpr[SubIdx]) do
    if (FStart <> -1) and (FEnd <> -1) then
     Result := Copy(InputString, FStart, FEnd - FStart);
end;

function TecRegExpr.Substitute(const InputString, ATemplate: ecString): ecString;
var i: integer;
    C: ecChar;
begin
//  if not FMatchOK then
//   raise Exception.Create('No matched string');
  Result := '';
  i := 1;
  while i <= Length(ATemplate) do
   begin
     if (ATemplate[i] = '\') and (i < Length(ATemplate)) then
      begin
       inc(i);
       if IsDigitChar(ATemplate[i]) then
         Result := Result + GetMatch(InputString, StrToInt(ATemplate[i]))
       else
        begin
         C := GetEscape(ATemplate, i);
         if C = #0 then C := ATemplate[i];
         Result := Result + C;
        end;
      end else Result := Result + ATemplate[i];
     inc(i);
   end;
end;

procedure TecRegExpr.Assign(Source: TPersistent);
begin
  if Source is TecRegExpr then
    with Source as TecRegExpr do
      begin
        Expression := Self.Expression;
        ModifierMask := Self.ModifierMask;
      end
  else inherited;
end;

end.




