{PICS0D.INC Pascal Integrated Communications System Overlays} { 6/4/87 Version 1.6 Copyright 1987 by Les Archambault} overlay procedure SendFile(var xfrname:filename; var XfrFile:untype_file ;remaining:integer;sendmode:char;var ok_to_send:boolean); const maxerr = 10; var CRCmode,KMDmode,timeout,firstime: boolean; bt,cancel: byte; ch: char; mm, ss, time_on, time_left, i, vv,recs,tot_errcnt, krecs,xrecs,block, errcnt,bufsize,bufblocks,kblocks: integer; arc_size:real; file_buf:buf_ptr; hdr_array:array[1..27] of byte absolute hdr; procedure Read_Arc_Block; { read a block from the archive file } begin if EOF(arc_file) then endfile := TRUE else begin {$I-} BlockRead(arc_file, arcbuf, 1); {$I+} endfile:=(ioresult<>0); end; arcptr := 1 end; function Get_Arc_Ch : byte; { read 1 character from the archive file } begin if endfile then Get_Arc_Ch := 0 else begin Get_Arc_Ch := arcbuf[arcptr]; if arcptr = 128 then Read_Arc_Block else arcptr := arcptr + 1 end end; begin {sendfile} new(file_buf); cancel:=0; OK:=true; KMDmode:=false; firstime:=true; setsect(setdrv,setusr); if sendmode<>'B' then begin setsect(HomDrv,HomUsr); timer(time_on, time_left); send_time(remaining, mm, ss); setsect(setdrv,setusr); if mm > time_left then begin writeln(USR, 'Die verbleibende Zeit reicht nicht mehr aus.'); OK := FALSE end; end; if OK then begin errcnt := 0; tot_errcnt:=0; recs:=1; block := 1; xrecs:=0; krecs:=0; if sendmode<>'B' then begin kblocks:=remaining div 8; if remaining mod 8<>0 then kblocks:=succ(kblocks); writeln(USR, XfrName, ' enthaelt: ', remaining, ' Bloecke.'); for i:=1 to length(XfrName) do write(usr,' '); writeln(usr,' ',kblocks,' 1k-Bloecke.'); writeln(USR, 'Transfer-Zeit ca. ', mm, ' Min. und ',ss, ' Sek. bei ', rate, ' Baud.'); if sendmode = 'K' then writeln(USR,'Eingestelltes Protokoll ist 1K-Xmodem.') else writeln(USR,'Eingestelltes Protokoll ist Xmodem.'); writeln(USR, 'Zum Abbrechen mehrmals Ctrl-X druecken.'); if in_arc then begin writeln(usr,'Archiv-Teile werden komprimiert gesendet.'); writeln(usr,'Nicht vergessen, anschliessend mit .ARC-Endung umzubenennen.'); end; writeln(USR, 'Fertig zum Senden...'); end; if (sendmode='K') or (sendmode='B') then KMDmode:=true; repeat bt := (GetByte(10, timeout) and $7F); CRCmode := ((bt=ord('C')) or (bt=ord('c'))); if CRCmode then begin if cancel>0 then cancel:=0; bt:=(getbyte(1,timeout) and $7F); if (sendmode<>'K') and (sendmode<>'B') then KMDmode:=((bt=ord('K')) or (bt=ord('k'))); if KMDmode and (remaining>=8) then begin writeln('1K Protokoll'); bufblocks:=8; bufsize:=1024; krecs:=remaining div 8; xrecs:=remaining mod 8; end else begin KMDmode:=false; bufblocks:=1; bufsize:=128; end; writeln('CRC Modus.'); errcnt := 0 end else if bt = ord(NAK) then begin if cancel>0 then cancel:=0; writeln('Checksum Modus.'); errcnt := 0; bufsize:=128; bufblocks:=1; end else if bt = ord(CAN) then begin errcnt:=succ(errcnt); cancel:=succ(cancel); if cancel>=2 then errcnt := maxerr end else {timeout or another char} begin if cancel>0 then cancel:=0; errcnt := succ(errcnt); end; until (errcnt = 0) or (errcnt >= maxerr); while ch_carck and ch_inprdy do bt:=ch_inp; {eat garbage} if KMDmode then remaining:=krecs; if in_arc then arc_size:=Long_to_Real(hdr.size)+29.0; while (remaining > 0) and (errcnt < maxerr) do begin if (not in_arc) then blockread(XfrFile, file_buf^, bufblocks) else begin if (block=1) and firstime then begin firstime:=false; file_buf^[1]:=26; {archive id byte} file_buf^[2]:=hdrver; for i:=1 to sizeof(heads) do file_buf^[i+2]:=hdr_array[i]; if arc_size>=bufsize-29 then begin for i:=30 to bufsize do file_buf^[i]:=get_arc_ch; arc_size:=arc_size-bufsize; end else begin for i:=1 to trunc(arc_size) do file_buf^[i]:=get_arc_ch; file_buf^[trunc(arc_size)+1]:=26; file_buf^[trunc(arc_size)+2]:=0; end; end else begin if arc_size>=bufsize then begin for i:=1 to bufsize do file_buf^[i]:=get_arc_ch; arc_size:=arc_size-bufsize; end else begin for i:=1 to trunc(arc_size) do file_buf^[i]:=get_arc_ch; file_buf^[trunc(arc_size)+1]:=26; file_buf^[trunc(arc_size)+2]:=0; end; end; end; remaining := pred(remaining); vv := 0; if CRCmode then begin for i := 1 to bufsize do updcrc(vv, file_buf^[i]); updcrc(vv, 0); updcrc(vv, 0); end else for i := 1 to bufsize do vv := vv + file_buf^[i]; repeat if (KMDmode) and (bufsize>128) then PutByte(ord(STX)) else PutByte(ord(SOH)); PutByte(lo(block)); PutByte(not lo(block)); for i := 1 to bufsize do PutByte(file_buf^[i]); if CRCmode then PutByte(hi(vv)); PutByte(lo(vv)); repeat bt := (GetByte(10, timeout) and $7F); if bt = ord(ACK) then begin if cancel>0 then cancel:=0; if (KMDmode) and (bufsize>128) then begin write(CR, 'Gesendete Bloecke: ',recs,'-',recs+7); recs:=recs+8; end else begin if KMDmode then begin write(cr); ClrEol; end; write(CR, 'Gesendeter Block: ', recs); { Local display of what is happening } recs:=succ(recs); end; block := succ(block) mod 256; errcnt := 0; end else if (bt = ord(NAK)) or timeout then begin if cancel>0 then cancel:=0; if bt = ord(NAK) then write(' ++ NAK received') else write(' ++ Timeout'); errcnt := succ(errcnt); tot_errcnt:=succ(tot_errcnt); writeln(' - Error ', errcnt, ' ++') end else if bt = ord(CAN) then begin errcnt:=succ(errcnt); cancel:=succ(cancel); if cancel>=2 then errcnt:=maxerr; end; ch := GetChar; { Monitor local console } until (bt in [ord(ACK), ord(NAK)]) or (errcnt>=maxerr) or timeout; until (errcnt = 0) or (errcnt >= maxerr); If (KMDmode) and (bufsize>128) and (tot_errcnt>(maxerr div 2)) and (tot_errcnt<255) then begin xrecs:=(remaining * 8)+xrecs; remaining:=0; {set up to change back to 128 bytes} tot_errcnt:=255; {prevent second use of this routine} end; if (KMDmode) and (remaining=0) and (xrecs>0) then begin bufblocks:=1; {switch back to 128 block size} bufsize:=128; remaining:=xrecs; xrecs:=0; end; end; {while errors less than max and more to send} writeln; OK := (errcnt = 0); if OK then begin repeat PutByte(ord(EOT)); if ord(ACK) = (GetByte(6, timeout) and $7F) then errcnt := 0 else errcnt := succ(errcnt) until (errcnt = 0) or (errcnt >= maxerr); OK := (errcnt = 0); if sendmode<>'B' then begin if OK then begin writeln(USR, 'Transfer beendet.'); if (not clock) then for i:=1 to mm do begin tick_a_min; hour_count:=hour_count+10.0; end; end else writeln(USR, 'Dateiende (EOT) nicht bestaetigt.') end; end else begin if sendmode<>'B' then writeln(USR, 'Transfer abgebrochen.'); putbyte(ord(CAN)); putbyte(ord(CAN)); end; end; if (not ok) then ok_to_send:=false; dispose(file_buf); end; Overlay procedure Test_Download_Ratio(var ok_to_send:boolean ;sendmode:char;fnum:integer); var i,x:integer; begin if (up_down_ratio>0) and (ok_to_send) then begin x:=user_rec.download; if sendmode='B' then x:=x+Fnum; if x=0 then x:=1; i:=user_rec.upload+1; if (((i*up_down_ratio) div x) < 2) and (((i*up_down_ratio) mod x) < 5) then begin writeln(usr); writeln(usr,'Das System erlaubt ',up_down_ratio,' Downloads pro Upload.'); writeln(usr,'Du naeherst Dich mit ',user_rec.download, ' Downloads und ',user_rec.upload,' Uploads diesem Limit.'); if sendmode='B' then Writeln(usr,'Batch-Transfer fuegt Deinen Downloads ',fnum,' hinzu.'); writeln(usr); end; if ((i*up_down_ratio) div x)<1 then begin ok_to_send:=false; writeln(usr); writeln(usr,'Download ist erst nach Empfang eines Uploads moeglich.'); writeln(usr); end; end; end; {end of PICS0D.INC }