libgeda/scheme/unit-tests/t0402-config.scm

   1 ;; Test Scheme procedures for working with configuration.
   2
   3 (use-modules (unit-test)
   4              (geda os)
   5              (geda config)
   6              (srfi srfi-1))
   7
   8 (or (defined? 'define-syntax)
   9     (use-modules (ice-9 syncase)))
  10
  11 (define *testdir*      (string-append (getcwd)   file-name-separator-string "t0402-tmp"))
  12 (define *testdirconf*  (string-append *testdir*  file-name-separator-string "geda.conf"))
  13 (define *testdirA*     (string-append *testdir*  file-name-separator-string "A"))
  14 (define *testdirAconf* (string-append *testdirA* file-name-separator-string "geda.conf"))
  15 (define *testdirB*     (string-append *testdir*  file-name-separator-string "B"))
  16 (define *testdirBconf* (string-append *testdirB* file-name-separator-string "geda.conf"))
  17
  18 ;; Setup/teardown of directories / files needed by tests
  19 (define (config-test-setup)
  20   (config-test-teardown)
  21   (mkdir *testdir*)
  22   (mkdir *testdirA*)
  23   (mkdir *testdirB*)
  24   (with-output-to-file *testdirconf* newline)
  25   (with-output-to-file *testdirAconf* newline))
  26 (define (config-test-teardown)
  27   (system* "rm" "-rf" *testdir*))
  28
  29 (define-syntax begin-config-test
  30   (syntax-rules ()
  31     ((_ name . test-forms)
  32      (begin-test name
  33        (dynamic-wind
  34          config-test-setup
  35          (lambda () . test-forms)
  36          config-test-teardown)))))
  37
  38 (begin-test 'default-config-context
  39   (let ((cfg (default-config-context)))
  40     (assert-true (config? cfg))
  41     (assert-equal cfg (default-config-context))
  42     (assert-equal #f (config-filename cfg))
  43     (assert-equal #f (config-parent cfg))
  44     (assert-true (config-trusted? cfg))))
  45
  46 (begin-test 'system-config-context
  47   (let ((cfg (system-config-context)))
  48     (assert-true (config? cfg))
  49     (assert-equal cfg (system-config-context))
  50     (assert-equal (default-config-context) (config-parent cfg))
  51     (assert-true (config-trusted? cfg))))
  52
  53 (begin-test 'user-config-context
  54   (let ((cfg (user-config-context)))
  55     (assert-true (config? cfg))
  56     (assert-equal cfg (user-config-context))
  57     (assert-equal (system-config-context) (config-parent cfg))
  58     (assert-true (config-trusted? cfg))))
  59
  60 (begin-config-test 'path-config-context
  61   ;; Unfortunately, there's no reliable way of testing the "recurse
  62   ;; all the way to root and then give up" functionality, because we
  63   ;; can't control the contents of the superdirectories of the CWD.
  64   (assert-equal "/geda.conf"
  65                 (config-filename (path-config-context "/__missing/file/")))
  66   (let ((c (path-config-context *testdir*))
  67         (a (path-config-context *testdirA*))
  68         (b (path-config-context *testdirB*)))
  69
  70     (assert-true (config? a))
  71     (assert-true (config? b))
  72     (assert-true (config? c))
  73
  74     (assert-equal b c)
  75
  76     (assert-equal *testdirconf* (config-filename c))
  77     (assert-equal *testdirAconf* (config-filename a))
  78
  79     (assert-equal (user-config-context) (config-parent a))
  80     (assert-equal #f (config-trusted? a))))
  81
  82 (begin-config-test 'config-load
  83   (let ((a (path-config-context *testdirA*)))
  84     (assert-equal #f (config-loaded? a))
  85     (assert-equal a (config-load! a))
  86     (assert-true (config-loaded? a))
  87     (chmod *testdirAconf* #o000) ;; Make conf unreadable
  88     (assert-thrown 'system-error (config-load! a)))
  89
  90   (assert-thrown 'system-error (config-load! (default-config-context))))
  91
  92 (begin-config-test 'config-save
  93   (let ((a (path-config-context *testdirA*)))
  94     (assert-equal a (config-save! a)))
  95
  96   (assert-thrown 'system-error (config-save! (default-config-context)))
  97   ;; FIXME test writing a file without permissions to write it.
  98   )
  99
 100 (begin-config-test 'config-parent
 101   (let ((a (path-config-context *testdirA*))
 102         (b (path-config-context *testdir*)))
 103     (assert-equal (user-config-context) (config-parent a))
 104     (assert-equal (user-config-context) (config-parent b))
 105
 106     (assert-equal a (set-config-parent! a #f))
 107     (assert-equal #f (config-parent a))
 108
 109     (assert-equal a (set-config-parent! a b))
 110     (assert-equal b (config-parent a))
 111
 112     ;; Check that configuration values are inherited from parent
 113     (assert-thrown 'config-error (config-boolean a "foo" "bar"))
 114     (set-config! b "foo" "bar" #t)
 115     (assert-true (config-boolean a "foo" "bar"))
 116
 117     ;; Check that set-config-parent! refuses to form loops
 118     (assert-equal b (set-config-parent! b a))
 119     (assert-equal (user-config-context) (config-parent b))
 120
 121     (assert-equal a (set-config-parent! a (user-config-context)))
 122     (assert-equal (user-config-context) (config-parent a))
 123     ))
 124
 125 (begin-config-test 'config-trust
 126   (let ((a (path-config-context *testdirA*)))
 127     (assert-equal #f (config-trusted? a))
 128     (assert-equal (user-config-context) (config-parent a))
 129     (assert-true (config-trusted? (user-config-context)))
 130     (assert-equal (user-config-context) (config-trusted-context a))
 131
 132     (assert-equal a (set-config-trusted! a #t))
 133     (assert-true (config-trusted? a))
 134     (assert-equal a (config-trusted-context a))
 135
 136     (assert-equal a (set-config-trusted! a #f))
 137     (assert-equal #f (config-trusted? a))))
 138
 139 (begin-config-test 'config-changed
 140   (let ((a (path-config-context *testdirA*)))
 141     (config-load! a)
 142     (assert-equal #f (config-changed? a))
 143     (set-config! a "foo" "bar" #t)
 144     (assert-true (config-changed? a))
 145     (config-save! a)
 146     (assert-equal #f (config-changed? a))
 147     (set-config! a "foo" "bar" #f)
 148     (assert-true (config-changed? a))
 149     (config-load! a)
 150     (assert-equal #f (config-changed? a))))
 151
 152 (begin-config-test 'config-groups
 153   (let ((a (path-config-context *testdir*))
 154         (b (path-config-context *testdirA*)))
 155     (dynamic-wind
 156        (lambda () (set-config-parent! b a))
 157        (lambda ()
 158
 159          (config-load! a)
 160          (config-load! b)
 161
 162          (assert-equal '() (config-groups a))
 163          (assert-equal '() (config-groups b))
 164          (assert-equal #f (config-has-group? a "foo"))
 165          (assert-equal #f (config-has-group? b "foo"))
 166
 167          (set-config! a "foo" "bar" #t)
 168          (assert-equal '("foo") (config-groups a))
 169          (assert-equal '("foo") (config-groups b))
 170          (assert-true (config-has-group? a "foo"))
 171          (assert-true (config-has-group? b "foo"))
 172          (assert-equal #f (config-has-group? a "fizz"))
 173
 174          (set-config! b "fizz" "bam" #t)
 175          (assert-equal '("foo") (config-groups a))
 176          (assert-true (lset= string= '("fizz" "foo") (config-groups b)))
 177          (assert-equal #f (config-has-group? a "fizz"))
 178          (assert-true (config-has-group? b "fizz")) )
 179        (lambda () (set-config-parent! b (user-config-context))))))
 180
 181 (begin-config-test 'config-source
 182   (let ((a (path-config-context *testdir*))
 183         (b (path-config-context *testdirA*)))
 184     (config-load! a)
 185     (config-load! b)
 186
 187     (set-config! a "foo" "bar" #t)
 188     (assert-equal a (config-source a "foo" "bar"))
 189     (assert-thrown 'config-error (config-source b "foo" "bar"))
 190
 191     (dynamic-wind
 192         (lambda () (set-config-parent! b a))
 193         (lambda ()
 194           (assert-equal a (config-source a "foo" "bar"))
 195           (assert-equal a (config-source b "foo" "bar")) )
 196         (lambda () (set-config-parent! b (user-config-context))))
 197     ))
 198
 199 (begin-config-test 'config-keys
 200   (let ((a (path-config-context *testdir*))
 201         (b (path-config-context *testdirA*)))
 202     (dynamic-wind
 203        (lambda () (set-config-parent! b a))
 204        (lambda ()
 205          (set-config-parent! b a)
 206          (config-load! a)
 207          (config-load! b)
 208
 209          (assert-thrown 'config-error '() (config-keys a "foo"))
 210
 211          (set-config! a "foo" "bar" #t)
 212          (assert-equal '("bar") (config-keys a "foo"))
 213          (assert-equal '("bar") (config-keys b "foo"))
 214          (assert-true (config-has-key? a "foo" "bar"))
 215          (assert-true (config-has-key? b "foo" "bar"))
 216          (assert-equal #f (config-has-key? a "foo" "bam"))
 217
 218          (set-config! b "foo" "bam" #t)
 219          (assert-equal '("bar") (config-keys a "foo"))
 220          (assert-same-strings '("bam" "bar") (config-keys b "foo"))
 221          (assert-true (config-has-key? b "foo" "bam"))
 222          (assert-equal #f (config-has-key? a "foo" "bam")))
 223
 224        (lambda () (set-config-parent! b (user-config-context))))))
 225
 226 (begin-config-test 'config-boolean
 227   (let ((a (path-config-context *testdir*)))
 228     (config-load! a)
 229     (assert-equal a (set-config! a "foo" "bar" #t))
 230     (assert-equal #t (config-boolean a "foo" "bar"))
 231     (assert-equal a (set-config! a "foo" "bar" #f))
 232     (assert-equal #f (config-boolean a "foo" "bar"))
 233     (assert-equal '(#f) (config-boolean-list a "foo" "bar"))
 234
 235     (assert-equal a (set-config! a "foo" "bar" '(#t #f)))
 236     (assert-equal '(#t #f) (config-boolean-list a "foo" "bar"))))
 237
 238 (begin-config-test 'config-int
 239   (let ((a (path-config-context *testdir*)))
 240     (config-load! a)
 241     (assert-equal a (set-config! a "foo" "bar" 42))
 242     (assert-equal 42 (config-int a "foo" "bar"))
 243     (assert-equal '(42) (config-int-list a "foo" "bar"))
 244
 245     (assert-equal a (set-config! a "foo" "bar" '(42 144)))
 246     (assert-equal '(42 144) (config-int-list a "foo" "bar"))))
 247
 248 (begin-config-test 'config-real
 249   (let ((a (path-config-context *testdir*)))
 250     (config-load! a)
 251     (assert-equal a (set-config! a "foo" "bar" 42.0))
 252     (assert-equal 42.0 (config-real a "foo" "bar"))
 253     (assert-equal '(42.0) (config-real-list a "foo" "bar"))
 254
 255     (assert-equal a (set-config! a "foo" "bar" '(42.0 144.0)))
 256     (assert-equal '(42.0 144.0) (config-real-list a "foo" "bar"))))
 257
 258 (begin-config-test 'config-string
 259   (let ((a (path-config-context *testdir*)))
 260     (config-load! a)
 261     (assert-equal a (set-config! a "foo" "bar" "wibble"))
 262     (assert-equal "wibble" (config-string a "foo" "bar"))
 263     (assert-equal '("wibble") (config-string-list a "foo" "bar"))
 264
 265     (assert-equal a (set-config! a "foo" "bar" '("wib;ble" "wobble")))
 266     (assert-equal '("wib;ble" "wobble") (config-string-list a "foo" "bar"))))
 267
 268 (begin-config-test 'config-get-set-errors
 269   (let ((a (path-config-context *testdir*)))
 270     (config-load! a)
 271     (assert-thrown 'wrong-type-arg (set-config! a "foo" "bar" 'BAD-VALUE))
 272     (assert-thrown 'wrong-type-arg (set-config! a "foo" "bar" '(BAD-VALUE)))
 273     (assert-thrown 'wrong-type-arg (set-config! a "foo" "bar" '(1 "foo")))
 274
 275     (set-config! a "foo" "bar" "wibble")
 276     (assert-thrown 'config-error (config-boolean a "foo" "bar"))
 277     (assert-thrown 'config-error (config-int a "foo" "bar"))
 278     (assert-thrown 'config-error (config-real a "foo" "bar"))))
 279
 280 (begin-config-test 'config-events
 281   (let* ((a (path-config-context *testdir*))
 282          (call-count 0)
 283          (handler  (lambda (cfg group key)
 284                      (set! call-count (1+ call-count)))))
 285     (assert-equal a (add-config-event! a handler))
 286     (set-config! a "foo" "bar" #t)
 287     (assert-equal 1 call-count)
 288
 289     ;; Check that a handler can't be registered multiple times with
 290     ;; the same context.
 291     (assert-equal a (add-config-event! a handler))
 292     (set-config! a "foo" "bar" #t)
 293     (assert-equal 2 call-count)
 294
 295     ;; Handler removal
 296     (assert-equal a (remove-config-event! a handler))
 297     (set-config! a "foo" "bar" #t)
 298     (assert-equal 2 call-count)))