[OpenSPARC-T2-SAM] / obp / obp / pkg / dhcp / tftp.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: tftp.fth
\ 
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ 
\  - Do no alter or remove copyright notices
\ 
\  - Redistribution and use of this software in source and binary forms, with 
\    or without modification, are permitted provided that the following 
\    conditions are met: 
\ 
\  - Redistribution of source code must retain the above copyright notice, 
\    this list of conditions and the following disclaimer.
\ 
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution. 
\ 
\    Neither the name of Sun Microsystems, Inc. or the names of contributors 
\ may be used to endorse or promote products derived from this software 
\ without specific prior written permission. 
\ 
\     This software is provided "AS IS," without a warranty of any kind. 
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, 
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A 
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN 
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR 
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR 
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN 
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR 
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE 
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, 
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF 
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ 
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility. 
\ 
\ ========== Copyright Header End ============================================
id: @(#)tftp.fth 2.24 02/08/22
purpose: Trivial File Transfer Protocol (TFTP) implementation
copyright: Copyright 1990-2002 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\ Trivial File Transfer Protocol

decimal

headerless

d# 128 instance buffer: tftp-file-buf
instance defer tftp-file
' tftp-file-buf to tftp-file

1 constant rrq-pkt
2 constant wrq-pkt
3 constant data-pkt
4 constant ack-pkt
5 constant err-pkt

struct ( tftp packet )
      2 field >opcode
      0 field >block#
      0 field >filename
      2 field >errorcode
      0 field >errmsg
d#  512 field >data
constant /tftp-packet

: opcode    ( -- )  active-struct@ >opcode ;
: block#    ( -- )  active-struct@ >block# ;
: filename  ( -- )  active-struct@ >filename ;
: errorcode ( -- )  active-struct@ >errorcode ;
: errmsg    ( -- )  active-struct@ >errmsg ;
: data      ( -- )  active-struct@ >data ;

d# 69 constant UP_TFTP

instance variable sid
instance variable did
instance variable this-block
instance variable #retries
instance variable #packet

false instance value first-try?

-1 instance value tftp-retries

: too-many-tftp-retries?  ( -- flag )  \ flag true if too many retries
   #retries @  tftp-retries u>=
;

: .merror  ( -- )
   use-server?  use-dhcp @  or  if
     ." TFTP Error: " errmsg dup cstrlen type
     abort
   then
   UP_TFTP did !        \ Unlock from server
;

: $cstrput  ( from-adr,len to-adr -- end-adr )
   3dup swap move   ( from-adr,len to-adr )
   swap +  nip      ( end-adr-1 )
   0 over c!        ( end-adr-1 )
   1+
;

: setup-request  ( file-name-str  rrq-pkt/wrq-pkt -- )
   0 this-block !
   packet-to-send active-struct !
   1 sid +!
   UP_TFTP did !        ( file-name  rrq-pkt/wrq-pkt )
   opcode be-w!    ( file-name-str )
   filename $cstrput ( mode-adr )
   " octet" rot $cstrput
   packet-to-send  -  #packet !
;

: setup-read-request  ( file-name-string -- )
   rrq-pkt setup-request
   1 this-block +!
;

: setup-write-request  ( file-name-string -- )
   wrq-pkt setup-request
;

: setup-ack-packet  ( -- )
   packet-to-send  active-struct !
   ack-pkt opcode be-w!
   this-block @  block#  be-w!
   4 #packet !
   1 this-block +!
;

: send-packet  ( tftp-adr tftp-len -- #sent )
   did @ his-udp-port !
   sid @ my-udp-port !
   ( tftp-adr tftp-len ) prepare-udp-packet ( len )
   transmit dup 0=  if
      ." TFTP send failed. Check Ethernet cable and transceiver" cr
   then                     ( #sent )
   d# 4000 set-timeout
;

0 instance value error-packet        \ Buffer address

: send-error-packet  ( -- )
   /tftp-packet alloc-mem to error-packet
   did @ >r
   udp-source-port be-w@ did !  \ set the udp-source-port to the port indicated
                              \ in the received error packet.
   error-packet  active-struct !
   err-pkt opcode be-w!
   5 ( Unknown transfer ID )  errorcode be-w!
   " Unknown source address" errmsg $cstrput  ( end-address )
   error-packet  tuck  -     ( packet-adr len )
   send-packet  drop
   r>  did !                 \ restore the previous did
   error-packet  /tftp-packet free-mem
;

: unlock-dest-ip-en-addr ( -- )
   use-server?  use-router?  use-dhcp @  or or if  exit  then
   broadcast-ip-addr his-ip-addr 4 cmove
   broadcast-en-addr his-en-addr 6 cmove
;

: lock-dest-ip-en-addr ( -- )
   active-struct @
   dup /ip-header - active-struct !
   ip-source-addr his-ip-addr 4 cmove
   /ether-header negate active-struct +!
   en-source-addr his-en-addr 6 cmove
   active-struct !
   his-ip-addr server-ip-addr 4 cmove
;

\ Check source port against destination id.
\ If it mismatches, error unless did is currently 69
: bad-src-port?  ( -- error )  \ assumes active-struct is udp
   false
   udp-source-port be-w@  did @  <>  if
      did @  UP_TFTP =  if
         udp-source-port be-w@  did !         \ Lock onto his port
         his-ip-addr broadcast-ip-addr?  if
            lock-dest-ip-en-addr              \ Lock onto dest ip & ether addresses
         then
      else  drop true
      then
   then
;

\ Check block number.  Assumes active-struct is tftp.
: bad-block#?  ( -- error? )  block# be-w@  this-block @ <>  ;

: send-current-packet  ( -- #sent )  packet-to-send  #packet @  send-packet  ;

: receive-tftp-packet  ( -- [ tftp-pkt-adr tftp-pkt-len ] flag )
   begin
      receive-udp-packet 0=  if  false exit  then     ( udp-pkt udp-len )
      drop active-struct !                            ( )
      udp-dest-port be-w@  sid @  =
   until
   bad-src-port?  if  send-error-packet false exit  then
   active-struct @ /udp-header +         ( tftp-pkt-adr )
   udp-length be-w@  /udp-header -       ( tftp-pkt-adr tftp-len )
   true
;

: receive-data-packet ( -- [ data-adr data-len ] flag )
   begin
      receive-tftp-packet 0=  if  false exit  then    ( tftp-adr tftp-len )
      over active-struct !                            ( tftp-adr tftp-len )
      opcode be-w@ data-pkt <>  bad-block#?  or
   while
      opcode be-w@ err-pkt =  if  .merror  then
      2drop
   repeat                                              ( tftp-adr tftp-len )
   false is  first-try?
   nip data swap 4 -  true
;

: ?try-broadcast  ( -- )
   first-try?  if
      unlock-dest-ip-en-addr
      \ Relock the destination port number
      d# 69 did !
      \ Give the server to come back up. Delay
      \ re-broadcasting to avoid jaming up the net.
      #retries @  if  5000 ms  then
   then
;

: get-data-packet ( adr -- adr' more? )
   #retries off
   begin
      send-current-packet drop
      receive-data-packet
   0= while
      ?try-broadcast
      1 #retries +!
      #retries @ d# 10 /mod drop 0=  if
         ." Retrying ... Check TFTP server and network setup" cr
      then
      too-many-tftp-retries?  if
         ." TFTP retry count exceeded" cr false exit
      then
   repeat

   \ Copy data from packet to our buffer at addr
   >r over r@ cmove  ( adr )

   r@ +           ( adr' )
   r> d# 512 =    ( adr' more? )
;

: need-router?  ( -- flag )
    server-ip-addr be-l@  on-my-net?  0=
;

: tftp-init  ( -- )
   true is first-try?
   packet-to-send 0=  if
      /tftp-packet alloc-mem to packet-to-send
      /udp-pseudo-hdr alloc-mem to udp-pseudo-hdr
   then
   get-msecs  h# 0ffff and  sid !  \ "random" number
;

: tftp-close  ( -- )
   packet-to-send /tftp-packet free-mem
   0 to packet-to-send
   udp-pseudo-hdr /udp-pseudo-hdr free-mem
   0 to udp-pseudo-hdr
;

headers
: tftpread  ( adr file-name -- size )
   tftp-init            ( adr file-name )
   reserve-buffer       ( adr file-name )
   setup-read-request   ( adr )
   dup                  ( adr adr )
   begin
      get-data-packet   ( adr adr' more? )
   while
      show-progress setup-ack-packet
   repeat               ( adr adr' )
   \ Send the final acknowledge.  Don't send if receive error.
   too-many-tftp-retries? 0= if
      setup-ack-packet
      send-current-packet drop   \ ignore errors
   then
   swap -
   release-buffer
   tftp-close too-many-tftp-retries? if ." tftp failed" abort then
;

headerless

\ previous definitions

\ *** New routines for tftpwrite ***

: receive-ack-packet  ( -- [ ack-packet-adr ack-len ] flag )
        \ flag is true if good packet.  other entries only if flag true
   receive-tftp-packet  ( [ tftp-packet-adr tftp-len ] flag )
   0=  if  false exit  then   ( packet-adr len )
   over active-struct !

   \ Check packet type
   opcode be-w@  err-pkt =  if  .merror 2drop false exit  then
   opcode be-w@  ack-pkt  <>  if
     ." Got a non-ack packet"  2drop false exit
   then

   bad-block#?  if  2drop false   else  nip data swap 4 -  true  then
;

: get-ack-packet  ( -- ack-received? )
   #retries off
   begin
      send-current-packet
      receive-ack-packet   ( [ ack-packet-adr ack-len ] flag )
   0= while
      1 #retries +!

\ XXX we need to be able to retry the whole transaction at a higher
\ level, so we should exit more gracefully than we do here.

      too-many-tftp-retries?  if  ." receive failed" false exit  then
   repeat   2drop true
;

: setup-data-packet  ( adr sizeleft -- adr' sizeleft' done? )
   dup 0<  if true exit then
   packet-to-send active-struct !
   data-pkt opcode be-w!
   1 this-block +!
   this-block @ block# be-w!    ( adr sizeleft )
   2dup  d# 512 min           ( adr sizeleft adr size<=512 )
   dup  4 + #packet !
   data swap cmove
   d# 512 -   \ decrease size remaining
   swap d# 512 + swap   \ adjust addr for remaining data
   false
;

headers

: tftpwrite  ( adr size file-name -- )
   tftp-init             ( adr size )
   reserve-buffer        ( adr size )
   setup-write-request   ( adr size )
   begin
      get-ack-packet if
         setup-data-packet  ( adr' sizeleft' done? )
      else true             \ error exit from loop
      then
   until  2drop
   release-buffer
   tftp-close
;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: tftp.fth
	4	\
	5	\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
	6	\
	7	\ - Do no alter or remove copyright notices
	8	\
	9	\ - Redistribution and use of this software in source and binary forms, with
	10	\ or without modification, are permitted provided that the following
	11	\ conditions are met:
	12	\
	13	\ - Redistribution of source code must retain the above copyright notice,
	14	\ this list of conditions and the following disclaimer.
	15	\
	16	\ - Redistribution in binary form must reproduce the above copyright notice,
	17	\ this list of conditions and the following disclaimer in the
	18	\ documentation and/or other materials provided with the distribution.
	19	\
	20	\ Neither the name of Sun Microsystems, Inc. or the names of contributors
	21	\ may be used to endorse or promote products derived from this software
	22	\ without specific prior written permission.
	23	\
	24	\ This software is provided "AS IS," without a warranty of any kind.
	25	\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
	26	\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
	27	\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
	28	\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
	29	\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
	30	\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
	31	\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
	32	\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
	33	\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
	34	\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
	35	\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
	36	\
	37	\ You acknowledge that this software is not designed, licensed or
	38	\ intended for use in the design, construction, operation or maintenance of
	39	\ any nuclear facility.
	40	\
	41	\ ========== Copyright Header End ============================================
	42	id: @(#)tftp.fth 2.24 02/08/22
	43	purpose: Trivial File Transfer Protocol (TFTP) implementation
	44	copyright: Copyright 1990-2002 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	\ Trivial File Transfer Protocol
	48
	49	decimal
	50
	51	headerless
	52
	53	d# 128 instance buffer: tftp-file-buf
	54	instance defer tftp-file
	55	' tftp-file-buf to tftp-file
	56
	57	1 constant rrq-pkt
	58	2 constant wrq-pkt
	59	3 constant data-pkt
	60	4 constant ack-pkt
	61	5 constant err-pkt
	62
	63	struct ( tftp packet )
	64	2 field >opcode
65	0 field >block#
66	0 field >filename
67	2 field >errorcode
68	0 field >errmsg
69	d# 512 field >data
70	constant /tftp-packet
71
72	: opcode ( -- ) active-struct@ >opcode ;
73	: block# ( -- ) active-struct@ >block# ;
74	: filename ( -- ) active-struct@ >filename ;
75	: errorcode ( -- ) active-struct@ >errorcode ;
76	: errmsg ( -- ) active-struct@ >errmsg ;
77	: data ( -- ) active-struct@ >data ;
78
79	d# 69 constant UP_TFTP
80
81	instance variable sid
82	instance variable did
83	instance variable this-block
84	instance variable #retries
85	instance variable #packet
86
87	false instance value first-try?
88
89	-1 instance value tftp-retries
90
91	: too-many-tftp-retries? ( -- flag ) \ flag true if too many retries
92	#retries @ tftp-retries u>=
93	;
94
95	: .merror ( -- )
96	use-server? use-dhcp @ or if
97	." TFTP Error: " errmsg dup cstrlen type
98	abort
99	then
100	UP_TFTP did ! \ Unlock from server
101	;
102
103	: $cstrput ( from-adr,len to-adr -- end-adr )
104	3dup swap move ( from-adr,len to-adr )
105	swap + nip ( end-adr-1 )
106	0 over c! ( end-adr-1 )
107	1+
108	;
109
110	: setup-request ( file-name-str rrq-pkt/wrq-pkt -- )
111	0 this-block !
112	packet-to-send active-struct !
113	1 sid +!
114	UP_TFTP did ! ( file-name rrq-pkt/wrq-pkt )
115	opcode be-w! ( file-name-str )
116	filename $cstrput ( mode-adr )
117	" octet" rot $cstrput
118	packet-to-send - #packet !
119	;
120
121	: setup-read-request ( file-name-string -- )
122	rrq-pkt setup-request
123	1 this-block +!
124	;
125
126	: setup-write-request ( file-name-string -- )
127	wrq-pkt setup-request
128	;
129
130	: setup-ack-packet ( -- )
131	packet-to-send active-struct !
132	ack-pkt opcode be-w!
133	this-block @ block# be-w!
134	4 #packet !
135	1 this-block +!
136	;
137
138	: send-packet ( tftp-adr tftp-len -- #sent )
139	did @ his-udp-port !
140	sid @ my-udp-port !
141	( tftp-adr tftp-len ) prepare-udp-packet ( len )
142	transmit dup 0= if
143	." TFTP send failed. Check Ethernet cable and transceiver" cr
144	then ( #sent )
145	d# 4000 set-timeout
146	;
147
148	0 instance value error-packet \ Buffer address
149
150	: send-error-packet ( -- )
151	/tftp-packet alloc-mem to error-packet
152	did @ >r
153	udp-source-port be-w@ did ! \ set the udp-source-port to the port indicated
154	\ in the received error packet.
155	error-packet active-struct !
156	err-pkt opcode be-w!
157	5 ( Unknown transfer ID ) errorcode be-w!
158	" Unknown source address" errmsg $cstrput ( end-address )
159	error-packet tuck - ( packet-adr len )
160	send-packet drop
161	r> did ! \ restore the previous did
162	error-packet /tftp-packet free-mem
163	;
164
165	: unlock-dest-ip-en-addr ( -- )
166	use-server? use-router? use-dhcp @ or or if exit then
167	broadcast-ip-addr his-ip-addr 4 cmove
168	broadcast-en-addr his-en-addr 6 cmove
169	;
170
171	: lock-dest-ip-en-addr ( -- )
172	active-struct @
173	dup /ip-header - active-struct !
174	ip-source-addr his-ip-addr 4 cmove
175	/ether-header negate active-struct +!
176	en-source-addr his-en-addr 6 cmove
177	active-struct !
178	his-ip-addr server-ip-addr 4 cmove
179	;
180
181	\ Check source port against destination id.
182	\ If it mismatches, error unless did is currently 69
183	: bad-src-port? ( -- error ) \ assumes active-struct is udp
184	false
185	udp-source-port be-w@ did @ <> if
186	did @ UP_TFTP = if
187	udp-source-port be-w@ did ! \ Lock onto his port
188	his-ip-addr broadcast-ip-addr? if
189	lock-dest-ip-en-addr \ Lock onto dest ip & ether addresses
190	then
191	else drop true
192	then
193	then
194	;
195
196	\ Check block number. Assumes active-struct is tftp.
197	: bad-block#? ( -- error? ) block# be-w@ this-block @ <> ;
198
199	: send-current-packet ( -- #sent ) packet-to-send #packet @ send-packet ;
200
201	: receive-tftp-packet ( -- [ tftp-pkt-adr tftp-pkt-len ] flag )
202	begin
203	receive-udp-packet 0= if false exit then ( udp-pkt udp-len )
204	drop active-struct ! ( )
205	udp-dest-port be-w@ sid @ =
206	until
207	bad-src-port? if send-error-packet false exit then
208	active-struct @ /udp-header + ( tftp-pkt-adr )
209	udp-length be-w@ /udp-header - ( tftp-pkt-adr tftp-len )
210	true
211	;
212
213	: receive-data-packet ( -- [ data-adr data-len ] flag )
214	begin
215	receive-tftp-packet 0= if false exit then ( tftp-adr tftp-len )
216	over active-struct ! ( tftp-adr tftp-len )
217	opcode be-w@ data-pkt <> bad-block#? or
218	while
219	opcode be-w@ err-pkt = if .merror then
220	2drop
221	repeat ( tftp-adr tftp-len )
222	false is first-try?
223	nip data swap 4 - true
224	;
225
226	: ?try-broadcast ( -- )
227	first-try? if
228	unlock-dest-ip-en-addr
229	\ Relock the destination port number
230	d# 69 did !
231	\ Give the server to come back up. Delay
232	\ re-broadcasting to avoid jaming up the net.
233	#retries @ if 5000 ms then
234	then
235	;
236
237	: get-data-packet ( adr -- adr' more? )
238	#retries off
239	begin
240	send-current-packet drop
241	receive-data-packet
242	0= while
243	?try-broadcast
244	1 #retries +!
245	#retries @ d# 10 /mod drop 0= if
246	." Retrying ... Check TFTP server and network setup" cr
247	then
248	too-many-tftp-retries? if
249	." TFTP retry count exceeded" cr false exit
250	then
251	repeat
252
253	\ Copy data from packet to our buffer at addr
254	>r over r@ cmove ( adr )
255
256	r@ + ( adr' )
257	r> d# 512 = ( adr' more? )
258	;
259
260	: need-router? ( -- flag )
261	server-ip-addr be-l@ on-my-net? 0=
262	;
263
264	: tftp-init ( -- )
265	true is first-try?
266	packet-to-send 0= if
267	/tftp-packet alloc-mem to packet-to-send
268	/udp-pseudo-hdr alloc-mem to udp-pseudo-hdr
269	then
270	get-msecs h# 0ffff and sid ! \ "random" number
271	;
272
273	: tftp-close ( -- )
274	packet-to-send /tftp-packet free-mem
275	0 to packet-to-send
276	udp-pseudo-hdr /udp-pseudo-hdr free-mem
277	0 to udp-pseudo-hdr
278	;
279
280	headers
281	: tftpread ( adr file-name -- size )
282	tftp-init ( adr file-name )
283	reserve-buffer ( adr file-name )
284	setup-read-request ( adr )
285	dup ( adr adr )
286	begin
287	get-data-packet ( adr adr' more? )
288	while
289	show-progress setup-ack-packet
290	repeat ( adr adr' )
291	\ Send the final acknowledge. Don't send if receive error.
292	too-many-tftp-retries? 0= if
293	setup-ack-packet
294	send-current-packet drop \ ignore errors
295	then
296	swap -
297	release-buffer
298	tftp-close too-many-tftp-retries? if ." tftp failed" abort then
299	;
300
301	headerless
302
303	\ previous definitions
304
305	\ * New routines for tftpwrite *
306
307	: receive-ack-packet ( -- [ ack-packet-adr ack-len ] flag )
308	\ flag is true if good packet. other entries only if flag true
309	receive-tftp-packet ( [ tftp-packet-adr tftp-len ] flag )
310	0= if false exit then ( packet-adr len )
311	over active-struct !
312
313	\ Check packet type
314	opcode be-w@ err-pkt = if .merror 2drop false exit then
315	opcode be-w@ ack-pkt <> if
316	." Got a non-ack packet" 2drop false exit
317	then
318
319	bad-block#? if 2drop false else nip data swap 4 - true then
320	;
321
322	: get-ack-packet ( -- ack-received? )
323	#retries off
324	begin
325	send-current-packet
326	receive-ack-packet ( [ ack-packet-adr ack-len ] flag )
327	0= while
328	1 #retries +!
329
330	\ XXX we need to be able to retry the whole transaction at a higher
331	\ level, so we should exit more gracefully than we do here.
332
333	too-many-tftp-retries? if ." receive failed" false exit then
334	repeat 2drop true
335	;
336
337	: setup-data-packet ( adr sizeleft -- adr' sizeleft' done? )
338	dup 0< if true exit then
339	packet-to-send active-struct !
340	data-pkt opcode be-w!
341	1 this-block +!
342	this-block @ block# be-w! ( adr sizeleft )
343	2dup d# 512 min ( adr sizeleft adr size<=512 )
344	dup 4 + #packet !
345	data swap cmove
346	d# 512 - \ decrease size remaining
347	swap d# 512 + swap \ adjust addr for remaining data
348	false
349	;
350
351	headers
352
353	: tftpwrite ( adr size file-name -- )
354	tftp-init ( adr size )
355	reserve-buffer ( adr size )
356	setup-write-request ( adr size )
357	begin
358	get-ack-packet if
359	setup-data-packet ( adr' sizeleft' done? )
360	else true \ error exit from loop
361	then
362	until 2drop
363	release-buffer
364	tftp-close
365	;