{ $L WORK:TTY.A.LIST.TEXT}
{$S+} {SWAPPING MODE FOR MORE SYMBOL TABLE SPACE}

PROGRAM TTY;

{PROGRAM TO ALLOW MICRO TO ACT AS A TERMINAL TO A REMOTE}
{AND TO TRANSFER FILES BETWEEN THE MICRO AND THE REMOTE }

Uses 
{-----------------------------------------------------------------------------}
            {TTY.UNIT.G - unit include file for general - 1-Feb-83 }
{-----------------------------------------------------------------------------}

 {$U *system.library  } ScreenOps

{-----------------------------------------------------------------------------}
                                {end TTY.UNIT.G}
{-----------------------------------------------------------------------------}

   { holds specific units for target mc }

Using SCREENOP


const   
    sc_fill_len = 11;
    sc_eol = 13;  

type
    sc_chset        = set of char;
    sc_misc_rec     = packed record
                        height, width : 0..255;
                        can_break, slow, xy_crt, lc_crt,
                        can_upscroll, can_downscroll : boolean;
                      end;
    sc_date_rec     = packed record
                        month : 0..12;
                        day :   0..31;
                        year :  0..99;
                      end;
    sc_info_type    = packed record
                        sc_version : string;
                        sc_date : sc_date_rec;
                        spec_char : sc_chset; {Characters not to echo}
                        misc_info : sc_misc_rec;
                      end;
    sc_long_string  = string[255];
    sc_scrn_command = (sc_whome, sc_eras_s, sc_erase_eol, sc_clear_lne,
                       sc_clear_scn, sc_up_cursor, sc_down_cursor,
                       sc_left_cursor, sc_right_cursor);
    sc_key_command  = (sc_backspace_key, sc_dc1_key, sc_eof_key, sc_etx_key,
                       sc_escape_key, sc_del_key, sc_up_key, sc_down_key, 
                       sc_left_key, sc_right_key, sc_not_legal, sc_insert_key, 
                       sc_delete_key);
    sc_choice       = (sc_get, sc_give);
    sc_window       = packed array [0..0] of char;
    sc_tx_port      = record
                        row, col,             { screen relative}
                        height, width,        { size of txport (zero based)}
                        cur_x, cur_y  : integer;
                                     {cursor positions relative to the txport }
                      end;
                      
      {entries 4..syscom^.subsidstart-1 are valid}
    sc_err_msg_array = array [4..4] of ^string;  {accessed $R-}
                      
  var
    sc_port : sc_tx_port;
    sc_printable_chars : sc_chset;
    sc_errorline : integer;
    sc_errormessage : ^sc_err_msg_array;
  
  procedure sc_use_info(do_what:sc_choice; var t_info:sc_info_type);
  procedure sc_use_port(do_what:sc_choice; var t_port:sc_tx_port);
  procedure sc_erase_to_eol(x,line:integer);
  procedure sc_left;
  procedure sc_right;
  procedure sc_up;
  procedure sc_down;
  procedure sc_getc_ch(var ch:char; return_on_match:sc_chset);
  procedure sc_clr_screen;
  procedure sc_clr_line (y:integer);
  procedure sc_home;
  procedure sc_eras_eos (x,line:integer);
  procedure sc_goto_xy(x, line:integer);
  procedure sc_clr_cur_line;
  function  sc_find_x:integer;
  function  sc_find_y:integer;
  function  sc_scrn_has(what:sc_scrn_command):boolean;
  function  sc_has_key(what:sc_key_command):boolean;
  function  sc_map_crt_command(var k_ch:char):sc_key_command;
  function  sc_prompt(line :sc_long_string; x_cursor,y_cursor,x_pos,
                       where:integer; return_on_match:sc_chset; 
                       no_char_back:boolean; break_char:char):char;
  function  sc_check_char(var buf:sc_window; var buf_index,bytes_left:integer)
                          :boolean;
  function  sc_space_wait(flush:boolean):boolean;
  procedure sc_init;
    
     ;

{*******************************************************}
{                                                       }
{        ERCC Microcomputer Support Unit                }
{                                                       }
{        Contributors     Austin Tate                   }
{                         Stephen Hayes                 }
{                         Kenneth Currie                }
{                         Gordon Wilkie                 }
{                                                       }
{*******************************************************}

CONST Version='20-Dec-84'; { last alteration date }
      SPACE=' ';
      NUL=0;
      CTRLA=1;
      EOT=4;
      BEL=7;
      BS=8;
      LF=10;
      CTRLL=12;
      CR=13;
      DLE=16;
      XON=17;
      PADXON='|';
      XOFF=19;
      CTRLX=24;
      ESC=27;
      DEL=127;
      CRMSB=141;
      XONMSB=145;  {XON WITH MSB SET}
      XOFFMSB=147;
      msb1=177;    {character '1' with the msb set}
      msb3=179;

{ HOST SPECIFIC CONSTANTS }

      NEWLINE=10;  { the host specific Newline character }
      TransparenCh=16;  { the Byte Stuff character for special cases }
      BS_Map_Ch=127;  { the host prefered ERASE character }

{ VALUES SET IN INITDATA WHICH CAN BE ALTERED BY CONFIGURE }
{    HALFDUPLEX=FALSE   SET TO TRUE FOR A HALF DUPLEX HOST                }
{    CHINMOD=128   MASK FOR CHARACTERS REEIVED IN GETFILE}

type
  short_string=string[12];
  long_string=string[255];
VAR BreakChar,CH:CHAR;
    MCNAME:STRING; {GIVES LOCAL MACHINE TYPE - INITIALISED BY REMSETUP}
    escape_sequence,settcp, setpad:STRING;
    str:long_string;
    CRSTRING,CTRLASTRING, ctrlPstring:STRING[1];
    textfile,DEBUG,HALFDUPLEX:BOOLEAN;
    bottomline,repeatch,CHINMOD,X_Chinmod,XOFNUM,WAITTIME,I,J:INTEGER;
    CursorLost,ALTFILE,GOODLOCAL,TERMINAL:BOOLEAN;
    PromptSet:set of char;
    WAtX,WAtY,WWidth,WDepth,WCurX,WCurY:integer; { window variables }

{$P}
{-----------------------------------------------------------------------------}
                             {24-Mar-82 TTY.MESS.D}
{-----------------------------------------------------------------------------}

     Const
       sink_size=512;              {the current sink size}
       calls=6;                    {the number of allowed messages}
       MessDVersion=1;
     Type
       mess_form=(empty, host, local, debugging, star ); {message types}
     Var
       sink:packed array[1..sink_size] of char;
       TimeOutUnits,sink_pointer:integer;
       Last_got_message:0..calls;
       messages:array[1..calls] of string;
       mess_type:array[1..calls] of mess_form;
       Host_prompt:string;

     {also needed are the following - assumed to come from elsewhere
     
          Var promptset:set of char;
     
          Procedure remread(ch:char);
     }

{-----------------------------------------------------------------------------}
                                {end TTY.MESS.D}
{-----------------------------------------------------------------------------}



Procedure PutTxt(S:String);        Forward;  { used in DEV.X.X }
Procedure PutLn;                   Forward;
Procedure GetCh(var ch:char; Prompting,Echo:boolean);
                                   Forward;
Procedure GetLn(Var S:LongString); Forward;

{$P}
{-----------------------------------------------------------------------------}
                                 (* DEV.X.I *)
{-----------------------------------------------------------------------------}
(* Special routines for IBM from V4 and Sirius 1 X-talk *)
{ 24-Dec-84  Gordon Wilkie   REmflush modified so as not to print bells on IBM
                             as this takes 0.5 secs, and causes buffer overflow
  21-Dec-84  Gordon Wilkie   Remflush buffer increased to 512 for IBM PC
   4-dec-84  Gordon Wilkie   Null Breakcondition added }
{ 29-Aug-84  Gordon Wilkie  no call of REMDONE since it is a null routine 
  20-Aug-84  Gordon Wilkie  no U/C conversion 
  Austin Tate and Ken Currie 17-Aug-82  }

var statrec: array [0..29] of integer;

(* DEFINITIONS FOR MACHINE CODE ROUTINE IN PORT.INIT *)


PROCEDURE REMCOMMAND(I:INTEGER);
BEGIN
  (* dummy *)
END;
   
FUNCTION REMDONE:BOOLEAN; (* is normally EXTERNAL but dummy fo test *)
begin
  remdone:=true;
end;

PROCEDURE REMWRITE(CH:CHAR);
var ch2:packed array [1..2] of char;
BEGIN
  ch2[1]:=ch;
  {WHILE NOT REMDONE DO {nothing;}
  unitwrite(8,ch2[1],1,,12)
END;

PROCEDURE REMREAD(VAR CH:CHAR);
var ch2:packed array [1..2] of char;
BEGIN
  unitread(7,ch2[1],1,,12);
  ch:=ch2[1];
END;

FUNCTION REMPRESS:BOOLEAN;
BEGIN
  unitstatus(7,statrec,1);
  REMPRESS:=(Statrec[0]>0);
END;
   
PROCEDURE REMBAUD;
BEGIN
  PUTTXT('Set values during initial boot configuration.');
  PUTLN;
END;

PROCEDURE REMSETUP;
BEGIN
   MCNAME:='General V4';
   SC_Use_port(SCGet, SCPort);
   Bottomline:=SCPort.Height;
   {BottomLine:=23;}
END;

PROCEDURE REMFLUSH;
var i,j,k:integer;
    ch:char;
    ch2:packed array [0..1511] of char;
    statrec: array [0..29] of integer;
    
{$r-}
BEGIN
  unitstatus(7,statrec,1);
  k:=statrec[0];
  while k > 0 do {ch available}
    begin
      unitread(7,ch2,k,,12);
      for i:= 0 to k-1 do ch2[i]:=chr(ord(ch2[i]) mod 128);
      j:=SCAN(k,=chr(7),ch2);
      while j<>k do
       begin
         ch2[j]:=chr(0);
         j:=SCAN(k,=chr(7),ch2);
       end;
      unitwrite(1,Ch2,k,,12);
      unitstatus(7,statrec,1);
      k:=statrec[0];
    end;
END;
{$r+}


PROCEDURE BREAKCONDITION;

BEGIN
  write ('Cannot Generate Break!');
  REMWRITE(CHR(CR));
END;

PROCEDURE REMCLOSE;
BEGIN  
END;

FUNCTION KEYPRESS:BOOLEAN;
BEGIN
  unitstatus(2,statrec,1);
  KEYPRESS:=(Statrec[0]>0);
END;

PROCEDURE KEYREAD(VAR CH:CHAR;PROMPTING,ECHO:BOOLEAN);
var ch2:packed array [1..2] of char;
    I : INTEGER;
BEGIN
  unitread(2,ch2[1],1,,12);
  ch:=ch2[1];
  IF CH=CHR(CR) THEN BEGIN
     IF ECHO THEN WRITELN;
  END ELSE BEGIN
     IF PROMPTING THEN BEGIN
        IF CH<(' ') THEN CH:=CHR(BEL)
        {ELSE IF ('a'<=CH) AND (CH<='z') THEN
           CH:=CHR((ORD(CH)-ORD('a'))+ORD('A'))};
     END;
     IF ECHO THEN WRITE(CH);
  END;
END;

FUNCTION PARTX1:CHAR;
BEGIN  (*MACHINE SPECIFIC PART MACHINE CHARACTER*)
  PARTX1:='I';
END;

FUNCTION PARTX2:INTEGER;
BEGIN
  (*MACHINE SPECIFIC PART REVISION NUMBER*)
  PARTX2:=7;
END;

{-----------------------------------------------------------------------------}
                                 {end DEV.X.G}
{-----------------------------------------------------------------------------}

  


   { remote routines appropriate for MCNAME only.
      Appropriate file is renamed to DEV.X.X.TEXT before compilation }
{$p}
{-----------------------------------------------------------------------------}
                             {18-Dec-84 - TTY.MESS}
{-----------------------------------------------------------------------------}

Function PartM:integer;
begin
  PartM:=4;
end;

{ This is the message handling part of X-Talk. The message structure
  is accessed only by the routine PUT_MESSAGE, which enters the
  messages,  PRINT_MESSAGE, which outputs the messages to the screen
  and GET_MESSAGE, which gets the next message in the structure - if
  there is one.

  It is assumed that the declarations in TTY.MESS.D.TEXT are available
}

Procedure Print_Messages; { write all messages to screen             }
(*--------1------------*)
Var
  i:integer;
begin
  (* we should always be at the start of a new line *)
  for i:=1 to calls do
    if mess_type[i] <> empty
      then writeln(messages[i]);
end; (* print_messages *)

Procedure Init_Messages; { initialises the messages and sets message }
(*----------1---------*) { pointer to zero                           }
var
  i:integer;
begin
  last_got_message:=0;
  for i:=1 to calls do
    mess_type[i]:=empty;
  host_prompt:='';
end; (* zero_messages *)

Procedure Put_Message(mess:string; importance:messform);
(*----------------------1-----------------------------*)
var                      { enters a message into the structure       }
  room_for_it:boolean;
  i,j,lowest:integer;
begin
  room_for_it:=false;
  lowest:=1;
  j:=ord(importance);
  for i:=1 to calls do
    if ord(mess_type[i]) < j then begin
                                    room_for_it:=true;
                                    lowest:=i;
                                    j:=ord(mess_type[i]);
                                  end;
  if room_for_it then
    begin
      mess_type[lowest]:=importance;
      messages[lowest]:=mess;
    end else writeln(mess); (* if we can't save it write it *)
end; (* put_messages *)

Procedure Get_Message(Var Mess:string);
(*-------------1---------------------*)
begin                   { gets the next message in the structure, if any}
  mess:='';
  if last_got_message < calls (* there may be another message *) 
     then begin
            last_got_message:=succ(last_got_message);
            if mess_type[last_got_message] <> empty
               then mess:=messages[last_got_message]; (* there was! *)
          end;
end;

Function Prompt_Verify(Match:string):boolean;
(*------------------1----------------------*)
                {checks to see if match is last substring of host_prompt }
begin
 if match='' then prompt_verify:=true
 else
   if length(host_prompt)<length(Match) then prompt_verify:=false
   else prompt_verify:=
      (Pos(match,hostprompt)=(length(hostprompt)-length(match)+1));
end; (* prompt_verify *)

Procedure Decypher(Var stars:boolean);{makes sense of the contents of the sink}
(*----------------1-----------------*)
Var
 temp:string;
 i,j,st_length:integer;

 Procedure What_String;  { determines the type of message                }
 (*---------2--------*)
 begin
   (*$R-*)
   temp[0]:=chr(st_length);
   (*$R+*)
   if (i=sinkpointer) AND ((sink[i]<>chr(CR)) OR (sink[i]<>chr(LF)))
      (* prompt is taken as an incomplete line at the end *)
      then host_prompt:=temp
      else begin
             if temp[1]='*' then begin
                                   put_message(temp,star);
                                   stars:=true;
                                 end
                            else put_message(temp,host);
           end;
 end; (* What_String *)
 

begin (* decypher *)
 i:=0; (* a simple pointer along the length of the sink *)
 if sink[1]=chr(NUL) then i:=1; (* ignore leading NUL *)
 st_length:=0; stars:=false;
 (*$R-*)
 repeat (* get a string *)
   i:=i+1;
   if sink[i] in [chr(CR),chr(LF)] then
      begin
        if st_length <> 0 then
           begin
             what_string;
             st_length:=0;
           end;
     end else begin
                 if st_length < 80 then
                   st_length:=st_length+1; (* truncate to 80 characters *)
                 temp[st_length]:=sink[i];
               end;
 until i>=sink_pointer;
 if st_length <> 0 then what_string;
 (*$R+*)
 
end; (* decypher *)

Procedure Mop_Up(inch:char); { simply gathers everything from host into sink}
(*---------1--------------*)
var
  i,j:integer; ch:char;
  stars,timed_out:boolean;
begin {mop-up}
  timed_out:=false;
  sink_pointer:=1; (* collect everything up to next prompt *)
  (* have allowed 255 chars at present *)
  sink[sink_pointer]:=inch; (* could be a NUL *)
  
  j:=0;
  while not rempress AND (j<>TimeOutUnits) do
    begin {not r & t 1}
      i:=0;
      while not rempress AND (i<>maxint) do i:=(i+1-1+1)*1;
      j:=j+1;
    end; {not r & t 1}
  
  while rempress do
    begin {not rempress}
      remread(ch);
      if sink_pointer < sink_size then sink_pointer:=sink_pointer+1;
      sink[sink_pointer]:=chr(ord(ch) MOD 128); (* strip top bit *)
      i:=0;
      while not rempress and (i < waittime) do i:=i+1; (* short timeout *)
      if not rempress then
         if NOT(sink[sinkpointer] IN PromptSet) then
           begin {not in promptset}
             
             j:=0;
             while not rempress AND (j<>TimeOutUnits) do
               begin {not r & t 2}
                 i:=0;
                 while not rempress AND (i<>maxint) do i:=(i+1-1+1)*1;
                 j:=j+1;
               end; {not r & t 2}
           
           end; {not in promptset}
    end; (* while rempress *)
 
 decypher(stars); 
 (* look for host messages and EXIT from getfile *)
 
 if timed_out AND not stars then put_message('*  Timed out.',local);
 
end; (* Mop-Up *)

{-----------------------------------------------------------------------------}
                                 {end TTY.MESS}
{-----------------------------------------------------------------------------}


{$P}
{-----------------------------------------------------------------------------}
               {general window routines.   9-Mar-84 - TTY.WIND.G}
{-----------------------------------------------------------------------------}

function PartW:integer;
begin
  {Window Part Revision Number}
  PartW:=2;
end;

function WSCPrompt(Line:SCLongString;
                   XLeaveCursor,YLeaveCursor,
                   TopLeftX,TopLeftY:integer;
                   ReturnOnMatch:SCChSet;
                   NoCharBack:boolean;
                   BreakChar:char):char;
var ch:char;
begin
  writeln;
  SCClrLine(BottomLine);
  ch:=SCPrompt(Line,XLeaveCursor,YLeaveCursor,0,BottomLine,
               ReturnOnMatch,NoCharBack,BreakChar);
  writeln(ch);
  WSCPrompt:=ch;
end;

procedure WInit;
begin
  WAtX:=0; WAtY:=0; WCurX:=0; WCurY:=0; WDepth:=0; WWidth:=0;
end;

procedure WTerminate;
begin
end;

procedure WFrame(Atx,Aty,Width,Depth:integer;Header:string);
begin
  WAtX:=AtX+1; WAtY:=AtY+1; WWidth:=Width; WDepth:=Depth;
end;

procedure WUnFrame(RemoveDisplay:boolean);
begin
  WAtX:=0; WAtY:=0; WCurX:=0; WCurY:=0; WDepth:=0; WWidth:=0;
end;

procedure WClrScreen;
begin
  SCClrScreen;
  GotoXY(0,WAtY);
end;

{KEYRDLN ROUTINE..USE INSTEAD OF READLN FROM KEYBOARD..}
PROCEDURE KEYRDLN(VAR STR:long_string );
VAR I:INTEGER;
    CH:CHAR;
BEGIN
   {$R-}
   str[0]:=chr(255);
   {$R+}
   for i:=1 to 255 do str[i]:=space;
   {OVERLAY ONTO A BED OF SPACES}
   I:=0;
   KEYREAD(CH,FALSE,FALSE); {READ..NO ECHO}
   WHILE NOT (CH=CHR(CR)) DO 
   BEGIN { while }
      IF (CH=CHR(DEL)) OR (CH=CHR(BS)) THEN BEGIN
         IF I<>0 THEN BEGIN
            I:=I-1;
            WRITE(CHR(BS),' ',CHR(BS));
         END;
      END ELSE IF CH<' ' THEN WRITE(CHR(BEL)) ELSE BEGIN
         WRITE(CH); {ECHO}
         I:=I+1;
         STR[I]:=CH;
      END;
      KEYREAD(CH,FALSE,FALSE);
   END; { while }
   WRITELN;
   {$R-}
  STR[0]:=CHR(I); {SET LENGTH}
   {$R+} { **RANGE CHECK BACK ON}
END;

FUNCTION KEYRDVAL(VAR VAL:INTEGER):BOOLEAN;
   {READS LINE AND CONVERTS TO NUMBER}
   {RESULT TRUE IF NUMBER OK}
   {NUMBER ASSUMED +VE FOR NOW}
VAR STR:long_string;
    I,J,K:INTEGER;
    SUCC:BOOLEAN;
BEGIN
   KEYRDLN(STR);
   K:=0;
   SUCC:=(LENGTH(STR)<>0); {TRUE IF STRING NOT NULL}
   IF SUCC THEN FOR I:=1 TO LENGTH(STR) DO BEGIN
      J:=ORD(STR[I])-ORD('0');
      IF (J<0) OR (J>9) THEN SUCC:=FALSE;
      IF SUCC THEN K:=K*10+J;
   END;
   IF SUCC THEN VAL:=K;
   KEYRDVAL:=SUCC;
END;

PROCEDURE PUTTXT;
   {DEFINED FORWARD..PARAMS S:STRING)  }
BEGIN
   WRITE(S);
END;

PROCEDURE PUTCH(CH:CHAR);
BEGIN
   WRITE(CH);
END;

PROCEDURE PUTINT(V,S:INTEGER);
BEGIN
   WRITE(V:S);
END;

PROCEDURE PUTLN;
   {DEFINED FORWARD}
BEGIN
  WRITELN;
END;

PROCEDURE GETLN;
{ DECLARED FORWARD..PARAMS(VAR S:long_string ); }
BEGIN
   KEYRDLN(S);
END;

PROCEDURE GETCH;
   { DEFINED FORWARD..PARAMS(VAR CH:CHAR; PROMPTING,ECHO:BOOLEAN); }
BEGIN
   KEYREAD(CH,PROMPTING,ECHO);
END;

{-----------------------------------------------------------------------------}
                                {end TTY.WIND.G}
{-----------------------------------------------------------------------------}


{$P}
{-----------------------------------------------------------------------------}
                              { TTY.PT2 }
{-----------------------------------------------------------------------------}

{ Modified
   1-Feb-83                                             }
   
FUNCTION PART2:INTEGER;
(*--------1----------*)
BEGIN
  (*PART 2 RELEASE VERSION*)
  PART2:=7;
END;

Procedure UpperCase(Var s:string);
var i:integer;
begin
  if length(s)>0 then
    begin
      for i:=1 to length(s) do
        begin
          if (s[i]>='a') and (s[i]<='z') then s[i]:=chr(ord(s[i])-32);
        end;
    end;
end;

FUNCTION SURE(STR:STRING):BOOLEAN;
VAR CH:CHAR;
BEGIN
  ch:=WSCPrompt(CONCAT(str,': Y(es, N(o '), -1,0, 60,8,
                ['Y','N'],false,',');
  SURE:=(CH='Y');
END;
PROCEDURE REMSINK(ECHO:BOOLEAN);
(* a sink for any characters received from remote *)
VAR Waits:INTEGER;
    CH:CHAR;
BEGIN
  Waits:=0;
  WHILE ((Waits<WAITTIME) AND NOT(REMPRESS)) DO Waits:=Waits+1;
  WHILE REMPRESS DO
    BEGIN
      if Echo then RemFlush
      else RemRead(Ch); {and discard}
      Waits:=0;
      WHILE ((Waits<WAITTIME) AND NOT(REMPRESS)) DO Waits:=Waits+1;
    END;
END;

PROCEDURE TRANSMIT(STR:STRING;ECHO:BOOLEAN);
{not to be used to send CR when followed by MopUp}
{as it echoes all characters following CR before exit}
VAR CH:CHAR;
    I,J,L,waits:INTEGER;
BEGIN
  L:=LENGTH(STR);
  FOR I:=1 TO L DO
    BEGIN
      waits:=0; {out here so not time critical}
      CH:=STR[I];
      REMWRITE(CH);
      IF HALFDUPLEX THEN
         BEGIN
           IF ECHO THEN WRITE(CH);
           while RemPress do RemFlush;
         END
      ELSE 
        BEGIN
          WHILE ((waits<WAITTIME) AND NOT(REMPRESS)) DO waits:=waits+1;
             while RemPress do
              BEGIN
                if Echo then RemFlush
                else RemRead(Ch); {and discard}
              END;
        END;
    END;
 REMSINK(ECHO); {cathes any extra chars returned late}
END;

procedure CRTransmit(Echo:boolean);
{transmit CR only - exit quickly to allow for MopUp}
begin
  if Echo then Writeln;
  RemWrite(chr(CR));
end;

Procedure Int_to_string(X,S:Integer; Var int_string:short_string);
(*-------------------------------1------------------------------*)
(* turn integer X into string of length S - if S=0 then no leading spaces *)
VAR I,J:INTEGER;
    digit:string[1];
BEGIN
   Int_String:='';
   IF X<0 THEN BEGIN
      X:=-X;
      IF X<0 THEN BEGIN
         int_string:='-32768';
         EXIT(PUTINT);
      END;
      int_string:=concat(int_string,'-');
      S:=S-1;
   END;
   I:=10000;
   WHILE (X DIV I=0) AND (I<>1) DO BEGIN
      S:=S+1;
      I:=I DIV 10;
   END;
   S:=S-5;
   WHILE S>0 DO BEGIN
      int_string:=concat(int_string,' ');
      S:=S-1;
   END;
  (*$R-*)
   digit[0]:=chr(1);
   REPEAT
      digit[1]:=CHR(ORD('0')+X DIV I);
      int_string:=concat(int_string,digit);
      X:=X-(X DIV I)*I;
      I:=I DIV 10;
   UNTIL I=0;
   (*$R+*)
END;

PROCEDURE GIVEREASON(REASON:INTEGER; VAR ST:STRING);
var NumSt:ShortString;
BEGIN
  IF (REASON>0) AND (REASON<=18) THEN
    BEGIN
      CASE REASON OF
         1: ST:='Bad Block, Parity error (CRC).';
         2: ST:='Bad Unit Number.';
         3: ST:='Illegal I/O Request.';
         4: ST:='Data-com timeout.';
         5: ST:='Volume is no longer on-line.';
         6: ST:='File is no longer in directory.';
         7: ST:='Bad file name.';
         8: ST:='No room, insufficient space on volume.';
         9: ST:='No such volume on line.';
        10: ST:='No such file on volume.';
        11: ST:='Duplicate directory entry.';
        12: ST:='Not closed, attempt to open an open file.';
        13: ST:='Not open, attempt to access a closed file.';
        14: ST:='Bad format, error in reading real or integer.';
        15: ST:='Ring buffer overflow.';
        16: ST:='Volume is write-protected.';
        17: ST:='Illegal Block Number.';
        18: ST:='Illegal Buffer.';
      END (*CASE*)
    END
  ELSE IF REASON<>0 THEN
    begin
      IntToString(Reason,0,NumST);
      ST:=CONCAT('I/O error ',NumST);
    end;
END;

PROCEDURE SETALT;
VAR CH:CHAR;
BEGIN
   ch:=WSCPrompt('Protocol: T(ext, B(inary ',-1,0, 50, 9,
                 ['T','B'], false,',');
   ALTFILE:=(ch='B');
END;

Procedure TTYInfo;
{----------------}
var ch:char;
begin
  ch:=WSCPrompt('TTY Info: F(ull mess, U(nits, B(reak Char, D(uplex, Q(uit ',
                -1,0, 50,9, ['F','U','B','D','Q'], false,',');
  case ch of
    'B': begin
           WFrame(34,11, 39,1, '');
           PutTxt('Give Break Char (<CR> for no change) ');
           GetCh(BreakChar,false,false);
           if Breakchar > ' ' then writeln(BreakChar)
                              else writeln;
           WUnFrame(true);
         end;
    'D': BEGIN
           ch:=WSCPrompt('Duplex: F(ull, H(alf ', -1,0, 50, 9,
                         ['H','F'], false,',');
           HALFDUPLEX:=(CH='H')
         END;
    'F': DEBUG:=Sure('Full messages ');
    'U': BEGIN
           ch:=WSCPrompt('Wait Units: I(ncrease, D(ecrease ', -1,0, 50,9,
                         ['I','D'], false, ',');
           if ch = 'I' then WaitTime:=WaitTime + 500
                       else WaitTime:=WaitTIme - 500;
           IF WAITTIME<=0 THEN WAITTIME:=1;
           TimeOutUnits:=ABS(WaitTime DIV 512) + 1;
         END;
    'Q': { no action };
  end; { case }
end;

PROCEDURE CONFIGURE;
VAR CH,ch1:CHAR;
    FINISH:BOOLEAN;
BEGIN
  FINISH:=FALSE;
  REPEAT
    ch:=WSCPrompt(CONCAT('Configure: P(rotocol,M(ask,T(TY Info',
                         ',H(ost info,S(td host,B(aud,Q(uit '),
                  -1,0, 45,6, ['B','H','M','P','S','T','Q'],
                  false,',');
    CASE CH OF
      'B': begin end;
      'H': BEGIN
           END;
      'M': BEGIN
             ch:=WSCPrompt('Mask: 8(bit, 7(bit ', -1,0, 50,  9,
             ['7','8'], false, ',');
             IF CH='7' THEN CHINMOD:=128
                       ELSE CHINMOD:=256;
           END;
      'P': SETALT;
      'S': begin
             ch1:=WSCPrompt('Set Std Host: P(ad, T(cp ',-1,0,50,9,['P','T'],
             false,',');
             if ch1='T' then
              begin
                Transmit(Settcp, true); remwrite(chr(CR));
              end else begin
                Transmit (setpad,  true);remwrite(chr(CR));remwrite(chr(CR));
              end;
                
             initmessages; MopUp(chr(NUL)); printmessages; write(HostPrompt);
             CursorLost:=false;
             Finish:=true; { takes us straight out of configure }
           end;
      'T': TTYInfo;
      'Q': FINISH:=TRUE;
    END (*CASE*);
  UNTIL FINISH;
END;

PROCEDURE NAMECHECK(Var Name:string; Var ABORT:boolean;
                                              Ask, textfile:boolean);
(*------------------------------1----------------------------------*)
(*CHECK LOCAL FILE NAME AND PRINT MESSAGES - CAN SET ABORT *)
(*PUT IN SEPARATE PROCEDURE TO GET MORE CODE SPACE IN MAIN PROCEDURE BODY*)
VAR CH:CHAR;
    I:INTEGER;
    DFile:file;
    St:String;
    BadName:boolean;
BEGIN
  ABORT:=false;
  (*REMOVE SPACES*)
  WHILE POS(' ',name)<>0 DO DELETE(name,POS(' ',name),1);
  IF LENGTH(name)=0 THEN 
     begin (* zero length name *)
       ABORT:=true;
       put_message('*  Null file name.',local);
     end
  ELSE
    BEGIN (* non null name *)
      for i:=1 TO LENGTH(name) do (* convert to UpperCase *)
          if ('a'<=name[i]) AND (name[i]<='z') then
             name[I]:=CHR((ORD(CH)-ORD('a'))+ORD('A'));
      IF POS(':',name)=LENGTH(name) THEN
        BEGIN (* : at end *)
            (*DEVICE NAME ENDS IN : - ONLY ALLOW PRINTER: *)
            (*AS CONSOLE: AND REMOUT: USED BY X-TALK      *)
            if name<>'PRINTER:' then
              BEGIN
                put_message(
                      '*  Only PRINTER: allowed for device output.',local);
                ABORT:=true;
              END;
        END (* : at end *)
        ELSE
          BEGIN (* open *)
            if textfile and (name<>'PRINTER:') then
               if POS('.TEXT',name)=0 then name:=concat(name,'.TEXT');
            if POS(':',name) <> 0 then
              begin
                BadName:= (length(name)-POS(':',name) > 15) OR 
                          (POS(':',name) > 8);
              end
                else
            if POS('*',name) = 1 then
              begin
                BadName:=(length(name) > 16);
              end
                else
            BadName:=length(name) > 15;
            if BadName then
              begin
                putmessage(CONCAT('* Illegal file name ',name,'.'),local);
                ABORT:=true;
              end;
            if not ABORT then 
             begin (* name seems OK *)
               (*$I-*)
               RESET(DFILE,name);
               IF IORESULT=0 THEN 
                 BEGIN (* 0 *)
                    if ask then begin (* ask *)
                      ch:=WSCPrompt(CONCAT('Destroy ',name,': Y(es, N(o '),
                                    -1,0, 20,15, ['Y','N'],false, ',');
                      IF CH='Y' THEN CLOSE(DFILE,PURGE) ELSE 
                      BEGIN (* 1 *)
                         CLOSE(DFILE);
                         ABORT:=true;
                      END; (* 1 *)
                  end (* ask *) else begin (* error *)
                                        ABORT:=true;
                                        put_message
                                          (CONCAT(
                                         '*  File ',name,' already exists.'),
                                        local);
                                      end; (* error *)
                 END (* 0 *)  ELSE 
                 IF IORESULT<>10 THEN 
                   BEGIN (* 2 *)
                      Givereason(ioresult,st);
                      put_message(st,local);
                      ABORT:=true;
                   END;  (* 2 *)
             end; (* name seems... *)
            (*$I+*)
          end; (* open *)
        END; (* non null name *)
END; (* namechecks *)

{-----------------------------------------------------------------------------}
                                 {end TTY.PT2}
{-----------------------------------------------------------------------------}



PROCEDURE SENDCTRL;
VAR CH:CHAR;
BEGIN
  WFrame(35,15, 38, 1, '');
  PutTxt('Type control letter (<CR> for none):');
  GetCh(ch,true,true);
  if ch in ['A'..'Z'] then REMWRITE(CHR((ORD(CH)-ORD('A'))+1));
  WUnFrame(true);
  CursorLost:=false; { needed to suppress the remwrite(chr(CR)) }
END;

Function Names_Paired(str,str2:long_string):Boolean;
{----------------------------1-------------------}
{ used by both putfile & getfile            }
var
  i,l_comma,r_comma:integer;
begin
  if (length(str)=0) OR (length(str2)=0) then names_paired:=false
                                         else
  if (str[1]=BreakChar) OR (str2[1]=BreakChar) OR (str[length(str)]=BreakChar)
     OR (str2[length(str2)]=BreakChar)
     then names_paired:=false
     else
       begin
         l_comma:=0; r_comma:=0;
         for i:=1 to length(str) do
           if str[i]=BreakChar then l_comma:=succ(l_comma);
         for i:=1 to length(str2) do
           if str2[i]=BreakChar then r_comma:=succ(r_comma);
           
         names_paired:=l_comma=r_comma;
         if not (lcomma=rcomma) then 
             put_message('*  File names not paired.',local);
       end;
end; { Names_Paired }

Procedure Next_Name(Var list:long_string; var name:string);
{---------------------------1---------------------------}
{ used by both putfile & getfile       }
var BreakString:string[1]; i:integer;
begin
  BreakString:=' '; {$R-} BreakString[1]:=BreakChar; {$R+}
  name:='';
  if (POS(BreakString,list)=0) AND (list<>'') then
     begin { last name only }
       name:=list;
       list:='';
     end                              else
     begin
       name:=COPY(list, 1, POS(BreakString,list)-1);
       DELETE(list, 1, POS(BreakString,list)); { remove the name }
     end;
     (*{ make sure the name is in upper case }
     for i:=1 to length(name) do
       if ('a'<=name[i]) AND (name[i]<='z') then
          name[i]:=chr(ord(name[i]) - ord('a') + ord('A')); *)
end; { next_name }


{$P}
{-----------------------------------------------------------------------------}
                             {7-Aug-84 - TTY.DOGET}
{-----------------------------------------------------------------------------}

{ modified 1-Feb-83
  modified 13-Aug-84  for new coding for PAD's by G. Wilkie 
  modified 29-Nov-84  for new coding for micro-pad-network-pad-micro transfers}

Function PartDG:integer;
begin
  PartDG:=4;
end;

Procedure DoGetFile(remotename,localname:string; textfile,debug:boolean;
                                             var user_interrupt:boolean );
(*----------------------------------2-----------------------------------*)
const
  FILLLEVEL=1024; (*ALLOW 256 CHARACTERS OF OVERRUN BY HOST AFTER XOFF*)
  buffer_size=1281;
  printer=6; (* in case file is to go to printer *)
var
  ch:char;
  DFILE:file;  (* using BLOCKREAD/WRITE *)
  Res,DOTCNT,CHARS,CHKSM,I,J,XOFCNT,PTR:INTEGER;
  leading_spaces,OVERRUN,STARTED,FINISHED,ESCAPE:BOOLEAN;
  ABORT,printer_chosen:boolean;
  cr_dle_32:packed array[1..3] of char; (* the start of line sequence *)
  buffer:PACKED ARRAY[1..buffer_size] OF CHAR;
  page,len,split_lines,last_CR_pos:integer;
  CHKSMOK: (CORRECT,WRONG,ABSENT);
  st:string;
  st_chars,st_chksm:short_string;
  

  PROCEDURE GETCHKSM;
  (*------3--------*)
  VAR CH:CHAR;      I:INTEGER;
      collect:packed array[1..8] of char;
      EXTRA:RECORD CASE BOOLEAN OF
         TRUE: (DAT:PACKED ARRAY[1..8] OF 0..15);
         FALSE:(CHKSM,CHARS:INTEGER);
       END;
         BEGIN
    (* a line feed before 8 characters have been received
       implies no checksum is present*)
    if xofcnt>0 then remwrite(chr(XON)); (* may be in xoff state *)
    i:=8;
    repeat
       remread(ch);
       collect[i]:=chr(ord(ch) MOD chinmod);
       i:=i-1;
    until (i=0) OR (ch=chr(LF));
    extra.chksm:=chksm;
    extra.chars:=chars;
    if ch=chr(LF) then chksmok:=absent else
        if i <> 0 then chksmok:=wrong
                  else chksmok:=correct;
    while ch <> chr(LF) do
      begin (* lose some characters *)
        remread(ch);
        ch:=chr(ord(ch) MOD chinmod);
      end;
    if chksmok=correct then 
      begin
         i:=8;
         repeat
           if (extra.dat[i]+ord('A')) <> ord(collect[i]) then chksmok:=wrong;
         i:=i-1;
         until (i=0) OR (chksmok=wrong);
      end;
  END;
    
    
PROCEDURE GETCHAR;
  (*------3------*)
VAR I:INTEGER;
    CH:CHAR;
  
  BEGIN (* getchar *)
     REMREAD(CH);
     CH:=CHR(ORD(CH) MOD CHINMOD); (*MASK AS DIRECTED - 128 OR 256*)
     if leading_spaces then
        begin (* leading spaces *)
          if ch=' ' then begin (* ' ' *)
                           buffer[ptr]:=succ(buffer[ptr]);
                           chars:=(chars +  1) MOD 16384;
                           chksm:=(chksm + ord(space)) MOD 16384;
                         end (* ' ' *)
                      else
                         begin (* ordinary character *)
                           leading_spaces:=false;
                           if ch='*' then escape:=true
                                     else
                              if started then
                                 begin (* collect *)
                                   chars:=(chars+1) MOD 16384;
                                   chksm:=(chksm+ord(ch)) MOD 16384;
                                   ptr:=ptr+1;
                                   if ch=chr(LF) then 
                                     begin (* a LF *)
                                       if textfile then 
                                         begin
                                           leading_spaces:=true;
                                           moveleft(CR_dle_32,buffer[ptr],
                                                    3);
                                           ptr:=ptr+2;
                                         end  else buffer[ptr]:=ch;
                                     end (* a LF *) else
                                   buffer[ptr]:=ch;
                                 end; (* collect *)
                         end; (* ordinary character *)
       end (* leading spaces *) else
    if escape then
       begin (* escape *)
         escape:=false;
         if ch='C' then begin
                          if started then
                            begin
                              ptr:=ptr+1;
                              buffer[ptr]:='*';
                              chars:=(chars+1) MOD 16384; 
                              chksm:=(chksm+ord('*')) MOD 16384;
                            end
                        end else
         if ch='1' then begin
                          if started then
                            begin
                              ptr:=ptr+1;
                              buffer[ptr]:=chr(xon);
                              chars:=(chars+1) MOD 16384;
                              chksm:=(chksm+xon) MOD 16384;
                            end
                        end else
         if ch='3' then begin
                          if started then
                            begin
                              ptr:=ptr+1;
                              buffer[ptr]:=chr(xoff);
                              chars:=(chars+1) MOD 16384;
                              chksm:=(chksm+xoff) MOD 16384;
                            end
                        end else
         if ch=chr(msb1) then begin
                          if started then
                            begin
                              ptr:=ptr+1;
                              buffer[ptr]:=chr(xonmsb);
                              chars:=(chars+1) MOD 16384;
                              chksm:=(chksm+xonmsb) MOD 16384;
                            end
                        end else
         if ch=chr(msb3) then begin
                          if started then
                            begin
                              ptr:=ptr+1;
                              buffer[ptr]:=chr(xoffmsb);
                              chars:=(chars+1) MOD 16384;
                              chksm:=(chksm+xoffmsb) MOD 16384;
                            end
                        end else
         if ch='B' then started:=true
                   else
         if ch='E' then begin
                          if started then
                            begin (* started *)
                              finished:=true;
                              getchksm;
                              if textfile then (* add an extra CR for UCSD *)
                                 begin (* textfile *)
                                   ptr:=ptr+1;
                                   buffer[ptr]:=chr(CR);
                                 end (* textfile *) else
                                 (* odd block for binary ? *)
                                   if ptr<=512 then page:=1;
                            end (* started *)
                        end
                   else begin
                          (* message in sink *)
                          Mop_Up(ch); 
                          (*$I-*) close(dfile); (*$I+*)
                          exit(dogetfile);
                        end;
        end (* escape *) else
                           if ch='*' then escape:=true
                                     else
                              if started then
                                 begin (* collect *)
                                   chars:=(chars+1) MOD 16384;
                                   chksm:=(chksm+ord(ch)) MOD 16384;
                                   ptr:=ptr+1;
                                   if ch=chr(LF) then 
                                     begin (* a LF *)
                                       if textfile then 
                                         begin
                                           leading_spaces:=true;
                                           moveleft(CR_dle_32,buffer[ptr],
                                                    3);
                                           ptr:=ptr+2;
                                         end  else buffer[ptr]:=ch;
                                     end (* a LF *) else
                                   buffer[ptr]:=ch;
                                 end; (* collect *)
  END;(* getchar *)
  
  
  Procedure Prepare;
  (*-------3------*)
  var Res:Integer;
  begin
    init_messages; (* do this here *)
    ABORT:=false; started:=false; finished:=false; escape:=false;
    user_interrupt:=false; split_lines:=0;
    if textfile then  (* textfile *) leading_spaces:=true
                else  (* binary   *) leading_spaces:=false;
    page:=2; chars:=0; chksm:=0; 
    printer_chosen:=false; overrun:=false;
    cr_dle_32[1]:=chr(CR); cr_dle_32[2]:=chr(DLE); 
    cr_dle_32[3]:=space; (* the special end of line sequence *)
    namecheck(localname,ABORT,false,textfile);
    if ABORT then exit(dogetfile);
    (*$I-*) (* try open the file *)
    if localname = 'PRINTER:' then printer_chosen:=true
                           else 
       begin (* not the Printer: *)
         rewrite(dfile,localname);
         if ioresult<>0 then
           begin (* can't open file *)
             Res:=ioresult;
             close(dfile);
             givereason(Res,st);
             put_message(st,local);
             exit(dogetfile);
           end (* can't... *) 
       end; (* not the .... *)
    (*$I+*)
  end; (* prepare *)
  
  Procedure Tidy_Up;
  (*-------3------*)
  var Res:integer;
  begin
    if ABORT and (xofcnt<>0) then remwrite (chr(XON));
    If ABORT then transmit(escape_sequence,false);
    (* Note that an XON may be needed first if XOFFed - not needed for EMAS *)
    (*$I-*)
    CLOSE(DFILE,LOCK);
    IF IORESULT<>0 THEN BEGIN
                          Res:=ioresult;
                          give_reason(Res,st);
                          put_message(st,local);
                        END;
    (*$I+*)
    remsink(false); (* a short timeout to lose prompt - if there ! *)
    remwrite(chr(CR));
    mop_up(chr(NUL));
    writeln; (* do this here to cater for part lines *)
    if chksmok=WRONG then put_message('*  Checksum faulty.',local);
    if overrun then 
      put_message('*  Overrun occurred - increase UNITS.',local)
               else 
      begin (* not overrun *)
        if chksmok=absent then put_message('*  No checksum.',local);
        if DEBUG then
          begin (* debug *)
            int_to_string(chars,6,st_chars);int_to_string(chksm,6,st_chksm);
            put_message(concat('*       ',st_chars,
                                 ' characters received.  Checksum:',
                                 st_chksm,'.'),debugging);
          end; (* debug *)
      end; (* not overrun *)
  end; (* tidy-up *)
  
  Procedure Interrupted;
  (*----------3-------*)
  begin
    keyread(ch,false,false);
    if ch=chr(ESC) then 
       begin
         user_interrupt:=sure('Curtail?');
         ABORT:=ABORT or user_interrupt;
       end;
  end;
        (* ********* *)
begin (* dogetfile *)
      (* ********* *)
  prepare; (* does all the initailising & checking prior to transfer *)
     
  fillchar(buffer,buffer_size,0); (* null fill the buffers *)
  ptr:=0; dotcnt:=0;
  if textfile and not(printer_chosen) then
    begin
     (*$I-*)
    j:=blockwrite(dfile,buffer[1],2);
     (*$I+*)
       (* write 2 blocks of NULs as textfile header.
        Note no RELBLOCK parameter as blocks will
        be written sequentially throughout        *)
     if ioresult <> 0 then
       begin (* something wrong *)
         Res:=ioresult;
         ABORT:=true;
         givereason(Res,st);
         put_message(st,local);
       end;
    end;
          
  if not ABORT then
    begin (* not ABORT *)
      transmit('GIVEFILE',false);
      remwrite(chr(CR));
      Mop_Up(chr(NUL));
      if prompt_verify('e:') then            (* looking for Givefile: *)
         init_messages
      else
        begin
          put_message('*  Incorrect prompt from host.',local);
          close(dfile);
          exit(dogetfile);
        end;
      transmit(remotename,false);
      remwrite(chr(CR));
      
      repeat (* until finished or ABORT *)
        xofcnt:=0; (* go into Getchar in XONed state *)
        
        repeat getchar until finished or (ptr > fill_level);
        
        if not finished then
          begin
            remwrite(chr(xoff));
            xofcnt:=1;
            repeat
              j:=0;
              while (j<waittime) and not rempress do j:=j+1;
              if rempress then getchar;
            until (j=waittime); (* waitunits of time *)
          end;
        write('..');
        dotcnt:=dotcnt+2;
        if dotcnt>=40 then begin
                            dotcnt:=0; (* roughly a buffer full *)
                            writeln;
                          end;
        (* do we have more than a buffer full *)
        if not textfile then
          begin (* binary case *)
            if ptr > fill_level then
               begin
                 last_CR_pos:=fill_level; ptr:=ptr-fill_level;
                 len:=ptr;
               end  else
               begin
                 last_CR_pos:=ptr; ptr:=0;
                 fillchar(buffer[last_CR_pos+1],1024-last_CR_pos,0);
               end;
          end (* binary ... *)
        else
          begin (* text *)
            if ptr>fill_level then (* limit is 1024 *)
              begin (* find last LF *)
                last_CR_pos:=ptr;
                repeat last_CR_pos:=last_CR_pos-1 
                until ((buffer[last_CR_pos]=chr(CR)) AND
                       (last_CR_pos < fill_level))
                      OR (last_CR_pos=1);
                (* < fill_level as last char on page must be NUL *)
                if buffer[last_CR_pos] <> chr(CR) then
                  begin
                    ABORT:=true;
                    put_message('*  Line longer than 1024 chars.',local);
                  end else
                  begin
                    len:=ptr-last_CR_pos;
                    if len > 256 then
                      begin
                        split_lines:=split_lines+1;
                        len:=ptr-1023; (* -1024+1 *)
                        moveright(buffer[1024],buffer[1025],len);
                        buffer[1024]:=chr(CR);
                        last_CR_pos:=1024;
                      end else
                      begin
                        moveright(buffer[last_CR_pos+1],buffer[1025],len);
                        if last_CR_pos <> 1024 then
                           fillchar(buffer[last_CR_pos+1],1024-last_CR_pos,0);
                      end;
                    (* now update the pointer *)
                    ptr:=len;
                  end;
              end (* last LF *) else
              begin (* less then 1024 *)
                fillchar(buffer[ptr+1],1024-ptr,0);
                last_CR_pos:=ptr; ptr:=0;
              end; (* may be finished *)
        end; (* text *)
        
        (* Do no more if ABORT *)
        if not ABORT then
          begin
            (* now write it away *)
            if printer_chosen then unitwrite(printer,buffer,last_CR_pos)
            else
              begin
                (*$I-*)
                j:=blockwrite(dfile,buffer[1],page);
                (*$I+*)
                if (j<>page) OR (ioresult<>0) then
                  begin   (* no RELBLOCK parameter *)
                    ABORT:=true;
                    put_message('*  Unable to write page.',local);
                  end;
              end;
              
            if ptr <> 0 then moveleft(buffer[1025],buffer[1],len);
            
            if finished AND (ptr<>0) then
              begin (* finished but some left yet *)
                fillchar(buffer[len+1],1024-len,0);
                if printer_chosen then unitwrite(printer,buffer,last_CR_pos)
                else
                  begin
                    (*$I-*)
                    j:=blockwrite(dfile,buffer[1],page);
                    (*$I+*) 
                    if (j<>page) OR (ioresult <> 0) then
                      begin   (* no RELBLOCK parameter *)
                        ABORT:=true;
                        put_message('*  Unable to write page.',local);
                      end;
                  end;
              end; (* finished but...*)
          
          while keypress and not ABORT do
            interrupted;
          
          if not ABORT then
             begin (* not ABORT *)
               if xofcnt<>0 then remwrite(chr(xon));
               if not finished then
                  begin (* not finished *)
                    if rempress then 
                       begin (* rempress *)
                         overrun:=true;
                         writeln;
                         writeln('Overrun, characters from remote lost!');
                         (* give message in case of premature exit - *E lost *)
                         remwrite(chr(CR));
                         (* CR to host in case *E lost *)
                         (* ** of host will cause exit in GETCHAR *)
                       end; (* rempress *)
                  end; (* not finished *)
             end; (* not ABORT *)
        end; (* previous not ABORT *)
      until finished or ABORT;
    end; (* not ABORT *)
  tidy_up;
end; (* dogetfile *)

{------------------------------------------------------------------------------}
                                {END TTY.DOGET}
{------------------------------------------------------------------------------}


{$P}
{-----------------------------------------------------------------------------}
                            {17-Aug-84  -  TTY.GET }
{-----------------------------------------------------------------------------}

{ last modified 17-Aug-84  uppercase and lower case filenames sent to host
  previous 1-Feb-83  }

Function PartG:integer;
begin
  PartG:=2;
end;

(*  CHECKSUM COMPUTATION
    8 letters made up as follows:-
    a) keep a sum of ordinal values of characters in the transfer
       rounded MOD 16384 in a 16 bit integer.
    b) keep a count of number of characters in the transfer rounded
       MOD 16384 in a 16 bit integer.
    c) for each nibble (4 bits) in the 16 bit quantities kept above
       (starting with the most significant nibble of the ordinal values
       sum and ending with the least significant nibble of the character
       count) add the ordinal code for the letter 'A' and send the
       resulting code as a character.  This means that 8 letters between
       'A' and 'O' are sent.
*)

PROCEDURE GETFILE;
(*------1-------*)
CONST FILLLEVEL=1024; (*ALLOW 256 CHARACTERS OF OVERRUN BY HOST AFTER XOFF*)
      buffer_size=1281;
      printer=6; (* in case file is to go to printer *)
VAR STR,STR2:long_string;
    DFILE:file;  (* using BLOCKREAD/WRITE *)
    r_name,l_name:string; CH:CHAR;
    user_interrupt,ABORT:BOOLEAN;
    st:string;
    

   Function GET_Checks(list:long_string):Boolean;
   (*--------------------2---------------------*)
   Var
     ABORT:boolean;
     name:string; i:integer;
     temp_list:long_string;
   begin
     temp_list:=list;
     get_checks:=true; ABORT:=false;
     while (temp_list<>'') AND not ABORT do
       begin
         next_name(temp_list,name);
         namecheck(name,ABORT,true,textfile);
       end;
     get_checks:=ABORT;
   end; (* get_checks *)
   

BEGIN (* GETFILE *)

  WRITELN;
  WRITE('--- Get file ');
  if textfile then begin
                     write('(Text, ');
                     if chinmod=128 then write('7') else write('8');
                     writeln(' bit codes) ---')
                   end
              else writeln('(Binary) ---');
  WRITELN;
  WRITE('Give remote file(s):');
  KEYRDLN(STR);
  WRITE('Give local  file(s):');
  KEYRDLN(STR2);
  UPPERCASE (str2);
  init_messages; (* initialise messages for name checking *)
  if names_paired(str,str2) then
     begin
       if not get_checks(str2) then (* check LOCAL names - true if ABORT *)
         begin (* local checks OK *)
           writeln;
           while str2<>'' do
             begin (* tranfers *)
               ABORT:=false;
               next_name(str,r_name); (* remote *)
               next_name(str2,l_name);(* local  *)
               if textfile AND (POS(':',l_name) <> length(l_name))
                 then if (POS('.TEXT',l_name)=0)
                        then l_name:=CONCAT(l_name,'.TEXT');
               writeln(r_name,' --> ',l_name);
               DoGetFile(r_name, l_name, textfile,debug,user_interrupt);
               if not user_interrupt then
                                       begin
                                         print_messages;
                                         if str2 <> '' then writeln;
                                       end
                                     else writeln;
             end  (* transfers *)    
         end  (* local... *)        else print_messages;
     end
       else printmessages;
  writeln; writeln('--- Get file finished ---',chr(BEL));
end; (* getfile *)

{------------------------------------------------------------------------------}
                                 {end TTY.GET}
{------------------------------------------------------------------------------}


{$P}
{-----------------------------------------------------------------------------}
                      {7-Aug-84  -  TTY.DOPUT for PAD's }
{-----------------------------------------------------------------------------}

{ modified 1-Feb-83
  modified 7-Aug-84 by G.Wilkie for coding for PAD's 
  modified 17-Dec-84 by G.Wilkie for abandoning all transfers if no
                                Take file: prompt  and fix flow control 
  modified 20-Dec-84 by G.Wilkie  for extra "if rempress then remcheck" before
  disk read for apple and also extra calls of mop_up at termination phase }

Function PartDP:integer;
begin
  PartDP:=7;
end;

Procedure DoPutFile(localname,remotename:string; textfile,debug:boolean;
                                           var user_interrupt,abortall:boolean);
(*----------------------------------1------------------------------------*)
CONST TERM=63; (* TERMINATOR=? *)
var
  ch:char;
  ABORT:boolean;
  pad:boolean;  { whether communicating with a PAD or TCP }
  block:packed array[1..1024] of char;
  filler:integer; (* this is a 2 byte overflow for block *)
  Res,page,blanks,relblock:integer;
  fill_level,j,chord:integer; 
  DFILE:file; (* untyped for a reason *)
  chars,chksm,dotcnt,totxof,maxxof,xofocc:integer;
  st:string;
  st_chars,st_chksm,st_totxof,st_maxxof,st_xofocc:short_string;
 
  PROCEDURE PUTCHKSM;
  (*-------2-------*)
  VAR I:INTEGER;
      EXTRA:RECORD CASE BOOLEAN OF
         TRUE: (DAT:PACKED ARRAY[0..7] OF 0..15);
         FALSE:(CHKSM,CHARS:INTEGER);
      END;
  BEGIN
     EXTRA.CHKSM:=CHKSM;
     EXTRA.CHARS:=CHARS;
     FOR I:=7 DOWNTO 0 DO REMWRITE(CHR(ORD('A')+EXTRA.DAT[I] MOD chinmod));
     remsink(false); (* lose the echo *)
     REMWRITE(CHR(CR));
  END;
  
  
  PROCEDURE REMCHECK;
  (*------2--------*)
  VAR i,XOFCNT:INTEGER;
      CH:CHAR;  
      
BEGIN
    XOFCNT:=0;
    REPEAT
        REMREAD(CH);
        CH:=CHR(ORD(CH) MOD 128); (* Explicit 7 bit Parity Mask *)
        if (xofcnt=0) and (ord(ch)=0) then EXIT (REMCHECK); {To handle PAD ??}
        IF CH=CHR(XOFF) THEN XOFCNT:=XOFCNT+1 (* An XOFF so bump count *)
                        ELSE IF (CH<>CHR(XON)) and (ch<>chr(0)) THEN
                          begin
                            Mop_Up(ch);
                            close(dfile);
                            if DEBUG then put_message
                                 ('*  Expected XON or | from host not char.',
                                      debugging);
                            exit(doputfile);
                          end;
     UNTIL (CH=CHR(XON)) OR ABORT; (* flow control resume *)
     TOTXOF:=TOTXOF+XOFCNT;        (* running XOFF total *)
     IF XOFCNT>MAXXOF THEN MAXXOF:=XOFCNT; (* the biggest yet? *)
     XOFOCC:=XOFOCC+1              (* register this occurence *)
  END; (* remcheck *)

  Procedure Case_Check;
  (*--------2--------*)
  var i:integer;
  begin
    case chord of
       CR:if textfile then begin
                             chord:=newline;
                             ch:=chr(newline); (* may be m/c dependent *)
                           end else if pad then begin
                             if rempress then remcheck;
                             remwrite (chr(DLE));
                             ch:=chr(CRMSB);  {chord left as CR for checksum}
                           end;
      DLE:if textfile then
          begin
            (*$R-*) (* j may overflow into filler bytes *)
            j:=j+1;
            blanks:=ord(block[j]) -33;(* 32 offset -1 *)
            (*$R+*) (* j may be 1025, hence filler area *)
            ch:=space; (* this is why the -1 appears above *)
            chord:=ord(space);
            if blanks > 0 then
              begin (* range check *)
                for i:=1 to blanks do 
                  begin
                    if rempress then remcheck;
                    remwrite(space);
                  end;
                chars:=(chars + blanks) MOD 16384;
                chksm:=(chksm + blanks*ord(space)) MOD 16384;
              end  (* range... *)
                           else
               if blanks = -1 then
                 begin (* zero DLE indent - get next char *)
                   (*$R-*) (* j may point past limit *)
                   j:=j+1;
                   chord:=ord(block[j]) MOD chinmod;
                   ch:=chr(chord);
                   case_check;
                   (*$R+*) (* j may be 1026 *)
                 end
                            else
                         if blanks < -1 then
                          begin (* an error *)
                            ABORT:=true; (* local message here *)
                            put_message('*  DLE expansion error.',local);
                          end;
                         (* note that if blanks = 0 then ch
                            has already been set to <space> *)
          end  (* DLE_case *)  else (* binary *)
                                 begin
                                   if rempress then remcheck;
                                   remwrite(chr(DLE));
                                 end;
     XON:if pad then begin
                       if rempress then remcheck;
                       remwrite (chr(DLE));
                       ch:='1';  {chord left as XON for checksum}
                     end;
     XOFF:if pad then begin
                        if rempress then remcheck;
                        remwrite (chr(DLE));
                        ch:='3';  {chord left as XOFF for checksum}
                      end;
     XONMSB:if pad then begin
                       if rempress then remcheck;
                       remwrite (chr(DLE));
                       ch:=chr(128+ord('1'));  {chord left as XONMSB
                                                              for checksum}
                     end;
     XOFFMSB:if pad then begin
                        if rempress then remcheck;
                        remwrite (chr(DLE));
                        ch:=chr(128+ord('3'));  {chord left as XOFFMSB
                                                               for checksum}
                      end;
     TERM:begin
            if rempress then remcheck;
            remwrite(chr(TransparenCh)); (* special character *)
          end;
    end; (* case *)
  end; (* case check *)
   
  Procedure Prepare;
  (*------2-------*)
  var Res:integer;
      Name:string;
  begin
    init_messages; (* message area should be empty *)
    (*$I-*) (* check for file OK *)
    {get correct name}
    Name:=LocalName;
    if textfile AND (POS('.TEXT',Name)=0)
      then Name:=CONCAT(Name,'.TEXT');

    reset(dfile,Name);
    Res:=IOResult;
    if Res <> 0 then
      begin (* something wrong *)
        close(dfile);
        givereason(Res,st);
        put_message(st,local);
        exit(doputfile);
      end; (* something wrong *)
    (*$I+*)
        
    (* do some initialisation *)
    totxof:=0; maxxof:=0; xofocc:=0;
    chksm:=0; chars:=0; dotcnt:=0;
    user_interrupt:=false; ABORT:=false;
    page:=2; (* but we may have odd number of blocks *)
  end; (* prepare *)
        
        
      (* ********* *)
begin (* doputfile *)
      (* ********* *)
  prepare; (* does all the initialising & checking before transfers *)
  (*$R-*)
  transmit('TAKEFILE',false);
  remwrite(chr(CR));
  Mop_Up(chr(NUL)); (* collect any response *)
  if prompt_verify('e:')                        (* looking for Takefile: *)
    then init_messages
    else begin
           if DEBUG then
             put_message('*  Incorrect prompt from host.',debugging);
           close(dfile);
           abortall :=true;
           exit(doputfile);
         end;  
  
  transmit(remotename,false); (* invoke EMAS TakeFile *)
  remwrite(chr(CR));
  (*$R+*)
  repeat
    remread(ch);
    ch:=chr(ord(ch) MOD 128); {explicit 7 bit mask}
  until not (ch in [chr(NUL), CHR(CR), chr(LF)]); (* skip the junk *)
  
  if not (ch in [chr(XON), PADXON]) then
    begin
      Mop_Up(ch); 
      close(dfile);
      if DEBUG then
        put_message('*  XON to start transfer not received.',debugging);
      exit(doputfile);
    end;
  
  pad:=ch=PADXON;  { needed for encoding of XON and XOFF }
  filler:=0; (* NULs in the overflow block *)
  if textfile then relblock:=2  (* skip 2 blocks of text file *)
              else relblock:=0;
  repeat (* until EOF or ABORT *)
    (*$I-*) j:=blockread(dfile, block, page, relblock);  (*$I+*)
    if j <> page then
      begin
        if (j=1) AND not textfile then page:=1
        else
          begin
            ABORT:=true;
            put_message('*  Unable to read page.',local);
          end;
      end;
    if ioresult<>0 then
      begin (* something wrong *)
        Res:=ioresult;
        givereason(Res,st);
        put_message(st,local);
      end;
    if not ABORT then
       begin (* blockread ok *)
         write('.');
         relblock:=relblock + page; (* point to next block *)
         (* do a backwards scan over NULs *)
         fill_level:=page*512;
         if textfile then
           begin (* textfile *)
             while (block[fill_level]=chr(NUL)) AND (fill_level>1)
                   do fill_level:=fill_level-1;
             if EOF(dfile) then 
                begin
                  if block[fill_level]=chr(CR) then fill_level:=fill_level-1;
                  (* remove very last CR *)
                  if (fill_level>2) then
                    begin
                      if (ord(block[fill_level])>=ord(space)) AND
                        (block[fill_level-1]=chr(DLE)) 
                      then fill_level:=fill_level-2;
                      (* remove DLE sequence if at end *)
                    end;
                end; (* eof *)
           end; (* textfile *)
         if fill_level > 0 then
           begin (* not a block of NULs in textfile mode *)
             j:=1;
             repeat
               ch:=block[j]; chord:=ord(ch);
               case_check;
               (* always get here - but may do one of the above *)
               chars:=(chars + 1) MOD 16384;
               chksm:=(chksm + chord) MOD 16384;  {chord used because if PAD
                        is true XON(XOFF) need to be sent as <DLE> '1'('3'), but
                                          for should be XON(XOFF) for checksum, 
                                                NEEDs MORE ELEGANT SOLUTION ?? }
               if rempress then remcheck;
               remwrite(chr(ord(ch) MOD chinmod));  { mod done after for 8 bits }
               (* this was the character we first thought of *)
               j:=j + 1;     (* point to the next character  *)
             until j > fill_level;  (* a buffer full *)
           end; (* not a block of NULs *)
        end; (* blockread ok *)
        
        if rempress then remcheck;  { added 19-12-84 for Apple, since if Xoff
                                        followed by xon sent now, this is lost
                                        due to no buffering  }
        
        write('.');
        dotcnt:=dotcnt + 2;
        if dotcnt>= 40 then begin
                             dotcnt:=0;
                             writeln;
                           end;        
       while keypress and not ABORT do
              begin
                keyread(ch,false,false);
                if ch = chr(ESC) then
                  begin
                    user_interrupt:=sure('Curtail?');
                    ABORT:=ABORT or user_interrupt;
                  end;
              end;
      until EOF(dfile) or ABORT;
     (*$I-*)
     CLOSE(DFILE);
     (*$I+*)
     if ioresult<>0 then
       begin
         Res:=ioresult; givereason(Res,st);
         put_message(st,local);
       end;
    IF REMPRESS THEN REMCHECK;
     REMWRITE(chr(TERM));
     MOP_UP(chr(NUL));   { added 20-12-84 for filestore problems  }
     PUTCHKSM; (*PUT OUT CHECKSUM TO HOST*)
     mop_up(chr(NUL));   { added 18-12-84   }
     remwrite(chr(CR));
     mop_up(chr(NUL));
     writeln; (* to cater for part lines *)
     if DEBUG then
       begin
         int_to_string(chars,6,st_chars); int_to_string(chksm,6,st_chksm);
         put_message(concat('*       ',st_chars,
                            ' characters sent.      Checksum:',st_chksm,'.'),
                            debugging);
         int_to_string(xofocc,0,st_xofocc);
         int_to_string(maxxof,0,st_maxxof);
         int_to_string(totxof,0,st_totxof);
         put_message(concat('*  XOFF occurred ',st_xofocc,' times, Max ',
                              st_maxxof,', Total ',st_totxof,'.'),debugging);
       end;
end; (* doputfile *)
      
{-----------------------------------------------------------------------------}
                                {end TTY.DOPUT}
{-----------------------------------------------------------------------------}



{$p}
{-----------------------------------------------------------------------------}
                       { -  TTY.PUT  - }
{-----------------------------------------------------------------------------}

{ modified
   3-Aug-84  Gordon Wilkie  PAD changes  
  20-Aug-84  Gordon Wilkie  uppercase and lower case allowed for remote names
  18-Dec-84  Gordon Wilkie  change to allow  abort all param  }

Function PartP:integer;
begin
  PartP:=3;
end;

(*  CHECKSUM COMPUTATION
    8 letters made up as follows:-
    a) keep a sum of ordinal values of characters in the transfer
       rounded MOD 16384 in a 16 bit integer.
    b) keep a count of number of characters in the transfer rounded
       MOD 16384 in a 16 bit integer.
    c) for each nibble (4 bits) in the 16 bit quantities kept above
       (starting with the most significant nibble of the ordinal values
       sum and ending with the least significant nibble of the character
       count) add the ordinal code for the letter 'A' and send the
       resulting code as a character.  This means that 8 letters between
       'A' and 'O' are sent.
*)

Procedure PutFile;
(*======1=======*)
VAR l_name,r_name:STRING;
    STR,STR2:long_string;
    abortall,BadName,user_interrupt,ABORT:BOOLEAN;
    CH:CHAR;
    
  Function PUT_Checks_OK(name_list:long_string):Boolean;
  (*-------------------------2------------------------*)
  Var
    dfile:file; (* used to test local files *)
    OK:boolean;
    st,name:string; Res,i:integer;
  Begin
    put_checks:=true;  OK:=true;
    (*$I-*)
    while (name_list <> '') AND OK do
      begin (* while *)
        next_name(name_list,name);
        if length(name) <> 0 then
          begin (* non zero name *)
            if textfile then
              if POS('.TEXT',name) = 0 then name:=concat(name,'.TEXT');
            if POS(':',name) <> 0 then
              begin
                BadName:= (length(name)-POS(':',name) > 15) OR 
                          (POS(':',name) > 8);
              end
                else
            if POS('*',name) = 1 then
              begin
                BadName:=(length(name) > 16);
              end
                else
            BadName:=length(name) > 15;
            if BadName then
              begin
                OK:=false;
                put_message(CONCAT(
                        '*  Illegal file name ',name,'.'),local);
              end else
                    begin (* name OK *)
                      reset(dfile,name);
                      if ioresult <> 0 then
                        begin
                          Res:=ioresult;
                          OK:=false;
                          put_message(concat('*  Unable to open local file ',
                                      name),local);
                          if DEBUG then begin
                             givereason(Res,st);
                             put_message(st,debugging);
                                        end;
                        end;
                     close(dfile);
                    end;(* name OK *)
          end (* non zero... *)
            else begin (* null name *)
                   OK:=false;
                   put_message('*  Null file name.',local);
                 end;  (* nul name *)
      end; (* while *)
      put_checks_OK:=OK;
    end; (* put_checks *)
  
 BEGIN (* PutFile *)
   WRITELN;
   WRITE('--- Put file ');
   if textfile then begin
                      write('(Text, ');
                      if chinmod=128 then write('7') else write('8');
                      writeln(' bit codes) ---')
                    end
               else writeln('(Binary) ---');
   WRITELN;
   WRITE('Give local  file(s):');
   KEYRDLN(STR);
   UPPERCASE (str);
   WRITE('Give remote file(s):');
   KEYRDLN(STR2);
   init_messages; (* initialise messages for namechecking procedures *)
   
   if names_paired(str,str2) then (* paired names *)
      begin
        if put_checks_OK(str) then      (* local files appear to be there *)
          begin 
            writeln;
            while str2<>'' do
               begin (* transfers *)
                 next_name(str, l_name);
                 next_name(str2, r_name);
                 {next_name returns name in capitals}
                 if textfile AND (POS('.TEXT',l_name)=0)
                    then l_name:=CONCAT(l_name,'.TEXT');
                 writeln(l_name,' --> ',r_name);
                 abortall:=false;
                 doputfile(l_name,r_name,textfile,debug,user_interrupt,
                                                                      abortall);
                 if abortall then str2:='';   {abandon all transfers}
                 print_messages; (*ENDING MESSAGES*)
                 if str2<>'' then writeln;
                 if abortall then writeln('Transfer abandoned');
               end  (* transfers *)
          end
           else print_messages;
      end
        else print_messages;
   writeln; writeln('--- Put file finished ---',chr(BEL));
end; (* putfile *)

{------------------------------------------------------------------------------}
{end TTY.PUT}
{------------------------------------------------------------------------------}


{$P}
{-----------------------------------------------------------------------------}
                              {1-Feb-83 - TTY.FLR}
{-----------------------------------------------------------------------------}
{  Modified  4-Dec-84 by G.Wilkie to check valid directory   }

FUNCTION PARTF:INTEGER;
BEGIN
  {FILER REVISION NUMBER}
  PARTF:=7;
END;

{$I-}
PROCEDURE FILEH(CODE:CHAR);

{ Assume all input through                            }
{   GETCH    input character from source stream       }
{   GETLN    input string from source stream up to NL }
{                                                     }
{Assume all output through                            }
{   PUTCH    output character to destination stream   }
{   PUTTXT   output string    to destination stream   }
{   PUTINT   output integer   to destination stream   }
{   PUTLN    output a newline to destination stream   }
{                                                     }
{There are calls to windowing routines - could be null}
{   WFRAME   set a text port for the output           }
{   WUNFRAME reset the text port to the entire screen }
{   WCLRSCREEN clears the text port and goes to 0,0   }

CONST VIDLENG=7;  {NUMBER OF CHARS IN A VOLUME ID}
      TIDLENG=15; {NUMBER OR CHARS IN A TITLE ID}
      MAXDIR=77;  {MAX NUMBER OF ENTRIES IN A DIRECTORY}

TYPE  DATEREC = PACKED RECORD
                  MONTH: 0..12;          {0 IMPLIES DATE NOT MEANINGFUL}
                  DAY: 0..31;            {DAY OF MONTH}
                  YEAR: 0..100           {100 IS TEMP DISK FILE FLAG}
                END {DATEREC} ;
      VID = STRING[VIDLENG];
      DIRRANGE = 0..MAXDIR;
      TID = STRING[TIDLENG];
 
      FILEKIND = (UNTYPEDFILE,XDSKFILE,CODEFILE,TEXTFILE,
                  INFOFILE,DATAFILE,GRAFFILE,FOTOFILE);
 
      DIRENTRY = RECORD
                   DFIRSTBLK: INTEGER;   {FIRST PHYSICAL DISK ADDR}
                   DLASTBLK: INTEGER;    {POINTS AT BLOCK FOLLOWING}
                   CASE DFKIND: FILEKIND OF
                     UNTYPEDFILE: {ONLY IN DIR[0]...VOLUME INFO}
                       (DVID: VID;              {NAME OF DISK VOLUME}
                        DEOVBLK: INTEGER;       {LASTBLK OF VOLUME}
                        DNUMFILES: DIRRANGE;    {NUM FILES IN DIR}
                        DLOADTIME: INTEGER;     {TIME OF LAST ACCESS}
                        DLASTBOOT: DATEREC);    {MOST RECENT DATE SETTING}
                     XDSKFILE,CODEFILE,TEXTFILE,INFOFILE,
                     DATAFILE,GRAFFILE,FOTOFILE:
                       (DTID: TID;               {TITLE OF FILE}
                        DLASTBYTE: 1..512;       {NUM BYTES IN LAST BLOCK}
                        DACCESS: DATEREC)        {LAST MODIFICATION DATE}
                 END {DIRENTRY} ;

VAR   DI: RECORD CASE BOOLEAN OF
            TRUE: (RECTORY: ARRAY [DIRRANGE] OF DIRENTRY);
            FALSE:(RBLOCKS: packed ARRAY[1..4] OF packed ARRAY[1..512] OF CHAR)
          END;


PROCEDURE SPACES(V:INTEGER);
BEGIN
   FOR V:=V DOWNTO 1 DO PUTCH(' ');
END;

PROCEDURE DIRINIT(UNITNUM:INTEGER);
BEGIN
  UNITREAD(UNITNUM,DI.RBLOCKS[1],2048,2); {LOAD DIR}
END {DIRINIT} ;

PROCEDURE DIRECTORY(DETAIL:BOOLEAN);
VAR LINES,I,UNITNUM,LARGEST,FREEBLKS,USEDAREA,USEDBLKS: INTEGER;
    GS: STRING;
    MONTHS: ARRAY [0..15] OF STRING[3];
    ScreensUsed:integer;

FUNCTION GETUNIT:BOOLEAN;
VAR I:INTEGER;
    GOOD:BOOLEAN;
    INSTRING:LONG_STRING;  { necessary in TTY }
    UNAMES:ARRAY[4..16] OF STRING[3];
BEGIN
   UNAMES[4]:='#4';
   UNAMES[5]:='#5';
   UNAMES[6]:='';
   UNAMES[7]:='';
   UNAMES[8]:='';
   UNAMES[9]:='#9';
   UNAMES[10]:='#10';
   UNAMES[11]:='#11';
   UNAMES[12]:='#12';
   UNAMES[13]:='#13';
   UNAMES[14]:='#14';
   UNAMES[15]:='#15';
   UNAMES[16]:='#16';
   PUTTXT('Unit: '); GETLN(INSTRING);
   while pos(' ',instring)<>0 do delete(instring,pos(' ',instring),1);
   IF INSTRING<>'' THEN IF INSTRING[LENGTH(INSTRING)]=':' THEN BEGIN
      {$R-}
      INSTRING[0]:=PRED(INSTRING[0]);
      {$R+}
   END;
   UpperCase(InString);
   IF INSTRING='*' THEN INSTRING:='#4';
   GOOD:=FALSE;
   IF INSTRING<>'' THEN BEGIN
      UNITNUM:=3;
      REPEAT
         UNITNUM:=UNITNUM+1;
         IF INSTRING[1]='#' THEN BEGIN
            IF INSTRING=UNAMES[UNITNUM] THEN BEGIN
               DIRINIT(UNITNUM);
               GOOD:=(IORESULT=0) and {$R-} (di.rectory[0].dvid[0]>=chr(1)) and 
                                           (di.rectory[0].dvid[0]<=chr(7));{$R+}
            END;
         END ELSE BEGIN
            IF UNAMES[UNITNUM]<>'' THEN BEGIN
               DIRINIT(UNITNUM);
               GOOD:=(IORESULT=0) and {$R-} (di.rectory[0].dvid[0]>=chr(1)) and 
                                           (di.rectory[0].dvid[0]<=chr(7));{$R+}
               if good then GOOD:=(DI.RECTORY[0].DVID=INSTRING);
            END;
         END;
      UNTIL GOOD OR (UNITNUM=16);
   END;
   IF NOT GOOD THEN BEGIN
      PUTTXT('Unit not on-line.');
      PUTLN;
   END;
   GETUNIT:=GOOD;
END;

PROCEDURE SENDLN;
VAR CH:CHAR;
BEGIN
  PUTLN;
  LINES:=LINES+1;
  IF LINES=19 THEN BEGIN
      PUTTXT('Press <space> to continue');
      REPEAT
         GETCH(CH,FALSE,FALSE);
      UNTIL CH=' ';
      if not(Detail) and (ScreensUsed<2) then
        begin
          WUnFrame(false); {leave image on screen}
          ScreensUsed:=ScreensUsed+1; {don't let it go over right margin}
          WFrame(15+ScreensUsed*16,0,34,20,'');
        end;
        {or just put WClrScreen for simplicity}
      WClrScreen;
      LINES:=0;
   END;
END;

PROCEDURE FREECHECK(FIRSTOPEN,NEXTUSED: INTEGER);
VAR FREEAREA: INTEGER;
BEGIN
  FREEAREA := NEXTUSED-FIRSTOPEN;
  IF FREEAREA > LARGEST THEN LARGEST := FREEAREA;
  IF FREEAREA > 0 THEN
    BEGIN FREEBLKS := FREEBLKS+FREEAREA;
      IF DETAIL THEN
        BEGIN
          PUTTXT('< UNUSED >      ');
          PUTINT(FREEAREA,4);
          SPACES(11);
          PUTINT(FIRSTOPEN,6);
          SENDLN;
        END
    END;
END {FREECHECK} ;

BEGIN
  if DETAIL then WFrame(15,0,63,20,'') else WFrame(15,0,34,20,'');
  IF GETUNIT THEN
    begin
      MONTHS[ 0] := '???'; MONTHS[ 1] := 'Jan';
      MONTHS[ 2] := 'Feb'; MONTHS[ 3] := 'Mar';
      MONTHS[ 4] := 'Apr'; MONTHS[ 5] := 'May';
      MONTHS[ 6] := 'Jun'; MONTHS[ 7] := 'Jul';
      MONTHS[ 8] := 'Aug'; MONTHS[ 9] := 'Sep';
      MONTHS[10] := 'Oct'; MONTHS[11] := 'Nov';
      MONTHS[12] := 'Dec'; MONTHS[13] := '???';
      MONTHS[14] := '???'; MONTHS[15] := '???';
      FREEBLKS := 0; USEDBLKS := 0;
      LARGEST := 0;
      WITH DI.RECTORY[0] DO
        BEGIN
          WClrScreen;
          ScreensUsed:=0;
          PUTTXT(DVID);
          PUTTXT(':');
          PUTLN;
        END;
      LINES:=1;
      FOR I := 1 TO DI.RECTORY[0].DNUMFILES DO
        WITH DI.RECTORY[I] DO
          BEGIN
            FREECHECK(DI.RECTORY[I-1].DLASTBLK,DFIRSTBLK);
            USEDAREA := DLASTBLK-DFIRSTBLK;
            USEDBLKS := USEDBLKS+USEDAREA;
            IF DACCESS.YEAR IN [1..99] THEN
            BEGIN
              PUTTXT(DTID);
              SPACES(TIDLENG-LENGTH(DTID)+1);
              PUTINT(USEDAREA,4);
              IF DACCESS.MONTH > 0 THEN
                SPACES(2);
                PUTINT(DACCESS.DAY,2);
                PUTCH('-');
                PUTTXT(MONTHS[DACCESS.MONTH]);
                PUTCH('-');
                PUTINT(DACCESS.YEAR,2);
              IF DETAIL THEN
                BEGIN
                  IF DACCESS.MONTH = 0 THEN SPACES(11);
                  PUTINT(DFIRSTBLK,6);
                  PUTINT(DLASTBYTE,6);
                  GS := '     file';
                  CASE DFKIND OF
                    XDSKFILE: GS := 'Bad block';
                    CODEFILE: GS := 'Code file';
                    TEXTFILE: GS := 'Text file';
                    INFOFILE: GS := 'Info file';
                    DATAFILE: GS := 'Data file';
                    GRAFFILE: GS := 'Graf file';
                    FOTOFILE: GS := 'Foto file'
                  END;
                  SPACES(2);
                  PUTTXT(GS)
                END;
              SENDLN;        END;
          END;
      FREECHECK(DI.RECTORY[I-1].DLASTBLK,DI.RECTORY[0].DEOVBLK);
      PUTINT(DI.RECTORY[0].DNUMFILES,0);
      PUTTXT(' files, ');
      PUTINT(USEDBLKS,0);
      PUTTXT(' blks used, ');
      PUTINT(FREEBLKS,0);
      PUTTXT(' free');
      IF DETAIL THEN BEGIN
         PUTTXT(', ');
         PUTINT(LARGEST,0);
         PUTTXT(' in largest area');
      END;
      PUTLN; {not SEND so screen not cleared}
    end;
  WUnFrame(false) {leave display on screen}
END; {DIRECTORY}

PROCEDURE VOLS;
VAR UNITNUM:INTEGER;
BEGIN
   WFrame(24,4,14,7,'Volumes');
   FOR UNITNUM:=4 TO 16 DO
      IF UNITNUM IN [4,5,9,10,11,12,13,14,15,16] THEN BEGIN
      DIRINIT(UNITNUM);
      IF (IORESULT=0) and {$R-} (di.rectory[0].dvid[0]>=chr(1)) and 
                                           (di.rectory[0].dvid[0]<=chr(7)){$R+}
       THEN BEGIN
         PUTLN;
         PUTINT(UNITNUM,3);
         SPACES(2);
         PUTTXT(DI.RECTORY[0].DVID);
         PUTCH(':');
      END;
   END;
   PUTLN;
   WUnFrame(false); {leave window on screen}
END;

PROCEDURE REMOVEFILE;
VAR STR:LONG_STRING; { necessary in TTY }
    DFILE:FILE;
BEGIN
   WFrame(24,4,35,2,'');
   PUTTXT('Remove filename:');
   GETLN(STR);
   RESET(DFILE,STR);
   IF IORESULT<>0 THEN
      PUTTXT('File does not exist.')
   ELSE BEGIN
      CLOSE(DFILE,PURGE);
      PUTTXT('File ');
      PUTTXT(STR);
      PUTTXT(' removed.');
   END;
   PUTLN;
   WUnFrame(false); {leave window on screen}
END;

BEGIN
   CASE CODE OF
   'E':DIRECTORY(TRUE);
   'L':DIRECTORY(FALSE);
   'V':VOLS;
   'R':REMOVEFILE;
   END;
END;

{$I+}

{-----------------------------------------------------------------------------}
                                 {end TTY.FLR}
{-----------------------------------------------------------------------------}


   {FILE HANDLING ROUTINES}
   
PROCEDURE FILELEVEL;
VAR FINISH:BOOLEAN;
    CH:CHAR;
BEGIN
   FINISH:=FALSE;
   REPEAT
      ch:=WSCPrompt('Filer: L(istdir, E(xtdir, V(olumes, R(emove, Q(uit ',
                    -1,0, 45,8, ['L','E','V','R','Q'],false,',');
   if ch = 'Q' then finish:=true
               else fileh(ch);
   UNTIL FINISH;
END;
PROCEDURE HELPTEXT;
BEGIN
  WFrame(38, 1, 40,17,'');
  WClrScreen;
  PutTxt('CTRL/L causes entry to local mode.');      PutLn;
  PutTxt('In this mode there are several commands.');PutLn;
  PutLn;
  PutTxt('P(ut file) is used to transfer a file');   PutLn;
  PutTxt('   from this system to the remote.');      PutLn;
  PutTxt('G(et file) is used to transfer a file');   PutLn;
  PutTxt('   from the remote to this system.');      PutLn;
  PutTxt('F(iler) is used to obtain a directory');   PutLn;
  PutTxt('   listing of files on line on this');     PutLn;
  PutTxt('   system, and remove unwanted files.');   PutLn;
  PutTxt('C(onfigure is used to set parameters to'); PutLn;
  PutTxt('   interface and program, and set host');  PutLn;
  PutTxt('   or local values.');                     PutLn;
  PutTxt('^(control) is used to send a control');    PutLn;
  PutTxt('   character to the host.');               PutLn;
  PutTxt('E(xit TTY) stops the TTY utility.');       PutLn;
  PutTxt('Q(uit local) returns to terminal mode.');
  WUnFrame(false);
END;

PROCEDURE TTYTITLE;
BEGIN
  SC_ClrScreen;
  SC_GotoXY(0,2);
  WRITELN('----------------------------------------------------------------');
  WRITELN('ERCC X-Talk Communications - ',mcname,' - TTY - ',version        );
  WRITELN('----------------------------------------------------------------');
  WRITELN('Micro acts as a normal terminal.');
  WRITE  ('CTRL/L enters local mode.');
  SC_GotoXY(0, 9);
END;

PROCEDURE INITDATA;
BEGIN
  { set up the host specific parts }
  CRSTRING:=' ';
  CRSTRING[1]:=CHR(CR);
  CTRLASTRING:=' ';
  CTRLASTRING[1]:=CHR(CTRLA);
  SETTCP:=CONCAT(CTRLASTRING,'P 5'); {CR SENT AFTER SETMODE}
  ctrlPstring:=' ';
  ctrlPstring[1]:=CHR(dle);
  setpad:=CONCAT(ctrlPstring,'ALFPAD=5 ');setpad[10]:=chr(cr);
  REPEATCH:=18;  {CTRL/R BY DEFAULT - CH TO REPEAT CURRENT LINE FROM}
                {HOST.  SET TO 0 IF THIS FACILITY IS NOT AVAILABLE }
  escape_sequence:='   '; { length 3 for EMAS }
  escape_sequence[1]:=chr(ESC); escape_sequence[2]:='A'; 
  escape_sequence[3]:=chr(CR);
  HALFDUPLEX:=FALSE;
  { now the non host specific parts }
  WAITTIME:=1500;
  TimeOutUnits:=ABS(WaitTime DIV 512) + 1; 
   { Determined by WaitTime - but should always be > 0. }
  ALTFILE:=FALSE;
  CHINMOD:=256; { assume 8 bit codes are the default }
  PROMPTSET:=[':','$'];
  BreakChar:=','; { the list separator }
  DEBUG:=FALSE;
END;

BEGIN
  INITDATA;
  REMSETUP;
  TERMINAL:=FALSE;
  TTYTITLE;
  WInit;
  REMWRITE(CHR(CR));
  {ALLOW HOST TO REPEAT PROMPT IF ALREADY LOGGED IN}

  REPEAT
    RemFlush; {version IV change}

    IF KEYPRESS THEN
      BEGIN
        KEYREAD(CH,FALSE,FALSE);
        IF (CH=CHR(CTRLL)) THEN
          BEGIN {LOCAL MODE}
            CursorLost:=true;
            {explicitly set CursorLost to true for special cases
             where cursor is at correct position after action}
            ch:=WSCPrompt(
  'TTY: P(ut,G(et,F(iler,C(onfigure,H(elp,^(ctrl,B(reak,E(xit TTY,Q(uit local ',
           -1,0, 40,7, [' ','C','^','E','F','G','H','P','B','R','Q'],false,',');
            CASE CH OF
              '^': SENDCTRL;
              'C': Configure;
              'E': begin TERMINAL:=true; CursorLost:=false; end;
              'F': FILELEVEL;
              'B': begin writeln; BREAKCONDITION; CursorLost:=false; end;
              'P',
              'G': BEGIN
                     if not CursorLost then writeln;
                       { if at end of prompt go to next line }
                     textfile:=(altfile=false);
                     if ch='G' then
                       begin
                         if altfile then
                           begin { binary }
                             x_chinmod:=chinmod;
                             chinmod:=256;
                             getfile;
                             chinmod:=x_chinmod;
                           end
                         else getfile;
                       end
                     else
                       if altfile then
                         begin { binary }
                           x_chinmod:=chinmod;
                           chinmod:=256;
                           putfile;
                           chinmod:=x_chinmod;
                         end
                       else putfile;
                   CursorLost:=true; { explicit setting to get Command: }
                   END;
              'H': HelpText;
              'R': begin
                     writeln;
                     WRITE  ('TTY Revision: ',Version,', 2.',PART2);
                     WRITE  (', M.',PARTM,' MD.',MessDVersion);
                     WRITE  (', W.',PARTW);
                     WRITE  (', G.',PARTG,' DG.',PARTDG);
                     WRITE  (', P.',PARTP,' DP.',PARTDP);
                     WRITELN(', F.',PARTF,
                             ', X.',PARTX1,PARTX2,'.');
                     CursorLost:=true;
                   end;
              ' ': { do nothing };
              'Q': { do nothing };
            END {CASE };
            IF CH=' ' THEN 
              begin
                if RepeatCh <> 0 then REMWRITE(CHR(REPEATCH));
                 {REPEAT PRESENT LINE}
              end
            ELSE IF CursorLost THEN
                     BEGIN
                       IF HALFDUPLEX THEN GotoXY(0,BottomLine) 
                                     else GotoXY(0,BottomLine-1);
                       REMWRITE(CHR(CR));
                     END;
          END
        ELSE
          BEGIN
            IF HALFDUPLEX THEN BEGIN
              IF CH=CHR(BS) THEN WRITE(CHR(BS),' ',CHR(BS))
              ELSE IF CH=CHR(CR) THEN WRITELN
              ELSE IF (CH<' ') THEN WRITE(CHR(BEL))
              ELSE WRITE(CH);
            END;
            IF CH=CHR(BS) THEN CH:=CHR(BS_Map_Ch); { map in required eraser }
            REMWRITE(CH)
          END
      END;

    RemFlush; {version IV change} 

  UNTIL TERMINAL;
  
  WTerminate;  { tidy up after use of windowing routines if needed }
  
  REMCLOSE;
END.