home *** CD-ROM | disk | FTP | other *** search
/ PD ROM 1 / PD ROM Volume I - Macintosh Software from BMUG (1988).iso / Programming / Complete Applications / Telecom / MT Special 3 / IBM WWIV / DLP1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-01-14  |  15.6 KB  |  489 lines  |  [TEXT/ttxt]
  1. function valuer(i:str):real;
  2. var rl:real; c:integer;
  3. begin
  4.   rl:=0;
  5.   c:=1;
  6.   while (c<length(i)) do begin
  7.     if not (i[c] in ['0'..'9']) then i:=copy(i,1,c-1);
  8.     c:=c+1;
  9.   end;
  10.   while (i<>'') do begin
  11.     c:=ord(i[1])-ord('0');
  12.     rl:=rl*10.0+c;
  13.     i:=copy(i,2,length(i)-1);
  14.   end;
  15.   valuer:=rl;
  16. end;
  17.  
  18. function cstrr(rl:real):str;
  19. var c1,c2,c3:integer; i:str; r1,r2:real;
  20. begin
  21.  if rl<=0.0 then cstrr:='0' else begin
  22.   r1:=ln(rl)/ln(10.0);
  23.   r2:=exp(ln(10)*(trunc(r1)));
  24.   i:='';
  25.   while (r2>0.999) do begin
  26.     c1:=trunc(rl/r2);
  27.     i:=i+chr(c1+ord('0'));
  28.     rl:=rl-c1*r2;
  29.     r2:=r2/10.0;
  30.   end;
  31.   cstrr:=i;
  32.  end;
  33. end;
  34.  
  35. procedure calcCRC(data:byte);
  36. var
  37.   i: byte;
  38. begin
  39.   chksum := lo(chksum + data);
  40.   if ucrc then begin
  41.     crc:=crc xor (data shl 8);
  42.     for i := 0 to 7 do begin
  43.       if (crc<0) then
  44.         crc:=(crc shl 1) xor $1021
  45.       else
  46.         crc:=crc shl 1;
  47.     end;
  48.   end;
  49. end;
  50.  
  51. function gtp(dl:boolean):integer;
  52. var c:char; s:str; done:boolean;
  53. begin
  54.   if dl then s:='01234Q?' else s:='0234Q?';
  55.   done:=false;
  56.   repeat
  57.     nl;
  58.     prompt('Protocol (?=list) : '); onek(c,s);
  59.     if c='?' then begin
  60.       nl;
  61.       print('Q) abort transfer');
  62.       print('0) don''t transfer');
  63.       if dl then print('1) ASCII transfer (download only)');
  64.       print('2) XMODEM');
  65.       print('3) XMODEM-CRC');
  66.       print('4) YMODEM');
  67.     end else done:=true;
  68.   until done or hangup;
  69.   if c='Q' then gtp:=-1 else gtp:=value(c+'');
  70. end;
  71.  
  72. procedure sendascii(fn:str);
  73. var f:file of char; c,c1:char; abort:boolean; i:integer;
  74.   procedure ckey;
  75.   begin
  76.     checkhangup;
  77.     while (not empty) and (not abort) do begin
  78.       if hangup then abort:=true;
  79.       c1:=inkey;
  80.       if (c1=^X) or (c1=#27) or (c1=' ') then abort:=true;
  81.       if c1=^S then getkey(c1);
  82.     end;
  83.   end;
  84. begin
  85.   assign(f,fn);
  86.   {$I-} reset(f); {$I+}
  87.   if ioresult<>0 then print('File not found.') else begin
  88.     abort:=false;
  89.     clrscr;
  90.     writeln('File: ',fn);
  91.     writeln('<ESC> to abort');
  92.     writeln;
  93.     gotoxy(1,5);
  94.     for i:=1 to 80 do write(#205);
  95.     gotoxy(1,17);
  96.     for i:=1 to 80 do write(#205);
  97.     window(1,10,80,20);
  98.     clrscr;
  99.     print('^X=ABORT');
  100.     print('^S=PAUSE'); nl;
  101.     while (not abort) and (not eof(f)) do begin
  102.       read(f,c); o(c); if (c<>#7) then write(c); ckey;
  103.     end;
  104.     close(f);
  105.     if useron then window(1,5,80,25) else window(1,1,80,25); gotoxy(1,19);
  106.     nl; nl; print('> FILE TRANSMISSION COMPLETE');
  107.   end;
  108. end;
  109.  
  110. procedure send(fn:str; var dok:boolean);
  111. var filv:file; try,mb,bn,ers,lbn:integer; done,abort:boolean; st,start:real; c:char;
  112.     x,y:integer; bfr:array [0..1023] of byte; numbt,numba:integer;
  113.  
  114.   procedure sb(bn:integer);
  115.   var bp:real; onumbt,c:integer;
  116.  
  117.     procedure mb0;
  118.     var i:str; c:integer;
  119.     begin
  120.       i:=fn;
  121.       while pos(' ',i)>0 do delete(i,pos(' ',i),1);
  122.       for c:=1 to length(i) do
  123.         if i[c] in ['A'..'Z'] then
  124.           i[c]:=chr(ord(i[c])-ord('A')+ord('a'));
  125.       i:=i+#0+cstrr(longfilesize(filv));
  126.       for c:=1 to length(i) do bfr[c-1]:=ord(i[c]);
  127.       numbt:=128; numba:=length(i);
  128.     end;
  129.  
  130.   begin
  131.     crc:=0; chksum:=0; onumbt:=numbt;
  132.     if bn=0 then mb0 else begin
  133.       bp:=(lbn*1.0-1.0)*128.0;
  134.       longseek(filv,bp);
  135.       blockread(filv,bfr[0],numbt,numba);
  136.     end;
  137.     for c:=numba to numbt-1 do bfr[c]:=0; c:=0;
  138.     if numbt=1024 then o1(#2) else o1(#1); o1(chr(lo(bn))); o1(chr(lo(bn) xor 255));
  139.     while (c<numbt) do begin
  140.       o1(chr(bfr[c])); calccrc(bfr[c]); c:=c+1;
  141.     end;
  142.     if ucrc then begin o1(chr(hi(crc))); o1(chr(lo(crc))); end else o1(chr(chksum));
  143.     dump; numbt:=onumbt;
  144.   end;
  145.  
  146.   procedure sblock(bn:integer; var abort:boolean);
  147.   var start:real; done:boolean; b:blk; try,i:integer; c:char;
  148.  
  149.   procedure ckbd;
  150.   begin
  151.     if keypressed then begin
  152.       read(kbd,c); if c=#27 then begin abort:=true; done:=true;
  153.       gotoxy(1,6); write('ABORTED FROM KEYBOARD'); end;
  154.     end;
  155.   end;
  156.  
  157.   begin
  158.     try:=1; abort:=false;
  159.     checkhangup;
  160.     done:=false;
  161.     while (not done) and (not hangup) do begin
  162.       gotoxy(20,3); write(bn); if ymodem then write('-',lbn);
  163.       gotoxy(20,4); write(try-1);
  164.       gotoxy(20,5); write(ers);
  165.       sb(bn);
  166.       start:=timer;
  167.       while tcheck(start,20) and (not commpressed) and (not hangup) and (not abort)
  168.         do begin checkhangup; ckbd; end;
  169.       ckbd;
  170.       if commpressed then c:=cinkey1 else c:=#21;
  171.       case c of
  172.         #6:done:=true;
  173.         #24:begin done:=true; abort:=true; gotoxy(1,6); write('ABORTED REMOTELY   '); end;
  174.         else begin try:=try+1; ers:=ers+1; if try>9 then begin
  175.             abort:=true; done:=true;
  176.             gotoxy(1,6); write('EXCESSIVE ERRORS     ');
  177.           end;
  178.         end;
  179.       end;
  180.     end;
  181.   end;
  182.  
  183.   function ok:boolean;
  184.   var start:real; c:char; try:integer; done:boolean;
  185.   begin
  186.     done:=false; abort:=false; start:=timer;
  187.     while tcheck(timer,90) and (not done) and (not abort) and (not hangup) do begin
  188.       checkhangup;
  189.       if keypressed then begin
  190.         read(kbd,c);
  191.         if c=#27 then begin
  192.           gotoxy(1,6); write('ABORTED FROM KEYBOARD');
  193.           abort:=true;
  194.         end;
  195.       end;
  196.       if commpressed then begin
  197.         c:=cinkey1;
  198.         if c=#21 then begin ucrc:=false; done:=true; end;
  199.         if c='C' then begin ucrc:=true; done:=true; end;
  200.         if c=#24 then begin abort:=true;
  201.           gotoxy(1,6); write('ABORTED REMOTELY    ');
  202.         end;
  203.       end;
  204.     end;
  205.     if not tcheck(timer,90) then begin
  206.       gotoxy(1,6); write('TIMEOUT ERROR    ');
  207.       abort:=true;
  208.     end;
  209.     ok:=(not abort) and (not hangup);
  210.   end;
  211.  
  212. begin
  213.   assign(filv,fn); ers:=0; if ymodem then numbt:=1024 else numbt:=128;
  214.   {$I-} reset(filv,1); {$I+}
  215.   if ioresult=0 then begin
  216.     mb:=trunc((longfilesize(filv)+127.0)/128.0);
  217.     if useron then print('> WAITING FOR START, ^X to abort'); x:=wherex; y:=wherey;
  218.     for bn:=1 to 6 do begin gotoxy(49,bn); write(#186); end;
  219.     gotoxy(49,7); write(#200); for bn:=1 to 30 do write(#205);
  220.     if useron then window(50,5,80,10) else window(50,1,80,6);
  221.     clrscr; writeln('File: ',fn);
  222.     writeln('Total blocks     = ',mb);
  223.     writeln('Current block    = 0');
  224.     writeln('# consec. errors = 0');
  225.     writeln('# errors         = 0');
  226.     write('<ESC> to abort');
  227.     if ok then begin
  228.       bn:=1; lbn:=1; try:=1;
  229.       if ft<>255 then begin
  230.         while (not abort) do begin
  231.           o1(#$81); o1(chr(ft)); o1(chr(ft xor $ff));
  232.           st:=timer; try:=try+1;
  233.           while tcheck(st,3) and not commpressed do;
  234.           if tcheck(st,6) then c:=cinkey else try:=try+1;
  235.           if (c=#6) or (try>4) then abort:=true;
  236.         end;
  237.         abort:=false; try:=1;
  238.       end;
  239.       if ymodem then sblock(0,abort);
  240.       while (not abort) and (lbn<=mb) do begin
  241.         sblock(bn,abort);
  242.         bn:=bn+1; if ymodem then lbn:=lbn+8 else lbn:=lbn+1;
  243.       end;
  244.       if not abort then begin
  245.         try:=1; done:=false;
  246.         repeat
  247.           start:=timer;
  248.           gotoxy(20,3); write('EOT ');  o1(#4); clreol;
  249.           while tcheck(start,10) and not commpressed and not hangup do checkhangup;
  250.           if commpressed then begin
  251.             c:=cinkey1; if c=#6 then begin
  252.               done:=true;
  253.             end;
  254.           end;
  255.           if not done then try:=try+1;
  256.         until (try>9) or hangup or done;
  257.       end;
  258.     end;
  259.     close(filv);
  260.     if useron then window(1,5,80,25) else window(1,1,80,25);
  261.     gotoxy(x,y);
  262.     dok:=not abort;
  263.     if dok then begin
  264.       thisuser.downloads:=thisuser.downloads+1;
  265.       thisuser.dk:=thisuser.dk+((mb+4) div 8);
  266.       print('> FILE TRANSMISSION COMPLETE');
  267.     end;
  268.   end else print('File not found.');
  269. end;
  270.  
  271. procedure receive(fn:str; var dok:boolean);
  272. var f:file; r1:array[0..1023] of byte; nbts,x,y,terr,xx,t1,csum,try,block,lblk,len:integer; b,b1,b2:byte; c:char;
  273.     bn0,start,abort,error,done,timeo,kba,sav:boolean; rl,rl1,rfl:real;
  274.  
  275. const nak=#21;
  276.       ack=#06;
  277.       can=#24;
  278.       soh=#01;
  279.  
  280.   procedure onec(var b:byte);
  281.   var r:real; c:char; i:byte;
  282.   begin
  283.     if buffer_Head<>buffer_Tail then begin
  284.       inline($FA);
  285.       b:=ord(buffer[buffer_Tail]);
  286.       buffer_Tail:=(buffer_Tail+1) mod (buffer_max+1);
  287.       inline($FB);
  288.     end else begin
  289.       r:=timer;
  290.       while (not commpressed) and tchk(r,1.0) do checkhangup;
  291.       if commpressed then b:=ord(cinkey1) else begin timeo:=true; b:=0; end;
  292.       if timeo then error:=true;
  293.       if hangup then begin error:=true; done:=true; abort:=true; end;
  294.     end;
  295.     if ucrc then begin
  296.       crc:=crc xor (b shl 8);
  297.       for i := 0 to 7 do begin
  298.         if (crc<0) then
  299.           crc:=(crc shl 1) xor $1021
  300.         else
  301.           crc:=crc shl 1;
  302.       end;
  303.     end else chksum := lo(chksum + b);
  304.   end;
  305.  
  306.   function onec1:byte;
  307.   var r:real; c:char;
  308.   begin
  309.     checkhangup;
  310.     r:=timer;
  311.     while (not commpressed) and tcheck(r,6) and (not hangup) do checkhangup;
  312.     if commpressed then onec1:=ord(cinkey1) else begin timeo:=true; onec1:=0; end;
  313.     if timeo then error:=true;
  314.     if hangup then begin error:=true; done:=true; abort:=true; end;
  315.   end;
  316.  
  317.   procedure checkkb;
  318.   var c:char;
  319.   begin
  320.     if keypressed then begin read(kbd,c); if c=#27 then begin
  321.       done:=true; abort:=true; gotoxy(5,5); writeln('ABORTED FROM KEYBOARD'); clreol; kba:=true; end;
  322.     end;
  323.   end;
  324.  
  325.   procedure rb0;
  326.   var i:str; c:integer;
  327.   begin
  328.     c:=0; while (r1[c]<>0) and (c<100) do c:=c+1;
  329.     c:=c+1; i:='';
  330.     while (chr(r1[c]) in ['0'..'9']) and (length(i)<10) do begin
  331.       i:=i+chr(r1[c]);
  332.       c:=c+1;
  333.     end;
  334.     rfl:=valuer(i); if rfl<0.0 then rfl:=0.0;
  335.   end;
  336.  
  337. begin
  338.   abort:=false; done:=false; timeo:=false; kba:=false;
  339.   block:=1; try:=1; start:=false; lblk:=1;
  340.   assign(f,fn); rl1:=timer; rfl:=0.0;
  341.   {$I-} rewrite(f,1);{$I+}
  342.   if ioresult<>0 then begin
  343.     print('> DISK ERROR, SORRY CAN''T UPLOAD IT.');
  344.     done:=true; abort:=true;
  345.   end;
  346.   if useron then print('> WAITING FOR START, ^X to abort'); x:=wherex; y:=wherey;
  347.   for terr:=1 to 6 do begin gotoxy(49,terr); write(#186); end;
  348.   gotoxy(49,7); write(#200); for terr:=1 to 30 do write(#205);
  349.   if useron then window(50,5,80,10) else window(50,1,80,6);
  350.   clrscr; writeln('File: '+fn);
  351.   writeln('Block number  = 0');
  352.   writeln('Consec errors = 0');
  353.   writeln('Total errors  = 0');
  354.   writeln('ER:');
  355.   write('<ESC> to abort.');
  356.   error:=true; terr:=0; bn0:=false;
  357.   while (not done) and (not hangup) do begin
  358.     gotoxy(17,3); write(try-1); gotoxy(17,4); write(terr); gotoxy(17,2); write(block,'-',lblk);
  359.     checkkb; if kba then begin done:=true; abort:=true; end;
  360.     if kba then o1(can) else
  361.       if error then begin if (block=1) and ucrc then o1('C') else o1(nak);
  362.         dump; if block<>1 then terr:=terr+1; try:=try+1;
  363.         gotoxy(17,3); write(try-1); gotoxy(17,4); write(terr); gotoxy(17,2); write(block,'-',lblk);
  364.       end else begin
  365.         o1(ack); dump;
  366.         if bn0 then rb0;
  367.         bn0:=false;
  368.         if sav and (not error) then begin
  369.           try:=1;
  370.           longseek(f,(lblk-1.0)*128.0);{$I-} blockwrite(f,r1,nbts); {$I+} if ioresult<>0 then begin
  371.             done:=true; abort:=true; gotoxy(5,5); write('DISK ERROR'); clreol;
  372.             sysoplog('Disk error in upload');
  373.           end;
  374.           block:=block+1; if ymodem then lblk:=lblk+8 else lblk:=lblk+1;
  375.         end else
  376.         begin gotoxy(5,5); write('Low block number ',block-1); clreol; end;
  377.       end;
  378.     if (not done) and (not abort) and (not hangup) then begin
  379.       start:=false; t1:=0;
  380.       while (not start) and (not hangup) and (not abort) do begin
  381.         timeo:=false;
  382.         b:=onec1;
  383.         if b=$81 then begin
  384.           b1:=onec1; b2:=onec1;
  385.           if b1=(b2 xor $ff) then begin
  386.             ft:=b1; o1(ack);
  387.           end else o1(nak);
  388.         end;
  389.         if b=ord(soh) then begin start:=true; ymodem:=false; end;
  390.         if b=2 then begin start:=true; ymodem:=true; end;
  391.         if b=ord(can) then begin abort:=true; done:=true; gotoxy(5,5); write('ABORTED REMOTELY'); clreol; end;
  392.         if b=04 then begin o1(ack); start:=true; done:=true; gotoxy(5,5); write('EOT RECEIVED'); clreol; end;
  393.         if timeo then begin if (block=1) and ucrc then o1('C') else o1(nak); t1:=t1+1; end;
  394.         if t1>=9 then begin start:=true; abort:=true; done:=true; end;
  395.       end;
  396.       if kba then begin o1(can); gotoxy(5,5); write('ABORTED FROM KEYBOARD'); clreol; end;
  397.     if try>9 then begin abort:=true; done:=true; gotoxy(5,5); write('ABORTING - too many errors'); clreol; end;
  398.     if t1>=9 then begin abort:=true; done:=true; gotoxy(5,5); write('TIMEOUT'); clreol; end;
  399.     error:=false; checkkb;
  400.     if not done then begin
  401.       gotoxy(17,3); write(try-1); gotoxy(17,4); write(terr); gotoxy(17,2); write(block,'-',lblk);
  402.       sav:=true;
  403.       onec(b1); if b1<>lo(block) then
  404.         if (b1+1) mod 256=lo(block) then begin
  405.           sav:=false;
  406.           if (block=1) and (b1=0) then bn0:=true;
  407.         end else begin
  408.           error:=true; gotoxy(5,5); write('bn was ',b1,' vs. ',lo(block)); clreol;
  409.         end;
  410.       onec(b); if b xor 255<>b1 then begin error:=true; gotoxy(5,5); write('com was ',b,' vs. ',b1 xor 255); clreol; end
  411.         else if sav and (b1<>lo(block)) then begin abort:=true; done:=true; end;
  412.       len:=0; chksum:=0; crc:=0; if ymodem then nbts:=1024 else nbts:=128;
  413.       while (len<nbts) and (not timeo) do begin
  414.         onec(r1[len]);
  415.         len:=len+1;
  416.       end;
  417.       xx:=crc; csum:=chksum;
  418.       onec(b); if ucrc then onec(b1);
  419.       if not error then begin
  420.         if ((b<>lo(csum)) and (not ucrc)) or
  421.            (((b<>hi(xx)) or (b1<>lo(xx))) and ucrc)
  422.         then begin error:=true; gotoxy(5,5); write('Checksum/CRC error in ',block); clreol; end;
  423.         end;
  424.       end;
  425.       if abort then o1(can);
  426.     end;
  427.   end;
  428.   if (rfl>0.1) and (rfl<=longfilesize(f)) then begin
  429.     longseek(f,rfl-1.0);
  430.     truncate(f);
  431.   end;
  432.   close(f);
  433.   if useron then window(1,5,80,25) else window(1,1,80,25);
  434.   gotoxy(x,y);
  435.   if hangup then abort:=true;
  436.   if abort then erase(f) else
  437.   begin
  438.     thisuser.uploads:=thisuser.uploads+1;
  439.     thisuser.uk:=thisuser.uk+((lblk+3) div 8);
  440.     writeln('> TRANSFER COMPLETED');
  441.     if timer<rl1 then rl1:=rl1-24.0*60*60;
  442.     extratime:=extratime+timer-rl1;
  443.     systat.uptoday:=systat.uptoday+1;
  444.   end;
  445.   dok:=not abort;
  446. end;
  447.  
  448. procedure send1(fn:str; var dok,abort:boolean);
  449. var i:integer;
  450. begin
  451.   i:=gtp(true); dok:=true; abort:=false;
  452.   if not useron then begin incom:=true; outcom:=true; if i=1 then i:=0; end;
  453.   case i of
  454.    -1:begin dok:=false; abort:=true; end;
  455.     0:dok:=false;
  456.     1:sendascii(fn);
  457.     2:if incom then begin ucrc:=false; ymodem:=false; send(fn,dok); end;
  458.     3:if incom then begin ucrc:=true; ymodem:=false; send(fn,dok); end;
  459.     4:if incom then begin ucrc:=true; ymodem:=true; send(fn,dok); end;
  460.   end;
  461.   if (i<=1) and (not incom) then dok:=false;
  462.   if useron then
  463.     if i>1 then
  464.       if dok then
  465.         sysoplog('Downloaded "'+fn+'"')
  466.       else
  467.         sysoplog('Tried D/L "'+fn+'"')
  468.     else
  469.       if i=1 then
  470.         sysoplog('Text D/L "'+fn+'"')
  471.       else
  472.   else begin incom:=false; outcom:=false; end;
  473. end;
  474.  
  475. procedure receive1(fn:str; var dok:boolean);
  476. var i:integer;
  477. begin
  478.   i:=gtp(false); dok:=true;
  479.   if not useron then begin incom:=true; outcom:=true; end;
  480.   case i of
  481.    -1:dok:=false;
  482.     0:dok:=false;
  483.     2:begin ucrc:=false; ymodem:=false; receive(fn,dok); end;
  484.     3:begin ucrc:=true; ymodem:=false; receive(fn,dok); end;
  485.     4:begin ucrc:=true; ymodem:=true; receive(fn,dok); end;
  486.   end;
  487.   if not useron then begin incom:=false; outcom:=false; end;
  488. end;
  489.