;; Copyright 2007-2010, Matthew Welland.
;;
;; This file is part of mtargs.
;;
;; mtargs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; mtargs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with mtargs. If not, see <http://www.gnu.org/licenses/>.
(module mtargs
(
arg-hash
get-arg
get-arg-number
get-arg-from
remove-arg-from-ht
get-args
usage
print-args
any-defined?
)
(import scheme) ;; gives us cond-expand in chicken-4
(cond-expand
(chicken-5
(import scheme (chicken base) (chicken port) (chicken file) (chicken process-context))
(import srfi-69 srfi-1))
(chicken-4
(import chicken posix srfi-69 srfi-1))
(else))
(define usage (make-parameter print))
(define arg-hash (make-hash-table))
(define (get-arg arg . default)
(if (null? default)
(hash-table-ref/default arg-hash arg #f)
(hash-table-ref/default arg-hash arg (car default))))
;; get an arg as a number
(define (get-arg-number arg . default)
(let* ((val-str (get-arg arg))
(val (if val-str (string->number val-str) #f)))
(if val
val
(if (null? default)
#f
default))))
(define (any-defined? . args)
(not (null? (filter (lambda (x) x)
(map get-arg args)))))
;; (define any any-defined?)
(define (get-arg-from ht arg . default)
(if (null? default)
(hash-table-ref/default ht arg #f)
(hash-table-ref/default ht arg (car default))))
(define (remove-arg-from-ht arg)
(hash-table-delete! arg-hash arg)
)
(define (get-args args params switches arg-hash num-needed)
(let* ((numtargs (length args))
(adj-num-needed (if num-needed (+ num-needed 2) #f)))
(if (< numtargs (if adj-num-needed adj-num-needed 2))
(if (>= num-needed 1)
(usage "No arguments provided")
'())
(let loop ((arg (cadr args))
(tail (cddr args))
(remtargs '()))
(cond
((member arg params) ;; args with params
(if (< (length tail) 1)
(usage "param given without argument " arg)
(let ((val (car tail))
(newtail (cdr tail)))
(hash-table-set! arg-hash arg val)
(if (null? newtail) remtargs
(loop (car newtail)(cdr newtail) remtargs)))))
((member arg switches) ;; args with no params (i.e. switches)
(hash-table-set! arg-hash arg #t)
(if (null? tail) remtargs
(loop (car tail)(cdr tail) remtargs)))
(else
(if (null? tail)(append remtargs (list arg)) ;; return the non-used args
(loop (car tail)(cdr tail)(append remtargs (list arg))))))))
))
(define (print-args arg-hash)
(for-each (lambda (arg)
(print " " arg " " (hash-table-ref/default arg-hash arg #f)))
(hash-table-keys arg-hash)))
(define (any-defined? . args)
(not (null? (filter (lambda (x) x)
(map get-arg args)))))
)