/[projects]/dao/DelphiScanner/Components/tpsystools_4.04/source/StRegEx.pas
ViewVC logotype

Annotation of /dao/DelphiScanner/Components/tpsystools_4.04/source/StRegEx.pas

Parent Directory Parent Directory | Revision Log Revision Log

Revision 2671 - (hide annotations) (download)
Tue Aug 25 18:15:15 2015 UTC (8 years, 10 months ago) by torben
File size: 76168 byte(s) 
Added tpsystools component
1 torben 2671 // TODO-UNICODE
2    
3     (* ***** BEGIN LICENSE BLOCK *****
4     * Version: MPL 1.1
5     *
6     * The contents of this file are subject to the Mozilla Public License Version
7     * 1.1 (the "License"); you may not use this file except in compliance with
8     * the License. You may obtain a copy of the License at
9     * http://www.mozilla.org/MPL/
10     *
11     * Software distributed under the License is distributed on an "AS IS" basis,
12     * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13     * for the specific language governing rights and limitations under the
14     * License.
15     *
16     * The Original Code is TurboPower SysTools
17     *
18     * The Initial Developer of the Original Code is
19     * TurboPower Software
20     *
21     * Portions created by the Initial Developer are Copyright (C) 1996-2002
22     * the Initial Developer. All Rights Reserved.
23     *
24     * Contributor(s):
25     *
26     * ***** END LICENSE BLOCK ***** *)
27    
28     {*********************************************************}
29     {* SysTools: StRegEx.pas 4.04 *}
30     {*********************************************************}
31     {* SysTools: SysTools Regular Expression Engine *}
32     {*********************************************************}
33    
34     {$I StDefine.inc}
35    
36     unit StRegEx;
37    
38     interface
39    
40     uses
41     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
42    
43     StConst,
44     StBase,
45     StStrms;
46    
47     const
48     StWordDelimString : string[31] = #9#32'!"&()*+,-./:;<=>?@[\]^`{|}~';
49     StHexDigitString : string[19] = '0123456789ABCDEF';
50    
51     type
52     TMatchPosition = packed record
53     StartPos : Cardinal;
54     EndPos : Cardinal;
55     Length : Cardinal;
56     LineNum : Cardinal;
57     end;
58    
59     TStOutputOption = (ooUnselected, ooModified, ooCountOnly);
60     TStOutputOptions = set of TStOutputOption;
61    
62     TStTokens = (tknNil, tknLitChar, tknCharClass, tknNegCharClass,
63     tknClosure, tknMaybeOne, tknAnyChar, tknBegOfLine,
64     tknEndOfLine, tknGroup, tknBegTag, tknEndTag, tknDitto);
65    
66     PStPatRecord = ^TStPatRecord;
67     TStPatRecord = packed record
68     StrPtr : ^ShortString;
69     NestedPattern : PStPatRecord;
70     NextPattern : PStPatRecord;
71     Token : TStTokens;
72     OneChar : AnsiChar;
73     NextOK : Boolean;
74     end;
75    
76     TStTagLevel = -1..9;
77     TStFlag = array[0..1023] of TStTagLevel;
78    
79     TStOnRegExProgEvent = procedure(Sender : TObject; Percent : Word) of object;
80     TStOnMatchEvent = procedure(Sender : TObject;
81     REPosition : TMatchPosition) of object;
82    
83    
84     TStNodeHeap = class
85     private
86     FFreeList : PStPatRecord;
87    
88     protected
89     procedure nhClearHeap;
90     function nhDeepCloneNode(aNode : PStPatRecord) : PStPatRecord;
91    
92     public
93     constructor Create;
94     destructor Destroy; override;
95    
96     function AllocNode : PStPatRecord;
97     procedure FreeNode(aNode : PStPatRecord);
98    
99     function CloneNode(aNode : PStPatRecord) : PStPatRecord;
100     end;
101    
102    
103     TStStreamRegEx = class(TObject)
104     protected {private}
105     { Private declarations }
106     FAvoid : Boolean;
107     FIgnoreCase : Boolean;
108     FInTextStream : TStAnsiTextStream;
109     FInFileSize : Cardinal;
110     FInputStream : TStream;
111    
112     FInLineBuf : PAnsiChar;
113     FInLineCount : Cardinal;
114     FInLineNum : Cardinal;
115     FInLineTermChar : AnsiChar;
116     FInLineTerminator : TStLineTerminator;
117     FInLineLength : integer;
118     FLineNumbers : Boolean;
119     FLinesPerSec : Cardinal;
120    
121     FMatchCount : Cardinal;
122    
123     FMatchPatSL : TStringList;
124     FMatchPatStr : PAnsiChar;
125     FMatchPatPtr : PStPatRecord;
126    
127     FMaxLineLength : Cardinal;
128    
129     FNodes : TStNodeHeap;
130    
131     FOnMatch : TStOnMatchEvent;
132     FOutLineLength : integer;
133     FOutLineTermChar : AnsiChar;
134     FOutLineTerminator: TStLineTerminator;
135    
136     FReplaceCount : Cardinal;
137     FReplacePatSL : TStringList;
138     FReplacePatStr : PAnsiChar;
139     FReplacePatPtr : PStPatRecord;
140    
141     FOnProgress : TStOnRegExProgEvent;
142     FOutputStream : TStream;
143     FOutTextStream : TStAnsiTextStream;
144     FOutLineBuf : PAnsiChar;
145    
146     FOutputOptions : TStOutputOptions;
147    
148     FSelAvoidPatSL : TStringList;
149     FSelAvoidPatStr : PAnsiChar;
150     FSelAvoidPatPtr : PStPatRecord;
151    
152     FSelectCount : Cardinal;
153    
154     protected
155     { Protected declarations }
156    
157     procedure AddTokenToPattern(var PatRec : PStPatRecord;
158     LastPatRec : PStPatRecord;
159     Token : TStTokens;
160     S : ShortString);
161     procedure AddTokenToReplace(var PatRec : PStPatRecord;
162     LastPatRec : PStPatRecord;
163     Token : TStTokens;
164     const S : ShortString); {!!.02}
165     function AppendS(Dest, S1, S2 : PAnsiChar; Count : Cardinal) : PAnsiChar;
166     function BuildAllPatterns : boolean;
167     function BuildPatternStr(var PStr : PAnsiChar;
168     var Len : Integer;
169     SL : TStringList) : Boolean;
170     function ConvertMaskToRegEx(const S : AnsiString) : AnsiString;
171     procedure DisposeItems(var Data : PStPatRecord);
172    
173     procedure InsertLineNumber(Dest : PAnsiChar;
174     const S : PAnsiChar; LineNum : Integer);
175     function GetPattern(var Pattern : PAnsiChar;
176     var PatList : PStPatRecord) : Boolean;
177     function GetReplace(Pattern : PAnsiChar;
178     var PatList : PStPatRecord) : Boolean;
179     function MakePattern(var Pattern : PAnsiChar;
180     Start : Integer;
181     Delim : AnsiChar;
182     var TagOn : Boolean;
183     var PatList : PStPatRecord) : Integer;
184     function MakeReplacePattern(Pattern : PAnsiChar;
185     Start : Integer;
186     Delim : AnsiChar;
187     var PatList : PStPatRecord) : Integer;
188     function FindMatch(var Buf : PAnsiChar;
189     PatPtr : PStPatRecord;
190     var REPosition : TMatchPosition) : Boolean;
191     function MatchOnePatternElement(var Buf : PAnsiChar;
192     var I : Integer;
193     var TagOn : Boolean;
194     var TagNum : Integer;
195     PatPtr : PStPatRecord) : Boolean;
196     function ProcessLine(Buf : PAnsiChar;
197     Len : integer;
198     LineNum : integer;
199     CheckOnly : Boolean;
200     var REPosition: TMatchPosition) : Boolean;
201     function SearchMatchPattern(var Buf : PAnsiChar;
202     OffSet : Integer;
203     var TagOn : Boolean;
204     var TagNum : Integer;
205     PatPtr : PStPatRecord) : Integer;
206     procedure SetMatchPatSL(Value : TStringList);
207     procedure SetOptions(Value : TStOutputOptions);
208     procedure SetReplacePatSL(Value : TStringList);
209     procedure SetSelAvoidPatSL(Value : TStringList);
210     procedure SubLine(Buf : PAnsiChar);
211     function SubLineFindTag(Buf : PAnsiChar;
212     I : Integer;
213     IEnd : Integer;
214     TagNum : Integer;
215     var Flags : TStFlag;
216     var IStart : Integer;
217     var IStop : Integer) : Boolean;
218     function SubLineMatchOne(Buf : PAnsiChar;
219     var Flags : TStFlag;
220     var TagOn : Boolean;
221     var I : Integer;
222     var TagNum : Integer;
223     PatPtr : PStPatRecord) : Boolean;
224     function SubLineMatchPattern(Buf : PAnsiChar;
225     var Flags : TStFlag;
226     var TagOn : Boolean;
227     var TagNum : Integer;
228     OffSet : Integer;
229     PatPtr : PStPatRecord) : Integer;
230     procedure SubLineWrite(Buf : PAnsiChar;
231     S : PAnsiChar;
232     RepRec : PStPatRecord;
233     I,
234     IEnd : Integer;
235     var Flags : TStFlag);
236    
237     public
238     { Public declarations }
239    
240     property InputStream : TStream
241     read FInputStream
242     write FInputStream;
243    
244     property OutputStream : TStream
245     read FOutputStream
246     write FOutputStream;
247    
248     constructor Create;
249     destructor Destroy; override;
250    
251     function CheckString(const S : AnsiString;
252     var REPosition : TMatchPosition) : Boolean;
253     function FileMasksToRegEx(Masks : AnsiString) : Boolean;
254     function Execute : Boolean;
255     function ReplaceString(var S : AnsiString;
256     var REPosition : TMatchPosition) : Boolean;
257    
258     property Avoid : Boolean
259     read FAvoid
260     write FAvoid;
261    
262     property IgnoreCase : Boolean
263     read FIgnoreCase
264     write FIgnoreCase;
265    
266     property InFixedLineLength : integer
267     read FInLineLength
268     write FInLineLength;
269    
270     property InLineTermChar : AnsiChar
271     read FInLineTermChar
272     write FInLineTermChar;
273    
274     property InLineTerminator : TStLineTerminator
275     read FInLineTerminator
276     write FInLineTerminator;
277    
278     property LineCount : Cardinal
279     read FInLineCount;
280    
281     property LineNumbers : Boolean
282     read FLineNumbers
283     write FLineNumbers;
284    
285     property LinesMatched : Cardinal
286     read FMatchCount;
287    
288     property LinesPerSecond : Cardinal
289     read FLinesPerSec;
290    
291     property LinesReplaced : Cardinal
292     read FReplaceCount;
293    
294     property LinesSelected : Cardinal
295     read FSelectCount;
296    
297     property MatchPattern : TStringList
298     read FMatchPatSL
299     write SetMatchPatSL;
300    
301     property MaxLineLength : Cardinal
302     read FMaxLineLength
303     write FMaxLineLength;
304    
305     property OnMatch : TStOnMatchEvent
306     read FOnMatch
307     write FOnMatch;
308    
309     property OnProgress : TStOnRegExProgEvent
310     read FOnProgress
311     write FOnProgress;
312    
313     property OutFixedLineLength : integer
314     read FOutLineLength
315     write FOutLineLength;
316    
317     property OutLineTermChar : AnsiChar
318     read FOutLineTermChar
319     write FOutLineTermChar;
320    
321     property OutLineTerminator : TStLineTerminator
322     read FOutLineTerminator
323     write FOutLineTerminator;
324    
325     property OutputOptions : TStOutputOptions
326     read FOutputOptions
327     write SetOptions;
328    
329     property ReplacePattern : TStringList
330     read FReplacePatSL
331     write SetReplacePatSL;
332    
333     property SelAvoidPattern : TStringList
334     read FSelAvoidPatSL
335     write SetSelAvoidPatSL;
336     end;
337    
338    
339     TStRegEx = class(TStComponent)
340     protected {private}
341     FAvoid : Boolean;
342     FIgnoreCase : Boolean;
343     FInFileSize : Cardinal;
344     FInFileStream : TFileStream;
345     FInLineCount : Cardinal;
346    
347     FInLineTermChar : AnsiChar;
348     FInLineTerminator : TStLineTerminator;
349     FInFixedLineLength: integer;
350     FInputFile : AnsiString;
351    
352     FLineNumbers : Boolean;
353     FLinesPerSec : Cardinal;
354    
355     FMatchCount : Cardinal;
356    
357     FMatchPatSL : TStringList;
358     FMatchPatStr : PAnsiChar;
359     FMatchPatPtr : PStPatRecord;
360    
361     FMaxLineLength : Cardinal;
362    
363     FNodes : TStNodeHeap;
364    
365     FOnProgress : TStOnRegExProgEvent;
366     FOnMatch : TStOnMatchEvent;
367    
368     FOutFileStream : TFileStream;
369     FOutTextStream : TStAnsiTextStream;
370     FOutLineBuf : PAnsiChar;
371    
372     FOutFixedLineLength : integer;
373     FOutLineTermChar : AnsiChar;
374     FOutLineTerminator: TStLineTerminator;
375    
376     FOutputFile : AnsiString;
377     FOutputOptions : TStOutputOptions;
378    
379     FReplaceCount : Cardinal;
380     FReplacePatSL : TStringList;
381     FReplacePatStr : PAnsiChar;
382     FReplacePatPtr : PStPatRecord;
383    
384     FSelAvoidPatSL : TStringList;
385     FSelAvoidPatStr : PAnsiChar;
386     FSelAvoidPatPtr : PStPatRecord;
387    
388     FSelectCount : Cardinal;
389    
390     FStream : TStStreamRegEx;
391    
392     protected
393     procedure SetMatchPatSL(Value : TStringList);
394     procedure SetOptions(Value : TStOutputOptions);
395     procedure SetReplacePatSL(Value : TStringList);
396     procedure SetSelAvoidPatSL(Value : TStringList);
397     procedure SetStreamProperties;
398     public
399     constructor Create(AOwner : TComponent); override;
400     destructor Destroy; override;
401    
402     function CheckString(const S : AnsiString;
403     var REPosition : TMatchPosition) : Boolean;
404     function FileMasksToRegEx(const Masks : AnsiString) : Boolean; {!!.02}
405     function Execute : Boolean;
406     function ReplaceString(var S : AnsiString;
407     var REPosition : TMatchPosition) : Boolean;
408    
409     property LineCount : Cardinal
410     read FInLineCount;
411    
412     property LinesMatched : Cardinal
413     read FMatchCount;
414    
415     property LinesPerSecond : Cardinal
416     read FLinesPerSec;
417    
418     property LinesReplaced : Cardinal
419     read FReplaceCount;
420    
421     property LinesSelected : Cardinal
422     read FSelectCount;
423    
424     property MaxLineLength : Cardinal
425     read FMaxLineLength
426     write FMaxLineLength;
427    
428     published
429     property Avoid : Boolean
430     read FAvoid
431     write FAvoid default False;
432    
433     property IgnoreCase : Boolean
434     read FIgnoreCase
435     write FIgnoreCase default False;
436    
437     property InFixedLineLength : Integer
438     read FInFixedLineLength
439     write FInFixedLineLength default 80;
440    
441     property InLineTermChar : AnsiChar
442     read FInLineTermChar
443     write FInLineTermChar default #10;
444    
445     property InLineTerminator : TStLineTerminator
446     read FInLineTerminator
447     write FInLineTerminator default ltCRLF;
448    
449     property InputFile : AnsiString
450     read FInputFile
451     write FInputFile;
452    
453     property LineNumbers : Boolean
454     read FLineNumbers
455     write FLineNumbers default False;
456    
457     property MatchPattern : TStringList
458     read FMatchPatSL
459     write SetMatchPatSL;
460    
461     property OnMatch : TStOnMatchEvent
462     read FOnMatch
463     write FOnMatch;
464    
465     property OnProgress : TStOnRegExProgEvent
466     read FOnProgress
467     write FOnProgress;
468    
469     property OutFixedLineLength : Integer
470     read FOutFixedLineLength
471     write FOutFixedLineLength default 80;
472    
473     property OutLineTermChar : AnsiChar
474     read FOutLineTermChar
475     write FOutLineTermChar default #10;
476    
477     property OutLineTerminator : TStLineTerminator
478     read FOutLineTerminator
479     write FOutLineTerminator default ltCRLF;
480    
481     property OutputFile : AnsiString
482     read FOutputFile
483     write FOutputFile;
484    
485     property OutputOptions : TStOutputOptions
486     read FOutputOptions
487     write SetOptions;
488    
489     property ReplacePattern : TStringList
490     read FReplacePatSL
491     write SetReplacePatSL;
492    
493     property SelAvoidPattern : TStringList
494     read FSelAvoidPatSL
495     write SetSelAvoidPatSL;
496     end;
497    
498    
499     implementation
500    
501     uses
502     StStrL,
503     StStrS;
504    
505    
506     const
507     Null = #0;
508     EndStr = #0;
509     NewLine = #13#10;
510     Dash = '-';
511     Esc = '\';
512     Any = '.'; {was '?'}
513     Closure = '*';
514     ClosurePlus = '+';
515     MaybeOne = '?'; {was '!'}
516     Bol = '^';
517     Eol = '$';
518     Ccl = '[';
519     Negate = '^';
520     CclEnd = ']';
521     BTag = '{';
522     ETag = '}';
523     BGroup = '(';
524     EGroup = ')';
525     Alter = '|'; {was #}
526     Ditto = '&';
527     lSpace = 's';
528     lNewline = 'n';
529     lTab = 't';
530     lBackSpace = 'b';
531     lReturn = 'r';
532     lFeed = 'l';
533     lHex = 'h';
534     lWordDelim = 'w';
535     lNil = 'z';
536    
537    
538     function CleanUpCase(S : String) : String;
539     {-convert string to uppercase and remove duplicates}
540     var
541     I : Integer;
542     K : Cardinal;
543     C : Char;
544     begin
545     Result := '';
546     S := AnsiUpperCase(S);
547     for I := 1 to Length(S) do begin
548     C := S[I];
549     if not StrChPosL(Result, C, K) then
550     Result := Result + C;
551     end;
552     end;
553    
554    
555     procedure AppendChar(C : AnsiChar; var S : ShortString);
556     {-append a character C onto string S}
557     begin
558     S := S + C;
559     end;
560    
561    
562     function IsAlphaNum(C : AnsiChar) : Boolean;
563     begin
564     Result := IsCharAlphaNumericA(C); //Ansi!
565     end;
566    
567    
568     procedure ExpandDash(Delim : AnsiChar;
569     var Pattern : PAnsiChar ;
570     var I : Integer;
571     var S : ShortString);
572     {-expand the innards of the character class, including dashes}
573     {stop when endc is found}
574     {return a string S with the expansion}
575     var
576     C,
577     CLeft,
578     CNext : AnsiChar;
579     K : Integer;
580    
581     begin
582     while (Pattern[I] <> Delim) and (Pattern[I] <> EndStr) do begin
583     C := Pattern[I];
584     if (C = Esc) then begin
585     if (Pattern[Succ(I)] <> EndStr) then begin
586     I := Succ(I);
587     C := Pattern[I];
588     case C of
589     lSpace : AppendChar(#32, S);
590     lTab : AppendChar(#9, S);
591     lBackSpace : AppendChar(#8, S);
592     lReturn : AppendChar(#13, S);
593     lFeed : AppendChar(#10, S);
594     else
595     AppendChar(C, S);
596     end;
597     end else
598     {escape must be the character}
599     AppendChar(Esc, S);
600     end else if (C <> Dash) then
601     {literal character}
602     AppendChar(C, S)
603     else if ((Length(S) = 0) or (Pattern[Succ(I)] = Delim)) then
604     {literal dash at begin or end of class}
605     AppendChar(Dash, S)
606     else begin
607     {dash in middle of class}
608     CLeft := Pattern[Pred(I)];
609     CNext := Pattern[Succ(I)];
610     if IsAlphaNum(CLeft) and IsAlphaNum(CNext) and (CLeft <= CNext) then begin
611     {legal dash to be expanded}
612     for K := (Ord(CLeft)+1) to Ord(CNext) do
613     AppendChar(AnsiChar(K), S);
614     {move over the end of dash character}
615     I := Succ(I);
616     end else
617     {dash must be a literal}
618     AppendChar(Dash, S);
619     end;
620     I := Succ(I);
621     end;
622     end;
623    
624    
625     function GetCharacterClass(var Pattern : PAnsiChar;
626     var I : Integer;
627     var S : ShortString;
628     var AToken : TStTokens) : Boolean;
629     {-expand a character class starting at position I of Pattern into a string S}
630     {return a token type (tknCharClass or tknNegCharClass)}
631     {return I pointing at the end of class character}
632     {return true if successful}
633    
634     begin
635     {skip over start of class character}
636     I := Succ(I);
637     if (Pattern[I] = Negate) then begin
638     AToken := tknNegCharClass;
639     I := Succ(I);
640     end else
641     AToken := tknCharClass;
642     {expand the character class}
643     S := '';
644     ExpandDash(CclEnd, Pattern, I, S);
645     Result := (Pattern[I] = CclEnd);
646     end;
647    
648    
649    
650    
651    
652     {******************************************************************************}
653     { TStNodeHeap Implementation }
654     {******************************************************************************}
655    
656     constructor TStNodeHeap.Create;
657     begin
658     inherited Create;
659    
660     New(FFreeList);
661     FillChar(FFreeList^, sizeof(TStPatRecord), 0);
662     end;
663    
664    
665     destructor TStNodeHeap.Destroy;
666     begin
667     nhClearHeap;
668     Dispose(FFreeList);
669    
670     inherited Destroy;
671     end;
672    
673    
674     function TStNodeHeap.AllocNode : PStPatRecord;
675     begin
676     if (FFreeList^.NextPattern = nil) then
677     New(Result)
678     else begin
679     Result := FFreeList^.NextPattern;
680     FFreeList^.NextPattern := Result^.NextPattern;
681     end;
682     FillChar(Result^, sizeof(TStPatRecord), 0);
683     end;
684    
685    
686     function TStNodeHeap.CloneNode(aNode : PStPatRecord) : PStPatRecord;
687     begin
688     {allocate a new node}
689     Result := AllocNode;
690    
691     {copy fields}
692     Result^.Token := aNode^.Token;
693     Result^.OneChar := aNode^.OneChar;
694     Result^.NextOK := aNode^.NextOK;
695     if (aNode^.StrPtr <> nil) then begin
696     New(Result^.StrPtr);
697     Result^.StrPtr^ := aNode^.StrPtr^;
698     end else
699     Result^.StrPtr := nil;
700    
701     {deep clone the nested node}
702     if (aNode^.NestedPattern <> nil) then
703     Result^.NestedPattern := nhDeepCloneNode(aNode^.NestedPattern);
704     end;
705    
706    
707     procedure TStNodeHeap.FreeNode(aNode : PStPatRecord);
708     begin
709     if (aNode <> nil) then begin
710     aNode^.NextPattern := FFreeList^.NextPattern;
711     FFreeList^.NextPattern := aNode;
712     end;
713     end;
714    
715    
716     procedure TStNodeHeap.nhClearHeap;
717     var
718     Walker,
719     Temp : PStPatRecord;
720     begin
721     Walker := FFreeList^.NextPattern;
722     FFreeList^.NextPattern := nil;
723     while (Walker <> nil) do begin
724     Temp := Walker;
725     Walker := Walker^.NextPattern;
726     Dispose(Temp);
727     end;
728     end;
729    
730    
731     function TStNodeHeap.nhDeepCloneNode(aNode : PStPatRecord) : PStPatRecord;
732     begin
733     {allocate a new node}
734     Result := AllocNode;
735    
736     {copy fields}
737     Result^.Token := aNode^.Token;
738     Result^.OneChar := aNode^.OneChar;
739     Result^.NextOK := aNode^.NextOK;
740     if (aNode^.StrPtr <> nil) then begin
741     New(Result^.StrPtr);
742     Result^.StrPtr^ := aNode^.StrPtr^;
743     end else
744     Result^.StrPtr := nil;
745    
746     {recursively deepclone the next and nested nodes}
747     if (aNode^.NextPattern <> nil) then
748     Result^.NextPattern := nhDeepCloneNode(aNode^.NextPattern);
749     if (aNode^.NestedPattern <> nil) then
750     Result^.NestedPattern := nhDeepCloneNode(aNode^.NestedPattern);
751     end;
752    
753    
754     {******************************************************************************}
755     { TStStreamRegEx Implementation }
756     {******************************************************************************}
757    
758    
759     constructor TStStreamRegEx.Create;
760     begin
761     inherited Create;
762    
763     FAvoid := False;
764     FIgnoreCase := False;
765     FLineNumbers := False;
766     FOutputOptions := [];
767    
768     FInLineTerminator := ltCRLF;
769     FInLineTermChar := #10;
770     FInLineLength := 80;
771    
772     FOutLineTerminator := ltCRLF;
773     FOutLineTermChar := #10;
774     FOutLineLength := 80;
775    
776     FMaxLineLength := 1024;
777    
778     FMatchPatSL := TStringList.Create;
779     FMatchPatPtr := nil;
780     FSelAvoidPatSL := TStringList.Create;
781     FSelAvoidPatPtr:= nil;
782     FReplacePatSL := TStringList.Create;
783     FReplacePatPtr := nil;
784    
785     FInputStream := nil;
786     FInTextStream := nil;
787     FOutputStream := nil;
788     FOutTextStream := nil;
789    
790     FNodes := TStNodeHeap.Create;
791     end;
792    
793    
794     procedure TStStreamRegEx.DisposeItems(var Data : PStPatRecord);
795     var
796     Walker, Temp : PStPatRecord;
797     begin
798     if (Data <> nil) then begin
799     Walker := Data;
800     while (Walker <> nil) do begin
801     Temp := Walker;
802    
803     if (Assigned(Walker^.StrPtr)) then
804     Dispose(Walker^.StrPtr);
805    
806     if (Assigned(Walker^.NestedPattern)) then
807     DisposeItems(Walker^.NestedPattern);
808    
809     Walker := Walker^.NextPattern;
810     FNodes.FreeNode(Temp);
811     end;
812     Data := nil;
813     end;
814     end;
815    
816    
817     destructor TStStreamRegEx.Destroy;
818     begin
819     DisposeItems(FMatchPatPtr);
820     DisposeItems(FSelAvoidPatPtr);
821     DisposeItems(FReplacePatPtr);
822    
823     FNodes.Free;
824     FNodes := nil;
825    
826     if (Assigned(FMatchPatStr)) then begin
827     FreeMem(FMatchPatStr, StrLen(FMatchPatStr) + 1);
828     FMatchPatStr := nil;
829     end;
830    
831     if (Assigned(FReplacePatStr)) then
832     FreeMem(FReplacePatStr, StrLen(FReplacePatStr) + 1);
833     FReplacePatStr := nil;
834    
835     if (Assigned(FSelAvoidPatStr)) then
836     FreeMem(FSelAvoidPatStr, StrLen(FSelAvoidPatStr) + 1);
837     FSelAvoidPatStr := nil;
838    
839     FMatchPatSL.Free;
840     FMatchPatSL := nil;
841    
842     FReplacePatSL.Free;
843     FReplacePatSL := nil;
844    
845     FSelAvoidPatSL.Free;
846     FSelAvoidPatSL := nil;
847    
848     inherited Destroy;
849     end;
850    
851    
852     function TStStreamRegEx.AppendS(Dest, S1, S2 : PAnsiChar;
853     Count : Cardinal) : PAnsiChar;
854     var
855     Remaining : Cardinal;
856     I : Cardinal;
857     begin
858     Result := Dest;
859     I := StrLen(S1);
860     Remaining := MaxLineLength - I;
861     if (Remaining < StrLen(S2)) then
862     Count := Remaining;
863     Move(S1[0], Dest[0], I);
864     Move(S2[0], Dest[I], Count);
865     I := I + Count;
866     Dest[I] := #0;
867     end;
868    
869    
870     function TStStreamRegEx.BuildAllPatterns : Boolean;
871     var
872     Len : Integer;
873     begin
874     if (FMatchPatSL.Count > 0) then begin
875     DisposeItems(FMatchPatPtr);
876    
877     if (BuildPatternStr(FMatchPatStr, Len, FMatchPatSL)) then begin
878     if (Len > 0) then
879     GetPattern(FMatchPatStr, FMatchPatPtr)
880     else
881     DisposeItems(FMatchPatPtr);
882     Result := True;
883     end else begin
884     DisposeItems(FMatchPatPtr);
885     Result := False;
886     end;
887     end else begin
888     DisposeItems(FMatchPatPtr);
889     Result := True;
890     end;
891    
892     if Result then begin
893     if (FSelAvoidPatSL.Count > 0) then begin
894     DisposeItems(FSelAvoidPatPtr);
895     if (BuildPatternStr(FSelAvoidPatStr, Len, FSelAvoidPatSL)) then begin
896     if (Len > 0) then
897     GetPattern(FSelAvoidPatStr, FSelAvoidPatPtr)
898     else
899     DisposeItems(FSelAvoidPatPtr);
900     Result := True;
901     end else begin
902     DisposeItems(FSelAvoidPatPtr);
903     Result := False;
904     end;
905     end else begin
906     DisposeItems(FSelAvoidPatPtr);
907     Result := True;
908     end;
909     end;
910    
911     if Result then begin
912     if (FReplacePatSL.Count > 0) then begin
913     DisposeItems(FReplacePatPtr);
914     if (BuildPatternStr(FReplacePatStr, Len, FReplacePatSL)) then begin
915     if (Len > 0) then
916     GetReplace(FReplacePatStr, FReplacePatPtr)
917     else
918     DisposeItems(FReplacePatPtr);
919     Result := True;
920     end else begin
921     DisposeItems(FReplacePatPtr);
922     Result := False;
923     end;
924     end else begin
925     DisposeItems(FReplacePatPtr);
926     Result := True;
927     end;
928     end;
929     end;
930    
931    
932    
933     function TStStreamRegEx.BuildPatternStr(var PStr : PAnsiChar;
934     var Len : Integer;
935     SL : TStringList) : Boolean;
936     var
937     I,
938     J : integer;
939     CurLen : Integer; {!!.01}
940     begin
941     Len := 0;
942     for I := 0 to pred(SL.Count) do
943     Len := Len + Length(TrimL(SL[I]));
944     if (Len = 0) then
945     Result := True
946     else begin
947     if Assigned(PStr) then
948     FreeMem(PStr, StrLen(PStr)+1);
949     GetMem(PStr, Len+1);
950     PStr[Len] := EndStr;
951     J := 0;
952     for I := 0 to pred(SL.Count) do begin
953     CurLen := Length(TrimL(SL[I])); {!!.01}
954     if CurLen > 0 then begin {!!.01}
955     Move(SL[I][1], PStr[J], CurLen); {!!.01}
956     Inc(J, CurLen); {!!.01}
957     end; {!!.01}
958     end;
959     Result := True;
960     end;
961     end;
962    
963    
964     function TStStreamRegEx.CheckString(const S : AnsiString;
965     var REPosition : TMatchPosition) : Boolean;
966     var
967     Tmp : PAnsiChar;
968     I : integer;
969     Len : integer;
970     OK : Boolean;
971     begin
972     I := Length(S);
973     GetMem(Tmp, I+3);
974     try
975     if I > 0 then {!!.01}
976     Move(S[1], Tmp[0], I);
977    
978     Tmp[I] := #13;
979     Tmp[I+1] := #10;
980     Tmp[I+2] := EndStr;
981    
982     if (FMatchPatSL.Count > 0) then begin
983     OK := BuildPatternStr(FMatchPatStr, Len, FMatchPatSL);
984     if (OK) then begin
985     if (Len > 0) then
986     GetPattern(FMatchPatStr, FMatchPatPtr)
987     else
988     DisposeItems(FMatchPatPtr);
989     end else
990     DisposeItems(FMatchPatPtr);
991     end else
992     DisposeItems(FMatchPatPtr);
993    
994     if (FSelAvoidPatSL.Count > 0) then begin
995     OK := BuildPatternStr(FSelAvoidPatStr, Len, FSelAvoidPatSL);
996     if (OK) then begin
997     if (Len > 0) then
998     GetPattern(FSelAvoidPatStr, FSelAvoidPatPtr)
999     else
1000     DisposeItems(FSelAvoidPatPtr);
1001     end;
1002     end else
1003     DisposeItems(FSelAvoidPatPtr);
1004    
1005     FMatchCount := 0;
1006     FSelectCount := 0;
1007     FReplaceCount := 0;
1008     FInLineCount := 0;
1009     FLinesPerSec := 0;
1010    
1011     REPosition.LineNum := 1;
1012     if ((FSelAvoidPatPtr <> nil) or (FMatchPatPtr <> nil)) then
1013     Result := ProcessLine(Tmp, I, 1, True, REPosition)
1014     else begin
1015     Result := False;
1016     RaiseStError(EStRegExError, stscNoPatterns);
1017     end;
1018     finally
1019     FreeMem(Tmp, I+3);
1020     end;
1021     end;
1022    
1023    
1024     function TStStreamRegEx.ReplaceString(var S : AnsiString;
1025     var REPosition : TMatchPosition) : Boolean;
1026     var
1027     Tmp : PAnsiChar;
1028     I : integer;
1029     Len : integer;
1030     OK : Boolean;
1031    
1032     function ProcessString(var S : AnsiString;
1033     Len : integer;
1034     LineNum : integer;
1035     var REPosition : TMatchPosition) : Boolean;
1036     var
1037     TmpBuf : PAnsiChar;
1038     ABuf : PAnsiChar;
1039     L : Integer;
1040     begin
1041     L := Length(S)+1;
1042     GetMem(TmpBuf, MaxLineLength+1);
1043     GetMem(ABuf, L);
1044     try
1045     StrPCopy(ABuf, S);
1046     if (FSelAvoidPatPtr <> nil) then begin
1047     Result := False;
1048     if (not Avoid) then
1049     Result := FindMatch(ABuf, FSelAvoidPatPtr, REPosition)
1050     else
1051     Result := not(FindMatch(ABuf, FSelAvoidPatPtr, REPosition));
1052     end else
1053     Result := True;
1054    
1055     if Result then begin
1056     {met select criterion, perhaps by default}
1057     FSelectCount := Succ(FSelectCount);
1058     if (FReplacePatPtr <> nil) then begin
1059     Result := FindMatch(ABuf, FMatchPatPtr, REPosition);
1060     if Result then begin
1061     TmpBuf[0] := #0;
1062     SubLine(ABuf);
1063     S := StrPas(FOutLineBuf);
1064     end;
1065     end;
1066     end;
1067     finally
1068     FreeMem(TmpBuf, MaxLineLength+1);
1069     FreeMem(ABuf, L);
1070     end;
1071     end;
1072    
1073    
1074     begin
1075     I := Length(S);
1076     GetMem(Tmp, I+3);
1077     try
1078     if I > 0 then {!!.01}
1079     Move(S[1], Tmp[0], I);
1080     Tmp[I] := #13;
1081     Tmp[I+1] := #10;
1082     Tmp[I+2] := EndStr;
1083    
1084     if (FMatchPatSL.Count > 0) then begin
1085     OK := BuildPatternStr(FMatchPatStr, Len, FMatchPatSL);
1086     if (OK) then begin
1087     if (Len > 0) then
1088     GetPattern(FMatchPatStr, FMatchPatPtr)
1089     else
1090     DisposeItems(FMatchPatPtr);
1091     end else
1092     DisposeItems(FMatchPatPtr);
1093     end else
1094     DisposeItems(FMatchPatPtr);
1095    
1096     if (FSelAvoidPatSL.Count > 0) then begin
1097     OK := BuildPatternStr(FSelAvoidPatStr, Len, FSelAvoidPatSL);
1098     if (OK) then begin
1099     if (Len > 0) then
1100     GetPattern(FSelAvoidPatStr, FSelAvoidPatPtr)
1101     else
1102     DisposeItems(FSelAvoidPatPtr);
1103     end;
1104     end else
1105     DisposeItems(FSelAvoidPatPtr);
1106    
1107     if (FReplacePatSL.Count > 0) then begin
1108     OK := BuildPatternStr(FReplacePatStr, Len, FReplacePatSL);
1109     if (OK) then begin
1110     if (Len > 0) then
1111     GetPattern(FReplacePatStr, FReplacePatPtr)
1112     else
1113     DisposeItems(FReplacePatPtr);
1114     end else
1115     DisposeItems(FReplacePatPtr);
1116     end else
1117     DisposeItems(FReplacePatPtr);
1118    
1119     FMatchCount := 0;
1120     FSelectCount := 0;
1121     FReplaceCount := 0;
1122     FInLineCount := 0;
1123     FLinesPerSec := 0;
1124    
1125     GetMem(FInLineBuf, MaxLineLength+3);
1126     GetMem(FOutLineBuf, MaxLineLength+3);
1127     try
1128     REPosition.LineNum := 1;
1129     if ((FSelAvoidPatPtr <> nil) or (FMatchPatPtr <> nil)) and
1130     (Assigned(FReplacePatPtr))then begin
1131     Result := ProcessString(S, I, 1, REPosition);
1132     end else begin
1133     Result := False;
1134     RaiseStError(EStRegExError, stscNoPatterns);
1135     end;
1136     finally
1137     FreeMem(FInLineBuf, MaxLineLength+3);
1138     FreeMem(FOutLineBuf, MaxLineLength+3);
1139     end;
1140     finally
1141     FreeMem(Tmp, I+3);
1142     end;
1143     end;
1144    
1145    
1146     function TStStreamRegEx.ConvertMaskToRegEx(const S : AnsiString) : AnsiString;
1147     var
1148     I : integer;
1149     TS : AnsiString;
1150     begin
1151     I := 1;
1152     while (I <= Length(S)) do begin
1153     if (I = 1) then begin
1154     if not (S[1] in ['*', '?']) then begin
1155     TS := '((^[' ;
1156     TS := TS + S[1] + '])';
1157     Inc(I);
1158     end else
1159     TS := '(';
1160     end;
1161    
1162     if not (S[I] in ['*', '?', '.', '\']) then
1163     TS := TS + S[I]
1164     else begin
1165     if (S[I] = '*') then
1166     TS := TS + '.*'
1167     else if (S[I] = '?') then begin
1168     if (I = 1) then
1169     TS := TS + '(^.)'
1170     else
1171     TS := TS + '.?';
1172     end else begin
1173     TS := TS + '\' + S[I];
1174     end;
1175     end;
1176     Inc(I);
1177     end;
1178     Result := TS + '\n)';
1179     end;
1180    
1181    
1182     function TStStreamRegEx.FileMasksToRegEx(Masks : AnsiString) : Boolean;
1183     var
1184     SL : TStringList;
1185     S : AnsiString;
1186     K : Cardinal;
1187     Len: Integer;
1188     begin
1189     SL := TStringList.Create;
1190     try
1191     if StrChPosL(Masks, ';', K) then begin
1192     while (K > 0) do begin
1193     S := Copy(Masks, 1, K-1);
1194     if (Length(S) > 0) then begin
1195     if (SL.Count = 0) then
1196     SL.Add(ConvertMaskToRegEx(S))
1197     else
1198     SL.Add('|' + ConvertMaskToRegEx(S));
1199     end;
1200     Delete(Masks, 1, K);
1201     if not (StrChPosL(Masks, ';', K)) then
1202     break;
1203     end;
1204     if (Length(Masks) > 0) then
1205     SL.Add('|' + ConvertMaskToRegEx(Masks));
1206     end else begin
1207     if (Length(Masks) > 0) then
1208     SL.Add(ConvertMaskToRegEx(Masks));
1209     end;
1210    
1211     if (SL.Count > 0) then begin
1212     FMatchPatSL.Clear;
1213     FMatchPatSL.Assign(SL);
1214     DisposeItems(FMatchPatPtr);
1215     FMatchPatPtr := nil;
1216     if (BuildPatternStr(FMatchPatStr, Len, FMatchPatSL)) then begin
1217     if (Len > 0) then
1218     GetPattern(FMatchPatStr, FMatchPatPtr)
1219     else begin
1220     DisposeItems(FMatchPatPtr);
1221     FMatchPatPtr := nil;
1222     end;
1223     Result := True;
1224     end else begin
1225     DisposeItems(FMatchPatPtr);
1226     FMatchPatPtr := nil;
1227     Result := False;
1228     end;
1229     Result := True;
1230     end else
1231     Result := False;
1232     finally
1233     SL.Free;
1234     end;
1235     end;
1236    
1237    
1238    
1239     function TStStreamRegEx.Execute : Boolean;
1240     var
1241     Len : TStMemSize;
1242     LineNum : Integer;
1243     ATime : TDateTime;
1244     PC : Cardinal;
1245     LPC : Cardinal;
1246     BytesRead : Cardinal;
1247     REPosition: TMatchPosition;
1248     Found : Boolean;
1249    
1250     Src : PAnsiChar; {!!!}
1251     FFoundText : AnsiString; {!!!}
1252     begin
1253     if (FMatchPatSL.Count = 0) and
1254     (FReplacePatSL.Count = 0) and (FSelAvoidPatSL.Count = 0) then
1255     RaiseStError(EStRegExError, stscNoPatterns);
1256    
1257     if (not (BuildAllPatterns)) then
1258     RaiseStError(EStRegExError, stscPatternError);
1259    
1260     if (FMatchPatPtr = nil) and (FSelAvoidPatPtr = nil) and (FReplacePatPtr = nil) then
1261     RaiseStError(EStRegExError, stscNoPatterns);
1262    
1263     if (not (Assigned(FInputStream))) or
1264     ((not (Assigned(FOutputStream)) and (not (ooCountOnly in OutputOptions)))) then
1265     RaiseStError(EStRegExError, stscStreamsNil);
1266    
1267     FInTextStream := nil;
1268     FOutTextStream := nil;
1269     try
1270     FInTextStream := TStAnsiTextStream.Create(FInputStream);
1271     FInTextStream.LineTermChar := FInLineTermChar;
1272     FInTextStream.LineTerminator := FInLineTerminator;
1273     FInTextStream.FixedLineLength := FInLineLength;
1274     FInFileSize := FInTextStream.Size;
1275    
1276     if not (ooCountOnly in OutputOptions) then begin
1277     FOutTextStream := TStAnsiTextStream.Create(FOutputStream);
1278     FOutTextStream.LineTermChar := FOutLineTermChar;
1279     FOutTextStream.LineTerminator := FOutLineTerminator;
1280     FOutTextStream.FixedLineLength := FInLineLength;
1281     end;
1282    
1283     FMatchCount := 0;
1284     FSelectCount := 0;
1285     FReplaceCount := 0;
1286     FInLineCount := 0;
1287     FLinesPerSec := 0;
1288     BytesRead := 0;
1289     LPC := 0;
1290    
1291     FInTextStream.Position := 0;
1292     FInLineBuf := nil;
1293     FOutLineBuf := nil;
1294     try
1295     GetMem(FInLineBuf, MaxLineLength+3);
1296     GetMem(FOutLineBuf, MaxLineLength+3);
1297    
1298     LineNum := 1;
1299     ATime := Now;
1300     while not FInTextStream.AtEndOfStream do begin
1301     Len := FInTextStream.ReadLineArray(FInLineBuf, MaxLineLength);
1302     Inc(BytesRead, Len);
1303    
1304     FInLineBuf[Len] := #13;
1305     FInLineBuf[Len+1] := #10;
1306     FInLineBuf[Len+2] := EndStr;
1307     {!!.02 - added }
1308     REPosition.StartPos := 0;
1309     REPosition.EndPos := 0;
1310     REPosition.Length := 0;
1311     {!!.02 - added end }
1312     REPosition.LineNum := LineNum;
1313     Found := ProcessLine(FInLineBuf, Len, LineNum, False, REPosition);
1314    
1315     {!!!}
1316     SetLength(FFoundText, REPosition.Length);
1317     Src := FInLineBuf;
1318     Inc(Src, REPosition.StartPos);
1319     StrMove(PAnsiChar(FFoundText), Src, REPosition.Length);
1320     {!!!}
1321    
1322     if (FInFileSize > 0) then begin
1323     PC := Round(BytesRead / FInFileSize * 100);
1324     {avoid calling with every line - when OnProgress is assigned}
1325     {performance is considerably reduced anyway, don't add to it}
1326     if (PC > LPC) then begin
1327     LPC := PC;
1328     if (Assigned(FOnProgress)) then
1329     FOnProgress(Self, PC);
1330     end;
1331     end;
1332     if (Assigned(FOnMatch)) and (Found) then
1333     FOnMatch(Self, REPosition);
1334    
1335     Inc(LineNum);
1336     end;
1337     ATime := (Now - ATime) * 86400;
1338     FInLineCount := LineNum-1;
1339     if (ATime > 0) then
1340     FLinesPerSec := Trunc(FInLineCount / ATime)
1341     else
1342     FLinesPerSec := 0;
1343     if (Assigned(FOnProgress)) then
1344     FOnProgress(Self, 100);
1345     Result := (FMatchCount > 0) or (FSelectCount > 0);
1346     finally
1347     FreeMem(FInLineBuf, MaxLineLength+3);
1348     FreeMem(FOutLineBuf, MaxLineLength+3);
1349     end;
1350     finally
1351     FInTextStream.Free;
1352     FInTextStream := nil;
1353     FOutTextStream.Free;
1354     FOutTextStream := nil;
1355     end;
1356     end;
1357    
1358    
1359     procedure TStStreamRegEx.AddTokenToPattern(var PatRec : PStPatRecord;
1360     LastPatRec : PStPatRecord;
1361     Token : TStTokens;
1362     S : ShortString);
1363     {-add a token record to the pattern list}
1364     {-S contains a literal character or an expanded character class}
1365    
1366    
1367     begin
1368     PatRec := FNodes.AllocNode;
1369     PatRec^.Token := Token; {save token type}
1370     PatRec^.NextOK := False; {default to non-alternation}
1371    
1372     LastPatRec^.NextPattern := PatRec; {hook up the previous token}
1373     case Token of
1374     tknNil, tknAnyChar, tknBegOfLine, tknEndOfLine, tknGroup, tknBegTag, tknEndTag :
1375     begin
1376     PatRec^.OneChar := Null;
1377     PatRec^.StrPtr := nil;
1378     end;
1379     tknLitChar :
1380     begin
1381     if IgnoreCase then
1382     PatRec^.OneChar := AnsiChar(AnsiUpperCase(S[1])[1])
1383     else
1384     PatRec^.OneChar := S[1];
1385     PatRec^.StrPtr := nil;
1386     end;
1387     tknCharClass, tknNegCharClass :
1388     begin
1389     PatRec^.OneChar := Null;
1390     if FIgnoreCase then
1391     S := CleanUpCase(S);
1392     New(PatRec^.StrPtr);
1393     PatRec^.StrPtr^ := S;
1394     end;
1395     else
1396     RaiseStError(EStRegExError, stscUnknownError);
1397     end;
1398     end;
1399    
1400    
1401     function TStStreamRegEx.MakePattern(var Pattern : PAnsiChar;
1402     Start : Integer;
1403     Delim : AnsiChar;
1404     var TagOn : Boolean;
1405     var PatList : PStPatRecord) : Integer;
1406     var
1407     I : Integer;
1408     NextLastPatRec,
1409     LastPatRec,
1410     TempPatRec,
1411     PatRec : PStPatRecord;
1412     Done : Boolean;
1413     AChar : AnsiChar;
1414     TmpStr : ShortString;
1415     AToken : TStTokens;
1416     GroupStartPos,
1417     GroupEndPos : integer;
1418    
1419     begin
1420     PatList := FNodes.AllocNode;
1421     PatList^.Token := tknNil; {put a nil token at the beginning}
1422     PatList^.NextOK := False;
1423     LastPatRec := PatList;
1424     NextLastPatRec := nil;
1425    
1426     I := Start; {start point of pattern string}
1427     Done := False;
1428     while not(Done) and (Pattern[I] <> Delim) and (Pattern[I] <> EndStr) do begin
1429     AChar := Pattern[I];
1430     if (AChar = Any) then
1431     AddTokenToPattern(PatRec, LastPatRec, tknAnyChar, AChar)
1432     else if (AChar = Bol) then
1433     AddTokenToPattern(PatRec, LastPatRec, tknBegOfLine, '')
1434     else if (AChar = Eol) then
1435     AddTokenToPattern(PatRec, LastPatRec, tknEndOfLine, '')
1436     else if (AChar = Ccl) then begin
1437     Done := (GetCharacterClass(Pattern, I, TmpStr, AToken) = False);
1438     if Done then
1439     RaiseStError(EStRegExError, stscExpandingClass);
1440     AddTokenToPattern(PatRec, LastPatRec, AToken, TmpStr);
1441     end else if (AChar = Alter) then begin
1442     if (NextLastPatRec = nil) or
1443     ((NextLastPatRec^.Token <> tknClosure) and
1444     (NextLastPatRec^.Token <> tknMaybeOne)) then begin
1445     {flag the current token as non-critical, i.e., "next is OK"}
1446     LastPatRec^.NextOK := True;
1447     end else begin
1448     {alternation immediately after a closure is probably not desired}
1449     {e.g., [a-z]*|[0-9] would internally produce ([a-z]|[0-9])*}
1450     Done := True;
1451     RaiseStError(EStRegExError, stscAlternationFollowsClosure);
1452     end;
1453     end else if (AChar = BGroup) then begin
1454     GroupStartPos := I+1;
1455     AddTokenToPattern(PatRec, LastPatRec, tknGroup, '');
1456     {recursive branch off the list}
1457     I := MakePattern(Pattern, Succ(I), EGroup, TagOn, TempPatRec);
1458     if (I > 0) then begin
1459     GroupEndPos := I-1;
1460     if (Pattern[I+1] <> EndStr) then begin
1461     if (Pattern[I+1] in [Closure, ClosurePlus]) then begin
1462     if ((((GroupEndPos - GroupStartPos) = 1) or
1463     (((GroupEndPos - GroupStartPos) = 2) and (Pattern[GroupStartPos] = Esc))) and
1464     (Pattern[GroupEndPos] in [Closure, MaybeOne])) then begin
1465     Done := True;
1466     RaiseStError(EStRegExError, stscClosureMaybeEmpty);
1467     end else
1468     PatRec^.NestedPattern := TempPatRec;
1469     end else
1470     PatRec^.NestedPattern := TempPatRec;
1471     end else
1472     PatRec^.NestedPattern := TempPatRec;
1473     end else begin
1474     {didn't find egroup}
1475     Done := True;
1476     RaiseStError(EStRegExError, stscUnbalancedParens);
1477     end;
1478     end else if ((AChar = BTag) and (not(TagOn))) then begin
1479     AddTokenToPattern(PatRec, LastPatRec, tknBegTag, '');
1480     TagOn := True;
1481     end else if ((AChar = ETag) and (TagOn)) then begin
1482     AddTokenToPattern(PatRec, LastPatRec, tknEndTag, '');
1483     TagOn := False;
1484     end else if (((AChar = Closure) or (AChar = ClosurePlus) or
1485     (AChar = MaybeOne)) and (I > Start)) then begin
1486     if ((LastPatRec^.Token in [tknBegOfLine, tknEndOfLine, tknMaybeOne, tknClosure]) or
1487     (NextLastPatRec^.Token = tknClosure)) then begin
1488     {error, can't have closure after any of these}
1489     Done := True;
1490     RaiseStError(EStRegExError, stscFollowingClosure);
1491     end else begin
1492     if (AChar = ClosurePlus) then begin
1493     {insert an extra copy of the last token before the closure}
1494     TempPatRec := FNodes.CloneNode(LastPatRec);
1495     NextLastPatRec^.NextPattern := TempPatRec;
1496     TempPatRec^.NextPattern := LastPatRec;
1497     NextLastPatRec := TempPatRec;
1498     end;
1499     {insert the closure between next to last and last token}
1500     TempPatRec := FNodes.AllocNode;
1501     NextLastPatRec^.NextPattern := TempPatRec;
1502     if (AChar = MaybeOne) then
1503     TempPatRec^.Token := tknMaybeOne
1504     else
1505     TempPatRec^.Token := tknClosure;
1506     TempPatRec^.OneChar := Null;
1507    
1508     TempPatRec^.NextPattern := LastPatRec;
1509     TempPatRec^.NextOK := False;
1510     {set j and lastj back into sequence}
1511     PatRec := LastPatRec;
1512     LastPatRec := TempPatRec;
1513     end;
1514     end else begin
1515     if (AChar = Esc) then begin
1516     {skip over escape character}
1517     I := Succ(I);
1518     AChar := Pattern[I];
1519     case AChar of
1520     lSpace : AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #32);
1521     lNewline :
1522     begin
1523     AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #13);
1524     LastPatRec := PatRec;
1525     AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #10);
1526     end;
1527     lTab : AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #9);
1528     lBackSpace : AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #8);
1529     lReturn : AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #13);
1530     lFeed : AddTokenToPattern(PatRec, LastPatRec, tknLitChar, #10);
1531     lWordDelim : AddTokenToPattern(PatRec, LastPatRec, tknCharClass, StWordDelimString);
1532     lHex : AddTokenToPattern(PatRec, LastPatRec, tknCharClass, StHexDigitString);
1533     else
1534     AddTokenToPattern(PatRec, LastPatRec, tknLitChar,AChar);
1535     end;
1536     end else
1537     AddTokenToPattern(PatRec, LastPatRec, tknLitChar, AChar);
1538     end;
1539     NextLastPatRec := LastPatRec;
1540     LastPatRec := PatRec;
1541     if not(Done) then
1542     I := Succ(I);
1543     end; {of looking through pattern string}
1544    
1545     if ((Done) or (Pattern[I] <> Delim)) then begin
1546     Result := 0;
1547     RaiseStError(EStRegExError, stscPatternError);
1548     end else
1549     Result := I;
1550     end;
1551    
1552    
1553     function TStStreamRegEx.GetPattern(var Pattern : PAnsiChar;
1554     var PatList : PStPatRecord) : Boolean;
1555     {-convert a Pattern PAnsiChar into a pattern list, pointed to by patlist}
1556     {-return true if successful}
1557     var
1558     TagOn : Boolean;
1559     begin
1560     TagOn := False;
1561     Result := (MakePattern(Pattern, 0, EndStr, TagOn, PatList) > 0);
1562     if TagOn then begin
1563     GetPattern := False;
1564     RaiseStError(EStRegExError, stscUnbalancedTag);
1565     end;
1566     end;
1567    
1568    
1569     procedure TStStreamRegEx.AddTokenToReplace(var PatRec : PStPatRecord;
1570     LastPatRec : PStPatRecord;
1571     Token : TStTokens;
1572     const S : ShortString); {!!.02}
1573     {-add a token record to the pattern list}
1574     {S contains a literal character or an expanded character class}
1575     begin
1576     PatRec := FNodes.AllocNode;
1577     PatRec^.Token := Token; {save token type}
1578     PatRec^.NextOK := False; {default to non-alternation}
1579     LastPatRec^.NextPattern := PatRec; {hook up the previous token}
1580     if (Token = tknLitChar) or (Token = tknDitto) then begin
1581     PatRec^.OneChar := S[1];
1582     PatRec^.StrPtr := nil;
1583     end else
1584     RaiseStError(EStRegExError, stscUnknownError);
1585     end;
1586    
1587    
1588     function TStStreamRegEx.MakeReplacePattern(Pattern : PAnsiChar;
1589     Start : Integer;
1590     Delim : AnsiChar;
1591     var PatList : PStPatRecord) : Integer;
1592     {-make a pattern list from arg[i], starting at start, ending at delim}
1593     {return 0 is error, last char position in arg if OK}
1594     var
1595     I : Integer;
1596     PatRec,
1597     LastPatRec : PStPatRecord;
1598     Done : Boolean;
1599     AChar : AnsiChar;
1600    
1601     begin
1602     PatList := FNodes.AllocNode;
1603     PatList^.Token := tknNil; {put a nil token at the beginning}
1604     PatList^.NextOK := False;
1605     LastPatRec := PatList;
1606     I := Start; {start point of pattern string}
1607     Done := False;
1608     while not(Done) and (Pattern[I] <> Delim) and (Pattern[I] <> EndStr) do begin
1609     AChar := Pattern[I];
1610     if (AChar = Ditto) then
1611     AddTokenToReplace(PatRec, LastPatRec, tknDitto, '0')
1612     else begin
1613     if (AChar = Esc) then begin
1614     {skip over escape character}
1615     I := Succ(I);
1616     AChar := Pattern[I];
1617     if (AChar >= '1') and (AChar <= '9') then
1618     {a tagged ditto}
1619     AddTokenToReplace(PatRec, LastPatRec, tknDitto, AChar)
1620     else case AChar of
1621     lSpace : AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #32);
1622     lNewline :
1623     begin
1624     AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #13);
1625     LastPatRec := PatRec;
1626     AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #10);
1627     end;
1628     lTab : AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #9);
1629     lBackSpace : AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #8);
1630     lReturn : AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #13);
1631     lFeed : AddTokenToReplace(PatRec, LastPatRec, tknLitChar, #10);
1632     lNil : ;
1633     else
1634     AddTokenToReplace(PatRec, LastPatRec, tknLitChar, AChar);
1635     end;
1636     end else
1637     AddTokenToReplace(PatRec, LastPatRec, tknLitChar, AChar);
1638     end;
1639     LastPatRec := PatRec;
1640     if not(Done) then
1641     Inc(I);
1642     end; {of looking through pattern string}
1643    
1644     if Done or (Pattern[I] <> Delim) then begin
1645     Result := 0;
1646     RaiseStError(EStRegExError, stscPatternError);
1647     end else
1648     Result := I;
1649     end;
1650    
1651    
1652     function TStStreamRegEx.GetReplace(Pattern : PAnsiChar;
1653     var PatList : PStPatRecord) : Boolean;
1654     begin
1655     Result := (MakeReplacePattern(Pattern, 0, EndStr, PatList) > 0);
1656     end;
1657    
1658    
1659     function TStStreamRegEx.MatchOnePatternElement(var Buf : PAnsiChar;
1660     var I : Integer;
1661     var TagOn : Boolean;
1662     var TagNum : Integer;
1663     PatPtr : PStPatRecord) : Boolean;
1664     {-match one pattern element at pattern pointed to by PatPtr, Buf[I]}
1665     var
1666     Advance : -1..255;
1667     AToken : TStTokens;
1668     PatPos : Integer;
1669     K : Cardinal;
1670     C : AnsiChar;
1671     begin
1672     Advance := -1;
1673     AToken := PatPtr^.Token;
1674     if FIgnoreCase then
1675     C := AnsiChar(AnsiUpperCase(Buf[I])[1])
1676     else
1677     C := Buf[I];
1678    
1679     if (C <> EndStr) then begin
1680     if (AToken = tknLitChar) then begin
1681     if (C = PatPtr^.OneChar) then
1682     Advance := 1;
1683     end else if (AToken = tknCharClass) then begin
1684     if (StrChPosS(PatPtr^.StrPtr^, C, K)) then
1685     Advance := 1;
1686     end else if (AToken = tknNegCharClass) then begin
1687     if (not (C in [#13, #10])) then begin
1688     if not (StrChPosS(PatPtr^.StrPtr^, C, K)) then
1689     Advance := 1;
1690     end;
1691     end else if (AToken = tknAnyChar) then begin
1692     if not (C in [#13, #10]) then
1693     Advance := 1;
1694     end else if (AToken = tknBegOfLine) then begin
1695     if (I = 0) then
1696     Advance := 0;
1697     end else if (AToken = tknEndOfLine) then begin
1698     if (C = #13) and (Buf[Succ(I)] = #10) then
1699     Advance := 0;
1700     end else if (AToken = tknNil) then begin
1701     Advance := 0;
1702     end else if (AToken = tknBegTag) then begin
1703     Advance := 0;
1704     if not(TagOn) then begin
1705     TagNum := Succ(TagNum);
1706     TagOn := True;
1707     end;
1708     end else if (AToken = tknEndTag) then begin
1709     Advance := 0;
1710     TagOn := False;
1711     end else if (AToken = tknGroup) then begin
1712     {we treat a group as a "character", but allow advance of multiple chars}
1713     {recursive call to SearchMatchPattern}
1714     PatPos := SearchMatchPattern(Buf, I, TagOn, TagNum, PatPtr^.NestedPattern);
1715     if (PatPos >= I) then begin
1716     I := PatPos;
1717     Advance := 0;
1718     end;
1719     end;
1720     end else begin
1721     {at end of line}
1722     {end tag marks match}
1723     if (AToken = tknEndTag) then
1724     Advance := 0;
1725     end;
1726    
1727     if (Advance >= 0) then begin
1728     {ignore tag words here, since they are not used}
1729     Result := True;
1730     Inc(I, Advance);
1731     end else
1732     Result := False;
1733     end;
1734    
1735    
1736     function TStStreamRegEx.SearchMatchPattern(var Buf : PAnsiChar;
1737     OffSet : Integer;
1738     var TagOn : Boolean;
1739     var TagNum : Integer;
1740     PatPtr : PStPatRecord) : Integer;
1741     {-look for match of pattern list starting at PatPtr with Buf[offset...]}
1742     {-return the last position that matched}
1743     var
1744     I : Integer;
1745     K : Integer;
1746     PatRec : PStPatRecord;
1747     Done : Boolean;
1748     AToken : TStTokens;
1749    
1750     begin
1751     Done := False;
1752     PatRec := PatPtr;
1753     while not(Done) and (PatRec <> nil) do begin
1754     AToken := PatRec^.Token;
1755     if (AToken = tknClosure) then begin
1756     {a closure}
1757     PatRec := PatRec^.NextPattern; {step past the closure in the pattern list}
1758     I := OffSet; {leave the current line position unchanged}
1759     {match as many as possible}
1760     while not(Done) and (Buf[I] <> EndStr) do begin
1761     if not(MatchOnePatternElement(Buf, I, TagOn, TagNum, PatRec)) then
1762     Done := True;
1763     end;
1764     {I points to the location that caused a non-match}
1765     {match rest of pattern against rest of input}
1766     {shrink closure by one after each failure}
1767     Done := False;
1768     K := -1;
1769     while not(Done) and (I >= OffSet) do begin
1770     K := SearchMatchPattern(Buf, I, TagOn, TagNum, PatRec^.NextPattern);
1771     if (K > -1) then
1772     Done := True
1773     else
1774     Dec(I);
1775     end;
1776     OffSet := K; {if k=-1 then failure else success}
1777     Done := True;
1778     end else if (AToken = tknMaybeOne) then begin
1779     {a 0 or 1 closure}
1780     PatRec := PatRec^.NextPattern; {step past the closure marker}
1781     {match or no match is ok, but advance lin cursor if matched}
1782     MatchOnePatternElement(Buf, OffSet, TagOn, TagNum, PatRec);
1783     {advance to the next pattern token}
1784     PatRec := PatRec^.NextPattern;
1785     end else if not(MatchOnePatternElement(Buf, OffSet,
1786     TagOn, TagNum, PatRec)) then begin
1787     if PatRec^.NextOK then begin
1788     {we get another chance because of alternation}
1789     PatRec := PatRec^.NextPattern;
1790     end else begin
1791     OffSet := -1;
1792     Done := True;
1793     end;
1794     end else begin
1795     {skip over alternates if we matched already}
1796     while (PatRec^.NextOK) and (PatRec^.NextPattern <> nil) do
1797     PatRec := PatRec^.NextPattern;
1798     {move to the next non-alternate}
1799     PatRec := PatRec^.NextPattern;
1800     end;
1801     end;
1802     Result := OffSet;
1803     end;
1804    
1805    
1806     function TStStreamRegEx.FindMatch(var Buf : PAnsiChar;
1807     PatPtr : PStPatRecord;
1808     var REPosition : TMatchPosition) : Boolean;
1809     var
1810     I,
1811     LPos,
1812     TagNum : Integer;
1813     TagOn : Boolean;
1814    
1815     begin
1816     LPos := -1;
1817     I := 0;
1818     TagNum := 0;
1819     TagOn := False;
1820     Result := False;
1821     REPosition.Length := 0;
1822     while (Buf[I] <> EndStr) and (LPos = -1) do begin
1823     LPos := SearchMatchPattern(Buf, I, TagOn, TagNum, PatPtr);
1824     Result := (LPos > -1);
1825     if (Result) then begin
1826     REPosition.StartPos := I+1;
1827     RePosition.EndPos := LPos;
1828     RePosition.Length := REPosition.EndPos - REPosition.StartPos + 1;
1829     end;
1830     Inc(I);
1831     end;
1832     end;
1833    
1834    
1835    
1836     procedure TStStreamRegEx.InsertLineNumber(Dest : PAnsiChar;
1837     const S : PAnsiChar;
1838     LineNum : Integer);
1839     var
1840     Count : Cardinal;
1841     SI : string[8];
1842     begin
1843     Dest[0] := #0;
1844     Count := StrLen(S);
1845     if (Count > MaxLineLength - 8) then
1846     Count := MaxLineLength - 8;
1847     SI := LeftPadS(IntToStr(LineNum), 6) + ' ';
1848     Move(SI[1], Dest[0], 8);
1849     Move(S^, Dest[8], Count);
1850     Dest[Count+8] := #0;
1851     end;
1852    
1853    
1854    
1855     function TStStreamRegEx.ProcessLine( Buf : PAnsiChar;
1856     Len : integer;
1857     LineNum : integer;
1858     CheckOnly : Boolean;
1859     var REPosition: TMatchPosition) : Boolean;
1860     var
1861     Tmp : PAnsiChar;
1862     begin
1863     GetMem(Tmp, MaxLineLength+1);
1864     try
1865     if (FSelAvoidPatPtr <> nil) then begin
1866     if (not Avoid) then
1867     Result := FindMatch(Buf, FSelAvoidPatPtr, REPosition)
1868     else if (Avoid) then
1869     Result := not(FindMatch(Buf, FSelAvoidPatPtr, REPosition))
1870     else
1871     Result := True;
1872     end else
1873     Result := True;
1874    
1875     if Result then begin
1876     {met select criterion, perhaps by default}
1877     FSelectCount := Succ(FSelectCount);
1878     if ((FReplacePatPtr <> nil) and (not CheckOnly)) then begin
1879     if (ooModified in FOutputOptions) then begin
1880     {we only want to replace and output lines that have a match}
1881     Result := FindMatch(Buf, FMatchPatPtr, REPosition);
1882     end;
1883     if Result then begin
1884     Tmp[0] := #0;
1885     SubLine(Buf);
1886     if (not (ooCountOnly in FOutputOptions)) then begin
1887     if (LineNumbers) then
1888     InsertLineNumber(Tmp, FOutlineBuf, LineNum)
1889     else
1890     StrCopy(Tmp, FOutlineBuf);
1891     Tmp[StrLen(Tmp)-2] := #0;
1892     FOutTextStream.WriteLineZ(Tmp);
1893     end;
1894     {subline keeps a count of matched lines and replaced patterns}
1895     end;
1896     end else if (FMatchPatPtr <> nil) then begin
1897     Result := FindMatch(Buf, FMatchPatPtr, REPosition);
1898     {met match criterion}
1899     if Result then begin
1900     FMatchCount := Succ(FMatchCount);
1901     if (not CheckOnly) then begin
1902     if (not (ooCountOnly in FOutputOptions)) then begin
1903     Buf[Len] := #0;
1904     if (LineNumbers) then
1905     InsertLineNumber(Tmp, Buf, LineNum)
1906     else
1907     StrCopy(Tmp, Buf);
1908     Tmp[StrLen(Tmp)] := #0;
1909     FOutTextStream.WriteLineZ(Tmp);
1910     end;
1911     end;
1912     end;
1913     end else begin
1914     {we are neither matching nor replacing, just selecting}
1915     {output the selected line}
1916     if (not CheckOnly) then begin
1917     if (not (ooCountOnly in FOutputOptions)) then begin
1918     Buf[Len] := #0;
1919     if (LineNumbers) then
1920     InsertLineNumber(Tmp, Buf, LineNum)
1921     else
1922     StrCopy(Tmp, Buf);
1923     Tmp[StrLen(Tmp)] := #0;
1924     FOutTextStream.WriteLineZ(Tmp);
1925     end;
1926     end;
1927     end;
1928     end else begin
1929     {non-selected line, do we write it?}
1930     if (ooUnselected in FOutputOptions) and
1931     (not (ooCountOnly in FOutputOptions)) then begin
1932     Buf[Len] := #0;
1933     if (LineNumbers) then
1934     InsertLineNumber(Tmp, Buf, LineNum)
1935     else
1936     StrCopy(Tmp, Buf);
1937     Tmp[StrLen(Tmp)] := #0;
1938     FOutTextStream.WriteLineZ(Tmp);
1939     end;
1940     end;
1941     finally
1942     FreeMem(Tmp, MaxLineLength+1);
1943     end;
1944     end;
1945    
1946    
1947    
1948     procedure TStStreamRegEx.SetMatchPatSL(Value : TStringList);
1949     begin
1950     FMatchPatSL.Assign(Value);
1951     DisposeItems(FMatchPatPtr);
1952     end;
1953    
1954    
1955    
1956     procedure TStStreamRegEx.SetOptions(Value : TStOutputOptions);
1957     begin
1958     if (Value <> FOutputOptions) then begin
1959     FOutputOptions := Value;
1960     if (ooCountOnly in FOutputOptions) then
1961     FOutputOptions := [ooCountOnly];
1962     end;
1963     end;
1964    
1965    
1966    
1967     procedure TStStreamRegEx.SetReplacePatSL(Value : TStringList);
1968     begin
1969     FReplacePatSL.Assign(Value);
1970     DisposeItems(FReplacePatPtr);
1971     end;
1972    
1973    
1974    
1975     procedure TStStreamRegEx.SetSelAvoidPatSL(Value : TStringList);
1976     begin
1977     FSelAvoidPatSL.Assign(Value);
1978     DisposeItems(FSelAvoidPatPtr);
1979     end;
1980    
1981    
1982     function TStStreamRegEx.SubLineMatchOne(Buf : PAnsiChar;
1983     var Flags : TStFlag;
1984     var TagOn : Boolean;
1985     var I : Integer;
1986     var TagNum : Integer;
1987     PatPtr : PStPatRecord) : Boolean;
1988     var
1989     Advance : -1..255;
1990     lToken : TStTokens;
1991     PatPos : Integer;
1992     K : Cardinal;
1993     C : AnsiChar;
1994     begin
1995     Advance := -1;
1996     lToken := PatPtr^.Token;
1997     if FIgnoreCase then
1998     C := AnsiChar(AnsiUpperCase(Buf[I])[1])
1999     else
2000     C := Buf[I];
2001    
2002     if (C <> EndStr) then begin
2003     if (lToken = tknLitChar) then begin
2004     if (C = PatPtr^.OneChar) then
2005     Advance := 1;
2006     end else if (lToken = tknCharClass) then begin
2007     if (StrChPosS(PatPtr^.StrPtr^, C, K)) then
2008     Advance := 1;
2009     end else if (lToken = tknNegCharClass) then begin
2010     if (pos(C, NewLine) = 0) then begin
2011     if not (StrChPosS(PatPtr^.StrPtr^, C, K)) then
2012     Advance := 1;
2013     end;
2014     end else if (lToken = tknAnyChar) then begin
2015     if (not (C in [#13, #10])) then
2016     Advance := 1;
2017     end else if (lToken = tknBegOfLine) then begin
2018     if (I = 0) then
2019     Advance := 0;
2020     end else if (lToken = tknEndOfLine) then begin
2021     if (C = #13) and (Buf[Succ(I)] = #10) then begin
2022     Advance := 0;
2023     end;
2024     end else if (lToken = tknNil) then begin
2025     Advance := 0;
2026     end else if (lToken = tknBegTag) then begin
2027     Advance := 0;
2028     if not(TagOn) then begin
2029     Inc(TagNum);
2030     TagOn := True;
2031     end;
2032     end else if (lToken = tknEndTag) then begin
2033     Advance := 0;
2034     TagOn := False;
2035     end else if (lToken = tknGroup) then begin
2036     {we treat a group as a "character", but allow advance of multiple chars}
2037    
2038     PatPos := SubLineMatchPattern(Buf, Flags, TagOn, TagNum,
2039     I, PatPtr^.NestedPattern);
2040     if (PatPos >= I) then begin
2041     I := PatPos;
2042     Advance := 0;
2043     end;
2044     end;
2045     end else begin
2046     {at end of line}
2047     {end tag marks match}
2048     if (lToken = tknEndTag) then
2049     Advance := 0;
2050     end;
2051    
2052     if (Advance > 0) then begin
2053     {we had a match at this (these) character position(s)}
2054     {set the match flags}
2055     if (TagOn) then
2056     Flags[I] := TagNum
2057     else
2058     Flags[I] := 0;
2059     Inc(I, Advance);
2060     Result := True;
2061     end else if (Advance = 0) then begin
2062     Result := True;
2063     end else begin
2064     {this character didn't match}
2065     Result := False;
2066     Flags[I] := -1;
2067     end;
2068     end;
2069    
2070    
2071    
2072     function TStStreamRegEx.SubLineMatchPattern(Buf : PAnsiChar;
2073     var Flags : TStFlag;
2074     var TagOn : Boolean;
2075     var TagNum : Integer;
2076     OffSet : Integer;
2077     PatPtr : PStPatRecord) : Integer;
2078     {-look for match of pattern list starting at PatPtr with Buf[offset...]}
2079     {return the last position that matched}
2080     var
2081     I,
2082     LocTag : Integer;
2083     PatPos : Integer;
2084     PatRec : PStPatRecord;
2085     Done : Boolean;
2086     AToken : TStTokens;
2087     OldTagOn : boolean;
2088     OldTagNum: integer;
2089     begin
2090     Done := False;
2091     PatRec := PatPtr;
2092     while not(Done) and (PatRec <> nil) do begin
2093     AToken := PatRec^.Token;
2094     if (AToken = tknClosure) then begin
2095     {a closure}
2096     PatRec := PatRec^.NextPattern; {step past the closure in the pattern list}
2097     I := OffSet; {leave the current line position unchanged}
2098     LocTag := TagNum;
2099     {match as many as possible}
2100     while not(Done) and (Buf[I] <> EndStr) do begin
2101     if not(SubLineMatchOne(Buf, Flags, TagOn,
2102     I, LocTag, PatRec)) then
2103     Done := True;
2104     end;
2105     {i points to the location that caused a non-match}
2106     {match rest of pattern against rest of input}
2107     {shrink closure by one after each failure}
2108     Done := False;
2109     PatPos := -1;
2110     while not(Done) and (I >= OffSet) do begin
2111     OldTagOn := TagOn;
2112     OldTagNum := LocTag;
2113     PatPos := SubLineMatchPattern(Buf, Flags, TagOn,
2114     LocTag, I, PatRec^.NextPattern);
2115     if (PatPos > -1) then
2116     Done := True
2117     else begin
2118     I := Pred(I);
2119     TagOn := OldTagOn;
2120     LocTag := OldTagNum;
2121     end;
2122     end;
2123     OffSet := PatPos; {if k=-1 then failure else success}
2124     TagNum := LocTag;
2125     Done := True;
2126     end else if (AToken = tknMaybeOne) then begin
2127     {a 0 or 1 closure}
2128     PatRec := PatRec^.NextPattern; {step past the closure marker}
2129     {match or no match is ok, but advance lin cursor if matched}
2130     SubLineMatchOne(Buf, Flags, TagOn, OffSet, TagNum, PatRec);
2131     {advance to the next pattern token}
2132     PatRec := PatRec^.NextPattern;
2133     end else if not(SubLineMatchOne(Buf, Flags, TagOn,
2134     OffSet, TagNum, PatRec)) then begin
2135     if PatRec^.NextOK then begin
2136     {we get another chance because of alternation}
2137     PatRec := PatRec^.NextPattern;
2138     end else begin
2139     OffSet := -1;
2140     Done := True;
2141     end;
2142     end else begin
2143     {skip over alternates if we matched already}
2144     while PatRec^.NextOK and (PatRec^.NextPattern <> nil) do
2145     PatRec := PatRec^.NextPattern;
2146     {move to the next non-alternate}
2147     PatRec := PatRec^.NextPattern;
2148     end;
2149     end;
2150     Result := OffSet;
2151     end;
2152    
2153    
2154     function TStStreamRegEx.SubLineFindTag(Buf : PAnsiChar;
2155     I : Integer;
2156     IEnd : Integer;
2157     TagNum : Integer;
2158     var Flags : TStFlag;
2159     var IStart : Integer;
2160     var IStop : Integer) : Boolean;
2161     {-find the tagged match region}
2162     {return true if it is found}
2163     begin
2164     IStart := I;
2165     while (Buf[IStart] <> EndStr) and (Flags[IStart] <> TagNum) do
2166     Inc(IStart);
2167     if (Flags[IStart] = TagNum) then begin
2168     Result := True;
2169     IStop := IStart;
2170     while (Flags[IStop] = TagNum) and (IStop < IEnd) do
2171     Inc(IStop);
2172     end else
2173     Result := False;
2174     end; {findtag}
2175    
2176    
2177    
2178     procedure TStStreamRegEx.SubLineWrite(Buf : PAnsiChar;
2179     S : PAnsiChar;
2180     RepRec : PStPatRecord;
2181     I,
2182     IEnd : Integer;
2183     var Flags : TStFlag);
2184     {-Write the output line with replacements}
2185     var
2186     TagNum,
2187     IStart,
2188     IStop : Integer;
2189     PatRec : PStPatRecord;
2190     Token : TStTokens;
2191     begin {writesub}
2192     {scan the replacement list}
2193     S[0] := #0;
2194     PatRec := RepRec;
2195     while (PatRec <> nil) do begin
2196     Token := PatRec^.Token;
2197     if (Token = tknDitto) then begin
2198     TagNum := Ord(PatRec^.OneChar)-Ord('0');
2199     if (TagNum = 0) then begin
2200     {untagged ditto}
2201     {add the entire matched region}
2202     AppendS(S, S, @Buf[I], IEnd-I);
2203     end else begin
2204     {tagged ditto}
2205     {find the tagged region}
2206    
2207     if SubLineFindTag(Buf, I, IEnd, TagNum, Flags, IStart, IStop) then begin
2208     {add the tagged region}
2209     AppendS(S, S, @Buf[IStart], IStop-IStart);
2210     end else begin
2211     {else couldn't find tagged word, don't append anything}
2212     end;
2213     end;
2214     end else if (Token = tknLitChar) then
2215     AppendS(S, S, @PatRec^.OneChar, 1);
2216     PatRec := PatRec^.NextPattern;
2217     end;
2218     end;
2219    
2220    
2221    
2222     procedure TStStreamRegEx.SubLine(Buf : PAnsiChar);
2223     var
2224     I,
2225     M,
2226     NumToAdd,
2227     TagNum,
2228     Lastm : Integer;
2229    
2230     Flags : TStFlag;
2231     TagOn,
2232     DidReplace : Boolean;
2233     ALine : PAnsiChar;
2234     begin
2235     DidReplace := False;
2236     LastM := -1;
2237     I := 0;
2238    
2239     GetMem(ALine, MaxLineLength+1);
2240     try
2241     FOutLineBuf[0] := #0;
2242     FillChar(ALine^, MaxLineLength+1, #0);
2243     while (Buf[I] <> EndStr) do begin
2244     TagNum := 0;
2245     TagOn := False;
2246    
2247     M := SubLineMatchPattern(Buf, Flags, TagOn, TagNum, I, FMatchPatPtr);
2248     if (M > -1) and (M <> I) and (LastM <> M) then begin
2249     {keep track of count}
2250     DidReplace := True;
2251     Inc(FReplaceCount);
2252     {replace matched text}
2253    
2254     SubLineWrite(Buf, ALine, FReplacePatPtr, I, M, Flags);
2255     LastM := M;
2256     AppendS(FOutLineBuf, FOutLineBuf, ALine, StrLen(ALine));
2257     end;
2258    
2259     if (M = -1) or (M = I) then begin
2260     {no match or null match, append the character}
2261     if (Buf[I] = #13) then
2262     NumToAdd := 2
2263     else
2264     NumToAdd := 1;
2265     AppendS(FOutLineBuf, FOutLineBuf, @Buf[I], NumToAdd);
2266     I := I + NumToAdd;
2267     end else {skip matched text}
2268     I := M;
2269    
2270     end;
2271     if DidReplace then
2272     Inc(FMatchCount);
2273     finally
2274     FreeMem(ALine, MaxLineLength+1)
2275     end;
2276     end;
2277    
2278    
2279     {******************************************************************************}
2280     { TStRegEx Implementation }
2281     {******************************************************************************}
2282    
2283     constructor TStRegEx.Create(AOwner : TComponent);
2284     begin
2285     inherited Create(AOwner);
2286    
2287     FAvoid := False;
2288     FIgnoreCase := False;
2289     FLineNumbers := False;
2290     FOutputOptions := [];
2291    
2292     FInLineTerminator := ltCRLF;
2293     FInLineTermChar := #10;
2294     FInFixedLineLength:= 80;
2295    
2296     FOutLineTerminator := ltCRLF;
2297     FOutLineTermChar := #10;
2298     FOutFixedLineLength := 80; {not used straight away}
2299    
2300     FMaxLineLength := 1024;
2301    
2302     FMatchPatSL := TStringList.Create;
2303     FMatchPatPtr := nil;
2304     FSelAvoidPatSL := TStringList.Create;
2305     FSelAvoidPatPtr:= nil;
2306     FReplacePatSL := TStringList.Create;
2307     FReplacePatPtr := nil;
2308    
2309     FInFileStream := nil;
2310     FOutFileStream := nil;
2311    
2312     FStream := TStStreamRegEx.Create;
2313     end;
2314    
2315    
2316     destructor TStRegEx.Destroy;
2317     begin
2318     FMatchPatSL.Free;
2319     FMatchPatSL := nil;
2320    
2321     FReplacePatSL.Free;
2322     FReplacePatSL := nil;
2323    
2324     FSelAvoidPatSL.Free;
2325     FSelAvoidPatSL := nil;
2326    
2327     FStream.Free;
2328     FStream := nil;
2329    
2330     inherited Destroy;
2331     end;
2332    
2333    
2334     function TStRegEx.CheckString(const S : AnsiString;
2335     var REPosition : TMatchPosition) : Boolean;
2336     begin
2337     if (Assigned(FStream)) then begin
2338     SetStreamProperties;
2339     Result := FStream.CheckString(S, REPosition);
2340     end else
2341     Result := False;
2342     end;
2343    
2344    
2345     function TStRegEx.ReplaceString(var S : AnsiString;
2346     var REPosition : TMatchPosition) : Boolean;
2347     begin
2348     if (Assigned(FStream)) then begin
2349     SetStreamProperties;
2350     Result := FStream.ReplaceString(S, REPosition);
2351     end else
2352     Result := False;
2353     end;
2354    
2355    
2356     function TStRegEx.FileMasksToRegEx(const Masks : AnsiString) : Boolean;{!!.02}
2357     begin
2358     if (Assigned(FStream)) then begin
2359     SetStreamProperties;
2360     Result := FStream.FileMasksToRegEx(Masks);
2361     if (Result) then
2362     FMatchPatSL.Assign(FStream.FMatchPatSL);
2363     end else
2364     Result := False;
2365     end;
2366    
2367    
2368     function TStRegEx.Execute : Boolean;
2369     begin
2370     Result := False;
2371     try
2372     if (not FileExists(FInputFile)) then
2373     RaiseStError(EStRegExError, stscInFileNotFound);
2374    
2375     try
2376     FInFileStream := TFileStream.Create(FInputFile,
2377     fmOpenRead or fmShareDenyWrite);
2378     FStream.InputStream := FInFileStream
2379     except
2380     RaiseStError(EStRegExError, stscREInFileError);
2381     Exit;
2382     end;
2383    
2384     if not (ooCountOnly in OutputOptions) then begin
2385     if (FileExists(FOutputFile)) then
2386     try
2387     SysUtils.DeleteFile(FOutputFile);
2388     except
2389     RaiseStError(EStRegExError, stscOutFileDelete);
2390     Exit;
2391     end;
2392    
2393     FOutFileStream := nil;
2394     FStream.OutputStream := nil;
2395     try
2396     FOutFileStream := TFileStream.Create(FOutputFile, fmCreate);
2397     FStream.OutputStream := FOutFileStream
2398     except
2399     RaiseStError(EStRegExError, stscOutFileCreate);
2400     Exit;
2401     end;
2402     end;
2403    
2404     SetStreamProperties;
2405     Result := FStream.Execute;
2406    
2407     FMatchCount := FStream.FMatchCount;
2408     FSelectCount := FStream.FSelectCount;
2409     FReplaceCount := FStream.FReplaceCount;
2410     FInLineCount := FStream.FInLineCount;
2411     FLinesPerSec := FStream.FLinesPerSec;
2412     finally
2413     FInFileStream.Free;
2414     FInFileStream := nil;
2415    
2416     FOutFileStream.Free;
2417     FOutFileStream := nil;
2418     end;
2419     end;
2420    
2421    
2422    
2423     procedure TStRegEx.SetMatchPatSL(Value : TStringList);
2424     begin
2425     FMatchPatSL.Assign(Value);
2426     end;
2427    
2428    
2429    
2430     procedure TStRegEx.SetOptions(Value : TStOutputOptions);
2431     begin
2432     if (Value <> FOutputOptions) then begin
2433     FOutputOptions := Value;
2434     if (ooCountOnly in FOutputOptions) then
2435     FOutputOptions := [ooCountOnly];
2436     end;
2437     end;
2438    
2439    
2440    
2441     procedure TStRegEx.SetReplacePatSL(Value : TStringList);
2442     begin
2443     FReplacePatSL.Assign(Value);
2444     end;
2445    
2446    
2447    
2448     procedure TStRegEx.SetSelAvoidPatSL(Value : TStringList);
2449     begin
2450     FSelAvoidPatSL.Assign(Value);
2451     end;
2452    
2453    
2454    
2455     procedure TStRegEx.SetStreamProperties;
2456     begin
2457     if (not Assigned(FStream)) then Exit;
2458    
2459     FStream.InLineTermChar := FInLineTermChar;
2460     FStream.InLineTerminator := FInLineTerminator;
2461     FStream.InFixedLineLength := FInFixedLineLength;
2462     {!!.02 - Changed }
2463     // FStream.InLineTermChar := FOutLineTermChar;
2464     // FStream.InLineTerminator := FOutLineTerminator;
2465     // FStream.InFixedLineLength := FOutFixedLineLength;
2466     FStream.OutLineTermChar := FOutLineTermChar;
2467     FStream.OutLineTerminator := FOutLineTerminator;
2468     FStream.OutFixedLineLength := FOutFixedLineLength;
2469     {!!.02 - Changed end }
2470    
2471     FStream.Avoid := FAvoid;
2472     FStream.IgnoreCase := FIgnoreCase;
2473     FStream.LineNumbers := FLineNumbers;
2474     FStream.MatchPattern := FMatchPatSL;
2475     FStream.OnMatch := FOnMatch;
2476     FStream.OnProgress := FOnProgress;
2477     FStream.OutputOptions := FOutputOptions;
2478     FStream.ReplacePattern := FReplacePatSL;
2479     FStream.SelAvoidPattern:= FSelAvoidPatSL;
2480    
2481     FStream.FMatchCount := 0;
2482     FStream.FSelectCount := 0;
2483     FStream.FReplaceCount := 0;
2484     FStream.FInLineCount := 0;
2485     FStream.FLinesPerSec := 0;
2486     end;
2487    
2488    
2489     end.
2490    
  ViewVC Help
Powered by ViewVC 1.1.20