From 342797575f2be4e3f8a69ed9ab79397f372e4a91 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 16 Mar 2023 19:53:54 +0100 Subject: [PATCH] Port last bits and pieces of orig tool. --- .gitignore | 1 + Makefile | 4 +- brmsaptool-orig.scm | 240 -------------------------------------------- brmsaptool.scm | 55 +++++++++- 4 files changed, 56 insertions(+), 244 deletions(-) delete mode 100644 brmsaptool-orig.scm diff --git a/.gitignore b/.gitignore index acf1d28..20988ae 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ brmsaptool *.link brmsaptool-static +*.c diff --git a/Makefile b/Makefile index ffdb8e8..66ebea0 100644 --- a/Makefile +++ b/Makefile @@ -24,7 +24,7 @@ # .PHONY: all -all: brmsaptool brmsaptool-static +all: brmsaptool CSC=csc @@ -54,7 +54,7 @@ brmsaptool-static: $(BRMSAPTOOL-OBJS) .PHONY: clean clean: - rm -f *.so *.link *.o *.import.scm brmsaptool brmsaptool-static + rm -f *.c *.so *.link *.o *.import.scm brmsaptool brmsaptool-static ################################################################ # Module static and shared object and import source compilation diff --git a/brmsaptool-orig.scm b/brmsaptool-orig.scm deleted file mode 100644 index edf10bf..0000000 --- a/brmsaptool-orig.scm +++ /dev/null @@ -1,240 +0,0 @@ -;; -;; brmsaptool.scm -;; -;; 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. -;; -(import (chicken condition) - (chicken file) - (chicken pathname) - (chicken file posix) - (chicken io) - (chicken string) - (chicken format) - (chicken sort) - (chicken time) - (chicken time posix) - (chicken process-context) - dictionary - month - period - member-file - command-line) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Static default configuration - -(define *members-directory* (make-parameter "members")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Members database - -;; Loads all symlinks from (*members-directory*) returning a list of -;; pairs (name . destination) -(define (load-members-raw-index) - (let loop ((fns (directory (*members-directory*))) - (rs '())) - (if (null? fns) - (let () - (display "-") - rs) - (let* ((fn (car fns)) - (ffn (make-pathname (*members-directory*) fn)) - (sl (if (symbolic-link? ffn) (read-symbolic-link ffn) #f))) - (loop (cdr fns) - (if sl - (cons (cons fn sl) rs) - rs)))))) - -;; Converts the raw members index to a list of dictionaries with keys -;; 'id, 'name and 'file. File names are without directory element. -(define (expand-members-raw-index ri) - (let loop ((ri ri) - (ds '())) - (if (null? ri) - (let () - (display "*") - ds) - (let* ((mp (car ri)) - (lnk (car mp)) - (dfn (cdr mp)) - (lnkn (string->number lnk)) - (dfnn (string->number dfn)) - (id (or dfnn lnkn)) - (name (if lnkn dfn lnk))) - (loop (cdr ri) - (cons (list (cons 'id id) - (cons 'name name) - (cons 'file dfn)) - ds)))))) - -;; Adds the 'info key to all expanded index entries by loading -;; appropriate 'file key file from the members directory. -(define (load-members-from-expanded-index ei) - (let loop ((ei ei) - (mdb '())) - (if (null? ei) - mdb - (let ((mi (car ei))) - (let ((mid (load-member-file - (make-pathname - (*members-directory*) - (dict-ref mi 'file))))) - (loop (cdr ei) - (cons (dict-set mi - 'info - mid) - mdb))))))) - -;; Loads all member information from given members database. -(define (load-members) - (load-members-from-expanded-index - (expand-members-raw-index - (load-members-raw-index)))) - -;; Gets member based by generic predicate -(define (find-member-by-predicate mdb pred) - (let loop ((mdb mdb)) - (if (null? mdb) - #f - (let ((mr (car mdb))) - (if (pred mr) - mr - (loop (cdr mdb))))))) - -;; Gets member record by member key -(define (find-member-by-key mdb key val) - (find-member-by-predicate - mdb - (lambda (mr) - (equal? (dict-ref mr key) val)))) - -;; Gets member record by member id (from file/symlink) -(define (find-member-by-id mdb id) - (find-member-by-key mdb 'id id)) - -;; Gets member record by member name (from file/symlink) -(define (find-member-by-name mdb name) - (find-member-by-key mdb 'name name)) - -;; Gets member record by member nick in member file the key 'nick -(define (find-member-by-nick mdb nick) - (find-member-by-predicate - mdb - (lambda (mr) - (equal? (dict-ref (dict-ref mr 'info) 'nick) nick)))) - -;; Returns the list of all members ids -(define (list-members-ids mdb) - (map (lambda (mr) (dict-ref mr 'id)) mdb)) - -;; Returns the list of all file names in members database -(define (list-members-names mdb) - (map (lambda (mr) (dict-ref mr 'name)) mdb)) - -;; Returns the list of all members nicks -(define (list-members-nicks mdb) - (map (lambda (mr) (dict-ref (dict-ref mr 'info) 'nick)) mdb)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Member predicates - -(define (member-suspended? mr) - #f) - -(define (member-student? mr) - #f) - -(define (member-destroyed? mr) - #f) - -;; Returns true if the member is neither suspended nor destroyed -(define (member-active? mr) - (not (or (member-suspended? mr) - (member-destroyed? mr)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Run everything - -(define action (make-parameter #f)) -(define member-parm (make-parameter #f)) - -;; Print banner -(print "brmsaptool 0.1 (c) 2023 Brmlab, z.s.") -(newline) - -;; Handle options -(command-line - print-help - (-h () "Help" - (print-help) - (exit 0)) - (-M (dn) "Members dir" (*members-directory* dn)) - (-mi (id) "Id" - (action 'member-by-id) - (member-parm (string->number id))) - (-mn (nick) "Nick" - (action 'member-by-nick) - (member-parm nick)) - ) - -;; Run tests -(print "Running self-tests:") -(dictionary-tests!) -(month-tests!) -(period-tests!) -(print "All self-tests ok!") -(newline) - -;; Load the members database -(display "Loading members ") -(define MDB (load-members)) -(print " ok.") -(print "Members in database: " (length MDB)) -(newline) - -;; Perform requested action -(case (action) - ((member-by-id member-by-nick) - (let ((mr (if (eq? (action) 'member-by-id) - (find-member-by-id MDB (member-parm)) - (find-member-by-nick MDB (member-parm))))) - (if mr - (let* ((id (dict-ref mr 'id)) - (name (dict-ref mr 'name)) - (info (dict-ref mr 'info)) - (sinfo (sort info - (lambda (a b) - (stringstring (car a)) - (symbol->string (car b))))))) - (print "User " id " alias " name) - (let loop ((sinfo sinfo)) - (when (not (null? sinfo)) - (let* ((kv (car sinfo)) - (k (car kv)) - (v (cdr kv))) - (print " " k ":\t" - (if (member k '(student suspend)) - (periods->string v) - v)) - (loop (cdr sinfo)))))) - (let () - (print "No such member " (member-parm) "."))))) - ((#f) (print "No action specified."))) diff --git a/brmsaptool.scm b/brmsaptool.scm index a5e94c7..c1d83d5 100644 --- a/brmsaptool.scm +++ b/brmsaptool.scm @@ -71,6 +71,7 @@ (-mfec (n) "Member-File parser Error Context (lines)" (*member-file-context* (string->number n))) (-mi (id) "Specify member by id" (-member-id- (string->number id))) (-mn (nick) "Specify member by nick" (-member-nick- nick)) + (-pi () "Print information" (-action- 'print-info)) ) ;; Load the members database (required for everything anyway) @@ -83,5 +84,55 @@ (find-member-by-nick MB (-member-nick-)) #f))) -;; ... -(void) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; + +(import (chicken string) + (chicken sort)) +(define (print-members-base-info mb) + (let ((nicks (list-members-nicks mb))) + (print "Members (" + (length nicks) + "): " + (string-intersperse + (sort + nicks + stringstring (car a)) + (symbol->string (car b))))))) + (print "User " id " alias(es): " + (string-intersperse + (map symbol->string aliases) + ", ")) + (newline) + (let loop ((sinfo sinfo)) + (when (not (null? sinfo)) + (let* ((kv (car sinfo)) + (k (car kv)) + (v (cdr kv))) + (print " " k ":\t" + (if (member k '(student suspend)) + (periods->string v) + v)) + (loop (cdr sinfo))))))) + +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Perform requested action +(case (-action-) + ((print-info) + (newline) + (if mr + (print-member-record-info mr) + (print-members-base-info MB)) + (newline)))