122 lines
3.4 KiB
Scheme
122 lines
3.4 KiB
Scheme
;;
|
|
;; members-base.scm
|
|
;;
|
|
;; Storage for member files.
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023 Brmlab, z.s.
|
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; Permission to use, copy, modify, and/or distribute this software
|
|
;; for any purpose with or without fee is hereby granted, provided
|
|
;; that the above copyright notice and this permission notice appear
|
|
;; in all copies.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
;;
|
|
|
|
(declare (unit members-base))
|
|
|
|
(module
|
|
members-base
|
|
(
|
|
load-members
|
|
members-base-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken pathname)
|
|
(chicken file posix)
|
|
(chicken file)
|
|
(chicken format)
|
|
testing
|
|
utils
|
|
dictionary)
|
|
|
|
;; Gets all files and symbolic links from given directory. The
|
|
;; symbolic links are represented by cons cells with car being the
|
|
;; name and cdr the link target.
|
|
(define (get-files+symlinks dn)
|
|
(let loop ((fns (directory dn))
|
|
(rs '()))
|
|
(if (null? fns)
|
|
rs
|
|
(let* ((fn (car fns))
|
|
(ffn (make-pathname dn fn)))
|
|
(loop (cdr fns)
|
|
(if (symbolic-link? ffn)
|
|
(cons (cons (string->symbol fn)
|
|
(string->symbol (read-symbolic-link ffn)))
|
|
rs)
|
|
(if (regular-file? ffn)
|
|
(cons (string->symbol fn) rs)
|
|
rs)))))))
|
|
|
|
;; Converts a list of symlinks and files in aforementioned format
|
|
;; into a dictionary of regular files as keys with lists of symlinks
|
|
;; as values. If the target file does not exist, adds 'error-0 symbol
|
|
;; as the first alias to this list with the number increasing with
|
|
;; each nonexistent file encountered. The error record is also
|
|
;; generated for symlinks pointing outside of the directory.
|
|
(define (files+symlinks->files-dictionary ls)
|
|
(let* ((links (filter pair? ls))
|
|
(files (filter symbol? ls))
|
|
(fdict
|
|
(let loop ((files files)
|
|
(res (make-dict)))
|
|
(if (null? files)
|
|
res
|
|
(loop (cdr files)
|
|
(dict-set res (car files) '()))))))
|
|
(let loop ((links links)
|
|
(res fdict)
|
|
(errs 0))
|
|
(if (null? links)
|
|
res
|
|
(let* ((link (car links))
|
|
(name (car link))
|
|
(target (cdr link)))
|
|
(if (dict-has-key? res target)
|
|
(loop (cdr links)
|
|
(dict-set res target (cons name (dict-ref res target)))
|
|
errs)
|
|
(loop (cdr links)
|
|
(dict-set res target
|
|
(list (string->symbol (sprintf "error-~A" errs))
|
|
name))
|
|
(+ errs 1))))))))
|
|
|
|
(define (load-members dn)
|
|
;; get the directory contents
|
|
(print (files+symlinks->files-dictionary (get-files+symlinks dn)))
|
|
;; filter all ids
|
|
;; resolve links (it might be unknown!)
|
|
;; load member files
|
|
1)
|
|
|
|
(define (members-base-tests!)
|
|
(run-tests
|
|
members-base
|
|
(test-equal? files+symlinks->files-dictionary
|
|
(files+symlinks->files-dictionary
|
|
'(joe (2803 . joe)))
|
|
'((joe 2803)))
|
|
(test-equal? files+symlinks->files-dictionary
|
|
(files+symlinks->files-dictionary
|
|
'(joe
|
|
(2803 . joe)
|
|
(666 . nonexistent)))
|
|
'((nonexistent error-0 666)
|
|
(joe 2803)))
|
|
))
|
|
|
|
)
|