slof/fs/envvar.fs

\ *****************************************************************************
\ * 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, string, DOES> char+ count ;
: 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 )
  drop c@ isdigit if true else false 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 evaluate 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 count 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
;

\ Enviroment variables might be board specific

#include <envvar_defaults.fs>

VARIABLE nvoff \ offset in envvar partition

: (nvupdate-one) ( adr type -- "value" )
   CASE
   1 OF aligned @ (.) ENDOF
   2 OF drop 0 0 ENDOF
   3 OF count 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? ;