[OpenSPARC-T2-SAM] / obp / obp / pkg / netinet / args.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: args.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: @(#)args.fth 1.2 07/04/12
purpose: Network boot support package argument processing
copyright: Copyright 2007 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

headerless

\ Get next comma delimited argument. Used for old style argument processing.
: arg-nextfield ( $ -- rem$ field$ )  ascii , left-parse-string ;

\ Get next argument. Arguments are separated by commas and may consist
\ of a single key or a key=value pair. Commas may appear in the value
\ field if the value is a quoted string. 
: arg-nextparam ( args$ -- rem$ value$ key$ )
   " ," string-skipchars  dup 0=  if			( args$' )
      null$ null$ exit
   then							( args$' )
   2dup 0 -rot bounds ?do				( args$' 0 )
      i c@  dup  ascii , =  swap ascii = =  or  if
         drop  i c@  leave
      then
   loop							( args$' delim )
   dup >r  left-parse-string 2swap  r>			( key$ $ delim )
   ascii = <>  over 0=  or  if				( key$ $ )
      null$ 2rot exit					( rem$ value$ key$ )
   then							( key$ $ )
   over c@  ascii " =  if				( key$ $ )
      2dup  1 /string  ascii " left-parse-string	( key$ $ $' val$ )
      2swap dup  if					( key$ $ val$ $' )
         over c@  ascii , =				( key$ $ val$ $' ok? )
      else						( key$ $ val$ $' )
         2over ca+ c@  ascii " =			( key$ $ val$ $' ok? )
      then  nip nip  					( key$ $ val$ ok? )
      0=  if						( key$ $ val$ )
         ." Bad quoted string '" 2swap type  ." '"  cr  -1 throw
      then						( key$ $ val$ )
      nip 2+ string-split				( key$ rem$ value$ )
   else							( key$ $ )
      ascii , left-parse-string				( key$ rem$ value$ )
   then							( key$ rem$ value$ )
   2rot							( rem$ value$ key$ )
;

: set-inet-addr ( ip$ adr -- )  inet-aton 0= throw ;
: get-dnumber   ( $ -- n )      $dnumber throw ;

: set-hostip       ( ip$ -- )    my-ip-addr     set-inet-addr ;
: set-subnet-mask  ( ip$ -- )    my-netmask     set-inet-addr ;
: set-router       ( ip$ -- )    router-ip      set-inet-addr ;
: set-tftp-server  ( ip$ -- )    tftp-server-ip set-inet-addr ;

: set-hostname     ( name$ -- )  hostname   pack drop ;

\ Client identifiers may be specified either as the ASCII hexadecimal
\ representation of the identifier, or as a quoted string. The identifier
\ specified here is used, without any transformations, as the client 
\ identifier in DHCP transactions and in the WANboot HTTP request 
\ query string.

: (set-client-id) ( $ -- invalid? )
   over c@  ascii " =  if					( $ )
      qdstring>string  dup 2 MAX_CID_LEN between  if		( cid$ )
         client-id pack drop  false				( false )
      else							( $ )
         2drop true						( true )
      then							( invalid? )
   else								( $ )
      dup 2 mod 0=  over 2/  2 MAX_CID_LEN between  and  if	( $ )
         hexascii-to-octet  dup if				( cid,len )
            client-id pack drop  false				( false )
         else							( $ )
            2drop true						( true )
         then							( invalid? )
      else							( $ )
         2drop true						( true )
      then							( invalid? )
   then								( invalid? )
;

: set-client-id ( $ -- )  (set-client-id) throw ;

\ Boot file URIs must be "safe-encoded". URIs containing commas are 
\ presented as quoted strings. Replace all occurences of "\" or "|" 
\ with "/".
: set-boot-file ( $ -- )
   qdstring>string  bootfile pack count  2dup bounds ?do
      i c@ dup  ascii \ =  swap ascii | =  or  if  ascii / i c!  then
   loop
   2dup is-uri? if  check-uri$-form  else  2drop  then
;

\ HTTP proxy server specification.
: set-http-proxy ( proxy$ -- )
   2dup  check-htproxy$-form  http-proxy pack drop
;

: set-dhcp-retries ( $ -- )  get-dnumber to dhcp-max-retries ;
: set-tftp-retries ( $ -- )  get-dnumber to tftp-max-retries ;

: arg=protocol? ( $ -- flag )
   2dup  " rarp" $= >r  2dup " bootp" $= >r  " dhcp" $=  r> r>  or or
;

\ Process protocol argument. "bootp" is treated as a synonym of "dhcp".
: process-protocol-arg ( $ -- )
   2dup " bootp" $=  if  2drop " dhcp"  then		( strategy$ )
   config-strategy pack drop				( )
;

\ Key table for handling arguments specifying configuration parameters
create cfgparam-args
   " file"		true	['] set-boot-file	token-handler,
   "host-ip"		true	['] set-hostip		token-handler,
   "router-ip"		true	['] set-router		token-handler,
   "subnet-mask"	true	['] set-subnet-mask	token-handler,
   "client-id"		true	['] set-client-id	token-handler,
   "hostname"		true	['] set-hostname	token-handler,
   "http-proxy"		true	['] set-http-proxy	token-handler,
   "dhcp-retries"	true	['] set-dhcp-retries	token-handler,
   "tftp-retries"	true	['] set-tftp-retries	token-handler,
   null$ 		0	0			token-handler,

: (process-argument) ( value$ key$ xt -- )
   >r 2swap r> catch if
      2drop ." Improperly formatted value for '" type ." '"  cr -1 throw
   else
      2drop
   then
;

: process-argument ( value$ key$ -- )
   2dup cfgparam-args find-token-handler 0=  if		( value$ key$ )
      ." Unknown key '" type ." '" cr  2drop exit	( )
   then							( value$ key$ xt )
   3 pick 0=  if					( value$ key$ xt )
      drop ." Missing value for '" type ." '" cr -1 throw 
   then							( value$ key$ xt )
   (process-argument)					( )
;

\ Process arguments specified in the new-style syntax.
\    [protocol,] [key=value,]*
\
\ When the key=value style syntax is used, absence of the protocol
\ parameter implies manual configuration.

: newstyle-args? ( args$ -- flag )  ascii = strchr 0<> ;

: process-newstyle-args ( args$ -- )
   " manual" config-strategy pack drop		( args$ )
   begin  dup  while				( args$ )
      arg-nextparam  2dup arg=protocol?  if	( rem$ null$ protocol$ )
         2swap 2drop  process-protocol-arg	( rem$ )
      else					( rem$ value$ key$ )
         process-argument			( rem$ )
      then					( rem$ )
   repeat  2drop				( )
;

\ Process arguments specified in (old-style) positional parameter syntax. 
\   [dhcp|bootp|rarp,][server-ip],[filename],[client-ip],[router-ip],
\       [boot-retries],[tftp-retries],[subnet-mask]

: ?arg-nextfield ( $ -- rem$ field$ true | rem$ false )
   arg-nextfield dup if  true  else  2drop false  then
;

: process-oldstyle-args ( args$ -- )
   2dup arg-nextfield  2dup arg=protocol?  if		( args$ $ protocol$ )
      process-protocol-arg  2swap 2drop			( $ )
   else							( args$ $ arg$ )
      2drop 2drop					( rem$ )
   then							( rem$ )
   ?arg-nextfield  if
      "tftp-server"  ['] set-tftp-server (process-argument)
   then
   ?arg-nextfield  if  " file"         process-argument  then
   ?arg-nextfield  if  "host-ip"      process-argument  then
   ?arg-nextfield  if  "router-ip"    process-argument  then
   ?arg-nextfield  if  "dhcp-retries" process-argument  then
   ?arg-nextfield  if  "tftp-retries" process-argument  then
   ?arg-nextfield  if  "subnet-mask"  process-argument  then
   2drop
;

\ Manual configuration requires that the client be provided with (at the
\ minimum) its own IP address, address of the boot server and the name
\ of the bootfile. Hence, the argument must be in URI form. URI syntax
\ would have been validated already - the code here verifies that the
\ file component in the URI has been specified.

: (check-manual-config-args) ( -- ok? )
   my-ip-addr inaddr-any?  if				( )
      false exit					( false )
   then							( )
   bootfile count dup if				( $ )
      2dup is-uri?  if					( $ )
         parse-uri  2drop 2drop nip 0<>			( ok? )
      else						( $ )
         2drop false					( false )
      then						( ok? )
   else							( null$ )
      2drop false					( false )
   then							( ok? )
;

: check-manual-config-args ( -- )
   (check-manual-config-args) 0=  if
      ." Manual Configuration: "
      ." Host IP, boot server and filename must be specified" cr
      -1 throw
   then
;

\ Process package arguments specified either on the command line or in
\ 'network-boot-arguments'. If any argument is specified on the command 
\ line, all arguments in 'network-boot-arguments' are ignored.

: process-args ( $ -- )
   dup 0=  if							( null$ )
      2drop  " network-boot-arguments" get-option-string	( args$ )
   then								( args$ )
   dup 0=  if  2drop exit  then					( args$ )
   2dup newstyle-args?  if					( args$ )
      process-newstyle-args					( )
      config-strategy count " manual" $=  if			( )
         check-manual-config-args 				( )
      then							( )
   else								( args$ )
      process-oldstyle-args					( )
   then								( )
;

headers
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: args.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: @(#)args.fth 1.2 07/04/12
	43	purpose: Network boot support package argument processing
	44	copyright: Copyright 2007 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	headerless
	48
	49	\ Get next comma delimited argument. Used for old style argument processing.
	50	: arg-nextfield ( $ -- rem$ field$ ) ascii , left-parse-string ;
	51
	52	\ Get next argument. Arguments are separated by commas and may consist
	53	\ of a single key or a key=value pair. Commas may appear in the value
	54	\ field if the value is a quoted string.
	55	: arg-nextparam ( args$ -- rem$ value$ key$ )
	56	" ," string-skipchars dup 0= if ( args$' )
	57	null$ null$ exit
	58	then ( args$' )
	59	2dup 0 -rot bounds ?do ( args$' 0 )
	60	i c@ dup ascii , = swap ascii = = or if
	61	drop i c@ leave
	62	then
	63	loop ( args$' delim )
	64	dup >r left-parse-string 2swap r> ( key$ $ delim )
65	ascii = <> over 0= or if ( key$ $ )
66	null$ 2rot exit ( rem$ value$ key$ )
67	then ( key$ $ )
68	over c@ ascii " = if ( key$ $ )
69	2dup 1 /string ascii " left-parse-string ( key$ $ $' val$ )
70	2swap dup if ( key$ $ val$ $' )
71	over c@ ascii , = ( key$ $ val$ $' ok? )
72	else ( key$ $ val$ $' )
73	2over ca+ c@ ascii " = ( key$ $ val$ $' ok? )
74	then nip nip ( key$ $ val$ ok? )
75	0= if ( key$ $ val$ )
76	." Bad quoted string '" 2swap type ." '" cr -1 throw
77	then ( key$ $ val$ )
78	nip 2+ string-split ( key$ rem$ value$ )
79	else ( key$ $ )
80	ascii , left-parse-string ( key$ rem$ value$ )
81	then ( key$ rem$ value$ )
82	2rot ( rem$ value$ key$ )
83	;
84
85	: set-inet-addr ( ip$ adr -- ) inet-aton 0= throw ;
86	: get-dnumber ( $ -- n ) $dnumber throw ;
87
88	: set-hostip ( ip$ -- ) my-ip-addr set-inet-addr ;
89	: set-subnet-mask ( ip$ -- ) my-netmask set-inet-addr ;
90	: set-router ( ip$ -- ) router-ip set-inet-addr ;
91	: set-tftp-server ( ip$ -- ) tftp-server-ip set-inet-addr ;
92
93	: set-hostname ( name$ -- ) hostname pack drop ;
94
95	\ Client identifiers may be specified either as the ASCII hexadecimal
96	\ representation of the identifier, or as a quoted string. The identifier
97	\ specified here is used, without any transformations, as the client
98	\ identifier in DHCP transactions and in the WANboot HTTP request
99	\ query string.
100
101	: (set-client-id) ( $ -- invalid? )
102	over c@ ascii " = if ( $ )
103	qdstring>string dup 2 MAX_CID_LEN between if ( cid$ )
104	client-id pack drop false ( false )
105	else ( $ )
106	2drop true ( true )
107	then ( invalid? )
108	else ( $ )
109	dup 2 mod 0= over 2/ 2 MAX_CID_LEN between and if ( $ )
110	hexascii-to-octet dup if ( cid,len )
111	client-id pack drop false ( false )
112	else ( $ )
113	2drop true ( true )
114	then ( invalid? )
115	else ( $ )
116	2drop true ( true )
117	then ( invalid? )
118	then ( invalid? )
119	;
120
121	: set-client-id ( $ -- ) (set-client-id) throw ;
122
123	\ Boot file URIs must be "safe-encoded". URIs containing commas are
124	\ presented as quoted strings. Replace all occurences of "\" or "\|"
125	\ with "/".
126	: set-boot-file ( $ -- )
127	qdstring>string bootfile pack count 2dup bounds ?do
128	i c@ dup ascii \ = swap ascii \| = or if ascii / i c! then
129	loop
130	2dup is-uri? if check-uri$-form else 2drop then
131	;
132
133	\ HTTP proxy server specification.
134	: set-http-proxy ( proxy$ -- )
135	2dup check-htproxy$-form http-proxy pack drop
136	;
137
138	: set-dhcp-retries ( $ -- ) get-dnumber to dhcp-max-retries ;
139	: set-tftp-retries ( $ -- ) get-dnumber to tftp-max-retries ;
140
141	: arg=protocol? ( $ -- flag )
142	2dup " rarp" $= >r 2dup " bootp" $= >r " dhcp" $= r> r> or or
143	;
144
145	\ Process protocol argument. "bootp" is treated as a synonym of "dhcp".
146	: process-protocol-arg ( $ -- )
147	2dup " bootp" $= if 2drop " dhcp" then ( strategy$ )
148	config-strategy pack drop ( )
149	;
150
151	\ Key table for handling arguments specifying configuration parameters
152	create cfgparam-args
153	" file" true ['] set-boot-file token-handler,
154	"host-ip" true ['] set-hostip token-handler,
155	"router-ip" true ['] set-router token-handler,
156	"subnet-mask" true ['] set-subnet-mask token-handler,
157	"client-id" true ['] set-client-id token-handler,
158	"hostname" true ['] set-hostname token-handler,
159	"http-proxy" true ['] set-http-proxy token-handler,
160	"dhcp-retries" true ['] set-dhcp-retries token-handler,
161	"tftp-retries" true ['] set-tftp-retries token-handler,
162	null$ 0 0 token-handler,
163
164	: (process-argument) ( value$ key$ xt -- )
165	>r 2swap r> catch if
166	2drop ." Improperly formatted value for '" type ." '" cr -1 throw
167	else
168	2drop
169	then
170	;
171
172	: process-argument ( value$ key$ -- )
173	2dup cfgparam-args find-token-handler 0= if ( value$ key$ )
174	." Unknown key '" type ." '" cr 2drop exit ( )
175	then ( value$ key$ xt )
176	3 pick 0= if ( value$ key$ xt )
177	drop ." Missing value for '" type ." '" cr -1 throw
178	then ( value$ key$ xt )
179	(process-argument) ( )
180	;
181
182	\ Process arguments specified in the new-style syntax.
183	\ [protocol,] [key=value,]*
184	\
185	\ When the key=value style syntax is used, absence of the protocol
186	\ parameter implies manual configuration.
187
188	: newstyle-args? ( args$ -- flag ) ascii = strchr 0<> ;
189
190	: process-newstyle-args ( args$ -- )
191	" manual" config-strategy pack drop ( args$ )
192	begin dup while ( args$ )
193	arg-nextparam 2dup arg=protocol? if ( rem$ null$ protocol$ )
194	2swap 2drop process-protocol-arg ( rem$ )
195	else ( rem$ value$ key$ )
196	process-argument ( rem$ )
197	then ( rem$ )
198	repeat 2drop ( )
199	;
200
201	\ Process arguments specified in (old-style) positional parameter syntax.
202	\ [dhcp\|bootp\|rarp,][server-ip],[filename],[client-ip],[router-ip],
203	\ [boot-retries],[tftp-retries],[subnet-mask]
204
205	: ?arg-nextfield ( $ -- rem$ field$ true \| rem$ false )
206	arg-nextfield dup if true else 2drop false then
207	;
208
209	: process-oldstyle-args ( args$ -- )
210	2dup arg-nextfield 2dup arg=protocol? if ( args$ $ protocol$ )
211	process-protocol-arg 2swap 2drop ( $ )
212	else ( args$ $ arg$ )
213	2drop 2drop ( rem$ )
214	then ( rem$ )
215	?arg-nextfield if
216	"tftp-server" ['] set-tftp-server (process-argument)
217	then
218	?arg-nextfield if " file" process-argument then
219	?arg-nextfield if "host-ip" process-argument then
220	?arg-nextfield if "router-ip" process-argument then
221	?arg-nextfield if "dhcp-retries" process-argument then
222	?arg-nextfield if "tftp-retries" process-argument then
223	?arg-nextfield if "subnet-mask" process-argument then
224	2drop
225	;
226
227	\ Manual configuration requires that the client be provided with (at the
228	\ minimum) its own IP address, address of the boot server and the name
229	\ of the bootfile. Hence, the argument must be in URI form. URI syntax
230	\ would have been validated already - the code here verifies that the
231	\ file component in the URI has been specified.
232
233	: (check-manual-config-args) ( -- ok? )
234	my-ip-addr inaddr-any? if ( )
235	false exit ( false )
236	then ( )
237	bootfile count dup if ( $ )
238	2dup is-uri? if ( $ )
239	parse-uri 2drop 2drop nip 0<> ( ok? )
240	else ( $ )
241	2drop false ( false )
242	then ( ok? )
243	else ( null$ )
244	2drop false ( false )
245	then ( ok? )
246	;
247
248	: check-manual-config-args ( -- )
249	(check-manual-config-args) 0= if
250	." Manual Configuration: "
251	." Host IP, boot server and filename must be specified" cr
252	-1 throw
253	then
254	;
255
256	\ Process package arguments specified either on the command line or in
257	\ 'network-boot-arguments'. If any argument is specified on the command
258	\ line, all arguments in 'network-boot-arguments' are ignored.
259
260	: process-args ( $ -- )
261	dup 0= if ( null$ )
262	2drop " network-boot-arguments" get-option-string ( args$ )
263	then ( args$ )
264	dup 0= if 2drop exit then ( args$ )
265	2dup newstyle-args? if ( args$ )
266	process-newstyle-args ( )
267	config-strategy count " manual" $= if ( )
268	check-manual-config-args ( )
269	then ( )
270	else ( args$ )
271	process-oldstyle-args ( )
272	then ( )
273	;
274
275	headers