source: cl-darcs/trunk/getopt.lisp

;;; Copyright (C) 2008 Magnus Henoch
;;;
;;; This program 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 2 of the
;;; License, or (at your option) any later version.
;;;
;;; This program 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 this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

(in-package :darcs)

(define-condition invalid-arguments (simple-error)
  ())

;; The option struct describes a command line option.
(defstruct option
  ;; keyword for return value of GETOPT
  (keyword (error "No keyword specified.") :type keyword)
  ;; short name of one character
  (short nil :type (or character null))
  ;; long name
  (long nil :type (or string null))
  ;; does it take an argument?  if so, describe the argument type.
  (arg nil :type (or string null))
  ;; one-line help string
  (help (error "No help string specified.") :type string))

(defun getopt (args options &aux parsed leftover)
  "Process command line ARGS, as specified by OPTIONS.
ARGS is a list of strings.
OPTIONS is a list of OPTION structs.

Return two values: a alist of parsed options, and a list of leftover args.
The keys of the alists are the keywords of the options found, and the
values are the provided arguments, or T if the option takes no argument."
  (flet ((what (arg)
           (cond
             ((string= arg "--")
              :pass)
             ((and (>= (length arg) 2)
                   (string= arg "--" :end1 2))
              :long)
             ((and (>= (length arg) 1)
                   (string= arg "-" :end1 1))
              :short)
             (t
              nil)))
         (maybe-get-argument (arg opt &key no-argument)
           (push (cons (option-keyword opt)
                       (if (option-arg opt)
                           (if (or no-argument (null args))
                               (error 'invalid-arguments
                                      :format-control "Option ~A requires an argument."
                                      :format-arguments (list arg))
                               (pop args))
                           t))
                 parsed))
         (maybe-split-long-option (arg)
           (let ((equal-pos (position #\= arg)))
             (if equal-pos
                 (progn
                   (push (subseq arg (1+ equal-pos)) args)
                   (subseq arg 2 equal-pos))
                 (subseq arg 2)))))

    (loop while args do
         (ecase (what (car args))
           (:pass
            ;; Got "--".  Skip it and return the remaining arguments
            ;; without checking.
            (pop args)
            (return-from getopt (values parsed (append (nreverse leftover) args))))

           (:long
            ;; Got a long option.  Identify it and retrieve its
            ;; argument, if any.
            (let* ((arg (pop args))
                   (long-option (maybe-split-long-option arg))
                   (option (find long-option options :key #'option-long :test #'string=)))
              (unless option
                (error 'invalid-arguments
                       :format-control "Unknown long option ~S (none of ~{~S ~})."
                       :format-arguments (list arg (mapcar #'option-long options))))
              (maybe-get-argument arg option)))

           (:short
            ;; Got a string of short options.  Identify them all.
            (let* ((arg (pop args))
                   (letters (map 'list #'identity (subseq arg 1))))

              (loop while letters
                 do
                   (let* ((letter (pop letters))
                          (option (find letter options :key #'option-short)))
                     (unless option
                       (error 'invalid-arguments
                              :format-control "Unknown option ~A."
                              :format-arguments (list letter)))
                     ;; Only the last short option can have an argument.
                     (maybe-get-argument letter option 
                                         :no-argument (not (null letters)))))))

           ((nil)
            ;; Not an option - leftover args.
            (push (pop args) leftover))))

    (values parsed (nreverse leftover))))