;; 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-from
usage
get-args
print-args
any-defined?
help
)
(import scheme chicken.base chicken.process-context srfi-69 srfi-1)
(define arg-hash (make-hash-table))
(define help "")
(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))))
(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 (usage . args)
(if (> (length args) 0)
(apply print "ERROR: " args))
(if (string? help)
(print help)
(print "Usage: " (car (argv)) " ... "))
(exit 0))
(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 remtargs arg-hash)
(print "ARGS: " remtargs)
(for-each (lambda (arg)
(print " " arg " " (hash-table-ref/default arg-hash arg #f)))
(hash-table-keys arg-hash)))
)