home *** CD-ROM | disk | FTP | other *** search
/ kermit.columbia.edu / kermit.columbia.edu.tar / kermit.columbia.edu / ucsdappleii / kermpack.text < prev    next >
Text File  |  1986-04-07  |  12KB  |  358 lines
  1. (* >>>> KERMPACK.TEXT  *************************************************)
  2.  
  3. (*$I-*)
  4. (*$R-*)
  5. (*$S+*)
  6. (*$V-*)
  7.  
  8. UNIT kermpack;  INTRINSIC CODE 21  ;
  9.  
  10.  
  11. INTERFACE
  12.  
  13. USES  kermglob,
  14.       kermutil;
  15.  
  16.  
  17. PROCEDURE spar;
  18.  
  19. PROCEDURE rpar;
  20.  
  21. PROCEDURE spack( ptype: CHAR; num, len: INTEGER );
  22.  
  23. PROCEDURE send_errpack( num : INTEGER );
  24.  
  25. FUNCTION  rpack(spnum: INTEGER; VAR len, rpnum: INTEGER; VAR data: packettype;
  26.                 timeout: INTEGER; soh_char: CHAR ) : CHAR;
  27.  
  28. FUNCTION  bufill_t : INTEGER;
  29.  
  30. FUNCTION  bufill_i : INTEGER;
  31.  
  32. PROCEDURE bufemp_t( len : INTEGER );
  33.  
  34. PROCEDURE bufemp_i( len : INTEGER );
  35.  
  36.  
  37. IMPLEMENTATION
  38.  
  39.  
  40. FUNCTION bufill_t (* : integer*);
  41.  
  42. (* fill a packet with data from a textfile...manages a 2 block buffer *)
  43.  
  44. var i, j, count: integer;
  45.     ch : char;
  46.  
  47. begin
  48.   i := 4; (* start at packet[4] for data chars *)
  49.   (* while file has some data & packet has some room we'll keep going *)
  50.   while ((bufpos <= bufend) or (not eof(applefile))) and (i < max1_data) do
  51.     begin
  52.       (* if we need more data from disk then *)
  53.       if (bufpos > bufend) and (not eof(applefile)) then
  54.         begin
  55.           (* read a textpage = 2 blocks *)
  56.           bufend := blockread(applefile,filebuf[1],2) * blksize;
  57.           io_status := ioresult;
  58.           if io_status <> 0 then exit( bufill_t );
  59.           (* and adjust buffer pointer *)
  60.           bufpos := 1
  61.         end; (* if *)
  62.       if (bufpos <= bufend) then          (* if we're within buffer bounds *)
  63.         begin
  64.           ch := filebuf[bufpos];          (* get a character *)
  65.           bufpos := bufpos + 1;           (* increase buffer pointer *)
  66.           if (ch = xdle_char) then        (* if it's space compression char, *)
  67.             begin
  68.               count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
  69.               bufpos := bufpos + 1;       (* read past # *)
  70.               ch := ' ';                  (* and make current char a space *)
  71.             end (* if *)
  72.             else                          (* otherwise, it's just a char *)
  73.               count := 1;                 (* so only 1 copy of it *)
  74.           if (ch in ctlq_set) then        (* if a control char *)
  75.             begin
  76.               if (ch = cr) then           (* if a carriage return *)
  77.                 begin
  78.                   packet[i] := quote;     (* put (quoted) CR in packet *)
  79.                   i := i + 1;
  80.                   packet[i] := ctl( cr );
  81.                   i := i + 1;
  82.                   ch := lf;               (* and we'll stick a LF after *)
  83.                 end; (* if *)
  84.               packet[i] := quote;         (* put the quote in packet *)
  85.               i := i + 1;
  86.               if ch <> quote then
  87.                       ch := ctl(ch);      (* and un-controllify char *)
  88.             end (* if *)
  89.         end; (* if *)
  90.       j := 1;
  91.       while (j <= count) and (i < max2_data) do
  92.         begin                             (* put all the chars in packet *)
  93.           if ch <> chr(0) then            (* so long as not a NUL *)
  94.             begin
  95.               packet[i] := ch;
  96.               i := i + 1;
  97.             end (* if *)
  98.           else bufpos := bufend +1;       (* if is a NUL so *)
  99.                                           (* skip to end of block *)
  100.                                           (* since rest will be NULs *)
  101.           j := j + 1
  102.         end; (* while *)
  103.     end; (* while *)
  104.   if (i = 4) then                         (* if we're at end of file, *)
  105.       bufill_t := (at_eof)                (* indicate it *)
  106.   else                                    (* else *)
  107.     begin
  108.       if (j <= count) then                (* if didn't all fit in packet *)
  109.         begin
  110.           bufpos := bufpos - 2;           (* put buf pointer at DLE *)
  111.                                           (* and update compress count *)
  112.           filebuf[bufpos + 1] := tochar(chr(count-j+1));
  113.         end; (* if *)
  114.       bufill_t := i                       (* return # of data in packet + 4 *)
  115.     end; (* else *)
  116. end; (* bufill_t *)
  117.  
  118.  
  119. FUNCTION bufill_i { : integer };
  120.  
  121.  fills packet with data form another type of file than a textfile.  
  122.  This will only work if serial wordlength can be set to 8 databits, 
  123.  no parity and if both sides plus the transport medium do not change
  124.  in any way the most significant bit of the byte send.              
  125.  
  126. var i : integer;
  127.     ch : char;
  128.  
  129. begin
  130.   i := 4; ch := ' ';
  131.   while ((bufpos <= bufend) or ( not eof(applefile))) and ( i < spsiz ) do
  132.     begin
  133.       if (bufpos > bufend) and ( not eof(applefile) ) then
  134.         begin
  135.           bufend := blockread( applefile, filebuf[1], 1) * blksize;
  136.           io_status := ioresult;
  137.           if io_status <> 0 then exit( bufill_i );
  138.           bufpos := 1;
  139.         end;
  140.       if (bufpos <= bufend) then
  141.         begin
  142.           ch := filebuf[bufpos];
  143.           bufpos := bufpos + 1;
  144.           if ch in ctlq_set then begin
  145.                                    packet[i] := quote;
  146.                                    i := i + 1;
  147.                                    if ch <> quote then ch := ctl( ch );
  148.                                   end;
  149.           packet[i] := ch;
  150.           i := i + 1;
  151.         end;
  152.     end; { while }
  153.   if i = 4 then bufill_i := at_eof
  154.            else bufill_i := i;
  155. end; { bufill_i }
  156.  
  157.  
  158.  
  159. PROCEDURE bufemp_t { len : integer };
  160.  
  161. var ch : char;
  162.     i, j : integer;
  163.  
  164. begin
  165.   i := 0;
  166.   while i < len do
  167.   begin
  168.     if bufpos < ( page_size - 1 )
  169.       then begin
  170.              ch := rec_pkt[i];
  171.              if ch = quote
  172.                then begin
  173.                       i := i + 1;
  174.                       ch := rec_pkt[i];
  175.                       if ch = quote
  176.                         then begin
  177.                                filebuf[bufpos] := ch;
  178.                                bufpos := bufpos + 1;
  179.                              end
  180.                         else begin
  181.                                ch := ctl( ch );
  182.                                if ch in [ cr, ff ] then
  183.                                  begin
  184.                                    if ch = ff then if no_ffeed
  185.                                                    then ch := cr;
  186.                                    filebuf[bufpos]   := ch;
  187.                                    filebuf[bufpos+1] := xdle_char;
  188.                                    filebuf[bufpos+2] := ' ';
  189.                                    crpos := bufpos;
  190.                                    bufpos := bufpos + 3;
  191.                                    dle_flag := true;
  192.                                  end;
  193.                              end;
  194.                     end
  195.                else begin
  196.                       if ( ch = ' ' ) and dle_flag
  197.                         then filebuf[bufpos-1] := succ( filebuf[bufpos-1] )
  198.                         else begin
  199.                                dle_flag := false;
  200.                                filebuf[bufpos] := ch;
  201.                                bufpos := bufpos + 1;
  202.                              end;
  203.                     end;
  204.              i := i + 1;
  205.            end
  206.       else begin
  207.              j := blockwrite( rec_file, filebuf[1], 1 );
  208.              bufpos := bufpos - crpos;
  209.              moveleft( filebuf[crpos], filebuf[1], bufpos );
  210.              fillchar( filebuf[crpos], pagesize + 1 - crpos, chr(0) );
  211.              j := blockwrite( rec_file, filebuf[blk_size + 1], 1 );
  212.              io_status := ioresult;
  213.              if j <> 1 then io_status := 8;
  214.              if io_status <> 0 then exit( bufemp_t );
  215.              bufpos := bufpos + 1;
  216.              crpos := pagesize - 1;
  217.            end;
  218.   end;
  219. end;  { bufemp_t }
  220.  
  221.  
  222.  
  223.  
  224. PROCEDURE bufemp_i { len : integer };
  225.  
  226. var ch : char;
  227.     i, j : integer;
  228.  
  229. begin
  230.   i := 0;
  231.   while i < len do
  232.   begin
  233.     if bufpos <= blk_size
  234.       then begin
  235.              ch := rec_pkt[i];
  236.              if ch = quote
  237.                then begin
  238.                       i := i + 1;
  239.                       ch := rec_pkt[i];
  240.                       if ch <> quote then ch := ctl( ch );
  241.                     end;
  242.              filebuf[bufpos] := ch;
  243.              bufpos := bufpos + 1;
  244.              i := i + 1;
  245.            end
  246.       else begin
  247.              j := blockwrite( rec_file, filebuf[1], 1 );
  248.              bufpos := 1;
  249.              io_status := ioresult;
  250.              if j <> 1 then io_status := 8;
  251.              if io_status <> 0 then exit( bufemp_i );
  252.            end;
  253.   end;
  254. end;  { bufemp_i }
  255.  
  256.  
  257.  
  258.  
  259.  
  260. PROCEDURE spar;
  261.  
  262. (* fills packet with my send-init parameters *)
  263.  
  264.   begin
  265.     packet[4] := tochar(chr(maxpack));   (* biggest packet i can receive *)
  266.     packet[5] := tochar(chr(mytime));    (* when i want to be timed out *)
  267.     packet[6] := tochar(chr(mypad));     (* how much padding i need *)
  268.     packet[7] := ctl(mypchar);           (* padding char i want *)
  269.     packet[8] := tochar(eoln_char);      (* end of line character i want *)
  270.     packet[9] := myquote;                (* control-quote char i want *)
  271.     packet[10]:= chr(0);                 (* I won't do 8-bit quoting *)
  272.   end; (* spar *)
  273.  
  274.  
  275.  
  276. PROCEDURE rpar;
  277.  
  278. (* gets their init params *)
  279.  
  280. begin
  281.   spsiz     := ord(unchar(rec_pkt[0]));         (* max send packet size     *)
  282.   max1_data := spsiz - 2;                       (* calculate maximal        *)
  283.   max2_data := spsiz + 1;                       (* data limits for bufill_t *)
  284.   xtime     := ord(unchar(rec_pkt[1]));         (* when i should time out   *)
  285.   pad       := ord(unchar(rec_pkt[2]));         (* number of pads to send   *)
  286.   padchar   := ctl(rec_pkt[3]);                 (* padding char to send     *)
  287.   xeol_char := unchar(rec_pkt[4]);              (* eol char i must send     *)
  288.   quote     := rec_pkt[5];                      (* incoming data quote char *)
  289. end; (* rpar *)
  290.  
  291.  
  292. PROCEDURE spack(*ptype: char; num: integer; len: integer*);
  293.  
  294. (* send a packet *)
  295.  
  296. const mtry = 10000;
  297.  
  298. var j, i, count: integer;
  299.     ch: char;
  300.  
  301. begin
  302.   if ibm and (currstate <> 's') then           (* if ibm and not SINIT then *)
  303.     begin
  304.       count := 0; ch := ' ';
  305.       repeat                                   (* wait for an xon *)
  306.         repeat
  307.             count := count + 1;
  308.             unitstatus( inport, j, control_word );
  309.         until ( j > 0 ) or ( count > mtry );
  310.         unitread( inport, ch, 1,, 12 );
  311.       until (ch = xon_char) or (count > mtry);
  312.       if count > mtry then exit( spack ); (* if wait too long then get out *)
  313.     end; (* if *)
  314.  
  315.   if pad > 0 then
  316.     begin
  317.       for i := 1 to pad do
  318.       unitwrite( outport, padchar, 1,, 12 ); (* write out any padding chars *)
  319.     end;
  320.   packet[0] := soh_char;                     (* packet sync character *)
  321.   packet[1] := tochar(chr(len - 1));         (* character count *)
  322.   packet[2] := tochar(chr(num));             (* packet number *)
  323.   packet[3] := ptype;                        (* packet type *)
  324.    (* data chars have already been filled in by by the bufill procedure *)
  325.                                              (* compute final chksum *)
  326.                                              (* len=data chars + 4 *)
  327.   packet[len]   := tochar( calc_checksum( packet, len ) );
  328.   packet[len+1] := xeol_char;
  329.   if debug then packet_write( packet, len+2 );
  330.   unitwrite( outport, packet[0], len+2,, 12 );
  331. end; (* spack *)
  332.  
  333.  
  334. PROCEDURE  send_errpack { num : integer };
  335.  
  336. var len : integer;
  337.  
  338. begin
  339.   len := length ( err_string );
  340.   moveleft( err_string[1], packet[4], len );
  341.   spack( 'E', num, len+4 );
  342. end;  { send_errpack }
  343.  
  344.  
  345. FUNCTION rpack{ (spnum:integer; var len,rpnum:integer; data:packettype;  }
  346.               {  timeout:integer; soh_char:char) : char } ; EXTERNAL;
  347.  
  348.  this function listens to the serial input port, detects a kermit 
  349.  package, decodes it and returns the data part of the packet.     
  350.  its function value is the type of the received packet. If there  
  351.  was a receive error or the timeout period (1..31 sec) was        
  352.  exhausted without receiving a valid packet the function returns  
  353.  with '@' as value, with rpnum=spnum and with len = 0.            
  354.  
  355.  
  356. begin
  357. end. { kermpack }
  358.