home *** CD-ROM | disk | FTP | other *** search
/ kermit.columbia.edu / kermit.columbia.edu.tar / kermit.columbia.edu / ucsdmagiscan2 / utils.txt < prev   
Text File  |  2011-08-11  |  8KB  |  272 lines
  1.  
  2. function ready(p:port):boolean;
  3. begin
  4.   ready:= ((p=terminal) and (not IoStatus(2))) or ((p=modem) and istbrr);
  5. end;
  6.  
  7. function pget(p:port):char;
  8. begin
  9.   if p=terminal then pget := chr( aand(IORead(80),127) ) { get from the keyboard }
  10.   else pget :=rcvbbt;
  11. end;
  12.  
  13. procedure read_str(*var p: port; var s: string*);
  14.  
  15. (* acts like readln(s) but takes input from specified port *)
  16.  
  17. var i: integer;
  18.  
  19.   begin
  20.     i := 0;
  21.     s := copy('',0,0);
  22.     repeat
  23.       repeat                              (* get a character *)
  24.       until ready(p);
  25.       ch:=pget(p);
  26.       if (ord(ch) = backspace) then       (* if it's a backspace then *)
  27.         begin
  28.           if (i > 0) then                   (* if not at beginning of line *)
  29.             begin
  30.               write(ch);                      (* go back a space on screen *)
  31.               write(' ');                     (* erase char on screen *)
  32.               write(ch);                      (* go back a space again *)
  33.               i := i - 1;                     (* adjust string counter *)
  34.               s := copy(s,1,i)                (* adjust string *)
  35.             end (* if *)
  36.         end (* if *)
  37.       else if (ord(ch) <> eoln_sym) then  (* otherwise if not at eoln  then *)
  38.         begin
  39.           write(ch);                        (* echo char on screen *)
  40.           i := i + 1;                       (* inc string counter *)
  41.           s := concat(s,' ');
  42.           s[i] := ch;                       (* put char in string *)
  43.         end; (* if *)
  44.     until (ord(ch) = eoln_sym);           (* if not eoln, get another char *)
  45.     s := copy(s,1,i);                     (* correct string length *)
  46.     writeln                               (* write a line on the screen *)
  47.   end; (* read_str *)
  48.  
  49. function read_ch(*p: port; var ch: char): boolean*);
  50.  
  51. (* read a character from an input port *)
  52.  
  53.   begin
  54.   if ready(p) then            (* if a char there *)
  55.     begin
  56.       ch := pget(p);      (* get the char *)
  57.       read_ch := true;               (* and return true *)
  58.     end (* if *)
  59.   else                             (* otherwise *)
  60.       read_ch := false;              (* return false *)
  61.   end; (* read_ch *)
  62.  
  63. function getch(*var r: char; p: port): boolean*);
  64.  
  65. (* gets a character, strips parity, returns true if it got a char which *)
  66. (* isn't Kermit SOH, false if it gets SOH or nothing after maxtry *)
  67.  
  68. const maxtry = 10000;
  69.  
  70. var count: integer;
  71.  
  72.   begin
  73.     count := 0;
  74.     getch := false;
  75.     repeat
  76.         count := count + 1;
  77.     until ready(p) or (count > maxtry);         (* wait for a character *)
  78.     if (count > maxtry) then                    (* if wait too long then *)
  79.         begin
  80.         getch := false; { act as if SOH ! }
  81.         exit(getch)                             (* get out of here *)
  82.         end;
  83.     r:=pget(p);                                 (* get the character *)
  84.     r := chr(aand(ord(r),127));                 (* strip parity from char *)
  85.     getch := (r <> chr(soh));                   (* return true if not SOH *)
  86.   end; (* getch *)
  87.  
  88.  
  89. function aand(*x,y: integer): integer*);
  90.  
  91. (* arithmetic and--takes 2 integers and ands them, yeilding an integer *)
  92.  
  93. var xrec, yrec, temp: int_bool_rec;
  94.  
  95.   begin
  96.     xrec.i := x;                  (* put the two numbers in variant record *)
  97.     yrec.i := y;
  98.     temp.b := xrec.b * yrec.b;  (* use as sets to 'and' them *)
  99.     aand := temp.i                (* return integer result *)
  100.   end; (* aand *)
  101.  
  102. function aor(*x,y: integer): integer*);
  103.  
  104. (* arithmetic or *)
  105.  
  106. var xrec, yrec, temp: int_bool_rec;
  107.  
  108.   begin
  109.     xrec.i := x;                  (* put two numbers in variant record *)
  110.     yrec.i := y;
  111.     temp.b := xrec.b + yrec.b;   (* use as sets to 'or' them *)
  112.     aor := temp.i                 (* return integer result *)
  113.   end; (* aor *)
  114.  
  115. function xor(*x,y: integer): integer*);
  116.  
  117. (* exclisive or *)
  118.  
  119. var xrec, yrec, temp: int_bool_rec;
  120.  
  121.   begin
  122.     xrec.i := x;                  (* put two numbers in variant record *)
  123.     yrec.i := y;
  124.                                   (* use as sets to 'xor' them *)
  125.     temp.b := (xrec.b - yrec.b) + (yrec.b - xrec.b);
  126.     xor := temp.i                 (* return integer result *)
  127.   end; (* xor *)
  128.  
  129. procedure error(*p: packettype; len: integer*);
  130.  
  131. (* writes error message sent by remote host *)
  132.  
  133. var i: integer;
  134.  
  135.   begin
  136.     gotoxy(0,errorline);
  137.     for i := 0 to len-1 do
  138.         write(p[i]);
  139.     gotoxy(0,promptline);
  140.   end; (* error *)
  141.  
  142. procedure ino_error(*i: integer*);
  143.  
  144.   begin
  145.     gotoxy(0,errorline);
  146.     writeln;         (* erase to end of line *)
  147.     gotoxy(0,errorline);
  148.     case i of
  149.         0: writeln('No error');
  150.         1: writeln('Bad Block, Parity error (CRC)');
  151.         2: writeln('Bad Unit Number');
  152.         3: writeln('Bad Mode, Illegal operation');
  153.         4: writeln('Undefined hardware error');
  154.         5: writeln('Lost unit, Unit is no longer on-line');
  155.         6: writeln('Lost file, File is no longer in directory');
  156.         7: writeln('Bad Title, Illegal file name');
  157.         8: writeln('No room, insufficient space');
  158.         9: writeln('No unit, No such volume on line');
  159.         10: writeln('No file, No such file on volume');
  160.         11: writeln('Duplicate file');
  161.         12: writeln('Not closed, attempt to open an open file');
  162.         13: writeln('Not open, attempt to close a closed file');
  163.         14: writeln('Bad format, error in reading real or integer');
  164.         15: writeln('Ring buffer overflow')
  165.       end; (* case *)
  166.     gotoxy(0,promptline)
  167.   end; (* ino_error *)
  168.  
  169. procedure debugwrite(*s: string*);
  170.  
  171. (* writes a debugging message *)
  172. var i: integer;
  173.  
  174.   begin
  175.     if debug then
  176.       begin
  177.         gotoxy(0,debugline+debnext);
  178.         writeln;
  179.         gotoxy(0,debugline+debnext);
  180.         debnext:=(debnext+1) mod debug_max;
  181.         write(s);                   (* write debugging message *)
  182.       end (* if debug *)
  183.   end; (* debugwrite *)
  184.  
  185. procedure debugint(*s: string; i: integer*);
  186.  
  187. (* write a debugging message and an integer *)
  188.  
  189.   begin
  190.     if debug then
  191.       begin
  192.         debugwrite(s);
  193.         write(i)
  194.       end (* if debug *)
  195.   end; (* debugint *)
  196.  
  197. procedure writescreen(*s: string*);
  198.  
  199. (* sets up the screen for receiving or sending files *)
  200.  
  201.   begin
  202.     write(chr(ff){clearscreen});
  203.     gotoxy(0,titleline);
  204.     write('                        Kermit UCSD p-system');
  205.     gotoxy(statuspos,statusline);
  206.     write(s);
  207.     gotoxy(0,packetline);
  208.     write('Number of Packets: ');
  209.     gotoxy(0,retryline);
  210.     write('Number of Tries: ');
  211.     gotoxy(0,fileline);
  212.     write('File Name: ');
  213.   end; (* writescreen *)
  214.  
  215. procedure refresh_screen(*numtry, num: integer*);
  216.  
  217. (* keeps track of packet count on screen *)
  218.  
  219.   begin
  220.     gotoxy(retrypos,retryline);
  221.     write(numtry: 5);
  222.     gotoxy(packetpos,packetline);
  223.     write(num: 5)
  224.   end; (* refresh_screen *)
  225.  
  226. function min(*x,y: integer): integer*);
  227.  
  228. (* returns smaller of two integers *)
  229.  
  230.   begin
  231.     if x < y then
  232.         min := x
  233.     else
  234.         min := y
  235.   end; (* min *)
  236.  
  237. function tochar(*ch: char): char*);
  238.  
  239. (* tochar converts a control character to a printable one by adding space *)
  240.  
  241.   begin
  242.     tochar := chr(ord(ch) + ord(' '))
  243.   end; (* tochar *)
  244.  
  245. function unchar(*ch: char): char*);
  246.  
  247. (* unchar undoes tochar *)
  248.  
  249.   begin
  250.     unchar := chr(ord(ch) - ord(' '))
  251.   end; (* unchar *)
  252.  
  253. function ctl(*ch: char): char*);
  254.  
  255. (* ctl toggles control bit: ^A becomes A, A becomes ^A *)
  256.  
  257.   begin
  258.     ctl := chr(xor(ord(ch),64))
  259.   end; (* ctl *)
  260.  
  261. procedure echo(ch: char);
  262.  
  263. (* echos a character on the screen *)
  264.  
  265.   begin
  266.     ch := chr(aand(ord(ch),127)); (* mask off parity bit *)
  267.     repeat until ISTATR;
  268.     sndabt(ch)
  269.   end; (* echo *)
  270.  
  271.  
  272.