270 lines
11 KiB
Common Lisp
270 lines
11 KiB
Common Lisp
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
|
;;;; This is copyrighted software. See documentation for terms.
|
|
;;;;
|
|
;;;; cmdline-utilities.lisp --- Command Line Parsing and Access
|
|
;;;;
|
|
;;;; $Id$
|
|
|
|
(cl:in-package #:pmsf-lib)
|
|
|
|
(pmsf-lib:file-version :pmsf-lib "$Id$")
|
|
|
|
;;;; %File Description:
|
|
;;;;
|
|
;;;; This file contains utilities to access the command line and to
|
|
;;;; parse command line arguments for options and proper arguments.
|
|
;;;;
|
|
|
|
(defun get-command-line-arguments ()
|
|
"Return the list of command line arguments passed to this process, including
|
|
the program name as its first argument."
|
|
#+sbcl
|
|
(copy-list sb-ext:*posix-argv*)
|
|
#+lispworks
|
|
(copy-list system:*line-arguments-list*))
|
|
|
|
;;;
|
|
;;; Parsing
|
|
;;;
|
|
|
|
(define-condition command-line-argument-error (simple-error)
|
|
((command-line :initarg :command-line
|
|
:reader command-line-argument-error-command-line)
|
|
(remaining-arguments :initarg :remaining-arguments
|
|
:reader
|
|
command-line-argument-error-remaining-arguments))
|
|
(:report
|
|
(lambda (c s)
|
|
(with-standard-io-syntax
|
|
(let ((*print-readably* nil))
|
|
(format s
|
|
"Error parsing command-line: ~?~%~
|
|
For command-line ~{~S~^ ~}, remaining arguments: ~{~S~^ ~}"
|
|
(simple-condition-format-control c)
|
|
(simple-condition-format-arguments c)
|
|
(command-line-argument-error-command-line c)
|
|
(command-line-argument-error-remaining-arguments c)))))))
|
|
|
|
;;;
|
|
;;; Main Entry Point
|
|
;;;
|
|
|
|
(defun parse-command-line-arguments (command-line
|
|
&key (required-arguments 0) allowed-arguments
|
|
option-specs)
|
|
"Parse the command-line given in COMMAND-LINE for the program-name, the
|
|
normal arguments and any options, based on the specifications given through
|
|
REQUIRED-ARGUMENTS, ALLOWED-ARGUMENTS and OPTION-SPECS. This function will
|
|
signal a COMMAND-LINE-ARGUMENT-ERROR if any of those specifications can't be
|
|
matched. Returns three values, the name of the program as a string, the list
|
|
of normal arguments after option processing finished, and an alist of options
|
|
and their arguments, as specified by option-spec."
|
|
(let ((program-name (first command-line))
|
|
(arguments (rest command-line)))
|
|
(flet ((is-long-option-p (arg)
|
|
(when (and (>= (length arg) 2) (string= arg "--" :end1 2))
|
|
(subseq arg 2)))
|
|
(find-option-by-name (name)
|
|
(find name option-specs :key #'first :test #'string=))
|
|
(is-option-terminator-p (name)
|
|
(string= name ""))
|
|
(command-line-argument-error (rest control &rest args)
|
|
(error 'command-line-argument-error
|
|
:command-line command-line
|
|
:remaining-arguments rest
|
|
:format-control control
|
|
:format-arguments args)))
|
|
;; Process and collect options
|
|
(loop with options = nil
|
|
with rest-arguments = arguments
|
|
for arg = (pop rest-arguments)
|
|
for option-name = (and arg (is-long-option-p arg))
|
|
for option = (and option-name (find-option-by-name option-name))
|
|
while (and option-name (not (is-option-terminator-p option-name)))
|
|
do
|
|
(unless option
|
|
(command-line-argument-error
|
|
rest-arguments
|
|
"Unknown option ~A, known options: ~{~A~^, ~}"
|
|
option-name (mapcar #'first option-specs)))
|
|
(destructuring-bind (option-matcher option-key option-arguments)
|
|
option
|
|
(unless (>= (length rest-arguments) option-arguments)
|
|
(command-line-argument-error
|
|
rest-arguments
|
|
"Option ~A needs ~D arguments but has only ~D."
|
|
option-matcher option-arguments (length rest-arguments)))
|
|
(push (list* option-key
|
|
(subseq rest-arguments 0 option-arguments))
|
|
options)
|
|
(setq rest-arguments (nthcdr option-arguments rest-arguments)))
|
|
finally
|
|
(when arg
|
|
(unless (and option-name (is-option-terminator-p option-name))
|
|
(push arg rest-arguments)))
|
|
(unless (>= (length rest-arguments) required-arguments)
|
|
(command-line-argument-error
|
|
rest-arguments
|
|
"~A needs ~D arguments but has only ~D."
|
|
program-name required-arguments (length rest-arguments)))
|
|
(unless (or (null allowed-arguments)
|
|
(<= (length rest-arguments) allowed-arguments))
|
|
(command-line-argument-error
|
|
rest-arguments
|
|
"~A needs at most ~D arguments but has ~D."
|
|
program-name allowed-arguments (length rest-arguments)))
|
|
(return (values program-name rest-arguments (nreverse options)))))))
|
|
|
|
;;;
|
|
;;; Parsing for lambda lists
|
|
;;;
|
|
|
|
(defun make-options-argument-list (options)
|
|
(loop with result = nil
|
|
for (option . args) in options
|
|
do
|
|
(cond
|
|
((null args)
|
|
(setf (getf result option) t))
|
|
(t
|
|
(push args (getf result option nil))))
|
|
finally
|
|
(return
|
|
(loop for (key values) on result by #'cddr
|
|
collect key
|
|
collect
|
|
(cond
|
|
((eq values t)
|
|
values)
|
|
((and (null (cdr values)) (null (cdar values)))
|
|
(caar values))
|
|
((null (cdr values))
|
|
(car values))
|
|
(t
|
|
(mapcar #'(lambda (x) (if (null (cdr x)) (car x) x))
|
|
values)))))))
|
|
|
|
(defun parse-command-line-for-argument-list (command-line &rest args)
|
|
"Parse the command-line given in COMMAND-LINE in order to construct an
|
|
argument list for invoking another function, based on the specifications
|
|
given through the remaining arguments, which will be passed to the function
|
|
PARSE-COMMAND-LINE-ARGUMENTS for the parsing itself. This function returns
|
|
an argument list, which will contain a position argument for each normal
|
|
argument to the function, followed by keyword arguments for each option
|
|
present in the command-line. Duplicate options are merged, options with
|
|
no argument are turned into boolean T keyword arguments, and options with
|
|
only single arguments are unwrapped into single keyword arguments."
|
|
(multiple-value-bind (prog-name arguments options)
|
|
(apply #'parse-command-line-arguments command-line args)
|
|
(declare (ignore prog-name))
|
|
(append arguments (make-options-argument-list options))))
|
|
|
|
;;;
|
|
;;; Main Entry Point
|
|
;;;
|
|
|
|
(defun call-with-parsed-arguments (function command-line &rest args)
|
|
"Invoke the given function with the arguments and options parsed out of the
|
|
command-line as given by COMMAND-LINE."
|
|
(apply function
|
|
(apply #'parse-command-line-for-argument-list command-line args)))
|
|
|
|
(defun call-with-parsed-command-line (function &rest args)
|
|
"Invoke the given function with the arguments and options parsed out of the
|
|
command-line as returned by GET-COMMAND-LINE-ARGUMENTS."
|
|
(apply function
|
|
(apply #'parse-command-line-for-argument-list
|
|
(get-command-line-arguments) args)))
|
|
|
|
(defun parse-argument-lambda-list (lambda-list)
|
|
(loop with state = :required
|
|
with program-arg = nil
|
|
with required-args = nil
|
|
with optional-args = nil
|
|
with rest-arg = nil
|
|
with keyword-args = nil
|
|
for arg in lambda-list
|
|
do
|
|
(if (member arg '(&optional &rest &program &key))
|
|
(case arg
|
|
(&optional
|
|
(unless (eq state :required)
|
|
(error "Misplaced &OPTIONAL in command-line lambda list: ~S"
|
|
lambda-list))
|
|
(setq state :optional))
|
|
(&rest
|
|
(unless (member state '(:required :optional))
|
|
(error "Misplaced &REST in command-line lambda list: ~S"
|
|
lambda-list))
|
|
(setq state :rest))
|
|
(&program
|
|
(unless (member state '(:required :optional :post-rest))
|
|
(error "Misplaced &PROGRAM in command-line lambda list: ~S"
|
|
lambda-list))
|
|
(setq state :program))
|
|
(&key
|
|
(unless (member state
|
|
'(:required :optional :post-rest :post-program))
|
|
(error "Misplaced &KEY in command-line lambda list: ~S"
|
|
lambda-list))
|
|
(setq state :key)))
|
|
(ecase state
|
|
(:required (push arg required-args))
|
|
(:optional (push arg optional-args))
|
|
(:rest (setq rest-arg arg
|
|
state :post-rest))
|
|
(:program (setq program-arg arg
|
|
state :post-program))
|
|
(:key (push arg keyword-args))))
|
|
finally
|
|
(when (eq state :rest)
|
|
(error "Missing &REST argument in command-line lambda list: ~S"
|
|
lambda-list))
|
|
(when (eq state :program)
|
|
(error "Missing &PROGRAM argument in command-line lambda list: ~S"
|
|
lambda-list))
|
|
(return
|
|
(values
|
|
program-arg
|
|
(nreverse required-args)
|
|
(nreverse optional-args)
|
|
rest-arg
|
|
(nreverse keyword-args)))))
|
|
|
|
(defmacro with-parsed-arguments ((&rest lambda-list) command-line &body body)
|
|
(multiple-value-bind (program-arg required-args optional-args
|
|
rest-arg keyword-args)
|
|
(parse-argument-lambda-list lambda-list)
|
|
(let ((required-argcount (length required-args))
|
|
(allowed-argcount (unless rest-arg
|
|
(+ (length required-args)
|
|
(length optional-args))))
|
|
(real-program-arg (or program-arg (gensym)))
|
|
(argument-ll (append required-args
|
|
(when optional-args
|
|
(cons '&optional optional-args))
|
|
(when rest-arg
|
|
(list '&rest rest-arg)))))
|
|
(multiple-value-bind (option-specs option-ll)
|
|
(loop for (var name args . default) in keyword-args
|
|
collect (list name var args) into option-specs
|
|
collect `((,var ,var) ,(car default)) into option-ll
|
|
finally
|
|
(return (values option-specs (list* '&key option-ll))))
|
|
(pmsf-lib:with-unique-names (arguments options)
|
|
`(multiple-value-bind (,real-program-arg ,arguments ,options)
|
|
(parse-command-line-arguments ,command-line
|
|
:option-specs ',option-specs
|
|
:required-arguments
|
|
,required-argcount
|
|
:allowed-arguments
|
|
,allowed-argcount)
|
|
(declare (ignorable ,real-program-arg))
|
|
(destructuring-bind ((,@argument-ll) (,@option-ll))
|
|
(list ,arguments (make-options-argument-list ,options))
|
|
,@body)))))))
|
|
|
|
(defmacro with-parsed-command-line ((&rest lambda-list) &body body)
|
|
`(with-parsed-arguments (,@lambda-list) (get-command-line-arguments)
|
|
,@body))
|