Overview
| SHA1 Hash: | 8f378d47407d563d12d4edbe100afdae12a1f9fb |
|---|---|
| Date: | 2011-11-27 16:28:25 |
| User: | matt |
| Comment: | Completed but not tested non-destructive open/modify/write of config files |
| Timelines: | family | ancestors | descendants | both | trunk |
| Downloads: | Tarball | ZIP archive |
| Other Links: | files | file ages | manifest |
Tags And Properties
- branch=trunk inherited from [d673a9367e]
- sym-trunk inherited from [d673a9367e]
Changes
Modified configf.scm from [e94bf5cc897fc504] to [b0a9c60c641a4415].
38 (append newalist (list (list key val))))) 38 (append newalist (list (list key val))))) 39 39 40 (define (config:eval-string-in-environment str) 40 (define (config:eval-string-in-environment str) 41 (let ((cmdres (cmd-run->list (conc "echo " str)))) 41 (let ((cmdres (cmd-run->list (conc "echo " str)))) 42 (if (null? cmdres) "" 42 (if (null? cmdres) "" 43 (caar cmdres)))) 43 (caar cmdres)))) 44 44 > 45 ;;====================================================================== > 46 ;; Make the regexp's needed globally available > 47 ;;====================================================================== > 48 > 49 (define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) > 50 (define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) > 51 (define configf:blank-l-rx (regexp "^\\s*$")) > 52 (define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) > 53 (define configf:key-val-pr (regexp "^(\\S+)\\s+(.*)$")) > 54 (define configf:comment-rx (regexp "^\\s*#.*")) > 55 (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) > 56 45 ;; read a config file, returns hash table of alists 57 ;; read a config file, returns hash table of alists 46 ;; adds to ht if given (must be #f otherwise) 58 ;; adds to ht if given (must be #f otherwise) 47 ;; envion-patt is a regex spec that identifies sections that will be eval'd 59 ;; envion-patt is a regex spec that identifies sections that will be eval'd 48 ;; in the environment on the fly 60 ;; in the environment on the fly 49 61 50 (define (read-config path ht allow-system #!key (environ-patt #f)) 62 (define (read-config path ht allow-system #!key (environ-patt #f)) 51 (debug:print 4 "INFO: read-config " path " allow-system " allow-system " envir 63 (debug:print 4 "INFO: read-config " path " allow-system " allow-system " envir 52 (if (not (file-exists? path)) 64 (if (not (file-exists? path)) 53 (if (not ht)(make-hash-table) ht) 65 (if (not ht)(make-hash-table) ht) 54 (let ((inp (open-input-file path)) 66 (let ((inp (open-input-file path)) 55 (res (if (not ht)(make-hash-table) ht)) | 67 (res (if (not ht)(make-hash-table) ht))) 56 (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) < 57 (section-rx (regexp "^\\[(.*)\\]\\s*$")) < 58 (blank-l-rx (regexp "^\\s*$")) < 59 (key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) < 60 (key-val-pr (regexp "^(\\S+)\\s+(.*)$")) < 61 (comment-rx (regexp "^\\s*#.*")) < 62 (cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))) < 63 (let loop ((inl (read-line inp)) 68 (let loop ((inl (read-line inp)) 64 (curr-section-name "default") 69 (curr-section-name "default") 65 (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn o 70 (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn o 66 (lead #f)) 71 (lead #f)) 67 (if (eof-object? inl) 72 (if (eof-object? inl) 68 (begin 73 (begin 69 (close-input-port inp) 74 (close-input-port inp) 70 res) 75 res) 71 (regex-case 76 (regex-case 72 inl 77 inl 73 (comment-rx _ (loop (read-line inp) curr-section | 78 (configf:comment-rx _ (loop (read-line inp) curr 74 (blank-l-rx _ (loop (read-line inp) curr-section | 79 (configf:blank-l-rx _ (loop (read-line inp) curr 75 (include-rx ( x include-file ) (begin | 80 (configf:include-rx ( x include-file ) (begin 76 (read-config include-file res al 81 (read-config include-file res al 77 (loop (read-line inp) curr-secti 82 (loop (read-line inp) curr-secti 78 (section-rx ( x section-name ) (loop (read-line inp) section-name | 83 (configf:section-rx ( x section-name ) (loop (read-line inp) sect 79 (key-sys-pr ( x key cmd ) (if allow-system | 84 (configf:key-sys-pr ( x key cmd ) (if allow-system 80 (let ((alist (hash-table-ref/d 85 (let ((alist (hash-table-ref/d 81 (val-proc (lambda () 86 (val-proc (lambda () 82 (let* ((cmdr 87 (let* ((cmdr 83 (stat 88 (stat 84 (res 89 (res 85 (if (not ( 90 (if (not ( 86 (begin 91 (begin ................................................................................................................................................................................ 93 (config:ass 98 (config:ass 94 99 95 100 96 101 97 102 98 (loop (read-line inp) curr-s 103 (loop (read-line inp) curr-s 99 (loop (read-line inp) curr-sec 104 (loop (read-line inp) curr-sec 100 (key-val-pr ( x key val ) (let* ((alist (hash-table-ref/de | 105 (configf:key-val-pr ( x key val ) (let* ((alist (hash-tabl 101 (envar (and environ-patt 106 (envar (and environ-patt 102 (realval (if envar 107 (realval (if envar 103 (config:eval-st 108 (config:eval-st 104 val))) 109 val))) 105 (if envar 110 (if envar 106 (begin 111 (begin 107 (debug:print 4 "INFO: read 112 (debug:print 4 "INFO: read 108 (setenv key realval))) 113 (setenv key realval))) 109 (hash-table-set! res curr-sectio 114 (hash-table-set! res curr-sectio 110 (config:assoc-s 115 (config:assoc-s 111 (loop (read-line inp) curr-secti 116 (loop (read-line inp) curr-secti 112 ;; if a continued line 117 ;; if a continued line 113 (cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/defau | 118 (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-r 114 (if var-flag ;; if s 119 (if var-flag ;; if s 115 (let ((newval (conc 120 (let ((newval (conc 116 (config-looku 121 (config-looku 117 ;; trim lead 122 ;; trim lead 118 (if lead 123 (if lead 119 (string-s 124 (string-s 120 "") 125 "") ................................................................................................................................................................................ 172 (tal (cdr fdat)) 177 (tal (cdr fdat)) 173 (cur "") 178 (cur "") 174 (led #f) 179 (led #f) 175 (res '())) 180 (res '())) 176 ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!! 181 ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!! 177 ;; 1. remove led whitespace 182 ;; 1. remove led whitespace 178 ;; 2. tack on to hed with "\n" 183 ;; 2. tack on to hed with "\n" 179 (let ((match (string-match cont-ln-rx hed))) | 184 (let ((match (string-match configf:cont-ln-rx hed))) 180 (if match ;; blast! have to deal with a multiline 185 (if match ;; blast! have to deal with a multiline 181 (let* ((lead (cadr match)) 186 (let* ((lead (cadr match)) 182 (lval (caddr match)) 187 (lval (caddr match)) 183 (newl (conc cur "\n" lval))) 188 (newl (conc cur "\n" lval))) 184 (if (not led)(set! led lead)) 189 (if (not led)(set! led lead)) 185 (if (null? tal) 190 (if (null? tal) 186 (set! fdat (append fdat (list newl))) 191 (set! fdat (append fdat (list newl))) ................................................................................................................................................................................ 189 (append res (list cur hed)) 194 (append res (list cur hed)) 190 (append res (list hed))))) 195 (append res (list hed))))) 191 ;; prev was a multiline 196 ;; prev was a multiline 192 (if (null? tal) 197 (if (null? tal) 193 newres 198 newres 194 (loop (car tal)(cdr tal) "" #f newres)))))))) 199 (loop (car tal)(cdr tal) "" #f newres)))))))) 195 200 > 201 ;; note: I'm cheating a little here. I merely replace "\n" with "\n " 196 (define (configf:expand-multi-lines fdat) 202 (define (configf:expand-multi-lines fdat) 197 ;; step 1.5 - compress any continued lines 203 ;; step 1.5 - compress any continued lines 198 (if (null? fdat) fdat 204 (if (null? fdat) fdat 199 (let loop ((hed (car fdat)) | 205 (let loop ((hed (car fdat)) 200 (tal (cdr fdat)) | 206 (tal (cdr fdat)) 201 (cur "") < 202 (led #f) < 203 (res '())) | 207 (res '())) 204 ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!! < 205 ;; 1. remove led whitespace < 206 ;; 2. tack on to hed with "\n" < 207 (let ((match (string-match cont-ln-rx hed))) < 208 (if match ;; blast! have to deal with a multiline < 209 (let* ((lead (cadr match)) < 210 (lval (caddr match)) < 211 (newl (conc cur "\n" lval))) < 212 (if (not led)(set! led lead)) < > 208 (let ((newres (append res (list (string-substitute (regexp "\n") "\n 213 (if (null? tal) | 209 (if (null? tal) 214 (set! fdat (append fdat (list newl))) < 215 (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacki < 216 (let ((newres (if led < 217 (append res (list cur hed)) < 218 (append res (list hed))))) < 219 ;; prev was a multiline < 220 (if (null? tal) < 221 newres | 210 newres 222 (loop (car tal)(cdr tal) "" #f newres)))))))) | 211 (loop (car tal)(cdr tal) newres)))))) 223 212 224 (define (configf:file->list fname) 213 (define (configf:file->list fname) 225 (if (file-exists? fname) 214 (if (file-exists? fname) 226 (let ((inp (open-input-file fname))) 215 (let ((inp (open-input-file fname))) 227 (let loop ((inl (read-line inp)) 216 (let loop ((inl (read-line inp)) 228 (res '())) 217 (res '())) 229 (if (eof-object? inl) 218 (if (eof-object? inl) ................................................................................................................................................................................ 240 ;; 2. Flatten any multiline entries 229 ;; 2. Flatten any multiline entries 241 ;; 3. Modify values per contents of "indat" and remove absent values 230 ;; 3. Modify values per contents of "indat" and remove absent values 242 ;; 4. Append new values to the section (immediately after last legit entry) 231 ;; 4. Append new values to the section (immediately after last legit entry) 243 ;; 5. Write out the new list 232 ;; 5. Write out the new list 244 ;;====================================================================== 233 ;;====================================================================== 245 234 246 (define (configf:write-config indat fname #!key (required-sections '())) 235 (define (configf:write-config indat fname #!key (required-sections '())) 247 (let* ((include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) < 248 (section-rx (regexp "^\\[(.*)\\]\\s*$")) < 249 (blank-l-rx (regexp "^\\s*$")) < 250 (key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) < 251 (key-val-pr (regexp "^(\\S+)\\s+(.*)$")) < 252 (comment-rx (regexp "^\\s*#.*")) < 253 (cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) < 254 ;; step 1: Open the output file and read it into a list | 236 (let* (;; step 1: Open the output file and read it into a list 255 (fdat (configf:file->list fname)) 237 (fdat (configf:file->list fname)) 256 (refdat (make-hash-table)) 238 (refdat (make-hash-table)) 257 (sechash (make-hash-table)) ;; current section hash, init with hash for 239 (sechash (make-hash-table)) ;; current section hash, init with hash for 258 (new #f)) ;; put the line to be used in new, if it is to be deleted | 240 (new #f) ;; put the line to be used in new, if it is to be deleted > 241 (secname #f)) 259 242 260 ;; step 2: Flatten multiline entries 243 ;; step 2: Flatten multiline entries 261 (if (not (null? fdat))(set! fdat (configf:compress-multi-line fdat))) 244 (if (not (null? fdat))(set! fdat (configf:compress-multi-line fdat))) 262 245 263 ;; step 3: Modify values per contents of "indat" and remove absent values 246 ;; step 3: Modify values per contents of "indat" and remove absent values 264 (if (not (null? fdat)) 247 (if (not (null? fdat)) 265 (let loop ((hed (car fdat)) 248 (let loop ((hed (car fdat)) 266 (tal (cadr fdat)) 249 (tal (cadr fdat)) 267 (res '()) 250 (res '()) 268 (sec #f) ;; section < 269 (lnum 0)) 251 (lnum 0)) 270 (regex-case 252 (regex-case 271 hed 253 hed 272 (comment-rx _ (set! res (append res (list hed)))) ;; | 254 (configf:comment-rx _ (set! res (append res (list he 273 (blank-l-rx _ (set! res (append res (list hed)))) ;; | 255 (configf:blank-l-rx _ (set! res (append res (list he 274 (section-rx ( x section-name ) (let ((section-hash (hash-table-ref/de | 256 (configf:section-rx ( x section-name ) (let ((section-hash (hash-tabl 275 (if (not section-hash) 257 (if (not section-hash) 276 (let ((newhash (make-hash-table) 258 (let ((newhash (make-hash-table) 277 (hash-table-set! refhash secti 259 (hash-table-set! refhash secti 278 (set! sechash newhash)) 260 (set! sechash newhash)) 279 (set! sechash section-hash)) 261 (set! sechash section-hash)) 280 (set! new hed) ;; will append this a 262 (set! new hed) ;; will append this a 281 (set! sec section-name) | 263 (set! secname section-name) 282 )) 264 )) 283 ;; No need to process key cmd, let it fall though to key val 265 ;; No need to process key cmd, let it fall though to key val 284 (key-val-pr ( x key val ) | 266 (configf:key-val-pr ( x key val ) 285 (let ((newval (config-lookup indat sec key))) 267 (let ((newval (config-lookup indat sec key))) 286 ;; can handle newval == #f here => that means key is re 268 ;; can handle newval == #f here => that means key is re 287 (cond 269 (cond 288 ((equal? newval val) 270 ((equal? newval val) 289 (set! res (append res (list hed)))) 271 (set! res (append res (list hed)))) 290 ((not newval) ;; key has been removed 272 ((not newval) ;; key has been removed 291 (set! new #f)) 273 (set! new #f))