;; Copyright 2006-2011, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on
;; lots of disparate data
;;
(module mutils
*
(import chicken scheme
;; data-structures posix
srfi-1
;; srfi-13
srfi-69
;; ports
extras
regex
posix
data-structures
)
(define (mutils:hierhash-ref hh . keys)
(if (null? keys)
#f
(let loop ((ht hh)
(key (car keys))
(tail (cdr keys)))
(if (null? tail)
(if (hash-table? ht)
(hash-table-ref/default ht key #f)
#f)
(if (hash-table? ht)
(loop (hash-table-ref/default ht key #f)
(car tail)
(cdr tail))
#f)))))
;; WATCH THE NON-INTUITIVE INTERFACE HERE!!!!
;; val comes first!
;;
(define (mutils:hierhash-set! hh val . keys)
(if (null? keys)
#f
(let loop ((ht hh)
(key (car keys))
(tail (cdr keys)))
(if (null? tail) ;; last one!
(hash-table-set! ht key val)
(let ((nh (hash-table-ref/default ht key #f)))
(if (not nh)(set! nh (make-hash-table)))
(hash-table-set! ht key nh)
(loop nh
(car tail)
(cdr tail)))))))
;; nice little routine to add an item to a list in a hashtable
;;
(define (mutils:hash-table-add-to-list htbl key item)
(let ((l (hash-table-ref/default htbl key #f)))
(if l
(hash-table-set! htbl key (cons item l))
(hash-table-set! htbl key (list item)))))
(define (mutils:hash-table-append-to-list htbl key lst)
(let ((l (hash-table-ref/default htbl key #f)))
(if l
(hash-table-set! htbl key (append lst l))
(hash-table-set! htbl key lst))))
;;======================================================================
;; Utils
;;======================================================================
(define (mutils:file->list fname)
(let ((fh (open-input-file fname))
(comment (regexp "^\\s*#"))
(blank (regexp "^\\s*$")))
(let loop ((l (read-line fh))
(res '()))
(if (eof-object? l)
(reverse res)
(if (or (string-match comment l)
(string-match blank l))
(loop (read-line fh) res)
(loop (read-line fh) (cons l res)))))))
(use sparse-vectors)
;; this is a simple two dimensional sparse array
;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!!
;;
(define (mutils:make-sparse-array)
(let ((a (make-sparse-vector)))
(sparse-vector-set! a 0 (make-sparse-vector))
a))
(define (mutils:sparse-array? a)
(and (sparse-vector? a)
(sparse-vector? (sparse-vector-ref a 0))))
(define (mutils:sparse-array-ref a x y)
(let ((row (sparse-vector-ref a x)))
(if row
(sparse-vector-ref row y)
#f)))
(define (mutils:sparse-array-set! a x y val)
(let ((row (sparse-vector-ref a x)))
(if row
(sparse-vector-set! row y val)
(let ((new-row (make-sparse-vector)))
(sparse-vector-set! a x new-row)
(sparse-vector-set! new-row y val)))))
;; some routines for treating assoc lists a bit like hash tables
(define (mutils:assoc-get/default alist key default)
(let ((res (assoc key alist)))
(if (and res (list? res)(> (length res) 1))
(cadr res)
default)))
(define (mutils:assoc-get alist key)
(cadr (assoc key alist)))
(define (mutils:hier-list? @hierlist)
(and (list? @hierlist)
(> (length @hierlist) 0)
(list? (car @hierlist))
(> (length (car @hierlist)) 1)))
(define (mutils:hier-list-get @hierlist . @path)
(if (list? @hierlist)
(let* (($path (car @path))
(@rempath (cdr @path))
(@match (assoc $path @hierlist)))
(if @match
(if (or (not (list? @rempath))(null? @rempath))
(cadr @match)
(apply mutils:hier-list-get (cadr @match) @rempath))
#f))
#f))
(define (mutils:hier-list-put! @hierlist . @path)
(let* (($path (car @path))
(@rempath (cdr @path))
($value (cadr @path))
(@match (assoc $path @hierlist))
(@remhierlist (remove (lambda (a)
(equal? a @match))
@hierlist))
(@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '())))
(@new-pair (list $path (if (eq? (length @rempath) 1)
(car @rempath)
(apply mutils:hier-list-put! @old-pair @rempath)))))
(cons @new-pair @remhierlist)))
(define (mutils:hier-list-remove! @hierlist . @path)
(let (($path (car @path)))
(if (eq? (length @path) 1)
(remove (lambda (a)
(equal? a (assoc $path @hierlist)))
@hierlist)
(let* ((@rempath (cdr @path))
(@match (assoc $path @hierlist))
(@remhierlist (remove (lambda (a)
(equal? @match a))
@hierlist))
(@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '())))
(@new-pair (list $path (apply mutils:hier-list-remove! @old-pair @rempath))))
(cons @new-pair @remhierlist)))))
(define (mutils:keys @hierlist . @path)
(map (lambda (@l)
(if (and (list? @l)(not (null? @l)))
(car @l)))
(if (null? @path) @hierlist
(apply mutils:hier-list-get @hierlist @path))))
;;======================================================================
;; Other utils
;;======================================================================
(define (check-write-create fpath)
(and (file-write-access? fpath)
(let ((fname (conc fpath "/.junk-" (current-seconds) "-" (random 10000))))
;;(print "trying to create/remove " fname)
(handle-exceptions
exn
#f
(begin
(with-output-to-file fname
(lambda ()
(print "You can delete this file")))
(delete-file fname)
#t)))))
;; do some sanity checks on the system
;;
(define (mutils:syscheck)
;; current dir writeable and do megatest.config, runconfigs.config files exist/readable
(print "Current directory " (current-directory) " writeable: "
(if (check-write-create ".") "yes" "no"))
;; home dir writeable
(print "Home directory " (get-environment-variable "HOME") " writeable: " (if (check-write-create (get-environment-variable "HOME")) "yes" "no"))
;; /tmp writeable
(print "/tmp directory writeable: " (if (check-write-create "/tmp") "yes" "no"))
;; load configs
;; each run disk read/write
;; link tree writeable
)
)