slof/fs/envvar.fs

\ *****************************************************************************
\ * Copyright (c) 2004, 2008 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 dup 0= \ try to find type of envvar
   IF             \ no type found
    drop 2swap
    2dup test-flag if 4 -rot else
    2dup test-secmode if 5 -rot else
       2dup test-int if 1 -rot else
	  2dup test-string IF 3 ELSE 2 THEN  \ 3 = string, 2 = default to bytes
	  -rot then then then
    rot
    >r 2swap r>
    \ XXX: create env
  else           \ take type from default value
    nip nip
  THEN
;

\ set an envvar
: $setenv ( param len name len -- )
   4dup set-option
   findtype dup 0=
   IF
      true ABORT" not a configuration variable"
   ELSE
      -rot $CREATE CASE
      1 OF evaluate env-int ENDOF \ XXX: wants decimal and 0x...
      \ Since we don't have 0x for hexnumbers, we need to find out the type ...
      2 OF
         2dup                    ( param len param len )
         depth >r                ( param len param len  R: depth-before )
         ['] evaluate CATCH IF   \ Catch 'unknown Forth words'...
            ( param len param' len'  R: depth-before )
            2drop  r> drop
            env-string           \ and encode 'unknown word' as string
         ELSE
            ( param len [...evaluated results...]  R: depth-before )
            \ If EVALUATE placed two items on the stack, use env-bytes,
            \ for one item use env-int:
            depth r> = IF env-bytes ELSE env-int THEN
            2drop
         THEN
      ENDOF
      3 OF env-string ENDOF
      4 OF evaluate env-flag ENDOF
      5 OF evaluate env-secmode ENDOF \ XXX: recognize none, command, full
      ENDCASE
   THEN
;

\ print an envvar
: (printenv) ( adr type -- )
   CASE
   1 OF aligned @ . ENDOF
   2 OF aligned dup cell+ swap @ dup IF dump ELSE 2drop THEN 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
   dup 0 > IF spaces ELSE
   drop space THEN
;

: .print-one-env
   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 s" 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? ;