qemu/roms/SLOF/slof/fs/envvar.fs

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2004, 2012 IBM Corporation
   3 \ * All rights reserved.
   4 \ * This program and the accompanying materials
   5 \ * are made available under the terms of the BSD License
   6 \ * which accompanies this distribution, and is available at
   7 \ * http://www.opensource.org/licenses/bsd-license.php
   8 \ *
   9 \ * Contributors:
  10 \ *     IBM Corporation - initial implementation
  11 \ ****************************************************************************/
  12
  13
  14 \ configuration variables
  15
  16 wordlist CONSTANT envvars
  17
  18 \ list the names in  envvars
  19 : listenv  ( -- )
  20    get-current envvars set-current  words  set-current
  21 ;
  22
  23 \ create a definition in  envvars
  24 : create-env ( "name" -- )
  25    get-current  envvars set-current  CREATE  set-current
  26 ;
  27
  28 \ lay out the data for the separate envvar types
  29 : env-int     ( n -- )  1 c, align , DOES> char+ aligned @ ;
  30 : env-bytes   ( a len -- )
  31    2 c, align dup , here swap dup allot move
  32    DOES> char+ aligned dup @ >r cell+ r>
  33 ;
  34 : env-string  ( str len -- )  3 c, align dup , here over allot swap move DOES> char+ aligned dup @ >r cell+ r> ;
  35 : env-flag    ( f -- )  4 c, c, DOES> char+ c@ 0<> ;
  36 : env-secmode ( sm -- )  5 c, c, DOES> char+ c@ ;
  37
  38 \ create default envvars
  39 : default-int     ( n "name" -- )      create-env env-int ;
  40 : default-bytes   ( a len "name" -- )  create-env env-bytes ;
  41 : default-string  ( a len "name" -- )  create-env env-string ;
  42 : default-flag    ( f "name" -- )      create-env env-flag ;
  43 : default-secmode ( sm "name" -- )     create-env env-secmode ;
  44
  45 : set-option ( option-name len option len -- )
  46    2swap encode-string
  47    2swap s" /options" find-node dup IF set-property ELSE drop 2drop 2drop THEN
  48 ;
  49
  50 \ find an envvar's current and default value, and its type
  51 : findenv ( name len -- adr def-adr type | 0 )
  52    2dup envvars voc-find dup 0<> IF ( ABORT" not a configuration variable" )
  53       link> >body char+ >r (find-order) link> >body dup char+ swap c@ r> swap
  54    ELSE
  55       nip nip
  56    THEN
  57 ;
  58
  59
  60 : test-flag ( param len -- true | false )
  61    2dup s" true" string=ci -rot s" false" string=ci or
  62 ;
  63
  64 : test-secmode ( param len -- true | false )
  65    2dup s" none" string=ci -rot 2dup s" command" string=ci -rot s" full"
  66    string=ci or or
  67 ;
  68
  69 : test-int ( param len -- true | false )
  70   $dh-number IF false ELSE drop true THEN
  71 ;
  72
  73 : findtype ( param len name len -- param len name len type )
  74    2dup findenv                         \ try to find type of envvar
  75    dup IF                               \ found a type?
  76       nip nip
  77       EXIT
  78    THEN
  79
  80    \ No type found yet, try to auto-detect:
  81    drop 2swap
  82    2dup test-flag IF
  83       4 -rot                         \ boolean type
  84    ELSE
  85       2dup test-secmode IF
  86          5 -rot                      \ secmode type
  87       ELSE
  88          2dup test-int IF
  89             1 -rot                   \ integer type
  90          ELSE
  91             2dup test-string
  92             IF 3 ELSE 2 THEN         \ 3 = string, 2 = default to bytes
  93             -rot
  94          THEN
  95       THEN
  96    THEN
  97    rot
  98    >r 2swap r>
  99 ;
 100
 101 \ set an envvar
 102 : $setenv ( param len name len -- )
 103    4dup set-option
 104    findtype
 105    -rot $CREATE
 106    CASE
 107       1 OF $dh-number IF 0 THEN env-int ENDOF \ XXX: wants decimal and 0x...
 108       2 OF env-bytes ENDOF
 109       3 OF env-string ENDOF
 110       4 OF evaluate env-flag ENDOF
 111       5 OF evaluate env-secmode ENDOF \ XXX: recognize none, command, full
 112    ENDCASE
 113 ;
 114
 115 \ print an envvar
 116 : (printenv) ( adr type -- )
 117    CASE
 118    1 OF aligned @ . ENDOF
 119    2 OF aligned dup cell+ swap @ swap . . ENDOF
 120    3 OF aligned dup @ >r cell+ r> type ENDOF
 121    4 OF c@ IF ." true" ELSE ." false" THEN ENDOF
 122    5 OF c@ . ENDOF \ XXX: print symbolically
 123    ENDCASE
 124 ;
 125
 126 : .printenv-header ( -- )
 127    cr
 128    s" ---environment variable--------current value-------------default value------"
 129    type cr
 130 ;
 131
 132 DEFER old-emit
 133 0 VALUE emit-counter
 134
 135 : emit-and-count emit-counter 1 + to emit-counter old-emit ;
 136
 137 : .enable-emit-counter
 138    0 to emit-counter
 139    ['] emit behavior to old-emit
 140    ['] emit-and-count to emit
 141 ;
 142
 143 : .disable-emit-counter
 144    ['] old-emit behavior to emit
 145 ;
 146
 147 : .spaces ( number-of-spaces -- )
 148    dup 0 > IF
 149       spaces
 150    ELSE
 151       drop space
 152    THEN
 153 ;
 154
 155 : .print-one-env ( name len -- )
 156    3 .spaces
 157    2dup dup -rot type 1c swap - .spaces
 158    findenv rot over
 159    .enable-emit-counter
 160    (printenv) .disable-emit-counter
 161    1a emit-counter - .spaces
 162    (printenv)
 163 ;
 164
 165 : .print-all-env
 166    .printenv-header
 167    envvars cell+
 168    BEGIN
 169       @ dup
 170    WHILE
 171       dup link> >name
 172       name>string .print-one-env cr
 173    REPEAT
 174    drop
 175 ;
 176
 177 : printenv
 178    parse-word dup 0= IF
 179       2drop .print-all-env
 180    ELSE
 181       findenv dup 0= ABORT" not a configuration variable"
 182       rot over cr ." Current: " (printenv)
 183       cr ." Default: " (printenv)
 184    THEN
 185 ;
 186
 187 \ set envvar(s) to default value
 188 : (set-default)  ( def-xt -- )
 189    dup >name name>string $CREATE dup >body c@ >r execute r> CASE
 190    1 OF env-int ENDOF
 191    2 OF env-bytes ENDOF
 192    3 OF env-string ENDOF
 193    4 OF env-flag ENDOF
 194    5 OF env-secmode ENDOF ENDCASE
 195 ;
 196
 197 \ Environment variables might be board specific
 198
 199 #include <envvar_defaults.fs>
 200
 201 VARIABLE nvoff \ offset in envvar partition
 202
 203 : (nvupdate-one) ( adr type -- "value" )
 204    CASE
 205    1 OF aligned @ (.d) ENDOF
 206    2 OF drop 0 0 ENDOF
 207    3 OF aligned dup @ >r cell+ r> ENDOF
 208    4 OF c@ IF s" true" ELSE s" false" THEN ENDOF
 209    5 OF c@ (.) ENDOF \ XXX: print symbolically
 210    ENDCASE
 211 ;
 212
 213 : nvupdate-one   ( def-xt -- )
 214    >r nvram-partition-type-common get-nvram-partition       ( part.addr part.len FALSE|TRUE R: def-xt )
 215    ABORT" No valid NVRAM." r>      ( part.addr part.len def-xt )
 216    >name name>string               ( part.addr part.len var.a var.l )
 217    2dup findenv nip (nvupdate-one)
 218    ( part.addr part.len var.addr var.len val.addr val.len )
 219    internal-add-env
 220    drop
 221 ;
 222
 223 : (nvupdate) ( -- )
 224    nvram-partition-type-common get-nvram-partition ABORT" No valid NVRAM."
 225    erase-nvram-partition drop
 226    envvars cell+
 227    BEGIN @ dup WHILE dup link> nvupdate-one REPEAT
 228    drop
 229 ;
 230
 231 : nvupdate ( -- )
 232    ." nvupdate is obsolete." cr
 233 ;
 234
 235 : set-default
 236    parse-word envvars voc-find
 237    dup 0= ABORT" not a configuration variable" link> (set-default)
 238 ;
 239
 240 : (set-defaults)
 241    envvars cell+
 242    BEGIN @ dup WHILE dup link> (set-default) REPEAT
 243    drop
 244 ;
 245
 246 \ Preset nvram variables in RAM, but do not overwrite them in NVRAM
 247 (set-defaults)
 248
 249 : set-defaults
 250    (set-defaults) (nvupdate)
 251 ;
 252
 253 : setenv  parse-word ( skipws ) 0d parse -leading 2swap $setenv (nvupdate) ;
 254
 255 : get-nv  ( -- )
 256    nvram-partition-type-common get-nvram-partition ( addr offset not-found | not-found ) \ find partition header
 257    IF
 258       ." No NVRAM common partition, re-initializing..." cr
 259       internal-reset-nvram
 260       (nvupdate)
 261       nvram-partition-type-common get-nvram-partition IF ." NVRAM seems to be broken." cr EXIT THEN
 262    THEN
 263    \ partition header found: read data from nvram
 264    drop ( addr )           \ throw away offset
 265    BEGIN
 266       dup rzcount  dup     \ make string from offset and make condition
 267    WHILE                   ( offset offset length )
 268       2dup [char] = split  \ Split string at equal sign (=)
 269                            ( offset offset length name len param len )
 270       2swap                ( offset offset length param len name len )
 271       $setenv              \ Set envvar
 272       nip                  \ throw away old string begin
 273       + 1+                 \ calc new offset
 274    REPEAT
 275    2drop drop              \ cleanup
 276 ;
 277
 278 get-nv
 279
 280 : check-for-nvramrc  ( -- )
 281    use-nvramrc?  IF
 282       s" Executing following code from nvramrc: "
 283       s" nvramrc" evaluate $cat
 284       nvramlog-write-string-cr
 285       s" (!) Executing code specified in nvramrc" type
 286       cr s"  SLOF Setup = " type
 287       \ to remove the string from the console if the nvramrc is broken
 288       \ we need to know how many chars are printed
 289       .enable-emit-counter
 290       s" nvramrc" evaluate ['] evaluate  CATCH  IF
 291          \ dropping the rest of the nvram string
 292          2drop
 293          \ delete the chars we do not want to see
 294          emit-counter 0  DO  8 emit  LOOP
 295          s" (!) Code in nvramrc triggered exception. "
 296          2dup nvramlog-write-string
 297          type cr 12 spaces s" Aborting nvramrc execution" 2dup
 298          nvramlog-write-string-cr type cr
 299          s"  SLOF Setup = " type
 300       THEN
 301       .disable-emit-counter
 302    THEN
 303 ;
 304
 305
 306 : (nv-findalias) ( alias-ptr alias-len -- pos )
 307    \ create a temporary empty string
 308    here 0
 309    \ append "devalias " to the temporary string
 310    s" devalias " string-cat
 311    \ append "<name-str>" to the temporary string
 312    3 pick 3 pick string-cat
 313    \ append a SPACE character to the temporary string
 314    s"  " string-cat
 315    \ get nvramrc
 316    s" nvramrc" evaluate
 317    \ get position of the temporary string inside of nvramrc
 318    2swap find-substr
 319    nip nip
 320 ;
 321
 322 : (nv-build-real-entry) ( name-ptr name-len dev-ptr dev-len -- str-ptr str-len )
 323    \ create a temporary empty string
 324    2swap here 0
 325    \ append "devalias " to the temporary string
 326    s" devalias " string-cat
 327    \ append "<name-ptr>" to the temporary string
 328    2swap string-cat
 329    \ append a SPACE character to the temporary string
 330    s"  " string-cat
 331    \ append "<dev-ptr> to the temporary string
 332    2swap string-cat
 333    \ append a CR character to the temporary string
 334    0d char-cat
 335    \ append a LF character to the temporary string
 336    0a char-cat
 337 ;
 338
 339 : (nv-build-null-entry) ( name-ptr name-len dev-ptr dev-len -- str-ptr str-len )
 340    4drop here 0
 341 ;
 342
 343 : (nv-build-nvramrc) ( name-str name-len dev-str dev-len xt-build-entry -- )
 344    \ *** PART 1: check if there is still an alias definition available ***
 345    ( alias-ptr alias-len path-ptr path-ptr call-build-entry alias-pos )
 346    4 pick 4 pick (nv-findalias)
 347    \ if our alias definition is a new one
 348    dup s" nvramrc" evaluate nip >= IF
 349       \ call-build-entry
 350       drop execute
 351       \ append content of "nvramrc" to the temporary string
 352       s" nvramrc" evaluate string-cat
 353       \ Allocate the temporary string
 354       dup allot
 355       \ write the string into nvramrc
 356       s" nvramrc" $setenv
 357    ELSE  \ if our alias is still defined in nvramrc
 358       \ *** PART 2: calculate the memory size for the new content of nvramrc ***
 359       \ add number of bytes needed for nvramrc-prefix to number of bytes needed
 360       \ for the new entry
 361       5 pick 5 pick 5 pick 5 pick 5 pick execute nip over +
 362       ( alias-ptr alias-len path-ptr path-ptr build-entry-xt alias-pos tmp-len )
 363       \ add number of bytes needed for nvramrc-postfix
 364       s" nvramrc" evaluate 3 pick string-at
 365       2dup find-nextline string-at nip +
 366       \ *** PART 3: build the new content ***
 367       \ allocate enough memory for new content
 368       alloc-mem 0
 369       ( alias-ptr alias-len path-ptr path-ptr build-entry-xt alias-pos mem len )
 370       \ add nvramrc-prefix
 371       s" nvramrc" evaluate drop 3 pick string-cat
 372       \ add new entry
 373       rot >r >r >r execute r> r> 2swap string-cat
 374       ( mem, len ) ( R: alias-pos )
 375       \ add nvramrc-postfix
 376       s" nvramrc" evaluate r> string-at
 377       2dup find-nextline string-at string-cat
 378       ( mem len )
 379       \ write the temporary string into nvramrc and clean up memory
 380       2dup s" nvramrc" $setenv free-mem
 381    THEN
 382 ;
 383
 384 : $nvalias ( name-str name-len dev-str dev-len -- )
 385    4dup ['] (nv-build-real-entry) (nv-build-nvramrc)
 386    set-alias
 387    s" true" s" use-nvramrc?" $setenv
 388    (nvupdate)
 389 ;
 390
 391 : nvalias ( "alias-name< >device-specifier<eol>" -- )
 392    parse-word parse-word dup 0<> IF
 393       $nvalias
 394    ELSE
 395       2drop 2drop
 396       cr
 397       "    Usage: nvalias (""alias-name< >device-specifier<eol>"" -- )" type
 398       cr
 399    THEN
 400 ;
 401
 402 : $nvunalias ( name-str name-len -- )
 403    s" " ['] (nv-build-null-entry) (nv-build-nvramrc)
 404    (nvupdate)
 405 ;
 406
 407 : nvunalias ( "alias-name< >" -- )
 408    parse-word $nvunalias
 409 ;
 410
 411 : diagnostic-mode? ( -- diag-switch? ) diag-switch? ;
 412