unit UParseText;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

const
  anyChar = [chr(0)..chr(255)];

type
  TLocation = record
                start : integer;
                len   : integer;
              end;
  TSetOfChars = set of char;

  EParseText = class(Exception);

  TPatternPart = class(TComponent)
  private
    { Private-Deklarationen }
    myNumChars   : integer;
    mySetOfChars : TSetOfChars;
    myCaseSensitive : boolean;
  protected
    { Protected-Deklarationen }
  public
    { Public-Deklarationen }
    property numChars   : integer     read myNumChars;
    property setOfChars : TSetOfChars read mySetOfChars;
    property caseSensitive : boolean read myCaseSensitive write myCaseSensitive;
    procedure init(pattern : string; var position : integer);
    constructor create(AOwner: TComponent); override;
  published
    { Published-Deklarationen }
  end;

  TPattern = class(TComponent)
  private
    { Private-Deklarationen }
    myPattern : TStringList;
    myCaseSensitive : boolean;
  protected
    { Protected-Deklarationen }
    procedure createPatternPart(pattern : string; var position : integer);
  public
    { Public-Deklarationen }
    property caseSensitive : boolean read myCaseSensitive write myCaseSensitive;
    procedure showPattern;
    procedure clear;
    procedure init(pattern : string);
    constructor create(AOwner: TComponent); override;
    destructor destroy; override;
  published
    { Published-Deklarationen }
  end;

  EBeforeFindFirst                  = procedure of object;
  EAfterFindFirst                   = procedure (actMatch : integer) of object;
  EBeforeFindPrev                   = procedure (actMatch : integer) of object;
  EAfterFindPrev                    = procedure (actMatch : integer) of object;
  EBeforeFindNext                   = procedure (actMatch : integer) of object;
  EAfterFindNext                    = procedure (actMatch : integer) of object;
  EBeforeFindLast                   = procedure (actMatch : integer) of object;
  EAfterFindLast                    = procedure (actMatch : integer) of object;
  ETextChanged                      = procedure of object;
  EPatternChanged                   = procedure of object;
  ECaseSensitiveChanged             = procedure of object;
  EOverlappingMatchesAllowedChanged = procedure of object;
  EWhichMatchingsChanged            = procedure of object;

  TOverlappingMatchesAllowed = (Yes,No);
  TWhichMatchings            = (All,ShortestOnly,LongestOnly);

const
  omaYes         = TOverlappingMatchesAllowed(Yes);
  omaNo          = TOverlappingMatchesAllowed(No);

  wmAll          = TWhichMatchings(All);
  wmShortestOnly = TWhichMatchings(ShortestOnly);
  wmLongestOnly  = TWhichMatchings(LongestOnly);

type

  TParseText = class(TComponent)
  private
    { Private-Deklarationen }
    myText                               : string;
    myPatternString                      : string;
    myPatternObj                         : TPattern;
    myCaseSensitive                      : boolean;
    myMatches                            : TStringList;
    myActMatch                           : integer;
    myLastLocation                       : TLocation;
    myOverlappingMatchesAllowed          : TOverlappingMatchesAllowed;
    myWhichMatchings                     : TWhichMatchings;

    myOnBeforeFindFirst                  : EBeforeFindFirst;
    myOnAfterFindFirst                   : EAfterFindFirst;
    myOnBeforeFindPrev                   : EBeforeFindPrev;
    myOnAfterFindPrev                    : EAfterFindPrev;
    myOnBeforeFindNext                   : EBeforeFindNext;
    myOnAfterFindNext                    : EAfterFindNext;
    myOnBeforeFindLast                   : EBeforeFindLast;
    myOnAfterFindLast                    : EAfterFindLast;
    myOnTextChanged                      : ETextChanged;
    myOnPatternChanged                   : EPatternChanged;
    myOnCaseSensitiveChanged             : ECaseSensitiveChanged;
    myOnOverlappingMatchesAllowedChanged : EOverlappingMatchesAllowedChanged;
    myOnWhichMatchingsChanged            : EWhichMatchingsChanged;

    procedure setMyText(t : string);
    procedure setMyPatternString(p : string);
    procedure setMyCaseSensitive(cs : boolean);
    procedure setMyOverlappingMatchesAllowed(oma : TOverlappingMatchesAllowed);
    procedure setMyWhichMatchings(wm : TWhichMatchings);
  protected
    { Protected-Deklarationen }
    procedure BeforeFindFirst; dynamic;
    procedure AfterFindFirst(actMatch : integer); dynamic;
    procedure BeforeFindPrev(actMatch : integer); dynamic;
    procedure AfterFindPrev(actMatch : integer); dynamic;
    procedure BeforeFindNext(actMatch : integer); dynamic;
    procedure AfterFindNext(actMatch : integer); dynamic;
    procedure BeforeFindLast(actMatch : integer); dynamic;
    procedure AfterFindLast(actMatch : integer); dynamic;
    procedure TextChanged; dynamic;
    procedure PatternChanged; dynamic;
    procedure CaseSensitiveChanged; dynamic;
    procedure OverlappingMatchesAllowedChanged; dynamic;
    procedure WhichMatchingsChanged; dynamic;

    function getNextMatch : boolean;
  public
    { Public-Deklarationen }
  published
    { Published-Deklarationen }
    property text                               : string                            read myText                               write setMyText;
    property pattern                            : string                            read myPatternString                      write setMyPatternString;
    property caseSensitive                      : boolean                           read myCaseSensitive                      write setMyCaseSensitive;
    property overlappingMatchesAllowed          : TOverlappingMatchesAllowed        read myOverlappingMatchesAllowed          write setMyOverlappingMatchesAllowed;
    property whichMatchings                     : TWhichMatchings                   read myWhichMatchings                     write setMyWhichMatchings;

    property OnBeforeFindFirst                  : EBeforeFindFirst                  read myOnBeforeFindFirst                  write myOnBeforeFindFirst;
    property OnAfterFindFirst                   : EAfterFindFirst                   read myOnAfterFindFirst                   write myOnAfterFindFirst;
    property OnBeforeFindPrev                   : EBeforeFindPrev                   read myOnBeforeFindPrev                   write myOnBeforeFindPrev;
    property OnAfterFindPrev                    : EAfterFindPrev                    read myOnAfterFindPrev                    write myOnAfterFindPrev;
    property OnBeforeFindNext                   : EBeforeFindNext                   read myOnBeforeFindNext                   write myOnBeforeFindNext;
    property OnAfterFindNext                    : EAfterFindNext                    read myOnAfterFindNext                    write myOnAfterFindNext;
    property OnBeforeFindLast                   : EBeforeFindLast                   read myOnBeforeFindLast                   write myOnBeforeFindLast;
    property OnAfterFindLast                    : EAfterFindLast                    read myOnAfterFindLast                    write myOnAfterFindLast;
    property OnTextChanged                      : ETextChanged                      read myOnTextChanged                      write myOnTextChanged;
    property OnPatternChanged                   : EPatternChanged                   read myOnPatternChanged                   write myOnPatternChanged;
    property OnCaseSensitiveChanged             : ECaseSensitiveChanged             read myOnCaseSensitiveChanged             write myOnCaseSensitiveChanged;
    property OnOverlappingMatchesAllowedChanged : EOverlappingMatchesAllowedChanged read myOnOverlappingMatchesAllowedChanged write myOnOverlappingMatchesAllowedChanged;
    property OnWhichMatchingsChanged            : EWhichMatchingsChanged            read myOnWhichMatchingsChanged            write myOnWhichMatchingsChanged;

    procedure showPattern;
    function findFirst(var loc : TLocation) : boolean;
    function findPrev(var loc : TLocation) : boolean;
    function findNext(var loc : TLocation) : boolean;
    procedure findClose;
    constructor create(AOwner: TComponent); override;
    destructor destroy; override;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Freeware', [TParseText]);
end;

end.
