223 lines
9.5 KiB
Racket
223 lines
9.5 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/string)
|
|
(require racket/file)
|
|
(require racket/port)
|
|
(require racket/serialize)
|
|
|
|
(provide file->ini
|
|
ini->file
|
|
ini-get
|
|
ini-set!
|
|
make-ini
|
|
get-ini-file
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Supporting functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-struct ini-cfg
|
|
(contents #:mutable #t)
|
|
)
|
|
|
|
(define (output-value v out)
|
|
(cond
|
|
((string? v)
|
|
(if (regexp-match? #rx"[\r\n]" v)
|
|
(begin
|
|
(display "VALUE:" out)
|
|
(write v out))
|
|
(display v out)))
|
|
((path? v)
|
|
(display (format "PATH:~a" v) out))
|
|
((number? v)
|
|
(display v out))
|
|
((boolean? v)
|
|
(display (if v "true" "false") out))
|
|
(else
|
|
(display"SER:" out)
|
|
(write (serialize v) out))
|
|
)
|
|
)
|
|
|
|
(define (section=? sect inp-sect)
|
|
(string-ci=? (format "~a" sect) (format "~a" inp-sect)))
|
|
|
|
(define (key=? key inp-key)
|
|
(section=? key inp-key))
|
|
|
|
|
|
(define re-num #px"^([+]|[-])?([0-9]+([.]([0-9]+))?)$")
|
|
(define re-bool #px"^(#f|#t|true|false)$")
|
|
(define re-value #px"^VALUE:(.*)$")
|
|
(define re-serialize #px"^SER:(.*)$")
|
|
(define re-path #px"^PATH:(.*)$")
|
|
|
|
(define (interpret s)
|
|
(let ((sr (regexp-match re-serialize s)))
|
|
(if (eq? sr #f)
|
|
(let ((m (regexp-match re-value s)))
|
|
(if (eq? m #f)
|
|
(let ((p (regexp-match re-path s)))
|
|
(if (eq? p #f)
|
|
(let ((ss (string-downcase (string-trim s))))
|
|
(let ((m-num (regexp-match re-num ss)))
|
|
(if (eq? m-num #f)
|
|
(let ((m-b (regexp-match re-bool ss)))
|
|
(if (eq? m-b #f)
|
|
s
|
|
(if (or (string=? ss "#t") (string=? ss "true"))
|
|
#t
|
|
#f)
|
|
))
|
|
(string->number (car m-num)))))
|
|
(string->path (cadr p))))
|
|
(let* ((content (cadr m)))
|
|
(with-handlers ([exn? (λ (e) content)])
|
|
(with-input-from-string content read)))))
|
|
(let ((content (cadr sr)))
|
|
(deserialize (with-input-from-string content read))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Public API
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (get-ini-file f)
|
|
(if (symbol? f)
|
|
(let* ((pref-dir (find-system-path 'pref-dir)))
|
|
(build-path pref-dir (string-append (symbol->string f) ".ini")))
|
|
(build-path f)))
|
|
|
|
|
|
(define (ini->file ini file #:private? [private? #f])
|
|
(let* ((file (get-ini-file file))
|
|
(_ (make-parent-directory* file))
|
|
(out (if (and private?
|
|
(memq (system-type 'os) '(unix macosx)))
|
|
(open-output-file file
|
|
#:exists 'replace
|
|
#:permissions #o600
|
|
#:replace-permissions? #t)
|
|
(open-output-file file #:exists 'replace))))
|
|
(let ((last-is-newline #f))
|
|
(for-each (lambda (section)
|
|
(let ((section-name (car section)))
|
|
(if (section=? section-name 'nil)
|
|
#t
|
|
(begin
|
|
(unless last-is-newline (newline out))
|
|
(display "[" out)
|
|
(display section-name out)
|
|
(display "]" out)
|
|
(newline out)))
|
|
(let ((lines (cdr section)))
|
|
(for-each (lambda (line)
|
|
(if (eq? (car line) 'comment)
|
|
(begin
|
|
(set! last-is-newline #f)
|
|
(display "; " out)
|
|
(display (cadr line) out)
|
|
(newline out))
|
|
(if (eq? (car line) 'empty)
|
|
(begin
|
|
(newline out)
|
|
(set! last-is-newline #t))
|
|
(if (eq? (car line) 'keyval)
|
|
(begin
|
|
(set! last-is-newline #f)
|
|
(display (cadr line) out)
|
|
(display "=" out)
|
|
(output-value (caddr line) out)
|
|
(newline out))
|
|
(error "Unknown line format")))))
|
|
lines))))
|
|
(mcdr ini)))
|
|
(close-output-port out)))
|
|
|
|
(define (make-ini)
|
|
(mcons 'ini (list)))
|
|
|
|
(define (file->ini file*)
|
|
(let* ((file (get-ini-file file*))
|
|
(lines (if (file-exists? file) (file->lines file) '()))
|
|
(re-section #px"^\\[([a-zA-Z0-9_.-]+)\\]$")
|
|
(re-keyval #px"^([a-zA-Z0-9_.-]+)[=](.*)$")
|
|
(re-comment #px"^[;](.*)$")
|
|
(line-nr 0))
|
|
(letrec ((f (lambda (sections section lines)
|
|
(if (null? lines)
|
|
(append sections (list section))
|
|
(let* ((line (string-trim (car lines)))
|
|
(empty (string=? line ""))
|
|
(m-comment (regexp-match re-comment line))
|
|
(m-keyval (regexp-match re-keyval line))
|
|
(m-section (regexp-match re-section line)))
|
|
(set! line-nr (+ 1 line-nr))
|
|
(if empty
|
|
(f sections (append section (list (list 'empty))) (cdr lines))
|
|
(if m-comment
|
|
(f sections (append section (list (list 'comment (cadr m-comment)))) (cdr lines))
|
|
(if m-keyval
|
|
(f sections (append section
|
|
(list
|
|
(list 'keyval (string->symbol
|
|
(string-trim (string-downcase
|
|
(cadr m-keyval))))
|
|
(interpret (string-trim (caddr m-keyval)))))) (cdr lines))
|
|
(if m-section
|
|
(f (append sections (list section)) (list (string->symbol (string-trim (cadr m-section)))) (cdr lines))
|
|
(error (format "Unknown INI line\n~a: ~a\n" line-nr line)))))))))))
|
|
(mcons 'ini (f '() (list 'nil) lines)))))
|
|
|
|
(define (ini-get ini section key def-val)
|
|
(letrec ((g (lambda (ini)
|
|
(if (null? ini)
|
|
def-val
|
|
(if (section=? section (caar ini))
|
|
(letrec ((f (lambda (l)
|
|
(if (null? l)
|
|
def-val
|
|
(let ((entry (car l)))
|
|
(if (eq? (car entry) 'keyval)
|
|
(if (key=? (cadr entry) key)
|
|
(caddr entry)
|
|
(f (cdr l)))
|
|
(f (cdr l))))))))
|
|
(f (cdar ini)))
|
|
(g (cdr ini)))))))
|
|
(g (mcdr ini))))
|
|
|
|
(define (ini-set! ini section key val)
|
|
(let ((found #f))
|
|
(letrec ((for-sect (lambda (sect)
|
|
(if (null? sect)
|
|
(if found
|
|
'()
|
|
(begin
|
|
(set! found #t)
|
|
(list (list 'keyval key val))))
|
|
(let ((entry (car sect)))
|
|
(if (eq? (car entry) 'keyval)
|
|
(if (key=? (cadr entry) key)
|
|
(begin
|
|
(set! found #t)
|
|
(cons (list 'keyval key val) (for-sect (cdr sect))))
|
|
(cons entry (for-sect (cdr sect))))
|
|
(cons entry (for-sect (cdr sect)))))))))
|
|
(letrec ((for-ini (lambda (ini)
|
|
(if (null? ini)
|
|
(if found
|
|
'()
|
|
(list (list section (list 'keyval key val))))
|
|
(let* ((ini-section (car ini))
|
|
(section-key (car ini-section)))
|
|
(if (section=? section-key section)
|
|
(cons (cons section (for-sect (cdr ini-section))) (for-ini (cdr ini)))
|
|
(cons ini-section (for-ini (cdr ini)))))))))
|
|
(let ((new-ini (for-ini (mcdr ini))))
|
|
(set-mcdr! ini new-ini)
|
|
ini)))))
|
|
|
|
|