stregex.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

      read FMaxLineLength
      write FMaxLineLength;

  published
    property Avoid : Boolean
      read FAvoid
      write FAvoid default False;

    property IgnoreCase : Boolean
      read FIgnoreCase
      write FIgnoreCase default False;

    property InFixedLineLength : Integer
      read FInFixedLineLength
      write FInFixedLineLength default 80;

    property InLineTermChar : AnsiChar
      read FInLineTermChar
      write FInLineTermChar default #10;

    property InLineTerminator : TStLineTerminator
      read FInLineTerminator
      write FInLineTerminator default ltCRLF;

    property InputFile : AnsiString
      read FInputFile
      write FInputFile;

    property LineNumbers : Boolean
      read FLineNumbers
      write FLineNumbers default False;

    property MatchPattern : TStringList
      read FMatchPatSL
      write SetMatchPatSL;

    property OnMatch : TStOnMatchEvent
      read FOnMatch
      write FOnMatch;

    property OnProgress : TStOnRegExProgEvent
      read FOnProgress
      write FOnProgress;

    property OutFixedLineLength : Integer
      read FOutFixedLineLength
      write FOutFixedLineLength default 80;

    property OutLineTermChar : AnsiChar
      read FOutLineTermChar
      write FOutLineTermChar default #10;

    property OutLineTerminator : TStLineTerminator
      read FOutLineTerminator
      write FOutLineTerminator default ltCRLF;

    property OutputFile : AnsiString
      read FOutputFile
      write FOutputFile;

    property OutputOptions : TStOutputOptions
      read FOutputOptions
      write SetOptions;

    property ReplacePattern : TStringList
      read FReplacePatSL
      write SetReplacePatSL;

    property SelAvoidPattern : TStringList
      read FSelAvoidPatSL
      write SetSelAvoidPatSL;
  end;


implementation

uses
  StStrL,
  StStrS,
  StStrZ;


const
  Null           = #0;
  EndStr         = #0;
  NewLine        = #13#10;
  Dash           = '-';
  Esc            = '\';
  Any            = '.';  {was '?'}
  Closure        = '*';
  ClosurePlus    = '+';
  MaybeOne       = '?';  {was '!'}
  Bol            = '^';
  Eol            = '$';
  Ccl            = '[';
  Negate         = '^';
  CclEnd         = ']';
  BTag           = '{';
  ETag           = '}';
  BGroup         = '(';
  EGroup         = ')';
  Alter          = '|';  {was #}
  Ditto          = '&';
  lSpace         = 's';
  lNewline       = 'n';
  lTab           = 't';
  lBackSpace     = 'b';
  lReturn        = 'r';
  lFeed          = 'l';
  lHex           = 'h';
  lWordDelim     = 'w';
  lNil           = 'z';


function CleanUpCase(S : ShortString) : ShortString;
{-convert string to uppercase and remove duplicates}
var
  I  : Integer;
  K  : Cardinal;
  C  : AnsiChar;
begin
  Result := '';
  S := AnsiUpperCase(S);
  for I := 1 to Length(S) do begin
    C := S[I];
    if not StrChPosS(Result, C, K) then
      Result := Result + C;
  end;
end;


procedure AppendChar(C : AnsiChar; var S : ShortString);
 {-append a character C onto string S}
begin
  S := S + C;
end;


function IsAlphaNum(C : AnsiChar) : Boolean;
begin
  Result := IsCharAlphaNumeric(C);
end;


procedure ExpandDash(Delim       : AnsiChar;
                     var Pattern : PAnsiChar ;
                     var I       : Integer;
                     var S       : ShortString);
{-expand the innards of the character class, including dashes}
{stop when endc is found}
{return a string S with the expansion}
var
  C,
  CLeft,
  CNext  : AnsiChar;
  K      : Integer;

begin
  while (Pattern[I] <> Delim) and (Pattern[I] <> EndStr) do begin
    C := Pattern[I];
    if (C = Esc) then begin
      if (Pattern[Succ(I)] <> EndStr) then begin
        I := Succ(I);
        C := Pattern[I];
        case C of
          lSpace      : AppendChar(#32, S);
          lTab        : AppendChar(#9,  S);
          lBackSpace  : AppendChar(#8,  S);
          lReturn     : AppendChar(#13, S);
          lFeed       : AppendChar(#10, S);
        else
          AppendChar(C, S);
        end;
      end else
        {escape must be the character}
        AppendChar(Esc, S);
    end else if (C <> Dash) then
      {literal character}
      AppendChar(C, S)
    else if ((Length(S) = 0) or (Pattern[Succ(I)] = Delim)) then
      {literal dash at begin or end of class}
      AppendChar(Dash, S)
    else begin
      {dash in middle of class}
      CLeft := Pattern[Pred(I)];
      CNext := Pattern[Succ(I)];
      if IsAlphaNum(CLeft) and IsAlphaNum(CNext) and (CLeft <= CNext) then begin
        {legal dash to be expanded}
        for K := (Ord(CLeft)+1) to Ord(CNext) do
          AppendChar(Chr(K), S);
        {move over the end of dash character}
        I := Succ(I);
      end else
        {dash must be a literal}
        AppendChar(Dash, S);
    end;
    I := Succ(I);
  end;
end;


function GetCharacterClass(var Pattern : PAnsiChar;
                           var I       : Integer;
                           var S       : ShortString;
                           var AToken  : TStTokens) : Boolean;
{-expand a character class starting at position I of Pattern into a string S}
{return a token type (tknCharClass or tknNegCharClass)}
{return I pointing at the end of class character}
{return true if successful}

begin
{skip over start of class character}
  I := Succ(I);
  if (Pattern[I] = Negate) then begin
    AToken := tknNegCharClass;
    I := Succ(I);
  end else
    AToken := tknCharClass;
  {expand the character class}
  S := '';
  ExpandDash(CclEnd, Pattern, I, S);
  Result := (Pattern[I] = CclEnd);
end;





{******************************************************************************}
{                           TStNodeHeap Implementation                         }
{******************************************************************************}

constructor TStNodeHeap.Create;
begin
  inherited Create;

  New(FFreeList);
  FillChar(FFreeList^, sizeof(TStPatRecord), 0);
end;


destructor TStNodeHeap.Destroy;
begin
  nhClearHeap;
  Dispose(FFreeList);

  inherited Destroy;
end;


function TStNodeHeap.AllocNode : PStPatRecord;
begin
  if (FFreeList^.NextPattern = nil) then
    New(Result)
  else begin
    Result := FFreeList^.NextPattern;
    FFreeList^.NextPattern := Result^.NextPattern;
  end;
  FillChar(Result^, sizeof(TStPatRecord), 0);
end;


function TStNodeHeap.CloneNode(aNode : PStPatRecord) : PStPatRecord;
begin
  {allocate a new node}
  Result := AllocNode;

  {copy fields}
  Result^.Token         := aNode^.Token;
  Result^.OneChar       := aNode^.OneChar;
  Result^.NextOK        := aNode^.NextOK;
  if (aNode^.StrPtr <> nil) then begin                                 
    New(Result^.StrPtr);                                               
    Result^.StrPtr^     := aNode^.StrPtr^;                             
  end else                                                             
    Result^.StrPtr      := nil;                                        

  {deep clone the nested node}
  if (aNode^.NestedPattern <> nil) then
    Result^.NestedPattern := nhDeepCloneNode(aNode^.NestedPattern);
end;


procedure TStNodeHeap.FreeNode(aNode : PStPatRecord);
begin
  if (aNode <> nil) then begin
    aNode^.NextPattern := FFreeList^.NextPattern;
    FFreeList^.NextPattern := aNode;
  end;
end;


procedure TStNodeHeap.nhClearHeap;
var
  Walker,
  Temp    : PStPatRecord;
begin
  Walker := FFreeList^.NextPattern;
  FFreeList^.NextPattern := nil;
  while (Walker <> nil) do begin
    Temp := Walker;
    Walker := Walker^.NextPattern;
    Dispose(Temp);
  end;
end;


function TStNodeHeap.nhDeepCloneNode(aNode : PStPatRecord) : PStPatRecord;
begin
  {allocate a new node}
  Result := AllocNode;

  {copy fields}
  Result^.Token         := aNode^.Token;
  Result^.OneChar       := aNode^.OneChar;
  Result^.NextOK        := aNode^.NextOK;
  if (aNode^.StrPtr <> nil) then begin                                 
    New(Result^.StrPtr);                                               
    Result^.StrPtr^     := aNode^.StrPtr^;                             
  end else                                                             
    Result^.StrPtr      := nil;

  {recursively deepclone the next and nested nodes}
  if (aNode^.NextPattern <> nil) then
    Result^.NextPattern := nhDeepCloneNode(aNode^.NextPattern);
  if (aNode^.NestedPattern <> nil) then
    Result^.NestedPattern := nhDeepCloneNode(aNode^.NestedPattern);
end;


{******************************************************************************}
{                           TStStreamRegEx Implementation                      }
{******************************************************************************}


constructor TStStreamRegEx.Create;
begin
  inherited Create;

  FAvoid          := False;
  FIgnoreCase     := False;
  FLineNumbers    := False;
  FOutputOptions  := [];

  FInLineTerminator := ltCRLF;
  FInLineTermChar   := #10;
  FInLineLength     := 80;

  FOutLineTerminator := ltCRLF;
  FOutLineTermChar   := #10;
  FOutLineLength     := 80;

  FMaxLineLength := 1024;

  FMatchPatSL    := TStringList.Create;
  FMatchPatPtr   := nil;
  FSelAvoidPatSL := TStringList.Create;
  FSelAvoidPatPtr:= nil;
  FReplacePatSL  := TStringList.Create;
  FReplacePatPtr := nil;

  FInputStream      := nil;
  FInTextStream     := nil;
  FOutputStream     := nil;
  FOutTextStream    := nil;

  FNodes    := TStNodeHeap.Create;
end;


procedure TStStreamRegEx.DisposeItems(var Data : PStPatRecord);
var
  Walker, Temp : PStPatRecord;
begin
  if (Data <> nil) then begin
    Walker := Data;
    while (Walker <> nil) do begin
      Temp := Walker;

      if (Assigned(Walker^.StrPtr)) then
        Dispose(Walker^.StrPtr);

      if (Assigned(Walker^.NestedPattern)) then
        DisposeItems(Walker^.NestedPattern);

      Walker := Walker^.NextPattern;
      FNodes.FreeNode(Temp);
    end;
    Data := nil;
  end;
end;


destructor TStStreamRegEx.Destroy;
begin
  DisposeItems(FMatchPatPtr);
  DisposeItems(FSelAvoidPatPtr);
  DisposeItems(FReplacePatPtr);

  FNodes.Free;
  FNodes := nil;

  if (Assigned(FMatchPatStr)) then begin
    FreeMem(FMatchPatStr, StrLen(FMatchPatStr) + 1);
    FMatchPatStr := nil;
  end;

  if (Assigned(FReplacePatStr)) then
    FreeMem(FReplacePatStr, StrLen(FReplacePatStr) + 1);
  FReplacePatStr := nil;

  if (Assigned(FSelAvoidPatStr)) then
    FreeMem(FSelAvoidPatStr, StrLen(FSelAvoidPatStr) + 1);
  FSelAvoidPatStr := nil;

  FMatchPatSL.Free;
  FMatchPatSL := nil;

  FReplacePatSL.Free;
  FReplacePatSL := nil;

  FSelAvoidPatSL.Free;