summaryrefslogtreecommitdiffstats
path: root/qemu/roms/SLOF/slof/fs/envvar.fs
blob: 33643130c25f2f679e0bfb41f624e9ca965be3b2 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
\ *****************************************************************************
\ * Copyright (c) 2004, 2012 IBM Corporation
\ * All rights reserved.
\ * This program and the accompanying materials
\ * are made available under the terms of the BSD License
\ * which accompanies this distribution, and is available at
\ * http://www.opensource.org/licenses/bsd-license.php
\ *
\ * Contributors:
\ *     IBM Corporation - initial implementation
\ ****************************************************************************/


\ configuration variables

wordlist CONSTANT envvars

\ list the names in  envvars
: listenv  ( -- )
   get-current envvars set-current  words  set-current
;

\ create a definition in  envvars
: create-env ( "name" -- )
   get-current  envvars set-current  CREATE  set-current
;

\ lay out the data for the separate envvar types
: env-int     ( n -- )  1 c, align , DOES> char+ aligned @ ;
: env-bytes   ( a len -- )
   2 c, align dup , here swap dup allot move
   DOES> char+ aligned dup @ >r cell+ r>
;
: env-string  ( str len -- )  3 c, align dup , here over allot swap move DOES> char+ aligned dup @ >r cell+ r> ;
: env-flag    ( f -- )  4 c, c, DOES> char+ c@ 0<> ;
: env-secmode ( sm -- )  5 c, c, DOES> char+ c@ ;

\ create default envvars
: default-int     ( n "name" -- )      create-env env-int ;
: default-bytes   ( a len "name" -- )  create-env env-bytes ;
: default-string  ( a len "name" -- )  create-env env-string ;
: default-flag    ( f "name" -- )      create-env env-flag ;
: default-secmode ( sm "name" -- )     create-env env-secmode ;

: set-option ( option-name len option len -- )
   2swap encode-string
   2swap s" /options" find-node dup IF set-property ELSE drop 2drop 2drop THEN
;

\ find an envvar's current and default value, and its type
: findenv ( name len -- adr def-adr type | 0 )
   2dup envvars voc-find dup 0<> IF ( ABORT" not a configuration variable" )
      link> >body char+ >r (find-order) link> >body dup char+ swap c@ r> swap
   ELSE
      nip nip
   THEN
;


: test-flag ( param len -- true | false )
   2dup s" true" string=ci -rot s" false" string=ci or
;

: test-secmode ( param len -- true | false )
   2dup s" none" string=ci -rot 2dup s" command" string=ci -rot s" full"
   string=ci or or
;

: test-int ( param len -- true | false )
  $dh-number IF false ELSE drop true THEN
;

: findtype ( param len name len -- param len name len type )
   2dup findenv                         \ try to find type of envvar
   dup IF                               \ found a type?
      nip nip
      EXIT
   THEN

   \ No type found yet, try to auto-detect:
   drop 2swap
   2dup test-flag IF
      4 -rot                         \ boolean type
   ELSE
      2dup test-secmode IF
         5 -rot                      \ secmode type
      ELSE
         2dup test-int IF
            1 -rot                   \ integer type
         ELSE
            2dup test-string
            IF 3 ELSE 2 THEN         \ 3 = string, 2 = default to bytes
            -rot
         THEN
      THEN
   THEN
   rot
   >r 2swap r>
;

\ set an envvar
: $setenv ( param len name len -- )
   4dup set-option
   findtype
   -rot $CREATE
   CASE
      1 OF $dh-number IF 0 THEN env-int ENDOF \ XXX: wants decimal and 0x...
      2 OF env-bytes ENDOF
      3 OF env-string ENDOF
      4 OF evaluate env-flag ENDOF
      5 OF evaluate env-secmode ENDOF \ XXX: recognize none, command, full
   ENDCASE
;

\ print an envvar
: (printenv) ( adr type -- )
   CASE
   1 OF aligned @ . ENDOF
   2 OF aligned dup cell+ swap @ swap . . ENDOF
   3 OF aligned dup @ >r cell+ r> type ENDOF
   4 OF c@ IF ." true" ELSE ." false" THEN ENDOF
   5 OF c@ . ENDOF \ XXX: print symbolically
   ENDCASE
;

: .printenv-header ( -- )
   cr
   s" ---environment variable--------current value-------------default value------"
   type cr
;

DEFER old-emit
0 VALUE emit-counter

: emit-and-count emit-counter 1 + to emit-counter old-emit ;

: .enable-emit-counter
   0 to emit-counter
   ['] emit behavior to old-emit
   ['] emit-and-count to emit
;

: .disable-emit-counter
   ['] old-emit behavior to emit
;

: .spaces ( number-of-spaces -- )
   dup 0 > IF
      spaces
   ELSE
      drop space
   THEN
;

: .print-one-env ( name len -- )
   3 .spaces
   2dup dup -rot type 1c swap - .spaces
   findenv rot over
   .enable-emit-counter
   (printenv) .disable-emit-counter
   1a emit-counter - .spaces
   (printenv)
;

: .print-all-env
   .printenv-header
   envvars cell+
   BEGIN
      @ dup
   WHILE
      dup link> >name
      name>string .print-one-env cr
   REPEAT
   drop
;

: printenv
   parse-word dup 0= IF
      2drop .print-all-env
   ELSE
      findenv dup 0= ABORT" not a configuration variable"
      rot over cr ." Current: " (printenv)
      cr ." Default: " (printenv)
   THEN
;

\ set envvar(s) to default value
: (set-default)  ( def-xt -- )
   dup >name name>string $CREATE dup >body c@ >r execute r> CASE
   1 OF env-int ENDOF
   2 OF env-bytes ENDOF
   3 OF env-string ENDOF
   4 OF env-flag ENDOF
   5 OF env-secmode ENDOF ENDCASE
;

\ Environment variables might be board specific

#include <envvar_defaults.fs>

VARIABLE nvoff \ offset in envvar partition

: (nvupdate-one) ( adr type -- "value" )
   CASE
   1 OF aligned @ (.d) ENDOF
   2 OF drop 0 0 ENDOF
   3 OF aligned dup @ >r cell+ r> ENDOF
   4 OF c@ IF s" true" ELSE s" false" THEN ENDOF
   5 OF c@ (.) ENDOF \ XXX: print symbolically
   ENDCASE
;

: nvupdate-one   ( def-xt -- )
   >r nvram-partition-type-common get-nvram-partition       ( part.addr part.len FALSE|TRUE R: def-xt )
   ABORT" No valid NVRAM." r>      ( part.addr part.len def-xt )
   >name name>string               ( part.addr part.len var.a var.l )
   2dup findenv nip (nvupdate-one)
   ( part.addr part.len var.addr var.len val.addr val.len )
   internal-add-env
   drop
;

: (nvupdate) ( -- )
   nvram-partition-type-common get-nvram-partition ABORT" No valid NVRAM."
   erase-nvram-partition drop
   envvars cell+
   BEGIN @ dup WHILE dup link> nvupdate-one REPEAT
   drop
;

: nvupdate ( -- )
   ." nvupdate is obsolete." cr
;

: set-default
   parse-word envvars voc-find
   dup 0= ABORT" not a configuration variable" link> (set-default)
;

: (set-defaults)
   envvars cell+
   BEGIN @ dup WHILE dup link> (set-default) REPEAT
   drop
;

\ Preset nvram variables in RAM, but do not overwrite them in NVRAM
(set-defaults)

: set-defaults
   (set-defaults) (nvupdate)
;

: setenv  parse-word ( skipws ) 0d parse -leading 2swap $setenv (nvupdate) ;

: get-nv  ( -- )
   nvram-partition-type-common get-nvram-partition ( addr offset not-found | not-found ) \ find partition header
   IF
      ." No NVRAM common partition, re-initializing..." cr
      internal-reset-nvram
      (nvupdate)
      nvram-partition-type-common get-nvram-partition IF ." NVRAM seems to be broken." cr EXIT THEN
   THEN
   \ partition header found: read data from nvram
   drop ( addr )           \ throw away offset
   BEGIN
      dup rzcount  dup     \ make string from offset and make condition
   WHILE                   ( offset offset length )
      2dup [char] = split  \ Split string at equal sign (=)
                           ( offset offset length name len param len )
      2swap                ( offset offset length param len name len )
      $setenv              \ Set envvar
      nip                  \ throw away old string begin
      + 1+                 \ calc new offset
   REPEAT
   2drop drop              \ cleanup
;

get-nv

: check-for-nvramrc  ( -- )
   use-nvramrc?  IF
      s" Executing following code from nvramrc: "
      s" nvramrc" evaluate $cat
      nvramlog-write-string-cr
      s" (!) Executing code specified in nvramrc" type
      cr s"  SLOF Setup = " type
      \ to remove the string from the console if the nvramrc is broken
      \ we need to know how many chars are printed
      .enable-emit-counter
      s" nvramrc" evaluate ['] evaluate  CATCH  IF
         \ dropping the rest of the nvram string
         2drop
         \ delete the chars we do not want to see
         emit-counter 0  DO  8 emit  LOOP
         s" (!) Code in nvramrc triggered exception. "
         2dup nvramlog-write-string
         type cr 12 spaces s" Aborting nvramrc execution" 2dup
         nvramlog-write-string-cr type cr
         s"  SLOF Setup = " type
      THEN
      .disable-emit-counter
   THEN
;


: (nv-findalias) ( alias-ptr alias-len -- pos )
   \ create a temporary empty string
   here 0
   \ append "devalias " to the temporary string
   s" devalias " string-cat
   \ append "<name-str>" to the temporary string
   3 pick 3 pick string-cat
   \ append a SPACE character to the temporary string
   s"  " string-cat
   \ get nvramrc
   s" nvramrc" evaluate
   \ get position of the temporary string inside of nvramrc
   2swap find-substr
   nip nip
;

: (nv-build-real-entry) ( name-ptr name-len dev-ptr dev-len -- str-ptr str-len )
   \ create a temporary empty string
   2swap here 0
   \ append "devalias " to the temporary string
   s" devalias " string-cat
   \ append "<name-ptr>" to the temporary string
   2swap string-cat
   \ append a SPACE character to the temporary string
   s"  " string-cat
   \ append "<dev-ptr> to the temporary string
   2swap string-cat
   \ append a CR character to the temporary string
   0d char-cat
   \ append a LF character to the temporary string
   0a char-cat
;

: (nv-build-null-entry) ( name-ptr name-len dev-ptr dev-len -- str-ptr str-len )
   4drop here 0
;

: (nv-build-nvramrc) ( name-str name-len dev-str dev-len xt-build-entry -- )
   \ *** PART 1: check if there is still an alias definition available ***
   ( alias-ptr alias-len path-ptr path-ptr call-build-entry alias-pos )
   4 pick 4 pick (nv-findalias)
   \ if our alias definition is a new one
   dup s" nvramrc" evaluate nip >= IF
      \ call-build-entry
      drop execute
      \ append content of "nvramrc" to the temporary string
      s" nvramrc" evaluate string-cat
      \ Allocate the temporary string
      dup allot
      \ write the string into nvramrc
      s" nvramrc" $setenv
   ELSE  \ if our alias is still defined in nvramrc
      \ *** PART 2: calculate the memory size for the new content of nvramrc ***
      \ add number of bytes needed for nvramrc-prefix to number of bytes needed
      \ for the new entry
      5 pick 5 pick 5 pick 5 pick 5 pick execute nip over +
      ( alias-ptr alias-len path-ptr path-ptr build-entry-xt alias-pos tmp-len )
      \ add number of bytes needed for nvramrc-postfix
      s" nvramrc" evaluate 3 pick string-at
      2dup find-nextline string-at nip +
      \ *** PART 3: build the new content ***
      \ allocate enough memory for new content
      alloc-mem 0
      ( alias-ptr alias-len path-ptr path-ptr build-entry-xt alias-pos mem len )
      \ add nvramrc-prefix
      s" nvramrc" evaluate drop 3 pick string-cat
      \ add new entry
      rot >r >r >r execute r> r> 2swap string-cat
      ( mem, len ) ( R: alias-pos )
      \ add nvramrc-postfix
      s" nvramrc" evaluate r> string-at
      2dup find-nextline string-at string-cat
      ( mem len )
      \ write the temporary string into nvramrc and clean up memory
      2dup s" nvramrc" $setenv free-mem
   THEN
;

: $nvalias ( name-str name-len dev-str dev-len -- )
   4dup ['] (nv-build-real-entry) (nv-build-nvramrc)
   set-alias
   s" true" s" use-nvramrc?" $setenv
   (nvupdate)
;

: nvalias ( "alias-name< >device-specifier<eol>" -- )
   parse-word parse-word dup 0<> IF
      $nvalias
   ELSE
      2drop 2drop
      cr
      "    Usage: nvalias (""alias-name< >device-specifier<eol>"" -- )" type
      cr
   THEN    
;

: $nvunalias ( name-str name-len -- )
   s" " ['] (nv-build-null-entry) (nv-build-nvramrc)
   (nvupdate)
;

: nvunalias ( "alias-name< >" -- )
   parse-word $nvunalias
;

: diagnostic-mode? ( -- diag-switch? ) diag-switch? ;