Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Posting-Version: version B 2.10 5/3/83; site k.cs.cmu.edu
Path: utzoo!watmath!clyde!burl!ulysses!mhuxr!mhuxn!ihnp4!qantel!lll-crg!seismo!rochester!pt.cs.cmu.edu!k.cs.cmu.edu!tim
From: tim@k.cs.cmu.edu (Tim Maroney)
Newsgroups: net.sources.mac
Subject: Macintosh Internet Protocols (8 of 12) (most of TFTP)
Message-ID: <668@k.cs.cmu.edu>
Date: Tue, 26-Nov-85 05:39:04 EST
Article-I.D.: k.668
Posted: Tue Nov 26 05:39:04 1985
Date-Received: Fri, 29-Nov-85 09:14:52 EST
Organization: Carnegie-Mellon University, Networking
Lines: 1796

echo extracting net/tftp_lib.text...
cat >net/tftp_lib.text <<'!E!O!F!'
{$X-}
{$M+}
{$R-}
{$0V-}
{$D-}
{$DECL DEBUG}
{$SETC DEBUG := false}
{$DECL ALLOCT}
{$SETC ALLOCT := false}
{$DECL BUNDLE}
{$SETC BUNDLE := true}
UNIT TFTP_Lib;

{ Please note the copyright notice in the file "copyright/notice" }

  { TFTP_LIB module using UDP over the Applebus		 }
  { by Mark Sherman (Dartmouth) and Tim Maroney (C-MU)	 }

INTERFACE

{$L-}
   USES {$U-}
      {$U Obj-Memtypes	  } Memtypes,
      {$U Obj-QuickDraw	  } QuickDraw,
      {$U Obj-OSIntf	  } OSIntf,
      {$U Obj-ToolIntf	  } ToolIntf,
      {$U Obj-ABPasIntf	  } ABPasIntf,
      {$U net-Task_Lib	  } Task_Lib,
      {$U net-Timer_Lib	  } Timer_Lib,
      {$U net-err_lib	  } Err_Lib,
      {$U net-IP_Lib	  } IP_Lib,
      {$U net-UDP_Lib	  } UDP_Lib,
      {$U net-calls	  } Call_Lib,
      {$U net-tftp_defs	  } TFTP_Defs,
      {$U net-tftp_file	  } TFTP_File;

{$L+}

CONST
	TFTKSZ = 2048;

PROCEDURE tftpinit;
PROCEDURE tfsinit(alert: ProcPtr; done:ProcPtr);
FUNCTION tftpuse(fhost: in_name; fname: StringPtr; volume:Integer;
		  rmfile: StringPtr; dir: integer; mode: integer;
		  userDone: ProcPtr): LongInt;
PROCEDURE tfs_on;
PROCEDURE tfs_off;
PROCEDURE tfabort;

IMPLEMENTATION

CONST MINTICKS = 10*60;

{ read or write request packet }
CONST
   MaxFileName = 512;
   tf_name_offset = 2;
TYPE
   tfreq = PACKED RECORD
	 {+0}	   tf_op: integer;	   { would be 1 (read) or 2 (write) }
	 {+2}	   tf_name: packed array[0..MaxFileName] of byte;
	END;
   Ref_tfreq = ^ tfreq;

{ data packet }

   tfdata = PACKED RECORD
	   { +0 }     tf_op: integer;	      { would be 3 }
	   { +2 }     tf_block: integer;
	   { +4 }     tf_data: packed array [0..511] of byte;
	END;
   Ref_tfdata = ^ tfdata;

{ finder information packet }
   tffinder = PACKED RECORD
	   { +0 }       tf_op: Integer;	     { would be 3 }
	   { +2 }       tf_block: Integer;   { would be 1 }
	   { +4 }       tf_finder: FInfo;
	 END;
     Ref_tffinder = ^ tffinder;

{ structure of an ack packet }

    tfack = PACKED RECORD
		tf_op: integer;	        { would be 4 }
		tf_block: integer;
	END;
    Ref_tfack = ^ tfack;

Ref_LongInt = ^ LongInt;

CONST
{ TFTP states }
	DATAWAIT        = 1;
	ACKWAIT	        = 2;
	DEAD	        = 3;
	TIMEOUT	        = 4;
	RCVERR	        = 5;
	RCVACK	        = 6;
	RCVDATA	        = 7;
	RCVLASTDATA     = 8;
	TERMINATED      = 9;

	TFTPSOCK        = 69    { TFTP's well known port };
	TFTPTRIES       = 10    { # of retries on packet transmission };
	REQTRIES        = 4     { # of retries on initial request };
	NORMLEN	        = 512   { normal length of received packet };

{  Constants for round trip time estimation and retry timeout.
    All calculation is done in clock ticks (at a rate of 18/second) but
    only the initial estimate and the upper limit are specified in ticks;
    the rest of the algorithm uses dimensionless multipliers.  }
{ Added multiplier of 4 for Macintosh (60 ticks/second) }

	Kinit = 3*4;    { Old = 3; Initial divisor for (1+1/K) estimate multiplier. }
	Kinc =  1;      { Reduce K by this if previous packet lost.  }
	T0    = 36;     { Initial value for round trip time estimate.  }

	MAXTMO = 4*216; { Old=216; upper limit on retry timeout timer, in ticks.}
	TMMULT =  3;    { multiplier to get retry timeout from round trip
			   estimate.  }

	OFF     = 0;
	ON      = 1;

	MAXTFTPS = 1;

VAR
	tfs_alert,server_done: ProcPtr;
	tftp: UDPCONN;
	tfstate: Byte;
	tfconnq:QHdr;	        { TFTP connection queue }

PROCEDURE tfrpyerr(udpc:UDPCONN; p: PACKET; code:Integer; text: StringPtr);
	FORWARD;
FUNCTION tfcleanup(cn: Ref_tfconn): LongInt;
	FORWARD;
PROCEDURE tfshnd(p:PACKET; len:Integer; host: in_name; Foo_Value:PTR);
	FORWARD;
PROCEDURE tftpwrit(cn: Ref_tfconn);
	FORWARD;
PROCEDURE tftpread(cn: Ref_tfconn);
	FORWARD;
PROCEDURE tftprcv(p:PACKET; len: Integer; fhost: in_name; cn: Ref_tfconn);
	FORWARD;
FUNCTION tfmkcn(dir:Integer; mode:Integer): Ref_tfconn;
	FORWARD;
PROCEDURE tfsndack(cn:Ref_tfconn; number: integer);
	FORWARD;
FUNCTION tfsndata(cn: Ref_tfconn; len: integer): Integer;
	FORWARD;
FUNCTION tfsndreq(cn: Ref_tfconn; fname: StringPtr): Integer;
	FORWARD;
FUNCTION tf_write(cn: Ref_tfconn; len: integer): Integer;
	FORWARD;
PROCEDURE tftptmo(cn: Ref_tfconn);
	forward;
PROCEDURE tfdoerr(cn: Ref_tfconn; p:PACKET; len:Byte);
	forward;

{$IFC DEBUG}
PROCEDURE tfcndump(cn: Ref_tfconn); FORWARD;

PROCEDURE out_inaddr(addr:in_name);
VAR tmp:STR255;
BEGIN
	cvt_inaddr(addr,tmp);
	Write(tmp);
END;
{$ENDC}

{$IFC ALLOCT}
PROCEDURE NoteAlloc(p:PACKET; s:STR255);
BEGIN
	WriteLn(s,': ',ORD4(p));
END;
{$ENDC}

{$S InitSeg}

PROCEDURE tftpinit;
BEGIN
	ntftps := 0;
	tfconnq.qFlags := 0;
	tfconnq.qHead := NIL;
	tfconnq.qTail := NIL;
END;

{$S TFTPSeg }

PROCEDURE tfkill(cn: Ref_tfconn);
VAR Dummy: Boolean;
BEGIN
    Dummy := tm_clear(cn^.tf_tm);
    cn^.tf_state := DEAD;
    tk_wake(cn^.tf_task);
END; { tfkill }

{ abort all TFTP connections }
PROCEDURE tfabort;
VAR     cn:Ref_tfconn;
	Dummy: Boolean;
BEGIN
	cn := POINTER(ORD4(tfconnq.qHead));
	while (cn <> NIL) do
		begin
		if cn^.tf_rcv >= 1 then begin
{$IFC DEBUG}
			WriteLn('tfabort: aborting connection in progress');
{$ENDC}
			tfudperr(cn^.tf_udp, cn^.tf_outp, ERRTXT,
				 StrCvt('Connection aborted'));
			tfkill(cn);
			end
		else begin
			{ I couldn't get this to work, so it's disallowed }
			Error(StrCvt(
				'Sorry, you can''t abort a connection request.'));
			end;
		cn := cn^.tf_next;
		end;
END;

FUNCTION tftp_data(p:Packet): PTR;
VAR Temp: Ref_tfdata;
BEGIN
    Temp := POINTER(ORD4(tftp_head(p)));
    tftp_data := POINTER( ORD4(temp) + { offset for tf_data } 4 );
END; { tftp_data }

{ turn the tftp server on}

PROCEDURE tfs_on;
BEGIN
	tfstate := ON;
END; { End of tfs_on }

{ turn the tftp server off }

PROCEDURE tfs_off;
BEGIN
	tfstate := OFF;
END; { end of tfs_off }

{ tfsinit(alert, done) - initialize the tftp server. This opens a UDP
	 connection but does not turn on the server. That needs to done by
	 an explicit call to tfs_on().
	alert() is a function which the server will call whenever it receives
	request for a transfer. This function will be called in the following
	way:
		alert(ip_addr, file_name, direction)

	alert() should return TRUE if it wishes to allow the transfer and
	FALSE otherwise.  done() is a function that the server will
	call to inform the invoker that this file transfer is complete or
	aborted.
}

PROCEDURE tfsinit(alert: ProcPtr; done:ProcPtr);
BEGIN
	tfstate := OFF;
	refusedt := 0; {time of most recent transfer refusal}

	tftp := udp_open(0, 0, TFTPSOCK, @tfshnd, NIL);
	IF (tftp=NIL) THEN
		Fatal(StrCvt('Can''t open UDP socket'),false);

	server_done := done;
	tfs_alert := alert;
END; { End of tfsinit }

{ handle an incoming tftp packet. This involves opening a udp connection
	(immediately so that we can report errors). If the server is OFF
	then the tftp will be refused; otherwise more checking will be done.
	Call the alert function and verify that the 'user' wishes to allow
	the tftp. Report an error if not. Finally, spawn a task to oversee
	the tftp and cleanup when it's done.
}

PROCEDURE tfshnd(p:PACKET; len:Integer; host: in_name; Foo_Value:PTR);
CONST
	Ignore_Case = FALSE;
	No_Diacrit = TRUE;
VAR
	nport: integer;
	ptreq: Ref_tfreq;
	cn: Ref_tfconn;
	mode: integer;
	FPart: tf_FilePart;
	smode,fname: STR255;
	FPartName: STRING[15];
	pup: Ref_udp;
	tmpudp: UDPCONN;
	TransDir: Integer;
	LongDummy: LongInt;
	OSStatus: OSErr;
{$IFC DEBUG}
	TempPtr: Ref_TFTP;
	TP2: Ref_Udp;
{$ENDC}

BEGIN
	CheckTask;

{$IFC DEBUG}
	WriteLn('tfshnd: entering tf server handler');
	WriteLn('Packet pointer: ',ORD4(p));
	WriteLn('Length	       : ',len);
	{ Write('Host	       : ');out_inaddr(host);WriteLn; }
	WriteLn('Useless data  : ',ORD4(Foo_Value));
	Write('TFTP Header at: ');
	TempPtr := tftp_head(p);
	IF TempPtr <> NIL THEN Write(ORD4(TempPtr)) ELSE Write(' NIL ');
	WriteLn('');
	IF TempPtr <> NIL THEN BEGIN
	    WriteLn('OPCde	 :',TempPtr^.tf_op);
	    WriteLn('Block	 :',TempPtr^.tf_block);
	    END;
	TP2 := udp_head(in_head(p));
	Write('UDP Header at : ');
	IF TP2 <> NIL THEN Write(ORD4(TP2)) ELSE Write(' NIL ');
	WriteLn('');
	IF TP2 <> NIL THEN BEGIN
	    WriteLn(' ud_srcp ',TP2^.ud_srcp);
	    WriteLn(' ud_dstp ',TP2^.ud_dstp);
	    WriteLn(' ud_len  ',TP2^.ud_len);
	    WriteLn(' ud_cksum',TP2^.ud_cksum);
	    END;
{$ENDC}

	pup := udp_head(in_head(p));

	{ If there is already a connection like this one, ignore duplicate
	  request. }

	if (udp_ckcon(host, pup^.ud_srcp) <> NIL) THEN BEGIN
{$IFC DEBUG}
		WriteLn('tfshnd: udp_ckcon <> NIL');
{$ENDC}
{$IFC ALLOCT}
		Write('tfshnd 1: ');
{$ENDC}
		udp_free(p);
		exit(tfshnd);
		END;

	{  If we refused a connection since this request got enqueued,
	assume this is a duplicate and discard it, so we don't bother the
	user with a duplicate question.	 (If we are unlucky, this might be
	a request from somewhere else that arrived while the user was
	thinking over the previous request.  Tough; somewhere else will
	just have to try again.)  }

	if (refusedt > p^.nb_tstamp) THEN BEGIN
{$IFC DEBUG}
		WriteLn('tfshnd: refusedt > p^.nb_tstamp');
{$ENDC}
{$IFC ALLOCT}
		Write('tfshnd 2: ');
{$ENDC}
		udp_free(p);
		exit(tfshnd);
		END;

	{  The next question:  Do we have room to do this transfer?  }

	if (ntftps >= MAXTFTPS) THEN BEGIN
		tk_yield;       { maybe the connection is waiting to die }
		if (ntftps >= MAXTFTPS) THEN BEGIN
			tfrpyerr(tftp, p, ERRTXT, StrCvt('Too many connections.'));
{$IFC ALLOCT}
			Write('tfshnd 3: ');
{$ENDC}
			udp_free(p);
			exit(tfshnd);
			END;
		END;

	ntftps := ntftps + 1;

	{  OK, let's check over the request more carefully. }

	ptreq := POINTER(ORD4(tftp_head(p)));
	ptreq^.tf_op := { bswap } (ptreq^.tf_op); { Swapping unnecssary on 68000 }
	IF (ptreq^.tf_op > WRQ) THEN BEGIN
{$IFC DEBUG}
		WriteLn('TFTP SERVER: bad tftp opcode ',ptreq^.tf_op);
{$ENDC}
{$IFC ALLOCT}
		Write('tfshnd 4: ');
{$ENDC}
		udp_free(p);
		ntftps := ntftps - 1;
		exit(tfshnd);
		END;

	{ Extract the file name from the request }
	CStr2PStr({ @ptreq^.tf_name} POINTER(ORD4(ptreq) + tf_name_offset )
		  ,@fname);

	{ Extract the transfer mode from the request }
	CStr2PStr(POINTER({Start of buffer } ORD4(ptreq) +
			  tf_name_offset +
			  {Characters of file name} Length(fname) +
			  {Null byte terminating fname} 1 ),
		  @smode);

	FPart := tf_DataPart; { We assume unless Mac mode }

	if EqualString(smode,'octet',Ignore_Case,No_Diacrit) then begin
		     mode := IMAGE;
		     FPart := tf_RsrcPart;
		     end
	else if EqualString(smode,'image',Ignore_Case,No_Diacrit) THEN begin
		     mode := IMAGE;
		     FPart := tf_RsrcPart;
		     end
	else if EqualString(smode,'netascii',Ignore_Case,No_Diacrit)
		THEN mode := ASCII
	else if EqualString(smode,'macintosh',Ignore_Case,No_Diacrit) THEN BEGIN
		mode := MACINTOSH;
		FPart := tf_FindPart;
		END
	else BEGIN
{$IFC DEBUG}
		Write('TFTP SERVER:  Bad mode ',smode,' in req ');
{$ENDC}
		tfrpyerr(tftp, p, ERRTXT, StrCvt('Bad mode'));
{$IFC ALLOCT}
		Write('tfshnd 6: ');
{$ENDC}
		udp_free(p);
		ntftps := ntftps - 1;
		exit(tfshnd);
		END;

	IF (tfstate=OFF) THEN BEGIN
		tfrpyerr(tftp, p, ERRTXT,
			 StrCvt('Transfers are not being accepted.'));
{$IFC ALLOCT}
		Write('tfshnd 7: ');
{$ENDC}
		udp_free(p);
		ntftps := ntftps - 1;
		exit(tfshnd);
		END;

	IF ptreq^.tf_op = RRQ
		THEN TransDir := PUT
		ELSE TransDir := GET;

	if CALL3A(host, @fname, TransDir, tfs_alert)=0 THEN
			BEGIN
			tfrpyerr(tftp, p, ERRTXT,StrCvt('Transfer refused.'));
			refusedt := TickCount;
{$IFC ALLOCT}
			Write('tfshnd 8: ');
{$ENDC}
			udp_free(p);
			ntftps := ntftps - 1;
			exit(tfshnd);
			END;

	{  It looks safe to try to open a connection.  }

	cn := tfmkcn(PUT, ASCII);       {  Direction is a dummy for now	 }
	if (cn=NIL) THEN BEGIN
		CantAlloc(StrCvt('TFTP'),StrCvt('connection'));
{$IFC ALLOCT}
		Write('tfshnd 9: ');
{$ENDC}
		udp_free(p);
		ntftps := ntftps - 1;
		exit(tfshnd);
		END;

	cn^.tf_done := server_done;
	cn^.tf_fn := fname;
	cn^.tf_fp := FPart;
	cn^.tf_volume := 0;
	cn^.tf_mode := mode;
	cn^.tf_udp := udp_open(host, pup^.ud_srcp,
				udp_socket, @tftprcv, POINTER(ORD4(cn)));
	if (cn^.tf_udp=NIL) THEN BEGIN
		CantConnect(StrCvt('TFTP'),StrCvt('UDP'));
		LongDummy := tfcleanup(cn);
{$IFC ALLOCT}
		Write('tfshnd 10: ');
{$ENDC}
		udp_free(p);
		ntftps := ntftps - 1;
		exit(tfshnd);
		END;

	IF (ptreq^.tf_op=RRQ) THEN BEGIN
		cn^.tf_dir := PUT;
		cn^.tf_fport := 1;
		cn^.tf_PB^.ioNamePtr := @cn^.tf_fn;
		cn^.tf_PB^.ioVRefNum := cn^.tf_volume;
		cn^.tf_PB^.ioVersNum := 0;
		cn^.tf_PB^.ioPermssn := fsRdPerm; { Only need to read it }
		cn^.tf_PB^.ioMisc := NIL;

		CASE cn^.tf_fp OF
		    tf_DataPart:
			BEGIN
			OSStatus := PBOpen(cn^.tf_PB, FALSE);
			IF OSStatus = noErr THEN
				begin
				if ForkZero(cn) then OSStatus := EOFErr
				else begin
					cn^.tf_PB^.ioPosMode := fsFromStart;
					cn^.tf_PB^.ioPosOffset := 0;
					OSStatus := PBSetFPos(cn^.tf_PB,FALSE);
					end;
				end;
			END;

		    tf_RsrcPart: BEGIN
			     OSStatus := PBOpenRF(cn^.tf_PB, FALSE);
			     IF OSStatus = noErr THEN
				begin
				if ForkZero(cn) then OSStatus := EOFErr
				else begin
					cn^.tf_PB^.ioPosMode := fsFromStart;
					cn^.tf_PB^.ioPosOffset := 0;
					OSStatus := PBSetFPos(cn^.tf_PB,FALSE);
					end;
				end;
			     END;

		    tf_FindPart: BEGIN
			{ Just see if file exists, don't really need to open it }
			OSStatus := PBOpen(cn^.tf_PB, FALSE);
			IF OSStatus = noErr THEN
				OSStatus := PBClose(cn^.tf_PB,FALSE);
		    END;
		END; { end of case }

		if NOT OpenOK(cn,OSStatus,p) THEN BEGIN
			tfudperr(cn^.tf_udp, cn^.tf_outp, FNOTFOUND,
				 StrCvt('Could not open the file'));
			CALL1B(OFF, cn^.tf_done);
			LongDummy := tfcleanup(cn);
			exit(tfshnd);
			end;

		cn^.tf_task := tk_fork(tk_cur, @tftpread, TFTKSZ, 'tfrd',
					POINTER(ORD4(cn)));
		END
	else BEGIN
		cn^.tf_dir := GET;
		cn^.tf_fport := 1;
		cn^.tf_PB^.ioNamePtr := @cn^.tf_fn;
		cn^.tf_PB^.ioVRefNum := cn^.tf_volume;
		cn^.tf_PB^.ioVersNum := 0;
		cn^.tf_PB^.ioPermssn := fsRdWrPerm;
		cn^.tf_PB^.ioMisc := NIL;
		{ See if file already there; yes, truncate it, else create it }
		CASE cn^.tf_fp OF

		tf_DataPart:
			BEGIN
			OSStatus := PBOpen(cn^.tf_PB,FALSE);
			ScratchIt(cn,OSStatus);
			END;

		tf_RsrcPart:
			BEGIN
			OSStatus := PBOpenRF(cn^.tf_PB, FALSE);
			ScratchIt(cn,OSStatus);
			END;

		tf_FindPart: BEGIN
		    { Do not need to open it, but if not available, it must
		      be created }
		    OSStatus := PBOpen(cn^.tf_PB,FALSE);
		    IF OSStatus = noErr THEN OSStatus := PBClose(cn^.tf_PB,FALSE)
		    ELSE IF OSStatus = fnfErr THEN BEGIN
			cn^.tf_PB^.ioNamePtr := @cn^.tf_fn;
			cn^.tf_PB^.ioVRefNum := cn^.tf_volume;
			cn^.tf_PB^.ioVersNum := 0;
			OSStatus := PBCreate(cn^.tf_PB,FALSE);
			{ Finder info will be filled in later }
			END;
		    END; { end of finder part }

		END; { end of case statement }

		if NOT OpenOK(cn,OSStatus,p) then BEGIN
			tfudperr(cn^.tf_udp, cn^.tf_outp, ACCESS,
				 StrCvt('Could not open the file'));
			CALL1B(OFF, cn^.tf_done);
			LongDummy := tfcleanup(cn);
			exit(tfshnd);
			end;

		cn^.tf_task := tk_fork(tk_cur, @tftpwrit, TFTKSZ, 'tfwr',
				       POINTER(ORD4(cn)));
		tk_yield;   { let it get started }
		cn^.tf_expected := 1;
		tfsndack(cn, 0);
		END;

{$IFC ALLOCT}
	Write('tfshnd 13: ');
{$ENDC}
	udp_free(p);
END; { end of tfshnd }

{ User TFTP: attempt to transmit or receive a file in the specified mode. }

FUNCTION tftpuse(fhost: in_name; fname: StringPtr; volume:Integer;
		  rmfile: StringPtr; dir: integer; mode: integer;
		  userDone: ProcPtr): LongInt;
VAR
	cn: Ref_tfconn;
	mysock: integer;
	FIPtr: ^ FInfo;
	len: LongInt;
	Status: Integer;
	LongDummy: LongInt;
	OSStatus: OSErr;
BEGIN

{$IFC DEBUG}
	Write('TFTP_USER called on ');
	out_inaddr(fhost);
	WriteLn(fname^,',',rmfile^,',',dir,',',mode,'.');
{$ENDC}
	cn := tfmkcn(dir, mode);
	if(cn=NIL) THEN BEGIN
		CantAlloc(StrCvt('TFTP'),StrCvt('connection'));
		tftpuse := 0;
		EXIT(tftpuse);
		END;

	ntftps := ntftps + 1;

	cn^.tf_done := userDone;
	cn^.tf_fn := fname^;
	cn^.tf_volume := volume;
	cn^.tf_mode := mode;
	if mode = MACINTOSH then
		cn^.tf_fp := tf_FindPart
	else if mode in [IMAGE, OCTET] then
		cn^.tf_fp := tf_RsrcPart
	else
		cn^.tf_fp := tf_DataPart;

	if (dir=GET) THEN BEGIN
		if mode IN [IMAGE, ASCII, OCTET, MACINTOSH] THEN BEGIN
		    cn^.tf_PB^.ioNamePtr := @cn^.tf_fn;
		    cn^.tf_PB^.ioVRefNum := cn^.tf_volume;
		    cn^.tf_PB^.ioVersNum := 0;
		    cn^.tf_PB^.ioPermssn := fsRdWrPerm;
		    cn^.tf_PB^.ioMisc := NIL;
		    { Try to open the file for writing, since we will try to
		      get this file }
		    CASE cn^.tf_fp OF

		    tf_DataPart:
			BEGIN
			OSStatus := PBOpen(cn^.tf_PB,FALSE);
			ScratchIt(cn,OSStatus);
			END;

		    tf_RsrcPart:
			BEGIN
			OSStatus := PBOpenRF(cn^.tf_PB, FALSE);
			ScratchIt(cn,OSStatus);
			END;

		    tf_FindPart: BEGIN
			OSStatus := PBOpen(cn^.tf_PB,false);
			IF OSStatus = noErr THEN
				OSStatus := PBClose(cn^.tf_PB,FALSE)
			ELSE IF OSStatus = fnfErr THEN BEGIN
				cn^.tf_PB^.ioNamePtr := @cn^.tf_fn;
				cn^.tf_PB^.ioVRefNum := cn^.tf_volume;
				cn^.tf_PB^.ioVersNum := 0;
				OSStatus := PBCreate(cn^.tf_PB,FALSE);
				{ Finder info filled in later }
				END;
		       END; { end of finder part }
		    END; { end of CASE on file part }

		 END { end of ASCII, OCTET and IMAGE modes }
{$IFC DEBUG}
		else if (mode=TEST) THEN BEGIN
		    WriteLn('tftpuse: TEST mode not supported ');
		    LongDummy := tfcleanup(cn);
		    tftpuse := 0;
		    EXIT(tftpuse);
		    END
{$ENDC}
		else BEGIN
{$IFC DEBUG}
		    WriteLn('TFTP_USER: Bad mode ',mode,'.');
{$ENDC}
		    LongDummy := tfcleanup(cn);
		    tftpuse := 0;
		    EXIT(tftpuse);
		    END;

		if (OSStatus <> noErr) THEN BEGIN
			FOpenErr(fname,OSStatus);
			LongDummy := tfcleanup(cn);
			tftpuse := 0;
			EXIT(tftpuse);
			END;

		mysock := udp_socket;
		cn^.tf_udp := udp_open(fhost, TFTPSOCK, mysock, @tftprcv,
				POINTER(ORD4(cn)));
		if (cn^.tf_udp=NIL) THEN BEGIN
			CantConnect(StrCvt('TFTP'),StrCvt('UDP'));
			LongDummy := tfcleanup(cn);
			tftpuse := 0;
			EXIT(tftpuse);
			END;

		cn^.tf_task := tk_cur;
		cn^.tf_fport := 0;
		cn^.tf_expected := 1;
		cn^.tf_task := tk_fork(tk_cur, @tftpwrit, TFTKSZ, 'tfwr',
				       POINTER(ORD4(cn)));
		Status := tfsndreq(cn, rmfile);
		if Status < 0 then begin
			Error(StrCvt('TFTP: Destination unreachable'));
			LongDummy := tfcleanup(cn);
			tftpuse := 0;
			end
		else    tftpuse := 1;
		exit(tftpuse);
	END { end of GET test }

	else if (dir=PUT) THEN BEGIN
		if mode in [IMAGE, ASCII, OCTET, MACINTOSH] THEN BEGIN
		  cn^.tf_PB^.ioNamePtr := @cn^.tf_fn;
		  cn^.tf_PB^.ioVRefNum := cn^.tf_volume;
		  cn^.tf_PB^.ioVersNum := 0;
		  cn^.tf_PB^.ioPermssn := fsRdPerm;
		  cn^.tf_PB^.ioMisc := NIL;
		  CASE cn^.tf_fp OF
		     tf_DataPart:
				{ Open a file for reading }
				begin
				OSStatus := PBOpen(cn^.tf_PB,FALSE);
				IF OSStatus = noErr THEN
					begin
					IF ForkZero(cn) THEN OSStatus := EOFErr
					else BEGIN
						cn^.tf_PB^.ioPosMode := fsFromStart;
						cn^.tf_PB^.ioPosOffset := 0;
						OSStatus := PBSetFPos(cn^.tf_PB,
								      FALSE);
						END;
					end;
				end;

			tf_RsrcPart:
			     BEGIN
			     OSStatus := PBOpenRF(cn^.tf_PB, FALSE);
			     IF OSStatus = noErr THEN
				begin
				IF ForkZero(cn) THEN OSStatus := EOFErr
				else BEGIN
					cn^.tf_PB^.ioPosMode := fsFromStart;
					cn^.tf_PB^.ioPosOffset := 0;
					OSStatus := PBSetFPos(cn^.tf_PB, FALSE);
					END;
				end;
			     END;

		     tf_FindPart: BEGIN
			{ Just see if file exists, don't really need to open it }
			OSStatus := PBOpen(cn^.tf_PB,FALSE);
			IF OSStatus = noErr THEN
				OSStatus := PBClose(cn^.tf_PB,FALSE);
			END; { end of finder part}
		  END; { end of case }
		  if NOT OpenOK(cn,OSStatus,NIL) then begin
			LongDummy := tfcleanup(cn);
			tftpuse := 0;
			exit(tftpuse);
			end;
		  END { end of mode test }
		else BEGIN
{$IFC DEBUG}
			WriteLn('Invalid mode for put.');
{$ENDC}
			LongDummy := tfcleanup(cn);
			tftpuse := 0;
			EXIT(tftpuse);
			END;

		if(OSStatus <> noErr) THEN BEGIN
			FOpenErr(fname,OSStatus);
			LongDummy := tfcleanup(cn);
			tftpuse := 0;
			EXIT(tftpuse);
			END;

		mysock := udp_socket;
		cn^.tf_udp := udp_open(fhost, TFTPSOCK, mysock, @tftprcv,
				       POINTER(ORD4(cn)));
		if (cn^.tf_udp=NIL) THEN BEGIN
			CantConnect(StrCvt('TFTP'),StrCvt('UDP'));
			OSStatus := PBClose(cn^.tf_PB,FALSE);
			LongDummy := tfcleanup(cn);
			tftpuse := 0;
			EXIT(tftpuse);
			END;

		cn^.tf_task := tk_cur;
		cn^.tf_expected := 0;
		cn^.tf_fport := 0;
		while cn^.tf_tries <> 0 do begin
			Status := tfsndreq(cn, rmfile);
			if Status < 0 then begin
				Error(StrCvt('TFTP: Destination unreachable'));
				LongDummy := tfcleanup(cn);
				tftpuse := 0;
				exit(tftpuse);
				end
			else    tftpuse := 1;
			cn^.tf_state := ACKWAIT;
			tk_block;
			if cn^.tf_state <> TIMEOUT then leave;
			end;
		if cn^.tf_tries = 0 then begin
			Error(StrCvt('TFTP: Request to send not acknowledged'));
			LongDummy := tfcleanup(cn);
			tftpuse := 0;
			exit(tftpuse);
			end
		else if cn^.tf_state = DEAD then begin
			LongDummy := tfcleanup(cn);
			tftpuse := 0;
			exit(tftpuse);
			end;

		cn^.tf_task := tk_fork(tk_cur, @tftpread, TFTKSZ, 'tfrd',
					POINTER(ORD4(cn)));
		tftpuse := 1;
		exit(tftpuse);
		END;
END; { end of tftpuse }

{ Task that receives a file from the remote system }

PROCEDURE tftpwrit(cn: Ref_tfconn);
VAR     Len: LongInt;
	Status: Integer;
	Dummy: Boolean;
BEGIN
	while(True) DO BEGIN
		cn^.tf_state := DATAWAIT;
		while (cn^.tf_state=DATAWAIT) DO tk_block;
{$IFC DEBUG}
		WriteLn('tftpwrit: awakened');
{$ENDC}

		if (cn^.tf_state=TIMEOUT) THEN BEGIN
			if (cn^.tf_tries > 0) THEN BEGIN
				Status := udp_write(cn^.tf_udp, cn^.tf_outp,
						    cn^.tf_lastlen);
				Dummy := tm_clear(cn^.tf_tm);
				tm_tset(cn^.tf_rt, @tftptmo,
					POINTER(ORD4(cn)), cn^.tf_tm);
				cycle;
				END
			ELSE BEGIN
				NotResponding(StrCvt('TFTP'));
				if cn^.tf_rcv >= NORMLEN then { in progress }
					tfudperr(cn^.tf_udp, cn^.tf_outp, ERRTXT,
					   StrCvt('Too many retries, giving up'));
				CALL1B(OFF, cn^.tf_done);
				len := tfcleanup(cn);
				ntftps := ntftps - 1;
				leave;
				END;
			END;

		if (cn^.tf_state = RCVLASTDATA) THEN BEGIN
			{ unless in Mac mode, have sent last data }
			if (cn^.tf_mode = MACINTOSH)
				AND (cn^.tf_fp <> tf_DataPart) THEN
				BEGIN
				cn^.tf_state := RCVDATA;
				if NOT MacPart(cn,1) then begin
					CALL1B(OFF, cn^.tf_done);
					Len := tfcleanup(cn);
					leave;
					end;
				END
			ELSE    BEGIN
				Dummy := tm_clear(cn^.tf_tm);
				CALL1B(ON, cn^.tf_done);
				Len := tfcleanup(cn);
				if (len=0) THEN
				 Error(StrCvt('Tried to transfer zero-length file'));
				ntftps := ntftps - 1;
				leave;
				END
			END;

		if (cn^.tf_state <> RCVDATA) THEN BEGIN
			Dummy := tm_clear(cn^.tf_tm);
			CALL1B(OFF, cn^.tf_done);
			len := tfcleanup(cn);
			ntftps := ntftps - 1;
			leave;
			END;
		END; { end of the WHILE loop }
	tk_exit;
END; { end of tfswrit }

{ Task that sends a file to the remote system }
{ This procedure was incorrect.	 It leaked storage and timed out improperly.
  It has been extensively rewritten. -- Tim }

PROCEDURE tftpread(cn: Ref_tfconn);
LABEL 666; { timeout retry }
VAR
	data: PTR;
	flen: LongInt;
	FIPtr: ^ FInfo;
	done: Boolean;
	pfill,psnt,tmp: PACKET;
	Status: Integer;
	LongDummy: LongInt;
	FinderInfo: FInfo;      { For macintosh mode transfers }
	OSStatus : OSErr;
	Dummy: Boolean;
	NEEDLF: Boolean;
BEGIN
	NEEDLF := FALSE;
	flen := NORMLEN;
	done := FALSE;
	cn^.tf_expected := 0;
	psnt := cn^.tf_outp;
	pfill := udp_alloc(512,0);
{$IFC ALLOCT}
	NoteAlloc('tftpread',pfill);
{$ENDC}
	if pfill = NIL then BEGIN
		CantAlloc(StrCvt('TFTP'),StrCvt('fill packet'));
		ntftps := ntftps - 1;
		tk_exit;
		end;

	{ Here's how the main loop for putting data blocks works:
		Fill the next packet to send
		Wait for ACK (of initial request or previous block)
		On timeout, resend and restart ACK wait, unless too many,
			in which case abort
		On ACK receipt, send the filled packet, reset the filled
			packet to be the old packet (which is no longer
			in use, having been ACKED), and go back up to Fill
			(unless done, in which case, wrap up [or restart if
			 in Mac mode])
	}

	while(true) DO BEGIN
		cn^.tf_state := ACKWAIT;
		CASE cn^.tf_fp of
		tf_DataPart, tf_RsrcPart:
			if cn^.tf_mode <> ASCII then begin
				cn^.tf_PB^.ioBuffer := tftp_data(pfill);
				cn^.tf_PB^.ioReqCount := NORMLEN;
				cn^.tf_PB^.ioPosMode := fsAtMark;
				OSStatus := PBRead(cn^.tf_PB,FALSE);
				flen := cn^.tf_PB^.ioActCount;
				end
			else begin
				{ ASCII mode; have to translate CR to CRLF }
				flen := NORMLEN;
				data := tftp_data(pfill);
				if NEEDLF then begin
					NEEDLF := false;
					data^ := $0a; { LF }
					flen := flen - 1;
					data := POINTER(ORD4(data)+1);
					end;
				cn^.tf_PB^.ioPosMode := $0d80;
				while flen > 0 do begin
					{ Read one line at a time }
					cn^.tf_PB^.ioBuffer := data;
					cn^.tf_PB^.ioReqCount := flen;
					OSStatus := PBRead(cn^.tf_PB,FALSE);
					flen := flen - cn^.tf_PB^.ioActCount;
					if OSStatus <> noErr then leave;
					data := POINTER(ORD4(data)
						     + (cn^.tf_PB^.ioActCount-1));
					if data^ = $0d { CR } then begin
						if flen = 0 then NEEDLF := true
						else begin
							data := POINTER(ORD4(data)
									+ 1);
							data^ := $0a; { LF }
							flen := flen - 1;
							data := POINTER(ORD4(data)
									+ 1);
							end;
						end;
					end; { while flen > 0 }
				flen := NORMLEN - flen;
				end; { ASCII mode }

		tf_FindPart: BEGIN
			IF (cn^.tf_expected = 0) THEN BEGIN
				FIPtr := POINTER(ORD4(tftp_data(pfill)));
				OSStatus := GetFInfo(cn^.tf_fn,cn^.tf_volume,FIPtr^);
				flen := sizeof(FInfo);
				END
			ELSE BEGIN
				flen := 0;
				OSStatus := eofErr;
				END;
			END;
		END; { end of the case }

		IF (OSStatus <> noErr) AND (OSStatus <> eofErr) THEN BEGIN
			{ For some reason our read died! }
			{ Just say that nothing is left and that EOF reached }
			FReadErr(StrCvt(cn^.tf_fn),OSStatus);
			OSStatus := eofErr;
			flen := 0;
			END;

		cn^.tf_size := cn^.tf_size + flen;

		if (cn^.tf_expected = 0) THEN cn^.tf_state := RCVACK;

666:	        while (cn^.tf_state=ACKWAIT) DO tk_block;

		if (cn^.tf_state=TIMEOUT) THEN BEGIN
			if (cn^.tf_tries > 0) THEN BEGIN
				Status := udp_write(cn^.tf_udp,psnt,
						    cn^.tf_lastlen);
				Dummy := tm_clear(cn^.tf_tm);
				tm_tset(cn^.tf_rt, @tftptmo,
					POINTER(ORD4(cn)), cn^.tf_tm);
				cn^.tf_state := ACKWAIT;
				goto 666;
				END
			ELSE BEGIN
				NotResponding(StrCvt('TFTP'));
				tfudperr(cn^.tf_udp,cn^.tf_outp,ERRTXT,
					 StrCvt('Retry limit exceeded, giving up'));
				cn^.tf_state := DEAD;
				CALL1B(OFF, cn^.tf_done);
				LongDummy := tfcleanup(cn);
{$IFC ALLOCT}
				WriteLn('tftpread 1: ');
{$ENDC}
				udp_free(pfill);
				ntftps := ntftps - 1;
				leave;
				END;
			END;

		if (cn^.tf_state=RCVACK) THEN BEGIN
			cn^.tf_expected := cn^.tf_expected + 1;

			if (done) THEN BEGIN
				if (cn^.tf_mode = MACINTOSH)
					AND (cn^.tf_fp <> tf_DataPart) THEN
					BEGIN
					if NOT MacPart(cn,0) then begin
						CALL1B(ON, cn^.tf_done);
						LongDummy := tfcleanup(cn);
						udp_free(pfill);
						leave;
						end;
					done := false;
					cycle;
					END
				ELSE    BEGIN
					Dummy := tm_clear(cn^.tf_tm);
					CALL1B(ON, cn^.tf_done);
					LongDummy := tfcleanup(cn);
{$IFC ALLOCT}
					WriteLn('tftpread 2: ');
{$ENDC}
					udp_free(pfill);
					ntftps := ntftps - 1;
					leave;
					END;
				END;

			{ Switch packets.  psnt is the last packet we sent;
			  it can now be safely written into (whereas before
			  it might have been waiting for an async net write).
			  So make it the fill packet. }
			tmp := psnt;
			cn^.tf_outp := pfill;
			psnt := pfill;
			pfill := tmp;
			Status := tfsndata(cn, flen);
			if (flen < NORMLEN) OR (OSStatus = eofErr) THEN
				done := TRUE;
			cycle;
			END;

		{ Anomalous state.  Die }
		Dummy := tm_clear(cn^.tf_tm);
		CALL1B(OFF, cn^.tf_done);
		LongDummy := tfcleanup(cn);
{$IFC ALLOCT}
		WriteLn('tftpread 3: ');
{$ENDC}
		udp_free(pfill);
		ntftps := ntftps - 1;
		leave;
		END;    { of tftpread main loop }
	tk_exit;
END { tftpread };

{ Utility routines }

{ Note: this formerly called udp_write, a no-no at timer level.	 The code
  that used it has been corrected. }

PROCEDURE tftptmo(cn: Ref_tfconn);
BEGIN
	cn^.tf_tmo := cn^.tf_tmo + 1;
	cn^.tf_tries := cn^.tf_tries - 1;
	cn^.tf_rsnd := cn^.tf_rsnd + 1;
	cn^.tf_NR := cn^.tf_NR + 1;
	cn^.tf_state := TIMEOUT;
	tk_wake(cn^.tf_task);
END; { end of tftptmo }

PROCEDURE tf_good(cn: Ref_tfconn);
VAR
	trtM: LongInt;
BEGIN
	trtM := TickCount - cn^.tf_sent;  {  Measured round trip time  }
	if(cn^.tf_NR_last=1) THEN cn^.tf_K := Kinit;

	if(cn^.tf_NR=1) THEN
		cn^.tf_trt := (trtM+cn^.tf_trt) DIV 2
	else BEGIN
		if ((cn^.tf_NR_last > 1) AND (cn^.tf_K >1) ) THEN
			cn^.tf_K := cn^.tf_K - Kinc;

		cn^.tf_trt := cn^.tf_trt + (cn^.tf_trt DIV cn^.tf_K);
		END;
	{ cn^.tf_rt := max(min( cn^.tf_trt*TMMULT , MAXTMO), MINTICKS); }
	cn^.tf_rt := cn^.tf_trt*TMMULT;
	if cn^.tf_rt > MAXTMO then cn^.tf_rt := MAXTMO;
	if cn^.tf_rt < MINTICKS then cn^.tf_rt := MINTICKS;

	cn^.tf_NR_last := cn^.tf_NR;
END; { end of tfgood }

{ Format up and send out an initial request for a tftp connection. }

FUNCTION tfsndreq(cn: Ref_tfconn; fname: StringPtr): Integer;
VAR
	ptreq : Ref_tfreq;
	NxtFieldPtr: PTR;
	modelen: Integer;
BEGIN
	ptreq := { (struct tfreq *)} POINTER(ORD4(tftp_head(cn^.tf_outp)));
	if (cn^.tf_dir=GET) THEN ptreq^.tf_op := RRQ
	else if (cn^.tf_dir=PUT) THEN ptreq^.tf_op := WRQ
	else BEGIN
{$IFC DEBUG}
		WriteLn('TFSNDREQ: Bad direction ',cn^.tf_dir,'.');
		tfcndump(cn);
		{ if BitAnd(NDEBUG,BUGHALT)<>0 THEN HALT; }
{$ENDC}
		tfsndreq := -1;
		exit(tfsndreq);
		END;

	PStr2CStr(fname,POINTER(ORD4(ptreq) + tf_name_offset));
	NxtFieldPtr := POINTER(ORD4(ptreq) + tf_name_offset + length(fname^) + 1);

	if (cn^.tf_mode=IMAGE) OR (cn^.tf_mode=TEST) THEN BEGIN
		PStr2CStr(StrCvt('image'),NxtFieldPtr);
		modelen := length('image');
		END
	else if (cn^.tf_mode=OCTET) THEN BEGIN
		PStr2CStr(StrCvt('octet'),NxtFieldPtr);
		modelen := length('octet');
		END
	else if (cn^.tf_mode=ASCII) THEN BEGIN
		PStr2CStr(StrCvt('netascii'),NxtFieldPtr);
		modelen := length('netascii');
		END
	else if (cn^.tf_mode=MACINTOSH) THEN BEGIN
		PStr2CStr(StrCvt('macintosh'),NxtFieldPtr);
		modelen := length('macintosh');
		END
	else BEGIN
{$IFC DEBUG}
		WriteLn('TFSNDREQ: Bad mode ',cn^.tf_mode,'.');
		tfcndump(cn);
		{ if BitAnd(NDEBUG,BUGHALT)<>0 THEN HALT; }
{$ENDC}
		tfsndreq := -1;
		exit(tfsndreq);
		END;

{$IFC DEBUG}
	WriteLn('TFTP:  sending file request');
{$ENDC}
	tfsndreq := tf_write(cn, { Overhead of tfreq for opcode }  2 +
				 { File name } length(fname^) + 1 +
				 { Mode size } modelen + 1);
END; { end of tfsndreq }

{ Process a data packet received for TFTP connection cn, according to the
	type specified in the connection block. Also
	handle out of sequence blocks and check on block length. If a block
	is way too short (len < tftp header size) send back an error message
	and abort the transfer; we have CSR disease. If the block is less
	than 512 bytes, shut down the transfer; we're done.
	Otherwise, just write it to disk (if necessary).
}

PROCEDURE tfdodata(cn: Ref_tfconn; p:PACKET; len: integer);
VAR
	data: PTR;
	ptfdat: Ref_tfdata;
	start_off, end_off: integer;
	RawPtr: PTR;
	Dummy: Boolean;
	OSStatus: OSErr;
	FIPtr: ^ FInfo;
	CurFInfo: FInfo;	        { Finder information of file }
BEGIN
	CheckTask;

	if(len < 4) THEN BEGIN
{	        log(tftplog, 'TFDODATA: CSR disease; len := %u', len);  }
		tfrpyerr(cn^.tf_udp, p, ERRTXT,StrCvt('You have CSR disease.'));
{$IFC DEBUG}
		WriteLn('TFDODATA: Died of CSR disease (gurgle).');
{$ENDC}
		tfkill(cn);
		exit(tfdodata);
		END;

	if (cn^.tf_state = TIMEOUT) THEN BEGIN
		{ Got it just in time! }
		cn^.tf_state := DATAWAIT;
		END
	else if (cn^.tf_state <> DATAWAIT) THEN BEGIN
{$IFC DEBUG}
		WriteLn('TFTP:  Received unexpected data block (state =',
			ORD(cn^.tf_state),')');
{$ENDC}
		tfrpyerr(cn^.tf_udp, p, ERRTXT,
			 StrCvt('Received unexpected data block'));
		exit(tfdodata);
		END;

	ptfdat := {(struct tfdata *)} POINTER(ORD4(tftp_head(p)));
	len := len - 4;			        { BAD. }

	if (ptfdat^.tf_block <> cn^.tf_expected) THEN BEGIN
{$IFC DEBUG}
		WriteLn('TFTP: Got block ', ptfdat^.tf_block,
			', expecting ', cn^.tf_expected);
{$ENDC}

{       We got a retransmission of a packet we have already tried to
ACK.  If we retransmit the ACK, and the old ACK finally gets through also,
our correspondent will resend the next data block, and we will do the same
thing for it, on through to the end of the file.  So we shouldn't retransmit
the ACK until we are convinced that the first one was actually lost.  We will
become convinced if our own timeout waiting for the next data packet
expires.  }

{  Here is what you shouldn't do. . .
		if(ptfdat^.tf_block=cn^.tf_expected-1)
			tfsndack(cn, ptfdat^.tf_block);
    And now we return to correct procedures. . .  }

		cn^.tf_ous := cn^.tf_ous + 1;
		exit(tfdodata);
		END;

	{ Send the ack before writing the data }
	Dummy := tm_clear(cn^.tf_tm);
	tf_good(cn);
	tfsndack(cn, ptfdat^.tf_block);
	cn^.tf_size := cn^.tf_size + len;
	data := tftp_data(p);

{$IFC DEBUG}
	WriteLn('tfdodata: about to write packet, len = ',len:1);
{$ENDC}
	IF cn^.tf_mode in [IMAGE, MACINTOSH, OCTET, ASCII] THEN BEGIN
	     CASE cn^.tf_fp OF
	       tf_DataPart, tf_RsrcPart:
		IF cn^.tf_mode <> ASCII THEN BEGIN
			cn^.tf_PB^.ioBuffer := data;
			cn^.tf_PB^.ioReqCount := len;
			cn^.tf_PB^.ioPosMode := fsAtMark;
			OSStatus := PBWrite(cn^.tf_PB,FALSE);
			END
		ELSE BEGIN
			{ ASCII mode, have to translate CRLF to just CR and
			  CR NUL to just CR as well; bare CR's shouldn't happen,
			  so we can just strip any character after a CR }
			if cn^.tf_SAWCR then begin
				{ last packet ended in CR, strip this character }
				cn^.tf_SAWCR := false;
				start_off := 1;
				end_off := 1;
{$IFC DEBUG}
				WriteLn('Last packet ended in CR');
{$ENDC}
				end
			else begin
				start_off := 0;
				end_off := 0;
				end;
			cn^.tf_PB^.ioPosMode := fsAtMark;
			OSStatus := noErr; { maybe no file write will be done }
{$IFC DEBUG}
			WriteLn('tfdodata: end_off = ',end_off:1,', start_off = ',
				start_off:1,', len = ',len:1);
{$ENDC}
			while end_off < len do begin
				RawPtr := POINTER(ORD4(data) + end_off);
				while (RawPtr^ <> $0d) & (end_off < len) do begin
					end_off := end_off + 1;
					RawPtr := POINTER(ORD4(RawPtr) + 1);
					end;
				if end_off = len then begin
					end_off := len - 1;
					RawPtr := POINTER(ORD4(RawPtr) - 1);
					end;
				cn^.tf_PB^.ioReqCount := (end_off - start_off) + 1;
				cn^.tf_PB^.ioBuffer
						:= POINTER(ORD4(data) + start_off);
{$IFC DEBUG}
				WriteLn('writing, ioReqCount = ',
					cn^.tf_PB^.ioReqCount:1);
{$ENDC}
				OSStatus := PBWrite(cn^.tf_PB, FALSE);
{$IFC DEBUG}
				WriteLn('written, OSStatus = ',OSStatus:1);
{$ENDC}
				if OSStatus <> noErr then leave;
				if (end_off = len-1) & (RawPtr^ = $0d) then begin
					{ last char in pkt was CR }
					cn^.tf_SAWCR := true;
					leave;
					end;
				start_off := end_off + 2;
				end_off := start_off;
				end; { while end_off < len do }
			END; { ASCII mode }

	      tf_FindPart: BEGIN
		      FIPtr := POINTER(ORD4(TFTP_Data(p)));
		      OSStatus := GetFInfo(cn^.tf_fn,cn^.tf_volume,CurFInfo);
		      CurFInfo.fdType := FIPtr^.fdType;
		      CurFInfo.fdCreator := FIPtr^.fdCreator;
		      { The ninth bit of the finder flags word means "the location
			of this file's icon is known".  However, the location
			is NOT known for a new file received by TFTP.  That
			bit has to be cleared, so that the Finder will figure out
			where the icon should go.  This is undocumented. }
		      CurFInfo.fdFlags := BitAND($feff,FIPtr^.fdFlags);
		      OSStatus := SetFInfo(cn^.tf_fn,cn^.tf_volume, CurFInfo);
		  END; { end of finder part }

	    END; { end of case statement }

	    IF OSStatus <> noErr THEN BEGIN
		    tfrpyerr(cn^.tf_udp, p, DISKFULL,StrCvt('Disk Full'));
		    FWriteErr(StrCvt(cn^.tf_fn),OSStatus);
		    tfkill(cn);
		    exit(tfdodata);
		    END;

	    END { end of mode test }
{$IFC DEBUG}
	else if cn^.tf_mode = TEST THEN BEGIN
	    WriteLn('TFDOData: Cannot process TEST mode');
	    END
{$ENDC}
	else BEGIN
		tfrpyerr(cn^.tf_udp, p, ERRTXT,StrCvt('Internal Error.'));
		tfkill(cn);
		exit(tfdodata);
		END;

	if (len=NORMLEN) THEN cn^.tf_state := RCVDATA
	else cn^.tf_state := RCVLASTDATA;

	cn^.tf_expected := cn^.tf_expected + 1;
	tk_wake(cn^.tf_task);
END; { End of tfdodata }

{ ack a certain block number }

PROCEDURE tfsndack(cn:Ref_tfconn; number: integer);
VAR     pack: Ref_tfack;
	Status: Integer;
BEGIN
	pack := { (struct tfack *)} POINTER(ORD4(tftp_head(cn^.tf_outp)));
	cn^.tf_lastlen := sizeof(tfack);
	pack^.tf_op := ACK;
	pack^.tf_block := number;
{$IFC DEBUG}
	WriteLn('TFTP:  ACKing block ',number);
{$ENDC}
	Status := tf_write(cn, sizeof(tfack));
END; { End of tfsndack }

{ write a tftp packet }

FUNCTION tf_write(cn: Ref_tfconn; len: integer):Integer;
VAR     mypacket: Ref_tfack;
BEGIN
	mypacket := { (struct tfack *) } POINTER(ORD4(tftp_head(cn^.tf_outp)));
	IF (mypacket^.tf_op <> RRQ) AND (mypacket^.tf_op <> WRQ) THEN BEGIN
		{ Byte swapping unnecessary on 68000 }
		{ mypacket^.tf_block := bswap (mypacket^.tf_block); }
		cn^.tf_tries := TFTPTRIES;
		END
		ELSE cn^.tf_tries := REQTRIES;

	mypacket^.tf_op := { bswap } (mypacket^.tf_op);
	cn^.tf_lastlen := len;
	cn^.tf_snt := cn^.tf_snt + 1;

	IF udp_write(cn^.tf_udp, cn^.tf_outp, len) <= 0 THEN begin
		tf_write := -1;
		cn^.tf_state := RCVERR;
		exit(tf_write);
		end;

	tm_tset(cn^.tf_rt, @tftptmo, POINTER(ORD4(cn)), cn^.tf_tm);
	cn^.tf_sent := TickCount;
	cn^.tf_NR := 1;
	tf_write := noErr;
END; { End of tf_write}

{$IFC DEBUG}

{ Dump a connection block for debugging purposes. }

PROCEDURE tfcndump(cn: Ref_tfconn);
BEGIN
	WriteLn('Connection addr = ',ORD4(cn));
	WriteLn('lastlen = ',cn^.tf_lastlen);
	WriteLn('expected =',cn^.tf_expected);

	WriteLn('state = ',cn^.tf_state);
	WriteLn(' dir = ',cn^.tf_dir);
	WriteLn(' mode = ',cn^.tf_mode);

	WriteLn('sent = ',cn^.tf_snt);
	WriteLn(' rcvd = ',cn^.tf_rcv);
	WriteLn(' tous = ',cn^.tf_ous);
	WriteLn(' tmo = ',cn^.tf_tmo);
	WriteLn(' rsnd = ',cn^.tf_rsnd);

	WriteLn('round trip delay = ',cn^.tf_trt);
	WriteLn(' K = ',cn^.tf_K);
	WriteLn(' curnt tmo = ',cn^.tf_rt);
END; { End of tfcndump }

{$ENDC}

{ Setup a TFTP connection block. }

FUNCTION tfmkcn(dir:Integer; mode:Integer): Ref_tfconn;
VAR
	cn: Ref_tfconn;
	Dummy: Boolean;
BEGIN
	cn := { (struct tfconn *)}
		POINTER(ORD4(NewPtr(sizeof(tfconn))));
	if (cn=NIL) THEN BEGIN
		CantAlloc(StrCvt('TFTP'),StrCvt('connection block'));
{	        log(tftplog, 'Couldn''t allocate connection block.');   }
		tfmkcn := NIL;
		exit(tfmkcn);
		END;

	cn^.tf_udp := NIL;
	cn^.tf_rcv := 0;
	cn^.tf_snt := 0;
	cn^.tf_ous := 0;
	cn^.tf_tmo := 0;
	cn^.tf_rsnd := 0;
	cn^.tf_dir := dir;
	cn^.tf_mode := mode;
	cn^.tf_size := 0;
	cn^.tf_K := Kinit;
	cn^.tf_trt := T0;
	cn^.tf_volume := 0;
	cn^.tf_SAWCR := false;
{$IFC DEBUG}
	cn^.tf_rt := 30*60; { 30 seconds }
{$ELSEC}
	{ cn^.tf_rt := max(min( cn^.tf_trt*TMMULT , MAXTMO), MINTICKS); }
	cn^.tf_rt := cn^.tf_trt*TMMULT;
	if cn^.tf_rt > MAXTMO then cn^.tf_rt := MAXTMO;
	if cn^.tf_rt < MINTICKS then cn^.tf_rt := MINTICKS;
{$ENDC}
	cn^.tf_NR := 0;
	cn^.tf_NR_last := 1;
	cn^.tf_tries := REQTRIES;

	cn^.tf_tm := tm_alloc;
	if(cn^.tf_tm=NIL) THEN BEGIN
		CantAlloc(StrCvt('TFTP'),StrCvt('timer'));
{	        log(tftplog, 'Couldn''t allocate timer.');      }
		DisposPtr(POINTER(ORD4(cn)));
		tfmkcn := NIL;
		exit(tfmkcn);
		END;

	cn^.tf_outp := udp_alloc(512, 0);
{$IFC ALLOCT}
	NoteAlloc(cn^.tf_outp, 'tfmkcn');
{$ENDC}
	if(cn^.tf_outp=NIL) THEN BEGIN
		CantAlloc(StrCvt('TFTP'),StrCvt('output packet'));
{	        log(tftplog, 'Couldn''t allocate output packet.');      }
		Dummy := tm_free(cn^.tf_tm);
		DisposPtr(POINTER(ORD4(cn)));
		tfmkcn := NIL;
		exit(tfmkcn);
		END;

	cn^.tf_PB := POINTER(ORD4(NewPtr(sizeof(ParamBlockRec))));
	if cn^.tf_PB = NIL then begin
		CantAlloc(StrCvt('TFTP'),StrCvt('parameter block'));
{	        log(tftplog, 'Couldn''t allocate parameter block.');	  }
		Dummy := tm_free(cn^.tf_tm);
		udp_free(cn^.tf_outp);
		DisposPtr(POINTER(ORD4(cn)));
		tfmkcn := NIL;
		exit(tfmkcn);
		END;

	cn^.tf_PB^.ioRefNum := -1;
	cn^.tf_task := tk_cur;
	cn^.tf_next := NIL;
	cn^.tf_qtype := dummyType;
	enqueue(POINTER(ORD4(cn)),@tfconnq);
	tfmkcn := cn;
END;

{ Cleanup routine called when done }

FUNCTION  tfcleanup(cn: Ref_tfconn): LongInt;
VAR
	size: LongInt;
	Dummy: Boolean;
	OSStatus: OSErr;
BEGIN
	{ Give us one last chance to flush out a packet that hasn't been
		processed yet. }
	tk_yield;

{$IFC DEBUG}
	WriteLn('TFCLEANUP called');
{$ENDC}
	if(cn^.tf_mode <> TEST) THEN BEGIN
		OSStatus := PBClose(cn^.tf_PB,FALSE);
		cn^.tf_PB^.ioNamePtr := NIL;
		cn^.tf_PB^.ioVRefNum := cn^.tf_volume;
		OSStatus := PBFlushVol(cn^.tf_PB,FALSE);
		END;
{$IFC BUNDLE}
	if (cn^.tf_dir = GET) AND (cn^.tf_mode in [IMAGE, OCTET]) then
		setbundle(StrCvt(cn^.tf_fn),cn^.tf_volume);
{$ENDC}
	udp_close(cn^.tf_udp);
	Dummy := tm_clear(cn^.tf_tm);
	Dummy := tm_free(cn^.tf_tm);
	DisposPtr(POINTER(ORD4(cn^.tf_PB)));
{$IFC ALLOCT}
	Write('tfcleanup: ');
{$ENDC}
	udp_free(cn^.tf_outp);
	cn^.tf_state := DEAD;
{$IFC DEBUG}
	tfcndump(cn);
{$ENDC}
{       tfcnlog(cn);    }
	size := cn^.tf_size;
	OSStatus := dequeue(POINTER(ORD4(cn)),@tfconnq);
	DisposPtr(POINTER(ORD4(cn)));
	tfcleanup := size;
END; { end of tfcleanup }

{ Send a TFTP data block. }

FUNCTION tfsndata(cn: Ref_tfconn; len: integer): Integer;
VAR
	tfdata_var: Ref_tfdata;
BEGIN
	tfdata_var := {(struct tfdata *)}
			POINTER(ORD4(tftp_head(cn^.tf_outp)));

	tfdata_var^.tf_op := DATA;
	tfdata_var^.tf_block := cn^.tf_expected;
{$IFC DEBUG}
	WriteLn('TFTP:  sending block ',tfdata_var^.tf_block:1,'.');
{$ENDC}
	tfsndata := tf_write(cn, sizeof(tfdata)-512+len);
END; { End of tfsndata }

{ Handle an incoming ack. }

PROCEDURE tfdoack(cn: Ref_tfconn; p: PACKET; len: Integer);
VAR
    ack: Ref_tfack;
    Dummy: Boolean;
BEGIN
	ack := { (tfack *) } POINTER(ORD4(tftp_head(p)));

	if(ack^.tf_block <> cn^.tf_expected) THEN BEGIN
			{  We have received an ACK,
			but not for the data block we sent.  It must be for
			a duplicate, since we wouldn't have sent
			the current data block if we hadn't gotten an ACK for
			the previous one.  This duplicate ACK means either
			that the network resent a packet that it wasn't sure
			got through, or else the other end resent the ACK
			because our current data block is lost or late.
			In either case, we can safely ignore this extra ACK,
			and if the ACK we want doesn't come our own timer will
			get us started again.  It isn't safe
			to resend the current data block now unless we are
			absolutely certain that the other end won't reack
			it if the earlier send was just delayed.  }

		cn^.tf_ous := cn^.tf_ous + 1;
{$IFC DEBUG}
		WriteLn('TFTP: ACK for block ',ack^.tf_block,' received again.');
{$ENDC}
		END
	else BEGIN
		tf_good(cn);
		Dummy := tm_clear(cn^.tf_tm);
		cn^.tf_state := RCVACK;
		tk_wake(cn^.tf_task);
		END;
END;

{ Handle an incoming packet. }
FUNCTION tfckport(cn: Ref_tfconn; p: PACKET): Boolean; FORWARD;

PROCEDURE tftprcv(p:PACKET; len: Integer; fhost: in_name; cn: Ref_tfconn);
VAR
	pdata: Ref_tfdata;
	op: integer;
	OSStatus:OSErr;
BEGIN
	CheckTask;

	cn^.tf_rcv := cn^.tf_rcv + 1;
	pdata := { (struct tfdata *)} POINTER(ORD4(tftp_head(p)));
	op := { bswap } (pdata^.tf_op); { swapping unnecessary for 68000 }
	pdata^.tf_op := op;

	CASE (op) OF

	DATA: if (tfckport(cn,p)) THEN tfdodata(cn, p, len);

	ACK: if (tfckport(cn,p)) THEN tfdoack(cn, p, len);

	ERRPCK: BEGIN
		if ((cn^.tf_fport=0)  OR
		    (cn^.tf_udp^.u_fport=udp_head(in_head(p))^.ud_srcp)) THEN
				BEGIN
				tfdoerr(cn, p, len);
				tfkill(cn);
				END;
{$IFC DEBUG}
		WriteLn('TFTP:  ignoring error packet.');
{$ENDC}
		END;

	OTHERWISE BEGIN
{$IFC DEBUG}
		WriteLn('TFTPRCV: Got bad opcode ',op,'.');
{$ENDC}
		tfrpyerr(cn^.tf_udp, p, ILLTFTP,StrCvt(' '));
		END;

	END; { End of case }

{$IFC ALLOCT}
	Write('tftprcv: ');
{$ENDC}
	udp_free(p);    {  So much for that packet!  }
END;	 {  end tftprcv }

{  Check over the port in the incoming packet.  }

FUNCTION tfckport(cn: Ref_tfconn; p: PACKET): Boolean;
VAR
	pdata: Ref_tfdata;
	svoutp: PACKET;
	pfport, svport: integer;
BEGIN
	pdata := {(struct tfdata *)} POINTER(ORD4(tftp_head(p)));
	pdata^.tf_block := { bswap } (pdata^.tf_block); { no byte swapping on 68000 }
	pfport := udp_head(in_head(p))^.ud_srcp;

	if(cn^.tf_fport=0) THEN BEGIN
	    {  Foreign port not yet identified, save it. }
	    if (cn^.tf_expected=pdata^.tf_block) THEN BEGIN{ but only if this is }
		cn^.tf_fport := 1;		     {  a response to our  }
		cn^.tf_udp^.u_fport := pfport;	     {  request.  }
		END
	    else BEGIN
{$IFC DEBUG}
		WriteLn('TFTP:  Received packet from old connection.');
		WriteLn('	    Expected block ',cn^.tf_expected,
			', got block ',pdata^.tf_block);
{$ENDC}
		tfrpyerr(cn^.tf_udp, p, ERRTXT,StrCvt('old connection'));
		tfckport := FALSE;
		EXIT(tfckport);
		END;
	    END { end of tf_fport = 0 test }
	else if( cn^.tf_udp^.u_fport <> pfport)	 THEN BEGIN
{$IFC DEBUG}
		    WriteLn('TFTP: Rcvd pkt from port ',pfport,', expect port ',
			    cn^.tf_udp^.u_fport);
{$ENDC}
		tfrpyerr(cn^.tf_udp, p, BADTID,StrCvt(' '));
		tfckport := FALSE;
		EXIT(tfckport);
		END;
	tfckport := TRUE;
END;    {  end tfckport	 }

{  Send error packet back where this packet came from.  }

PROCEDURE tfrpyerr(udpc:UDPCONN; p: PACKET; code:Integer; text: StringPtr);
VAR
	svport: integer;
	svhost: in_name;
	svoutp: PACKET;
BEGIN
	svport := udpc^.u_fport;  { Save correct port no.  }
	svhost := udpc^.u_fhost;  {  and host id  }
	udpc^.u_fport := udp_head(in_head(p))^.ud_srcp;	 { improper }
	udpc^.u_fhost := in_head(p)^.ip_src;  {	 layer violation  }
	tfudperr(udpc, p, code, text);

	udpc^.u_fport := svport; {N.B. udperr must not yield }
	udpc^.u_fhost := svhost; { or these saves will fail  }
END;    {  end tfrpyerr()  }

{ Process an incoming error packet }

PROCEDURE tfdoerr(cn: Ref_tfconn; p:PACKET; len:Byte);
CONST
     tf_err_offset = 4;
VAR     perr: PTR;
	LocalErr: STR255;
	i:INTEGER;
BEGIN
	perr := POINTER(ORD4(tftp_head(p)));
	CStr2PStr(POINTER(ORD4(perr) + tf_err_offset),@LocalErr);
	for i := 1 to length(LocalErr) do begin
		if (LocalErr[i] = chr($d)) or (LocalErr[i] = chr($a)) then
			LocalErr[i] := ' ';
		end;
	Error2(StrCvt('TFTP: Error from foreign host: '),@LocalErr);
	cn^.tf_state := RCVERR;
END; { end of tfdoerr }

END.

!E!O!F!
exit
-=-
Tim Maroney, Professional Heretic, CMU Center for Art and Technology
tim@k.cs.cmu.edu       | uucp: {seismo,decwrl,ucbvax,etc.}!k.cs.cmu.edu!tim
CompuServe: 74176,1360 | God is not dead; he just smells funny.