diff --git a/Makefile b/Makefile index 5bb7aa2..6c39ce4 100644 --- a/Makefile +++ b/Makefile @@ -44,23 +44,25 @@ BBSTOOL-DEPS=bbstool.scm testing.import.scm listing.import.scm \ member-record.import.scm configuration.import.scm \ progress.import.scm table.import.scm cards.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 \ month.scm period.scm ansi.scm command-line.scm \ members-base.scm utils.scm primes.scm member-record.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 \ command-line.o members-base.o utils.o primes.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 \ dictionary.so command-line.so members-base.so utils.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 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 \ member-record.import.scm ansi.import.scm period.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.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.o: member-fees.import.scm 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) diff --git a/members-base.scm b/members-base.scm index 47514ab..697a07d 100644 --- a/members-base.scm +++ b/members-base.scm @@ -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|) - )) - ) diff --git a/members-dir.scm b/members-dir.scm new file mode 100644 index 0000000..a59f7f9 --- /dev/null +++ b/members-dir.scm @@ -0,0 +1,162 @@ +;; +;; members-dir.scm +;; +;; Storage for member files. +;; +;; ISC License +;; +;; Copyright 2023 Brmlab, z.s. +;; Dominik Pantůček +;; +;; 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|) + )) + + )