|
- ;;; Database module, serializing kv stores associated with symbols
- ;;; to and from s-expressions on file.
-
- (module database (database-set database-get database-save *database* database-load database-remove get-all-objects object-exists? has-property? toggle-flag database-null)
- (import scheme)
- (import chicken.io)
- (import util)
-
- ;; The global database.
- (define *database* '())
-
- ;; This has to exist and be exported in order for the test suite
- ;; not to trigger warnings.
- (define (database-null)
- (set! *database* '()))
-
- ;; Set KEY associated with symbol NAME to VALUE.
- (define (database-set name key value)
- (set! *database* (let loop ((kv *database*))
- (if (null? kv)
- (list (cons name (list (cons key value))))
- (if (equal? name (caar kv))
- (cons (cons name (let loop ((kv (cdar kv)))
- (if (null? kv)
- (list (cons key value))
- (if (equal? key (caar kv))
- (cons (cons key value) (cdr kv))
- (cons (car kv) (loop (cdr kv))))))) (cdr kv))
- (cons (car kv) (loop (cdr kv))))))))
-
- ;; Get KEY associated with symbol NAME, returning DEFAULT if it doesn't exist.
- (define (database-get name key default)
- (let loop ((kv *database*))
- (if (null? kv)
- default
- (if (equal? name (caar kv))
- (let loop ((kv (cdar kv)))
- (if (null? kv)
- default
- (if (equal? key (caar kv))
- (cdar kv)
- (loop (cdr kv)))))
- (loop (cdr kv))))))
-
- ;; Save database to a file, in s-expression format.
- (define (database-save filename)
- (with-output-to-file filename (thunk (write *database*))))
-
- ;; Load database from a file.
- (define (database-load filename)
- (with-input-from-file filename (thunk (set! *database* (car (read-list))))))
-
- ;; Remove all associations from symbol NAME from database.
- (define (database-remove name)
- (set! *database* (let loop ((kv *database*))
- (if (null? kv)
- '()
- (if (equal? name (caar kv))
- (cdr kv)
- (cons (car kv) (loop (cdr kv))))))))
-
- ;; Get a list of all symbols in the database.
- (define (get-all-objects)
- (map car *database*))
-
- ;; Does a symbol exist in the database, e.g. is there
- ;; a symbol that has values associated with it in the database?
- (define (object-exists? object)
- (list? (member object (get-all-objects))))
-
- ;; Is there a value PROPERTY associated with the symbol OBJECT?
- (define (has-property? object property)
- (let loop ((kv *database*))
- (if (null? kv)
- #f
- (if (eq? (caar kv) object)
- (let loop ((kv (cdar kv)))
- (if (null? kv)
- #f
- (if (eq? (caar kv) property)
- #t
- (loop (cdr kv)))))
- (loop (cdr kv))))))
-
- ;; If OBJECT has a value FLAG that is unset or false, set it to true.
- ;; Else set it to false.
- (define (toggle-flag object flag)
- (if (database-get object flag #f)
- (database-set object flag #f)
- (database-set object flag #t))))
|