Basic command-line parsing.

brmsaptool.scm

@@ -30,7 +30,6 @@
 	(chicken sort)
 	(chicken time)
 	(chicken time posix)
-
 	(chicken process-context))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -484,6 +483,56 @@
 (define (list-members-nicks mdb)
   (map (lambda (mr) (dict-ref (dict-ref mr 'info) 'nick)) mdb))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Command-line parsing
+
+;; Prints simple help
+(define (print-help)
+  (print "Command-line arguments:
+
+  -h      prints this help
+  -M dir  specifies the members database directory
+")
+  (exit 0))
+
+;; Consumes given number of arguments from the list and returns the
+;; remainder of the list and a list of arguments consumed.
+(define (consume-args args num)
+  (let loop ((args args)
+	     (res '())
+	     (num num))
+    (if (= num 0)
+	(list args (reverse res))
+	(if (null? args)
+	    (error 'consume-args "Not enough arguments" num)
+	    (loop (cdr args)
+		  (cons (car args) res)
+		  (- num 1))))))
+
+;; Performs the actual parsing based on specification.
+(define (do-parse-command-line specs)
+  (let loop ((args (command-line-arguments)))
+    (when (not (null? args))
+      (let* ((arg (car args))
+	     (specp (assoc arg specs)))
+	(when (not specp)
+	  (error 'parse-command-line "Unknown argument" arg))
+	(let* ((proc (cadr specp))
+	       (info (procedure-information proc))
+	       (nargs (- (length info) 1))
+	       (aargsl (consume-args (cdr args) nargs))
+	       (args (car aargsl))
+	       (aargs (cadr aargsl)))
+	  (apply proc aargs)
+	  (loop args))))))
+
+;; Simple syntax wrapper for command-line arguments specification
+(define-syntax parse-command-line
+  (syntax-rules ()
+    ((_ ((arg proc) ...))
+     (do-parse-command-line
+      `((arg ,proc) ...)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Run everything
 
@@ -491,6 +540,10 @@
 (print "brmsaptool 0.1 (c) 2023 Brmlab, z.s.")
 (newline)
 
+(parse-command-line
+ (("-h" print-help)
+  ("-M" (lambda (dn) (*members-directory* dn)))))
+
 ;; Run tests
 (print "Running self-tests:")
 (dict-tests!)