;; Copyright 2007-2010, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest 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.
;;
;; Megatest 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 Megatest. If not, see <http://www.gnu.org/licenses/>.
(declare (unit margs))
;; (declare (uses common))
(module margs
*
(import
scheme
chicken.base
chicken.process-context
srfi-1
srfi-69
)
(define help #f)
(define args:arg-hash (make-hash-table))
(define (args:get-arg arg . default)
(if (null? default)
(hash-table-ref/default args:arg-hash arg #f)
(hash-table-ref/default args:arg-hash arg (car default))))
(define (args:any? . args)
(not (null? (filter (lambda (x) x)
(map args:get-arg args)))))
(define (args: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 (args:remove-arg-from-ht arg)
(hash-table-delete! args:arg-hash arg)
)
(define (args:usage . args)
(if (> (length args) 0)
(apply print "ERROR: " args))
(if (string? help)
(print help)
(print "Usage: " (car (argv)) " ... "))
(exit 0))
;; one-of args defined
(define (args:any-defined? . param)
(let ((res #f))
(for-each
(lambda (arg)
(if (args:get-arg arg)(set! res #t)))
param)
res))
;; args:
(define (args:get-args args params switches arg-hash num-needed)
(let* ((numargs (length args))
(adj-num-needed (if num-needed (+ num-needed 2) #f)))
(if (< numargs (if adj-num-needed adj-num-needed 2))
(if (>= num-needed 1)
(args:usage "No arguments provided")
'())
(let loop ((arg (cadr args))
(tail (cddr args))
(remargs '()))
(cond
((member arg params) ;; args with params
(if (< (length tail) 1)
(args:usage "param given without argument " arg)
(let ((val (car tail))
(newtail (cdr tail)))
(hash-table-set! arg-hash arg val)
(if (null? newtail) remargs
(loop (car newtail)(cdr newtail) remargs)))))
((member arg switches) ;; args with no params (i.e. switches)
(hash-table-set! arg-hash arg #t)
(if (null? tail) remargs
(loop (car tail)(cdr tail) remargs)))
(else
(if (null? tail)(append remargs (list arg)) ;; return the non-used args
(loop (car tail)(cdr tail)(append remargs (list arg))))))))
))
(define (args:print-args remargs arg-hash)
(print "ARGS: " remargs)
(for-each (lambda (arg)
(print " " arg " " (hash-table-ref/default arg-hash arg #f)))
(hash-table-keys arg-hash)))
)