Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/XCRT.ZIP/XCRT.PAS

Pascal/Delphi Source File | 1988-10-07 | 13.2 KB | 502 lines

Unit  xCRT;  {                     Version 1.2                      88/10/06

Useful extensions to the CRT unit.

This program is hereby donated to the public domain. It may be freely copied,
used & modified without charge or fee.

Author        :  Mike Babulic
                 3827 Charleswood Dr. N.W.
                 Calgary, Alberta
                 CANADA
                 T2L 2C7
Compuserve ID :  72307,314

}


interface

  uses Dos

{$IFDEF VER40}
   ,EnvUnit,Crt
{$ENDIF};


{--------------------------------------------------------------------------}

function GetKey: char;        {Waits for you to press a key on the keyboard}

var xKey : char;              {if GetKey returned 0, this contains the
                               extended key code}

const                         {Useful characters & keyboard codes}
    CR    = #13;
    ESC   = #27;
    BS    = #8;
    TAB   = #9;

    xKeyCode = #0;    {extended key codes}

      NUL   = #3;

      Shift_TAB = #15;

      goHome  = #71;  goEnd   = #79;
      Ins     = #82;  Del     = #83;

      goLeft   =  #75;   goRight  =  #77;  {arrow keys}
      goUp     =  #72;   goDown   =  #75;



{--------------------------------------------------------------------------}


function AskYN(prompt:string; defaultYes:boolean): boolean;
  {prints the prompt and waits for a Y or N.
   Returns TRUE if Y is pressed.
    - returns defaultYes if CR is pressed}


{--------------------------------------------------------------------------}

type
    EfResult = (EfQuit   { Escape key pressed }
               ,EfNormal { Normal Exit        }
               ,EfGoNext { Normal Exit, go to next "enter field"}
               ,EfGoPrev { Normal Exit, go to previous "enter field"}
               );

function EnterField(
                    var data{:string};   { Data string to be edited }
                    MaxLen,              { Maximum length of data string }
                    FieldLen,            { Length of edit field }
                    Offset               { Starting cursor pos. in field }
                      : integer
           ):EfResult;
  {Creates a 1 line data entry field at the current position on the screen.
   Can use Ins,Del,Home,End and arrow keys to edit the field.
   Escape is the Quit key.}

function MaxFieldLen(len:integer): integer;
  {Maximum field length (up to "len") allowed at current cursor position}

procedure FrameField(MaxLen:integer);
  {Build a Frame for a field at the current cursor position}

{--------------------------------------------------------------------------}


type
      XFName = record
          d : DirStr;
          n : NameStr;
          x : ExtStr;
          end;

      XFDlogKind = (forInput,forOutput);


const  {Switches for GetXFName}

      XFSearchPath        :boolean = TRUE;  {Search the path for name}
      XfAskAboutWildcards :boolean = TRUE;  {Warns user when wildcards in name}


function GetXFName(prompt:string; defaultName:PathStr; kind:XFDlogKind;
                   var name:XFName
                  ):boolean;
  {Use the EnterField to prompt the user for a file name.
   Returns TRUE if "name" is a valid file name and the user selected it.
     - prompt      : a message to prompt the user.
     - defaultName : a initial value of "name".
     - kind        : is the file going to be for input or output?
     - name        : the file name is returned here.
  }


{--------------------------------------------------------------------------}


function LoCase(c:char):char;  {returns lower case value of "c");


procedure ClrLine;             {clear a line on the screen}


function WindH : word;         {Horizontal size of current text window}

function WindV : word;         {Vertical size of current text window}


{--------------------------------------------------------------------------}


implementation

{$IFNDEF VER40}
    uses EnvUnit,Crt;
{$ENDIF}

  const
    {special characters}

    cLeft    =  #27;   cRight   =  #26;  {visible arrow characters}
    cUp      =  #24;   cDown    =  #25;

function LoCase(c:char):char;
  begin
    if c in ['A'..'Z'] then c := chr(ord(c)-ord('A')+ord('a'));
    LoCase := c;
  end;


function GetKey: char;
  var c:char;
  begin
    repeat until keypressed;
    c := ReadKey;
    if c=#0 then
      xKey := ReadKey
    else
      xKey := #0;
    GetKey := c;
  end;

procedure ClrLine;
  begin
    gotoXY(1,whereY); ClrEol;
  end;

function WindH : word;
  begin
    WindH := lo(WindMax) - lo(WindMin) + 1;
  end;

function WindV : word;
  begin
    WindV := hi(WindMax) - hi(WindMin) + 1;
  end;

function MaxFieldLen(len:integer): integer;
  var max : integer;
  begin
    max := WindH-whereX+1;
    if len<max then
      MaxFieldLen := len
    else begin
      MaxFieldLen := max;
      {Turbo's CRT unit will scroll when
       you write in the bottom right corner, so..}
         if WhereY=WindV then  MaxFieldLen := max-2;
    end;
  end;

procedure FrameField(MaxLen:integer);
  var
      x,y,i : integer;
  begin
    x := whereX;  y := whereY;
    MaxLen := MaxFieldLen(MaxLen+3);
    write('[');
    for i := 3 to MaxLen do  write(' ');
    write(' ]');
    gotoXY(x+1,y);
  end;


function EnterField(
                    var data{:string};   { Data string to be edited }
                    MaxLen,              { Maximum length of data string }
                    FieldLen,            { Length of edit field }
                    Offset               { Starting cursor pos. in field }
                      : integer
           ):EfResult;
  var
      value : string  ABSOLUTE  data;
      x,y : integer;
      theLine: string;
      len,i : integer;
      key : char;
      InsertMode : boolean;
  procedure Update(first,last:integer);
    forward;
  function InRange(i:integer):integer;
    begin
      if      i<1      then  i:=1
      else if i>MaxLen then  i:=MaxLen;
      InRange := i;
    end;
  procedure go(pos:integer);
    begin
      pos := InRange(pos);
      if not InsertMode then
        update(i,pos);
      i := pos;
      if i < offset then begin
        offset := i;
        update(offset,offset+FieldLen-1);
       end
      else if i >= offset+FieldLen then begin
        offset := i-FieldLen+1;
        update(offset,offset+FieldLen-1);
      end;
      gotoXY(x+i-offset,y);
    end;

  var UpdateRequest : record
        Issued : Boolean;
        first,last : integer;
        end;
  procedure Update(first,last:integer);
    var t,j,k : integer;
    begin
      first := InRange(first);  last := InRange(last);
      if first>last then begin
        j := first;  first := last;  last := j;
      end;
      if UpdateRequest.Issued then begin
        if first < UpdateRequest.First then
          UpdateRequest.First  := first;
        if last  > UpdateRequest.Last  then
          UpdateRequest.Last   := last;
       end
      else begin
        UpdateRequest.First  := first;
        UpdateRequest.Last   := last;
        UpdateRequest.Issued := TRUE;
      end;
    end;
  procedure DoUpdate;
    var oldCursor,toWrite,j : integer;
        oldTextAttr : byte;
    begin  with UpdateRequest do if Issued then begin
      if first <  offset          then first := offset;
      if last  >= offset+FieldLen then last  := offset+FieldLen-1;
      oldCursor := i;
      go(first);
        write(copy(theLine,first,last-first+1));
        toWrite := Length(theLine);
        if toWrite<first then toWrite := first;
        for j := toWrite to last do
          write(' ');
      go(oldCursor);
      if not InsertMode then begin
        oldTextAttr := TextAttr;
        TextAttr := $7F AND NOT TextAttr;
        if i<=len then
          write(theLine[i])
        else
          write(' ');
        TextAttr := oldTextAttr;
        go(oldCursor);
      end;
      Issued := FALSE;
    end  end;
  procedure DelChar(pos:integer);
    begin if (len>0) and (pos>0) and (pos<=len) then begin
      delete(theLine,pos,1);
      len := pred(len);
      if len<i then go(len+1);
      update(pos,len+1);
    end  end;
  procedure InsChar(pos:integer);
    begin if (len<MaxLen) and (pos<=MaxLen)then begin
      if pos<0   then  pos := 0;
      if len>pos then begin
        Move(theLine[pos],theLine[pos+1],len-pos+1);
        len := succ(len);
       end
      else if len<pos then begin
        FillChar(theLine[len+1],pos-len-1,' ');
        len := pos;
       end
      else begin
        len := succ(len);
      end;
      theLine[pos] := key;
      theLine[0] := chr(len);
      update(pos,len);
    end  end;
  procedure Echo;
    begin
      if (i>len) or InsertMode then
        InsChar(i)
      else begin
        theLine[i] := key;
        Update(i,i);
       end;
      go(succ(i));
    end;
  procedure FindEnd;
    begin
      while (len>0) and (theLine[len]=' ') do  len := pred(len);
      theLine[0] := chr(len);
      if len<offset then
        go(1);
      go(len+1);
    end;
  function EoEf : boolean;
    begin
      EoEf := (key IN [CR,ESC,TAB]) or (xKey = shift_TAB) or (i>=MaxLen);
    end;
  begin
    UpdateRequest.Issued := FALSE;
    x := whereX; y := whereY;
    InsertMode := TRUE;
    FieldLen := MaxFieldLen(FieldLen);
    theLine := value;
    len := length(value);
    go(offset);
    Update(1,len);
    DoUpdate;
    key := GetKey;
    while not EoEf do begin
        if key IN [' '..'~'] then
          Echo
        else if key = BS then begin
          if i>1 then begin
           go(pred(i));  DelChar(i);
          end end
        else if key = xKeyCode then
          case xKey of
            goLeft : go(pred(i));
            goRight: go(succ(i));
            goHome : go(1);
            goEnd  : FindEnd;
            Ins    : begin InsertMode := not InsertMode; update(i,i) end;
            Del    : DelChar(i);
          end; {case}
        DoUpdate;
        key := GetKey;
    end;
    if not InsertMode then begin
      InsertMode := True;
      Update(i,i);
    end;
    if key<> ESC then
      value := theLine;
    case key of
      ESC :begin
             EnterField := EfQuit;
             theLine    := value;   len := length(theLine);
             offset := 1;
             update(1,MaxLen);
           end;
      CR  :  EnterField := EfNormal;
      TAB :  EnterField := EfGoNext;
    else
      if xKey = Shift_TAB then  EnterField := EfGoPrev;
    end;
    doUpdate;
  end;

function AskYN(prompt:string; defaultYes:boolean): boolean;
  const
      Yes = 'Y';
      No  = 'N';
  var
      x,y,i  : integer;
      answer : char;
  begin
    x := whereX;
    y := whereY;
    write(prompt,' [');
      if defaultYes then
        write(UpCase(Yes),',',LoCase(No),']',BS,BS)
      else
        write(LoCase(Yes),',',UpCase(No),']');
      write(BS,BS);
    repeat
        answer := UpCase(GetKey);
    until answer IN [Yes,No,CR];
    gotoXY(x,y);
      for i := 1 to length(prompt) do  write(' ');
      write('      ');
      gotoXY(x,y);
    if answer = CR then
      if defaultYes then answer := Yes else answer := No;
    AskYN := (answer = Yes);
  end;


function GetXFName(prompt:string; defaultName:PathStr; kind:XFDlogKind;
                   var name:XFName
                  ):boolean;
  const
      FieldLen = 30;
  var
      k : char;
      s,t : PathStr;
      x,y : integer;
      done,found : boolean;
      flag : EfResult;
  procedure ErrMsg(m:string);
    begin
      gotoXY(x,y); writeln;
      write('     ',m);
    end;
  begin
    found := FALSE;
    x := whereX;
    writeln;writeln;
      y := whereY-2;
    s := DefaultName;
    repeat
      gotoXY(x,y);
      write(prompt);
        ClrEol;
      {get the answer}
      FrameField(FieldLen);
      done := (EfQuit = EnterField(s,SizeOf(s),FieldLen,1));
      if not done then begin
        if XFSearchPath then begin
          t := FFind(s);
          found := (t<>FFindErr);
         end
        else begin
          found := fileExists(s);
          if found then t := s;
        end;
      end;
      if kind = forInput then begin
        if not (found or done) then ErrMsg('File not found!');
       end
      else {forOutput} begin
        if found then begin
          ErrMsg('Overwrite "'+t+'"?');
          found := AskYN('',false);
          ClrLine;
          if not (found or FileExists(s)) then begin
            t := FExpand(s);
            ErrMsg('Write to "'+t+'"?');
            found := AskYN('',false);
            ClrLine;
          end;
         end
        else if not done then begin
          t := s;
          found := TRUE; {because we aren't overwriting anything}
        end;
      end;
      if found and XfAskAboutWildcards and ContainsWildcards(s) then begin
        ErrMsg('Filename contains wildcard characters.');
        found := AskYN(' OK?',false);
        ClrLine;
      end;
      done := done or found;
    until done;
    gotoxy(x,y+1); ClrEol;
    gotoxy(x,y+2); ClrEol;
    if found then begin
      with name do  fsplit(FExpand(t),d,n,x);
    end;
    GetXFName := found;
  end;


begin
  XFSearchPath := TRUE;
end.