brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Start splitting members-dir.

Browse source
This commit is contained in:
Dominik Pantůček 2023-03-29 20:15:48 +02:00
parent 817a1c8422
commit 3693b9860d
3 changed files with 179 additions and 126 deletions
Download patch file Download diff file Expand all files Collapse all files

124
members-base.scm
View file

@ -66,98 +66,9 @@
month
configuration
progress
table)
table
members-dir)
;; 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))))))))
;; Checks whether given string is a 4-digit decimal number.
(define (is-4digit-string? s)
(if (irregex-search (irregex "^[0-9]{4}$") s)
#t
#f))
;; checks whether given symbol is a 4-digit one.
(define (is-4digit-symbol? s)
(is-4digit-string?
(symbol->string s)))
;; Returns true if the list contains at least one 4-digit symbol.
(define (list-contains-4digit-symbol? lst)
(let loop ((lst lst))
(if (null? lst)
#f
(if (is-4digit-symbol? (car lst))
#t
(loop (cdr lst))))))
;; Returns the first 4-digit symbol from the list.
(define (get-4digit-symbol-from-list lst)
(let loop ((lst lst))
(if (null? lst)
#f
(if (is-4digit-symbol? (car lst))
(car lst)
(loop (cdr lst))))))
;; Returns dictionary containing only records with either 4-digit
;; name or one of its aliases being 4-digit.
(define (files-dictionary-filter-4digit-symbols d)
(dict-filter
(lambda (k v)
(list-contains-4digit-symbol? (cons k v)))
d))
;; Returns a dictionary containing file-name, symlinks, id and info
;; keys. The info key contains whatever load-member-file from the
;; member-file module returns. The id key contains whatever is the
@ -176,9 +87,7 @@
(car opts))))
(with-progress
progress? "Loading-members " " ok."
(let* ((fss (files-dictionary-filter-4digit-symbols
(files+symlinks->files-dictionary
(get-files+symlinks dn))))
(let* ((fss (get-files+symlinks-dictionary dn))
(mb0 (dict-map
(lambda (symfn symlinks)
(when progress?
@ -440,31 +349,4 @@
(vfids (list->vector fids)))
(vector-ref vfids (pseudo-random-integer (vector-length vfids)))))
;; Performs self-tests of this module.
(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)))
(test-true is-4digit-string? (is-4digit-string? "0000"))
(test-false is-4digit-string? (is-4digit-string? "AAAA"))
(test-false is-4digit-string? (is-4digit-string? "666"))
(test-true is-4digit-symbol? (is-4digit-symbol? '|0000|))
(test-false is-4digit-symbol? (is-4digit-symbol? '|ABC|))
(test-true list-contains-4digit-symbol? (list-contains-4digit-symbol? '(|0000| abc |666|)))
(test-false list-contains-4digit-symbol? (list-contains-4digit-symbol? '(|00000| abc |666|)))
(test-eq? get-4digit-symbol-from-list
(get-4digit-symbol-from-list '(|000| abc |6666| qwer))
'|6666|)
))
)