src/command-line.lisp

   1 ;;;; command-line.lisp -- Application command line argument retrieval
   2 ;;;;                      and processing for Common Lisp.
   3
   4 ;;;; Copyright (C) 2003 James F. Amundson
   5
   6 ;;;; command-line.lisp is free software; you can redistribute it
   7 ;;;; and/or modify it under the terms of the GNU General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 2, or (at your option) any later version.
  10
  11 ;;;; command-line.lisp is distributed in the hope that it will be
  12 ;;;; useful, but WITHOUT ANY WARRANTY; without even the implied
  13 ;;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14 ;;;; See the GNU General Public License for more details.
  15
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with command-line.lisp; see the file COPYING.  If not,
  18 ;;;; write to the Free Software Foundation, Inc., 59 Temple Place -
  19 ;;;; Suite 330, Boston, MA 02111-1307, USA.
  20
  21 ;; Defined in maxima-package.
  22 ;; (defpackage "COMMAND-LINE"
  23 ;;   (:use "COMMON-LISP")
  24 ;;   (:nicknames "CMDLINE")
  25 ;;   (:export "CL-OPTION" "MAKE-CL-OPTION" "LIST-CL-OPTIONS" "PROCESS-ARGS"
  26 ;;         "GET-APPLICATION-ARGS"))
  27
  28 (in-package :command-line)
  29
  30 (defstruct cl-option
  31   (names nil)
  32   (argument nil)
  33   (action nil)
  34   (help-string nil))
  35
  36 (defun cl-option-description (name arg)
  37   (if arg
  38       (cond ((= (length name) 1) (format nil "~a ~a" name arg))
  39             ((equal (subseq name 0 2) "--") (format nil "~a=~a" name arg))
  40             (t (format nil "~a ~a" name arg)))
  41       name))
  42
  43 (defun list-cl-options (cl-option-list)
  44   (format t "options:~%")
  45   (dolist (opt cl-option-list)
  46     (let ((help-string (cl-option-help-string opt))
  47           (names (cl-option-names opt))
  48           (arg (cl-option-argument opt)))
  49       (format t "    ~a" (cl-option-description (first names) arg))
  50       (dolist (name (rest names))
  51         (format t ", ~a" (cl-option-description name arg)))
  52       (terpri)
  53       (if help-string
  54           (format t "        ~a" help-string))
  55       (terpri)))
  56   (finish-output))
  57
  58 ;; Old argument processing.  Leaving this here for now, but if getopts
  59 ;; works well enough, then these should be removed.
  60 #+(or)
  61 (progn
  62 (defun parse-args (args cl-option-list)
  63   (if (null args)
  64       nil
  65       (let ((arg (pop args))
  66             (arg-matched nil))
  67         (dolist (opt cl-option-list)
  68           (when (member arg (cl-option-names opt) :test #'equal)
  69             (cond ((and (cl-option-action opt) (cl-option-argument opt))
  70                    (funcall (cl-option-action opt) (pop args)))
  71                   ((cl-option-action opt)
  72                    (funcall (cl-option-action opt)))
  73                   ((cl-option-argument opt)
  74                    (pop args)))
  75             (setf arg-matched t)
  76             (return t)))
  77         (unless (or arg-matched (equal arg ""))
  78           (format t "Warning: argument ~a not recognized~%" arg))
  79         (parse-args args cl-option-list))))
  80
  81 (defun expand-compound-arg (arg)
  82   (map 'list  #'(lambda (char) (concatenate 'string "-" (string char)))
  83        (subseq arg 1)))
  84
  85 (defun expand-equals-arg (arg)
  86   (let ((equals-position (search "=" arg)))
  87     (list (subseq arg 0 equals-position) (subseq arg (+ 1 equals-position)))))
  88
  89 (defun expand-args (args)
  90   (if (null args)
  91       nil
  92       (let* ((arg (car args))
  93              (rest (expand-args (cdr args)))
  94              (listarg (list arg)))
  95         (cond ((< (length arg) 2) nil)
  96               ((and (equal (subseq arg 0 2) "--") (search "=" arg))
  97                (setf listarg (expand-equals-arg arg)))
  98               ((equal (subseq arg 0 2) "--") nil)
  99               ((equal (char arg 0) #\-)
 100                (if (> (length arg) 2)
 101                    (setf listarg (expand-compound-arg arg)))))
 102         (append listarg rest))))
 103
 104 (defun process-args (args cl-option-list)
 105   (parse-args (expand-args args) cl-option-list))
 106 )
 107
 108 (defun process-args (args cl-option-list)
 109   (flet ((fixup (options)
 110            ;; Massage cl-option into the format wanted by getopt.
 111            ;; Basically, remove any leading dashes, and if the
 112            ;; cl-option includes an argument, treat it as a required
 113            ;; argument.
 114            (let ((opts nil))
 115              (dolist (o options)
 116                (dolist (name (cl-option-names o))
 117                  (push (list (string-left-trim "-" name)
 118                              (if (cl-option-argument o)
 119                                  :required
 120                                  :none)
 121                              nil)
 122                        opts)))
 123              (nreverse opts))))
 124     (let ((options (fixup cl-option-list)))
 125       (multiple-value-bind (non-opts opts errors)
 126           (getopt:getopt args options :allow-exact-match t)
 127         (declare (ignore non-opts))     ;non-opts ignored for now
 128         ;; Look over all of opts and run the action
 129         #+nil (format t "opts = ~S~%" opts)
 130         (dolist (o opts)
 131           ;; Try to find the corresponding cl-option.
 132           (let ((cl-opt (find (car o)
 133                               cl-option-list
 134                               :test #'(lambda (desired e)
 135                                         ;; Strip off any leading
 136                                         ;; dashes from the option name
 137                                         ;; and compare with the
 138                                         ;; desired option.
 139                                         (member desired (cl-option-names e)
 140                                                 :test #'equal
 141                                                 :key #'(lambda (e)
 142                                                          (string-left-trim "-" e)))))))
 143             #+nil (format t "Processing ~S -> ~S~%" o cl-opt)
 144             (if cl-opt
 145                 (cond ((and (cl-option-action cl-opt) (cl-option-argument cl-opt))
 146                        (funcall (cl-option-action cl-opt) (cdr o)))
 147                       ((cl-option-action cl-opt)
 148                        (funcall (cl-option-action cl-opt))))
 149                 (warn "Could not find option ~S in cl-options: ~S.~%Please report this bug."
 150                       o cl-option-list))))
 151         (format t "~{Warning: argument ~A not recognized.~%~}" errors)
 152         ;; What do we do about non-option arguments?  We just ignore them for now.
 153         ))))
 154
 155
 156 (defun get-application-args ()
 157   ;; -- is used to distinguish between options for a lisp implementation
 158   ;; and for Maxima.
 159   (flet ((remove-implementation-args (arglist)
 160            (let ((dashes (member "--" arglist :test #'equal)))
 161              (if dashes
 162                  (cdr dashes)
 163                  arglist))))
 164     (remove-implementation-args
 165      #+clisp
 166      (rest ext:*args*)
 167
 168      #+ecl
 169      (rest (ext:command-args))
 170
 171      #+cmu
 172      (if (boundp 'ext::*command-line-application-arguments*)
 173          ext::*command-line-application-arguments*
 174          (rest ext:*command-line-strings*))
 175
 176      #+scl
 177      (rest ext:*command-line-strings*)
 178
 179      #+sbcl
 180      (rest sb-ext:*posix-argv*)
 181
 182      #+gcl
 183      (rest si:*command-args*)
 184
 185      #+allegro
 186      (rest (system:command-line-arguments :application t))
 187
 188      #+lispworks
 189      (rest system:*line-arguments-list*)
 190
 191      #+openmcl
 192      (rest ccl:*command-line-argument-list*)
 193
 194      #+abcl
 195      ext:*command-line-argument-list*)))