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 (5 of 12)
Message-ID: <665@k.cs.cmu.edu>
Date: Tue, 26-Nov-85 05:34:07 EST
Article-I.D.: k.665
Posted: Tue Nov 26 05:34:07 1985
Date-Received: Fri, 29-Nov-85 21:26:13 EST
Organization: Carnegie-Mellon University, Networking
Lines: 1688

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

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

{ This file contains the routines which implement the Macintosh multitasking
 * system. Only the (hopefully) machine-independent routines are included
 * herein; the machine dependent routines are in the file
 * net-task_asm. The following routines are included:
 *      tk_init	      initializes the tasking system and creates the first task
 *      tk_fork	        creates additional tasks
 *      tk_block        blocks the current, goes through the circular list
 *		        of tasks task in round robbin order until it finds
 *		        one that is awake and starts it running
 *      tk_wake	        awakens a task by seting its event flag
 *
 * Tasks are allocated dynamically as needed; they may
 * be of any size but their size is fixed once they are allocated. They are
 * then uniquely and permanantly associate with a task control block.
 *
 * Tasks form a circular list that is strung together by pointers (tk_nxt).
 * Currently tasks are placed in the list when they are created and they never
 * change their position.
 * Tasks have three states: blocked, awake, and running. The running task is
 * the task that is currently executing. Only one task runs at any given time
 * and its event flag (ev_flg) determines whether it will be blocked or awake
 * after it finishes running. If a task is not running, it is awake if its
 * event flag is set, and it is blocked if its event flag is not set.
 * tk_block resets a task's event flag just before as it starts to run.
 * A running task may thus awaken itself. A task gives up control of the
 * processor by calling tk_block. Tk_block used the tk_nxt pointer of the
 * task that is giving up control, to find the next task in the circular list.
 * If this next task is awake, tk_block will set it running. If it is blocked,
 * tk_block will use its tk_nxt pointer to find the next element in the
 * circular list. If it is awake, tk_block will set it running. If not,...etc.
 * The currently running task is identified by the global variable tk_cur.
 }

INTERFACE

{$L-}

USES {$U-}
      {$U Obj-Memtypes	  } Memtypes,
      {$U Obj-QuickDraw	  } QuickDraw,
      {$U Obj-OSIntf	  } OSIntf,
      {$U Obj-ToolIntf	  } ToolIntf,
      {$U Obj-PackIntf	  } PackIntf,
      {$U net-err_lib	  } Err_Lib;

{$L+}

CONST
	MaxTaskName = 8;	        { Maximum characters in a task name }
TYPE
	stack = byte;		        { type of data in task stacks }
	Ref_Stack = ^ Stack;
	Ref_Task = ^ task;
	Task_State = (Blocked, Awake, Running);
	Task_Name = String[MaxTaskName];

	{ For all but the initial task, the TCB below sits at the very bottom
	  of allocated stack space for the task. Since the stack grows
	  downward, a stack that grows too large will clobber its TCB }

	task = RECORD		        { a task - top of its stack }
	    tk_sp: PTR;		        { task's current stack ptr }
	    tk_nxt: Ref_Task;	        { pointer to next task }
	    tk_size: Integer;	        { Size of allocated task }
	    tk_unique: Ref_Task;        { Unique Identification for collision }
	    ev_flg: Task_State;	        { flag set if task is scheduled }
	    tk_stack: packed array[0..0] of stack;  { task's stack }
	END;

VAR
	Main_Task: Ref_Task;	        { main task - always around }
	tk_cur: Ref_Task;	        { a pointer to the current task }
	TDEBUG: Integer { := 0 };       { DEBUG flag }

PROCEDURE tk_wake(tk:Ref_Task);
PROCEDURE tk_yield;
FUNCTION tk_init(stksiz:Integer): Ref_Task;
FUNCTION tk_fork(prev_tk:Ref_Task; start:ProcPtr; stksiz: Integer;
		 name:Task_Name; arg:Ptr): Ref_Task;
PROCEDURE tk_block;
PROCEDURE tk_exit;

PROCEDURE CheckTask;

PROCEDURE _cdump; { This makes the decl external for the assembly routine }

IMPLEMENTATION

{ Names are kept in a separate table so they can be retrieved when tasks overflow.
  If they are kept in the TCB, they will be overwritten at overflow.  Here we
  declare the table and the routines which manipulate it. }

CONST MAXTASKS = 16;

TYPE    tk_name_entry = packed record
		theTCB:Ref_task;
		theName:Task_Name;
		inUse:Boolean
		end;

VAR     nametable: array [1..MAXTASKS] of tk_name_entry;

PROCEDURE initnames;
VAR i:INTEGER;
BEGIN
	for i := 1 to MAXTASKS do nametable[i].inUse := false;
END;

PROCEDURE nametask(tk:Ref_task; name:Task_Name);
VAR i:INTEGER;
BEGIN
	i := 1;
	while (i <= MAXTASKS) & (nametable[i].inUse) do i := i + 1;
	if i <= MAXTASKS then begin
		nametable[i].theTCB := tk;
		nametable[i].theName := name;
		nametable[i].inUse := true;
		end;
END;

FUNCTION getname(tk:Ref_task):StringPtr;
VAR i:INTEGER;
BEGIN
	for i := 1 to MAXTASKS do
		if nametable[i].inUse then
			if nametable[i].theTCB = tk then begin
				getname := StrCvt(nametable[i].theName);
				exit(getname);
				end;
	getname := NIL;
END;

PROCEDURE delname(tk:Ref_task);
VAR i:INTEGER;
BEGIN
	for i := 1 to MAXTASKS do
		if nametable[i].inUse then
			if nametable[i].theTCB = tk then begin
				nametable[i].inUse := false;
				exit(delname);
				end;
END;

CONST   AlertResource = 666;

VAR
	death: Boolean { :=  false };   { Claim that a task should be killed }
	died: Ref_Task;		        { Task that died }
	Next_tk : Ref_Task;  { the next task to run during scheduling}
			     { This is global to minimize stack munging }
	Free_Task_List: Ref_Task;       { Where tasks that died have their
					  storage placed }
	FirstTask: Task;

FUNCTION GetSP: Ptr; External;

PROCEDURE tk_alert(tk:Ref_Task); forward;

{ Two assembly language routines for munging the stack }

PROCEDURE tk_frame (PTCB:Ref_Task; StackSize: LongInt;
		    Proc_Start: ProcPtr; Proc_Arg: PTR);EXTERNAL;

PROCEDURE tk_swtch(Old_Task:Ref_Task;New_Task:Ref_Task); EXTERNAL;

{ STK_INIT(size) is essentially something else... }

PROCEDURE stk_init(size:Integer); EXTERNAL;

{ STK_ALLOC(size) is sort of what it is. }

FUNCTION stk_alloc(size: Integer):PTR; EXTERNAL;

{ Initialize the tasking system. Create the first task, and set its stack
   pointer to the main program stack. The first task will always use the main
   program stack, even though tk_init sets aside space for a stack of size
   stksiz.(?!) The circular list of tasks contains only the original task,
   so originally set its next task pointer to point to itself. This routine
   returns to the caller with a pointer to the first task.      }

{$S InitSeg }

FUNCTION tk_init(stksiz:Integer): Ref_Task;
VAR
	tk : Ref_Task;	        { pointer to the first task }
	Actual_Size: Integer;
BEGIN   { size of the stack that is never used--in bytes }

	{ CouldAlert(AlertResource); }	   { Need task alert box in memory }

	{ Initialize the globals }
	TDEBUG := 0;		        { DEBUG flag }
	death :=  false ;	        { No task should be killed }
	Free_Task_List := NIL;	        { No killed tasks on the list yet }

	Actual_Size := stksiz + sizeof(task);
	IF Odd(Actual_Size) THEN Actual_Size := Actual_Size + 1;
	{ Now allocate the stack space for the main program to use }
	{ Although the TCB is not really used here, we leave it just in case
	  this stack space is reused. }
	Stk_Init(Actual_Size);

	{ create the first task }
	tk := @FirstTask;

	tk_cur := tk;		        { It is the currently running task }
	tk^.ev_flg := Blocked;	        { Since it is running it does not }
					{ need to be awakened, but it will }
					{ sleep when it blocks unless it }
					{ resets its flag.		 }
	initnames;
	nametask(tk,'Main');
	{ tk^.tk_name := 'Main'; }
	tk^.tk_Size := Actual_Size;
	tk^.tk_unique := @FirstTask;

	tk^.tk_nxt := tk;	        { It is the next task since it is }
					{ the only task.        }
	tk_init := tk;		        { Return the initial task }
END;

{$S	    }

PROCEDURE CheckTask;
{ This checks for task over flow }
BEGIN
    IF tk_cur <> @FirstTask THEN
    IF (ORD4(GetSP) <= ORD4(tk_cur)) OR (tk_cur <> tk_cur^.tk_Unique) THEN
	tk_alert(tk_cur);
END;

PROCEDURE tk_wake(tk:Ref_Task);
BEGIN
     tk^.ev_flg := Awake;
END;

PROCEDURE tk_yield;
BEGIN
	tk_wake(tk_cur);
	tk_block;
END;

{ Create a new task  with stksiz bytes of stack, and place it in the circular
   list of tasks after prev_tk. Awaken it so that it will run, and set it up
   so that when it does run, it will start runing  routine start.
   This routine does not affect the execution of the currently running task.
   It returns a pointer to the new task.        }

FUNCTION tk_fork(prev_tk:Ref_Task; start:ProcPtr; stksiz: Integer;
		 name:Task_Name; arg:Ptr): Ref_Task;
	{task   *prev_tk;}      { predecessor to the new task }
	{int    (*start) ();}   { Where the new task starts execution. }
	{int    stksiz;}        { The size of the stack of the new task. }
	{char   *name;}	        { The task's name as a string }
	{unsigned arg;}	        { argument to the task }
VAR
	tk: Ref_Task;	        { a pointer to the new task }
	TempTK, OTemp: Ref_Task;{ For checking free task list }
	size: integer;	        { size of the new task }
BEGIN
	size := stksiz + sizeof(task);

	IF Odd(size) THEN size := size + 1;

	{ create the new task }
	{ Either reuse some storage from before or create a new block }

	TempTK := Free_Task_List;
	OTemp := NIL;
	tk := NIL;
	WHILE (TempTK <> NIL) AND (tk = NIL) DO
		IF TempTK^.tk_Size >= Size THEN BEGIN
		    { Found a block that was large enough -- any fit strategy }
		    tk := TempTK;
		    Size := TempTK^.tk_Size;    { Don't lose any space }
		    IF OTemp = NIL
			THEN Free_Task_List := TempTK^.tk_nxt
			ELSE OTemp^.tk_nxt := TempTK^.tk_nxt;
		    END
		ELSE BEGIN
		    OTemp := TempTK;
		    TempTK := TempTK^.tk_Nxt;
		    END;

	IF tk = NIL THEN tk := { (task *)}  POINTER(ORD4(stk_alloc (size)))  ;

	{ set it up to run }

	tk_frame (tk, size, start, arg);

	tk^.ev_flg := Awake;	        { Schedule the task to run. }

	tk^.tk_nxt := prev_tk^.tk_nxt;	   { Fit it in after prev_tk. }
	prev_tk^.tk_nxt := tk;

	{ tk^.tk_name := name; }	    { Set its name }
	nametask(tk,name);
	tk^.tk_Size := size;		    { Set its size }
	tk^.tk_unique := tk;		    { Set its unique ID }

{$IFC DEBUG}
	Write('Task ',name,' has TCB at ');
	WriteLong(ORD4(tk));WriteLn('');
{$ENDC}
	tk_fork := tk;		        { Return ptr to TCB }
END;

{ Block the currently running task and run the next task in the circular list
   of tasks that is awake. Before returning, see if any cleanup has to be done
	for another task.
}

PROCEDURE tk_block;
BEGIN
	CheckTask;	     { Make sure we are still OK ! }

	Next_tk := tk_cur;   { Get the current task and block it }

{$IFC DEBUG}
	IF (TDEBUG <> 0) THEN
		WriteLn('TASK: Task blocking: ', getname(tk_cur)^);
{$ENDC}

	REPEAT
		Next_tk := Next_tk^.tk_nxt;
		IF Next_tk <> Next_tk^.tk_Unique THEN tk_alert(tk_cur);
	UNTIL (Next_tk^.ev_flg <> Blocked);

	Next_tk^.ev_flg := Blocked;	  { Reset its event flag before it runs }

	if Next_tk <> tk_Cur THEN tk_swtch (tk_cur,Next_tk);	 { Run the next task. }

	tk_cur := Next_tk;

{$IFC DEBUG}
	IF (TDEBUG <> 0) THEN
		WriteLn('TASK: Task now running: ', getname(tk_cur)^);
{$ENDC}

	IF death THEN BEGIN
		{ free up the task }
		death := FALSE;
		{ cfree(POINTER(ORD4(died))); }
		{Can't free stack in the Mac, so instead we just keep a list
		 of the old stack space for possible reuse }
		died^.tk_Nxt :=	 Free_Task_List;
		Free_Task_List := died;
		END;
END; { end of tk_block }


{ tk_exit() : destroy the current task. Accomplished by setting a flag
	indicating that an exit has occured and then entering the scheduler
	loop. When tk_block() returns for some other task and finds this
	flag set, it deallocates the task which exited. This is nry
	because we still need a stack to run on.

	The task removes itself from the circular list of tasks in the system
	so that it cannot be awoken after it has exited. Otherwise, the exit
	might be done in the context of the task itself, which would prove
	disastrous.

	Yes, this routine never returns (not really).
}

PROCEDURE tk_exit;
VAR     tk: Ref_Task;
BEGIN
	{ hunt for the task which tk_cur is the successor of }
	tk := tk_cur;
	WHILE (tk^.tk_nxt <> tk_cur) DO tk := tk^.tk_nxt;

	{ now patch around tk_cur }
	tk^.tk_nxt := tk_cur^.tk_nxt;

	death := TRUE;
	died := tk_cur;
	delname(tk_cur);
	tk_block;
	Fatal(StrCvt('Disaster: tk_exit() returning!!!'),false);
END; { end of tk_exit }

PROCEDURE _cdump;
BEGIN
    Fatal(StrCvt(concat('Task ',getname(tk_cur)^,' is trying to return')),false);
END; { end of _cdump }

PROCEDURE tk_alert(tk:Ref_Task);
VAR dummy:INTEGER;
    SPStr,TCBStr:STR255;
BEGIN
	NumToString(ORD4(GetSP),SPStr);
	NumToString(ORD4(tk_cur),TCBStr);
	ParamText(SPStr,TCBStr,getname(tk)^,'');
	dummy := StopAlert(AlertResource,NIL);
	reboot;
END;

END.
!E!O!F!
#
#
echo extracting net/term_lib.text...
cat >net/term_lib.text <<'!E!O!F!'
{$X-}
{$M+}
{$R+}
{$0V-}
{$D+}
{$DECL DEBUG}
{$SETC DEBUG := false}
{$DECL VT102}
{$SETC VT102 := false}
UNIT Term_Lib;

{
	The emulation code is taken from, and modified to Pascal from,
	the source for Macintosh Kermit... which is:

	Copyright (c) 1985, Trustees of Columbia University, New York.
	Non-commercial use permitted with this notice.
}

INTERFACE

{$L-}
   USES {$U-}
      {$U Obj-Memtypes	  } Memtypes,
      {$U Obj-QuickDraw	  } QuickDraw,
      {$U Obj-OSIntf	  } OSIntf,
      {$U Obj-ToolIntf	  } ToolIntf;

PROCEDURE em_init;
PROCEDURE em_reset;
PROCEDURE em(c:char);
PROCEDURE EmStr(s:STR255);
PROCEDURE EmLn(s:STR255);
PROCEDURE em_input(eptr:PTR; VAR s:str255);
PROCEDURE em_flush;
PROCEDURE IoUpdate;
PROCEDURE IoIdle;
PROCEDURE IoActivate(modifiers:INTEGER);
PROCEDURE IoClick(where: INTEGER; pt: Point; modifiers: INTEGER);

VAR myWindow: windowptr;       { the window we're emulating in... }

IMPLEMENTATION

CONST
     RETURN = chr($d);	        { carriage return }
     LINEFEED = chr($a);        { linefeed }
     C_L = chr($c);	        { Control-L }
     MAXLIN = 24;	        { Number of lines of text on screen }
     MAXCOL = 80;	        { Number of chars across screen }
     NUMTABS = 9;	        { max number of tabstops on line }
     LINEHEIGHT = 12;	        { pixels height per line of text in window }
     TOPMARGIN = 3;
     BOTTOMMARGIN = 301;        { (LINEHEIGHT * MAXLIN + TOPMARGIN) }
     LEFTMARGIN = 3;
     LINEADJ = 3;	        { amount of char below baseline for row }
     RIGHTMARGIN = 483;	        { (CHARWIDTH * MAXCOL + LEFTMARGIN) }
     CF_OUTC = 0;	        { character type flags }
     CF_SESC = 1;
     CF_MESC = 2;
     CF_TOSS = 3;

TYPE
    sparm = array [0..5] of SignedByte;
VAR
    scroll: rect;
    lastblink: LongInt;
    bmargin: Integer;
    nxtlin: array [0..MAXLIN-1] of Integer; { Linked list of lines }
    botlin: Integer;
    scrtop, scrbot: Integer;
    tabstops: array[0..NUMTABS-1] of integer;
    insert,		        { insert or overwrite text? }
    autowrap:   Boolean;        { autowrap on exceed right margin? }
    scr: array[0..MAXLIN-1] of packed array[0..MAXCOL-1] of char;
    toplin: integer;	        { offset of top of screen from top of array }
    abslin: integer;
    curlin, curcol: integer;    { cursor position }
    savlin, savcol: integer;    { saved cursor position }
    charflg: integer;
    invmode: Boolean;	        {reverse video mode}
    textstyle: style;
    prvchr: char;
    width: integer;	        { width of characters }
    outbuf: packed array[0..MAXCOL] of char;
    outcnt,outcol: Integer;
    dumptr: RgnHandle;
    num1, num2: integer;        { numeric version of parameters }
    numone, numtwo: sparm;
    cursor_on: boolean;	        { cursor currently drawn }
    numptr: Ptr;

{$S Terminal}

procedure makerect( var r: rect; lin, col, numlin, numcol: integer );
{ make a rectangle given the passed boundaries }
begin
  r.top := lin * LINEHEIGHT + TOPMARGIN;
  r.left := col * width + LEFTMARGIN;
  r.bottom := r.top + numlin * LINEHEIGHT;
  r.right := r.left + numcol * width;
end;

PROCEDURE flushbuf;
var r:rect;
e:EventRecord;
begin
	if outcnt = 0 then exit(flushbuf);
	makerect(r,abslin,outcol,1,outcnt);
	if invmode then FillRect(r,black) else EraseRect(r);
	DrawText(@outbuf,0,outcnt);
	outcnt := 0;
	ObscureCursor;
end;

PROCEDURE buf_char(c:char);
begin
	if outcnt = 0 then outcol := curcol;
	outbuf[outcnt] := c;
	outcnt := outcnt + 1;
end;

FUNCTION fndrel(linum:Integer):Integer;
VAR lin,i:Integer;
begin
	lin := toplin;
	for i := 0 to linum - 1 do lin := nxtlin[lin];
	fndrel := lin;
end;

FUNCTION fndabs(linum:Integer):Integer;
VAR i,lin:Integer;
BEGIN
	lin := toplin;
	i := 0;
	while lin <> linum do begin
		i := i + 1;
		lin := nxtlin[lin];
		end;
	fndabs := i;
END;

FUNCTION fndprv(linum:Integer):Integer;
VAR lin:Integer;
BEGIN
	lin := toplin;
	while nxtlin[lin] <> linum do lin := nxtlin[lin];
	fndprv := lin;
END;

procedure relmove( hor, ver: integer );
{ move a relative number of lines and chars.  Both can be negative }
begin
   Move(hor*width,ver*LINEHEIGHT);
   abslin:= abslin + ver;
   curcol:= curcol + hor;
   curlin:= fndrel(abslin);
end;

procedure absmove( hor, ver: integer );
{ move to absolute row and column as specified. }
begin
   MoveTo(hor*width+LEFTMARGIN,(ver+1)*LINEHEIGHT+TOPMARGIN-LINEADJ);
   abslin := ver;
   curcol := hor;
   curlin := fndrel(ver);
end;

procedure zeroline( n: integer );
{ wipe specified line of the RAM version of the screen to all spaces }
var
    index: integer;
begin
    for index := 0 to MAXCOL-1 do scr[n, index] := ' ';
end;

{ terminal operations }

procedure cursor_erase;
begin
	Line(-width,0);
	cursor_on := false;
end;

procedure cursor_draw;
begin
	Line(width,0);
	cursor_on := true;
end;

procedure back_space;
begin
  if (curcol > 0) then relmove(-1,0);
end;

procedure carriage_return;
begin
  absmove(0, abslin);
end;

procedure rev_line_feed;
VAR tbot, ttop, tlout: Integer;
begin
    if curlin = scrtop then begin
	 scrollrect(scroll,0,lineheight,dumptr);
	 zeroline(scrbot);
	 tbot := scrbot;
	 ttop := scrtop;
	 tlout := nxtlin[scrbot];
	 nxtlin[scrbot] := scrtop;
	 scrtop := scrbot;
	 scrbot := fndprv(scrbot);
	 if ttop = toplin then toplin := scrtop
	 else nxtlin[fndprv(ttop)] := scrtop;
	 if tbot = botlin then begin
		botlin := scrbot;
		nxtlin[botlin] := -1;
		end
	 else   nxtlin[scrbot] := tlout;
	 curlin := scrtop;
	 end
    else relmove(0,-1);
end;

procedure line_feed;
VAR tbot, ttop, tlout: Integer;
begin
    if curlin = scrbot then begin
	 scrollrect(scroll,0,-lineheight,dumptr);
	 zeroline(scrtop);
	 tbot := scrbot;
	 ttop := scrtop;
	 tlout := nxtlin[scrbot];
	 nxtlin[scrbot] := scrtop;
	 scrbot := scrtop;
	 scrtop := nxtlin[scrtop];
	 if ttop = toplin then toplin := scrtop
	 else nxtlin[fndprv(ttop)] := scrtop;
	 if tbot = botlin then begin
		botlin := scrbot;
		nxtlin[botlin] := -1;
		end
	 else   nxtlin[scrbot] := tlout;
	 curlin := scrbot;
	 end
    else relmove(0,1);
end;

procedure insert_char;
VAR i:Integer;
    r:Rect;
begin
     makerect(r,abslin,curcol,1,MAXCOL-curcol);
     ScrollRect(r,width,0,dumptr);
     for i := MAXCOL-1 downto curcol+2 do scr[abslin,i-1] := scr[abslin,i];
     scr[abslin,curcol] := ' ';
end;

procedure erase_char;
{ Erase the current character location to the background color }
var r: rect;
begin
    scr[curlin,curcol] := ' ';
    makerect(r,abslin,curcol,1,1);
    if invmode then FillRect(r,black) else EraseRect(r);
end;

procedure tab;
var i: integer;
begin
  for i := 0 to NUMTABS - 1 do begin
	if (tabstops[i] > curcol) then begin
		absmove(tabstops[i],abslin);
		leave;
		end;
	end;
end;

procedure bell;
begin
  sysbeep(3);
end;

procedure cursor_save;
begin
	savcol := curcol;
	savlin := abslin;
end;

procedure cursor_restore;
begin
	absmove(savcol,savlin);
end;

procedure query_terminal;
{ respond to a request from the host querying our terminal.... }
VAR err:OSErr;
begin
{$IFC VT102}
	err := PostEvent(keyDown,27{escape});
	err := PostEvent(keyDown,ord('['));
	err := PostEvent(keyDown,ord('?'));
	err := PostEvent(keyDown,ord('6'));
	err := PostEvent(keyDown,ord('c'));
{$ENDC}
end;

procedure insert_mode;
begin
	if (prvchr <> '?') & (num1 = 4) then insert := true;
end;

procedure end_insert_mode;
begin
	if (prvchr <> '?') & (num1 = 4) then insert := false;
end;

procedure up;
begin
  if num1 = 0 then num1 := 1;
  relmove(0,-num1);
end;

procedure down;
begin
  if num1 = 0 then num1 := 1;
  relmove(0,num1);
end;

procedure left;
begin
  if num1 = 0 then num1 := 1;
  relmove(-num1,0);
end;

procedure right;
begin
  if num1 = 0 then num1 := 1;
  relmove(num1,0);
end;

procedure cursor_position;
begin
  num1 := num1 - 1;
  if num1 < 0 then num1 := 0;
  num2 := num2 - 1;
  if num2 < 0 then num2 := 0;
  absmove(num2,num1);
end;

procedure clear_screen;
{ clear the entire screen to nada.... }
var index: integer;
    r:	   rect;
begin
  makerect(r,0,0,MAXLIN,MAXCOL);
  eraserect(r);
  for index := 0 to MAXLIN - 1 do zeroline(index);
end;

procedure clear_line;
var i: integer;
    r: rect;
begin
  case num1 of
	0:      begin   { here to the right }
		  makerect(r,abslin,curcol,1,maxcol-curcol);
		  for i:= curcol to maxcol - 1 do scr[curlin,i] := ' ';
		end;
	1:      begin   { left to here }
		  makerect(r,abslin,0,1,curcol+1);
		  for i:= 0 to curcol do scr[curlin,i] := ' ';
		end;
	2:      begin   { entire line }
		  makerect(r,abslin,0,1,maxcol);
		  zeroline(curlin);
		end;
  end;
  eraserect(r);
end;

procedure erase_display;
var i: integer;
    r: rect;
begin
  case num1 of
	0:      begin
		  clear_line;
		  makerect(r,abslin+1,0,maxlin-abslin,maxcol);
		  eraserect(r);
		  for i:= abslin+1 to maxlin-1 do zeroline(fndrel(i));
		end;
	1:      begin
		  clear_line;
		  makerect(r,0,0,abslin,maxcol);
		  eraserect(r);
		  for i:= 0 to abslin do zeroline(fndrel(i));
		end;
	2:      clear_screen;
  end;
end;

{$IFC VT102}
procedure insert_line;
{ not part of VT100 code, only VT102 }
VAR r:rect;
begin
	if num1 = 0 then num1 := 1;
	makerect(r,abslin,0,0,MAXCOL);
	r.bottom := bmargin;
	if num1 > fndabs(scrbot) - abslin then
		num1 := fndabs(scrbot) - abslin;
	ScrollRect(r,0,num1*LINEHEIGHT,dumptr);
{ Do the book keeping!!! }
end;

procedure delete_line;
{ not part of VT100 code, only VT102 }
VAR r:rect;
begin
	if num1 = 0 then num1 := 1;
	makerect(r,abslin,0,0,MAXCOL);
	r.bottom := bmargin;
	if num1 > fndabs(scrbot) - abslin then
		num1 := fndabs(scrbot) - abslin;
	ScrollRect(r,0,-num1*LINEHEIGHT,dumptr);
{ Do the book keeping!!! }
end;
{$ENDC}

procedure delete_char;
var i: integer;
    r: rect;
begin
  if num1 = 0 then num1 := 1;
  makerect(r,abslin,curcol,1,maxcol-curcol);
  if (num1 > maxcol-curcol-1) then num1 := maxcol-curcol-1;
  scrollrect(r,-width*num1,0,dumptr);   { scroll the little sucker out... }
  for i := curcol to (maxcol-num1)-1 do scr[abslin,i]:= scr[abslin,i+num1];
  while i< maxcol do begin
    scr[abslin,i]:= ' ';
    i:= i+1;
  end;
end;

procedure text_mode;
begin
  case num1 of
    0:  begin
		invmode := false;
		textstyle := [];
		textface([]);
		textmode(srcor);
	end;
    1:  begin
		textstyle := textstyle + [bold];
		textface(textstyle);
	end;
    4:  begin
		textstyle := textstyle + [underline];
		textface(textstyle);
	end;
    7:  begin
		invmode := true;
		textmode(srcbic);
	end;
    22: if bold in textstyle then begin
		textstyle:= textstyle - [bold];
		textface(textstyle);
	end;
    24: if underline in textstyle then begin
		textstyle := textstyle - [underline];
		textface(textstyle);
	end;
    27: begin
		invmode := false;
		textmode(srcor);
	end;
  end;
end;

procedure home_cursor;
begin
  absmove(0,0);
end;

procedure set_scroll_region;
begin
	num1 := num1 - 1;
	if num1 < 0 then num1 := 0;     { make top of line (prev line) }
	if num2 = 0 then num2 := 24;    { zero means whole screen }
	scroll.top := (num1 * LINEHEIGHT) + TOPMARGIN;
	scroll.bottom := (num2 * LINEHEIGHT) + TOPMARGIN;
	bmargin := scroll.bottom;
	scrtop := fndrel(num1);
	scrbot := fndrel(num2 - 1);
	home_cursor;
end;

{ parsing routines }

procedure do_ctrl( ch: char );
{ perform operation corresponding to the passed control character }
begin
  case ord(ch) of
    7:  bell;
    8:  back_space;
    9:  tab;
    10, 11, 12:
	line_feed;
    13: carriage_return;
    27: charflg := CF_SESC;
  end;
end;

procedure multi_char;
{ initialize state for multi-character escape sequence }
begin
	numone[0] := 0;
	numone[1] := 0;
	numtwo[0] := 0;
	numtwo[1] := 0;
	numptr := @numone;
	prvchr := chr(0);
	charflg := CF_MESC;
end;

procedure do_sesc( ch: char );
{ given a single char, assume it is the second half of a simple escape sequence
  and call the appropriate processing routine.
}
begin
  case ord(ch) of
	35, 40, 41:
		charflg := CF_TOSS;
	55:     cursor_save;
	56:     cursor_restore;
	69:     line_feed;
	77:     rev_line_feed;
	90:     query_terminal;
	91:     multi_char;
  end;
end;

procedure do_mesc( ch: char );
{ given a single char, and up to two numeric parameters, perform the requested
  multi-character escape sequence
}
begin
  case ord(ch) of
	65:     up;
	66:     down;
	67:     right;
	68:     left;
	72:     cursor_position;
	74:     erase_display;
	75:     clear_line;
{$IFC VT102}
	76:     insert_line;	        { not part of VT100 }
	77:     delete_line;	        { not part of VT100 }
{$ENDC}
	80:     delete_char;
	99:     query_terminal;
	102:    cursor_position;
	104:    insert_mode;
	108:    end_insert_mode;
	109:    text_mode;
	114:    set_scroll_region;
  end;
end;

function str_to_int( s: sparm ): integer;
var result: integer;
    index: integer;
begin
  result := 0;
  index := 0;
  while s[index] <> 0 do begin
    if (s[index] >= ord('0')) & (s[index] <= ord('9')) then
      result := (result * 10) + (s[index] - ord('0'))
    else if s[index] = ord('-') then result := -result;
    index := index + 1;
  end;
  str_to_int := result;
end;

procedure MDrawChar( ch: char );
{ actually draw or otherwise handle the char passed to us.  Update all relevent
  pointers }
begin
  if (ch < ' ') then begin
	flushbuf;
	do_ctrl(ch);
	end
  else if ( ord(ch) < 128 ) then begin
    if (curcol >= MAXCOL) then begin    { do we need to handle end of line? }
      if autowrap then begin	        { if so, do we want to autowrap... }
	flushbuf;
	carriage_return;
	line_feed;
	end
      else begin	        { ...or just stick on the right margin? }
	back_space;
	if outcnt > 0 then outcnt := outcnt - 1;
	end;
      end;
    if insert then begin	 { are we in insert mode? }
	insert_char;
	erase_char;
	DrawChar(ch);
	end
    else buf_char(ch);
    { save char in RAM array for update later }
    scr[curlin,curcol] := ch;
    curcol:= curcol+1;
  end;
end;

procedure printit( ch: char );
begin
  ch := chr(BitAnd(ord(ch),$7f));
  case charflg of
    CF_OUTC:    MDrawChar(ch);	        { just output the char }
    CF_SESC:    begin		        { handle single-char escape sequence }
		  charflg := CF_OUTC;
		  do_sesc(ch);
		end;
    CF_MESC:			        { multi-char escape sequences }
		if (ord(ch) >= 32) & (ord(ch) < 64) then begin
		  if (ch >= '<') & (ch <= '?') then prvchr := ch
		  else if ((ch >= '0')&(ch <= '9')) | (ch = '-') | (ch = '+') then
		      begin
		      numptr^ := ORD(ch);
		      numptr := POINTER(ORD4(numptr)+1);
		      numptr^ := 0;
		      end
		  else if (ch = ';') then numptr := @numtwo;
		  end
		else begin	    { we've finished sequence, so }
		  { convert strings numone and numtwo to numbers num1 and num2 }
		  num1 := str_to_int(numone);
		  num2 := str_to_int(numtwo);
		  do_mesc(ch);
		  charflg:= CF_OUTC;
		end;
    CF_TOSS:    charflg := CF_OUTC;     { just ignore this char and go on }
  end;
end;

{ framework routines }

PROCEDURE em_reset;
BEGIN
    numptr := @numone;
    textsize(9);
    textmode(srcOr);
    textstyle := [];
    textface(textstyle);
    outcnt := 0;
    invmode := false;
    insert := false;
    lastblink := TickCount;
    charflg := CF_OUTC;		     { initialize to normal char outputting }
    scroll.left := LEFTMARGIN;
    scroll.right := RIGHTMARGIN;
    scroll.top := TOPMARGIN;
    scroll.bottom := (MAXLIN * LINEHEIGHT) + TOPMARGIN;
    bmargin := scroll.bottom;
    scrtop := toplin;
    scrbot := botlin;
END;

PROCEDURE em_init;
var   index: integer;
      FontNumber: Integer;
      bounds:	  Rect;
      i: Integer;
begin
    GetFNum('monaco',FontNumber);
    bounds.top := 40;
    bounds.left := 4;
    bounds.bottom := 340;
    bounds.right := 508;
    myWindow := newwindow(nil,bounds,concat('MacTELNET of ',COMPDATE),true,
			  4,pointer(-1),false,0);
    setport(myWindow);
    textfont(fontnumber);
    textsize(9);
    textmode(srcOr);
    textstyle := [];
    textface(textstyle);
    dumptr := NewRgn;
    PenMode(patXor);
    width := charwidth('W');
    toplin := 0;
    botlin := MAXLIN - 1;
    for i := 0 to MAXLIN-1 do nxtlin[i] := i + 1;
    nxtlin[botlin] := -1;
    autowrap := true;
    em_reset;
    for index := 0 to NUMTABS-1 do tabstops[index] := 8*(index+1);
    for index := 0 to MAXLIN-1 do zeroline(index);
    clear_screen;
    home_cursor;
    cursor_save;
    cursor_on := false;
end;

PROCEDURE em(c:char);
{ Write character to terminal window }
begin
    if cursor_on then cursor_erase;
    printit(c);
end;

PROCEDURE EmStr(s:STR255);
{ Output a string of chars to screen }
VAR i: INTEGER;
begin
   if cursor_on then cursor_erase;
   for i := 1 to length(s) do printit(s[i]);
end;

PROCEDURE em_flush;
{ makes sure all pending output was done }
BEGIN
   if cursor_on then cursor_erase;
   flushbuf;
END;

PROCEDURE EmLn(s:STR255);
{ Output passed string followed by a carriage return and linefeed }
begin
	EmStr(s);
	flushbuf;
	carriage_return;
	line_feed;
end;

{ event handling routines }

PROCEDURE em_input(eptr:PTR; VAR s:str255);
{ handle a keypress from the user }
VAR e:^EventRecord;
    c:char;
BEGIN
     e := POINTER(ORD4(eptr));
     { For now each character only maps to one character }
     s := 'X';				     {makes it have one character length }
     c := chr(e^.message MOD 128);
     if (BitAND(e^.modifiers,cmdKey) <> 0) & (c >= '@') then begin
	  if (c >= 'a') & (c <= 'z') then
	       c := chr(ord(c) - $20);			      { convert to upper }
	  s[1] := chr(ord(c) - $40)		     { extract control character }
	  end
     else if (c = '`') then begin
	   if (BitAND(e^.modifiers,cmdKey) = 0)
		then s[1] := chr(27) { escape }
		else s[1] := c;
	   end
     else if (c = ' ') then begin
	   if (BitAND(e^.modifiers,cmdKey) = 0)
		then s[1] := ' '
		else s[1] := chr(0); { command-space equals null }
	   end
     else
	  s[1] := c;						   { normal char }
END;

PROCEDURE IoUpdate;
var i,lin: integer;
{ redraw the screen in response to an update event by writing out the contents
  of our RAM image of the screen to the physical screen...
}
BEGIN
   BeginUpdate(myWindow);
   lin := toplin;
   for i := 0 to MAXLIN-1 do begin
       MoveTo(LEFTMARGIN,(i+1)*LINEHEIGHT+TOPMARGIN-LINEADJ);
       DrawText(@scr[lin],0,MAXCOL);
       lin := nxtlin[lin];
   end;
   MoveTo(curcol*width + LEFTMARGIN,
	  (abslin+1)*LINEHEIGHT + TOPMARGIN - LINEADJ);
   cursor_draw;
   EndUpdate(myWindow);
END;

PROCEDURE IoIdle;
{ called repeatedly when nothing is happening... use to blink cursor, etc. }
BEGIN
	flushbuf;
	if TickCount - lastblink >= GetCaretTime then begin
		if not cursor_on then cursor_draw else cursor_erase;
		lastblink := TickCount;
		end;
END;

PROCEDURE IoActivate(modifiers:INTEGER);
BEGIN
END;

PROCEDURE IoClick(where: INTEGER; pt: Point; modifiers: INTEGER);
{ gets called when some fool presses the button on the mouse.... }
BEGIN
END;

END.	 { of unit }

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

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

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;

{$L+}

CONST
{ TFTP randoms }
	GET     = 10	        { GET file from other host to here };
	PUT     = 11	        { PUT file on other host };
	ASCII   = 1	        { transfer as netascii };
	IMAGE   = 2	        { transfer as image };
	TEST    = 3	        { test mode - diskless };
	OCTET   = 4	        { octet mode - same as image };
	MACINTOSH = 5;	        { Macintosh mode - exchange Finder info }

{ TFTP error codes }
	ERRTXT	        = 0     { see the enclosed text };
	FNOTFOUND       = 1     { file not found };
	ACCESS	        = 2     { access violation };
	DISKFULL        = 3     { don't even ask. };
	ILLTFTP	        = 4     { illegal TFTP operation };
	BADTID	        = 5     { unkown transfer ID };
	FEXISTS	        = 6     { file already exists };
	NOUSER	        = 7     { no such user };
{ TFTP opcodes }
	RRQ     = 1	        { read  request };
	WRQ     = 2	        { write request };
	DATA    = 3	        { data packet };
	ACK     = 4	        { acknowledgement packet };
	ERRPCK  = 5	        { error packet };

TYPE
	 tf_FilePart = ( tf_DataPart, tf_RsrcPart, tf_FindPart);

	{ The TFTP connection structure. Contains connection info,and data for
	  timeout calculations. Also, I have added header information for
	  Mac queues so the connections can be kept on tfconnq }

	 Ref_TFconn = ^ tfconn;

	 tfconn = RECORD
		tf_next:Ref_TFconn;     { queue pointer to next element }
		tf_qtype:QTypes;        { second part of queue header }
		tf_udp: UDPCONN;        { udp connection for this transfer }
		tf_outp: PACKET;        { last sent packet }
		tf_lastlen: integer;    { length of last sent pkt }
		tf_expected: integer;   { most recently processed block }
		tf_fport: integer;      { foreign port }
		tf_task: Ref_task;      { main task for tftp connection }
		tf_tm: Ref_timer;       { our timer }
		tf_state: integer;      { state of connection }
		tf_done:ProcPTR;        { Procedure to call on close }
		tf_tries: integer;      { # of retries already done }
		tf_mode: integer;       { mode := IMAGE, [net]ASCII, ... }
		tf_dir: integer;        { direction of the transfer }
		tf_size: LongInt;       { # of bytes transferred }
		tf_rcv: integer;        { # of packets received }
		tf_snt: integer;        { # of packets sent }
		tf_ous: integer;        { # of out of sequence packets }
		tf_tmo: integer;        { # of timeouts }
		tf_rsnd: integer;       { # of resends }
		tf_trt: LongInt;        { round trip time }
		tf_rt: LongInt;	        { current timeout }
		tf_NR: Byte;	        { number rexmissions of this pkt }
		tf_NR_last: Byte;       { '     '       ' of prev pkt }
		tf_K: Byte;	        { tuning constant }
		tf_SAWCR: Boolean;      { did last packet end in CR? }
		tf_sent: LongInt;       { time that pkt was sent }
		tf_PB: ParmBlkPtr;      { parameter block for I/O }
		tf_fp: tf_FilePart;     { Which part of Macintosh }
		tf_volume: Integer;     { volume identifier of file }
		tf_fn: STR255;	        { name of the file - what a storage waste }
	END;

{ Generic TFTP Packet }

   tfpacket = PACKED RECORD
		tf_op: Integer;	        { op code }
		tf_block: Integer;      { Block of type dependent data }
		END;

   Ref_tftp = ^ tfpacket;

VAR
	ntftps: Byte;
	refusedt: LongInt;      { time of most recent transfer refusal }

FUNCTION tftp_head(p:PACKET):Ref_TFTP;

IMPLEMENTATION

{$S TFTPSeg}

FUNCTION tftp_head(p:PACKET):Ref_TFTP;
BEGIN
    tftp_head := POINTER(ORD4(udp_data(udp_head(in_head(p)))));
END; { tftp_head }

END.

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

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

  { TFTP_LIB module using UDP over the Applebus, file operations }
  { by 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;

{$L+}

FUNCTION ForkZero(cn:Ref_tfconn):BOOLEAN;
procedure CStr2PStr(PC: PTR; PS: StringPtr);
procedure PStr2CStr(PS: StringPtr; PC:Ptr);
PROCEDURE ScratchIt(cn:Ref_tfconn; VAR OSStatus:OSErr);
FUNCTION OpenOK(cn:Ref_tfconn; OSStatus:OSErr; p:PACKET):BOOLEAN;
FUNCTION MacPart(cn:Ref_tfconn; expected:INTEGER):Boolean;
PROCEDURE tfudperr(udpc: UDPCONN; p: PACKET; code:Integer; text: StringPtr);

{$IFC BUNDLE}
PROCEDURE setbundle(fn:StringPtr; vol:integer);
{$ENDC}

IMPLEMENTATION

{$S TFTPSeg }

FUNCTION ForkZero(cn:Ref_tfconn):BOOLEAN;
VAR OSStatus: OSErr;
BEGIN
     OSStatus := PBGetEOF(cn^.tf_PB,FALSE);
     IF OSStatus <> noERR THEN ForkZero := TRUE
     ELSE ForkZero := (ORD4(cn^.tf_PB^.ioMisc) = 0);
END;

procedure CStr2PStr(PC: PTR; PS: StringPtr);
{ Take a pointer to a C string and make it into a Pascal string }
VAR  Size: 0..255;
     ZeroPtr: PTR;
BEGIN
       ZeroPtr := PC;
       FOR Size := 0 TO 255 DO
	  IF ZeroPtr^ = 0 THEN BEGIN { Found end of C string, now copy it }
	       BlockMove(PC,POINTER(ORD4(PS)+1),Size);
	       ZeroPtr := POINTER(ORD4(PS));
	       ZeroPtr^ := Size;
	       EXIT(CStr2PStr);
	       END
	  ELSE ZeroPtr := POINTER(ORD4(ZeroPtr) + 1); { Advance the C ptr }
       { Did not find a null byte !}
       PS^ := '';
END;

procedure PStr2CStr(PS: StringPtr; PC:Ptr);
VAR TempPtr: PTR;
BEGIN
       TempPtr := POINTER(ORD4(PS)+1);
       BlockMove(TempPtr,PC,Length(PS^));
       PC := POINTER(ORD4(PC)+Length(PS^));
       PC^ := 0; { Place a null byte at end of string }
END;

PROCEDURE ScratchIt(cn:Ref_tfconn; VAR OSStatus:OSErr);
BEGIN
	IF OSStatus = NoErr THEN begin
		{ Already there, see if we can delete it }
		OSStatus := PBClose(cn^.tf_PB,FALSE);
		if OSStatus <> noErr then exit(ScratchIt);
		cn^.tf_PB^.ioNamePtr := @cn^.tf_fn;
		cn^.tf_PB^.ioVRefNum := cn^.tf_volume;
		cn^.tf_PB^.ioVersNum := 0;
		OSStatus := PBDelete(cn^.tf_PB,FALSE);
		if OSStatus <> noErr then exit(ScratchIt);
		OSStatus := fnfErr
		end;
	IF OSStatus = fnfErr THEN BEGIN
		{ Hm, name not present, let's create it }
		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);
		IF OSStatus = noErr THEN BEGIN { Have to set the finder info }
			cn^.tf_PB^.ioNamePtr := @cn^.tf_fn;
			cn^.tf_PB^.ioVRefNum := cn^.tf_volume;
			cn^.tf_PB^.ioVersNum := 0;
			cn^.tf_PB^.ioFlCrDat := TickCount;
			cn^.tf_PB^.ioFlMdDat := TickCount;
			cn^.tf_PB^.ioFlFndrInfo.fdCreator := '????';
			cn^.tf_PB^.ioFlFndrInfo.fdFlags := 0;
			cn^.tf_PB^.ioFlFndrInfo.fdFldr := fDisk;
			{ fdLocation is irrelevant; will be inited by Finder }
			if cn^.tf_fp = tf_RsrcPart then
				cn^.tf_PB^.ioFlFndrInfo.fdType := 'APPL'
			else    cn^.tf_PB^.ioFlFndrInfo.fdType := 'TEXT';
			OSStatus := PBSetFInfo(cn^.tf_PB,FALSE);
			END;
		IF OSStatus = noErr THEN BEGIN { Created it, now open it }
			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;
			IF cn^.tf_fp = tf_DataPart
			THEN    OSStatus := PBOpen(cn^.tf_PB,FALSE)
			ELSE    OSStatus := PBOpenRF(cn^.tf_PB,FALSE);
		END;
	END; { end of fnfErr}

	{ If everything is still OK, set mark to beginning of file }
	IF OSStatus = noErr THEN BEGIN
		cn^.tf_PB^.ioPosMode := fsFromStart;
		cn^.tf_PB^.ioPosOffset := 0;
		OSStatus := PBSetFPos(cn^.tf_PB,FALSE);
		END;
END; { of Scratch It }

FUNCTION OpenOK(cn:Ref_tfconn; OSStatus:OSErr; p:PACKET):BOOLEAN;
VAR     LongDummy:LONGINT;
BEGIN
	if (OSStatus <> noErr) THEN BEGIN
		FOpenErr(StrCvt(cn^.tf_fn),OSStatus);
		refusedt := TickCount;
{$IFC ALLOCT}
		Write('OpenOK: ');
{$ENDC}
		if p <> NIL then udp_free(p);
		ntftps := ntftps - 1;
		OpenOK := false;
		END
	ELSE    OpenOK := true;
END; { OpenOK }

{ Mac mode transfers involve three file parts.  This is managed by checking
  EOF's in Mac mode.  If there is an EOF and this isn't yet the data part,
  MacPart is called to switch to the next part. }

FUNCTION MacPart(cn:Ref_tfconn; expected:INTEGER):Boolean;
VAR OSStatus:OSErr;
    retval:Boolean;
BEGIN
	cn^.tf_expected := expected;
	if (cn^.tf_fp = tf_RsrcPart) then
		begin
{$IFC DEBUG}
		WriteLn('MacPart: changing to data fork');
{$ENDC}
		{ Open file descriptor with data fork }
		OSStatus := PBClose(cn^.tf_PB,FALSE);
		cn^.tf_fp := tf_DataPart;
		cn^.tf_PB^.ioNamePtr := @cn^.tf_fn;
		cn^.tf_PB^.ioVRefNum := cn^.tf_volume;
		cn^.tf_PB^.ioVersNum := 0;
		cn^.tf_PB^.ioMisc := NIL;
		if cn^.tf_dir = GET then
			BEGIN
			cn^.tf_PB^.ioPermssn := fsRdWrPerm;
			OSStatus := PBOpen(cn^.tf_PB,FALSE);
			END
		ELSE
			BEGIN
			cn^.tf_PB^.ioPermssn := fsRdPerm;
			OSStatus := PBOpen(cn^.tf_PB,FALSE);
			IF OSStatus = noErr THEN BEGIN
				cn^.tf_PB^.ioPosMode := fsFromStart;
				cn^.tf_PB^.ioPosOffset := 0;
				OSStatus := PBSetFPos(cn^.tf_PB,FALSE);
				END;
			END;
		retval := OpenOK(cn,OSStatus,NIL);
		if not retval then tfudperr(cn^.tf_udp, cn^.tf_outp, FNOTFOUND,
			 StrCvt('Could not change to data fork'));
		MacPart := retval;
		end

	else if (cn^.tf_fp = tf_FindPart) then
		begin
		{ Open file descriptor with resource file }
{$IFC DEBUG}
		WriteLn('MacPart: changing to resource fork');
{$ENDC}
		cn^.tf_fp := tf_RsrcPart;
		cn^.tf_PB^.ioNamePtr := @cn^.tf_fn;
		cn^.tf_PB^.ioVRefNum := cn^.tf_volume;
		cn^.tf_PB^.ioVersNum := 0;
		cn^.tf_PB^.ioMisc := NIL;
		if cn^.tf_dir = GET then
			BEGIN
			cn^.tf_PB^.ioPermssn := fsRdWrPerm;
			OSStatus := PBOpenRF(cn^.tf_PB, FALSE);
			END
		else
			BEGIN
			cn^.tf_PB^.ioPermssn := fsRdPerm;
			OSStatus := PBOpenRF(cn^.tf_PB, FALSE);
			IF OSStatus = noErr THEN BEGIN
				cn^.tf_PB^.ioPosMode := fsFromStart;
				cn^.tf_PB^.ioPosOffset := 0;
				OSStatus := PBSetFPos(cn^.tf_PB,FALSE);
				END;
			END;
		retval := OpenOK(cn,OSStatus,NIL);
		if not retval then tfudperr(cn^.tf_udp, cn^.tf_outp, FNOTFOUND,
			 StrCvt('Could not change to resource fork'));
		MacPart := retval;
		end;
END;

{$IFC BUNDLE}
{ If this file has a bundle in its resource fork, then set the bundle bit }

PROCEDURE setbundle(fn:StringPtr; vol:integer);
VAR     info:FInfo;
	refnum,count1,count2:integer;
	h:handle;
	o:^OSType;
begin
{$IFC DEBUG}
	WriteLn('setbundle: called on ',fn^,', volume ',vol:1);
{$ENDC}
	count1 := CountResources('BNDL');
	if setvol(NIL,vol) <> noErr then exit(setbundle);
	refnum := OpenResFile(fn^);
	if refnum = -1 then exit(setbundle);
	count2 := CountResources('BNDL');
	if count2 > count1 then { there's a bundle in this file }
		begin
		h := GetIndResource('BNDL',1);
		if (h = NIL) | (GetFInfo(fn^,vol,info) <> noErr) then begin
			CloseResFile(refnum);
			exit(setbundle);
			end;
		o := POINTER(ORD4(h^));
		info.fdCreator := o^;
		info.fdFlags := BitOR(info.fdFlags,fHasBundle);
		if SetFInfo(fn^,vol,info) <> noErr then begin
			CloseResFile(refnum);
			exit(setbundle);
			end;
		{ TODO: Open the desk top and remove the version data resource }
		end;
	CloseResFile(refnum);
end;
{$ENDC}

PROCEDURE tfudperr(udpc: UDPCONN; p: PACKET; code:Integer; text: StringPtr);
{ error packet definitions }
CONST
     tf_err_offset = 4;
TYPE
     tferr = PACKED RECORD
	{ +0 }	      tf_op: integer;	      { would be 5 }
	{ +2 }	      tf_code: integer;
	{ +4 }	      tf_err: packed array[0:0] of byte;
	END;
     Ref_tferr = ^ tferr;
VAR
	len: integer;
	perr: ^tferr;
	dummy: integer;
	FakeStr: StringPtr;
BEGIN
	len := 4;

	perr := { (struct tferr *) } POINTER(ORD4(tftp_head(p)));
	perr^.tf_op := { bswap} { No byte swap on 68000 }  (ERRPCK);
	perr^.tf_code := { bswap } { No bte swap on 68000 } (code);

	if(code=ERRTXT) THEN BEGIN
		FakeStr := Text;
		PStr2CStr( text,
			   { @perr^.tf_err } POINTER(ORD4(perr) + tf_err_offset));
		len := len + length(text^)+1; { 1 for the null byte }
		END
	else BEGIN
		CASE code OF
		    0: FakeStr := StrCvt('The JNC Memorial BUGHALT');
		    1: FakeStr := StrCvt('File not found');
		    2: FakeStr := StrCvt('Access violation');
		    3: FakeStr := StrCvt('Disk full');
		    4: FakeStr := StrCvt('Illegal TFTP operation');
		    5: FakeStr := StrCvt('Unknown transfer ID');
		    6: FakeStr := StrCvt('File already exists');
		    7: FakeStr := StrCvt('No such user');
		    otherwise FakeStr := StrCvt('Unknown error');
		END; { end of CASE }
		PStr2CStr( FakeStr,
			   { @perr^.tf_err } POINTER(ORD4(perr) + tf_err_offset));
		len := len + length(FakeStr^)+1; { 1 for the null byte }
		END;
{$IFC DEBUG}
	 WriteLn('TFTP: Sending error packet, ',code,' <',FakeStr^,'>');
{$ENDC}
	 dummy := udp_write(udpc, p, len);
END; { End of tfudperr }

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.