home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
PASCAL
/
EDITWIN
/
EDLINE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-07-03
|
9KB
|
297 lines
{**************************************************************}
{ }
{ Saved as: EDLINE.PAS }
{ Language: Turbo Pascal 6 }
{ Author: Pat Anderson }
{ Purpose: ReadLn replacement, some }
{ miscellaneous string manipulation }
{ routines }
{ Last modified: Sat 06-20-92 }
{ }
{**************************************************************}
unit EdLine;
{--------------------------------------------------------------}
INTERFACE
{--------------------------------------------------------------}
uses
Crt,
Dos,
Minikit;
const
On = TRUE;
Off = FALSE;
var
SaveAttr : byte;
CursorPosition,
StartColumn : byte;
function EditLn (var line : string;
color_attr : byte;
var insert_flag : boolean;
var cursor : byte;
col,
row,
field_length : byte;
StickAtEnds : boolean;
DoWhileWaiting : proc) : char;
{function to input and/or edit a string, returns string
as edited, status of insert/overwrite flag and cursor position,
in var parameters, and key used to terminate input/editing as
function return value}
{--------------------------------------------------------------}
IMPLEMENTATION
{--------------------------------------------------------------}
var
key : char;
function EditLn;
var
ExitFlag : boolean;
key : char;
{------------------------------------------------------------}
{ Nested service routines for EditLn procedure }
{------------------------------------------------------------}
procedure CursorRight; {nested in Editline procedure}
begin
Inc (cursor);
if cursor > col + field_length - 1 then
if not StickAtEnds then
ExitFlag := true
else
Cursor := Col + Field_Length - 1;
end; {of CursorRight procedure}
procedure CursorLeft; {nested in EditLine procedure}
begin
Dec (cursor);
if cursor < col then
if not StickAtEnds then
ExitFlag := true
else
Cursor := Col;
end; {of CursorLeft procedure}
procedure CursorFront; {nested in EditLine procedure}
begin
cursor := col;
end; {of CursorFront procedure}
procedure CursorEnd; {nested in EditLine procedure}
var
position : byte;
begin
position := Length (line);
while line[position] = ' ' do
Dec (position);
cursor := col + position
end; {of CursorEnd procedure}
procedure WordRight; {nested in EditLine procedure}
var position : byte;
begin
position := cursor - col + 1;
while line[position] <> ' ' do
begin
Inc (position);
if position = field_length then
Exit;
end;
repeat
Inc (position);
until (line[position] <> ' ') OR (position = field_length);
cursor := col + position - 1;
if cursor = field_length then
CursorEnd;
end; {of WordRight procedure}
procedure WordLeft; {nested in Editline procedure}
var position : byte;
begin
position := cursor - col + 1;
while (line[position] <> ' ') AND (position >= 1) do
Dec (position);
while (line[position] = ' ') AND (position >= 1) do
Dec (position);
while (line[position] <> ' ') AND (position >= 1) do
Dec (position);
if position < 1 then
begin
cursor := col;
Exit;
end;
cursor := col + position - 1;
if cursor > col then Inc (cursor)
end; {of WordLeft procedure}
procedure DoBackSpace; {nested in EditLine procedure}
var
position : byte;
begin
if StickAtEnds then
if cursor = col then
Exit;
position := cursor - col + 1;
Delete (line, position - 1, 1);
line := line + ' ';
CursorLeft;
end; {of DoBackSpace procedure}
procedure DeleteChar; {nested in EditLine procedure}
var
position : byte;
begin
position := cursor - col + 1;
Delete (line, position, 1);
line := line + ' '
end; {of DeleteChar procedure}
procedure DeleteWord; {nested in EditLine procedure}
var
position : byte;
begin
position := cursor - col + 1;
repeat
DeleteChar
until (COPY(line, position, 1) = ' ');
DeleteChar
end; {of DeleteWord procedure}
procedure DeleteEOL; {nested in EditLine procedure}
var
count, position : byte;
begin
position := cursor - col + 1;
count := field_length - position + 1;
Delete (line, position, count);
line := Pad (line, field_length)
end; {of DeleteEOL procedure}
procedure ToggleInsert; {nested in EditLine procedure}
begin
insert_flag := NOT insert_flag;
end; {of ToggleInsert procedure}
procedure InsertChar; {nested in EditLine procedure}
var
character : string[1];
position : byte;
begin
position := cursor - col + 1;
(* Delete (line, field_length,1); *)
character := key;
Insert (character, line, position);
if line[field_length + 1] = ' ' then
Delete (line, field_length + 1, 1)
else
ExitFlag := true;
if Length (line) > field_length then
ExitFlag := true;
CursorRight
end; {of InsertChar procedure}
procedure ReplaceChar; {nested in EditLine procedure}
var
position : byte;
begin
position := cursor - col + 1;
line[position] := key;
CursorRight;
end; {of ReplaceChar procedure}
procedure PositionCursor; {nested in Editline procedure}
begin
Gotoxy (cursor, row);
if insert_flag then
BlockCursorOn
else
NormCursorOn;
end; {of PositionCursor procedure}
procedure ExtendedCodes; {nested in EditLine procedure}
begin
case key of
LeftArrow : CursorLeft; {left arrow}
RightArrow: CursorRight; {right arrow}
Home : CursorFront; {Home}
Del : DeleteChar; {Del}
End_Key : CursorEnd; {End}
Ins : ToggleInsert; {Ins}
CtlLeft : WordLeft; {Ctrl-left arrow}
CtlRight : WordRight; {Ctrl-right arrow}
else
ExitFlag := TRUE;
end; {of case statement}
end; {of ExtendedCodes procedure}
procedure ControlCodes; {nested in EditLine procedure}
begin
case key of
BackSpace : DoBackSpace;
^E : DeleteEOL;
^W, ^T : DeleteWord;
else {any other single control code}
ExitFlag := TRUE;
end; {of case statement}
end; {of ControlCodes procedure}
procedure ActOnKeypress; {nested in EditLine procedure}
begin
if key > #126 then
Extendedcodes
else
if key < #32 then
ControlCodes
else
if insert_flag = TRUE then
InsertChar
else ReplaceChar;
end; {of ActOnKeypress procedure}
procedure DisplayLine; {nested in EditLine procedure}
var
SaveAttr : byte;
begin
SaveAttr := TextAttr;
TextAttr := color_attr;
CursorOff;
GotoXY (col, row);
Write (line);
TextAttr := SaveAttr;
end; {of DisplayLine procedure}
begin {MAIN of EditLine procedure}
ExitFlag := FALSE;
SaveAttr := TextAttr;
TextAttr := Edit_Attr;
StartColumn := Col;
if Length (line) > field_length then
line := Copy (line, 1, field_length);
line := Pad (line, field_length);
if Cursor = field_length then
CursorEnd;
repeat
begin
DisplayLine;
PositionCursor;
CursorPosition := Cursor;
key := GetKey (DoWhileWaiting);
ActOnKeypress;
end;
until ExitFlag;
EditLn := key;
line := Strip (line);
TextAttr := SaveAttr;
end; {of EditLine procedure}
end.