home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / archives / ucsdwdme.zip / rsutils.text < prev    next >
Text File  |  1984-12-03  |  15KB  |  403 lines
  1. function getfil(*filename: string): boolean*);
  2.  
  3. (* opens a file for writing *)
  4.  
  5.   begin
  6.     (*$I-*) (* turn i/o checking off *)
  7.     rewrite(f,filename);
  8.     (*$I-*) (* turn i/o checking on *)
  9.     getfil := (ioresult = 0)
  10.   end; (* getfil *)
  11.  
  12. procedure bufemp(*buffer: packettype; var f: text; len: integer*);
  13.  
  14. (* empties a packet into a file *)
  15.  
  16. var i,ls: integer;
  17.     r: char;
  18.     s: string;
  19.  
  20.   begin
  21.     s := copy('',0,0);
  22.     ls := 0;
  23.     i := 0;
  24.     while i < len do
  25.       begin
  26.         r := buffer[i];          (* get a character *)
  27.         if (r = myquote) then    (* if character is control quote *)
  28.           begin
  29.             i := i + 1;               (* skip over quote and *)
  30.             r := buffer[i];        (* get quoted character *)
  31.             if (aand(ord(r),127) <> ord(myquote)) then
  32.                 r := ctl(r);       (* controllify it *)
  33.           end; (* if *)
  34.         if (ord(r) = cr) then          (* else if a carriage return then *)
  35.           begin
  36.             i := i + 3;               (* skip over that and line feed *)
  37.             (*$I-*)                   (* turn i/o checking off *)
  38.             writeln(f,s);             (* and write out line to file *)
  39.             s := copy('',0,0);        (* empty the string var *)
  40.             ls := 0;
  41.             if (io_result <> 0) then  (* if io_error *)
  42.               begin
  43.                 io_error(ioresult);     (* tell them and *)
  44.                 state := 'a';           (* abort *)
  45.               end (* if *)
  46.           end
  47.       (*$I+*)                      (* turn i/o checking back on *)
  48.       else                        (* else, is a regular char, so *)
  49.           begin
  50.             r:= chr(aand(ord(r),127));     (* mask off parity bit *)
  51.             s := concat(s,' ');       (* and add character to out string *)
  52.             ls := ls + 1;
  53.             s[ls] := r;
  54.             i := i + 1                (* increase buffer pointer *)
  55.           end; (* else *)
  56.       end; (* while *)              (* and get another char *)
  57.       (*$I-*)                     (* turn i/o checking off *)
  58.       write(f,s);                 (* and write out line to file *)
  59.       if (io_result <> 0) then    (* if io_error *)
  60.         begin
  61.           io_error(ioresult);       (* tell them and *)
  62.           state := 'a';             (* abort *)
  63.         end (* if *)
  64.       (*$I+*)                      (* turn i/o checking back on *)
  65.   end; (* bufemp *)
  66.  
  67. function bufill(*var buffer: packettype): integer*);
  68.  
  69. (* fill a packet with data from a file...manages a 2 block buffer *)
  70.  
  71. var i, j, k, t7, count: integer;
  72.     r: char;
  73.  
  74.   begin
  75.     i := 0;
  76.     (* while file has some data & packet has some room we'll keep going *)
  77.     while ((bufpos <= bufend) or (not eof(oldf))) and (i < spsiz-9) do
  78.       begin
  79.         (* if we need more data from disk then *)
  80.         if (bufpos > bufend) and (not eof(oldf)) then
  81.           begin
  82.             (* read a couple of blocks *)
  83.             bufend := blockread(oldf,filebuf[1],2) * blksize;
  84.             (* and adjust buffer pointer *)
  85.             bufpos := 1
  86.           end; (* if *)
  87.         if (bufpos <= bufend) then     (* if we're within buffer bounds *)
  88.           begin
  89.             r := filebuf[bufpos];      (* get a character *)
  90.             bufpos := bufpos + 1;         (* increase buffer pointer *)
  91.             if (ord(r) = dle) then           (* if it's space compression char, *)
  92.               begin
  93.                 count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
  94.                 bufpos := bufpos + 1;       (* read past # *)
  95.                 r := ' ';                (* and make current char a space *)
  96.               end (* else if *)
  97.             else                           (* otherwise, it's just a char *)
  98.                 count := 1;                (* so only 1 copy of it *)
  99.             if (r in ctlset) then     (* if a control char *)
  100.               begin
  101.                 if (ord(r) = cr) then         (* if a carriage return *)
  102.                   begin
  103.                     buffer[i] := quote;      (* put (quoted) CR in buffer *)
  104.                     i := i + 1;
  105.                     buffer[i] := ctl(chr(cr));
  106.                     i := i + 1;
  107.                     r := chr(lf);            (* and we'll stick a LF after *)
  108.                   end; (* if *)
  109.                 if r <> chr(0) then          (* if not a NUL then *)
  110.                   begin
  111.                     buffer[i] := quote;      (* put the quote in buffer *)
  112.                     i := i + 1;
  113.                     if r <> quote then
  114.                         r := ctl(r);   (* and un-controllify char *)
  115.                   end (* if *)
  116.               end; (* if *)
  117.           end; (* if *)
  118.         j := 1;
  119.         while (j <= count) and (i <= spsiz - 5) do
  120.           begin                           (* put all the chars in buffer *)
  121.             if (ord(r) <> 0) then            (* so long as not a NUL *)
  122.               begin
  123.                 buffer[i] := r;
  124.                 i := i + 1;
  125.               end (* if *)
  126.             else                          (* is a NUL so *)
  127.                 if (bufpos > blksize) then  (* skip to end of block *)
  128.                     bufpos := bufend + 1    (* since rest will be NULs *)
  129.                 else
  130.                     bufpos := blksize + 1;
  131.             j := j + 1
  132.           end; (* while *)
  133.       end; (* while *)
  134.     if (i = 0) then                         (* if we're at end of file, *)
  135.         bufill := (at_eof)                    (* indicate it *)
  136.     else                                    (* else *)
  137.       begin
  138.         if (j <= count) then                  (* if didn't all fit in packet *)
  139.           begin
  140.             bufpos := bufpos - 2;               (* put buf pointer at DLE *)
  141.                                                 (* and update compress count *)
  142.             filebuf[bufpos + 1] := tochar(chr(count-j+1));
  143.           end; (* if *)
  144.         bufill := i                           (* return # of chars in packet *)
  145.       end; (* else *)
  146.   end; (* bufill *)
  147.  
  148. procedure spar(*var packet: packettype*);
  149.  
  150. (* fills data array with my send-init parameters *)
  151.  
  152.   begin
  153.     packet[0] := tochar(chr(maxpack));   (* biggest packet i can receive *)
  154.     packet[1] := tochar(chr(mytime));    (* when i want to be timed out *)
  155.     packet[2] := tochar(chr(mypad));     (* how much padding i need *)
  156.     packet[3] := ctl(chr(mypchar));      (* padding char i want *)
  157.     packet[4] := tochar(chr(myeol));     (* end of line character i want *)
  158.     packet[5] := myquote;                (* control-quote char i want *)
  159.     packet[6] := 'N';                    (* I won't do 8-bit quoting *)
  160.   end; (* spar *)
  161.  
  162. procedure rpar(*var packet: packettype*);
  163.  
  164. (* gets their init params *)
  165. var s:string;
  166.   begin
  167.     s:='rpar:spsize:## timint:## pad:## padchar:### eol:### quote:###';
  168.     spsiz := ord(unchar(packet[0]));     (* max send packet size *)
  169.     s[13]:=chr(ord('0')+(spsiz div 10));
  170.     s[14]:=chr(ord('0')+(spsiz mod 10));
  171.     timint := ord(unchar(packet[1]));    (* when i should time out *)
  172.     s[23]:=chr(ord('0')+(timint div 10));
  173.     s[24]:=chr(ord('0')+(timint mod 10));
  174.     pad := ord(unchar(packet[2]));       (* number of pads to send *)
  175.     s[30]:=chr(ord('0')+(pad div 10));
  176.     s[31]:=chr(ord('0')+(pad mod 10));
  177.     padchar := ctl(packet[3]);           (* padding char to send *)
  178.     s[41]:=chr(ord('0')+(ord(padchar) div 100));
  179.     s[42]:=chr(ord('0')+((ord(padchar) mod 100) div 10));
  180.     s[43]:=chr(ord('0')+(ord(padchar) mod 10));
  181.     eol := unchar(packet[4]);            (* eol char i must send *)
  182.     s[49]:=chr(ord('0')+(ord(eol) div 100));
  183.     s[50]:=chr(ord('0')+((ord(eol) mod 100) div 10));
  184.     s[51]:=chr(ord('0')+(ord(eol) mod 10));
  185.     quote := packet[5];                  (* incoming data quote char *)
  186.     s[59]:=chr(ord('0')+(ord(quote) div 100));
  187.     s[60]:=chr(ord('0')+((ord(quote) mod 100) div 10));
  188.     s[61]:=chr(ord('0')+(ord(quote) mod 10));
  189.     debugwrite(s);
  190.   end; (* rpar *)
  191.  
  192. procedure packetwrite(*p: packettype; len: integer*);
  193.  
  194. (* writes out all of a packet for debugging purposes *)
  195.  
  196. var i: integer;
  197.     s: string;
  198.   begin
  199.     s:='length:## Sequence:## Type: #';
  200.     if p[0]=chr(soh) then s:=concat('SOH ',s);
  201.     s[8]:=chr(ord('0')+(ord(p[1]) div 10));
  202.     s[9]:=chr(ord('0')+(ord(p[1]) mod 10));
  203.     s[20]:=chr(ord('0')+(ord(p[2]) div 10));
  204.     s[21]:=chr(ord('0')+(ord(p[2]) mod 10));
  205.     s[length(s)]:=p[3];
  206.     debugwrite(s);
  207.     gotoxy(0,debugline+debnext);
  208.     debnext:=(debnext+1) mod debug_max;
  209.     for i := 4 to len+3 do
  210.       begin
  211.         if i = 84 then
  212.           begin
  213.             gotoxy(0,debugline+debnext);
  214.             debnext:=(debnext+1) mod debug_max;
  215.             write(chr(27),'K');
  216.           end; (* if *)
  217.         write(p[i])
  218.       end; (* for *)
  219.   end; (* packetwrite *)
  220.  
  221. procedure spack(*ptype: char; num: integer; len: integer; data: packettype*);
  222.  
  223. (* send a packet *)
  224.  
  225. const maxtry = 10000;
  226.  
  227. var bufp, i, count: integer;
  228.     chksum: char;
  229.     buffer: packettype;
  230.     ch: char;
  231.  
  232.   begin
  233.     if ibm and (state <> 's') then           (* if ibm and not SINIT then *)
  234.       begin
  235.         count := 0;
  236.         repeat                                 (* wait for an xon *)
  237.             repeat
  238.                 count := count + 1
  239.             until (readch(modem,ch)) or (count > maxtry );
  240.         until (ch = xon) or (count > maxtry);
  241.         if count > maxtry then                 (* if wait too long then *)
  242.           begin
  243.             exit(spack)                          (* get out *)
  244.           end; (* if *)
  245.       end; (* if *)
  246.  
  247.     bufp := 0;
  248.     for i := 1 to pad do begin
  249.         while not istbtr do ;
  250.         sndbbt(padchar);                     (* write out any padding chars *)
  251.         end;
  252.     buffer[bufp] := chr(soh);                (* packet sync character *)
  253.     bufp := bufp + 1;
  254.     chksum := tochar(chr(len + 3));          (* init chksum *)
  255.     buffer[bufp] := tochar(chr(len + 3));    (* character count *)
  256.     bufp := bufp + 1;
  257.     chksum := chr(ord(chksum) + ord(tochar(chr(num))));
  258.     buffer[bufp] := tochar(chr(num));
  259.     bufp := bufp + 1;
  260.     chksum := chr(ord(chksum) + ord(ptype));
  261.     buffer[bufp] := ptype;                   (* packet type *)
  262.     bufp := bufp + 1;
  263.  
  264.     for i := 0 to len - 1 do                 (* loop through data chars *)
  265.       begin
  266.         buffer[bufp] := data[i];             (* store char *)
  267.         bufp := bufp + 1;
  268.         chksum := chr(ord(chksum) + ord(data[i]))
  269.       end; (* for i *)
  270.                                              (* compute final chksum *)
  271.     chksum := chr(aand(ord(chksum) + (aand(ord(chksum),192) div 64), 63));
  272.     buffer[bufp] := tochar(chksum);
  273.     bufp := bufp + 1;
  274.     buffer[bufp] := eol;
  275.  
  276.     if (parity <> nopar) then
  277.         for i := 0 to bufp do                 (* set correct parity on buffer *)
  278.             buffer[i] := parity_array[buffer[i]];
  279.  
  280.     for i:=0 to bufp do begin
  281.       while not istbtr do;
  282.       sndbbt(buffer[i]);    (* send the packet out *)
  283.       end;
  284.  
  285.     debugwrite('sending');
  286.     if debug then
  287.         packetwrite(buffer,len);
  288.   end; (* spack *)
  289.  
  290. function getsoh(*p: port): boolean*);
  291.  
  292. (* reads characters until it finds an SOH; returns false if has to read more *)
  293. (* than maxtry chars *)
  294.  
  295. const maxtry = 10000; (* allows about 1 second of trying *)
  296.  
  297. var ch: char;
  298.     seconds,count: integer;
  299.  
  300.   begin
  301.     count := 0;
  302.     seconds:=0;
  303.     get_soh := true;
  304.     repeat
  305.         repeat
  306.             count := count + 1;
  307.             if count>maxtry then begin
  308.              seconds:=seconds+1;
  309.              count:=0;
  310.              end;
  311.         until ready(p) or (seconds > timint); (* wait for a character *)
  312.         if (seconds > timint) then
  313.           begin
  314.             get_soh := false;
  315.             exit(get_soh);
  316.           end;
  317.         ch := pget(p);                           (* get the character *)
  318.         ch := chr(aand(ord(ch),127));            (* strip parity of char *)
  319.     until (ch = chr(SOH))                        (* if not SOH, get more *)
  320.   end; (* getsoh *)
  321.  
  322. (*$G+*) (* turn on goto option...need it for next routine *)
  323.  
  324. function rpack(*var len, num: integer; var data: packettype): char*);
  325.  
  326. (* read a packet *)
  327.  
  328. label 1; (* used to emulate C's CONTINUE statement *)
  329.  
  330. const maxtry = 10000; (* allows for about 1 second of checking *)
  331.  
  332. var seconds, count, i, ichksum: integer;
  333.     chksum, ptype: char;
  334.     r: char;
  335.  
  336.   begin
  337.     count := 0;
  338.     seconds := 0;
  339.  
  340.     if not getsoh(modem) and (state<>'r') then (*if don't get synch char then *)
  341.       begin
  342.         rpack := 'N';                        (* treat as a NAK *)
  343.         num := n mod 64;
  344.         exit(rpack)                          (* and get out of here *)
  345.       end;
  346.  
  347.   1: count := count + 1;
  348.      if (count>maxtry)and(state<>'r') then (* end of one second *)
  349.         if seconds<timint then begin       (* and aren't waiting for init *)
  350.           count:=0;
  351.           seconds:=seconds+1;
  352.         end
  353.         else begin                       (* if we've tried too many times *)
  354.           rpack := 'N';                      (* treat as NAK *)
  355.           exit(rpack)                        (* and get out of here *)
  356.         end; (* if *)
  357.  
  358.     if not getch(r,modem) then                (* get a char and *)
  359.             goto 1;                        (* resynch if soh *)
  360.  
  361.     ichksum := ord(r);                     (* start checksum *)
  362.     len := ord(unchar(r)) - 3;             (* character count *)
  363.  
  364.     if not getch(r,modem) then             (* get a char and *)
  365.         goto 1;                            (* resynch if soh *)
  366.     ichksum := ichksum + ord(r);
  367.     num := ord(unchar(r));                 (* packet number *)
  368.  
  369.     if not getch(r,modem) then             (* get a char and *)
  370.         goto 1;                            (* resynch if soh *)
  371.     ichksum := ichksum + ord(r);
  372.     ptype := r;                            (* packet type *)
  373.  
  374.     for i := 0 to len-1 do                 (* get any data *)
  375.       begin
  376.         if not getch(r,modem) then            (* get a char and *)
  377.             goto 1;                        (* resynch if soh *)
  378.         ichksum := ichksum + ord(r);
  379.         data[i] := r;
  380.       end; (* for i *)
  381.     data[len] := chr(0);                   (* mark end of data *)
  382.  
  383.     if not getch(r,modem) then                (* get a char and *)
  384.         goto 1;                            (* resynch if soh *)
  385.  
  386.                                            (* compute final checksum *)
  387.     chksum := chr(aand(ichksum + (aand(ichksum,192) div 64), 63));
  388.  
  389.     if (chksum <> unchar(r)) then       (* if checksum bad *)
  390.         rpack := chr(0)                      (* return 'false' indicator *)
  391.     else                                   (* else *)
  392.         rpack := ptype;                      (* return packet type *)
  393.  
  394.     if debug then
  395.       begin
  396.         gotoxy(0,debugline+debnext);
  397.         debnext:= (debnext+1) mod debug_max;
  398.         write('rpack: len:',len,' num:',num,' ptype:',ptype);
  399.       end; (* if *)
  400.   end; (* rpack *)
  401.  
  402. (*$G-*) (* turn off goto option...don't need it anymore *)
  403.