Move sources to separate directory.

src/bbstool.scm

@@ -0,0 +1,199 @@
+;;
+;; bbstool.scm
+;;
+;; Brmburo system - members management tool.
+;;
+
+;; The license of this file and of the whole suite.
+(define license-text "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 testing
+	listing
+	dictionary
+	month
+	period
+	command-line
+	utils
+	ansi
+	members-base
+	primes
+	member-record
+	configuration
+	table
+	cards
+	members-print
+	member-parser
+	member-fees
+	members-dir
+	csv-simple
+	members-payments)
+
+;; Print banner
+(print "bbstool 0.7 (c) 2023 Brmlab, z.s.")
+(newline)
+
+;; Command-line options and configurable parameters
+(define *members-directory* (make-parameter "members"))
+(define *apikeys-file* (make-parameter "apikey.ntlm"))
+(define -member-id- (make-parameter #f))
+(define -member-nick- (make-parameter #f))
+(define -action- (make-parameter #f))
+(define -fname- (make-parameter #f))
+(define -run-tests?- (make-parameter #f))
+
+;; Arguments parsing
+(command-line
+ print-help
+ (-h () "This help"
+     (print "Command-line options:")
+     (newline)
+     (print-help)
+     (newline)
+     (exit 0))
+ (-license () "Show licensing terms"
+	   (print license-text)
+	   (exit 0))
+ (-members (dir) "Members base directory" (*members-directory* dir))
+ (-context (n) "Member-File parser Error Context (lines)" (*member-file-context* (string->number n)))
+ (-mi (id) "Specify member by id" (-member-id- (string->number id)))
+ (-mn (nick) "Specify member by nick" (-member-nick- nick))
+ (-info () "Print information" (-action- 'print-info))
+ (-stats (file:gnuplot-data) "Get stats for all months"
+	 (-action- 'print-stats)
+	 (-fname- file:gnuplot-data))
+ (-month (YYYY-MM) "Specify current month"
+	 (*current-month* (string->month YYYY-MM)))
+ (-print () "Print given member file"
+	 (-action- 'print-member-file))
+ (-tests () "Run self-tests upon startup" (-run-tests?- #t))
+ (-idstats () "Returns information about available member ids" (-action- 'print-idstats))
+ (-genid () "Generates random member id" (-action- 'genid))
+ (-tstyle (style) "Use given table style: debug, ascii, unicode"
+	  (*table-border-style* (string->symbol style)))
+ (-gencards (file:cards file:desfires) "Generates brmdoor-compatible card files"
+	    (-action- 'gencards)
+	    (-fname- (list file:cards file:desfires)))
+ (-problems () "Prints all files with problems" (-action- 'problems))
+ (-fees () "Prints fees table" (-action- 'fees))
+ )
+
+;; Run tests
+(when (-run-tests?-)
+  (listing-tests!)
+  (dictionary-tests!)
+  (month-tests!)
+  (period-tests!)
+  (utils-tests!)
+  (ansi-tests!)
+  (command-line-tests!)
+  (members-dir-tests!)
+  (primes-tests!)
+  (member-record-tests!)
+  (member-parser-tests!)
+  (table-tests!)
+  (csv-simple-tests!)
+  (newline))
+
+;; Load the members database (required for everything anyway)
+(define MB (members-payments-process
+	    (load-members (*members-directory*) #t)
+	    (*apikeys-file*)))
+
+;; If a member is specified by either id or nick, get its record
+(define mr
+  (if (-member-id-)
+      (let ((mr (find-member-by-id MB (-member-id-))))
+	(when (not mr)
+	  (print "Member id " (-member-id-) " not found!"))
+	mr)
+      (if (-member-nick-)
+	  (let ((mr (find-member-by-nick MB (-member-nick-))))
+	    (when (not mr)
+	      (print "Member nick " (-member-nick-) " not found!"))
+	    mr)
+	  #f)))
+
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Perform requested action
+(case (-action-)
+  ((print-info)
+   (newline)
+   (print "Current month: " (month->string (*current-month*)))
+   (newline)
+   (if mr
+       (let ()
+	 (print-member-table mr)
+	 (let* ((fees (member-fees-total mr))
+		(credit (member-credit-total mr))
+		(payments (member-payments-total mr))
+		(balance (- (+ credit payments) fees)))
+	   (print "Total fees: " fees)
+	   (print "Total credit: " credit)
+	   (print "Total payments: " payments)
+	   (print "Balance: " balance)
+	   ))
+       (print-members-base-table MB))
+   (newline))
+  ((print-stats)
+   (newline)
+   (parameterize ((current-output-port (open-output-file (-fname-))))
+     (print-members-base-stats
+      (members-base-stats MB))))
+  ((print-member-file)
+   (cond (mr
+	  (newline)
+	  (print-member-source mr))
+	 (else
+	  (print "No member specified!"))))
+  ((print-idstats)
+   (newline)
+   (print-members-ids-stats MB)
+   (newline))
+  ((genid)
+   (newline)
+   (print "New member id: " (gen-member-id MB))
+   (newline))
+  ((gencards)
+   (apply cards-export MB (-fname-)))
+  ((problems)
+   (let ((num (let loop ((mb MB)
+			 (num 0))
+		(if (null? mb)
+		    num
+		    (loop (cdr mb)
+			  (if (or (member-has-problems? (car mb))
+				  (member-has-highlights? (car mb)))
+			      (let ()
+				(newline)
+				(print-member-table (car mb))
+				(print-member-source (car mb))
+				(add1 num))
+			      num))))))
+     (when (= num 0)
+       (newline)
+       (print "No problems found."))))
+  ((fees)
+   (newline)
+   (print-members-fees-table MB))
+  
+  )