home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / intelrmx86 / send.p86 < prev    next >
Text File  |  2020-01-01  |  18KB  |  704 lines
  1. /* SEND MODULE: this module handles all sending of data between the    */
  2. /* host and RMX system                        */
  3. $compact
  4. $optimize(3)
  5.  
  6. send$module:
  7. do;
  8.  
  9. $INCLUDE(:INC:LTKSEL.LIT)
  10. $INCLUDE(:INC:UREAD.EXT)
  11. $INCLUDE(:INC:UWRITE.EXT)
  12. $INCLUDE(:INC:UDCTIM.EXT)
  13. $INCLUDE(:INC:NSLEEP.EXT)
  14.  
  15. /* here are some global declarations for the communication module */
  16.  
  17. declare true literally '0FFH';
  18. declare false literally '00H';
  19.  
  20. declare chrmsk literally '07FH';
  21. declare maxtry literally '05';
  22. declare space literally '020H';
  23. declare cr literally '0DH';
  24. declare lf literally '0AH';
  25. declare null literally '00H';
  26. declare crlf literally 'cr,lf,null';
  27. declare eofl literally '0';
  28. declare delete literally '07FH';
  29.  
  30. declare send$delay byte external;
  31. declare send$eol byte external;
  32. declare send$paclen byte external;
  33. declare send$padchar byte external;
  34. declare send$padding byte external;
  35. declare send$pause byte external;
  36. declare send$quote byte external;
  37. declare send$start byte external;
  38. declare send$time byte external;
  39.  
  40. declare readonly literally '1';
  41. declare writeonly literally '2';
  42. declare rdwr literally '3';
  43. declare noedit literally '0';
  44.  
  45. declare pksize literally '94';
  46. declare send$packet(pksize) byte public;    /* buffer for packets */
  47. declare recv$packet(pksize) byte public;    /* buffer for packets */
  48.  
  49. declare send_delay word;
  50. declare state byte;            /* FSM last state */
  51. declare msgnum byte;            /* message number */
  52. declare tries byte;            /* max number of retries */
  53. declare numpads byte;            /* how many pads to send */
  54. declare padchar byte;            /* the present pad character */
  55. declare eol byte;            /* the present eol character */
  56. declare quote byte;            /* the present quote character */
  57. declare timeint byte;            /* the present time out */
  58. declare spsize byte;            /* the present packet size */
  59. declare pklen word;
  60. declare (j,count) word initial (0,0);
  61. declare (k,cnt)   word initial (0,0);
  62. declare buflen literally '128';
  63. declare inbuf (buflen) byte;
  64. declare outbuf(buflen) byte;
  65. declare outlen word initial (0);
  66.  
  67. declare (in$conn,out$conn) token external;
  68. declare (ci$conn,co$conn) token external;
  69. declare status word external;
  70. declare debug byte external;
  71. declare file$conn token external;
  72. declare iobuff(1024) byte external;
  73. declare file$len (2) word external;
  74. declare byte$out dword;
  75. declare byte$tot dword at (@file$len);
  76. declare frac$tot word;
  77. declare filename structure
  78.     (len byte,
  79.      name(80) byte) external;
  80. declare wait$time byte public;
  81. declare system$end$time dword public;
  82. declare time$buffer structure
  83.     (system$time    dword,
  84.      date(8)        byte,
  85.      time(8)        byte);
  86.  
  87. /* here are the subroutines */
  88.  
  89. check$error: procedure (fatal) byte external;
  90.     declare fatal byte;
  91. end check$error;
  92.  
  93. co:    procedure(char) external;
  94.     declare char byte;
  95. end co;
  96.  
  97. prints:    procedure(msg) external;
  98.     declare msg pointer;
  99. end prints;
  100.  
  101. print:     procedure(string) external;
  102.     declare string pointer;
  103. end print;
  104.  
  105. nout:     procedure(n) external;
  106.     declare n word;
  107. end nout;
  108.  
  109. noutd:     procedure(n) external;
  110.     declare n dword;
  111. end noutd;
  112.  
  113. file$open: procedure (mode) external;
  114.     declare mode byte;
  115. end file$open;
  116.  
  117. newline: procedure external; end newline;
  118.  
  119. /* TOCHAR: takes a character and converts it to a printable character      */
  120. /*         by adding a space                        */
  121.  
  122. tochar: procedure(char) byte public;
  123.     declare char byte;
  124.     return (char + space);
  125. end tochar;
  126.  
  127.  
  128. /* UNCHAR: undoes 'tochar' */
  129.  
  130. unchar:    procedure(char) byte public;
  131.     declare char byte;
  132.     return (char - space);
  133. end unchar;
  134.  
  135.  
  136. /* CTL: this routine takes a character and toggles the control bit    */
  137. /* (ie. ^A becomes A and A becomes ^A).                    */
  138.  
  139. ctl:     procedure(char) byte public;
  140.     declare char byte;
  141.     declare cntrlbit literally '040H';
  142.     return (char xor cntrlbit);
  143. end ctl;
  144.  
  145. getc: procedure (conn) byte public;
  146.     declare conn token;
  147.     if debug then call print(@('Entering getc...',crlf));
  148.     k=k+1;
  149. loop:
  150.     if k>=cnt then do;
  151.       cnt=DQ$READ(conn,@inbuf,buflen,@status);
  152.       if check$error(0) then wait$time = 0;
  153.       k=0;
  154.         if debug then call print(@('back from reading...',crlf));
  155.       if cnt=0 then call chk$time;
  156.       if wait$time=0 then return 0;
  157.         if debug then call print(@('looping back to read again',crlf));
  158.       goto loop;
  159.     end;
  160.     return inbuf(k);
  161. end getc;
  162.  
  163. putc: procedure (c, conn) public;
  164.     declare c byte;
  165.     declare conn token;
  166.     outbuf(outlen)=c;
  167.     outlen=outlen+1;
  168.     if outlen>=buflen then call do$put(conn);
  169. end putc;
  170.  
  171. do$put: procedure (conn) public;
  172.     declare conn token;
  173.     if outlen>0 then do;
  174.       call DQ$WRITE(conn,@outbuf,outlen,@status);
  175.       if check$error(0) then return;
  176.       outlen=0;
  177.     end;
  178. end do$put;
  179.  
  180. set$end$time: procedure (wait) public;
  181.     declare wait byte;
  182.     time$buffer.system$time=0;
  183.     call DQ$DECODE$TIME(@time$buffer,@status);
  184.     if check$error(1) then return;
  185.     wait$time=wait;
  186.     system$end$time=time$buffer.system$time +
  187.                     double(double(wait));
  188.     if debug then do;
  189.         call print(@('wait_time=',null));
  190.         call nout(wait$time);
  191.         call print(@('  from end_time=',null));
  192.         call noutd(system$end$time);
  193.         call print(@('  and now_time=',null));
  194.         call noutd(time$buffer.system$time);
  195.         call newline;
  196.     end;
  197. end set$end$time;
  198.  
  199. chk$time: procedure public;
  200.     if debug then call print(@(' enter chk_time...',crlf));
  201.     call RQ$SLEEP(10,@status); /* add wait a little? */
  202.     if check$error(1) then return;
  203.     time$buffer.system$time=0;
  204.     call DQ$DECODE$TIME(@time$buffer,@status);
  205.     if check$error(1) then return;
  206.     if time$buffer.system$time>system$end$time then wait$time=0;
  207.     else wait$time=system$end$time-time$buffer.system$time;
  208.     if debug then do;
  209.         call print(@('wait_time=',null));
  210.         call nout(wait$time);
  211.         call print(@('  from end_time=',null));
  212.         call noutd(system$end$time);
  213.         call print(@('  and now_time=',null));
  214.         call noutd(time$buffer.system$time);
  215.         call newline;
  216.     end;
  217.     return;
  218. end chk$time;
  219.  
  220. spar:     procedure (a) public;
  221.     declare a address;
  222.     declare b based a byte;
  223.     b = tochar(send$paclen);        /* set up header */
  224.     a = a + 1;
  225.     b = tochar(send$time);
  226.     a = a + 1;
  227.     b = tochar(send$padding);
  228.     a = a + 1;
  229.     b = ctl(send$padchar);
  230.     a = a + 1;
  231.     b = tochar(send$eol);
  232.     a = a + 1;
  233.     b = send$quote;
  234. end spar;
  235.  
  236.  
  237. rpar:    procedure (addr) public;
  238.     declare addr address;
  239.     declare item based addr byte;
  240.  
  241.     spsize = unchar(item);        /* isn't plm wonderful? */
  242.     addr = addr + 1;
  243.     timeint = unchar(item);
  244.     addr = addr + 1;
  245.     numpads = unchar(item);
  246.     addr = addr + 1;
  247.     padchar = ctl(item);
  248.     addr = addr + 1;
  249.         eol = unchar(item);
  250.     addr = addr + 1;
  251.     quote = item;
  252. end rpar;
  253.  
  254.  
  255. bufill:    procedure (packet) byte;
  256.     declare packet address;
  257.     declare (pp, maxpp) address;
  258.     declare done byte;
  259.     declare chr based pp byte;
  260.     declare i word;
  261.  
  262.     done = false;
  263.     pp = packet;
  264.     maxpp = pp + spsize - 8;
  265.     do while not done;
  266.       if j>=count then do;
  267.         count = DQ$READ(file$conn,@iobuff,512,@status);
  268.         if status > 0 then do;
  269.           call print(@('Error reading file',crlf));
  270.           if check$error(0) then return 0;
  271.         end;
  272.         if count = 0 then done = true;
  273.         j=0;
  274.       end;
  275.       else do;
  276.       do i=j to count-1;
  277.         if ((iobuff(i) and chrmsk) < space) or
  278.         ((iobuff(i) and chrmsk) = delete) then
  279.           do;
  280.         chr = quote;
  281.         pp = pp + 1;
  282.         chr = ctl(iobuff(i));
  283.           end;
  284.         else
  285.           if (iobuff(i) and chrmsk) = quote then
  286.         do;
  287.           chr = quote;
  288.           pp = pp + 1;
  289.           chr = iobuff(i);
  290.         end;
  291.           else
  292.         chr = iobuff(i);
  293.         pp = pp + 1;
  294.         byte$out=byte$out+1;
  295.         if pp >= maxpp then do;
  296.           j = i+1;
  297.           return (pp-packet);
  298.         end;
  299.       end;
  300.       j=count+1;
  301.       end;
  302.     end;
  303.     return (pp - packet);
  304. end bufill;
  305.  
  306.  
  307. /* SPACK: this routine sends a packet of data to the host, it takes    */
  308. /* four parameters, the type of packet, message number, packet length   */
  309. /* and a pointer to a buffer containing what is to be output. It does    */
  310. /* not return a value.                            */
  311.  
  312. spack:    procedure(type, pknum, length, packet) public;
  313.     declare (type, pknum, length) byte;
  314.     declare packet address;
  315.     declare char based packet byte;
  316.     declare (i, chksum) byte;
  317.  
  318.     if debug then do;
  319.       call print(@('Sending packet ',null));
  320.       call nout(pknum);
  321.       call newline;
  322.     end;
  323.  
  324.     i = 1;                    /* do padding */
  325.     do while (i <= numpads);
  326.       call putc(padchar, out$conn);
  327.       i = i + 1;
  328.     end;
  329.  
  330.     chksum = 0;
  331.     /* send the packet header */
  332.  
  333.     call putc(send$start, out$conn);        /* send packet marker (soh) */
  334.     if debug then call co('s');
  335.     i = tochar(length + 3);
  336.     chksum = i;
  337.     call putc(i, out$conn);            /* send character count     */
  338.     if debug then call co('c');
  339.     i = tochar(pknum);
  340.     chksum = chksum + i;            /* add in packet number     */
  341.     call putc(i, out$conn);            /* send packet number        */
  342.     if debug then call co('n');
  343.     chksum = chksum + type;            /* add in packet type        */
  344.     call putc(type, out$conn);            /* send the packet type        */
  345.     if debug then call co(type);
  346.  
  347.     /* now send the data */
  348.     do i = 1 to length;
  349.       chksum = chksum + char;
  350.       call putc(char, out$conn);
  351.       if debug then call co(char);
  352.       packet = packet + 1;
  353.     end;
  354.  
  355.     /* check sum generation */
  356.  
  357.     chksum = ((chksum + (chksum and 192) / 64) and 63);
  358.     chksum = tochar(chksum);
  359.     call putc(chksum, out$conn);        /* send the chksum */
  360.     if debug then call co('c');
  361.  
  362.     call putc(eol, out$conn);            /* terminate the packet */
  363.     if debug then do;
  364.       call co('e');
  365.       call newline;
  366.     end;
  367.     call do$put(out$conn);
  368. end spack;
  369.  
  370.  
  371. /* RPACK: this routine receives a packet from the host.  It takes three    */
  372. /* parameters: the address of where to put the length of the packet,    */
  373. /* the address of where to put the packet number and the address of the */
  374. /* buffer to recieve the data.  It returns true for a positive reply or */
  375. /* false for a NEGative reply.                        */
  376.  
  377. rpack:     procedure(length, pknum, packet) byte public;
  378.     declare (length, pknum, packet, pkptr) address;
  379.  
  380.     declare len based length byte;
  381.     declare num based pknum byte;
  382.     declare pk based pkptr byte;
  383.     declare (i, index, chksum, hischksum, type, inchar, msglen) byte;
  384.  
  385.     declare buffer(128) byte;
  386.  
  387.     if debug then call print(@('rpack | ',null));
  388.  
  389.     inchar = 0;            /* wait for a header */
  390.     call set$end$time(send$time);
  391.     do while inchar <> send$start;
  392.       inchar = getc(in$conn);
  393.       if wait$time=0 then return 'N';
  394.     end;
  395.     index = 0;
  396.     call set$end$time(send$time);
  397.     inchar = getc(in$conn);
  398.       if wait$time=0 then return 'N';
  399.     do while (inchar <> send$eol);
  400.       buffer(index) = inchar;
  401.       index = index + 1;
  402.       inchar = getc(in$conn);
  403.       if wait$time=0 then return 'N';
  404.     end;
  405.     buffer(index) = null;
  406.     if debug then do;
  407.     call print(@('Received packet: [',null));
  408.     call print(@buffer);
  409.     call print(@(']',cr,lf,'Length of message: ',null));
  410.     end;
  411.     msglen = index - 1;
  412.     if debug then do;
  413.     call nout(msglen);
  414.     call newline;
  415.     call print(@('Length field: ',null));
  416.     call nout(buffer(0));
  417.     call co('_');
  418.     end;
  419.     len = unchar(buffer(0)-3);
  420.     if debug then do;
  421.     call nout(len);
  422.     call print(@(cr,lf,'Message number: ',null));
  423.     call nout(buffer(1));
  424.     call co('_');
  425.     end;
  426.     num = unchar(buffer(1));
  427.     if debug then do;
  428.     call nout(num);
  429.     call print(@(cr,lf,'Type: ',null));
  430.     end;
  431.     type = buffer(2);
  432.     if debug then do;
  433.     call co(type);
  434.     call newline;
  435.     end; /* debug */
  436.  
  437.     pkptr = packet;
  438.     chksum = buffer(0) + buffer(1) + buffer(2);
  439.  
  440.     i = 3;                /* index of first data character */
  441.     do while (i < msglen);
  442.       chksum = (pk := buffer(i)) + chksum;
  443.       pkptr = pkptr+1;
  444.       i = i + 1;
  445.     end;
  446.     pk = null;        /* terminate with null for printing */
  447.     pkptr = packet;
  448.  
  449.     chksum = (chksum + ((chksum and 192) / 64)) and 63;
  450.  
  451.     if debug then do;
  452.     call print(@('His checksum: ',null));
  453.     call nout(buffer(msglen));
  454.     call co('_');
  455.     end; /* debug */
  456.     hischksum = unchar(buffer(msglen));
  457.     if debug then do;
  458.     call nout(hischksum);
  459.     call print(@(cr,lf,'Our checksum: ',null));
  460.     call nout(chksum);
  461.     call newline;
  462.     end; /* debug */
  463.     if chksum = hischksum then do;
  464.       if debug then call co('.');
  465.       if type='E' then do;
  466.         if len>0 then call print(@pk);
  467.       end;
  468.       return type;
  469.     end;
  470.     call print(@('Bad checksum received', crlf));
  471.     len=0;
  472.     return 'E';
  473. end rpack;
  474.  
  475.  
  476.  
  477.  
  478. /* SDATA: this routine sends the data from the buffer area to the host.    */
  479. /* It takes no parameters but returns the next state depending on the    */
  480. /* type of acknowledgement.                        */
  481.  
  482. sdata:     procedure byte;
  483.     declare (num, length, retc) byte;
  484.  
  485.     if debug then call print(@('sdata...',crlf));
  486.  
  487.     if tries > maxtry then return 'A';
  488.       else tries = tries + 1;
  489.  
  490.     call spack('D', msgnum, pklen, .send$packet);
  491.     retc = rpack(.length, .num, .recv$packet);
  492.     if (retc = 'N') then return state;
  493.     if (retc <> 'Y') then return 'A';
  494.     /* here when good acknowledgement */
  495.     tries = 0;
  496.     msgnum = (msgnum + 1) mod 64;
  497.     pklen = bufill(.send$packet);
  498.     frac$tot=(byte$out*100)/byte$tot;
  499.     call print(@('output ',null));
  500.     call noutd(byte$out);
  501.     call print(@(' bytes = ',null));
  502.     call nout(frac$tot);
  503.     call print(@('%',cr,null));
  504.     if pklen > 0 then return 'D';
  505.       else return 'Z';
  506. end sdata;
  507.  
  508.  
  509. /* SFILE: this routine sends a packet to the host which contains the     */
  510. /* filename of the file being sent so that the file can be created at    */
  511. /* the host end. It returns a new state depending on the nature of the    */
  512. /* the hosts acknowledgement.                        */
  513.  
  514. sfile:     procedure byte;
  515.     declare (num, length, retc) byte;
  516.     declare fnptr address;
  517.     declare fnindex based fnptr byte;
  518.  
  519.     if debug then call print(@('sfile...',crlf));
  520.  
  521.     if tries > maxtry then return 'A';
  522.       else tries = tries + 1;
  523.  
  524.     if debug then call print(@(cr,lf,'Filename is: ',null));
  525.     call prints(@filename);
  526.     call newline;
  527.     if debug then do;
  528.     call print(@(cr,lf,'length is: ',null));
  529.     call nout(length);
  530.     call newline;
  531.     end; /* debug */
  532.     call spack('F', msgnum, filename.len,.filename.name);
  533.     retc = rpack(.length, .num, .recv$packet);
  534.  
  535.     if (retc = 'N') then return state;
  536.     if (retc <> 'Y') then return 'A';
  537.     /* here on valid acknowledgement */
  538.     tries = 0;
  539.     msgnum = (msgnum + 1) mod 64;
  540.     pklen = bufill(.send$packet);
  541.     if debug then call nout(pklen);
  542.     if debug then call newline;
  543.     if pklen > 0 then return 'D';
  544.       else return 'Z';
  545. end sfile;
  546.  
  547.  
  548. /* SEOF: this routine is used when eof is detected, it closes up and    */
  549. /* returns the new state as usual.                    */
  550.  
  551. seof:    procedure byte;
  552.     declare (num, length, retc) byte;
  553.  
  554.     if debug then call print(@('seof...',crlf));
  555.  
  556.     if tries > maxtry then return 'A';
  557.       else tries = tries + 1;
  558.  
  559.     call spack('Z', msgnum, 0, .send$packet);
  560.     retc = rpack(.length, .num, .recv$packet);
  561.     if (retc = 'N') then return state;
  562.     if (retc <> 'Y') then return 'A';
  563.     /* here on valid acknowledgement */
  564.     byte$out=0;
  565.     tries = 0;
  566. /* here is where you open next file if wildcard spec. */
  567.     filename.len=0;
  568.     msgnum = (msgnum + 1) mod 64;
  569.     if filename.len=0 then
  570.         return 'B';
  571.     else do;
  572.         call file$open(1);
  573.         return 'S';
  574.     end;
  575. end seof;
  576.  
  577.  
  578. /* SINIT: this routine does initialisations and opens the file to be    */
  579. /* send, it returns a new state depending on the outcome of trying to    */
  580. /* open the file.                            */
  581.  
  582. sinit:    procedure byte;
  583.     declare (len, num, retc) byte;
  584.  
  585.     call print(@(cr,lf,'Sending ',null));
  586.  
  587.     if tries  > maxtry then return 'A';
  588.       else tries = tries + 1;
  589.  
  590.     call spar(.send$packet);
  591.     call spack('S', msgnum, 6, .send$packet);    /* send start packet */
  592.  
  593.     retc = rpack(.len, .num, .recv$packet);
  594.     if (retc = 'N') then return state;
  595.     if (retc <> 'Y') then return 'A';
  596.     /* here on valid acknowledgement */
  597.     call rpar(.recv$packet);
  598.     if eol = 0 then eol = send$eol;
  599.     if quote = 0 then quote = send$quote;
  600.     byte$out=0;
  601.     tries = 0;
  602.     msgnum = (msgnum + 1) mod 64;
  603.     return 'F';
  604. end sinit;
  605.  
  606.  
  607. /* SBREAK: this module breaks the flow of control at the end of a     */
  608. /* transmission and allows the send routine to terminate by returning    */
  609. /* either a successful or failure condition to the main kermit routine. */
  610.  
  611. sbreak:    procedure byte public;
  612.     declare (num, length, retc) byte;
  613.  
  614.     if debug then call print(@('sbreak...',crlf));
  615.  
  616.     if tries > maxtry then return 'A';
  617.       else tries = tries + 1;
  618.  
  619.     call spack('B', msgnum, 0, .send$packet);
  620.     retc = rpack(.length, .num, .recv$packet);
  621.  
  622.     if (retc = 'N') then return state;
  623.     if (retc <> 'Y') then return 'A';
  624.     /* we only get here if we received a valid acknowledgement */
  625.     tries = 0;
  626.     msgnum = (msgnum + 1) mod 64;
  627.     return 'C';
  628. end sbreak;
  629.  
  630. /* serror: this module sends an error packet to abort the transmittion */
  631.  
  632. serror:    procedure byte;
  633.     declare (num, length, retc) byte;
  634.  
  635.     if debug then call print(@('serror...',crlf));
  636.  
  637.     if tries > maxtry then return 'A';
  638.       else tries = tries + 1;
  639.  
  640.     call spack('B', msgnum, 0, .send$packet);
  641.     retc = rpack(.length, .num, .recv$packet);
  642.  
  643.     if (retc = 'N') then return state;
  644.     if (retc <> 'Y') then return 'A';
  645.     /* we only get here if we received a valid acknowledgement */
  646.     tries = 0;
  647.     msgnum = (msgnum + 1) mod 64;
  648.     return 'A';
  649. end serror;
  650.  
  651. send$setup: procedure public;
  652.     msgnum = 0;
  653.     tries = 0;
  654.  
  655.     spsize = send$paclen;
  656.     timeint = send$time;
  657.     numpads = send$padding;
  658.     padchar = send$padchar;
  659.     eol = send$eol;
  660.     quote = send$quote;
  661. end send$setup;
  662.  
  663.  
  664. /* SEND: here's the main code for the send command, it's a FSM for    */
  665. /* sending files. The main loop calles various routines until it     */
  666. /* finishes or an error occurs; this is signified by a true or false     */
  667. /* result being returned to the main 'kermit' routine.            */
  668.  
  669. send:    procedure byte public;
  670.  
  671.     state = 'S';                /* start in Send-Init state */
  672.     call send$setup;
  673.  
  674.     send_delay=double(send$delay)*100;
  675.     if co$conn=out$conn then call RQ$SLEEP(send_delay,@status);
  676.  
  677.     do while true;
  678.       if debug then
  679.         do;
  680.           call print(@('state : ',null));
  681.           call co(state);
  682.           call newline;
  683.         end;
  684.       if state = 'D' then state = sdata;
  685.       else
  686.         if state = 'F' then state = sfile;
  687.         else
  688.           if state = 'Z' then state = seof;
  689.           else
  690.             if state = 'S' then state = sinit;
  691.         else
  692.           if state = 'B' then state = sbreak;
  693.               else
  694.                 if state = 'C' then return true;
  695.             else
  696.               if state = 'A' then return false;
  697.             else
  698.               if state = 'E' then return false;
  699.           else return false;
  700.     end;
  701. end send;
  702.  
  703. end send$module;
  704.