C!T ROM 2/ctrom_ii_b.zip/ctrom_ii_b/PROGRAM/PASCAL/EDITWIN/EDLINE.PAS

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.