home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / archives / ucsdterak.tar.gz / ucsdterak.tar / kermit.text < prev    next >
Text File  |  1984-04-11  |  37KB  |  1,141 lines

  1. program kermit;
  2.  
  3. (* $R-*) (* turn range checking off *)
  4. (*$S+*) (* turn swapping on *)
  5. (* $L+*)
  6. (*$U PARSELIB.CODE*)
  7. USES PARSER;
  8.  
  9. const blksize = 512;
  10.       oport = 8;          (* output port # *)
  11.       clearscreen = 12;   (* charcter which erases screen *)
  12.       bell = 7;           (* ASCII bell *)
  13.       maxpack = 93;       (* maximum packet size minus 1 *)
  14.       soh = 1;            (* start of header *)
  15.       sp = 32;            (* ASCII space *)
  16.       cr = 13;            (* ASCII CR *)
  17.       lf = 10;            (* ASCII line feed *)
  18.       dle = 16;           (* ASCII DLE (space compression prefix for psystem) *)
  19.       del = 127;          (* delete *)
  20.       my_esc = 29;        (* default esc char for connect (^]) *)
  21.       maxtry = 5;         (* number of times to retry sending packet *)
  22.       my_quote = '#';     (* quote character I'll use *)
  23.       my_pad = 0;         (* number of padding chars I need *)
  24.       my_pchar = 0;       (* padding character I need *)
  25.       my_eol = 13;        (* end of line character i need *)
  26.       my_time = 5;        (* seconds after which I should be timed out *)
  27.       maxtim = 20;        (* maximum timeout interval *)
  28.       mintim = 2;         (* minimum time out interval *)
  29.       at_eof = -1;        (* value to return if at eof *)
  30.       rqsize = 5000;      (* input queue size *)
  31.       qsize1 = 5001;      (* qsize + 1 *)
  32.       eoln_sym = 13;      (* pascal eoln sym *)
  33.       back_space = 8;     (* pascal backspace sym *)
  34.  
  35. (* screen control information *)
  36.   (* console line on which to put specified info *)
  37.       title_line = 1;
  38.       statusline = 2;
  39.       packet_line = 3;
  40.       retry_line = 4;
  41.       file_line = 5;
  42.       error_line = 6;
  43.       debug_line = 7;
  44.       prompt_line = 8;
  45.   (* position on line to put info *)
  46.       statuspos = 70;
  47.       packet_pos = 19;
  48.       retry_pos = 17;
  49.       file_pos = 11;
  50.  
  51. type queue = record (* input queue *)
  52.                  qsize: integer;
  53.                  inp: integer;
  54.                  outp: integer;
  55.                  maxchar: integer;
  56.                  data: packed array[0..rqsize] of char;
  57.                end; (* queue *)
  58.      packettype = packed array[0..maxpack] of char;
  59.      parity_type = (evenpar, oddpar, markpar, spacepar, nopar);
  60.  
  61.      char_int_rec = record (* allows character to be treated as integer... *)
  62.                            (* is system dependent *)
  63.                       case boolean of
  64.                           true: (i: integer);
  65.                           false: (ch: char)
  66.                     end; (* record *)
  67.  
  68.      int_bool_rec = record (* allows integer to be treated as boolean... *)
  69.                            (* used for numeric AND,OR,XOR...system dependent *)
  70.                       case boolean of
  71.                           true: (i: integer);
  72.                           false: (b: boolean)
  73.                     end; (* record *)
  74.  
  75. var kq, rq: queue;
  76.     state: char; (* current state *)
  77.     f: file of char; (* file to be received *)
  78.     oldf: file; (* file to be sent *)
  79.     s: string;
  80.     eol, quote, esc_char: char;
  81.     fwarn, ibm, half_duplex, debug: boolean;
  82.     i, size, rpsiz, spsiz, pad, n, num_try, oldtry, timint: integer;
  83.     recpkt, packet: packettype;
  84.     padchar, ch: char;
  85.     debf: text; (* file for debug output *)
  86.     parity: parity_type;
  87.     xon: char;
  88.     filebuf: packed array[1..1024] of char;
  89.     bufpos, bufend: integer;
  90.     parity_array: packed array[char] of char;
  91.     ctlset: set of char;
  92.     rec_ok, send_ok: boolean;
  93.  
  94. function read_ch(var q: queue; var ch: char): boolean;
  95. forward;
  96.  
  97. procedure clear_buf(var q: queue);
  98. forward;
  99.  
  100. function aand(x,y: integer): integer;
  101. forward;
  102.  
  103. function aor(x,y: integer): integer;
  104. forward;
  105.  
  106. function xor(x,y: integer): integer;
  107. forward;
  108.  
  109. procedure error(p: packettype; len: integer);
  110. forward;
  111.  
  112. procedure io_error(i: integer);
  113. forward;
  114.  
  115. procedure debugwrite(s: string);
  116. forward;
  117.  
  118. procedure debugint(s: string; i: integer);
  119. forward;
  120.  
  121. procedure writescreen(s: string);
  122. forward;
  123.  
  124. procedure refresh_screen(numtry, num: integer);
  125. forward;
  126.  
  127. function min(x,y: integer): integer;
  128. forward;
  129.  
  130. function tochar(ch: char): char;
  131. forward;
  132.  
  133. function unchar(ch: char): char;
  134. forward;
  135.  
  136. function ctl(ch: char): char;
  137. forward;
  138.  
  139. function getfil(filename: string): boolean;
  140. forward;
  141.  
  142. procedure bufemp(buffer: packettype; var f: text; len: integer);
  143. forward;
  144.  
  145. function bufill(var buffer: packettype): integer;
  146. forward;
  147.  
  148. procedure spar(var packet: packettype);
  149. forward;
  150.  
  151. procedure rpar(var packet: packettype);
  152. forward;
  153.  
  154. procedure spack(ptype: char; num:integer; len: integer; data: packettype);
  155. forward;
  156.  
  157. function getch(var r: char_int_rec; var q: queue): boolean;
  158. forward;
  159.  
  160. function getsoh(var q: queue): boolean;
  161. forward;
  162.  
  163. function rpack(var len, num: integer; var data: packettype): char;
  164. forward;
  165.  
  166. procedure read_str(var q: queue; var s: string);
  167. forward;
  168.  
  169. procedure show_parms;
  170. forward;
  171.  
  172. (*$I HELP.TEXT*)
  173. (*$I SENDSW.TEXT*)
  174. (*$I RECSW.TEXT*)
  175.  
  176. procedure rcvinit(var q: queue; size: integer);
  177.   external;
  178.  
  179. procedure rcvfinit;
  180.   external;
  181.  
  182. procedure kbdinit(var q: queue; size: integer);
  183.   external;
  184.  
  185. procedure kbdfinit;
  186.   external;
  187.  
  188. procedure sendbrk;
  189.   external;
  190.  
  191. procedure read_str(*var q: queue; var s: string*);
  192.  
  193. (* acts like readln(s) but takes input from input queue *)
  194.  
  195. var i: integer;
  196.  
  197.   begin
  198.     i := 0;
  199.     s := copy('',0,0);
  200.     repeat
  201.       repeat                              (* get a character *)
  202.       until read_ch(kq,ch);
  203.       if (ord(ch) = backspace) then       (* if it's a backspace then *)
  204.         begin
  205.           if (i > 0) then                   (* if not at beginning of line *)
  206.             begin
  207.               write(ch);                      (* go back a space on screen *)
  208.               write(' ');                     (* erase char on screen *)
  209.               write(ch);                      (* go back a space again *)
  210.               i := i - 1;                     (* adjust string counter *)
  211.               s := copy(s,1,i)                (* adjust string *)
  212.             end (* if *)
  213.         end (* if *)
  214.       else if (ord(ch) <> eoln_sym) then  (* otherwise if not at eoln  then *)
  215.         begin
  216.           write(ch);                        (* echo char on screen *)
  217.           i := i + 1;                       (* inc string counter *)
  218.           s := concat(s,' ');
  219.           s[i] := ch;                       (* put char in string *)
  220.         end; (* if *)
  221.     until (ord(ch) = eoln_sym);           (* if not eoln, get another char *)
  222.     s := copy(s,1,i);                     (* correct string length *)
  223.     writeln                               (* write a line on the screen *)
  224.   end; (* read_str *)
  225.  
  226. function aand(*x,y: integer): integer*);
  227.  
  228. (* arithmetic and--takes 2 integers and ands them, yeilding an integer *)
  229.  
  230. var xrec, yrec, temp: int_bool_rec;
  231.  
  232.   begin
  233.     xrec.i := x;                  (* put the two numbers in variant record *)
  234.     yrec.i := y;
  235.     temp.b := xrec.b and yrec.b;  (* use as booleans to 'and' them *)
  236.     aand := temp.i                (* return integer result *)
  237.   end; (* aand *)
  238.  
  239. function aor(*x,y: integer): integer*);
  240.  
  241. (* arithmetic or *)
  242.  
  243. var xrec, yrec, temp: int_bool_rec;
  244.  
  245.   begin
  246.     xrec.i := x;                  (* put two numbers in variant record *)
  247.     yrec.i := y;
  248.     temp.b := xrec.b or yrec.b;   (* use as booleans to 'or' them *)
  249.     aor := temp.i                 (* return integer result *)
  250.   end; (* aor *)
  251.  
  252. function xor(*x,y: integer): integer*);
  253.  
  254. (* exclisive or *)
  255.  
  256. var xrec, yrec, temp: int_bool_rec;
  257.  
  258.   begin
  259.     xrec.i := x;                  (* put two numbers in variant record *)
  260.     yrec.i := y;
  261.                                   (* use as booleans to 'xor' them *)
  262.     temp.b := (xrec.b or yrec.b) and (not(xrec.b and yrec.b));
  263.     xor := temp.i                 (* return integer result *)
  264.   end; (* xor *)
  265.  
  266. procedure error(*p: packettype; len: integer*);
  267.  
  268. (* writes error message sent by remote host *)
  269.  
  270. var i: integer;
  271.  
  272.   begin
  273.     gotoxy(0,errorline);
  274.     for i := 0 to len-1 do
  275.         write(p[i]);
  276.     gotoxy(0,promptline);
  277.   end; (* error *)
  278.  
  279. procedure io_error(*i: integer*);
  280.  
  281.   begin
  282.     gotoxy(0,errorline);
  283.     write(chr(27),'K');         (* erase to end of line *)
  284.     case i of
  285.         0: writeln('No error');
  286.         1: writeln('Bad Block, Parity error (CRC)');
  287.         2: writeln('Bad Unit Number');
  288.         3: writeln('Bad Mode, Illegal operation');
  289.         4: writeln('Undefined hardware error');
  290.         5: writeln('Lost unit, Unit is no longer on-line');
  291.         6: writeln('Lost file, File is no longer in directory');
  292.         7: writeln('Bad Title, Illegal file name');
  293.         8: writeln('No room, insufficient space');
  294.         9: writeln('No unit, No such volume on line');
  295.         10: writeln('No file, No such file on volume');
  296.         11: writeln('Duplicate file');
  297.         12: writeln('Not closed, attempt to open an open file');
  298.         13: writeln('Not open, attempt to close a closed file');
  299.         14: writeln('Bad format, error in reading real or integer');
  300.         15: writeln('Ring buffer overflow')
  301.       end; (* case *)
  302.     gotoxy(0,promptline)
  303.   end; (* io_error *)
  304.  
  305. procedure debugwrite(*s: string*);
  306.  
  307. (* writes a debugging message *)
  308. var i: integer;
  309.  
  310.   begin
  311.     if debug then
  312.       begin
  313.         gotoxy(0,debugline);
  314.         write(chr(27),'K');         (* erase to end of line *)
  315.         write(s);
  316.         for i := 1 to 2000 do ;                (* write debugging message *)
  317.       end (* if debug *)
  318.   end; (* debugwrite *)
  319.  
  320. procedure debugint(*s: string; i: integer*);
  321.  
  322. (* write a debugging message and an integer *)
  323.  
  324.   begin
  325.     if debug then
  326.       begin
  327.         debugwrite(s);
  328.         write(i)
  329.       end (* if debug *)
  330.   end; (* debugint *)
  331.  
  332. procedure writescreen(*s: string*);
  333.  
  334. (* sets up the screen for receiving or sending files *)
  335.  
  336.   begin
  337.     write(chr(clearscreen));
  338.     gotoxy(0,titleline);
  339.     write('                        Kermit UCSD p-system');
  340.     gotoxy(statuspos,statusline);
  341.     write(s);
  342.     gotoxy(0,packetline);
  343.     write('Number of Packets: ');
  344.     gotoxy(0,retryline);
  345.     write('Number of Tries: ');
  346.     gotoxy(0,fileline);
  347.     write('File Name: ');
  348.   end; (* writescreen *)
  349.  
  350. procedure refresh_screen(*numtry, num: integer*);
  351.  
  352. (* keeps track of packet count on screen *)
  353.  
  354.   begin
  355.     gotoxy(retrypos,retryline);
  356.     write(numtry: 5);
  357.     gotoxy(packetpos,packetline);
  358.     write(num: 5)
  359.   end; (* refresh_screen *)
  360.  
  361. function min(*x,y: integer): integer*);
  362.  
  363. (* returns smaller of two integers *)
  364.  
  365.   begin
  366.     if x < y then
  367.         min := x
  368.     else
  369.         min := y
  370.   end; (* min *)
  371.  
  372. function tochar(*ch: char): char*);
  373.  
  374. (* tochar converts a control character to a printable one by adding space *)
  375.  
  376.   begin
  377.     tochar := chr(ord(ch) + ord(' '))
  378.   end; (* tochar *)
  379.  
  380. function unchar(*ch: char): char*);
  381.  
  382. (* unchar undoes tochar *)
  383.  
  384.   begin
  385.     unchar := chr(ord(ch) - ord(' '))
  386.   end; (* unchar *)
  387.  
  388. function ctl(*ch: char): char*);
  389.  
  390. (* ctl toggles control bit: ^A becomes A, A becomes ^A *)
  391.  
  392.   begin
  393.     ctl := chr(xor(ord(ch),64))
  394.   end; (* ctl *)
  395.  
  396. procedure echo(ch: char);
  397.  
  398. (* echos a character on the screen *)
  399.  
  400.   begin
  401.     ch := chr(aand(ord(ch),127)); (* mask off parity bit *)
  402.     if ch <> chr(lf) then
  403.       begin
  404.         unitwrite(1,ch,1)
  405.       end (* if *)
  406.   end; (* echo *)
  407.  
  408. procedure clear_buf(*var q: queue*);
  409.  
  410. (* empties the buffer input buffer *)
  411.  
  412.   begin
  413.     q.outp := q.inp
  414.   end; (* clear_buf *)
  415.  
  416. function getfil(*filename: string): boolean*);
  417.  
  418. (* opens a file for writing *)
  419.  
  420.   begin
  421.     (*$I-*) (* turn i/o checking off *)
  422.     rewrite(f,filename);
  423.     (*$I-*) (* turn i/o checking on *)
  424.     getfil := (ioresult = 0)
  425.   end; (* getfil *)
  426.  
  427. procedure bufemp(*buffer: packettype; var f: text; len: integer*);
  428.  
  429. (* empties a packet into a file *)
  430.  
  431. var i,ls: integer;
  432.     r: char_int_rec;
  433.     s: string;
  434.  
  435.   begin
  436.     s := copy('',0,0);
  437.     ls := 0;
  438.     i := 0;
  439.     while i < len do
  440.       begin
  441.         r.ch := buffer[i];          (* get a character *)
  442.         if (r.ch = myquote) then    (* if character is control quote *)
  443.           begin
  444.             i := i + 1;               (* skip over quote and *)
  445.             r.ch := buffer[i];        (* get quoted character *)
  446.             if (aand(r.i,127) <> ord(myquote)) then
  447.                 r.ch := ctl(r.ch);    (* controllify it *)
  448.           end; (* if *)
  449.         if (r.i = cr) then          (* else if a carriage return then *)
  450.           begin
  451.             i := i + 3;               (* skip over that and line feed *)
  452.             (*$I-*)                   (* turn i/o checking off *)
  453.             writeln(f,s);             (* and write out line to file *)
  454.             s := copy('',0,0);        (* empty the string var *)
  455.             ls := 0;
  456.             if (io_result <> 0) then  (* if io_error *)
  457.               begin
  458.                 io_error(ioresult);     (* tell them and *)
  459.                 state := 'a';           (* abort *)
  460.               end (* if *)
  461.           end
  462.       (*$I+*)                      (* turn i/o checking back on *)
  463.       else                        (* else, is a regular char, so *)
  464.           begin
  465.             r.i := aand(r.i,127);     (* mask off parity bit *)
  466.             s := concat(s,' ');       (* and add character to out string *)
  467.             ls := ls + 1;
  468.             s[ls] := r.ch;
  469.             i := i + 1                (* increase buffer pointer *)
  470.           end; (* else *)
  471.       end; (* while *)              (* and get another char *)
  472.       (*$I-*)                     (* turn i/o checking off *)
  473.       write(f,s);                 (* and write out line to file *)
  474.       if (io_result <> 0) then    (* if io_error *)
  475.         begin
  476.           io_error(ioresult);       (* tell them and *)
  477.           state := 'a';             (* abort *)
  478.         end (* if *)
  479.       (*$I+*)                      (* turn i/o checking back on *)
  480.   end; (* bufemp *)
  481.  
  482. function bufill(*var buffer: packettype): integer*);
  483.  
  484. (* fill a packet with data from a file...manages a 2 block buffer *)
  485.  
  486. var i, j, k, t7, count: integer;
  487.     r: char_int_rec;
  488.  
  489.   begin
  490.     i := 0;
  491.     (* while file has some data & packet has some room we'll keep going *)
  492.     while ((bufpos <= bufend) or (not eof(oldf))) and (i < spsiz-9) do
  493.       begin
  494.         (* if we need more data from disk then *)
  495.         if (bufpos > bufend) and (not eof(oldf)) then
  496.           begin
  497.             (* read a couple of blocks *)
  498.             bufend := blockread(oldf,filebuf[1],2) * blksize;
  499.             (* and adjust buffer pointer *)
  500.             bufpos := 1
  501.           end; (* if *)
  502.         if (bufpos <= bufend) then     (* if we're within buffer bounds *)
  503.           begin
  504.             r.ch := filebuf[bufpos];      (* get a character *)
  505.             bufpos := bufpos + 1;         (* increase buffer pointer *)
  506.             if (r.i = dle) then           (* if it's space compression char, *)
  507.               begin
  508.                 count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
  509.                 bufpos := bufpos + 1;       (* read past # *)
  510.                 r.ch := ' ';                (* and make current char a space *)
  511.               end (* else if *)
  512.             else                           (* otherwise, it's just a char *)
  513.                 count := 1;                (* so only 1 copy of it *)
  514.             if (r.ch in ctlset) then     (* if a control char *)
  515.               begin
  516.                 if (r.i = cr) then         (* if a carriage return *)
  517.                   begin
  518.                     buffer[i] := quote;      (* put (quoted) CR in buffer *)
  519.                     i := i + 1;
  520.                     buffer[i] := ctl(chr(cr));
  521.                     i := i + 1;
  522.                     r.i := lf;                (* and we'll stick a LF after *)
  523.                   end; (* if *)
  524.                 if r.i <> 0 then           (* if not a NUL then *)
  525.                   begin
  526.                     buffer[i] := quote;      (* put the quote in buffer *)
  527.                     i := i + 1;
  528.                     if r.ch <> quote then
  529.                         r.ch := ctl(r.ch);   (* and un-controllify char *)
  530.                   end (* if *)
  531.               end; (* if *)
  532.           end; (* if *)
  533.         j := 1;
  534.         while (j <= count) and (i <= spsiz - 5) do
  535.           begin                           (* put all the chars in buffer *)
  536.             if (r.i <> 0) then            (* so long as not a NUL *)
  537.               begin
  538.                 buffer[i] := r.ch;
  539.                 i := i + 1;
  540.               end (* if *)
  541.             else                          (* is a NUL so *)
  542.                 if (bufpos > blksize) then  (* skip to end of block *)
  543.                     bufpos := bufend + 1    (* since rest will be NULs *)
  544.                 else
  545.                     bufpos := blksize + 1;
  546.             j := j + 1
  547.           end; (* while *)
  548.       end; (* while *)
  549.     if (i = 0) then                         (* if we're at end of file, *)
  550.         bufill := (at_eof)                    (* indicate it *)
  551.     else                                    (* else *)
  552.       begin
  553.         if (j <= count) then                  (* if didn't all fit in packet *)
  554.           begin
  555.             bufpos := bufpos - 2;               (* put buf pointer at DLE *)
  556.                                                 (* and update compress count *)
  557.             filebuf[bufpos + 1] := tochar(chr(count-j+1));
  558.           end; (* if *)
  559.         bufill := i                           (* return # of chars in packet *)
  560.       end; (* else *)
  561.   end; (* bufill *)
  562.  
  563. procedure spar(*var packet: packettype*);
  564.  
  565. (* fills data array with my send-init parameters *)
  566.  
  567.   begin
  568.     packet[0] := tochar(chr(maxpack));   (* biggest packet i can receive *)
  569.     packet[1] := tochar(chr(mytime));    (* when i want to be timed out *)
  570.     packet[2] := tochar(chr(mypad));     (* how much padding i need *)
  571.     packet[3] := ctl(chr(mypchar));      (* padding char i want *)
  572.     packet[4] := tochar(chr(myeol));     (* end of line character i want *)
  573.     packet[5] := myquote;                (* control-quote char i want *)
  574.     packet[6] := 'N';                    (* I won't do 8-bit quoting *)
  575.   end; (* spar *)
  576.  
  577. procedure rpar(*var packet: packettype*);
  578.  
  579. (* gets their init params *)
  580.  
  581.   begin
  582.     spsiz := ord(unchar(packet[0]));     (* max send packet size *)
  583.     timint := ord(unchar(packet[1]));    (* when i should time out *)
  584.     pad := ord(unchar(packet[2]));       (* number of pads to send *)
  585.     padchar := ctl(packet[3]);           (* padding char to send *)
  586.     eol := unchar(packet[4]);            (* eol char i must send *)
  587.     quote := packet[5];                  (* incoming data quote char *)
  588.   end; (* rpar *)
  589.  
  590. procedure packetwrite(p: packettype; len: integer);
  591.  
  592. (* writes out all of a packet for debugging purposes *)
  593.  
  594. var i: integer;
  595.  
  596.   begin
  597.     gotoxy(0,debugline);
  598.     for i := 0 to len+3 do
  599.       begin
  600.         if i = 80 then
  601.           begin
  602.             gotoxy(0,debugline+1);
  603.             write(chr(27),'K');
  604.           end; (* if *)
  605.         write(p[i])
  606.       end; (* for *)
  607.     for i := 1 to 2000 do ;
  608.   end; (* packetwrite *)
  609.  
  610. procedure spack(*ptype: char; num: integer; len: integer; data: packettype*);
  611.  
  612. (* send a packet *)
  613.  
  614. const maxtry = 10000;
  615.  
  616. var bufp, i, count: integer;
  617.     chksum: char;
  618.     buffer: packettype;
  619.     ch: char;
  620.  
  621.   begin
  622.     if ibm and (state <> 's') then           (* if ibm and not SINIT then *)
  623.       begin
  624.         count := 0;
  625.         repeat                                 (* wait for an xon *)
  626.             repeat
  627.                 count := count + 1
  628.             until (readch(rq,ch)) or (count > maxtry );
  629.         until (ch = xon) or (count > maxtry);
  630.         if count > maxtry then                 (* if wait too long then *)
  631.           begin
  632.             exit(spack)                          (* get out *)
  633.           end; (* if *)
  634.       end; (* if *)
  635.  
  636.     bufp := 0;
  637.     for i := 1 to pad do
  638.         unitwrite(oport,padchar,1);          (* write out any padding chars *)
  639.     buffer[bufp] := chr(soh);                (* packet sync character *)
  640.     bufp := bufp + 1;
  641.     chksum := tochar(chr(len + 3));          (* init chksum *)
  642.     buffer[bufp] := tochar(chr(len + 3));    (* character count *)
  643.     bufp := bufp + 1;
  644.     chksum := chr(ord(chksum) + ord(tochar(chr(num))));
  645.     buffer[bufp] := tochar(chr(num));
  646.     bufp := bufp + 1;
  647.     chksum := chr(ord(chksum) + ord(ptype));
  648.     buffer[bufp] := ptype;                   (* packet type *)
  649.     bufp := bufp + 1;
  650.  
  651.     for i := 0 to len - 1 do                 (* loop through data chars *)
  652.       begin
  653.         buffer[bufp] := data[i];             (* store char *)
  654.         bufp := bufp + 1;
  655.         chksum := chr(ord(chksum) + ord(data[i]))
  656.       end; (* for i *)
  657.                                              (* compute final chksum *)
  658.     chksum := chr(aand(ord(chksum) + (aand(ord(chksum),192) div 64), 63));
  659.     buffer[bufp] := tochar(chksum);
  660.     bufp := bufp + 1;
  661.     buffer[bufp] := eol;
  662.  
  663.     if (parity <> nopar) then
  664.         for i := 0 to bufp do                 (* set correct parity on buffer *)
  665.             buffer[i] := parity_array[buffer[i]];
  666.  
  667.     unitwrite(oport,buffer[0],bufp+1);        (* send the packet out *)
  668.  
  669.     if debug then
  670.         packetwrite(buffer,len);
  671.   end; (* spack *)
  672.  
  673. function read_ch(*var q: queue; var ch: char): boolean*);
  674.  
  675. (* read a character from an input queue *)
  676.  
  677.   begin
  678.     with q do
  679.       begin
  680.         if (inp <> outp) then            (* if a char there *)
  681.           begin
  682.             ch := data[outp];              (* get the char *)
  683.             outp := (outp + 1) mod qsize1; (* increment buffer pointer *)
  684.             read_ch := true;               (* and return true *)
  685.           end (* if *)
  686.         else                             (* otherwise *)
  687.             read_ch := false;              (* return false *)
  688.       end (* with *)
  689.   end; (* read_ch *)
  690.  
  691. function getch(*var r: char_int_rec; var q: queue): boolean*);
  692.  
  693. (* gets a character, strips parity, returns true if it got a char which *)
  694. (* isn't Kermit SOH, false if it gets SOH or nothing after maxtry *)
  695.  
  696. const maxtry = 10000;
  697.  
  698. var count: integer;
  699.  
  700.   begin
  701.     count := 0;
  702.     getch := false;
  703.     with q do
  704.       begin
  705.         repeat
  706.             count := count + 1;
  707.         until (inp <> outp) or (count > maxtry);    (* wait for a character *)
  708.         if (count > maxtry) then                    (* if wait too long then *)
  709.             exit(getch);                              (* get out of here *)
  710.         r.ch := data[outp];                         (* get the character *)
  711.         outp := (outp + 1) mod qsize1;              (* increment pointer *)
  712.         r.i := aand(r.i,127);                       (* strip parity from char *)
  713.         getch := (r.ch <> chr(soh));                (* return true if not SOH *)
  714.       end (* with *)
  715.   end; (* getch *)
  716.  
  717. function getsoh(*var q: queue): boolean*);
  718.  
  719. (* reads characters until it finds an SOH; returns false if has to read more *)
  720. (* than maxtry chars *)
  721.  
  722. const maxtry = 10000;
  723.  
  724. var ch: char;
  725.     count: integer;
  726.  
  727.   begin
  728.     count := 0;
  729.     get_soh := true;
  730.     with q do
  731.       begin
  732.         repeat
  733.             repeat
  734.                 count := count + 1
  735.             until (inp <> outp) or (count > maxtry); (* wait for a character *)
  736.             if (count > maxtry) then
  737.               begin
  738.                 get_soh := false;
  739.                 exit(get_soh)
  740.               end; (* if *)
  741.             ch := data[outp];                        (* get the character *)
  742.             outp := (outp + 1) mod qsize1;           (* increment pointer *)
  743.             ch := chr(aand(ord(ch),127));            (* strip parity of char *)
  744.         until (ch = chr(SOH))                        (* if not SOH, get more *)
  745.     end (* with q *)
  746.   end; (* getsoh *)
  747.  
  748. (*$G+*) (* turn on goto option...need it for next routine *)
  749.  
  750. function rpack(*var len, num: integer; var data: packettype): char*);
  751.  
  752. (* read a packet *)
  753.  
  754. label 1; (* used to emulate C's CONTINUE statement *)
  755.  
  756. const maxtry = 10000;
  757.  
  758. var count, i, ichksum: integer;
  759.     chksum, ptype: char;
  760.     r: char_int_rec;
  761.  
  762.   begin
  763.     count := 0;
  764.  
  765.     if not getsoh(rq) and (state<>'r') then (*if don't get synch char then *)
  766.       begin
  767.         rpack := 'N';                        (* treat as a NAK *)
  768.         num := n mod 64;
  769.         exit(rpack)                          (* and get out of here *)
  770.       end;
  771.  
  772.   1: count := count + 1;
  773.      if (count>maxtry)and(state<>'r') then (* if we've tried too many times *)
  774.         begin                               (* and aren't waiting for init *)
  775.           rpack := 'N';                      (* treat as NAK *)
  776.           exit(rpack)                        (* and get out of here *)
  777.         end; (* if *)
  778.  
  779.     if not getch(r,rq) then                (* get a char and *)
  780.             goto 1;                        (* resynch if soh *)
  781.  
  782.     ichksum := r.i;                        (* start checksum *)
  783.     len := ord(unchar(r.ch)) - 3;          (* character count *)
  784.  
  785.     if not getch(r,rq) then                (* get a char and *)
  786.         goto 1;                            (* resynch if soh *)
  787.     ichksum := ichksum + r.i;
  788.     num := ord(unchar(r.ch));              (* packet number *)
  789.  
  790.     if not getch(r,rq) then                (* get a char and *)
  791.         goto 1;                            (* resynch if soh *)
  792.     ichksum := ichksum + r.i;
  793.     ptype := r.ch;                         (* packet type *)
  794.  
  795.     for i := 0 to len-1 do                 (* get any data *)
  796.       begin
  797.         if not getch(r,rq) then            (* get a char and *)
  798.             goto 1;                        (* resynch if soh *)
  799.         ichksum := ichksum + r.i;
  800.         data[i] := r.ch;
  801.       end; (* for i *)
  802.     data[len] := chr(0);                   (* mark end of data *)
  803.  
  804.     if not getch(r,rq) then                (* get a char and *)
  805.         goto 1;                            (* resynch if soh *)
  806.  
  807.                                            (* compute final checksum *)
  808.     chksum := chr(aand(ichksum + (aand(ichksum,192) div 64), 63));
  809.  
  810.     if (chksum <> unchar(r.ch)) then       (* if checksum bad *)
  811.         rpack := chr(0)                      (* return 'false' indicator *)
  812.     else                                   (* else *)
  813.         rpack := ptype;                      (* return packet type *)
  814.  
  815.     if debug then
  816.       begin
  817.         gotoxy(0,debugline);
  818.         write(len,num,ptype);
  819.         for i := 1 to 1000 do
  820.             ;
  821.       end; (* if *)
  822.   end; (* rpack *)
  823.  
  824. (*$G-*) (* turn off goto option...don't need it anymore *)
  825.  
  826. procedure connect;
  827.  
  828. (* connect to remote host (terminal emulation *)
  829.  
  830. var ch: char;
  831.     close: boolean;
  832.  
  833.   procedure read_esc;
  834.  
  835.   (* read charcter after esc char and interpret it *)
  836.  
  837.     begin
  838.       repeat
  839.       until read_ch(kq,ch);       (* wait until they've typed something in *)
  840.       if (ch in ['a'..'z']) then  (* uppercase it *)
  841.           ch := chr(ord(ch) - ord('a') + ord('A'));
  842.       if ch in ['B','C','S','?'] then
  843.           case ch of
  844.               'B': sendbrk;       (* B: send a break to the IBM *)
  845.               'C': close := true; (* C: end connection *)
  846.               'S': begin          (* S: show status *)
  847.                   noun := allsym;
  848.                   showparms
  849.                 end; (* S *)
  850.               '?': begin          (* ?: show options *)
  851.                   writeln('B    Send a BREAK signal.');
  852.                   write('C    Close Connection, return to ');
  853.                   writeln('KERMIT-UCSD command level.');
  854.                   writeln('S    Show Status of connection');
  855.                   writeln('?    Print this list');
  856.                   write('^',esc_char,'   send the escape ');
  857.                   writeln('character itself to the');
  858.                   writeln('     remote host.')
  859.                 end; (* ? *)
  860.             end (* case *)
  861.       else if ch = esc_char then  (* ESC-char: send it out *)
  862.         begin
  863.           if half_duplex then
  864.             begin
  865.               echo(ch);
  866.               unitwrite(oport,ch,1)
  867.             end (* if *)
  868.         end (* else if *)
  869.       else                        (* anything else: ignore *)
  870.           write(chr(bell))
  871.     end; (* read_esc *)
  872.  
  873.   begin (* connect *)
  874.     clear_buf(kq);                    (* empty keyboard buffer *)
  875.     clear_buf(rq);                    (* empty remote input buffer *)
  876.     writeln('Connecting to host...type CTRL-',ctl(esc_char),' C to exit');
  877.     close := false;
  878.     repeat
  879.         if read_ch(rq,ch) then        (* if char from host then *)
  880.             echo(ch);                   (* echo it *)
  881.  
  882.         if read_ch(kq,ch) then        (* if char from keyboard then *)
  883.             if ch <> esc_char then      (* if not ESC-char then *)
  884.               begin
  885.                 if half_duplex then       (* echo it if half-duplex *)
  886.                     echo(ch);
  887.                 unitwrite(oport,ch,1)     (* send it out the port *)
  888.               end (* if *)
  889.             else (* ch = esc_char *)    (* else is ESC-char so *)
  890.               read_esc;                   (* interpret next char *)
  891.     until close;                      (* if still connected, get more *)
  892.     writeln('Disconnected')
  893.   end; (* connect *)
  894.  
  895. procedure fill_parity_array;
  896.  
  897. (* parity value table for even parity...not(entry) = odd parity *)
  898.  
  899. const min = 0;
  900.       max = 126;
  901.  
  902. var i, shifter, counter: integer;
  903.     minch, maxch, ch: char;
  904.     r: char_int_rec;
  905.  
  906.   begin
  907.     minch := chr(min);
  908.     maxch := chr(max);
  909.     case parity of
  910.       evenpar:
  911.         begin
  912.           for ch := minch to maxch do
  913.             begin
  914.               r.ch := ch;               (* put char into variant record *)
  915.               shifter := aand(r.i,255); (* mask off parity bit *)
  916.               counter := 0;
  917.               for i := 1 to 7 do        (* count the 1's *)
  918.                 begin
  919.                   if odd(shifter) then
  920.                       counter := counter + 1;
  921.                   shifter := shifter div 2
  922.                 end; (* for i *)
  923.               if odd(counter) then       (* stick a 1 on if necessary *)
  924.                   parity_array[ch] := chr(aor(ord(ch),128))
  925.               else
  926.                   parity_array[ch] := chr(aand(ord(ch),127))
  927.             end; (* for ch *)
  928.         end; (* case even *)
  929.       oddpar:
  930.         begin
  931.           for ch := minch to maxch do
  932.             begin
  933.               r.ch := ch;                (* put char into variant record *)
  934.               shifter := aand(r.i,255);  (* mask off parity bit *)
  935.               counter := 0;
  936.               for i := 1 to 7 do         (* count the 1's *)
  937.                 begin
  938.                   if odd(shifter) then
  939.                       counter := counter + 1;
  940.                   shifter := shifter div 2
  941.                 end; (* for i *)
  942.               if odd(counter) then        (* stick a 1 on if necessary *)
  943.                   parity_array[ch] := chr(aand(ord(ch),127))
  944.               else
  945.                   parity_array[ch] := chr(aor(ord(ch),128))
  946.             end; (* for ch *)
  947.         end; (* case odd *)
  948.       markpar:
  949.           for ch := minch to maxch do     (* stick a 1 on all chars *)
  950.               parity_array[ch] := chr(aor(ord(ch),128));
  951.       spacepar:
  952.           for ch := minch to maxch do     (* mask off parity on all chars *)
  953.               parity_array[ch] := chr(aand(ord(ch),127));
  954.       nopar:
  955.           for ch := minch to maxch do     (* don't mess w/parity bit at all *)
  956.               parity_array[ch] := ch;
  957.     end; (* case *)
  958.   end; (* fill_parity_array *)
  959.  
  960. procedure write_bool(s: string; b: boolean);
  961.  
  962. (* writes message & 'on' if b, 'off' if not b *)
  963.   begin
  964.     write(s);
  965.     case b of
  966.         true: writeln('on');
  967.         false: writeln('off');
  968.       end; (* case *)
  969.   end; (* write_bool *)
  970.  
  971. procedure show_parms;
  972.  
  973. (* shows the various settable parameters *)
  974.  
  975.   begin
  976.     case noun of
  977.         allsym:
  978.           begin
  979.             write_bool('Debugging is ',debug);
  980.             writeln('Escape character is ^',ctl(esc_char));
  981.             write_bool('File warning is ',fwarn);
  982.             write_bool('IBM is ',ibm);
  983.             write_bool('Local echo is ',halfduplex);
  984.             case parity of
  985.                 evenpar: write('Even');
  986.                 markpar: write('Mark');
  987.                 nopar: write('No');
  988.                 oddpar: write('Odd');
  989.                 spacepar: write('Space');
  990.               end; (* case *)
  991.             writeln(' parity');
  992.           end; (* allsym *)
  993.         debugsym: write_bool('Debugging is ',debug);
  994.         escsym: writeln('Escape character is ^',ctl(esc_char));
  995.         filewarnsym: write_bool('File warning is ',fwarn);
  996.         ibmsym: write_bool('IBM is ',ibm);
  997.         localsym: write_bool('Local echo is ',halfduplex);
  998.         paritysym: begin
  999.             case parity of
  1000.                 evenpar: write('Even');
  1001.                 markpar: write('Mark');
  1002.                 nopar: write('No');
  1003.                 oddpar: write('Odd');
  1004.                 spacepar: write('Space');
  1005.               end; (* case *)
  1006.             writeln(' parity');
  1007.            end; (* paritysym *)
  1008.       end; (* case *)
  1009.   end; (* show_sym *)
  1010.  
  1011. procedure set_parms;
  1012.  
  1013. (* sets the parameters *)
  1014.  
  1015.   begin
  1016.     case noun of
  1017.         debugsym: case adj of
  1018.                       onsym: begin
  1019.                           debug := true;
  1020.                           (*$I-*)
  1021.                           rewrite(debf,'CONSOLE:')
  1022.                           (*I+*)
  1023.                         end; (* onsym *)
  1024.                       offsym: debug := false
  1025.                     end; (* case adj *)
  1026.         escsym: escchar := newescchar;
  1027.         filewarnsym: fwarn := (adj = onsym);
  1028.         ibmsym: case adj of
  1029.                     onsym: begin
  1030.                         ibm := true;
  1031.                         parity := markpar;
  1032.                         half_duplex := true;
  1033.                         fillparityarray
  1034.                       end; (* onsym *)
  1035.                     offsym: begin
  1036.                         ibm := false;
  1037.                         parity := nopar;
  1038.                         half_duplex := false;
  1039.                         fillparityarray
  1040.                       end; (* onsym *)
  1041.                   end; (* case adj *)
  1042.         localsym: halfduplex := (adj = onsym);
  1043.         paritysym: begin
  1044.               case adj of
  1045.                   evensym: parity := evenpar;
  1046.                   marksym: parity := markpar;
  1047.                   nonesym: parity := nopar;
  1048.                   oddsym: parity := oddpar;
  1049.                   spacesym: parity := spacepar;
  1050.                 end; (* case *)
  1051.               fill_parity_array;
  1052.              end; (* paritysym *)
  1053.       end; (* case *)
  1054.   end; (* set_parms *)
  1055.  
  1056. procedure initialize;
  1057.  
  1058. var ch: char;
  1059.  
  1060.   begin
  1061.     pad := mypad;
  1062.     padchar := chr(mypchar);
  1063.     eol := chr(my_eol);
  1064.     esc_char := chr(my_esc);
  1065.     quote := my_quote;
  1066.     ctlset := [chr(1)..chr(31),chr(del),quote];
  1067.     half_duplex := false;
  1068.     debug := false;
  1069.     fwarn := false;
  1070.     spsiz := max_pack;
  1071.     rpsiz := max_pack;
  1072.     n := 0;
  1073.     parity := nopar;
  1074.     initvocab;
  1075.     fill_parity_array;
  1076.     ibm := false;
  1077.     xon := chr(17);
  1078.     bufpos := 1;
  1079.     bufend := 0;
  1080.     rcvinit(rq,rqsize);
  1081.     kbdinit(kq,rqsize);
  1082.   end; (* initialize *)
  1083.  
  1084. procedure closeup;
  1085.  
  1086.   begin
  1087.     kbdfinit;
  1088.     rcvfinit;
  1089.     writeln(chr(clear_screen))
  1090.   end; (* closeup *)
  1091.  
  1092.   begin (* kermit *)
  1093.     initialize;
  1094.     repeat
  1095.         write('Kermit-UCSD> ');
  1096.         readstr(kq,line);
  1097.         case parse of
  1098.             unconfirmed: writeln('Unconfirmed');
  1099.             parm_expected: writeln('Parameter expected');
  1100.             ambiguous: writeln('Ambiguous');
  1101.             unrec: writeln('Unrecognized command');
  1102.             fn_expected: writeln('File name expected');
  1103.             ch_expected: writeln('Single character expected');
  1104.             null: case verb of
  1105.                       consym: connect;
  1106.                       helpsym: help;
  1107.                       recsym: begin
  1108.                           recsw(rec_ok);
  1109.                           gotoxy(0,debugline);
  1110.                           write(chr(bell));
  1111.                           if rec_ok then
  1112.                               writeln('successful receive')
  1113.                           else
  1114.                               writeln('unsuccessful receive');
  1115.                           (*$I-*) (* set i/o checking off *)
  1116.                           close(oldf);
  1117.                           (*$I+*) (* set i/o checking back on *)
  1118.                           gotoxy(0,promptline);
  1119.                         end; (* recsym *)
  1120.                       sendsym: begin
  1121.                           uppercase(filename);
  1122.                           sendsw(send_ok);
  1123.                           gotoxy(0,debugline);
  1124.                           write(chr(bell));
  1125.                           if send_ok then
  1126.                               writeln('successful send')
  1127.                           else
  1128.                               writeln('unsuccessful send');
  1129.                           (*$I-*) (* set i/o checking off *)
  1130.                           close(oldf);
  1131.                           (*$I+*) (* set i/o checking back on *)
  1132.                           gotoxy(0,promptline);
  1133.                         end; (* sendsym *)
  1134.                       setsym: set_parms;
  1135.                       show_sym: show_parms;
  1136.                   end; (* case verb *)
  1137.         end; (* case parse *)
  1138.      until (verb = exitsym) or (verb = quitsym);
  1139.      closeup
  1140.    end. (* kermit *)
  1141.