Initial CL parser/generator implementation
This commit is contained in:
269
lib/cmdline-utilities.lisp
Normal file
269
lib/cmdline-utilities.lisp
Normal file
@ -0,0 +1,269 @@
|
||||
;;;; 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))
|
||||
Reference in New Issue
Block a user