mirror of
https://github.com/PDP-10/stacken.git
synced 2026-03-03 09:56:03 +00:00
932 lines
28 KiB
ObjectPascal
932 lines
28 KiB
ObjectPascal
(* AMIS search module *) (* -*-Pascal-*- *)
|
|
|
|
(****************************************************************************)
|
|
(* *)
|
|
(* Copyright (C) 1980, 1981, 1982, 1983, 1984, 1985, 1986, 1987 by *)
|
|
(* Stacken, Royal Institute Of Technology, Stockholm, Sweden. *)
|
|
(* All rights reserved. *)
|
|
(* *)
|
|
(* This software is furnished under a license and may be used and copied *)
|
|
(* only in accordance with the terms of such license and with the *)
|
|
(* inclusion of the above copyright notice. This software or any other *)
|
|
(* copies thereof may not be provided or otherwise made available to any *)
|
|
(* other person. No title to and ownership of the software is hereby *)
|
|
(* transferred. *)
|
|
(* *)
|
|
(* The information in this software is subject to change without notice *)
|
|
(* and should not be construed as a commitment by Stacken. *)
|
|
(* *)
|
|
(* Stacken assumes no responsibility for the use or reliability of its *)
|
|
(* software on equipment which is not supported by Stacken. *)
|
|
(* *)
|
|
(****************************************************************************)
|
|
|
|
(*$E+,T-*) (* Compiler directives. *)
|
|
|
|
module Search;
|
|
|
|
const (* Common constant declarations for all AMIS modules. 1981-07-26 / JMR *)
|
|
CtrlAtSign = 0; CtrlA = 1; CtrlB = 2;
|
|
CtrlC = 3; CtrlD = 4; CtrlE = 5;
|
|
CtrlF = 6; CtrlG = 7; CtrlH = 8;
|
|
CtrlI = 9; CtrlJ = 10; CtrlK = 11;
|
|
CtrlL = 12; CtrlM = 13; CtrlN = 14;
|
|
CtrlO = 15; CtrlP = 16; CtrlQ = 17;
|
|
CtrlR = 18; CtrlS = 19; CtrlT = 20;
|
|
CtrlU = 21; CtrlV = 22; CtrlW = 23;
|
|
CtrlX = 24; CtrlY = 25; CtrlZ = 26;
|
|
CtrlLeftBracket = 27; CtrlBackSlash = 28; CtrlRightBracket = 29;
|
|
CtrlUpArrow = 30; CtrlUnderScore = 31; RubOut = 127;
|
|
|
|
Null = CtrlAtSign; Bell = CtrlG; BackSpace = CtrlH;
|
|
HorizontalTab = CtrlI; LineFeed = CtrlJ; FormFeed = CtrlL;
|
|
CarriageReturn = CtrlM; Escape = CtrlLeftBracket;
|
|
|
|
HelpChar = CtrlUnderscore; (* Gives you help almost everywhere in AMIS. *)
|
|
|
|
StrSize = 40; (* Length of fixed length PACKED ARRAY OF CHAR strings. *)
|
|
|
|
type (* Common type declarations for all AMIS modules. 1981-07-26 / JMR *)
|
|
string = packed array [1 .. StrSize] of char; (* Fixed length string. *)
|
|
bufpos = integer; (* *** SYSTEM DEPENDENT *** Position in the buffer. *)
|
|
|
|
var
|
|
OldStr : string; (* Contains the last search string. *)
|
|
OldLen : integer; (* Holds significant length of string. *)
|
|
|
|
(* External procedures and functions in alphabetical order. *)
|
|
|
|
function BGetChar(i : bufpos) : char; external;
|
|
function BufSearch(Str : string; Len, RepeatCount : integer; HowFar : bufpos) :
|
|
boolean; external;
|
|
procedure Bug(Str : string); external;
|
|
procedure CommandLoop(RecursiveName : string); external;
|
|
procedure Delete(Len : bufpos); external;
|
|
function Delim(C : char) : boolean; external;
|
|
procedure EchoArrow(C : char); external;
|
|
procedure EchoClear; external;
|
|
procedure EchoDec(Number : integer); external;
|
|
procedure EchoString(Str : string); external;
|
|
procedure EchoUpdate; external;
|
|
procedure EOLString(var Str : string; var Len : integer); external;
|
|
procedure Error(Str : string); external;
|
|
function GetChar(Dot : bufpos) : char; external;
|
|
function GetDot : bufpos; external;
|
|
function GetLine(Lines : integer) : bufpos; external;
|
|
function GetMark(Pop : boolean) : bufpos; external;
|
|
function GetNull(Dot : bufpos) : char; external;
|
|
function GetSize : bufpos; external;
|
|
procedure Insert(C : char); external;
|
|
function KbdStop : boolean; external;
|
|
function Letter(C : char) : boolean; external;
|
|
function DownCase(C : char) : char; external;
|
|
function MetaBit : boolean; external;
|
|
procedure ModeClear; external;
|
|
procedure ModeString(Str : string); external;
|
|
procedure OvWLine; external;
|
|
procedure OvWString(Str : string); external;
|
|
function QReadC : char; external;
|
|
function ReadC : char; external;
|
|
procedure ReadLine(Prompt : string; var Str : string; var Length : integer);
|
|
external;
|
|
procedure ReMap(var c: char; searching: boolean); external;
|
|
procedure ReRead; external;
|
|
procedure SetDot(NewDot : bufpos); external;
|
|
procedure SetMark(NewMark : bufpos); external;
|
|
procedure TrmBeep; external;
|
|
procedure TtyWrite(c: char); external;
|
|
function UpCase(C : char) : char; external;
|
|
procedure WinOverWrite(ch : char); external;
|
|
procedure WinPos(row : integer); external;
|
|
procedure WinRefresh; external;
|
|
procedure WinUpdate; external;
|
|
|
|
(*---------------------------------------------------------------------------*)
|
|
(* Initialization procedure. Should be called at start of program execution. *)
|
|
|
|
(*@VMS: [global] *)
|
|
procedure SeaInit(Total: boolean);
|
|
begin
|
|
if Total
|
|
then OldLen := 0
|
|
end;
|
|
|
|
(*---------------------------------------------------------------------------*)
|
|
(* IncrementalSearch implements the AMIS functions ^R Incremental Search, ^R *)
|
|
(* Reverse Search and ^R String Search. Incremental should be true for ^R *)
|
|
(* Incremental Search and ^R Reverse Search and false for ^R String Search. *)
|
|
(* SearchArg is the numeric argument given to the command for ^R Incremental *)
|
|
(* Search and ^R String Search, and the negative of the numeric argument for *)
|
|
(* ^R Reverse Search. *)
|
|
|
|
(*@VMS: [global] *)
|
|
procedure IncrementalSearch(Incremental : boolean; SearchArg : integer);
|
|
|
|
type
|
|
refcontext = ^context;
|
|
context = packed record
|
|
Previous : refcontext;
|
|
CSuccess : boolean;
|
|
CSearchLen : 0..StrSize;
|
|
CSearchArg : integer;
|
|
CBeginDot, CDot : bufpos
|
|
end;
|
|
|
|
var
|
|
SearchStr, ReturnStr : string;
|
|
SearchLen, ReturnLen, ReturnPos : integer;
|
|
BeginDot : bufpos;
|
|
CurrentContext : refcontext;
|
|
BVoid, Success, More : boolean;
|
|
C : char;
|
|
|
|
procedure Search;
|
|
var
|
|
TopLine : boolean;
|
|
JumpBefore : (JumpToBeginning, DontJump, JumpToEnd);
|
|
ReturnPos : integer;
|
|
|
|
procedure GiveHelp;
|
|
begin
|
|
OvWString('You are typing a search string. '); OvWLine;
|
|
OvWString('You can rub out, or cancel with one or ');
|
|
OvWString('two C-G''s. '); OvWLine;
|
|
OvWString('C-U cancels the search string. Rubout ');
|
|
OvWString('rubs out one character. '); OvWLine;
|
|
OvWString('C-R reverses the direction of the ');
|
|
OvWString('search. '); OvWLine;
|
|
OvWString('C-B starts searching from the beginning ');
|
|
OvWString('of buffer, C-E starts at the end. '); OvWLine;
|
|
OvWString('C-F positions window so search object is');
|
|
OvWString('displayed near top. '); OvWLine;
|
|
OvWString('C-S searches, and returns to read in ');
|
|
OvWString('loop. Escape searches and exits. '); OvWLine;
|
|
OvWString('C-Q quotes control characters to search ');
|
|
OvWString('for them. ')
|
|
end;
|
|
|
|
function DotSearch : boolean;
|
|
var
|
|
OldDot : bufpos;
|
|
Success : boolean;
|
|
begin
|
|
EchoUpdate;
|
|
if JumpBefore = DontJump
|
|
then begin
|
|
OldDot := GetDot;
|
|
if SearchArg < 0
|
|
then SetDot(OldDot + SearchLen)
|
|
end
|
|
else begin
|
|
if JumpBefore = JumpToBeginning
|
|
then OldDot := 0
|
|
else oldDot := GetSize;
|
|
SetDot(OldDot)
|
|
end (* if *);
|
|
if SearchLen = 0
|
|
then Success := BufSearch(OldStr, OldLen, SearchArg, 0)
|
|
else begin
|
|
Success := BufSearch(SearchStr, SearchLen, SearchArg, 0);
|
|
OldStr := SearchStr;
|
|
OldLen := SearchLen
|
|
end (* if *);
|
|
if Success
|
|
then begin
|
|
if SearchArg < 0
|
|
then SetDot(GetDot - SearchLen);
|
|
if TopLine
|
|
then WinPos(2);
|
|
DotSearch := true
|
|
end
|
|
else begin
|
|
SetDot(OldDot);
|
|
EchoString('FAIL ');
|
|
BVoid := KbdStop;
|
|
DotSearch := false
|
|
end (* if *)
|
|
end (* DotSearch *);
|
|
|
|
procedure RePaint;
|
|
var
|
|
Pos : integer;
|
|
begin (* RePaint *)
|
|
EchoClear;
|
|
if JumpBefore = JumpToBeginning
|
|
then EchoString('BJ ')
|
|
else
|
|
if JumpBefore = JumpToEnd
|
|
then EchoString('EJ ');
|
|
if TopLine
|
|
then EchoString('Top Line ');
|
|
if SearchArg < 0
|
|
then EchoString('Reverse ');
|
|
EchoString('Search: ');
|
|
for Pos := 1 to SearchLen
|
|
do EchoArrow(SearchStr[Pos])
|
|
end (* RePaint *);
|
|
|
|
begin (* Search *)
|
|
TopLine := false;
|
|
JumpBefore := DontJump;
|
|
More := true;
|
|
while More
|
|
do begin
|
|
RePaint;
|
|
WinUpdate;
|
|
C := ReadC;
|
|
ReMap(c, true);
|
|
if C = Chr(HelpChar) (* C-_ => Display help message. *)
|
|
then begin
|
|
GiveHelp
|
|
end
|
|
else
|
|
if C = Chr(CtrlB) (* C-B => Search forward from beginning. *)
|
|
then begin
|
|
JumpBefore := JumpToBeginning;
|
|
if SearchArg < 0
|
|
then SearchArg := - SearchArg
|
|
end
|
|
else
|
|
if C = Chr(CtrlE) (* C-E => Search backward from end. *)
|
|
then begin
|
|
JumpBefore := JumpToEnd;
|
|
if SearchArg > 0
|
|
then SearchArg := - SearchArg
|
|
end
|
|
else
|
|
if C = Chr(CtrlF) (* C-F => Position match near top of screen. *)
|
|
then begin
|
|
TopLine := true
|
|
end
|
|
else
|
|
if C = Chr(CtrlR) (* C-R => Reverse direction of search. *)
|
|
then begin
|
|
if SearchArg > 0
|
|
then SearchArg := - 1
|
|
else SearchArg := 1
|
|
end
|
|
else
|
|
if C = Chr(CtrlS) (* C-S => Search and return to read in loop. *)
|
|
then begin
|
|
EchoString('^S ');
|
|
More := DotSearch
|
|
end
|
|
else
|
|
if C = Chr(Escape) (* Escape => Search and exit. *)
|
|
then begin
|
|
EchoString('$ ');
|
|
BVoid := DotSearch;
|
|
More := false
|
|
end
|
|
else
|
|
if C = Chr(RubOut) (* Rubout => Rub out one character. *)
|
|
then begin
|
|
if SearchLen > 0
|
|
then SearchLen := SearchLen - 1
|
|
else TrmBeep
|
|
end
|
|
else
|
|
if C = Chr(CtrlU) (* C-U => Rub out the search string. *)
|
|
then begin
|
|
SearchLen := 0
|
|
end
|
|
else
|
|
if C = Chr(CarriageReturn)(* Return => Insert end of line sequency into*)
|
|
then begin (* search string. *)
|
|
if SearchLen + ReturnLen > StrSize
|
|
then TrmBeep
|
|
else begin
|
|
for ReturnPos := 1 to ReturnLen
|
|
do SearchStr[SearchLen + ReturnPos] := ReturnStr[ReturnPos];
|
|
SearchLen := SearchLen + ReturnLen
|
|
end
|
|
end
|
|
else begin (* Other character => Insert it into string. *)
|
|
if C = Chr(CtrlQ) (* C-Q => Insert next character into string. *)
|
|
then begin
|
|
C := QReadC;
|
|
end (* if *);
|
|
if SearchLen + 1 > StrSize
|
|
then TrmBeep
|
|
else begin
|
|
SearchStr[SearchLen + 1] := C;
|
|
SearchLen := SearchLen + 1
|
|
end
|
|
end (* if *)
|
|
end (* while *)
|
|
end (* Search *);
|
|
|
|
procedure GiveHelp;
|
|
begin (* GiveHelp *)
|
|
OvWString('You are typing a search string. '); OvWLine;
|
|
OvWString('You can rub out, or cancel with one or ');
|
|
OvWString('two C-G''s. '); OvWLine;
|
|
OvWString('C-R and C-S change direction or repeat ');
|
|
OvWString('the search, '); OvWLine;
|
|
OvWString('C-R backward and C-S forward. Escape ');
|
|
OvWString('exits. '); OvWLine;
|
|
OvWString('C-Q quotes control characters to search ');
|
|
OvWString('for them. ')
|
|
end (* GiveHelp *);
|
|
|
|
procedure PopContext;
|
|
var
|
|
OldContext : refcontext;
|
|
begin
|
|
if CurrentContext = nil
|
|
then Bug('PopContext: CurrentContext = nil! /JMR ');
|
|
OldContext := CurrentContext;
|
|
CurrentContext := CurrentContext^.Previous;
|
|
Dispose(OldContext)
|
|
end;
|
|
|
|
procedure RestoreContext;
|
|
begin (* RestoreContext *)
|
|
if CurrentContext = nil
|
|
then Bug('RestoreContext: CurrentContext = nil! /J');
|
|
with CurrentContext^
|
|
do begin
|
|
Success := Csuccess;
|
|
SearchLen := CSearchLen;
|
|
SearchArg := CSearchArg;
|
|
BeginDot :=CBeginDot;
|
|
SetDot(CDot)
|
|
end (* with *);
|
|
PopContext
|
|
end (* RestoreContext *);
|
|
|
|
procedure SaveContext;
|
|
var
|
|
NewContext : refcontext;
|
|
begin (* SaveContext *)
|
|
New(NewContext);
|
|
with NewContext^
|
|
do begin
|
|
Previous := CurrentContext;
|
|
CSuccess := Success;
|
|
CSearchLen := SearchLen;
|
|
CSearchArg := SearchArg;
|
|
CBeginDot := BeginDot;
|
|
CDot := GetDot
|
|
end (* with *);
|
|
CurrentContext := NewContext
|
|
end (* SaveContext *);
|
|
|
|
procedure RePaint;
|
|
var
|
|
Pos : integer;
|
|
begin (* RePaint *)
|
|
EchoClear;
|
|
if not Success
|
|
then EchoString('Failing ');
|
|
if SearchArg < 0
|
|
then EchoString('Reverse ');
|
|
EchoString('I-Search: ');
|
|
for Pos := 1 to SearchLen
|
|
do EchoArrow(SearchStr[Pos])
|
|
end (* RePaint *);
|
|
|
|
function DotSearch(StartDot : bufpos) : boolean;
|
|
var
|
|
OldDot : bufpos;
|
|
begin (* DotSearch *)
|
|
EchoUpdate;
|
|
OldDot := getdot;
|
|
SetDot(StartDot);
|
|
if BufSearch(SearchStr, SearchLen, SearchArg, 0)
|
|
then begin
|
|
DotSearch := true;
|
|
if SearchArg < 0
|
|
then SetDot(GetDot - SearchLen)
|
|
end
|
|
else begin
|
|
DotSearch:= false;
|
|
BVoid := KbdStop;
|
|
SetDot(OldDot)
|
|
end
|
|
end (* DotSearch *);
|
|
|
|
begin (* IncrementalSearch *)
|
|
if SearchArg = 0
|
|
then error('NYI? 0 Argument Is Not Yet Implemented ');
|
|
SearchLen := 0;
|
|
EOLString(ReturnStr, ReturnLen);
|
|
if Incremental
|
|
then begin
|
|
ReturnPos := 0;
|
|
CurrentContext := nil;
|
|
Success := true;
|
|
BeginDot := GetDot;
|
|
More := true;
|
|
while More
|
|
do begin
|
|
RePaint;
|
|
WinUpdate;
|
|
if ReturnPos = 0
|
|
then begin
|
|
C := QReadC;
|
|
ReMap(c, true);
|
|
end (* if *);
|
|
if (ReturnPos > 0) (* End of line sequency *)
|
|
or (not MetaBit) and (* Or kind of printing char *)
|
|
(c in [chr(HorizontalTab), chr(LineFeed), chr(CtrlQ),
|
|
' '..'~' (*@VMS: , chr(160)..chr(255) *)])
|
|
then begin (* Insert it into string and search. *)
|
|
SaveContext;
|
|
if ReturnPos > 0 (* End of line sequency => Insert next *)
|
|
then begin (* character from end of line sequency. *)
|
|
C := ReturnStr[ReturnPos];
|
|
ReturnPos := ReturnPos + 1;
|
|
if ReturnPos > ReturnLen
|
|
then ReturnPos := 0
|
|
end
|
|
else
|
|
if C = Chr(CtrlQ) (* C-Q => Read another character, and use *)
|
|
then begin (* that character instead. *)
|
|
C := QReadC;
|
|
end (* if *);
|
|
if SearchLen = StrSize
|
|
then TrmBeep
|
|
else begin
|
|
SearchLen := SearchLen + 1;
|
|
SearchStr[SearchLen] := C;
|
|
if Success
|
|
then begin
|
|
if SearchArg > 0
|
|
then Success := DotSearch(GetDot - SearchLen + 1)
|
|
else
|
|
if SearchLen = 1
|
|
then Success := DotSearch(GetDot)
|
|
else
|
|
if BeginDot > GetDot + SearchLen
|
|
then Success := DotSearch(GetDot + SearchLen)
|
|
else Success := DotSearch(BeginDot)
|
|
end
|
|
else TrmBeep;
|
|
end (* if *)
|
|
end
|
|
else
|
|
if (C = Chr(HelpChar)) and (* C-_ => Display help message. *)
|
|
(not MetaBit)
|
|
then begin
|
|
GiveHelp
|
|
end
|
|
else
|
|
if (C = Chr(CarriageReturn)) and (* Return => Insert end of *)
|
|
(not MetaBit) (* line sequency into *)
|
|
then begin (* search string, instead of the characters *)
|
|
ReturnPos := 1 (* typed in, next time. *)
|
|
end
|
|
else
|
|
if (C = Chr(RubOut)) and (* Rubout => Rub out one character in the *)
|
|
(not MetaBit)
|
|
then begin (* search string, or one C-R or C-S command. *)
|
|
if CurrentContext = nil
|
|
then TrmBeep
|
|
else RestoreContext
|
|
end
|
|
else
|
|
if (C = Chr(CtrlG)) and (* C-G => Rub out untill success, if failing,*)
|
|
(not MetaBit)
|
|
then begin (* rub out all the way back, if successfull. *)
|
|
if Success
|
|
then begin
|
|
if CurrentContext <> nil
|
|
then begin
|
|
while CurrentContext^.Previous <> nil
|
|
do PopContext;
|
|
RestoreContext
|
|
end (* if *);
|
|
More := false
|
|
end
|
|
else begin
|
|
while not Success
|
|
do RestoreContext
|
|
end (* if *)
|
|
end
|
|
else
|
|
if (C = Chr(CtrlR)) and (* C-R => Search backward, recalling the old *)
|
|
(not MetaBit)
|
|
then begin (* search string, if the current is empty. *)
|
|
SaveContext;
|
|
if SearchLen = 0
|
|
then begin
|
|
SearchArg := - 1;
|
|
SearchStr := OldStr;
|
|
SearchLen := OldLen;
|
|
RePaint;
|
|
Success := DotSearch(GetDot)
|
|
end
|
|
else
|
|
if SearchArg < 0
|
|
then begin
|
|
if Success
|
|
then Success := DotSearch(GetDot + SearchLen - 1)
|
|
else TrmBeep
|
|
end
|
|
else begin
|
|
Success := true;
|
|
SearchArg := - 1;
|
|
RePaint;
|
|
Success := DotSearch(GetDot)
|
|
end (* if *)
|
|
end
|
|
else
|
|
if (C = Chr(CtrlS)) and (* C-S => Search forward, recalling the old *)
|
|
(not MetaBit)
|
|
then begin (* search string, if the current is empty. *)
|
|
SaveContext;
|
|
if SearchLen = 0
|
|
then begin
|
|
SearchArg := 1;
|
|
SearchStr := OldStr;
|
|
SearchLen := OldLen;
|
|
RePaint;
|
|
Success := DotSearch(GetDot)
|
|
end
|
|
else
|
|
if SearchArg > 0
|
|
then begin
|
|
if Success
|
|
then Success := DotSearch(GetDot - SearchLen + 1)
|
|
else TrmBeep
|
|
end
|
|
else begin
|
|
Success := true;
|
|
SearchArg := 1;
|
|
RePaint;
|
|
Success := DotSearch(GetDot)
|
|
end (* if *)
|
|
end
|
|
else
|
|
if (C = Chr(Escape)) and (not MetaBit) and
|
|
(SearchLen = 0) (* Escape AND Empty search *)
|
|
then begin (* string => Enter ^R String Search. *)
|
|
Search
|
|
end
|
|
else begin (* Other character => Exit, and remember the *)
|
|
OldStr := SearchStr; (* search string. Reread the character unless*)
|
|
OldLen := SearchLen; (* it is Escape. *)
|
|
EchoString('$ ');
|
|
if (C <> Chr(Escape)) or MetaBit
|
|
then ReRead;
|
|
More := false
|
|
end (* if *)
|
|
end (* while *);
|
|
while CurrentContext <> nil
|
|
do PopContext
|
|
end
|
|
else Search
|
|
end (* IncrementalSearch *);
|
|
|
|
(*---------------------------------------------------------------------------*)
|
|
(* QueryReplace implements the AMIS functions Query Replace and Replace *)
|
|
(* String. Query should be true for Query Replace and false for Replace *)
|
|
(* String. Delimitered should be true if a numeric argument was given to *)
|
|
(* Query Replace or Replace String. The routine prompts with 'Replace:' and *)
|
|
(* reads the search string from the terminal. Thereafter it prompts with *)
|
|
(* 'with:' and reads the replacement string. The last part of the routine *)
|
|
(* is a loop, in which the replacement is done. *)
|
|
|
|
(*@VMS: [global] *)
|
|
procedure QueryReplace(Query, Delimitered : boolean);
|
|
var
|
|
ModeName : string;
|
|
SearchStr, ReplaceStr : string;
|
|
SearchLen, ReplaceLen, SearchFirstLetter, ReplaceFirstLetter : integer;
|
|
PreserveCase, DontSearch, DontReplace, More : boolean;
|
|
C : char;
|
|
|
|
procedure GiveHelp;
|
|
begin (* GiveHelp *)
|
|
OvWString('Space => replace, Rubout => don''t, Comma');
|
|
OvWString('=> replace and show, ');
|
|
OvWLine;
|
|
OvWString('Period replaces once and exits, ! ');
|
|
OvWString('replaces all the rest, ');
|
|
OvWLine;
|
|
OvWString('C-R enters editor recursively, C-W does ');
|
|
OvWString('so after killing FOO, ');
|
|
OvWLine;
|
|
OvWString('^ returns to previous locus, ? gets ');
|
|
OvWString('help, C-L redisplays, ');
|
|
OvWLine;
|
|
OvWString('Escape exits, anything else exits and ');
|
|
OvWString('is reread. ');
|
|
OvWLine;
|
|
OvWLine;
|
|
OvWString('Type a space to see buffer again. ')
|
|
end (* GiveHelp *);
|
|
|
|
procedure CheckCase(Str : string; Len : integer);
|
|
var
|
|
Pos : integer;
|
|
FoundLower, FoundUpper : boolean;
|
|
C : char;
|
|
begin (* CheckCase *)
|
|
if PreserveCase
|
|
then begin
|
|
Pos := 1;
|
|
FoundLower := false;
|
|
FoundUpper := false;
|
|
while (Pos <= Len) and not FoundUpper
|
|
do begin
|
|
C := Str[Pos];
|
|
if C <> UpCase(C)
|
|
then FoundLower := true
|
|
else
|
|
if C <> DownCase(C)
|
|
then FoundUpper := true;
|
|
Pos := Pos + 1
|
|
end (* while *);
|
|
PreserveCase := FoundLower and not FoundUpper
|
|
end (* if *)
|
|
end (* CheckCase *);
|
|
|
|
function FindFirstLetter(Str : string; Len : integer) : integer;
|
|
var
|
|
Pos : integer;
|
|
FoundLetter : boolean;
|
|
begin (* FindFirstLetter *)
|
|
Pos := 1;
|
|
FoundLetter := false;
|
|
while (Pos <= Len) and not FoundLetter
|
|
do begin
|
|
FoundLetter := Letter(Str[Pos]);
|
|
Pos := Pos + 1
|
|
end (* while *);
|
|
if not FoundLetter
|
|
then Bug('FindFirstLetter: None found! /JMR ');
|
|
FindFirstLetter := Pos - 1
|
|
end (* FindFirstLetter *);
|
|
|
|
function DotSearch : boolean;
|
|
var
|
|
More : boolean;
|
|
OldDot : bufpos;
|
|
begin (* DotSearch *)
|
|
if Delimitered
|
|
then begin
|
|
OldDot := GetDot;
|
|
More := true;
|
|
while More
|
|
do begin
|
|
if not BufSearch(SearchStr, SearchLen, 1, 0)
|
|
then begin
|
|
SetDot(OldDot);
|
|
DotSearch := false;
|
|
More := false
|
|
end
|
|
else
|
|
if Delim(GetNull(GetDot - SearchLen - 1))
|
|
and Delim(GetNull(GetDot))
|
|
then begin
|
|
DotSearch := true;
|
|
More := false
|
|
end (* if *)
|
|
end (* while *)
|
|
end
|
|
else DotSearch := BufSearch(SearchStr, SearchLen, 1, 0);
|
|
end (* DotSearch *);
|
|
|
|
procedure Replace;
|
|
var
|
|
Pos : integer;
|
|
FirstUpper, RestUpper, FoundLetter : boolean;
|
|
Dot, Size : bufpos;
|
|
C : char;
|
|
begin (* Replace *)
|
|
if PreserveCase
|
|
then begin
|
|
FirstUpper := false;
|
|
RestUpper := false;
|
|
Dot := GetDot - SearchLen + SearchFirstLetter - 1;
|
|
C := GetChar(Dot);
|
|
if C <> DownCase(C)
|
|
then begin
|
|
FirstUpper := true;
|
|
RestUpper := true;
|
|
Dot := Dot + 1;
|
|
Size := GetSize;
|
|
FoundLetter := false;
|
|
while (Dot < Size) and not FoundLetter
|
|
do begin
|
|
C := GetChar(Dot);
|
|
FoundLetter := Letter(C);
|
|
Dot := Dot + 1
|
|
end (* while *);
|
|
if FoundLetter
|
|
then RestUpper := C <> DownCase(C)
|
|
end (* if *);
|
|
Delete (- SearchLen);
|
|
for Pos := 1 to ReplaceFirstLetter
|
|
do
|
|
if FirstUpper
|
|
then Insert(UpCase(ReplaceStr[Pos]))
|
|
else Insert(ReplaceStr[Pos]);
|
|
for Pos := ReplaceFirstLetter + 1 to ReplaceLen
|
|
do
|
|
if RestUpper
|
|
then Insert(UpCase(ReplaceStr[Pos]))
|
|
else Insert(ReplaceStr[Pos])
|
|
end
|
|
else begin
|
|
Delete(- SearchLen);
|
|
for Pos := 1 to ReplaceLen
|
|
do Insert(ReplaceStr[Pos])
|
|
end (* if *)
|
|
end (* Replace *);
|
|
|
|
procedure RePaint;
|
|
var
|
|
Pos : integer;
|
|
begin (* RePaint *)
|
|
ModeClear;
|
|
ModeString(ModeName);
|
|
EchoClear;
|
|
EchoString('Replace: ');
|
|
for Pos := 1 to SearchLen
|
|
do EchoArrow(SearchStr[Pos]);
|
|
EchoString(' with: ');
|
|
for Pos := 1 to ReplaceLen
|
|
do EchoArrow(ReplaceStr[Pos])
|
|
end (* RePaint *);
|
|
|
|
begin (* QueryReplace *)
|
|
ModeName := 'Query Replace. ';
|
|
EchoClear;
|
|
ReadLine('Replace: ', SearchStr, SearchLen);
|
|
ReadLine(' with: ', ReplaceStr, ReplaceLen);
|
|
PreserveCase := true;
|
|
CheckCase(SearchStr, SearchLen);
|
|
CheckCase(ReplaceStr, ReplaceLen);
|
|
if PreserveCase
|
|
then begin
|
|
SearchFirstLetter := FindFirstLetter(SearchStr, SearchLen);
|
|
ReplaceFirstLetter := FindFirstLetter(ReplaceStr, ReplaceLen)
|
|
end (* if *);
|
|
if Query
|
|
then begin
|
|
ModeClear;
|
|
ModeString(ModeName)
|
|
end
|
|
else begin
|
|
EchoClear;
|
|
EchoUpdate
|
|
end;
|
|
DontSearch := false;
|
|
DontReplace := false;
|
|
More := true;
|
|
while More
|
|
do begin
|
|
if not DontSearch
|
|
then begin
|
|
SetMark(GetDot);
|
|
More := DotSearch
|
|
end (* if *);
|
|
if More
|
|
then
|
|
if Query
|
|
then begin
|
|
WinUpdate;
|
|
C := QReadC;
|
|
if ((C = Chr(HelpChar)) or (C = '?')) and
|
|
(not MetaBit) (* C-_ and ? => Show help message. *)
|
|
then begin
|
|
GiveHelp;
|
|
DontSearch := true
|
|
end
|
|
else
|
|
if (C = ' ') and (not MetaBit) (* Space => Replace, and continue. *)
|
|
then begin
|
|
if not DontReplace
|
|
then Replace;
|
|
DontSearch := false;
|
|
DontReplace := false
|
|
end
|
|
else
|
|
if (C = Chr(Rubout)) and (not MetaBit) (* Rubout => Don't replace, *)
|
|
(* but continue. *)
|
|
then begin
|
|
DontSearch := false;
|
|
DontReplace := false
|
|
end
|
|
else
|
|
if (C = ',') and (not MetaBit) (* Comma => Replace, and stay there. *)
|
|
then begin
|
|
if not DontReplace
|
|
then Replace;
|
|
DontSearch := true;
|
|
DontReplace := true
|
|
end
|
|
else
|
|
if (C = '.') and (not MetaBit) (* Period => Replace, and exit. *)
|
|
then begin
|
|
if not DontReplace
|
|
then Replace;
|
|
More := false
|
|
end
|
|
else
|
|
if (C = '!') and (not MetaBit) (* Exclamation point => Replace, *)
|
|
then begin (* and continue without asking *)
|
|
EchoClear;
|
|
EchoUpdate;
|
|
if not DontReplace
|
|
then Replace;
|
|
DontSearch := false;
|
|
DontReplace := false;
|
|
Query := false
|
|
end
|
|
else
|
|
if ((C = Chr(CtrlR)) or (C = Chr(CtrlW))) and (not MetaBit)
|
|
(* C-R and C-W => Enter recursive edit level *)
|
|
then begin
|
|
if (C = Chr(CtrlW)) and not DontReplace
|
|
then Delete(- SearchLen);(* C-W => delete match before. *)
|
|
CommandLoop(ModeName);
|
|
RePaint;
|
|
DontSearch := true;
|
|
DontReplace := true
|
|
end
|
|
else
|
|
if (C = '^') and (not MetaBit) (* ^ => Return to previous match. *)
|
|
then begin
|
|
SetDot(GetMark(true));
|
|
DontSearch := true;
|
|
DontReplace := true
|
|
end
|
|
else
|
|
if (C = Chr(CtrlL)) and (not MetaBit) (* C-L => Redisplay window. *)
|
|
then begin
|
|
WinRefresh;
|
|
DontSearch := true
|
|
end
|
|
else begin (* Other character => Exit, and reread the *)
|
|
if (C <> Chr(Escape)) or (* character, unless it is Escape. *)
|
|
MetaBit
|
|
then ReRead;
|
|
More := false
|
|
end
|
|
end
|
|
else Replace
|
|
end (* while *);
|
|
if Query
|
|
then EchoClear
|
|
end (* QueryReplace *);
|
|
|
|
(*---------------------------------------------------------------------------*)
|
|
(* HowMany implements the AMIS function How Many. It prompts with 'Pattern:' *)
|
|
(* and reads the pattern string from the terminal. Then it counts the number *)
|
|
(* of occurences of the pattern string, after point. *)
|
|
|
|
(*@VMS: [global] *)
|
|
procedure HowMany;
|
|
var
|
|
SearchStr : string;
|
|
SearchLen, Occurences : integer;
|
|
OldDot : bufpos;
|
|
begin (* HowMany *)
|
|
EchoClear;
|
|
OldDot := GetDot;
|
|
ReadLine('Pattern: ', SearchStr, SearchLen);
|
|
EchoClear;
|
|
EchoUpdate;
|
|
Occurences := 0;
|
|
while BufSearch(SearchStr, SearchLen, 1, 0)
|
|
do Occurences := Occurences + 1;
|
|
EchoDec(Occurences);
|
|
EchoString(' occurences ');
|
|
EchoUpdate;
|
|
SetDot(OldDot)
|
|
end (* HowMany *);
|
|
|
|
(*---------------------------------------------------------------------------*)
|
|
(* Occur implements the AMIS function Occur. It prompts with 'Pattern:' *)
|
|
(* and reads the pattern string from the terminal. Then it shows every line, *)
|
|
(* after point, that contains the pattern string. *)
|
|
|
|
(*@VMS: [global] *)
|
|
procedure Occur;
|
|
var
|
|
SearchStr : string;
|
|
SearchLen : integer;
|
|
OldDot, First, Last, P : bufpos;
|
|
Ch : char;
|
|
begin (* Occur *)
|
|
EchoClear;
|
|
OldDot := GetDot;
|
|
ReadLine('Pattern: ', SearchStr, SearchLen);
|
|
while BufSearch(SearchStr, SearchLen, 1, 0)
|
|
do begin
|
|
First:= GetLine(0); Last:= GetLine(1);
|
|
for P:= First to Last-1 do WinOverWrite(BGetChar(P));
|
|
Setdot(Last);
|
|
end;
|
|
SetDot(OldDot)
|
|
end (* Occur *);
|
|
|
|
(*---------------------------------------------------------------------------*)
|
|
|
|
(*@TOPS: begin end. *)
|
|
(*@VMS: end. *)
|