stregex.pas

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

  FOutTextStream := nil;
  try
    FInTextStream := TStAnsiTextStream.Create(FInputStream);
    FInTextStream.LineTermChar := FInLineTermChar;
    FInTextStream.LineTerminator := FInLineTerminator;
    FInTextStream.FixedLineLength := FInLineLength;
    FInFileSize := FInTextStream.Size;

    if not (ooCountOnly in OutputOptions) then begin
      FOutTextStream := TStAnsiTextStream.Create(FOutputStream);
      FOutTextStream.LineTermChar := FOutLineTermChar;
      FOutTextStream.LineTerminator := FOutLineTerminator;
      FOutTextStream.FixedLineLength := FInLineLength;
    end;

    FMatchCount    := 0;
    FSelectCount   := 0;
    FReplaceCount  := 0;
    FInLineCount   := 0;
    FLinesPerSec   := 0;
    BytesRead      := 0;
    LPC            := 0;

    FInTextStream.Position := 0;
    FInLineBuf := nil;
    FOutLineBuf := nil;
    try
      GetMem(FInLineBuf, MaxLineLength+3);
      GetMem(FOutLineBuf, MaxLineLength+3);

      LineNum := 1;
      ATime := Now;
      while not FInTextStream.AtEndOfStream do begin
        Len := FInTextStream.ReadLineArray(FInLineBuf, MaxLineLength);
        Inc(BytesRead, Len);

        FInLineBuf[Len]   := #13;
        FInLineBuf[Len+1] := #10;
        FInLineBuf[Len+2] := EndStr;
{!!.02 - added }
        REPosition.StartPos := 0;
        REPosition.EndPos   := 0;
        REPosition.Length   := 0;
{!!.02 - added end }
        REPosition.LineNum := LineNum;
        Found := ProcessLine(FInLineBuf, Len, LineNum, False, REPosition);

{!!!}
        SetLength(FFoundText, REPosition.Length);
        Src := FInLineBuf;
        Inc(Src, REPosition.StartPos);
        StrMove(PChar(FFoundText), Src, REPosition.Length);
{!!!}

        if (FInFileSize > 0) then begin
          PC := Round(BytesRead / FInFileSize * 100);
          {avoid calling with every line - when OnProgress is assigned}
          {performance is considerably reduced anyway, don't add to it}
          if (PC > LPC) then begin
            LPC := PC;
            if (Assigned(FOnProgress)) then
              FOnProgress(Self, PC);
          end;
        end;
        if (Assigned(FOnMatch)) and (Found) then
          FOnMatch(Self, REPosition);

        Inc(LineNum);
      end;
      ATime := (Now - ATime) * 86400;
      FInLineCount := LineNum-1;
      if (ATime > 0) then
        FLinesPerSec := Trunc(FInLineCount / ATime)
      else
        FLinesPerSec := 0;
      if (Assigned(FOnProgress)) then
        FOnProgress(Self, 100);
      Result := (FMatchCount > 0) or (FSelectCount > 0);
    finally
      FreeMem(FInLineBuf, MaxLineLength+3);
      FreeMem(FOutLineBuf, MaxLineLength+3);
    end;
  finally
    FInTextStream.Free;
    FInTextStream := nil;
    FOutTextStream.Free;
    FOutTextStream := nil;
  end;
end;


procedure TStStreamRegEx.AddTokenToPattern(var PatRec : PStPatRecord;
                                           LastPatRec : PStPatRecord;
                                                Token : TStTokens;
                                                    S : ShortString);
{-add a token record to the pattern list}
{-S contains a literal character or an expanded character class}


begin
  PatRec := FNodes.AllocNode;
  PatRec^.Token := Token;        {save token type}
  PatRec^.NextOK := False;       {default to non-alternation}

  LastPatRec^.NextPattern := PatRec;  {hook up the previous token}
  case Token of
    tknNil, tknAnyChar, tknBegOfLine, tknEndOfLine, tknGroup, tknBegTag, tknEndTag :
      begin
        PatRec^.OneChar := Null;
        PatRec^.StrPtr := nil;
      end;
    tknLitChar :
      begin
        if IgnoreCase then
          PatRec^.OneChar := AnsiUpperCase(S[1])[1]
        else
          PatRec^.OneChar := S[1];
        PatRec^.StrPtr := nil;
      end;
    tknCharClass, tknNegCharClass :
      begin
        PatRec^.OneChar := Null;
        if FIgnoreCase then
          S := CleanUpCase(S);
        New(PatRec^.StrPtr);
        PatRec^.StrPtr^ := S;
      end;
  else
    RaiseStError(EStRegExError, stscUnknownError);
  end;
end;


function TStStreamRegEx.MakePattern(var Pattern : PAnsiChar;
                                        Start   : Integer;
                                        Delim   : AnsiChar;
                                    var TagOn   : Boolean;
                                    var PatList : PStPatRecord) : Integer;
var
  I              : Integer;
  NextLastPatRec,
  LastPatRec,
  TempPatRec,
  PatRec         : PStPatRecord;
  Done           : Boolean;
  AChar          : AnsiChar;
  TmpStr         : ShortString;
  AToken         : TStTokens;
  GroupStartPos,
  GroupEndPos    : integer;

begin
  PatList := FNodes.AllocNode;
  PatList^.Token  := tknNil;    {put a nil token at the beginning}
  PatList^.NextOK := False;
  LastPatRec := PatList;
  NextLastPatRec := nil;

  I := Start;                 {start point of pattern string}
  Done := False;
  while not(Done) and (Pattern[I] <> Delim) and (Pattern[I] <> EndStr) do begin
    AChar := Pattern[I];
    if (AChar = Any) then
      AddTokenToPattern(PatRec, LastPatRec, tknAnyChar, AChar)
    else if (AChar = Bol) then
      AddTokenToPattern(PatRec, LastPatRec, tknBegOfLine, '')
    else if (AChar = Eol) then
      AddTokenToPattern(PatRec, LastPatRec, tknEndOfLine, '')
    else if (AChar = Ccl) then begin
      Done := (GetCharacterClass(Pattern, I, TmpStr, AToken) = False);
      if Done then
        RaiseStError(EStRegExError, stscExpandingClass);
      AddTokenToPattern(PatRec, LastPatRec, AToken, TmpStr);
    end else if (AChar = Alter) then begin
      if (NextLastPatRec = nil) or
         ((NextLastPatRec^.Token <> tknClosure) and
          (NextLastPatRec^.Token <> tknMaybeOne)) then begin
        {flag the current token as non-critical, i.e., "next is OK"}
        LastPatRec^.NextOK := True;
      end else begin
        {alternation immediately after a closure is probably not desired}
        {e.g., [a-z]*|[0-9] would internally produce ([a-z]|[0-9])*}
        Done := True;
        RaiseStError(EStRegExError, stscAlternationFollowsClosure);
      end;
    end else if (AChar = BGroup) then begin
      GroupStartPos := I+1;
      AddTokenToPattern(PatRec, LastPatRec, tknGroup, '');
      {recursive branch off the list}
      I := MakePattern(Pattern, Succ(I), EGroup, TagOn, TempPatRec);
      if (I > 0) then begin
        GroupEndPos := I-1;
        if (Pattern[I+1] <> EndStr) then begin
          if (Pattern[I+1] in [Closure, ClosurePlus]) then begin
            if  ((((GroupEndPos - GroupStartPos) = 1) or
                (((GroupEndPos - GroupStartPos) = 2) and (Pattern[GroupStartPos] = Esc))) and
                (Pattern[GroupEndPos] in [Closure, MaybeOne])) then begin
              Done := True;
              RaiseStError(EStRegExError, stscClosureMaybeEmpty);
            end else
              PatRec^.NestedPattern := TempPatRec;
          end else
            PatRec^.NestedPattern := TempPatRec;
        end else
          PatRec^.NestedPattern := TempPatRec;
      end else begin
        {didn't find egroup}
        Done := True;
        RaiseStError(EStRegExError, stscUnbalancedParens);
      end;
    end else if ((AChar = BTag) and (not(TagOn))) then begin
      AddTokenToPattern(PatRec, LastPatRec, tknBegTag, '');
      TagOn := True;
    end else if ((AChar = ETag) and (TagOn)) then begin
      AddTokenToPattern(PatRec, LastPatRec, tknEndTag,  '');
      TagOn := False;
    end else if (((AChar = Closure) or (AChar = ClosurePlus) or
                  (AChar = MaybeOne)) and (I > Start)) then begin
      if ((LastPatRec^.Token in [tknBegOfLine, tknEndOfLine, tknMaybeOne, tknClosure]) or
          (NextLastPatRec^.Token = tknClosure)) then begin
        {error, can't have closure after any of these}
        Done := True;
        RaiseStError(EStRegExError, stscFollowingClosure);
      end else begin
        if (AChar = ClosurePlus) then begin
          {insert an extra copy of the last token before the closure}
          TempPatRec := FNodes.CloneNode(LastPatRec);
          NextLastPatRec^.NextPattern := TempPatRec;
          TempPatRec^.NextPattern := LastPatRec;
          NextLastPatRec := TempPatRec;
        end;
        {insert the closure between next to last and last token}
        TempPatRec := FNodes.AllocNode;
        NextLastPatRec^.NextPattern := TempPatRec;
        if (AChar = MaybeOne) then
          TempPatRec^.Token := tknMaybeOne
        else
          TempPatRec^.Token := tknClosure;
        TempPatRec^.OneChar := Null;

        TempPatRec^.NextPattern := LastPatRec;
        TempPatRec^.NextOK := False;
        {set j and lastj back into sequence}
        PatRec := LastPatRec;
        LastPatRec := TempPatRec;
      end;
    end else begin
      if (AChar = Esc) then begin
        {skip over escape character}
        I := Succ(I);
        AChar := Pattern[I];
        case AChar of
          lSpace     : AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #32);
          lNewline   :
            begin
              AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #13);
              LastPatRec  := PatRec;
              AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #10);
            end;
          lTab       : AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #9);
          lBackSpace : AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #8);
          lReturn    : AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #13);
          lFeed      : AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #10);
          lWordDelim : AddTokenToPattern(PatRec, LastPatRec, tknCharClass, StWordDelimString);
          lHex       : AddTokenToPattern(PatRec, LastPatRec, tknCharClass, StHexDigitString);
        else
          AddTokenToPattern(PatRec, LastPatRec, tknLitChar,AChar);
        end;
      end else
        AddTokenToPattern(PatRec, LastPatRec, tknLitChar, AChar);
    end;
    NextLastPatRec := LastPatRec;
    LastPatRec  := PatRec;
    if not(Done) then
      I := Succ(I);
  end; {of looking through pattern string}

  if ((Done) or (Pattern[I] <> Delim)) then begin
    Result := 0;
    RaiseStError(EStRegExError, stscPatternError);
  end else
    Result := I;
end;


function TStStreamRegEx.GetPattern(var Pattern : PAnsiChar;
                                   var PatList : PStPatRecord) : Boolean;
{-convert a Pattern PAnsiChar into a pattern list, pointed to by patlist}
{-return true if successful}
var
  TagOn          : Boolean;
begin
  TagOn := False;
  Result := (MakePattern(Pattern, 0, EndStr, TagOn, PatList) > 0);
  if TagOn then begin
    GetPattern := False;
    RaiseStError(EStRegExError, stscUnbalancedTag);
  end;
end;


procedure TStStreamRegEx.AddTokenToReplace(var PatRec : PStPatRecord;
                                           LastPatRec : PStPatRecord;
                                                Token : TStTokens;
                                          const S     : ShortString);  {!!.02}
{-add a token record to the pattern list}
{S contains a literal character or an expanded character class}
begin
  PatRec := FNodes.AllocNode;
  PatRec^.Token := Token;                    {save token type}
  PatRec^.NextOK  := False;                  {default to non-alternation}
  LastPatRec^.NextPattern := PatRec;         {hook up the previous token}
  if (Token = tknLitChar) or (Token = tknDitto) then begin
    PatRec^.OneChar := S[1];
    PatRec^.StrPtr := nil;
  end else
    RaiseStError(EStRegExError, stscUnknownError);
end;


function TStStreamRegEx.MakeReplacePattern(Pattern     : PAnsiChar;
                                           Start       : Integer;
                                           Delim       : AnsiChar;
                                           var PatList : PStPatRecord) : Integer;
{-make a pattern list from arg[i], starting at start, ending at delim}
{return 0 is error, last char position in arg if OK}
var
  I          : Integer;
  PatRec,
  LastPatRec : PStPatRecord;
  Done       : Boolean;
  AChar      : AnsiChar;

begin
  PatList := FNodes.AllocNode;
  PatList^.Token     := tknNil;    {put a nil token at the beginning}
  PatList^.NextOK    := False;
  LastPatRec := PatList;
  I := Start;                    {start point of pattern string}
  Done := False;
  while not(Done) and (Pattern[I] <> Delim) and (Pattern[I] <> EndStr) do begin
    AChar := Pattern[I];
    if (AChar = Ditto) then
      AddTokenToReplace(PatRec, LastPatRec, tknDitto, '0')
    else begin
      if (AChar = Esc) then begin
        {skip over escape character}
        I := Succ(I);
        AChar := Pattern[I];
        if (AChar >= '1') and (AChar <= '9') then
          {a tagged ditto}
          AddTokenToReplace(PatRec, LastPatRec, tknDitto, AChar)
        else case AChar of
          lSpace       : AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #32);
          lNewline     :
            begin
              AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #13);
              LastPatRec := PatRec;
              AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #10);
            end;
          lTab         : AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #9);
          lBackSpace   : AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #8);
          lReturn      : AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #13);
          lFeed        : AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #10);
          lNil         : ;
        else
          AddTokenToReplace(PatRec, LastPatRec, tknLitChar, AChar);
        end;
      end else
        AddTokenToReplace(PatRec, LastPatRec, tknLitChar, AChar);
    end;
    LastPatRec := PatRec;
    if not(Done) then
      Inc(I);
  end; {of looking through pattern string}

  if Done or (Pattern[I] <> Delim) then begin
    Result := 0;
    RaiseStError(EStRegExError, stscPatternError);
  end else
    Result := I;
end;


function TStStreamRegEx.GetReplace(Pattern     : PAnsiChar;
                                   var PatList : PStPatRecord) : Boolean;
begin
  Result := (MakeReplacePattern(Pattern, 0, EndStr, PatList) > 0);
end;


function TStStreamRegEx.MatchOnePatternElement(var Buf    : PAnsiChar;
                                               var I      : Integer;
                                               var TagOn  : Boolean;
                                               var TagNum : Integer;
                                               PatPtr   : PStPatRecord) : Boolean;
{-match one pattern element at pattern pointed to by PatPtr, Buf[I]}
var
  Advance  : -1..255;
  AToken   : TStTokens;
  PatPos   : Integer;
  K        : Cardinal;
  C        : AnsiChar;
begin
  Advance := -1;
  AToken := PatPtr^.Token;
  if FIgnoreCase then
    C := AnsiUpperCase(Buf[I])[1]
  else
    C := Buf[I];

  if (C <> EndStr) then begin
    if (AToken = tknLitChar) then begin
      if (C = PatPtr^.OneChar) then
        Advance := 1;
    end else if (AToken = tknCharClass) then begin
      if (StrChPosS(PatPtr^.StrPtr^, C, K)) then
        Advance := 1;
    end else if (AToken = tknNegCharClass) then begin
      if (not (C in [#13, #10])) then begin
        if not (StrChPosS(PatPtr^.StrPtr^, C, K)) then
          Advance := 1;