Bump version to 1.19-dev.

This reverts commit 488499cf23.

CHANGELOG.md

@@ -0,0 +1,197 @@
+ChangeLog
+=========
+
+1.18 - released 2025-01-06
+--------------------------
+
+* fix typo in members-print
+* create LaTeX source of general meeting attendance sheet
+* add expected income, cash flow and average age to stats
+* add QR code payment in CZK on members' payments pages'
+
+1.17 - released 2024-10-01
+--------------------------
+
+* add "Current Fee" column to -fees to see special discounts
+* add EUR account to members page
+* fix erroneous newlines in cronjobs
+* add support for full RFC email addresses in *email-from* configuration
+* handling of members without any fees or payments
+
+1.16.2 - released 2024-05-07
+----------------------------
+
+* fix rada-ml-pred? in -mlsync
+
+1.16.1 - released 2024-04-02
+----------------------------
+
+* add EUR account for paying membership fees to member's page
+
+1.16 - released 2024-02-09
+--------------------------
+
+* handle # character at weird positions in DokuWiki users.auth.php
+* unify -mlsync and -mlcheck handling of member predicates
+* handle unicode characters with 3-byte UTF-8 representation correctly
+* calculate expected income with respect to discounts granted
+* report soon-expiring members in the summary emails
+* report mailing lists check status in summary emails
+
+1.15.1 - released 2024-01-02
+----------------------------
+
+* fix calculating historical membership fee (was erroneously based on
+  current date)
+* fix showing basic information without MLs loaded
+
+1.15 - released 2023-12-24
+--------------------------
+
+* increase membership fees starting 2024-01 (specification.rkt)
+* add support for explicit fee amounts for specified period
+
+1.14 - released 2023-12-06
+--------------------------
+
+* add support for dynamic terminal size
+* use table cell formatting instead of paragraph formatting everywhere
+* fix sqlite3 database locking issue
+* allow limiting -fees output to -active only
+
+1.13 - released 2023-12-05
+--------------------------
+
+* add dokuwiki problems to summary emails
+* handle more SEPA payments
+
+1.12 - released 2023-11-16
+--------------------------
+
+* switch to eggs: srfi-1, sqlite3
+* semi-automatic export for brmdoor
+* improvements of summary emails for council
+* redirect dokuwiki plugin to login page if not logged in
+* sync council and revision mailing lists
+
+1.11 - released 2023-09-23
+--------------------------
+
+* add support for CC in emails
+* update manual page
+* setup new cron jobs
+
+1.10 - released 2023-09-17
+--------------------------
+
+* direct access of mailman 3 database
+
+1.9 - released 2023-09-16
+-------------------------
+
+* implement support for mailman 3
+* add total debt to long-term debtors listings
+
+1.8 - released 2023-07-29
+------------------------
+
+* remove old compatibility static web pages generator
+* update documentation
+* update Fio fetcher to handle new limits imposed by the bank
+* output plain list of active members (used by BrmBar project)
+
+1.7 - released 2023-07-04
+-------------------------
+
+* include current month in stats
+* right-alignment in table cells
+* functionality improvements of dokuwiki plugin
+* checking council group between dokuwiki and members database
+
+1.6.2 - released 2023-06-29
+---------------------------
+
+* fix passing members to remove_members mailman binary
+
+1.6.1 - released 2023-06-27
+---------------------------
+
+* fix ML removal
+* fix sync re-read
+
+1.6 - released 2023-06-27
+-------------------------
+
+* dokuwiki plugin
+* delete generated files for destroyed members
+* verify dokuwiki users information
+
+1.5 - released 2023-06-19
+-------------------------
+
+* improved table renderer
+* show membership fees and payments balances history
+* improved generator of static web pages
+
+1.4 - released 2023-05-26
+-------------------------
+
+* vim and joe syntax highlighting support
+* improved Fio bank statement fetcher and merger
+
+1.3 - released 2023-05-22
+-------------------------
+
+* organizational bodies membership
+
+1.2.1 - released 2023-05-19
+---------------------------
+
+* fix email string argument passing
+* use bi-directional mailman communication
+
+1.2 - released 2023-05-19
+-------------------------
+
+* split configuration and action command-line options
+* support for git annotate
+* show suspended members that are about to expire
+* optimized utf-8 support
+
+1.1 - released 2023-05-14
+-------------------------
+
+* support for suppressing output (used in cron jobs)
+* sorted members in notifications
+* report missing keys in member files
+* internal ML membership synchronization
+
+1.0 - released 2023-04-23
+-------------------------
+
+This was the first oficially released version which contains all the
+functionality required to take over the original solution.
+
+* parsing and interpreting member files with specified grammar
+* basic support for start/stop periods
+* command-line arguments support with integrated help display
+* static builds
+* cards export for BrmDoor project
+* data validation and error reporting
+* improved manual credit handling
+* member id validation and generation
+* export of gnuplot-compatible statistics
+* static web data generation
+* table formatting with color support
+* member fees and payments accounting
+* support for multiple join/destroy periods
+* period-based exchange rates lookups
+* unpaired transactions handling
+* internal ML membership check
+* notifications for both council and members with debts
+* universal Fio bank account statement fetcher
+* preliminary SEPA payment parsing
+* programming modules documentation
+* git status support
+* sample configuration
+* manual page

README.md

@@ -9,7 +9,7 @@ License
 
 ISC License
 
-Copyright 2023 Brmlab, z.s.
+Copyright 2023-2024 Brmlab, z.s.
 Dominik Pantůček <dominik.pantucek@trustica.cz>
 
 Permission to use, copy, modify, and/or distribute this software

doc/d-utils.md

@@ -388,6 +388,16 @@ quoted-printable sequences.
 Returns the ```str``` with all characters converted to upper case
 using ```char-upcase```. Does not work with UTF-8.
 
+### string-capitalize [procedure]
+
+    (string-capitalize str)
+
+* ```str``` - arbitrary string
+
+Returns the ```str``` with the first character converted to upper case
+using ```char-upcase``` and the remainder converted to lower case
+using ```char-downcase```. Does not work with UTF-8.
+
 ## util-mail [module]
 
     (import util-mail)

doc/formats.md

@@ -56,7 +56,6 @@ Processed source is scanned for known keys. Known keys are:
 * nick
 * name
 * mail
-* phone
 * born
 
 Multiple instances of single key are considered an error.
@@ -83,6 +82,7 @@ line numbers as the value for such key. Multikeys are:
 * revisionstop
 * grantstart
 * grantstop
+* phone
 
 The result is a valid dictionary of keys and multikeys.
 
@@ -104,7 +104,8 @@ periods.
 The joined key is converted into a month value.
 
 Card and desfire lists are parsed to get lists of card id and optional
-comment.
+comment. The same processing is used for phone to support multiple
+phone numbers.
 
 Credit list is parsed to get a list of amounts and optional comments.
 

doc/hackerbase.1

@@ -273,10 +273,6 @@ Specify member by nickname.
 .B \-destroyed
 Show destroyed members in \fB-fees\fR action as well.
 
-.TP
-.B \-ml-all
-Load all mailman list memberships to show them in members info.
-
 .SH "FILES"
 
 All the information about members is stored in in members file in the

src/Makefile

@@ -42,7 +42,9 @@ HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm			\
 	tests.import.scm notifications.import.scm logging.import.scm	\
 	progress.import.scm cal-period.import.scm			\
 	util-stdout.import.scm export-web-static.import.scm		\
-	dokuwiki.import.scm
+	dokuwiki.import.scm mailinglist.import.scm			\
+	export-sheet.import.scm mbase-query.import.scm			\
+	qr-payment.import.scm
 
 HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o		\
 	 cal-period.o ansi.o util-bst-ldict.o command-line.o mbase.o	\
@@ -58,8 +60,9 @@ HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o		\
 	 table-style.o sgr-state.o util-utf8.o sgr-cell.o		\
 	 template-list-expander.o box-drawing.o export-web-static.o	\
 	 util-dir.o dokuwiki.o racket-kwargs.o duck.o util-bst.o	\
-	 util-bst-bdict.o util-bst-ldict.o util-bst-lset.o mailman2.o	\
-	 mailman-common.o mailman3.o mailman3-sql.o
+	 util-bst-bdict.o util-bst-ldict.o util-bst-lset.o		\
+	 mailman-common.o mailman3.o mailman3-sql.o tiocgwinsz.o	\
+	 mailinglist.o export-sheet.o mbase-query.o qr-payment.o
 
 GENDOC-SOURCES=gendoc.scm duck-extract.import.scm			\
 	util-time.import.scm util-csv.import.scm util-git.import.scm	\
@@ -68,14 +71,15 @@ GENDOC-SOURCES=gendoc.scm duck-extract.import.scm			\
 	util-format.import.scm util-tag.import.scm			\
 	util-string.import.scm util-bst.import.scm			\
 	util-bst-bdict.import.scm util-bst-ldict.import.scm		\
-	util-dir.import.scm util-utf8.import.scm
+	util-dir.import.scm util-utf8.import.scm util-mail.import.scm	\
+	util-bst-lset.import.scm
 
 GENDOC-OBJS=gendoc.o duck-extract.o util-time.o util-csv.o util-io.o	\
 	progress.o testing.o util-proc.o util-git.o util-io.o		\
 	util-stdout.o util-parser.o util-proc.o util-format.o		\
 	racket-kwargs.o util-bst-ldict.o util-tag.o duck.o		\
 	util-string.o util-bst.o util-bst-bdict.o util-bst-ldict.o	\
-	util-dir.o util-utf8.o
+	util-dir.o util-utf8.o util-bst-lset.o util-mail.o
 
 .PHONY: imports
 imports: $(HACKERBASE-DEPS)
@@ -205,7 +209,8 @@ MEMBERS-PRINT-SOURCES=members-print.scm util-bst-ldict.import.scm	\
 	bank-account.import.scm members-fees.import.scm			\
 	members-payments.import.scm brmember-format.import.scm		\
 	specification.import.scm cal-format.import.scm			\
-	util-git.import.scm racket-kwargs.import.scm
+	util-git.import.scm racket-kwargs.import.scm			\
+	tiocgwinsz.import.scm
 
 members-print.o: members-print.import.scm
 members-print.import.scm: $(MEMBERS-PRINT-SOURCES)
@@ -255,13 +260,6 @@ ENVIRONMENT-SOURCES=environment.scm ansi.import.scm
 environment.o: environment.import.scm
 environment.import.scm: $(ENVIRONMENT-SOURCES)
 
-MAILMAN2-SOURCES=mailman2.scm util-bst-lset.import.scm	\
-	util-io.import.scm mailman-common.import.scm	\
-	configuration.import.scm
-
-mailman2.o: mailman2.import.scm
-mailman2.import.scm: $(MAILMAN2-SOURCES)
-
 UTIL-TIME-SOURCES=util-time.scm duck.import.scm
 
 util-time.o: util-time.import.scm
@@ -289,7 +287,7 @@ util-io.o: util-io.import.scm
 util-io.import.scm: $(UTIL-IO-SOURCES)
 
 UTIL-PARSER-SOURCES=util-parser.scm testing.import.scm	\
-	duck.import.scm
+	duck.import.scm racket-kwargs.import.scm
 
 util-parser.o: util-parser.import.scm
 util-parser.import.scm: $(UTIL-PARSER-SOURCES)
@@ -330,7 +328,8 @@ NOTIFICATIONS-SOURCES=notifications.scm brmember.import.scm		\
 	brmember-format.import.scm configuration.import.scm		\
 	util-time.import.scm members-fees.import.scm mbase.import.scm	\
 	members-print.import.scm table.import.scm			\
-	bank-account.import.scm logging.import.scm
+	bank-account.import.scm logging.import.scm			\
+	mailinglist.import.scm
 
 notifications.o: notifications.import.scm
 notifications.import.scm: $(NOTIFICATIONS-SOURCES)
@@ -469,7 +468,8 @@ box-drawing.import.scm: $(BOX-DRAWING-SOURCES)
 EXPORT-WEB-STATIC-SOURCES=export-web-static.scm brmember.import.scm	\
 	util-dir.import.scm mbase.import.scm				\
 	members-payments.import.scm cal-day.import.scm			\
-	util-git.import.scm configuration.import.scm texts.import.scm
+	util-git.import.scm configuration.import.scm texts.import.scm	\
+	members-fees.import.scm qr-payment.import.scm
 
 export-web-static.o: export-web-static.import.scm
 export-web-static.import.scm: $(EXPORT-WEB-STATIC-SOURCES)
@@ -520,10 +520,9 @@ UTIL-BST-LSET-SOURCES=util-bst-lset.scm util-bst.import.scm	\
 util-bst-lset.o: util-bst-lset.import.scm
 util-bst-lset.import.scm: $(UTIL-BST-LSET-SOURCES)
 
-MAILMAN-SOURCES=mailman.scm mailman2.import.scm			\
-	mailman-common.import.scm util-bst-lset.import.scm	\
-	configuration.import.scm mailman3.import.scm		\
-	progress.import.scm
+MAILMAN-SOURCES=mailman.scm mailman-common.import.scm		\
+	util-bst-lset.import.scm configuration.import.scm	\
+	mailman3.import.scm progress.import.scm
 
 mailman.o: mailman.import.scm
 mailman.import.scm: $(MAILMAN-SOURCES)
@@ -543,3 +542,37 @@ MAILMAN3-SQL-SOURCES=mailman3-sql.scm configuration.import.scm
 
 mailman3-sql.o: mailman3-sql.import.scm
 mailman3-sql.import.scm: $(MAILMAN3-SQL-SOURCES)
+
+TIOCGWINSZ-SOURCES=tiocgwinsz.scm duck.import.scm
+
+tiocgwinsz.o: tiocgwinsz.import.scm
+tiocgwinsz.import.scm: $(TIOCGWINSZ-SOURCES)
+
+MAILINGLIST-SOURCES=mailinglist.scm racket-kwargs.import.scm		\
+	mailman.import.scm mbase.import.scm util-string.import.scm	\
+	brmember.import.scm
+
+mailinglist.o: mailinglist.import.scm
+mailinglist.import.scm: $(MAILINGLIST-SOURCES)
+
+EXPORT-SHEET-SOURCES=export-sheet.scm mbase.import.scm		\
+	brmember.import.scm brmember-format.import.scm		\
+	util-bst-ldict.import.scm members-payments.import.scm	\
+	util-format.import.scm members-fees.import.scm		\
+	cal-period.import.scm
+
+export-sheet.o: export-sheet.import.scm
+export-sheet.import.scm: $(EXPORT-SHEET-SOURCES)
+
+MBASE-QUERY-SOURCES=mbase-query.scm mbase.import.scm			\
+	brmember.import.scm util-bst-ldict.scm primes.import.scm	\
+	cal-period.import.scm cal-month.import.scm			\
+	members-fees.import.scm members-payments.import.scm
+
+mbase-query.o: mbase-query.import.scm
+mbase-query.import.scm: $(MBASE-QUERY-SOURCES)
+
+QR-PAYMENT-SOURCES=qr-payment.scm util-io.import.scm
+
+qr-payment.o: qr-payment.import.scm
+qr-payment.import.scm: $(QR-PAYMENT-SOURCES)

src/brmember-parser.scm

@@ -48,7 +48,7 @@
 	 cal-day)
 
  ;; Pass 2: known keys
- (define mandatory-keys '(nick name mail phone))
+ (define mandatory-keys '(nick name mail))
  (define optional-keys '(born))
  (define known-multikeys
    '(card desfire
@@ -59,7 +59,9 @@
 	  councilstart councilstop
 	  revisionstart revisionstop
 	  grantstart grantstop
-	  joined destroyed))
+	  joined destroyed
+	  feestart feestop
+	  phone))
  (define ignored-keys '(mail2))
 
  (define known-keys (append mandatory-keys optional-keys))
@@ -83,6 +85,9 @@
      
      (joined member start)
      (destroyed member stop)
+
+     (feestart fee start)
+     (feestop fee stop)
      ))
  (define start-stop-markers (map car start-stop-markers-lookup))
 
@@ -109,22 +114,38 @@
      (info
       ,(lambda (mr output key value)
 	 (case key
-	   ((student suspend member revision chair council grant)
+	   ((student suspend member revision chair council grant fee)
 	    (let* ((res (period-markers->cal-periods value))
 		   (ok? (car res))
-		   (periods (cadr res))
+		   (periods0 (cadr res))
+		   (periods
+		    (if (eq? key 'fee)
+			(let ((ps
+			       (map
+				(lambda (p)
+				  (let* ((sc (cal-period-scomment p))
+					 (scp (string-first+rest sc))
+					 (amts (car scp))
+					 (amt (string->number amts))
+					 (rc (cdr scp)))
+				    (set-cal-period-scomment
+				     p
+				     (list amt rc))))
+				periods0)))
+			  ps)
+			periods0))
 		   (msg (caddr res))
 		   (line-number (cadddr res))
 		   (mr1 (brmember-sub-set mr output key periods)))
 	      (if ok?
 		  mr1
 		  (brmember-add-highlight mr1 line-number msg 3 'error))))
-	   ((card desfire)
+	   ((card desfire phone)
 	    (brmember-sub-set mr output key
-				   (map
-				    (lambda (rec)
-				      (string-first+rest (car rec)))
-				    value)))
+			      (map
+			       (lambda (rec)
+				 (string-first+rest (car rec)))
+			       value)))
 	   ((credit)
 	    (let loop ((mr mr)
 		       (src-credits value)
@@ -253,7 +274,7 @@
 		   (caar passes)
 		   (interpreter-pass mr pass-name (ldict-ref mr prev-name) pass-proc)))))))
 
- ;; Loads member file source. Performs passes 0, 1 and 2.
+ ;; Loads member file source. Performs passes 0-4
  (define (load-brmember-file mr)
    (let* ((mrif (brmember-input-file mr))
 	  (source (read-lines mrif))

src/brmember.scm

@@ -85,6 +85,10 @@
   brmember-mailman
   brmember-add-mailman
 
+  brmember-spec-fee
+
+  brmember-age
+
   brmember-tests!
   )
 
@@ -421,7 +425,8 @@
    (if (brmember-suspended? mr)
        (let ((period (cal-periods-match (brmember-info mr 'suspend))))
 	 (if period
-	     (cal-month-diff (cal-period-since period) (*current-month*))
+	     (cal-month-diff (cal-ensure-month (cal-period-since period))
+			     (*current-month*))
 	     0))
        0))
 
@@ -478,6 +483,29 @@
 	     (cons ml
 		   (brmember-mailman mr))))
 
+ ;; Returns special fee for current month or #f if it should be default
+ (define (brmember-spec-fee mr)
+   (let ((fee-periods (brmember-info mr 'fee #f)))
+     (if fee-periods
+	 (let ((fee-period (cal-month-find-period fee-periods)))
+	   (if fee-period
+	       (let ()
+		 (car (cal-period-scomment fee-period)))
+	       #f))
+	 #f)))
+
+ (define (brmember-age mr)
+   (let ((born (brmember-info mr 'born #f)))
+     (if born
+	 (let ((lst (string-split born "-")))
+	   (if (null? lst)
+	       #f
+	       (let ((y (string->number (car lst))))
+		 (if y		     
+		     (- (current-year) y)
+		     #f))))
+	 #f)))
+
  ;; Self-tests
  (define (brmember-tests!)
    (run-tests
@@ -486,8 +514,8 @@
 	       (ldict-equal?
 		(make-brmember '|1234| "members/1234" '(|member|))
 		(make-ldict
-		 `((file-name . |1234|)
-		   (TAG . ,TAG-BRMEMBER)
+		 `((TAG . ,TAG-BRMEMBER)
+		   (file-name . |1234|)
 		   (file-path . "members/1234")
 		   (symlinks |member|)
 		   (id . 1234)))))

src/cal-period.scm

@@ -26,435 +26,464 @@
 (declare (unit cal-period))
 
 (module
- cal-period
- (
-  *current-month*
-  *current-day*
-
-  set-current-month!
-  set-current-day!
-
-  with-current-month
-  with-current-day
-  
-  make-cal-period
-
-  cal-period-since
-  cal-period-before
-  cal-period-scomment
-  cal-period-bcomment
-  
-  period-markers->cal-periods
-  
-  cal-periods-duration
-  
-  cal-month-in-period?
-  cal-month-in-periods?
-
-  cal-day-in-period?
-  cal-day-in-periods?
-  
-  cal-periods->string
-  cal-periods-match
-  
-  make-cal-period-lookup-table
-  lookup-by-cal-period
-
-  cal-ensure-month
-  cal-ensure-day
-  
-  cal-period-tests!
-  )
-
- (import scheme
-	 (chicken base)
-	 (chicken sort)
-	 (chicken time)
-	 (chicken time posix)
-	 (chicken format)
-	 (chicken string)
-	 cal-month
-	 testing
-	 util-tag
-	 cal-day)
-
- ;; Type tag
- (define TAG-CAL-PERIOD (make-tag CAL-PERIOD))
-
- ;; Current month - if changed, we get the actual state for given month.
- (define *current-month*
-   (make-parameter
-    (let ((d (seconds->local-time (current-seconds))))
-      (make-cal-month (+ 1900 (vector-ref d 5))
-		      (+ (vector-ref d 4) 1)))))
-
- ;; Current month - if changed, we get the actual state for given month.
- (define *current-day*
-   (make-parameter
-    (let ((d (seconds->local-time (current-seconds))))
-      (make-cal-day (+ 1900 (vector-ref d 5))
-		    (+ (vector-ref d 4) 1)
-		    (vector-ref d 3)))))
-
- ;; Changes both current-month and current-day based on given month
- (define (set-current-month! m)
-   (*current-month* m)
-   (*current-day* (cal-ensure-day m)))
-
- ;; Changes both current-day and current-month based on given day
- (define (set-current-day! d)
-   (*current-day* d)
-   (*current-month* (cal-ensure-month d)))
-
- ;; Parameterizes both current-month and current-day based on given
- ;; month
- (define-syntax with-current-month
-   (syntax-rules ()
-     ((_ ms body ...)
-      (let ((m ms))
-	(parameterize ((*current-month* m)
-		       (*current-day* (cal-ensure-day m)))
-	  body ...)))))
-
- ;; Parameterizes both current-day and current-month based on given
- ;; day
- (define-syntax with-current-day
-   (syntax-rules ()
-     ((_ ds body ...)
-      (let ((d ds))
-	(parameterize ((*current-day* d)
-		       (*current-month* (cal-ensure-month d)))
-	  body ...)))))
-
- ;; Creates a new period value with optional since and before
- ;; comments.
- (define (make-cal-period since before . args)
-   (let ((scomment (if (not (null? args)) (car args) #f))
-	 (bcomment (if (and (not (null? args))
-			    (not (null? (cdr args))))
-		       (cadr args)
-		       #f)))
-     (list TAG-CAL-PERIOD since before scomment bcomment)))
-
- ;; Simple accessors
- (define cal-period-since cadr)
- (define cal-period-before caddr)
- (define cal-period-scomment cadddr)
- (define cal-period-bcomment (compose cadddr cdr))
-
- ;; Type predicate
- (define (cal-period? p)
-   (and (pair? p)
-	(eq? (car p)
-	     TAG-CAL-PERIOD)))
-
- ;; Month subtype predicate
- (define (cal-period-month? p)
-   (and (cal-period? p)
-	(cal-month? (cal-period-since p))
-	(cal-month? (cal-period-before p))))
-
- ;; Day subtype predicate
- (define (cal-period-day? p)
-   (and (cal-period? p)
-	(cal-day? (cal-period-since p))
-	(cal-day? (cal-period-before p))))
-
- ;; Validation
- (define (cal-period-valid? p)
-   (and (pair? p)
-	(eq? (car p)
-	     TAG-CAL-PERIOD)
-	(let ((since (cal-period-since p))
-	      (before (cal-period-before p)))
-	  (or (and (cal-month? since)
-		   (cal-month? before)
-		   (cal-month<=? since before))
-	      (and (cal-day? since)
-		   (cal-day? before)
-		   (cal-day<=? since before))))))
-
- ;; Sorts period markers (be it start or end) chronologically and
- ;; returns the sorted list.
- (define (sort-period-markers l)
-   (sort l
-	 (lambda (a b)
-	   (cal-day/month<? (cadr a) (cadr b)))))
-
- ;; Converts list of start/stop markers to list of pairs of months -
- ;; periods. The markers are lists in the form (start/stop cal-month).
- (define (period-markers->cal-periods l)
-   (let loop ((l (sort-period-markers l))
-	      (ps '())
-	      (cb #f))
-     (if (null? l)
-	 (list #t
-	       (if cb
-		   (reverse (cons (make-cal-period (car cb) #f (cadr cb)) ps))
-		   (reverse ps))
-	       ""
-	       -1)
-	 (let* ((marker (car l))
-		(rmt (if cb 'stop 'start))
-		(mtype (car marker))
-		(month (cadr marker))
-		(line-number (if (null? (cddr marker))
-				 #f
-				 (caddr marker)))
-		(comment (if (and line-number
-				  (not (null? (cdddr marker))))
-			     (cadddr marker)
-			     #f)))
-	   (if (eq? mtype rmt)
-	       (if cb
-		   (loop (cdr l)
-			 (cons (make-cal-period (car cb) month (cadr cb) comment) ps)
-			 #f)
-		   (loop (cdr l)
-			 ps
-			 (list month comment)))
-	       (list #f
-		     (reverse ps)
-		     (sprintf "Invalid start/stop sequence marker ~A" marker)
-		     line-number))))))
-
- ;; Returns duration of period in months. Start is included, end is
- ;; not. The period contains the month just before the specified end.
- (define (cal-period->duration p)
-   (let* ((b (cal-period-since p))
-	  (e (cal-period-before p))
-	  (e- (if e e (*current-month*))))
-     (cal-month-diff b e-)))
-
- ;; Returns sum of periods lengths.
- (define (cal-periods-duration l)
-   (apply + (map cal-period->duration l)))
-
- ;; True if month belongs to given month period - start inclusive, end
- ;; exclusive.
- (define (cal-month-in-period? p . ml)
-   (let ((m (if (null? ml)
-		(*current-month*)
-		(cal-ensure-month (car ml))))
-	 (before (cal-ensure-month (cal-period-before p) #t))
-	 (since (cal-ensure-month (cal-period-since p))))
-     (and (or (not before)
-	      (cal-month<? m before))
-	  (not (cal-month<? m since)))))
-
- ;; Returns true if given month is in at least one of the periods
- ;; given. Defaults to current month.
- (define (cal-month-in-periods? ps . ml)
-   (let ((m (if (null? ml)
-		(*current-month*)
-		(car ml))))
-     (let loop ((ps ps))
-       (if (null? ps)
-	   #f
-	   (if (cal-month-in-period? (car ps) m)
-	       #t
-	       (loop (cdr ps)))))))
-
- ;; Checks whether given day belongs to day or month period
- (define (cal-day-in-period? p . dl)
-   (let ((d (if (null? dl)
-		(*current-day*)
-		(cal-ensure-day (car dl))))
-	 (before (cal-ensure-day (cal-period-before p)))
-	 (since (cal-ensure-day (cal-period-since p))))
-     (and (or (not before)
-	      (cal-day<? d before))
-	  (not (cal-day<? d since)))))
-
- ;; Returns true if the day belongs to at least one period
- (define (cal-day-in-periods? ps . dl)
-   (let ((d (if (null? dl)
-		(*current-day*)
-		(cal-ensure-day (car dl)))))
-     (let loop ((ps ps))
-       (if (null? ps)
-	   #f
-	   (if (cal-day-in-period? (car ps) d)
-	       #t
-	       (loop (cdr ps)))))))
-
- ;; Returns string representing a month period with possibly open end.
- (define (cal-period->string p)
-   (sprintf "~A..~A"
-	    (cal-day/month->string (cal-period-since p))
-	    (cal-day/month->string (cal-period-before p))))
-
- ;; Returns a string representing a list of periods.
- (define (cal-periods->string ps)
-   (string-intersperse
-    (map cal-period->string ps)
-    ", "))
-
- ;; Finds a period the month matches and returns it. If no period
- ;; matches, it returns #f.
- (define (cal-periods-match ps .  ml)
-   (let ((m (if (null? ml) (*current-month*) (car ml))))
-     (let loop ((ps ps))
-       (if (null? ps)
-	   #f
-	   (if (cal-month-in-period? (car ps) m)
-	       (car ps)
-	       (loop (cdr ps)))))))
-
- ;; Creates lookup table from definition source
- (define (make-cal-period-lookup-table source)
-   (let loop ((lst source)
-	      (res '())
-	      (prev #f))
-     (if (null? lst)
-	 (reverse
-	  (cons (cons (make-cal-period (apply make-cal-month (car prev)) #f)
-		      (cdr prev))
-		res))
-	 (loop (cdr lst)
-	       (if prev
-		   (cons (cons (make-cal-period (apply make-cal-month (car prev))
-						(apply make-cal-month (caar lst)))
-			       (cdr prev))
-			 res)
-		   res)
-	       (car lst)))))
-
- ;; Looks up current month and returns associated definitions
- (define (lookup-by-cal-period table)
-   (let loop ((lst table))
-     (if (null? lst)
-	 #f
-	 (if (cal-month-in-period? (caar lst))
-	     (cdar lst)
-	     (loop (cdr lst))))))
-
- ;; Wrapper that accepts either day or month and returns testable month
- (define (cal-ensure-month v . stop?s)
-   (if v
-       (if (cal-month? v)
-	   v
-	   (if (cal-day? v)
-	       (apply cal-day->month v stop?s)
-	       #f))
-       #f))
-
- ;; Ensures day for checking the periods
- (define (cal-ensure-day v)
-   (if v
-       (if (cal-day? v)
-	   v
-	   (if (cal-month? v)
-	       (make-cal-day (cal-month-year v)
-			     (cal-month-month v)
-			     1)
-	       #f))
-       #f))
-
- ;; Performs self-tests of the period module.
- (define (cal-period-tests!)
-   (run-tests
     cal-period
-    (test-equal? sort-period-markers
-		 (sort-period-markers
-		  `((start ,(make-cal-month 2023 1))
-		    (stop ,(make-cal-month 2022 10))
-		    (start ,(make-cal-month 2022 3))))
-		 `((start ,(make-cal-month 2022 3))
-		   (stop ,(make-cal-month 2022 10))
-		   (start ,(make-cal-month 2023 1))))
-    (test-equal? period-markers->cal-periods
-	         (period-markers->cal-periods
+    (
+     current-year
+     *current-month*
+     *current-day*
+
+     set-current-month!
+     set-current-day!
+
+     with-current-month
+     with-current-day
+  
+     make-cal-period
+
+     cal-period-since
+     cal-period-before
+     cal-period-scomment
+     cal-period-bcomment
+
+     set-cal-period-scomment
+  
+     period-markers->cal-periods
+  
+     cal-periods-duration
+  
+     cal-month-in-period?
+     cal-month-in-periods?
+
+     cal-month-find-period
+
+     cal-day-in-period?
+     cal-day-in-periods?
+  
+     cal-periods->string
+     cal-periods-match
+  
+     make-cal-period-lookup-table
+     lookup-by-cal-period
+
+     cal-ensure-month
+     cal-ensure-day
+  
+     cal-period-tests!
+     )
+
+  (import scheme
+	  (chicken base)
+	  (chicken sort)
+	  (chicken time)
+	  (chicken time posix)
+	  (chicken format)
+	  (chicken string)
+	  cal-month
+	  testing
+	  util-tag
+	  cal-day)
+
+  ;; Type tag
+  (define TAG-CAL-PERIOD (make-tag CAL-PERIOD))
+
+  (define (current-year)
+    (cal-month-year (*current-month*)))
+
+  ;; Current month - if changed, we get the actual state for given month.
+  (define *current-month*
+    (make-parameter
+     (let ((d (seconds->local-time (current-seconds))))
+       (make-cal-month (+ 1900 (vector-ref d 5))
+		       (+ (vector-ref d 4) 1)))))
+
+  ;; Current month - if changed, we get the actual state for given month.
+  (define *current-day*
+    (make-parameter
+     (let ((d (seconds->local-time (current-seconds))))
+       (make-cal-day (+ 1900 (vector-ref d 5))
+		     (+ (vector-ref d 4) 1)
+		     (vector-ref d 3)))))
+
+  ;; Changes both current-month and current-day based on given month
+  (define (set-current-month! m)
+    (*current-month* m)
+    (*current-day* (cal-ensure-day m)))
+
+  ;; Changes both current-day and current-month based on given day
+  (define (set-current-day! d)
+    (*current-day* d)
+    (*current-month* (cal-ensure-month d)))
+
+  ;; Parameterizes both current-month and current-day based on given
+  ;; month
+  (define-syntax with-current-month
+    (syntax-rules ()
+      ((_ ms body ...)
+       (let ((m ms))
+	 (parameterize ((*current-month* m)
+			(*current-day* (cal-ensure-day m)))
+	   body ...)))))
+
+  ;; Parameterizes both current-day and current-month based on given
+  ;; day
+  (define-syntax with-current-day
+    (syntax-rules ()
+      ((_ ds body ...)
+       (let ((d ds))
+	 (parameterize ((*current-day* d)
+			(*current-month* (cal-ensure-month d)))
+	   body ...)))))
+
+  ;; Creates a new period value with optional since and before
+  ;; comments.
+  (define (make-cal-period since before . args)
+    (let ((scomment (if (not (null? args)) (car args) #f))
+	  (bcomment (if (and (not (null? args))
+			     (not (null? (cdr args))))
+			(cadr args)
+			#f)))
+      (list TAG-CAL-PERIOD since before scomment bcomment)))
+
+  ;; Simple accessors
+  (define cal-period-since cadr)
+  (define cal-period-before caddr)
+  (define cal-period-scomment cadddr)
+  (define cal-period-bcomment (compose cadddr cdr))
+
+  ;; Direct updater
+  (define (set-cal-period-scomment p c)
+    (list TAG-CAL-PERIOD
+	  (cal-period-since p)
+	  (cal-period-before p)
+	  c
+	  (cal-period-bcomment p)))
+
+  ;; Type predicate
+  (define (cal-period? p)
+    (and (pair? p)
+	 (eq? (car p)
+	      TAG-CAL-PERIOD)))
+
+  ;; Month subtype predicate
+  (define (cal-period-month? p)
+    (and (cal-period? p)
+	 (cal-month? (cal-period-since p))
+	 (cal-month? (cal-period-before p))))
+
+  ;; Day subtype predicate
+  (define (cal-period-day? p)
+    (and (cal-period? p)
+	 (cal-day? (cal-period-since p))
+	 (cal-day? (cal-period-before p))))
+
+  ;; Validation
+  (define (cal-period-valid? p)
+    (and (pair? p)
+	 (eq? (car p)
+	      TAG-CAL-PERIOD)
+	 (let ((since (cal-period-since p))
+	       (before (cal-period-before p)))
+	   (or (and (cal-month? since)
+		    (cal-month? before)
+		    (cal-month<=? since before))
+	       (and (cal-day? since)
+		    (cal-day? before)
+		    (cal-day<=? since before))))))
+
+  ;; Sorts period markers (be it start or end) chronologically and
+  ;; returns the sorted list.
+  (define (sort-period-markers l)
+    (sort l
+	  (lambda (a b)
+	    (cal-day/month<? (cadr a) (cadr b)))))
+
+  ;; Converts list of start/stop markers to list of pairs of months -
+  ;; periods. The markers are lists in the form (start/stop cal-month).
+  (define (period-markers->cal-periods l)
+    (let loop ((l (sort-period-markers l))
+	       (ps '())
+	       (cb #f))
+      (if (null? l)
+	  (list #t
+		(if cb
+		    (reverse (cons (make-cal-period (car cb) #f (cadr cb)) ps))
+		    (reverse ps))
+		""
+		-1)
+	  (let* ((marker (car l))
+		 (rmt (if cb 'stop 'start))
+		 (mtype (car marker))
+		 (month (cadr marker))
+		 (line-number (if (null? (cddr marker))
+				  #f
+				  (caddr marker)))
+		 (comment (if (and line-number
+				   (not (null? (cdddr marker))))
+			      (cadddr marker)
+			      #f)))
+	    (if (eq? mtype rmt)
+		(if cb
+		    (loop (cdr l)
+			  (cons (make-cal-period (car cb) month (cadr cb) comment) ps)
+			  #f)
+		    (loop (cdr l)
+			  ps
+			  (list month comment)))
+		(list #f
+		      (reverse ps)
+		      (sprintf "Invalid start/stop sequence marker ~A" marker)
+		      line-number))))))
+
+  ;; Returns duration of period in months. Start is included, end is
+  ;; not. The period contains the month just before the specified end.
+  (define (cal-period->duration p)
+    (let* ((b (cal-period-since p))
+	   (e (cal-period-before p))
+	   (e- (if e e (*current-month*))))
+      (cal-month-diff b e-)))
+
+  ;; Returns sum of periods lengths.
+  (define (cal-periods-duration l)
+    (apply + (map cal-period->duration l)))
+
+  ;; True if month belongs to given month period - start inclusive, end
+  ;; exclusive.
+  (define (cal-month-in-period? p . ml)
+    (let ((m (if (null? ml)
+		 (*current-month*)
+		 (cal-ensure-month (car ml))))
+	  (before (cal-ensure-month (cal-period-before p) #t))
+	  (since (cal-ensure-month (cal-period-since p))))
+      (and (or (not before)
+	       (cal-month<? m before))
+	   (not (cal-month<? m since)))))
+
+  ;; Returns true if given month is in at least one of the periods
+  ;; given. Defaults to current month.
+  (define (cal-month-in-periods? ps . ml)
+    (let ((m (if (null? ml)
+		 (*current-month*)
+		 (car ml))))
+      (let loop ((ps ps))
+	(if (null? ps)
+	    #f
+	    (if (cal-month-in-period? (car ps) m)
+		#t
+		(loop (cdr ps)))))))
+
+  ;; Returns true if given month is in at least one of the periods
+  ;; given. Defaults to current month.
+  (define (cal-month-find-period ps . ml)
+    (let ((m (if (null? ml)
+		 (*current-month*)
+		 (car ml))))
+      (let loop ((ps ps))
+	(if (null? ps)
+	    #f
+	    (if (cal-month-in-period? (car ps) m)
+		(car ps)
+		(loop (cdr ps)))))))
+
+  ;; Checks whether given day belongs to day or month period
+  (define (cal-day-in-period? p . dl)
+    (let ((d (if (null? dl)
+		 (*current-day*)
+		 (cal-ensure-day (car dl))))
+	  (before (cal-ensure-day (cal-period-before p)))
+	  (since (cal-ensure-day (cal-period-since p))))
+      (and (or (not before)
+	       (cal-day<? d before))
+	   (not (cal-day<? d since)))))
+
+  ;; Returns true if the day belongs to at least one period
+  (define (cal-day-in-periods? ps . dl)
+    (let ((d (if (null? dl)
+		 (*current-day*)
+		 (cal-ensure-day (car dl)))))
+      (let loop ((ps ps))
+	(if (null? ps)
+	    #f
+	    (if (cal-day-in-period? (car ps) d)
+		#t
+		(loop (cdr ps)))))))
+
+  ;; Returns string representing a month period with possibly open end.
+  (define (cal-period->string p)
+    (sprintf "~A..~A"
+	     (cal-day/month->string (cal-period-since p))
+	     (cal-day/month->string (cal-period-before p))))
+
+  ;; Returns a string representing a list of periods.
+  (define (cal-periods->string ps)
+    (string-intersperse
+     (map cal-period->string ps)
+     ", "))
+
+  ;; Finds a period the month matches and returns it. If no period
+  ;; matches, it returns #f.
+  (define (cal-periods-match ps .  ml)
+    (let ((m (if (null? ml) (*current-month*) (car ml))))
+      (let loop ((ps ps))
+	(if (null? ps)
+	    #f
+	    (if (cal-month-in-period? (car ps) m)
+		(car ps)
+		(loop (cdr ps)))))))
+
+  ;; Creates lookup table from definition source
+  (define (make-cal-period-lookup-table source)
+    (let loop ((lst source)
+	       (res '())
+	       (prev #f))
+      (if (null? lst)
+	  (reverse
+	   (cons (cons (make-cal-period (apply make-cal-month (car prev)) #f)
+		       (cdr prev))
+		 res))
+	  (loop (cdr lst)
+		(if prev
+		    (cons (cons (make-cal-period (apply make-cal-month (car prev))
+						 (apply make-cal-month (caar lst)))
+				(cdr prev))
+			  res)
+		    res)
+		(car lst)))))
+
+  ;; Looks up current month and returns associated definitions
+  (define (lookup-by-cal-period table)
+    (let loop ((lst table))
+      (if (null? lst)
+	  #f
+	  (if (cal-month-in-period? (caar lst))
+	      (cdar lst)
+	      (loop (cdr lst))))))
+
+  ;; Wrapper that accepts either day or month and returns testable month
+  (define (cal-ensure-month v . stop?s)
+    (if v
+	(if (cal-month? v)
+	    v
+	    (if (cal-day? v)
+		(apply cal-day->month v stop?s)
+		#f))
+	#f))
+
+  ;; Ensures day for checking the periods
+  (define (cal-ensure-day v)
+    (if v
+	(if (cal-day? v)
+	    v
+	    (if (cal-month? v)
+		(make-cal-day (cal-month-year v)
+			      (cal-month-month v)
+			      1)
+		#f))
+	#f))
+
+  ;; Performs self-tests of the period module.
+  (define (cal-period-tests!)
+    (run-tests
+     cal-period
+     (test-equal? sort-period-markers
+		  (sort-period-markers
+		   `((start ,(make-cal-month 2023 1))
+		     (stop ,(make-cal-month 2022 10))
+		     (start ,(make-cal-month 2022 3))))
 		  `((start ,(make-cal-month 2022 3))
 		    (stop ,(make-cal-month 2022 10))
-		    (start ,(make-cal-month 2023 1))
-		    (stop ,(make-cal-month 2023 4))))
-		 `(#t
-		   (,(make-cal-period (make-cal-month 2022 3)
-				      (make-cal-month 2022 10) #f #f)
-		    ,(make-cal-period (make-cal-month 2023 1)
-				      (make-cal-month 2023 4) #f #f))
-		   ""
-		   -1))
-    (test-equal? period-markers->cal-periods-open
-	         (period-markers->cal-periods
-		  `((start ,(make-cal-month 2022 3))
-		    (stop ,(make-cal-month 2022 10))
-		    (start ,(make-cal-month 2023 1))
-		    (stop ,(make-cal-month 2023 4))
-		    (start ,(make-cal-month 2023 5))))
-		 `(#t
-		   (,(make-cal-period (make-cal-month 2022 3)
-				      (make-cal-month 2022 10) #f #f)
-		    ,(make-cal-period (make-cal-month 2023 1)
-				      (make-cal-month 2023 4) #f #f)
-		    ,(make-cal-period (make-cal-month 2023 5) #f #f #f))
-		   ""
-		   -1))
-    (test-eq? cal-period->duration
-	      (cal-period->duration (make-cal-period (make-cal-month 2023 1)
-						     (make-cal-month 2023 4) #f #f))
-	      3)
-    (parameterize ((*current-month* (make-cal-month 2023 4)))
-      (test-eq? cal-period->duration
-		(cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f))
-		3))
-    (test-eq? cal-periods-duration
-	      (cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3)
-							(make-cal-month 2022 10) #f #f)
-				      ,(make-cal-period (make-cal-month 2023 1)
-							(make-cal-month 2023 4) #f #f)))
-	      10)
-    (test-true cal-month-in-period?
-	       (cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
-						      (make-cal-month 2022 4) #f #f)
-				     (make-cal-month 2022 3)))
-    (test-false cal-month-in-period?
+		    (start ,(make-cal-month 2023 1))))
+     (test-equal? period-markers->cal-periods
+	          (period-markers->cal-periods
+		   `((start ,(make-cal-month 2022 3))
+		     (stop ,(make-cal-month 2022 10))
+		     (start ,(make-cal-month 2023 1))
+		     (stop ,(make-cal-month 2023 4))))
+		  `(#t
+		    (,(make-cal-period (make-cal-month 2022 3)
+				       (make-cal-month 2022 10) #f #f)
+		     ,(make-cal-period (make-cal-month 2023 1)
+				       (make-cal-month 2023 4) #f #f))
+		    ""
+		    -1))
+     (test-equal? period-markers->cal-periods-open
+	          (period-markers->cal-periods
+		   `((start ,(make-cal-month 2022 3))
+		     (stop ,(make-cal-month 2022 10))
+		     (start ,(make-cal-month 2023 1))
+		     (stop ,(make-cal-month 2023 4))
+		     (start ,(make-cal-month 2023 5))))
+		  `(#t
+		    (,(make-cal-period (make-cal-month 2022 3)
+				       (make-cal-month 2022 10) #f #f)
+		     ,(make-cal-period (make-cal-month 2023 1)
+				       (make-cal-month 2023 4) #f #f)
+		     ,(make-cal-period (make-cal-month 2023 5) #f #f #f))
+		    ""
+		    -1))
+     (test-eq? cal-period->duration
+	       (cal-period->duration (make-cal-period (make-cal-month 2023 1)
+						      (make-cal-month 2023 4) #f #f))
+	       3)
+     (parameterize ((*current-month* (make-cal-month 2023 4)))
+       (test-eq? cal-period->duration
+		 (cal-period->duration (make-cal-period (make-cal-month 2023 1) #f #f #f))
+		 3))
+     (test-eq? cal-periods-duration
+	       (cal-periods-duration `(,(make-cal-period (make-cal-month 2022 3)
+							 (make-cal-month 2022 10) #f #f)
+				       ,(make-cal-period (make-cal-month 2023 1)
+							 (make-cal-month 2023 4) #f #f)))
+	       10)
+     (test-true cal-month-in-period?
 		(cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
 						       (make-cal-month 2022 4) #f #f)
-				      (make-cal-month 2022 5)))
-    (test-true cal-month-in-periods?
-	       (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
-							  (make-cal-month 2022 4) #f #f)
-					,(make-cal-period (make-cal-month 2023 5)
-							  (make-cal-month 2023 10) #f #f))
 				      (make-cal-month 2022 3)))
-    (test-true cal-month-in-periods?
-	       (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
-							  (make-cal-month 2022 4) #f #f)
-					,(make-cal-period (make-cal-month 2023 5)
-							  (make-cal-month 2023 10) #f #f))
-				      (make-cal-month 2023 7)))
-    (test-false cal-month-in-periods?
+     (test-false cal-month-in-period?
+		 (cal-month-in-period? (make-cal-period (make-cal-month 2022 1)
+							(make-cal-month 2022 4) #f #f)
+				       (make-cal-month 2022 5)))
+     (test-true cal-month-in-periods?
 		(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
 							   (make-cal-month 2022 4) #f #f)
 					 ,(make-cal-period (make-cal-month 2023 5)
 							   (make-cal-month 2023 10) #f #f))
-				       (make-cal-month 2022 10)))
-    (test-equal? cal-period->string
-		 (cal-period->string (make-cal-period (make-cal-month 2022 1)
-						      (make-cal-month 2022 4) #f #f))
-		 "2022-01..2022-04")
-    (test-equal? cal-periods->string
-	         (cal-periods->string `(,(make-cal-period (make-cal-month 2022 1)
-							  (make-cal-month 2022 4) #f #f)
-					,(make-cal-period (make-cal-month 2022 12)
-							  (make-cal-month 2023 2) #f #f)))
-		 "2022-01..2022-04, 2022-12..2023-02")
-    (test-false cal-periods-match
-		(cal-periods-match `(,(make-cal-period (make-cal-month 2022 1)
-						       (make-cal-month 2022 4) #f #f)
-				     ,(make-cal-period (make-cal-month 2022 12)
-						       (make-cal-month 2023 2) #f #f))
-				   (make-cal-month 2022 5)))
-    (test-equal? cal-periods-match
+				       (make-cal-month 2022 3)))
+     (test-true cal-month-in-periods?
+		(cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
+							   (make-cal-month 2022 4) #f #f)
+					 ,(make-cal-period (make-cal-month 2023 5)
+							   (make-cal-month 2023 10) #f #f))
+				       (make-cal-month 2023 7)))
+     (test-false cal-month-in-periods?
+		 (cal-month-in-periods? `(,(make-cal-period (make-cal-month 2022 1)
+							    (make-cal-month 2022 4) #f #f)
+					  ,(make-cal-period (make-cal-month 2023 5)
+							    (make-cal-month 2023 10) #f #f))
+					(make-cal-month 2022 10)))
+     (test-equal? cal-period->string
+		  (cal-period->string (make-cal-period (make-cal-month 2022 1)
+						       (make-cal-month 2022 4) #f #f))
+		  "2022-01..2022-04")
+     (test-equal? cal-periods->string
+	          (cal-periods->string `(,(make-cal-period (make-cal-month 2022 1)
+							   (make-cal-month 2022 4) #f #f)
+					 ,(make-cal-period (make-cal-month 2022 12)
+							   (make-cal-month 2023 2) #f #f)))
+		  "2022-01..2022-04, 2022-12..2023-02")
+     (test-false cal-periods-match
 		 (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1)
 							(make-cal-month 2022 4) #f #f)
 				      ,(make-cal-period (make-cal-month 2022 12)
 							(make-cal-month 2023 2) #f #f))
-				    (make-cal-month 2022 2))
-		 (make-cal-period (make-cal-month 2022 1)
-				  (make-cal-month 2022 4) #f #f))
-    ))
+				    (make-cal-month 2022 5)))
+     (test-equal? cal-periods-match
+		  (cal-periods-match `(,(make-cal-period (make-cal-month 2022 1)
+							 (make-cal-month 2022 4) #f #f)
+				       ,(make-cal-period (make-cal-month 2022 12)
+							 (make-cal-month 2023 2) #f #f))
+				     (make-cal-month 2022 2))
+		  (make-cal-period (make-cal-month 2022 1)
+				   (make-cal-month 2022 4) #f #f))
+     ))
 
- )
+  )

src/configuration.scm

@@ -1,5 +1,5 @@
 ;;
-;; configuraiton.scm
+;; configuration.scm
 ;;
 ;; Configuration parameters used by various modules.
 ;;

src/dokuwiki.scm

@@ -54,7 +54,7 @@
 	      (users '()))
      (if (null? lines)
 	 users
-	 (let ((line (parser-preprocess-line (car lines))))
+	 (let ((line (parser-preprocess-line (car lines) #:strip-comments? #f)))
 	   (if (equal? line "")
 	       (loop (cdr lines)
 		     users)
@@ -74,8 +74,8 @@
    (handle-exceptions
     exn
     (let ()
-      (log-warning "DokuWiki: cannot open ~A" fname)
-      (stdout-printf "DokuWiki: cannot open ~A" fname)
+      (log-warning "DokuWiki (~A) exception ~A" fname (condition->list exn))
+      (stdout-printf "DokuWiki (~A) exception ~A" fname (condition->list exn))
       '())
     (with-input-from-file fname
       parse-dokuwiki-users-auth)))

src/duck-extract.scm

@@ -135,18 +135,12 @@
 		       res))))))
 
  (define (print-duck-signature sig)
-   ;;(print sig)
    (let* ((curry-depth (get-curry-depth sig))
 	  (name (get-signature-name sig))
 	  (nameline (format "    ~A~A" (make-string curry-depth #\() name))
 	  (spaceline (make-string (add1 (string-length nameline)) #\space))
 	  (args (gather-signature-arguments sig))
 	  (eargs (expand-signature-arguments args)))
-     ;;(print "  curry depth = " curry-depth)
-     ;;(print "  name = " name)
-     ;;(print "  args = " args)
-     ;;(printf "  eargs = ~S" eargs)
-     ;;(newline)
      (if (null? eargs)
 	 (print nameline ")")
 	 (let loop ((args eargs)

src/export-sheet.scm

@@ -0,0 +1,226 @@
+;;
+;; export-sheet.scm
+;;
+;; Export attendance sheet as MarkDown document.
+;;
+;; ISC License
+;;
+;; Copyright 2024 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 export-sheet))
+
+(module
+ export-sheet
+ (
+  print-attendance-sheet
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken string)
+	 (chicken format)
+	 (chicken sort)
+	 srfi-1
+	 mbase
+	 brmember
+	 brmember-format
+	 util-bst-ldict
+	 members-payments
+	 util-format
+	 members-fees
+	 cal-period
+	 cal-day)
+
+ (define (print-attendance-sheet MB number)
+   (print "\\documentclass{article}")
+   (print "\\usepackage{fancyhdr}")
+   (print "\\usepackage{longtable}")
+   (print "\\usepackage{lastpage}")
+   (print "\\usepackage[top=3cm,left=1cm,right=2cm,bottom=3cm]{geometry}")
+   (print "\\lhead{}")
+   (print
+    (format
+     "\\chead{Prezenční listina ~A. Valné Hromady brmlab z.s. konané ~A. ~A. ~A v sídle spolku}"
+     number  
+     (cal-day-day (*current-day*))
+     (cal-day-month (*current-day*))
+     (cal-day-year (*current-day*))
+     ))
+   (print "\\rhead{}")
+   (print "\\renewcommand{\\headrulewidth}{0pt}")
+   (print "\\lfoot{}")
+   (print "\\cfoot{Strana \\thepage{} ze \\pageref*{LastPage}}")
+   (print "\\rfoot{}")   
+   (print "\\pagestyle{fancy}")
+   (print "\\begin{document}")
+   (print "\\begin{center}")
+   (newline)
+   (print "\\vskip1em")
+   (newline)
+   (define colnames
+     '((id) Nick "Jméno" "Příjmení" (Fee) (Bilance)
+       ("\\raisebox{2pt}{\\begin{minipage}{15mm}\\begin{center}Aktivní\\\\Měsíce\\end{center}\\end{minipage}}")
+       ((Hlas?)) Podpis))
+   (print "\\renewcommand\\arraystretch{2.1}")
+   (print
+    (format
+     "\\begin{longtable}{|~A|}"
+     (string-intersperse
+      (map
+       (lambda (x)
+	 (if (list? x)
+	     (if (list? (car x))
+		 "c"
+		 "r")
+	     "l"))
+       colnames)
+      "|")))
+   (print "\\hline")
+   (print
+    (string-intersperse
+     (map
+      (lambda (x)
+	(format
+	 "\\textbf{~A}"
+	 (if (symbol? x)
+	     (symbol->string x)
+	     (if (string? x)
+		 x
+		 (if (string? (car x))
+		     (car x)
+		     (if (list? (car x))
+			 (symbol->string (caar x))
+			 (symbol->string (car x))))))))
+      colnames)
+     "&")
+    "\\\\")
+   (print "\\hline")
+   (print "\\endhead")
+   (define valid-voters 0)
+   (define ok-balances 0)
+   (define ok-actives 0)
+   (let loop ((mrs (sort
+		    (find-members-by-predicate
+		     MB (lambda (mr)
+			  (brmember-active? mr)))
+		    (lambda (a b)
+		      (string<? (brmember-nick a)
+				(brmember-nick b))))))
+     (when (not (null? mrs))
+       (let* ((mr (car mrs))
+	      (info (ldict-ref mr 'info))
+	      (name (ldict-ref info 'name "ERROR"))
+	      (name* (string-translate*
+		      name
+		      '(("_" . " "))))
+	      (namel (string-split name*))
+	      (sname (car (reverse namel)))
+	      (fname
+	       (string-intersperse
+		(reverse
+		 (cdr
+		  (reverse namel)))
+		" "))
+	      (cal (member-calendar mr))
+	      (rcal (reverse cal))
+	      (rcal12
+	       (if (> (length rcal) 12)
+		   (take rcal 12)
+		   rcal))
+	      (acal12 (map cadr rcal12))
+	      (acal12* (map (lambda (f) (if (memq 'active f) 1 0)) acal12))
+	      (numactive (foldl + 0 acal12*))
+	      (spec-fee (brmember-spec-fee mr))
+	      (current-fee (if spec-fee
+			       spec-fee
+			       (member-calendar-entry->fee
+				(list (*current-month*)
+				      (brmember-flags mr)
+				      spec-fee))))
+	      (balance-ok? (>= (member-total-balance mr)
+			      (- current-fee)))
+	      (active-ok? (>= numactive 9))
+	      (vote-ok? (and balance-ok? active-ok?))
+	      )
+	 (when balance-ok?
+	   (set! ok-balances (+ ok-balances 1)))
+	 (when active-ok?
+	   (set! ok-actives (+ ok-actives 1)))
+	 (when vote-ok?
+	   (set! valid-voters (+ valid-voters 1)))
+	 (print
+	  (brmember-id mr)
+	  " & "
+	  (string-translate*
+	   (brmember-nick mr)
+	   '(("_" . "\\_")))
+	  " & \\small "
+	  fname
+	  " & \\small "
+	  sname
+	  " & "
+	  current-fee
+	  " & "
+	  "\\raisebox{2pt}{\\begin{minipage}{15mm}\\begin{flushright}"
+	  (format-amount-tex
+	   (member-total-balance mr))
+	  "\\\\"
+	  (if balance-ok?
+	      "Bez~dluhu"
+	      "---~~~~~~")
+	  "\\end{flushright}\\end{minipage}}"
+	  " & "
+	  ;(if balance-ok?
+	  ;    "Y"
+	  ;    "--")
+	  ;" & "
+	  "\\raisebox{2pt}{\\begin{minipage}{12mm}\\begin{center}"
+	  numactive "/" 12
+	  "\\\\"
+	  (if active-ok?
+	      "Splněno"
+	      "\\phantom{Sp}---\\phantom{Sp}")
+	  "\\end{center}\\end{minipage}}"
+	  " & "
+	  ;(if active-ok?
+	  ;    "Y"
+	  ;    "--")
+	  ;" & "
+	  (if vote-ok?
+	      "Ano"
+	      "--")
+	  " & "
+	  "~\\hskip28mm~"
+	  " \\\\")
+	 (print "\\hline")
+	 (loop (cdr mrs)))))
+   (print "\\end{longtable}")
+   (print "\\end{center}")
+   (print "\\end{document}")
+   (print "% valid-voters = " valid-voters)
+   (print "% valid-balances = " ok-balances)
+   (print "% valid-actives = " ok-actives)
+   )
+
+ (define (format-amount-tex amt)
+   (string-translate*
+    (format-amount amt)
+    '(("--" . "--{}--"))))
+
+ )

src/export-web-static.scm

@@ -44,7 +44,10 @@
 	 cal-day
 	 util-git
 	 configuration
-	 texts)
+	 texts
+	 logging
+	 qr-payment
+	 members-fees)
 
  ;; HTML entities
  (define (sanitize-html str)
@@ -87,6 +90,8 @@
      (print "dd+dt,dd+dt+dd{border-top:1px solid #8cacbb}")
      (print "dd{grid-column:2/3;font-weight:bold;margin:0px;padding-left:16px}")
      (print "footer{background:#dee7ec;border-top:1px solid #8cacbb;padding:16px}")
+     (print ".qr svg{width:100%;height:auto;max-width:10cm}")
+     (print ".qr{text-align: center}")
      (print "</style>")
      (print "</head>")
      (print "<body>")
@@ -100,10 +105,21 @@
 	    (brmember-nick mr) "</dd>")
      (print "<dt>Member ID, Variable Symbol for Payments<br>(Členské číslo, variabilní symbol plateb)</dt><dd>"
 	    (brmember-id mr) "</dd>")
-     (print "<dt>Balance in CZK<br>(Zůstatek v Kč)</dt><dd>" (caar (reverse bhs)) "</dd>")
-     (print "<dt>Account for Payments<br>(Účet pro platbu příspěvků)</dt><dd>2500079551/2010</dd>")
+     (print "<dt>Balance in CZK<br>(Zůstatek v Kč)</dt><dd>"
+	    (if (null? bhs)
+		"0"
+		(caar (reverse bhs)))
+	    "</dd>")
+     (print "<dt>Account for Payments<br>(Účet pro platbu příspěvků)</dt><dd>CZK: 2500079551/2010<br>EUR:  CZ93 2010 0000 0021 0007 9552</dd>")
      (print "</dl>")
      (print "</div>")
+     (print "<div class=\"bi qr\">")
+     (let ((fee (member-calendar-entry->fee
+		 (make-member-calendar-entry mr))))
+       (print "<h2>Payment of membership fee " fee " CZK<br/>(Platba členského příspěvku)</h2>")
+       (print (make-brmlab-qrp-svg-string
+	       fee "CZK" (brmember-id mr))))
+     (print "</div>")
      (print "<div class=\"bi\">")
      (print "<h2>Payments History</h2>")
      (print "<table>")

src/gendoc.scm

@@ -1,3 +1,27 @@
+;;
+;; gendoc.scm
+;;
+;; Generate documentation for all documented modules dynamically.
+;;
+;; 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.
+;;
 
 (import duck-extract)
 

src/hackerbase.scm

@@ -50,7 +50,10 @@
 	export-web-static
 	dokuwiki
 	racket-kwargs
-	util-string)
+	util-string
+	mailinglist
+	export-sheet
+	mbase-query)
 
 ;; Command-line options and configurable parameters
 (define -needs-bank- (make-parameter #f))
@@ -62,8 +65,10 @@
 (define -web-dir- (make-parameter #f))
 (define -normal-month- (make-parameter #t))
 (define -show-destroyed- (make-parameter #f))
+(define -show-only-active- (make-parameter #f))
 (define -notify-months- (make-parameter 1))
 (define -send-emails- (make-parameter #f))
+(define -number- (make-parameter #f))
 
 ;; Arguments parsing
 (command-line
@@ -137,6 +142,8 @@
  "Misc options:"
  (-destroyed () "Show destroyed members in -fees"
 	     (-show-destroyed- #t))
+ (-only-active () "Show only active members in -fees"
+	       (-show-only-active- #t))
  ""
  "Base Actions:"
  (-info () "Print information"
@@ -177,7 +184,14 @@
 	  (-action- 'genweb))
  (-stats (file:gnuplot-data) "Get stats for all months"
 	 (-action- 'print-stats)
+	 (-needs-bank- #t)
 	 (-fname- file:gnuplot-data))
+ (-sheet (filename gmnum) "Generate attendance sheet for given GM number"
+	 (-needs-bank- #t)
+	 (-fname- filename)
+	 (-number- gmnum)
+	 (-action- 'gen-sheet))
+	 
  ""
  "Mailman Actions:"
  (-mlsync () "Synchronize internal ML"
@@ -283,31 +297,6 @@
 	      (print "  " (car keys) ": " (length (ldict-ref status (car keys)))))
 	    (loop (cdr keys)))))))
 
-(define* (check-mailing-list mls name #:pred? (pred? #f))
-  (define ml (find-mailman-list mls name))
-  (let-values (((missing surplus)
-		(mailman-compare-members ml
-					 (mbase-active-emails MB
-							      #:suspended #t
-							      #:pred? pred?
-							      ))))
-    (if (null? (cdr ml))
-	(print "Skipping ML check - not loaded")
-	(if (and (null? missing)
-		 (null? surplus))
-	    (print (format "~a mailing list membership in sync." (string-capitalize name)))
-	    (let ()
-	      (print (format "~a mailing list:" (string-capitalize name)))
-	      (when (not (null? missing))
-		(print "  Missing: " missing))
-	      (when (not (null? surplus))
-		(print "  Outsiders: " surplus)))))))
-
-(define (rada-ml-pred? mr)
-  (or (brmember-council? mr)
-      (brmember-chair? mr)
-      (brmember-revision? mr)))
-
 ;; Perform requested action
 (case (-action-)
   ((print-info)
@@ -319,10 +308,7 @@
        (let ()
 	 (print-members-base-table MB)
 	 (newline)
-	 (check-mailing-list MLS "internal")
-	 (check-mailing-list MLS "rada"
-			     #:pred? rada-ml-pred?)
-	 (check-mailing-list MLS "rk" #:pred? brmember-revision?)
+	 (print-mailing-list-checks MB MLS)
 	 (print-git-status)))
    (newline))
   ((print-stats)
@@ -372,12 +358,16 @@
    (newline)
    (if mr
        (print-member-balances-table mr)
-       (print-members-fees-table MB (-show-destroyed-))))
+       (print-members-fees-table MB (-show-destroyed-) (-show-only-active-))))
   ((repl)
    (repl))
   ((genweb)
    (log-info "Generating static web files")
    (gen-html-members MB (-web-dir-)))
+  ((gen-sheet)
+   (log-info "Generating attendance sheet")
+   (parameterize ((current-output-port (open-output-file (-fname-))))
+     (print-attendance-sheet MB (-number-))))
   ((edit)
    (if mr
        (let ()
@@ -402,11 +392,11 @@
 	  (print "Mailman synchronization disabled with manually specified current month."))))
   ((notify)
    (let ((nmembers (members-to-notify MB (-notify-months-))))
-     (newline)
+     (stdout-newline)
      (if (null? nmembers)
 	 (print "Everyone paid on time.")
 	 (let ()
-	   (print "Notify" (-notify-months-))
+	   (stdout-print "Notify" (-notify-months-))
 	   (let loop ((lst nmembers))
 	     (when (and (not (null? lst))
 			(or (not mr)
@@ -420,8 +410,8 @@
    (print-git-status))
   ((summary)
    (if (-send-emails-)
-       (make+send-summary-email MB)
-       (make+print-summary-email MB)))
+       (make+send-summary-email MB MLS)
+       (make+print-summary-email MB MLS)))
   ((list)
    (for-each (lambda (mr)
 	       (print (brmember-nick mr)))

src/mailinglist.scm

@@ -0,0 +1,78 @@
+;;
+;; mailinglist.scm
+;;
+;; Common high-level mailinglist management procedures.
+;;
+;; 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 mailinglist))
+
+(module
+ mailinglist
+ (
+  check-mailing-list
+  print-mailing-list-checks
+
+  rada-ml-pred?
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken format)
+	 racket-kwargs
+	 mailman
+	 mbase
+	 util-string
+	 brmember)
+
+ (define* (check-mailing-list MB mls name #:pred? (pred? #f) #:suspended (suspended #f))
+   (define ml (find-mailman-list mls name))
+   (when ml
+     (let-values (((missing surplus)
+		   (mailman-compare-members ml
+					    (mbase-active-emails MB
+								 #:suspended suspended
+								 #:pred? pred?
+								 ))))
+       (if (null? (cdr ml))
+	   (print "Skipping ML check - not loaded")
+	   (if (and (null? missing)
+		    (null? surplus))
+	       (print (format "~a mailing list membership in sync." (string-capitalize name)))
+	       (let ()
+		 (print (format "~a mailing list:" (string-capitalize name)))
+		 (when (not (null? missing))
+		   (print "  Missing: " missing))
+		 (when (not (null? surplus))
+		   (print "  Outsiders: " surplus))))))))
+
+ (define (print-mailing-list-checks MB MLS)
+   (check-mailing-list MB MLS "internal" #:suspended #t)
+   (check-mailing-list MB MLS "rada"
+		       #:pred? rada-ml-pred?)
+   (check-mailing-list MB MLS "rk" #:pred? brmember-revision?))
+
+ (define (rada-ml-pred? mr)
+   (or (brmember-council? mr)
+       (brmember-chair? mr)
+       (brmember-revision? mr)))
+
+ )

src/mailman.scm

@@ -49,7 +49,6 @@
  (import scheme
 	 (chicken base)
 	 (chicken module)
-	 mailman2
 	 mailman-common
 	 util-bst-lset
 	 configuration
@@ -59,24 +58,17 @@
  ;; Syntax for simplifying export of case-version procedures
  (define-syntax define-mailman-proc
    (syntax-rules ()
-     ((_ name proc2)
+     ((_ name proc3)
       (begin
 	(export name)
 	(define (name . args)
 	  (case (*mailman-version*)
-	    ((2) (apply proc2 args))))))
-     ((_ name proc2 proc3)
-      (begin
-	(export name)
-	(define (name . args)
-	  (case (*mailman-version*)
-	    ((2) (apply proc2 args))
 	    ((3) (apply proc3 args))))))))
 
  (define-mailman-proc list-mailman-lists
-   list-mailman2-lists list-mailman3-lists)
+   list-mailman3-lists)
  (define-mailman-proc list-mailman-list-members
-   list-mailman2-list-members list-mailman3-list-members)
+   list-mailman3-list-members)
 
   ;; Loads a single mailman list as mailman structure, if
  ;; unsuccessfull, returns only a list with ML name and no member
@@ -112,9 +104,9 @@
    (assoc name lsts))
 
  (define-mailman-proc add-email-to-mailman-list
-   add-email-to-mailman2-list add-email-to-mailman3-list)
+   add-email-to-mailman3-list)
  (define-mailman-proc remove-email-from-mailman-list
-   remove-email-from-mailman2-list remove-email-from-mailman3-list)
+   remove-email-from-mailman3-list)
 
  ;; Ensures given email is in given ML
  (define (mailman-ensure-member ml email)

src/mailman2.scm

@@ -1,104 +0,0 @@
-;;
-;; mailman2.scm
-;;
-;; Mailman management interface - Mailman version 2.x support
-;;
-;; 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 mailman2))
-
-(module
- mailman2
- (
-  list-mailman2-lists
-  list-mailman2-list-members
-  
-  add-email-to-mailman2-list
-  remove-email-from-mailman2-list
-  )
-
- (import scheme
-	 (chicken base)
-	 (chicken pathname)
-	 (chicken string)
-	 (chicken sort)
-	 (chicken format)
-	 srfi-1
-	 util-bst-lset
-	 util-io
-	 mailman-common
-	 configuration)
-
- ;; Returns full path to given mailman binary
- (define (mailman-bin bin)
-   (make-pathname (*mailman2-bin*) bin))
-
- ;; Mailman-specific process output lines capture
- (define (get-mailman-output-lines bin . args)
-   (apply
-    get-process-output-lines
-    (mailman-bin bin)
-    args))
-
- ;; Sends all lines to the process
- (define (mailman-send/recv bin args . lines)
-   (apply
-    process-send/recv
-    (mailman-bin bin)
-    args
-    lines))
-    
- ;; Returns the list of available lists
- (define (list-mailman2-lists)
-   (get-mailman-output-lines "list_lists" "-b"))
-
- ;; Returns the list of members of given list
- (define (list-mailman2-list-members lst)
-   (sort
-    (get-mailman-output-lines "list_members" lst)
-    string-ci<?))
-
- ;; Adds given email to given listname
- (define (add-email-to-mailman2-list listname email)
-   (print "Add " email " to " listname ".")
-   (let ((result
-	  (mailman-send/recv
-	   "add_members"
-	   (list "-r" "-" listname)
-	   email)))
-     (let loop ((lines result))
-       (when (not (null? lines))
-	 (print " | " (car lines))
-	 (loop (cdr lines))))))
-
- ;; Removes given email from given listname
- (define (remove-email-from-mailman2-list listname email)
-   (print "Remove " email " from " listname ".")
-   (let ((result
-	  (get-mailman-output-lines
-	   "remove_members" listname
-	   (sprintf "~A" email))))
-     (let loop ((lines result))
-       (when (not (null? lines))
-	 (print " | " (car lines))
-	 (loop (cdr lines))))))
-
- )

src/mailman3-sql.scm

@@ -45,7 +45,11 @@
  ;; Returns (possibly cached) SQLite3 DB handle
  (define (mailman3-db)
    (when (not (*cached-mailman3-db*))
-     (*cached-mailman3-db* (open-database (*mailman3-sql-path*))))
+     (*cached-mailman3-db*
+      (let ((handler (make-busy-timeout 2000)))
+	(let ((db (open-database (*mailman3-sql-path*))))
+	  (set-busy-handler! db handler)
+	  db))))
    (*cached-mailman3-db*))
 
  ;; Returns the list of mailman3 mailinglists by querying te

src/mbase-query.scm

@@ -0,0 +1,123 @@
+;;
+;; mbase-query.scm
+;;
+;; Queries of various mbase derived attributes.
+;;
+;; ISC License
+;;
+;; Copyright 2023-2025 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 mbase-query))
+
+(module
+    mbase-query
+    (
+     mbase-info
+     mbase-stats
+     )
+
+  (import scheme
+	  (chicken base)
+	  srfi-1
+	  mbase
+	  brmember
+	  util-bst-ldict
+	  primes
+	  cal-period
+	  cal-month
+	  members-fees
+	  members-payments)
+
+  (define (members-base-oldest-month mb)
+    (make-cal-month 2015 1))
+
+  (define (members-average-age mrs)
+    (let* ((ages (map brmember-age mrs))
+	   (valid (filter (lambda (x) x) ages))
+	   (num (length valid))
+	   (sum (foldl + 0 valid)))
+      (exact->inexact (/ sum num))))
+
+  ;; Returns dictionary with statistics about the members base.
+  (define (mbase-info mb-arg)
+    (let* ((members (find-members-by-predicate mb-arg brmember-usable?))
+	   (di0 (make-ldict))
+	   (di1 (ldict-set di0 'invalid
+			   (filter (compose not is-4digit-prime? brmember-id) members)))
+	   (active-members (filter brmember-active? members))
+	   (di2 (ldict-set di1 'active
+			   active-members))
+	   (di3 (ldict-set di2 'suspended
+			   (filter brmember-suspended? members)))
+	   (di4 (ldict-set di3 'students
+			   (filter brmember-student? members)))
+	   (di5 (ldict-set di4 'destroyed
+			   (filter brmember-destroyed? members)))
+	   (di6 (ldict-set di5 'month (*current-month*)))
+	   (di7 (ldict-set di6 'total members))
+	   (di8 (ldict-set di7 'problems
+			   (find-members-by-predicate mb-arg brmember-has-problems?)))
+	   (di9 (ldict-set di8 'expected
+			   (get-expected-income mb-arg)))
+	   (mbals (map member-total-balance active-members))
+	   (di10 (ldict-set di9 'balance
+			    (foldl + 0 mbals)))
+	   (di11 (ldict-set di10 'advance
+			    (foldl + 0
+				   (map (lambda (v)
+					  (max 0 v))
+					mbals))))
+	   (di12 (ldict-set di11 'debt
+			    (foldl + 0
+				   (map (lambda (v)
+					  (min 0 v))
+					mbals))))
+	   (di13 (ldict-set di12 'age
+			    (members-average-age active-members)))
+	   )
+      di13))
+
+  ;; Returns a list two lists: keys, data.
+  ;; Each data record contains values for all keys.
+  (define (mbase-stats mb)
+    (let ((keys
+	   '(month
+	     total active suspended students destroyed invalid
+	     expected balance advance debt
+	     age
+	     )))
+      (let mloop ((data '())
+		  (month (members-base-oldest-month mb)))
+	(if (cal-month<=? month (*current-month*))
+	    (let ((bi (with-current-month month
+					  (mbase-info mb))))
+	      (let kloop ((row (list (ldict-ref bi 'month)))
+			  (keys (cdr keys)))
+		(if (null? keys)
+		    (mloop (cons (reverse row) data)
+			   (cal-month-add month 1))
+		    (kloop (cons (let ((val (ldict-ref bi (car keys))))
+				   (if (list? val)
+				       (length val)
+				       val))
+				 row)
+			   (cdr keys)))))
+	    (list keys (reverse data))))))
+
+  )

src/mbase.scm

@@ -50,8 +50,6 @@
   mbase-update-by-id
   mbase-update
 
-  mbase-stats
-
   mbase-add-unpaired
   mbase-unpaired
 
@@ -207,47 +205,6 @@
 				    (proc mr)
 				    mr)))))
 
- ;; Returns dictionary with statistics about the members base.
- (define (mbase-info mb-arg)
-   (let* ((members (find-members-by-predicate mb-arg brmember-usable?))
-	  (di0 (make-ldict))
-	  (di1 (ldict-set di0 'invalid
-			  (filter (compose not is-4digit-prime? brmember-id) members)))
-	  (di2 (ldict-set di1 'active
-			  (filter brmember-active? members)))
-	  (di3 (ldict-set di2 'suspended
-			  (filter brmember-suspended? members)))
-	  (di4 (ldict-set di3 'students
-			  (filter brmember-student? members)))
-	  (di5 (ldict-set di4 'destroyed
-			  (filter brmember-destroyed? members)))
-	  (di6 (ldict-set di5 'month (*current-month*)))
-	  (di7 (ldict-set di6 'total members))
-	  (di8 (ldict-set di7 'problems
-			  (find-members-by-predicate mb-arg brmember-has-problems?))))
-     di8))
-
- (define (members-base-oldest-month mb)
-   (make-cal-month 2015 1))
-
- ;; Returns a list two lists: keys, data.
- ;; Each data record contains values for all keys.
- (define (mbase-stats mb)
-   (let ((keys '(month total active suspended students destroyed invalid)))
-     (let mloop ((data '())
-		 (month (members-base-oldest-month mb)))
-       (if (cal-month<=? month (*current-month*))
-	   (let ((bi (with-current-month month
-					 (mbase-info mb))))
-	     (let kloop ((row (list (ldict-ref bi 'month)))
-			 (keys (cdr keys)))
-	       (if (null? keys)
-		   (mloop (cons (reverse row) data)
-			  (cal-month-add month 1))
-		   (kloop (cons (length (ldict-ref bi (car keys))) row)
-			  (cdr keys)))))
-	   (list keys (reverse data))))))
-
  ;; Adds unpaired transaction to given members-base
  (define (mbase-add-unpaired mb tr)
    (ldict-set mb 'unpaired

src/members-fees.scm

@@ -30,6 +30,7 @@
  (
   lookup-member-fee
   member-calendar
+  make-member-calendar-entry
   member-calendar-first-month
   member-calendar-last-month
   member-calendar-query
@@ -40,12 +41,15 @@
   member-calendar->table
   members-summary
   member-calendar-entry->fee
+  get-expected-income
+  get-expected-income-string
   )
 
  (import scheme
 	 (chicken base)
 	 (chicken format)
 	 (chicken sort)
+	 (chicken string)
 	 srfi-1
 	 configuration
 	 brmember
@@ -82,12 +86,17 @@
        (if (cal-month>? cm last-month)
 	   (reverse cal)
 	   (loop (cal-month-add cm)
-		 (cons (list cm
-			     (with-current-month
-			      cm
-			      (brmember-flags mr)))
+		 (cons (with-current-month
+			cm
+			(make-member-calendar-entry mr))
 		       cal))))))
 
+ ;; Assumes current-month is specified correctly
+ (define (make-member-calendar-entry mr)
+   (list (*current-month*)
+	 (brmember-flags mr)
+	 (brmember-spec-fee mr)))
+
  ;; Returns the first month of the calendar
  (define (member-calendar-first-month mc)
    (caar mc))
@@ -111,23 +120,29 @@
 		   (ansi-string #:bgblack "\xc2\xa0\xc2\xa0") ; Destroyed
 		   (if (member 'student (cadr e))
 		       (ansi-string #:bgyellow "\xc2\xa0\xc2\xa0") ; Student
-		       (ansi-string #:bggreen "\xc2\xa0\xc2\xa0")))) ; Normal
+		       (if (caddr e)
+			   (ansi-string #:bgblue (format "~a" (caddr e)))
+			   (ansi-string #:bggreen "\xc2\xa0\xc2\xa0"))))) ; Normal
 	   "\xc2\xa0\xc2\xa0") ; Nonexistent - should not happen
        "\xc2\xa0\xc2\xa0")) ; Nonexistent
 
  ;; Converts the entry into the fee
  (define (member-calendar-entry->fee e)
-   (if e
-       (if (member 'existing (cadr e))
-	   (if (member 'suspended (cadr e))
-	       0 ; Suspended
-	       (if (member 'destroyed (cadr e))
-		   0 ; Destroyed
-		   (if (member 'student (cadr e))
-		       (lookup-member-fee 'student) ; Student
-		       (lookup-member-fee 'regular)))) ; Normal
-	   0) ; Nonexistent - should not happen
-       0)) ; Nonexistent
+   (with-current-month
+    (car e)
+    (if e
+	(if (member 'existing (cadr e))
+	    (if (member 'suspended (cadr e))
+		0			; Suspended
+		(if (member 'destroyed (cadr e))
+		    0			; Destroyed
+		    (if (member 'student (cadr e))
+			(lookup-member-fee 'student) ; Student
+			(if (caddr e)
+			    (caddr e)
+			    (lookup-member-fee 'regular))))) ; Normal
+	    0)			     ; Nonexistent - should not happen
+	0))) ; Nonexistent
 
  ;; Converts the calendar into a table where rows represent years and
  ;; contain the year in the first cell and 12 cells for months after
@@ -193,5 +208,39 @@
 		    (+ (cdr acc) (if (brmember-student? mr) 0 1))))
 	    (cons 0 0)
 	    members)))
+
+ (define (get-expected-income mb)
+   (let* ((flst
+	   (map (compose member-calendar-entry->fee make-member-calendar-entry)
+		(find-members-by-predicate mb brmember-active?)))
+	  (amts (sort (delete-duplicates flst) <))
+	  (sums
+	   (map
+	    (lambda (amt)
+	      (cons amt
+		    (length (filter (lambda (v) (= v amt)) flst))))
+	    amts)))
+     (foldl + 0 (map (lambda (p) (* (car p) (cdr p))) sums))))
+
+ (define (get-expected-income-string mb)
+   (let* ((flst
+	   (map (compose member-calendar-entry->fee make-member-calendar-entry)
+		(find-members-by-predicate mb brmember-active?)))
+	  (amts (sort (delete-duplicates flst) <))
+	  (sums
+	   (map
+	    (lambda (amt)
+	      (cons amt
+		    (length (filter (lambda (v) (= v amt)) flst))))
+	    amts)))
+     (string-append
+      "Expected income: "
+      (string-intersperse (map
+			   (lambda (p)
+			     (format "~A*~A" (cdr p) (car p)))
+			   sums)
+			  " + ")
+      " = "
+      (number->string (foldl + 0 (map (lambda (p) (* (car p) (cdr p))) sums))))))
  
  )

src/members-payments.scm

@@ -90,12 +90,21 @@
 				   (substring msg 0 ci2)
 				   msg))
 			  (ci3 (substring-index "NULL" msg))
-			  (vs3 (if ci3
+			  (vs3 (if (and ci3
+					(>= (string-length msg) (+ ci3 8)))
 				   (substring msg (+ ci3 4) (+ ci3 4 4))
-				   msg)))
+				   msg))
+			  (ci4 (substring-index "VS" msg))
+			  (vs4 (if (and ci4
+					(>= (string-length msg) (+ ci4 6)))
+				   (substring msg (+ ci4 2) (+ ci4 6))
+				   msg))
+			  )
 		     (or (string->number vs1)
 			 (string->number vs2)
-			 (string->number vs3))))))
+			 (string->number vs3)
+			 (string->number vs4)
+			 )))))
 	 varsym-id)))
 
  ;; Special comparator (originally with JendaSAP hack)

src/members-print.scm

@@ -67,7 +67,8 @@
 	 cal-format
 	 util-git
 	 cal-day
-	 racket-kwargs)
+	 racket-kwargs
+	 tiocgwinsz)
 
  (define *show-payments-count* (make-parameter 36))
 
@@ -96,7 +97,7 @@
 	  (body (map (lambda (k)
 		       (let ((v (ldict-ref info k)))
 			 (case k
-			   ((card desfire)
+			   ((card desfire phone)
 			    (list k 
 				  (table->string
 				   (map
@@ -128,8 +129,25 @@
 				   (ptbl (table->string
 					  pdata
 					  #:border '(((#:right light) ... none) ...))))
-			      ;;(print pdata)
-			      ;;(write ptbl)(newline)
+			      (list k ptbl)))
+			   ((fee)
+			    (let* ((pdata
+				    (cons
+				     (list "Amount" "Since" "Until")
+				     (map
+				      (lambda (p)
+					(list
+					 (format "\t~A" (car (cal-period-scomment p)))
+					 (string-append (cal-day/month->string
+							 (cal-period-since p)) " "
+							 (or (cadr (cal-period-scomment p)) ""))
+					 (string-append (cal-day/month->string
+							 (cal-period-before p)) " "
+							 (or (cal-period-bcomment p) ""))))
+				      v)))
+				   (ptbl (table->string
+					  pdata
+					  #:border '(((#:right light) ... none) ...))))
 			      (list k ptbl)))
 			   (else
 			    (if v
@@ -160,7 +178,6 @@
 			(list (list (ansi-string #:red "DokuWiki")
 				    (ansi-string #:red "---")))))
 	  (result (filter identity (append head body mailman dokuwiki))))
-     ;;(write result)(newline)
      (table->string result
 		    #:border '(((#:bottom #:right light) ... (#:bottom light))
 			       ...
@@ -267,11 +284,9 @@
  (define (members-table-row a:? label mrs fmt)
    (list (string-append "\t" a:? label)
 	 (length mrs)
-	 (ansi-paragraph-format
-	  (member-records->string
-	   (sort mrs brmember<?)
-	   fmt)
-	  60)))
+	 (member-records->string
+	  (sort mrs brmember<?)
+	  fmt)))
 
  ;; Generic table of members attributes
  (define (members-attrs-table mrs fmt hdr row)
@@ -301,102 +316,103 @@
 
  ;; Prints nicely aligned members base info
  (define (print-members-base-table mb)
-   (let* ((total-count (length
-			(find-members-by-predicate mb brmember-usable?)))
-	  (invalid-mrs (find-members-by-predicate
-			mb
-			(compose not is-4digit-prime? brmember-id)))
-	  (suspended-mrs (find-members-by-predicate mb brmember-suspended?))
-	  (debtor-mrs (sort
-		       (members-to-notify mb 3)
-		       brmember<?))
-	  (soon-expire-mrs (sort
-			    (find-members-by-predicate
-			     mb
-			     (brmember-suspended-for 21 24))
-			    brmember<?)))
-     (print "Known members: " total-count)
-     (newline)
-     (print
-      (table->string
-       (filter
-	identity
-	(list (list "Type" "Count" "List")
-	      (members-pred-table-row mb
-				      (ansi-string #:yellow "Chair:")
-				      brmember-chair?
-				      "~N")
-	      (members-pred-table-row mb
-				      (ansi-string #:yellow "Council:")
-				      brmember-council?
-				      "~N")
-	      (members-pred-table-row mb
-				      (ansi-string #:yellow "Revision:")
-				      brmember-revision?
-				      "~N")
-	      (members-pred-table-row mb
-				      (ansi-string #:yellow "Grant:")
-				      brmember-grant?
-				      "~N")
-	      (members-pred-table-row mb
-				      (string-append a:success "Active:")
-				      brmember-active?
-				      "~N~E")
-	      (members-pred-table-row mb
-				      (string-append a:highlight "Students:")
-				      brmember-student?
-				      "~N~E")
-	      (members-table-row a:warning "Suspended:" suspended-mrs "~N~E (~S)")
-	      (members-pred-table-row mb
-				      (string-append a:warning "Destroyed:")
-				      brmember-destroyed?
-				      "~N~E")
-	      (let ((suspended2 (filter
-				 (lambda (mr)
-				   (>= (brmember-suspended-months mr)
-				       member-suspend-max-months))
-				 suspended-mrs)))
-		(if (null? suspended2)
+   (let-values (((rows columns) (term-size)))
+     (let* ((total-count (length
+			  (find-members-by-predicate mb brmember-usable?)))
+	    (invalid-mrs (find-members-by-predicate
+			  mb
+			  (compose not is-4digit-prime? brmember-id)))
+	    (suspended-mrs (find-members-by-predicate mb brmember-suspended?))
+	    (debtor-mrs (sort
+			 (members-to-notify mb 3)
+			 brmember<?))
+	    (soon-expire-mrs (sort
+			      (find-members-by-predicate
+			       mb
+			       (brmember-suspended-for 21 24))
+			      brmember<?)))
+       (print "Known members: " total-count)
+       (newline)
+       (print
+	(table->string
+	 (filter
+	  identity
+	  (list (list "Type" "Count" "List")
+		(members-pred-table-row mb
+					(ansi-string #:yellow "Chair:")
+					brmember-chair?
+					"~N")
+		(members-pred-table-row mb
+					(ansi-string #:yellow "Council:")
+					brmember-council?
+					"~N")
+		(members-pred-table-row mb
+					(ansi-string #:yellow "Revision:")
+					brmember-revision?
+					"~N")
+		(members-pred-table-row mb
+					(ansi-string #:yellow "Grant:")
+					brmember-grant?
+					"~N")
+		(members-pred-table-row mb
+					(string-append a:success "Active:")
+					brmember-active?
+					"~N~E")
+		(members-pred-table-row mb
+					(string-append a:highlight "Students:")
+					brmember-student?
+					"~N~E")
+		(members-table-row a:warning "Suspended:" suspended-mrs "~N~E (~S)")
+		(members-pred-table-row mb
+					(string-append a:warning "Destroyed:")
+					brmember-destroyed?
+					"~N~E")
+		(let ((suspended2 (filter
+				   (lambda (mr)
+				     (>= (brmember-suspended-months mr)
+					 member-suspend-max-months))
+				   suspended-mrs)))
+		  (if (null? suspended2)
+		      #f
+		      (members-table-row (ansi #:magenta) "Suspended (long):" suspended2 "~N (~S)")))
+		(if (null? soon-expire-mrs)
 		    #f
-		    (members-table-row (ansi #:magenta) "Suspended (long):" suspended2 "~N (~S)")))
-	      (if (null? soon-expire-mrs)
-		  #f
-		  (members-table-row (ansi #:magenta #:bold) "Expire Soon:"
-				     soon-expire-mrs "~N (~S)"))
-	      (members-pred-table-row mb
-				      (ansi-string #:red #:bold "Prolems:")
-				      brmember-has-problems?
-				      "~N~E ~A")
-	      (if (null? debtor-mrs)
-		  #f
-		  (list (ansi-string "\t" #:magenta #:bold "Debtors:")
-			(format "~A" (length debtor-mrs))
-			(table->string
-			 (append
-			  (members-attrs-table debtor-mrs
-					       brmember-format
-					       (list "Name" "Balance" "Last Payment")
-					       (list "~N" "\t~B" "~L"))
-			  (list
-			   (list
-			    "Total"
-			    (format
-			     "\t~A"
-			     (foldr
-			      (lambda (v a)
-				(+ (member-total-balance v) a))
-			      0
-			      debtor-mrs)))))
-			 #:border '(((#:bottom #:right light) ... (#:bottom light))
-				    ((#:right light) ... none) ...
-				    ((#:top #:right light) ... (#:top light)))
-			 #:ansi-reset? #t)))
-	      ))
-       #:border '(((#:bottom #:right light) ... (#:bottom light))
-		  ...
-		  ((#:right light) ... none))
-       #:width 70
-       #:ansi-reset? #t)))
+		    (members-table-row (ansi #:magenta #:bold) "Expire Soon:"
+				       soon-expire-mrs "~N (~S)"))
+		(members-pred-table-row mb
+					(ansi-string #:red #:bold "Problems:")
+					brmember-has-problems?
+					"~N~E ~A")
+		(if (null? debtor-mrs)
+		    #f
+		    (list (ansi-string "\t" #:magenta #:bold "Debtors:")
+			  (format "~A" (length debtor-mrs))
+			  (table->string
+			   (append
+			    (members-attrs-table debtor-mrs
+						 brmember-format
+						 (list "Name" "Balance" "Last Payment")
+						 (list "~N" "\t~B" "~L"))
+			    (list
+			     (list
+			      "Total"
+			      (format
+			       "\t~A"
+			       (foldr
+				(lambda (v a)
+				  (+ (member-total-balance v) a))
+				0
+				debtor-mrs)))))
+			   #:border '(((#:bottom #:right light) ... (#:bottom light))
+				      ((#:right light) ... none) ...
+				      ((#:top #:right light) ... (#:top light)))
+			   #:ansi-reset? #t)))
+		))
+	 #:border '(((#:bottom #:right light) ... (#:bottom light))
+		    ...
+		    ((#:right light) ... none))
+	 #:width (- columns 10)
+	 #:ansi-reset? #t))))
    (let ((pmrs (find-members-by-predicate mb brmember-file-has-problems?)))
      (when (not (null? pmrs))
        (newline)
@@ -471,11 +487,25 @@
 	      ")"))))
 
  ;; Prints summary table of all fees and credits for all members
- (define (print-members-fees-table MB . ds)
-   (let ((destroyed? (if (null? ds)
+ (define (print-members-fees-table MB . dsa)
+   (let ((destroyed? (if (null? dsa)
 			 #f
-			 (car ds))))
-     (let* ((members ;; Pass 1
+			 (car dsa)))
+	 (only-active? (if (or (null? dsa)
+			       (null? (cdr dsa)))
+			   #f
+			   (cadr dsa))))
+     (let* ((raw-members
+	     (sort
+	      (if destroyed?
+		  (find-members-by-predicate MB (lambda x #t))
+		  (if only-active?
+		      (find-members-by-predicate MB (lambda (mr)
+						      (brmember-active? mr)))
+		      (find-members-by-predicate MB (lambda (mr)
+						      (not (brmember-destroyed? mr))))))
+	      brmember<?))
+	    (members ;; Pass 1
 	     (map
 	      (lambda (mr)
 		(let* ((balance (member-balance mr))
@@ -496,13 +526,15 @@
 			payment
 			total
 			balance
+			(let ((spec-fee (brmember-spec-fee mr)))
+			  (if spec-fee
+			      spec-fee
+			      (member-calendar-entry->fee
+			       (list (*current-month*)
+				     (brmember-flags mr)
+				     spec-fee))))
 			)))
-	      (sort
-	       (if destroyed?
-		   (find-members-by-predicate MB (lambda x #t))
-		   (find-members-by-predicate MB (lambda (mr)
-						   (not (brmember-destroyed? mr)))))
-	       brmember<?)))
+	      raw-members))
 	    (balances (map (lambda (m)
 			     (list-ref m 6))
 			   members)))
@@ -511,6 +543,7 @@
 	 (cons
 	  (list (ansi-string #:bgblue #:brightyellow #:bold "Member")
 		(ansi-string #:bgblue #:brightyellow #:bold "Status")
+		(ansi-string #:bgblue #:brightyellow #:bold "Current")
 		(ansi-string #:bgblue #:brightyellow #:bold "Fees")
 		(ansi-string #:bgblue #:brightyellow #:bold "Credit")
 		(ansi-string #:bgblue #:brightyellow #:bold "Payments")
@@ -521,6 +554,7 @@
 	      (let ((total (list-ref member 5)))
 		(list (list-ref member 0)
 		      (list-ref member 1)
+		      (sprintf "\t~A" (list-ref member 7))
 		      (sprintf "\t~A" (list-ref member 2))
 		      (sprintf "\t~A" (list-ref member 3))
 		      (sprintf "\t~A" (list-ref member 4))
@@ -537,9 +571,11 @@
 	   (let* ((fees (foldl + 0 (map (lambda (b) (ldict-ref b 'fees)) balances)))
 		  (credit (foldl + 0 (map (lambda (b) (ldict-ref b 'credit)) balances)))
 		  (payment (foldl + 0 (map (lambda (b) (ldict-ref b 'payment)) balances)))
-		  (total (- (+ credit payment) fees)))
+		  (total (- (+ credit payment) fees))
+		  (current-total (foldl + 0 (map (lambda (m) (list-ref m 7)) members))))
 	     (list (list (ansi-string #:bold "Total")
 			 ""
+			 (ansi-string "\t" #:bold (sprintf "~A" current-total))
 			 (ansi-string "\t" #:bold (sprintf "~A" fees))
 			 (ansi-string "\t" #:bold (sprintf "~A" credit))
 			 (ansi-string "\t" #:bold (sprintf "~A" payment))
@@ -570,19 +606,7 @@
 		     (map (lambda (member)
 			    (min 0 (list-ref member 5)))
 			  members)))
-       (let* ((ns (foldl (lambda (acc member)
-			   (cons (+ (car acc) (if (eq? 'student (cadr member)) 1 0))
-				 (+ (cdr acc) (if (eq? 'active (cadr member)) 1 0))))
-			 (cons 0 0)
-			 members))
-	      (students (car ns))
-	      (full (cdr ns)))
-	 (print "Expected income: "
-		(+ (* (lookup-member-fee 'normal) full)
-		   (* (lookup-member-fee 'student) students))
-		" (" full " full members + " students " students)"))
-       )
-     ))
+       (print (get-expected-income-string MB)))))
 
  (define (unpaired-table mb . args)
    (apply

src/notifications.scm

@@ -40,6 +40,7 @@
 	 (chicken format)
 	 (chicken string)
 	 (chicken sort)
+	 (chicken port)
 	 brmember
 	 util-mail
 	 util-bst-ldict
@@ -54,7 +55,8 @@
 	 table
 	 bank-account
 	 logging
-	 srfi-1)
+	 srfi-1
+	 mailinglist)
 
  ;; Prints email to the console
  (define (print-notification-email em)
@@ -142,16 +144,14 @@
      (send-notification-email em)))
 
  ;; Summary email of membership fees payments
- (define (summary-email-body mb)
+ (define (summary-email-body mb mls)
    (let* ((mbs (members-summary mb))
 	  (students (car mbs))
 	  (full (cdr mbs))
 	  (income (+ (* (lookup-member-fee 'normal) full)
 		     (* (lookup-member-fee 'student) students)))
 	  (income-lst
-	   (list (format "Expected income: ~A CZK" income)
-		 (format "  ~A full members" full)
-		 (format "  ~A students" students)))
+	   (list (get-expected-income-string mb)))
 	  (unpaired (mbase-unpaired mb))
 	  (unpaired-lst
 	   (if (null? unpaired)
@@ -160,6 +160,30 @@
 		(list ""
 		      "Unpaired transactions:")
 		(unpaired-table mb #:border-style 'ascii))))
+	  (soonexps (sort
+		     (find-members-by-predicate
+		      mb
+		      (brmember-suspended-for 21 24))
+		     brmember<?))
+	  (soonexps-lst
+	   (if (null? soonexps)
+	       '()
+	       (list ""
+		     (format "Expiring members (~A): ~A"
+			     (length soonexps)
+			     (string-intersperse
+			      (map
+			       (lambda (mr)
+				 (brmember-format "~N (~S)" mr))
+			       soonexps)
+			      ",")))))
+	  (mlcheck-lst
+	   (cons ""
+		 (string-split
+		  (with-output-to-string
+		    (lambda ()
+		      (print-mailing-list-checks mb mls)))
+		  "\n")))
 	  (debtors (sort
 		    (members-to-notify mb 1)
 		    brmember<?))
@@ -256,6 +280,8 @@
 		       ", "))))))
      (append income-lst
 	     unpaired-lst
+	     soonexps-lst
+	     mlcheck-lst
 	     debtors-lst
 	     boring-lst
 	     dw-lst
@@ -266,21 +292,21 @@
 		   ))))
 
  ;; Creates the summary email structure
- (define (make-summary-email mb)
+ (define (make-summary-email mb mls)
    (make-ldict
     `((to . ,(*summary-mailto*))
       (subject . ,(format "Členské příspěvky ~A"
 			  (today/iso)))
-      (body . ,(summary-email-body mb)))))
+      (body . ,(summary-email-body mb mls)))))
 
  ;; Just print to standard output
- (define (make+print-summary-email mb)
-   (let ((em (make-summary-email mb)))
+ (define (make+print-summary-email mb mls)
+   (let ((em (make-summary-email mb mls)))
      (print-notification-email em)))
 
  ;; Actually send emails
- (define (make+send-summary-email mr)
-   (let ((em (make-summary-email mr)))
+ (define (make+send-summary-email mr mls)
+   (let ((em (make-summary-email mr mls)))
      (send-notification-email em)))
 
  )

src/qr-payment.scm

@@ -0,0 +1,104 @@
+;;
+;; qr-payment.scm
+;;
+;; QR payment generator.
+;;
+;; ISC License
+;;
+;; Copyright 2023-2025 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 qr-payment))
+
+(module
+    qr-payment
+    (
+     make-qrp
+     make-brmlab-qrp
+     make-brmlab-qrp-svg-string
+     )
+
+  (import scheme
+	  (chicken format)
+	  (chicken string)
+	  (chicken base)
+	  util-io)
+
+  (define (make-empty-qrp . vs)
+    (let ((v (if (null? vs) "1.0" (car vs))))
+      (list v "SPD")))
+
+  (define (add-field-to-qrp qrp key value)
+    (cons (format "~A:~A" key value)
+	  qrp))
+
+  (define (serialize-qrp qrp)
+    (string-intersperse (reverse qrp) "*"))
+
+  (define (ensure-amount-format amt)
+    (let* ((n (if (string? amt)
+		  (string->number amt)
+		  amt))
+	   (s (number->string n))
+	   (f (string-split s "."))
+	   (i? (null? (cdr f))))
+      (format "~A.~A"
+	      (car f)
+	      (if i?
+		  "00"
+		  (substring
+		   (string-append (cadr f) "0")
+		   0 2)))))
+
+  (define (make-qrp iban amt cc vs msg)
+    (let loop ((keys '(ACC AM CC MSG X-VS))
+	       (vals (list iban (ensure-amount-format amt) cc msg vs))
+	       (qrp (make-empty-qrp)))
+      (if (null? keys)
+	  (serialize-qrp qrp)
+	  (loop (cdr keys)
+		(cdr vals)
+		(add-field-to-qrp qrp (car keys) (car vals))))))
+
+  (define (make-brmlab-qrp amt cc vs)
+    (let ((iban (if (equal? cc "CZK")
+		    "CZ0520100000002500079551"
+		    (if (equal? cc "EUR")
+			"CZ9320100000002100079552"
+			(error "Invalid currency!")))))
+      (make-qrp iban amt cc vs "Brmlab")))
+
+  (define (qrp-create-svg-string qrps)
+    (let-values
+	(((ec ol)
+	  (get-process-exit+output-lines
+	   "qrencode"
+	   "-t" "svg"
+	   "--inline"
+	   "-o" "-"
+	   "-l" "M"
+	   qrps)))
+      (if (eq? ec 0)
+	  (string-intersperse ol "\n")
+	  #f)))
+
+  (define (make-brmlab-qrp-svg-string amt cc vs)
+    (qrp-create-svg-string
+     (make-brmlab-qrp amt cc vs)))
+
+  )

src/sgr-block.scm

@@ -366,7 +366,6 @@
 			    slw))
 		   state)))
        (let ((sln (sgr-list-neutralize sl)))
-	 ;;(write sln)(newline)
 	 (values (list sln) initial-state))))
 
  ;; Renders all the lines and appends the resulting blocks

src/specification.scm

@@ -39,7 +39,8 @@
  ;; Convert into lookups - a list of (list period regular student)
  (define member-fees-lookup-table
    (make-cal-period-lookup-table
-    '(((2010 1) 500 250))))
+    '(((2010 1) 500 250)
+      ((2024 1) 1000 250))))
 
  ;; Exchange rates
  (define exchange-rates-lookup-table

src/table-processor.scm

@@ -204,8 +204,6 @@
 	      (tbl1 (render-cells-widths ptbl col-widths))
 	      ;;(_ (print tbl1))
 	      (tbl2 (map expand-row-height tbl1)))
-	 ;;(write tbl1)(newline)
-	 ;;(write tbl2)(newline)
 	 ;; Just return the result - both the table and cached column widths
 	 (values tbl2
 		 col-widths))))

src/table.scm

@@ -88,7 +88,6 @@
 	    (borders (expand-table-style border-spec num-columns num-rows))
 	    (col-separators (table-col-separators? borders))
 	    (rows (merge-rows ptbl borders col-separators unicode?)))
-       ;;(write rows)(newline)
        (let loop ((rows rows)
 		  (borders borders)
 		  (res '())

src/texts.scm

@@ -5,7 +5,7 @@
 ;;
 ;; ISC License
 ;;
-;; Copyright 2023 Brmlab, z.s.
+;; Copyright 2023-2025 Brmlab, z.s.
 ;; Dominik Pantůček <dominik.pantucek@trustica.cz>
 ;;
 ;; Permission to use, copy, modify, and/or distribute this software
@@ -39,7 +39,7 @@
 	 (chicken format))
 
  ;; Short banner
- (define banner-line "HackerBase 1.13 (c) 2023 Brmlab, z.s.")
+ (define banner-line "HackerBase 1.19-dev (c) 2023-2025 Brmlab, z.s.")
 
  ;; Banner source with numbers for ANSI CSI SGR
  (define banner-source "

src/tiocgwinsz.scm

@@ -0,0 +1,63 @@
+;;
+;; tiocgwinsz.scm
+;;
+;; Get size of current terminal.
+;;
+;; 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 tiocgwinsz))
+
+(import duck)
+
+(foreign-declare "#include <sys/ioctl.h>")
+
+(module*
+ tiocgwinsz
+ #:doc ("TTY terminal size support.")
+ (
+  term-size
+  )
+
+ (import scheme
+	 (chicken foreign)
+	 (chicken bitwise))
+
+ (define tiocgwinsz-ioctl
+   (foreign-lambda*
+    int ()
+    "
+struct winsize wss;
+if (ioctl(0, TIOCGWINSZ, &wss) == 0) {
+  C_return(wss.ws_row*65536+wss.ws_col);
+} else {
+  C_return(0);
+}
+"
+    ))
+
+ (define/doc (term-size)
+   ("Returns the number of terminal rows and columns.")
+   (let ((res (tiocgwinsz-ioctl)))
+     (values 
+      (arithmetic-shift res -16)
+      (bitwise-and res #xffff))))
+
+ )

src/util-bst-bdict.scm

@@ -1,3 +1,27 @@
+;;
+;; util-bst-bdict.scm
+;;
+;; BST-based number dictionary.
+;;
+;; 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 util-bst-bdict))
 

src/util-bst-ldict.scm

@@ -1,3 +1,27 @@
+;;
+;; util-bst-ldict.scm
+;;
+;; BST-based symbol dictionary.
+;;
+;; 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 util-bst-ldict))
 

src/util-bst-lset.scm

@@ -1,3 +1,27 @@
+;;
+;; util-bst-lset.scm
+;;
+;; BST-based set implementation.
+;;
+;; 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 util-bst-lset))
 

src/util-bst.scm

@@ -1,3 +1,27 @@
+;;
+;; util-bst.scm
+;;
+;; Underlying BST implementation for sets and dictionaries.
+;;
+;; 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 util-bst))
 
@@ -262,10 +286,12 @@
        (call/cc
 	(lambda (cc)
 	  (set! break cc)
-	  (if resume
-	      (resume '())
-	      (bst-iter-kv bst yield))
-	  #f)))))
+	  (cond (resume
+		 (resume '())
+		 (break #f))
+		(else
+		 (bst-iter-kv bst yield)
+		 (break #f))))))))
 
  (define/doc (bst-keys bst)
    ("Returns all the keys contained in given dictionary.")

src/util-mail.scm

@@ -5,7 +5,7 @@
 ;;
 ;; ISC License
 ;;
-;; Copyright 2023 Brmlab, z.s.
+;; Copyright 2023-2024 Brmlab, z.s.
 ;; Dominik Pantůček <dominik.pantucek@trustica.cz>
 ;;
 ;; Permission to use, copy, modify, and/or distribute this software
@@ -39,6 +39,8 @@
 	 (chicken base)
 	 (chicken keyword)
 	 (chicken string)
+	 (chicken irregex)
+	 (chicken format)
 	 util-io
 	 util-utf8
 	 util-string
@@ -61,6 +63,14 @@ sent to the address stored within.")
 		      "?=")
        subj))
 
+ ;; Extracts only usernam@domain from given full RFC email address
+ (define (extract-email-email str)
+   (let* ((irr (irregex "(?:\"?([^\"]*)\"?\\s)?(?:<?(.+@[^>]+)>?)"))
+	  (em (irregex-match irr str))
+	  (name (irregex-match-substring em 1))
+	  (email (irregex-match-substring em 2)))
+     email))
+
  ;; Sends an email using the UNIX mail(1) utility.
  (define*/doc (send-mail body-lines
 			 #:from (from #f)
@@ -83,17 +93,22 @@ Sends email using mail(1) command. The arguments ```#:to``` and
 			tos))
 	  (header-args
 	   (flatten
-	    (map
-	     (lambda (h) (list "-a" h))
-	     headers))))
-     (apply process-send/recv
-	    "mail"
-	    (append (if from
-			(list "-r" from)
-			'())
-		    (list "-s" (encode-subject subject))
-		    real-tos
-		    header-args)
-	    body-lines)))
+	    (append
+	     (if from (list (sprintf "From: ~A" from)) '())
+	     (map
+	      (lambda (h) (list "-a" h))
+	      headers)))))
+     (let ((from-email (if from
+			   (extract-email-email from)
+			   #f)))
+       (apply process-send/recv
+	      "mail"
+	      (append (if from
+			  (list "-r" from-email)
+			  '())
+		      (list "-s" (encode-subject subject))
+		      real-tos
+		      header-args)
+	      body-lines))))
 
  )

src/util-parser.scm

@@ -39,11 +39,12 @@ member file parsers. All functions are UTF-8 aware.")
  
  (import scheme
 	 (chicken base)
+	 racket-kwargs
 	 testing)
 
  ;; Pass 0: Removes any comments and removes any leading and trailing
  ;; whitespace.
- (define/doc (parser-preprocess-line line)
+ (define*/doc (parser-preprocess-line line #:strip-comments? (strip-comments? #t))
    ("* ```line``` - a string with contents of one source line
 
 If the input ```line``` contains the ```#``` character, the rest of
@@ -62,7 +63,9 @@ Returns a string representing the preprocessed line.")
 		      (ploop (add1 pidx)))))
 	  (hpos (let hloop ((hidx ppos))
 		  (if (or (= hidx llen)
-			  (eq? (string-ref line hidx) #\#))
+			  (and (or strip-comments?
+				   (= hidx 0))
+			       (eq? (string-ref line hidx) #\#)))
 		      hidx
 		      (hloop (add1 hidx)))))
 	  (spos (let sloop ((sidx (sub1 hpos)))

src/util-utf8.scm

@@ -120,13 +120,13 @@ of the string and a list of remaining bytes (as integers).")
  (define/doc (utf8-bytes->lists chars)
    ("The same as above but accepts a list of bytes (as integers).")
    (let loop ((bytes chars)
-	      (rpending '())
+	      (rpending chars)
 	      (pending 0)
 	      (expected #f)
 	      (res '()))
      (if (null? bytes)
 	 (values (reverse res)
-		 (reverse rpending))
+		 rpending)
 	 (let ((byte (car bytes)))
 	   (cond (expected
 		  ;; Decode UTF-8 sequence
@@ -135,14 +135,14 @@ of the string and a list of remaining bytes (as integers).")
 			 (let ((char (integer->char (bitwise-ior pending
 								 (bitwise-and byte #b111111)))))
 			   (loop (cdr bytes)
-				 '()
+				 (cdr bytes)
 				 0
 				 #f
 				 (cons char res))))
 			(else
 			 ;; Intermediate bytes
 			 (loop (cdr bytes)
-			       (cons byte rpending)
+			       rpending
 			       (arithmetic-shift (bitwise-ior pending
 							      (bitwise-and byte #b111111)) 6)
 			       (sub1 expected)
@@ -152,7 +152,7 @@ of the string and a list of remaining bytes (as integers).")
 		  (cond ((= (bitwise-and byte #b10000000) 0)
 			 ;; ASCII
 			 (loop (cdr bytes)
-			       '()
+			       (cdr bytes)
 			       0
 			       #f
 			       (cons (integer->char byte) res)))
@@ -160,20 +160,20 @@ of the string and a list of remaining bytes (as integers).")
 			 ;; First byte of UTF-8 sequence
 			 (let-values
 			     (((first-byte char-bytes)
-			       (cond ((= (bitwise-and byte #b11000000) #b11000000)
+			       (cond ((= (bitwise-and byte #b11100000) #b11000000)
 				      (values (bitwise-and byte #b11111)
 					      2))
-				     ((= (bitwise-and byte #b11100000) #b11100000)
+				     ((= (bitwise-and byte #b11110000) #b11100000)
 				      (values (bitwise-and byte #b1111)
 					      3))
-				     ((= (bitwise-and byte #b11110000) #b11110000)
+				     ((= (bitwise-and byte #b11111000) #b11110000)
 				      (values (bitwise-and byte #b111)
 					      4))
 				     (else
 				      ;; Should not happen
 				      (values 0 0)))))
 			   (loop (cdr bytes)
-				 (list byte)
+				 bytes
 				 (arithmetic-shift first-byte 6)
 				 (sub1 char-bytes)
 				 res))))))))))