Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

87 lines (71 sloc) 2.637 kB
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This software was written by Evan Hanson, subsequently deprecated,
;;; and hereby placed into the Public Domain. All warranties are
;;; disclaimed.
;;;
(use easy-args srfi-13 srfi-78)
(define-syntax test-arguments
(syntax-rules (=> =/=>)
((_ <a> <e> ... => <r>)
(parameterize ((command-line-arguments <a>))
(check (begin <e> ...) => <r>)))
((_ <a> <e> ... =/=> <r>)
(test-arguments <a>
(call-with-current-continuation
(lambda (k)
(invalid-argument-handler (compose k car list))
<e> ...)) => <r>))))
;; Without arguments.
(test-arguments '()
(define-arguments (bool) (num 1) (sym 'foo) (str "bar"))
(list (bool) (num) (sym) (str)) => '(#f 1 foo "bar"))
;; With arguments, general form.
(test-arguments '("--num" "2" "--sym" "baz" "--str=qux")
(define-arguments ((bool)) ((num) 1) ((sym) 'foo) ((str) "bar"))
(list (bool) (num) (sym) (str)) => '(#f 2 baz "qux"))
;; Single-character option flags.
(test-arguments '("-bn2" "-m" "baz" "-rqux")
(define-arguments (b) (n 1) (m 'foo) (r "bar"))
(list (b) (n) (m) (r)) => '(#t 2 baz "qux"))
;; Repeated arguments.
(test-arguments '("--num" "2" "--number" "3")
(define-arguments ((num number n) 1))
(num) => 3)
;; Strip earmuffs from parameter names.
(test-arguments '("--earmuffs" "bar")
(define-arguments (*earmuffs* 'foo))
(*earmuffs*) => 'bar)
;; Guard procedure.
(test-arguments '("--str" "bar")
(define-arguments
((str) "foo"
(lambda (str)
(string-append str "!"))))
(str) => "bar!")
;; Leftover arguments.
(test-arguments '("--matched" "unmatched")
(define-arguments (matched))
(command-line-arguments) => '("unmatched"))
;; Unmatched argument.
(test-arguments '("--matched" "-b" "--unmatched=ignored")
(define-arguments (matched))
(unmatched-arguments) => '((#\b . #t) ("unmatched" . "ignored")))
;; Bad default.
(test-arguments '("--foo")
(handle-exceptions exn
((condition-property-accessor 'exn 'message) exn)
(define-arguments ((foo f) (lambda (x) x)))) =/=> "invalid default value")
;; No argument given.
(test-arguments '("--foo")
(define-arguments ((foo f) "bar")) =/=> "value required")
;; Non-numeric argument given.
(test-arguments '("--foo")
(define-arguments ((foo f) 1)) =/=> "numeric value required")
;; Value given for boolean argument.
(test-arguments '("--foo=1")
(define-arguments ((foo f)))
(foo) =/=> "unexpected value")
(if (not (check-passed? 12))
(begin (check-report)
(error 'easy-args "Failed to pass test suite.")))
Jump to Line
Something went wrong with that request. Please try again.