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 (defvar *wrap-help-string* t
  43   "Wrap the help string when non-NIL")
  44
  45 (defun print-help-string (help-string)
  46   "Print the help string neatly by breaking long lines as needed.
  47   This assumes that the HELP-STRING doesn't have any kind of manually
  48   inserted formatting."
  49   (cond
  50     (*wrap-help-string*
  51      ;; Break the help string into a list of words and print the list
  52      ;; of words individually with a single space after, and inserting
  53      ;; a newline as needed.
  54      (let ((words (pregexp::pregexp-split "\\s+" help-string)))
  55        ;; This format string is a modified version of the example in
  56        ;; https://www.lispworks.com/documentation/HyperSpec/Body/22_cfb.htm.
  57        ;; Each line is prefixed by 8 spaces and we wrap the line at 80
  58        ;; columns.
  59        (format t "        ~{~<~%        ~1,80:; ~A~>~^~}" words)))
  60     (t
  61      (format t "        ~a" help-string))))
  62
  63 (defun list-cl-options (cl-option-list &key texi-table-form)
  64   "Prints all the command line options for Maxima in a neat form.  If
  65   :TEXI-TABLE-FORM is non-NIL, the output is suitable for adding a
  66   table to commandline-options.texi."
  67   (if texi-table-form
  68       (format t "@need 100~%@table @code~%")
  69       (format t "options:~%"))
  70   (dolist (opt cl-option-list)
  71     (let ((help-string (cl-option-help-string opt))
  72           (names (cl-option-names opt))
  73           (arg (cl-option-argument opt)))
  74       (when texi-table-form
  75         (format t "@need 150~%@item "))
  76       (let ((options (mapcar #'(lambda (name)
  77                                  (cl-option-description name arg))
  78                              names)))
  79         ;; Wrap any long list of options, except we don't when
  80         ;; producing output for the texi file.
  81         (cond (texi-table-form
  82                (format t "~{~A~^, ~}~%" options))
  83               (t
  84                ;; The output is 4 spaces, then each of the options
  85                ;; separated by a ", ".  The output is wrapped at
  86                ;; column 80.  This format string is a modified version
  87                ;; of the example from
  88                ;; https://www.lispworks.com/documentation/HyperSpec/Body/22_cfb.htm.
  89                (format t "    ~{~<~%      ~1,80:;~A~>~^, ~}~%"
  90                        options))))
  91
  92       (when help-string
  93         (print-help-string help-string))
  94       (when texi-table-form
  95         (format t "~2%"))
  96       (terpri)))
  97   (when texi-table-form
  98     (format t "@end table~%"))
  99   (finish-output))
 100
 101 (defun process-args (args cl-option-list)
 102   (flet ((fixup (options)
 103            ;; Massage cl-option into the format wanted by getopt.
 104            ;; Basically, remove any leading dashes, and if the
 105            ;; cl-option includes an argument, treat it as a required
 106            ;; argument.
 107            (let ((opts nil))
 108              (dolist (o options)
 109                (dolist (name (cl-option-names o))
 110                  (push (list (string-left-trim "-" name)
 111                              (if (cl-option-argument o)
 112                                  :required
 113                                  :none)
 114                              nil)
 115                        opts)))
 116              (nreverse opts))))
 117     (let ((options (fixup cl-option-list)))
 118       (multiple-value-bind (non-opts opts errors)
 119           (getopt:getopt args options :allow-exact-match t)
 120         (declare (ignore non-opts))     ;non-opts ignored for now
 121         ;; Look over all of opts and run the action
 122         #+nil (format t "opts = ~S~%" opts)
 123         (dolist (o opts)
 124           ;; Try to find the corresponding cl-option.
 125           (let ((cl-opt (find (car o)
 126                               cl-option-list
 127                               :test #'(lambda (desired e)
 128                                         ;; Strip off any leading
 129                                         ;; dashes from the option name
 130                                         ;; and compare with the
 131                                         ;; desired option.
 132                                         (member desired (cl-option-names e)
 133                                                 :test #'equal
 134                                                 :key #'(lambda (e)
 135                                                          (string-left-trim "-" e)))))))
 136             #+nil (format t "Processing ~S -> ~S~%" o cl-opt)
 137             (if cl-opt
 138                 (cond ((and (cl-option-action cl-opt) (cl-option-argument cl-opt))
 139                        (funcall (cl-option-action cl-opt) (cdr o)))
 140                       ((cl-option-action cl-opt)
 141                        (funcall (cl-option-action cl-opt))))
 142                 (warn "Could not find option ~S in cl-options: ~S.~%Please report this bug."
 143                       o cl-option-list))))
 144         (format t "~{Warning: argument ~A not recognized.~%~}" errors)
 145         ;; What do we do about non-option arguments?  We just ignore them for now.
 146         ))))
 147
 148
 149 (defun get-application-args ()
 150   ;; -- is used to distinguish between options for a lisp implementation
 151   ;; and for Maxima.
 152   (flet ((remove-implementation-args (arglist)
 153            (let ((dashes (member "--" arglist :test #'equal)))
 154              (if dashes
 155                  (cdr dashes)
 156                  arglist))))
 157     (remove-implementation-args
 158      #+clisp
 159      (rest ext:*args*)
 160
 161      #+ecl
 162      (rest (ext:command-args))
 163
 164      #+cmu
 165      (if (boundp 'ext::*command-line-application-arguments*)
 166          ext::*command-line-application-arguments*
 167          (rest ext:*command-line-strings*))
 168
 169      #+scl
 170      (rest ext:*command-line-strings*)
 171
 172      #+sbcl
 173      (rest sb-ext:*posix-argv*)
 174
 175      #+gcl
 176      (rest si:*command-args*)
 177
 178      #+allegro
 179      (rest (system:command-line-arguments :application t))
 180
 181      #+lispworks
 182      (rest system:*line-arguments-list*)
 183
 184      #+openmcl
 185      (rest ccl:*command-line-argument-list*)
 186
 187      #+abcl
 188      ext:*command-line-argument-list*)))