--- /dev/null
+\ *****************************************************************************
+\ * 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? ;
+
Code Review / kvmfornfv.git / blobdiff