Overview
| Comment: | Added alternative items specification via files, sxml, slash and space |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.65 |
| Files: | files | file ages | folders |
| SHA1: |
b98ca9757c87cf8b481c0e7851b1bfa7 |
| User & Date: | matt on 2020-07-26 22:57:19 |
| Other Links: | branch diff | manifest | tags |
Context
|
2020-07-27
| ||
| 16:45 | Added info on items file support check-in: cb1f6252e1 user: mrwellan tags: v1.65 | |
|
2020-07-26
| ||
| 22:57 | Added alternative items specification via files, sxml, slash and space check-in: b98ca9757c user: matt tags: v1.65 | |
|
2020-07-24
| ||
| 17:06 | Speculative fixes/defense against couple crashes check-in: b46cb6aa87 user: mrwellan tags: v1.65, v1.6556 | |
Changes
Modified items.scm from [fd1d57a170] to [16328a4b96].
| ︙ | ︙ | |||
121 122 123 124 125 126 127 128 129 |
(define (items:check-valid-items class item)
(let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
(if s (string-split s) #f))))
(if valid-values
(if (member item valid-values)
item #f)
item)))
(define (items:get-items-from-config tconfig)
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > | > > > | 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
(define (items:check-valid-items class item)
(let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
(if s (string-split s) #f))))
(if valid-values
(if (member item valid-values)
item #f)
item)))
;; '(("k1" "k2" "k3")
;; ("a" "b" "c")
;; ("d" "e" "f"))
;;
;; => '((("k1" "a")("k2" "b")("k3" "c"))
;; (("k1" "d")("k2" "e")("k3" "f")))
;;
(define (items:first-row-intersperse data)
(if (< (length data) 2)
'()
(let ((header (car data))
(rows (cdr data)))
(map (lambda (row)
(map list header row))
rows))))
;; k1/k2/k3
;; a/b/c
;; d/e/f
;; => '(("k1" "k2" "k3")
;; ("a" "b" "c")
;; ("d" "e" "f"))
;;
;; => '((("k1" "a")("k2" "b")("k3" "c"))
;; (("k1" "d")("k2" "e")("k3" "f")))
;;
(define (items:read-items-file fname ftype) ;; 'sxml 'slash 'space
(if (and fname (file-exists? fname))
(items:first-row-intersperse (case ftype
((slash space)
(let ((splitter (case ftype
((slash) (lambda (x)(string-split x "/")))
(else string-split))))
(debug:print 0 *default-log-port* "Reading " fname " of type " ftype)
(with-input-from-file fname
(lambda ()
(let loop ((inl (read-line))
(res '()))
(if (eof-object? inl)
res
(loop (read-line)(cons (splitter inl) res))))))))
((sxml)(with-input-from-file fname read))
(else (debug:print 0 *default-log-port* "items file type " ftype " not recognised"))))
(begin
(if fname (debug:print 0 *default-log-port* "no items file " fname " found"))
'())))
(define (items:get-items-from-config tconfig)
(let* ((slashf (configf:lookup tconfig "itemopts" "slash")) ;; a/b/c\nd/e/f\n ...
(sxmlf (configf:lookup tconfig "itemopts" "sxml")) ;; '(("a" "b" "c")("d" "e" "f") ...)
(spacef (configf:lookup tconfig "itemopts" "space")) ;; a b c\nd e f\n ...
(have-items (hash-table-ref/default tconfig "items" #f))
(have-itable (hash-table-ref/default tconfig "itemstable" #f))
(items (hash-table-ref/default tconfig "items" '()))
(itemstable (hash-table-ref/default tconfig "itemstable" '())))
(debug:print 5 *default-log-port* "items: " items " itemstable: " itemstable)
(set! items (map (lambda (item)
(if (procedure? (cadr item))
(list (car item)((cadr item))) ;; evaluate the proc
item))
items))
(set! itemstable (map (lambda (item)
(if (procedure? (cadr item))
(list (car item)((cadr item))) ;; evaluate the proc
item))
itemstable))
(if (and have-items (null? items)) (debug:print 0 *default-log-port* "WARNING:[items] section in testconfig but no entries defined"))
(if (and have-itable (null? itemstable))(debug:print 0 *default-log-port* "WARNNG:[itemstable] section in testconfig but no entries defined"))
(if (or (not (null? items))
(not (null? itemstable))
slashf
sxmlf
spacef)
(append (item-assoc->item-list items)
(item-table->item-list itemstable)
(items:read-items-file slashf 'slash)
(items:read-items-file sxmlf 'sxml)
(items:read-items-file spacef 'space))
'(()))))
;; (pp (item-assoc->item-list itemdat))
|