--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ;;;
+;;; Free Software available under an MIT-style license. See LICENSE ;;;
+;;; ;;;
+;;; Copyright (c) 2009 ITA Software, Inc. All rights reserved. ;;;
+;;; ;;;
+;;; Original author: Francois-Rene Rideau ;;;
+;;; ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#+xcvb (module (:depends-on ("pkgdcl")))
+;; let's not DEPEND on (:build "/cl-launch") since
+;; that opens a can of worm for people using ASDF.
+
+(in-package :command-line-arguments)
+
+(defun get-command-line-arguments ()
+ (if (find-package :cl-launch)
+ (symbol-value (find-symbol (string :*arguments*) :cl-launch))
+ (progn
+ #+sbcl (cdr sb-ext:*posix-argv*)
+ #+clozure (cdr (ccl::command-line-arguments))
+ #+gcl (cdr si:*command-args*)
+ #+ecl (loop for i from 1 below (si:argc) collect (si:argv i))
+ #+cmu (cdr extensions:*command-line-strings*)
+ #+allegro (cdr (sys:command-line-arguments))
+ #+lispworks (cdr sys:*line-arguments-list*)
+ #+clisp ext:*args*
+ #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp)
+ (error "get-command-line-arguments not supported for your implementation"))))
+
+(defun compute-and-process-command-line-options (specification)
+ (process-command-line-options specification (get-command-line-arguments)))
+
+(defun invoke-command-line-handler (function options arguments &key
+ (positional-arity 0) (rest-arity nil) name)
+ (let ((l (length arguments)))
+ (unless (>= l positional-arity)
+ (error "~@[~A: ~] Too few arguments. Expected~@[ at least~] ~A, got ~A ~S"
+ name rest-arity positional-arity l arguments))
+ (when (and (> l positional-arity) (not rest-arity))
+ (error "~@[~A: ~] Too many arguments. Expected only ~A, got ~A ~S"
+ name positional-arity l arguments))
+ (let ((positional-arguments (subseq arguments 0 positional-arity))
+ (rest-arguments (when rest-arity (subseq arguments positional-arity))))
+ (apply function (append positional-arguments
+ (etypecase rest-arity
+ (null nil)
+ ((eql t) (list rest-arguments))
+ (keyword (list rest-arity rest-arguments)))
+ options)))))
+
+(defun handle-command-line (specification function
+ &key (positional-arity 0) (rest-arity nil) name
+ (command-line (get-command-line-arguments)))
+ (multiple-value-bind (options arguments)
+ (process-command-line-options specification command-line)
+ (invoke-command-line-handler function options arguments
+ :name name
+ :positional-arity positional-arity
+ :rest-arity rest-arity)))
:licence "MIT"
:description "small library to deal with command-line arguments"
:long-description "A library to abstract away the parsing of Unix-style command-line arguments"
- :depends-on ("parse-command-line-arguments" "get-command-line-arguments")
+ :depends-on ("parse" "argv" "help")
:build-image nil))
;;:depends-on (:cl-launch) ; cl-launch affects the build too much for unsuspecting ASDF users.
:components
((:file "pkgdcl")
- (:file "get-command-line-arguments" :depends-on ("pkgdcl"))
- (:file "parse-command-line-arguments" :depends-on ("get-command-line-arguments"))))
+ (:file "argv" :depends-on ("pkgdcl"))
+ (:file "parse" :depends-on ("pkgdcl"))
+ (:file "help" :depends-on ("pkgdcl"))))
+++ /dev/null
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; ;;;
-;;; Free Software available under an MIT-style license. See LICENSE ;;;
-;;; ;;;
-;;; Copyright (c) 2009 ITA Software, Inc. All rights reserved. ;;;
-;;; ;;;
-;;; Original author: Francois-Rene Rideau ;;;
-;;; ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-#+xcvb (module (:depends-on ("pkgdcl")))
-;; let's not DEPEND on (:build "/cl-launch") since
-;; that opens a can of worm for people using ASDF.
-
-(in-package :command-line-arguments)
-
-(defun get-command-line-arguments ()
- (if (find-package :cl-launch)
- (symbol-value (find-symbol (string :*arguments*) :cl-launch))
- (progn
- #+sbcl (cdr sb-ext:*posix-argv*)
- #+clozure (cdr (ccl::command-line-arguments))
- #+gcl (cdr si:*command-args*)
- #+ecl (loop for i from 1 below (si:argc) collect (si:argv i))
- #+cmu (cdr extensions:*command-line-strings*)
- #+allegro (cdr (sys:command-line-arguments))
- #+lispworks (cdr sys:*line-arguments-list*)
- #+clisp ext:*args*
- #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp)
- (error "get-command-line-arguments not supported for your implementation"))))
--- /dev/null
+#+xcvb (module (:depends-on ("pkgdcl")))
+
+(in-package :command-line-arguments)
+
+(defun split-sequence (sequence delimiter)
+ (loop
+ :with index = 0
+ :for match = (position delimiter sequence :start index)
+ :when (and match
+ (not (= index match)))
+ :collect (subseq sequence index match)
+ :when match
+ :do (setf index (1+ match))
+ :unless (or match
+ (= index (length sequence)))
+ :collect (subseq sequence index)
+ :while match))
+
+(defun show-option-help (specification &key (stream *standard-output*) sort-names)
+ ;; TODO: be clever when trying to align stuff horizontally
+ (loop :with *print-right-margin* = (max (or *print-right-margin* 0) 100)
+ :for spec :in specification :do
+ (destructuring-bind (names &key negation documentation negation-documentation
+ type optional list (initial-value nil initial-value-p) &allow-other-keys) spec
+ (declare (ignorable negation documentation negation-documentation type optional list))
+ (unless (consp names)
+ (setf names (list names)))
+ (flet ((option-names (names)
+ (let ((n (mapcar 'option-name names)))
+ (if sort-names
+ (stable-sort n #'< :key #'length)
+ n))))
+ (when documentation
+ (format stream "~& ~32A ~8A ~@<~@;~{~A ~}~@:>"
+ (format nil "~{ ~A~}" (option-names names))
+ (string-downcase type)
+ (split-sequence documentation #\Space))
+ (format stream "~:[~*~; (default: ~S)~]~%" initial-value-p initial-value))
+ (when negation-documentation
+ (format stream " ~32A ~8A ~@<~@;~{~A ~}~@:>~%"
+ (format nil "~{ ~A~}" (option-names (make-negated-names names negation)))
+ (string-downcase type)
+ (split-sequence negation-documentation #\Space)))))))
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-#+xcvb (module (:depends-on ("get-command-line-arguments")))
+#+xcvb (module (:depends-on ("pkgdcl")))
(in-package :command-line-arguments)
-;;(declaim (optimize (speed 1) (safety 3) (debug 3)))
-
(defvar *command-line-arguments* nil
"a list of strings, the arguments passed to the program on its command-line,
or what's currently left of them as they are processed")
(do-process-command-line-options)
(values *command-line-options* *command-line-arguments*)))
-(defun compute-and-process-command-line-options (specification)
- (process-command-line-options specification (get-command-line-arguments)))
-
-(defun split-sequence (sequence delimiter)
- (loop
- :with index = 0
- :for match = (position delimiter sequence :start index)
- :when (and match
- (not (= index match)))
- :collect (subseq sequence index match)
- :when match
- :do (setf index (1+ match))
- :unless (or match
- (= index (length sequence)))
- :collect (subseq sequence index)
- :while match))
-
-(defun show-option-help (specification &key (stream *standard-output*) sort-names)
- ;; TODO: be clever when trying to align stuff horizontally
- (loop :with *print-right-margin* = (max (or *print-right-margin* 0) 100)
- :for spec :in specification :do
- (destructuring-bind (names &key negation documentation negation-documentation
- type optional list (initial-value nil initial-value-p) &allow-other-keys) spec
- (declare (ignorable negation documentation negation-documentation type optional list))
- (unless (consp names)
- (setf names (list names)))
- (flet ((option-names (names)
- (let ((n (mapcar 'option-name names)))
- (if sort-names
- (stable-sort n #'< :key #'length)
- n))))
- (when documentation
- (format stream "~& ~32A ~8A ~@<~@;~{~A ~}~@:>"
- (format nil "~{ ~A~}" (option-names names))
- (string-downcase type)
- (split-sequence documentation #\Space))
- (format stream "~:[~*~; (default: ~S)~]~%" initial-value-p initial-value))
- (when negation-documentation
- (format stream " ~32A ~8A ~@<~@;~{~A ~}~@:>~%"
- (format nil "~{ ~A~}" (option-names (make-negated-names names negation)))
- (string-downcase type)
- (split-sequence negation-documentation #\Space)))))))
-
-#| Testing:
-
-(defparameter *opt-spec*
- '((("all" #\a) :type boolean :documentation "do it all")
- ("blah" :type string :initial-value "blob" :documentation "This is a very long multi line documentation. The function SHOW-OPTION-HELP should display this properly indented, that is all lines should start at the same column.")
- (("verbose" #\v) :type boolean :documentation "include debugging output")
- (("file" #\f) :type string :documentation "read from file instead of standard input")
- (("xml-port" #\x) :type integer :optional t :documentation "specify port for an XML listener")
- (("http-port" #\h) :type integer :initial-value 80 :documentation "specify port for an HTTP listener")
- ("enable-cache" :type boolean :documentation "enable cache for queries")
- ("path" :type string :list t :optional t :documentation "add given directory to the path")
- ("port" :type integer :list (:initial-contents (1 2)) :optional t :documentation "add a normal listen on given port")))
-
-(defun foo (args &key all verbose file xml-port enable-cache port path http-port blah)
- (list args :all all :verbose verbose :file file :xml-port xml-port :http-port http-port :blah blah
- :enable-cache enable-cache :port port :path path))
-
-(multiple-value-bind (options arguments)
- (process-command-line-options
- *opt-spec*
- '("--all" "--no-verbose" "--file" "foo" "-f" "-v" "-v"
- "-x" "--disable-cache" "-h" "8080"
- "--no-port" "--port" "3" "--port=4"
- "--path" "/foo" "--path" "/bar"
- "--" "--foo" "bar" "baz"))
- (write arguments :pretty nil) (terpri)
- (write options :pretty nil) (terpri)
- (write (apply 'foo arguments options) :pretty nil)
- (terpri))
-
-(show-option-help *opt-spec*)
-
-|#
#:process-command-line-options
#:compute-and-process-command-line-options
#:get-command-line-arguments
+ #:handle-command-line
#:show-option-help
))
--- /dev/null
+(in-package :command-line-arguments)
+
+(defparameter *opt-spec*
+ '((("all" #\a) :type boolean :documentation "do it all")
+ ("blah" :type string :initial-value "blob" :documentation "This is a very long multi line documentation. The function SHOW-OPTION-HELP should display this properly indented, that is all lines should start at the same column.")
+ (("verbose" #\v) :type boolean :documentation "include debugging output")
+ (("file" #\f) :type string :documentation "read from file instead of standard input")
+ (("xml-port" #\x) :type integer :optional t :documentation "specify port for an XML listener")
+ (("http-port" #\h) :type integer :initial-value 80 :documentation "specify port for an HTTP listener")
+ ("enable-cache" :type boolean :documentation "enable cache for queries")
+ ("path" :type string :list t :optional t :documentation "add given directory to the path")
+ ("port" :type integer :list (:initial-contents (1 2)) :optional t :documentation "add a normal listen on given port")))
+
+(defun foo (args &key all verbose file xml-port enable-cache port path http-port blah)
+ (list args :all all :verbose verbose :file file :xml-port xml-port :http-port http-port :blah blah
+ :enable-cache enable-cache :port port :path path))
+
+(multiple-value-bind (options arguments)
+ (process-command-line-options
+ *opt-spec*
+ '("--all" "--no-verbose" "--file" "foo" "-f" "-v" "-v"
+ "-x" "--disable-cache" "-h" "8080"
+ "--no-port" "--port" "3" "--port=4"
+ "--path" "/foo" "--path" "/bar"
+ "--" "--foo" "bar" "baz"))
+ (write arguments :pretty nil) (terpri)
+ (write options :pretty nil) (terpri)
+ (write (apply 'foo arguments options) :pretty nil)
+ (terpri))
+
+(show-option-help *opt-spec*)
common-lisp.net / projects/qitab/command-line-arguments.git / commitdiff
