Category : Pascal Source Code
Archive   : RPL60.ZIP
Filename : RPLREP.INC
{*}
{*source code copyright (c) 1985, by TurboPower Software*}
{*}
{*}
function GetRep(var arg : PatLine; var PatList : PatPtr) : Boolean;
{-convert argument into a pattern list, pointed to by patlist}
{return true if successful}
function MakeRep(var arg : PatLine; Start : Integer; Delim : Char; var PatList : PatPtr) : 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;
Lastj, j : PatPtr;
Done : Boolean;
c : Char;
procedure AddRep(Tok : Tokens; Lastj : PatPtr; var j : PatPtr; s : LongString);
{-add a token record to the pattern list}
{s contains a literal character or an expanded character class}
begin
New(j); {allocate a new pointer for this token}
j^.Tok := Tok; {save token type}
j^.NexTok := False; {default to non-alternation}
j^.NestPtr := nil; {nestptr and next are filled in later if at all}
j^.Next := nil;
Lastj^.Next := j; {hook up the previous token}
if (Tok = tLitChar) or (Tok = tDitto) then begin
j^.One := s[1];
j^.StrPtr := nil;
end else begin
WrL('addrep:can''t happen');
Halt;
end;
end; {addrep}
begin {makerep}
New(PatList); {starter point for patlist}
PatList^.Tok := tNil; {put a nil token at the beginning}
PatList^.NexTok := False;
PatList^.Next := nil; {terminate list in case of nil pattern}
Lastj := PatList;
i := Start; {start point of pattern string}
Done := False;
while not(Done) and (arg[i] <> Delim) and (arg[i] <> EndStr) do begin
c := arg[i];
if (c = Ditto) then
AddRep(tDitto, Lastj, j, '0')
else begin
if c = Esc then begin
{skip over escape character}
i := Succ(i);
c := arg[i];
if (c >= '1') and (c <= '9') then
{a tagged ditto}
AddRep(tDitto, Lastj, j, c)
else case c of
lSpace : AddRep(tLitChar, Lastj, j, #32);
lNewline : begin
AddRep(tLitChar, Lastj, j, #13);
Lastj := j;
AddRep(tLitChar, Lastj, j, #10);
end;
lTab : AddRep(tLitChar, Lastj, j, #9);
lBackSpace : AddRep(tLitChar, Lastj, j, #8);
lReturn : AddRep(tLitChar, Lastj, j, #13);
lFeed : AddRep(tLitChar, Lastj, j, #10);
lInput : AddRep(tLitChar, Lastj, j, #60);
lOutput : AddRep(tLitChar, Lastj, j, #62);
lPipe : AddRep(tLitChar, Lastj, j, #124);
lNil : ;
else
AddRep(tLitChar, Lastj, j, c);
end;
end else
AddRep(tLitChar, Lastj, j, c);
end;
Lastj := j;
if not(Done) then i := Succ(i);
end; {of looking through pattern string}
if Done or (arg[i] <> Delim) then begin
MakeRep := 0;
WrL('pattern error detected near end of '+Copy(arg, 1, i));
end else MakeRep := i;
end; {makerep}
begin {getrep}
GetRep := (MakeRep(arg, 1, EndStr, PatList) > 0);
end; {getrep}
procedure SubLine(var Lin : Line; PatRec, RepRec : PatPtr; var Sub : Line);
{-rescan the line to get flags and multiple substititions}
var
NumToAdd, TagNum, i, Lastm, m : Integer;
tSub : Line;
flags : Flag;
TagOn, DidReplace : Boolean;
function aMatch(var Lin : Line; var flags : Flag;
OffSet : Integer;
var TagNum : Integer;
Pat : PatPtr) : Integer;
{-look for match of pattern list starting at pat with lin.val[offset...]}
{return the last position that matched}
var
i, k, LocTag : Integer;
j : PatPtr;
Done, Junk : Boolean;
tTok : Tokens;
function oMatch(var Lin : Line; var flags : Flag;
var i, TagNum : Integer;
Pat : PatPtr) : Boolean;
{-match one pattern element at pattern pointed to by pat, lin.val[i]}
var
Advance : -1..255;
tTok : Tokens;
k : Integer;
c : Char;
begin {omatch}
Advance := -1;
tTok := Pat^.Tok;
if IgnoreCase then c := UpCaseMac(Lin.Val[i]) else c := Lin.Val[i];
if c <> EndStr then begin
if tTok = tLitChar then begin
if c = Pat^.One then Advance := 1;
end else if tTok = tCcl then begin
k := Pos(c, Pat^.StrPtr^);
if k > 0 then Advance := 1;
end else if tTok = tnCcl then begin
if Pos(c, NewLine) = 0 then begin
k := Pos(c, Pat^.StrPtr^);
if k = 0 then Advance := 1;
end;
end else if tTok = tAny then begin
if (c <> #13) and (c <> #10) then Advance := 1;
end else if tTok = tBol then begin
if i = 1 then Advance := 0;
end else if tTok = tEol then begin
if (c = #13) and (Lin.Val[Succ(i)] = #10) then begin
Advance := 0;
end;
end else if tTok = tNil then begin
Advance := 0;
end else if tTok = tbTag then begin
Advance := 0;
if not(TagOn) then begin
{WrL('increment tagnum to ',tagnum+1);}
TagNum := Succ(TagNum);
TagOn := True;
end;
end else if tTok = teTag then begin
Advance := 0;
TagOn := False;
end else if tTok = tGroup then begin
{we treat a group as a "character", but allow advance of multiple chars}
{recursive call to amatch}
k := aMatch(Lin, flags, i, TagNum, Pat^.NestPtr);
if k >= i then begin
i := k;
Advance := 0;
end;
end;
end else begin
{at end of line}
{end tag marks match}
if (tTok = teTag) then Advance := 0;
end;
if Advance > 0 then begin
{we had a match at this (these) character position(s)}
{set the match flags}
if TagOn then flags[i] := TagNum else flags[i] := 0;
i := i+Advance;
oMatch := True;
end else if Advance = 0 then begin
oMatch := True;
end else begin
{this character didn't match}
oMatch := False;
flags[i] := -1;
end;
end; {omatch}
begin {amatch}
Done := False;
j := Pat;
while not(Done) and (j <> nil) do begin
tTok := j^.Tok;
if tTok = tClosure then begin
{a closure}
j := j^.Next; {step past the closure in the pattern list}
i := OffSet; {leave the current line position unchanged}
LocTag := TagNum;
{match as many as possible}
while not(Done) and (Lin.Val[i] <> EndStr) do begin
if not(oMatch(Lin, flags, i, LocTag, j)) then Done := True;
end;
{i points to the location that caused a non-match}
{match rest of pattern against rest of input}
{shrink closure by one after each failure}
Done := False;
while not(Done) and (i >= OffSet) do begin
{call amatch recursively}
k := aMatch(Lin, flags, i, LocTag, j^.Next);
if k > 0 then
Done := True
else begin
i := Pred(i);
LocTag := flags[i];
{WrL('resetting tagnum to ',loctag);}
end;
end;
OffSet := k; {if k=0 then failure else success}
TagNum := LocTag;
Done := True;
end else if tTok = tMaybeOne then begin
{a 0 or 1 closure}
j := j^.Next; {step past the closure marker}
{match or no match is ok, but advance lin cursor if matched}
Junk := oMatch(Lin, flags, OffSet, TagNum, j);
{advance to the next pattern token}
j := j^.Next;
end else if not(oMatch(Lin, flags, OffSet, TagNum, j)) then begin
if j^.NexTok then begin
{we get another chance because of alternation}
j := j^.Next;
end else begin
{omatch failed, can't back up}
OffSet := 0;
Done := True;
end;
end else begin {omatch succeeded}
{skip over alternates if we matched already}
while j^.NexTok and (j^.Next <> nil) do j := j^.Next;
{move to the next non-alternate}
j := j^.Next;
end;
end;
aMatch := OffSet;
end; {amatch}
procedure WriteSub(var Lin : Line; var flags : Flag; RepRec : PatPtr;
i, iEnd : Integer; var m : Line);
{-Wr the output line with replacements}
var
TagNum, iStart, iStop : Integer;
j : PatPtr;
Tok : Tokens;
function FindTag(var Lin : Line; var flags : Flag; i, iEnd, TagNum : Integer;
{-} var iStart, iStop : Integer) : Boolean;
{-find the tagged match region}
{return true if it is found}
begin
iStart := i;
while (Lin.Val[iStart] <> EndStr) and (flags[iStart] <> TagNum) do
iStart := Succ(iStart);
if flags[iStart] = TagNum then begin
FindTag := True;
iStop := iStart;
while (flags[iStop] = TagNum) and (iStop < iEnd) do
iStop := Succ(iStop);
end else FindTag := False;
end; {findtag}
begin {writesub}
{scan the replacement list}
m.Length := 0;
j := RepRec;
while j <> nil do begin
Tok := j^.Tok;
if Tok = tDitto then begin
TagNum := Ord(j^.One)-Ord('0');
if TagNum = 0 then begin
{untagged ditto}
{add the entire matched region}
AppendS(m.Val[1], m.Length, Lin.Val[i], iEnd-i, m);
end else begin
{tagged ditto}
{find the tagged region}
if FindTag(Lin, flags, i, iEnd, TagNum, iStart, iStop) then begin
{add the tagged region}
AppendS(m.Val[1], m.Length, Lin.Val[iStart], iStop-iStart, m);
end {else couldn't find tagged word, don't append anything}
else begin
end;
end;
end else if Tok = tLitChar then
AppendS(m.Val[1], m.Length, j^.One, 1, m);
j := j^.Next;
end;
end; {writesub}
{ I debug.inc}
begin
DidReplace := False;
Lastm := 0;
i := 1;
{m:=lin.length;}
{debug(false);}
Sub.Length := 0;
while (Lin.Val[i] <> EndStr) do begin
TagNum := 0;
TagOn := False;
m := aMatch(Lin, flags, i, TagNum, PatRec);
if (m > 0) and (m <> i) and (Lastm <> m) then begin
{keep track of count}
DidReplace := True;
if wrCnt < 32766 then wrCnt := Succ(wrCnt);
{debug(true);}
{replace matched text}
WriteSub(Lin, flags, RepRec, i, m, tSub);
Lastm := m;
AppendS(Sub.Val[1], Sub.Length, tSub.Val[1], tSub.Length, Sub);
end;
if (m = 0) or (m = i) then begin
{no match or null match, append the character}
if Lin.Val[i] = #13 then NumToAdd := 2 else NumToAdd := 1;
AppendS(Sub.Val[1], Sub.Length, Lin.Val[i], NumToAdd, Sub);
i := i+NumToAdd;
end else {skip matched text}
i := m;
end;
if DidReplace then MatchCnt := Succ(MatchCnt);
end; {subline}
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/