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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA
  19
  20 ;; Defined in maxima-package.
  21 ;; (defpackage "COMMAND-LINE"
  22 ;;   (:use "COMMON-LISP")
  23 ;;   (:nicknames "CMDLINE")
  24 ;;   (:export "CL-OPTION" "MAKE-CL-OPTION" "LIST-CL-OPTIONS" "PROCESS-ARGS"
  25 ;;         "GET-APPLICATION-ARGS"))
  26
  27 (in-package :command-line)
  28
  29 (defstruct cl-option
  30   (names nil)
  31   (argument nil)
  32   (action nil)
  33   (help-string nil))
  34
  35 (defun cl-option-description (name arg)
  36   (if arg
  37       (cond ((= (length name) 1) (format nil "~a ~a" name arg))
  38             ((equal (subseq name 0 2) "--") (format nil "~a=~a" name arg))
  39             (t (format nil "~a ~a" name arg)))
  40       name))
  41
  42 #-gcl
  43 (defun print-help-string (help-string)
  44   "Print the help string neatly by breaking long lines as needed.
  45   This assumes that the HELP-STRING doesn't have any kind of manually
  46   inserted formatting."
  47   ;; Break the string into a list of words, where any number of
  48   ;; whitespace characters separates the words.
  49   (let ((words (pregexp::pregexp-split "\\s+" help-string)))
  50     ;; Print the list of words individually with a single space after,
  51     ;; and inserting a newline as needed.  Each line is prefixed by 8
  52     ;; spaces.  This bit of code is a slightly modified pprint-vector
  53     ;; example from
  54     ;; http://www.lispworks.com/documentation/HyperSpec/Body/22_bb.htm.
  55     (let ((*print-right-margin* 80))
  56       (pprint-logical-block (nil nil :prefix "        ")
  57         (let ((end (length words))
  58               (k 0))
  59           (when (plusp end)
  60             (loop (pprint-pop)
  61                   (princ (elt words k))
  62                   (if (= (incf k) end) (return nil))
  63                   (write-char #\space)
  64                   (pprint-newline :fill))))))))
  65
  66 ;; Gcl doesn't have pprint-logical-block and friends and I (rtoy) am
  67 ;; not going to try to implement it.  Just print the whole string out
  68 ;; as we used to do before.
  69 #+gcl
  70 (defun print-help-string (help-string)
  71   (format t "        ~a" help-string))
  72
  73 (defun list-cl-options (cl-option-list)
  74   (format t "options:~%")
  75   (dolist (opt cl-option-list)
  76     (let ((help-string (cl-option-help-string opt))
  77           (names (cl-option-names opt))
  78           (arg (cl-option-argument opt)))
  79       (format t "    ~a" (cl-option-description (first names) arg))
  80       (dolist (name (rest names))
  81         (format t ", ~a" (cl-option-description name arg)))
  82       (terpri)
  83       (when help-string
  84         (print-help-string help-string))
  85       (terpri)))
  86   (finish-output))
  87
  88 (defun process-args (args cl-option-list)
  89   (flet ((fixup (options)
  90            ;; Massage cl-option into the format wanted by getopt.
  91            ;; Basically, remove any leading dashes, and if the
  92            ;; cl-option includes an argument, treat it as a required
  93            ;; argument.
  94            (let ((opts nil))
  95              (dolist (o options)
  96                (dolist (name (cl-option-names o))
  97                  (push (list (string-left-trim "-" name)
  98                              (if (cl-option-argument o)
  99                                  :required
 100                                  :none)
 101                              nil)
 102                        opts)))
 103              (nreverse opts))))
 104     (let ((options (fixup cl-option-list)))
 105       (multiple-value-bind (non-opts opts errors)
 106           (getopt:getopt args options :allow-exact-match t)
 107         (declare (ignore non-opts))     ;non-opts ignored for now
 108         ;; Look over all of opts and run the action
 109         #+nil (format t "opts = ~S~%" opts)
 110         (dolist (o opts)
 111           ;; Try to find the corresponding cl-option.
 112           (let ((cl-opt (find (car o)
 113                               cl-option-list
 114                               :test #'(lambda (desired e)
 115                                         ;; Strip off any leading
 116                                         ;; dashes from the option name
 117                                         ;; and compare with the
 118                                         ;; desired option.
 119                                         (member desired (cl-option-names e)
 120                                                 :test #'equal
 121                                                 :key #'(lambda (e)
 122                                                          (string-left-trim "-" e)))))))
 123             #+nil (format t "Processing ~S -> ~S~%" o cl-opt)
 124             (if cl-opt
 125                 (cond ((and (cl-option-action cl-opt) (cl-option-argument cl-opt))
 126                        (funcall (cl-option-action cl-opt) (cdr o)))
 127                       ((cl-option-action cl-opt)
 128                        (funcall (cl-option-action cl-opt))))
 129                 (warn "Could not find option ~S in cl-options: ~S.~%Please report this bug."
 130                       o cl-option-list))))
 131         (format t "~{Warning: argument ~A not recognized.~%~}" errors)
 132         ;; What do we do about non-option arguments?  We just ignore them for now.
 133         ))))
 134
 135
 136 (defun get-application-args ()
 137   ;; -- is used to distinguish between options for a lisp implementation
 138   ;; and for Maxima.
 139   (flet ((remove-implementation-args (arglist)
 140            (let ((dashes (member "--" arglist :test #'equal)))
 141              (if dashes
 142                  (cdr dashes)
 143                  arglist))))
 144     (remove-implementation-args
 145      #+clisp
 146      (rest ext:*args*)
 147
 148      #+ecl
 149      (rest (ext:command-args))
 150
 151      #+cmu
 152      (if (boundp 'ext::*command-line-application-arguments*)
 153          ext::*command-line-application-arguments*
 154          (rest ext:*command-line-strings*))
 155
 156      #+scl
 157      (rest ext:*command-line-strings*)
 158
 159      #+sbcl
 160      (rest sb-ext:*posix-argv*)
 161
 162      #+gcl
 163      (rest si:*command-args*)
 164
 165      #+allegro
 166      (rest (system:command-line-arguments :application t))
 167
 168      #+lispworks
 169      (rest system:*line-arguments-list*)
 170
 171      #+openmcl
 172      (rest ccl:*command-line-argument-list*)
 173
 174      #+abcl
 175      ext:*command-line-argument-list*)))