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

19
Makefile
View file

@ -44,23 +44,25 @@ BBSTOOL-DEPS=bbstool.scm testing.import.scm listing.import.scm \
member-record.import.scm configuration.import.scm \ member-record.import.scm configuration.import.scm \
progress.import.scm table.import.scm cards.import.scm \ progress.import.scm table.import.scm cards.import.scm \
member-parser.import.scm member-print.import.scm \ member-parser.import.scm member-print.import.scm \
member-fees.import.scm member-fees.import.scm members-dir.import.scm
BBSTOOL-SOURCES=bbstool.scm testing.scm listing.scm dictionary.scm \ BBSTOOL-SOURCES=bbstool.scm testing.scm listing.scm dictionary.scm \
month.scm period.scm ansi.scm command-line.scm \ month.scm period.scm ansi.scm command-line.scm \
members-base.scm utils.scm primes.scm member-record.scm \ members-base.scm utils.scm primes.scm member-record.scm \
configuration.scm progress.scm table.scm cards.scm \ configuration.scm progress.scm table.scm cards.scm \
member-print.scm member-parser.scm member-fees.scm member-print.scm member-parser.scm member-fees.scm \
members-dir.scm
BBSTOOL-OBJS=testing.o listing.o month.o period.o ansi.o dictionary.o \ BBSTOOL-OBJS=testing.o listing.o month.o period.o ansi.o dictionary.o \
command-line.o members-base.o utils.o primes.o \ command-line.o members-base.o utils.o primes.o \
member-record.o configuration.o progress.o table.o cards.o \ member-record.o configuration.o progress.o table.o cards.o \
member-print.o member-fees.o member-print.o member-fees.o members-dir.o
BBSTOOL-SHARED=testing.so listing.so month.so period.so ansi.so \ BBSTOOL-SHARED=testing.so listing.so month.so period.so ansi.so \
dictionary.so command-line.so members-base.so utils.so \ dictionary.so command-line.so members-base.so utils.so \
primes.so member-record.so configuration.so progress.so \ primes.so member-record.so configuration.so progress.so \
table.so cards.so member-print.so member-fees.so table.so cards.so member-print.so member-fees.so \
members-dir.so
.PHONY: imports .PHONY: imports
imports: $(BBSTOOL-DEPS) imports: $(BBSTOOL-DEPS)
@ -138,7 +140,8 @@ MEMBERS-BASE-SOURCES=members-base.scm testing.import.scm \
utils.import.scm dictionary.import.scm primes.import.scm \ utils.import.scm dictionary.import.scm primes.import.scm \
member-record.import.scm ansi.import.scm period.import.scm \ member-record.import.scm ansi.import.scm period.import.scm \
month.import.scm configuration.import.scm progress.import.scm \ month.import.scm configuration.import.scm progress.import.scm \
table.import.scm member-parser.import.scm table.import.scm member-parser.import.scm \
members-dir.import.scm
members-base.so: members-base.o members-base.so: members-base.o
members-base.o: members-base.import.scm members-base.o: members-base.import.scm
@ -214,3 +217,9 @@ MEMBER-FEES-SOURCES=member-fees.scm configuration.import.scm \
member-fees.so: member-fees.o member-fees.so: member-fees.o
member-fees.o: member-fees.import.scm member-fees.o: member-fees.import.scm
member-fees.import.scm: $(MEMBER-FEES-SOURCES) member-fees.import.scm: $(MEMBER-FEES-SOURCES)
MEMBERS-DIR-SOURCES=members-dir.scm
members-dir.so: members-dir.o
members-dir.o: members-dir.import.scm
members-dir.import.scm: $(MEMBERS-DIR-SOURCES)

124
members-base.scm
View file

@ -66,98 +66,9 @@
month month
configuration configuration
progress 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 ;; Returns a dictionary containing file-name, symlinks, id and info
;; keys. The info key contains whatever load-member-file from the ;; keys. The info key contains whatever load-member-file from the
;; member-file module returns. The id key contains whatever is the ;; member-file module returns. The id key contains whatever is the
@ -176,9 +87,7 @@
(car opts)))) (car opts))))
(with-progress (with-progress
progress? "Loading-members " " ok." progress? "Loading-members " " ok."
(let* ((fss (files-dictionary-filter-4digit-symbols (let* ((fss (get-files+symlinks-dictionary dn))
(files+symlinks->files-dictionary
(get-files+symlinks dn))))
(mb0 (dict-map (mb0 (dict-map
(lambda (symfn symlinks) (lambda (symfn symlinks)
(when progress? (when progress?
@ -440,31 +349,4 @@
(vfids (list->vector fids))) (vfids (list->vector fids)))
(vector-ref vfids (pseudo-random-integer (vector-length vfids))))) (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|)
))
) )

162
members-dir.scm Normal file
View file

@ -0,0 +1,162 @@
;;
;; members-dir.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-dir
(
load-members-dir
members-dir-tests
)
(import scheme)
;; 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))
;; Loads the members directory as dictionary of files to symlinks
;; mapping.
(define (load-members-dir dn)
(files-dictionary-filter-4digit-symbols
(files+symlinks->files-dictionary
(get-files+symlinks dn))))
;; Performs self-tests of this module.
(define (members-dir-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|)
))
)