src/options/option.lisp

   1 ;;; option.lisp --- Basic Option management
   2
   3 ;; Copyright (C) 2010, 2011 Didier Verna
   4
   5 ;; Author:        Didier Verna <didier@lrde.epita.fr>
   6 ;; Maintainer:    Didier Verna <didier@lrde.epita.fr>
   7
   8 ;; This file is part of Clon.
   9
  10 ;; Permission to use, copy, modify, and distribute this software for any
  11 ;; purpose with or without fee is hereby granted, provided that the above
  12 ;; copyright notice and this permission notice appear in all copies.
  13
  14 ;; THIS SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  15 ;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  16 ;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  17 ;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  18 ;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  19 ;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  20 ;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  21
  22
  23 ;;; Commentary:
  24
  25 ;; Contents management by FCM version 0.1.
  26
  27
  28 ;;; Code:
  29
  30 (in-package :com.dvlsoft.clon)
  31 (in-readtable :com.dvlsoft.clon)
  32
  33
  34 ;; ==========================================================================
  35 ;; The Option Class
  36 ;; ==========================================================================
  37
  38 (defabstract option (item)
  39   ((short-name :documentation "The option's short name."
  40                :type (or null string)
  41                :initarg :short-name
  42                :initform nil
  43                :reader short-name)
  44    (long-name :documentation "The option's long name."
  45               :type (or null string)
  46               :initarg :long-name
  47               :initform nil
  48               :reader long-name)
  49    (description :documentation "The option's description."
  50                 :type (or null string)
  51                 :initarg :description
  52                 :initform nil
  53                 :reader description)
  54    (env-var :documentation "The option's associated environment variable."
  55             :type (or null string)
  56             :initarg :env-var
  57             :initform nil
  58             :reader env-var))
  59   (:default-initargs
  60     :internal nil)
  61   (:documentation "The OPTION class.
  62 This is the base class for all options."))
  63
  64
  65 ;; ------------------
  66 ;; Traversal protocol
  67 ;; ------------------
  68
  69 (defmethod untraverse ((option option))
  70   "OPTION is a terminal object: just return it."
  71   option)
  72
  73
  74 ;; ---------------------------
  75 ;; Help specification protocol
  76 ;; ---------------------------
  77
  78 (defmethod help-spec ((option option) &key)
  79   "Return OPTION's help specification."
  80   (accumulate (option)
  81     (accumulate (syntax)
  82       (accumulate (short)
  83         (accumulate (name)
  84           (when (short-name option)
  85             (format nil "-~A" (short-name option)))))
  86       (accumulate (long)
  87         (accumulate (name)
  88           (when (long-name option)
  89             (format nil "--~A" (long-name option))))))
  90     (accumulate (usage)
  91       (accumulate (description)
  92         (description option))
  93       (when (env-var option)
  94         `(environment
  95           (header "Environment:")
  96           (variable ,(env-var option)))))))
  97
  98
  99
 100 ;; ==========================================================================
 101 ;; Error Management
 102 ;; ==========================================================================
 103
 104 (define-condition option-error (error)
 105   ((option :documentation "The concerned option."
 106            :type option
 107            :initarg :option
 108            :reader option))
 109   (:documentation "An error related to an option."))
 110
 111
 112
 113 ;; ==========================================================================
 114 ;; The Name Clash Check Protocol
 115 ;; ==========================================================================
 116
 117 (defgeneric check-name-clash (item1 item2)
 118   (:documentation ~"Check for name clash between ITEM1's options "
 119                   ~"and ITEM2's options.")
 120   (:method (item1 (text text))
 121     "Do nothing (no name clash with a text object."
 122     #+(or ccl ecl clisp) (declare (ignore item1))
 123     #+ecl                (declare (ignore text))
 124     (values))
 125   (:method ((text text) item2)
 126     "Do nothing (no name clash with a text object."
 127     #+(or ccl ecl clisp) (declare (ignore item2))
 128     #+ecl                (declare (ignore text))
 129     (values))
 130   ;; #### NOTE: currently, name clashes are considered on short and long names
 131   ;; independently. That is, it is possible to have a short name identical to
 132   ;; a long one, although I don't see why you would want to do that, and I
 133   ;; should probably prohibit it altogether.
 134   (:method ((option1 option) (option2 option))
 135     "Ensure that there is no name clash between OPTION1 and OPTION2."
 136     (unless (eq option1 option2)
 137       (when (and (short-name option1) (short-name option2)
 138                  (string= (short-name option1) (short-name option2)))
 139         (error "Options ~A and ~A: indentical short name ~S."
 140                option1 option2 (short-name option1)))
 141       (when (and (long-name option1) (long-name option2)
 142                  (string= (long-name option1) (long-name option2)))
 143         (error "Options ~A and ~A: identical Long name ~S."
 144                option1 option2 (long-name option1))))))
 145
 146
 147
 148 ;; ==========================================================================
 149 ;; The Option Search protocol
 150 ;; ==========================================================================
 151
 152 (defun option-abbreviation-distance (option partial-name)
 153   "Return the distance between OPTION's long name and PARTIAL-NAME.
 154 If PARTIAL-NAME does not abbreviate OPTION's long name, return
 155 MOST-POSITIVE-FIXNUM."
 156   (with-slots (long-name) option
 157     (if (beginning-of-string-p partial-name long-name)
 158         (- (length long-name) (length partial-name))
 159       most-positive-fixnum)))
 160
 161 (defun match-option (option &key short-name long-name)
 162   "Try to match OPTION against SHORT-NAME, LONG-NAME.
 163 If OPTION matches, return the name that matched."
 164   (econd (short-name
 165           (when (string= short-name (short-name option))
 166             short-name))
 167          (long-name
 168           (when (string= long-name (long-name option))
 169             long-name))))
 170
 171 (defgeneric option-sticky-distance (option namearg)
 172   (:documentation ~"Try to match OPTION's short name with a sticky argument "
 173                   ~"against NAMEARG.
 174 If OPTION matches, return the length of OPTION's short name; otherwise 0.")
 175   ;; #### NOTE: this method currently only applies to flags.
 176   (:method ((option option) namearg)
 177     "Return 0 (non-valued options don't take any argument, sticky or not)."
 178     ;; #### NOTE: the consequence of this method returning 0 is that
 179     ;; non-valued options (i.e. flags) won't ever get a cmdline-argument in
 180     ;; retrieve-from-short-call, hence the assertion there.
 181     #+(or ccl ecl clisp) (declare (ignore namearg))
 182     #+ecl                (declare (ignore option))
 183     0))
 184
 185
 186
 187 ;; ==========================================================================
 188 ;; The Char Packs Protocol
 189 ;; ==========================================================================
 190
 191 ;; When examining the command-line, we first try to spot an option, then a
 192 ;; short or negated pack, and then fall back to an unknown option. When things
 193 ;; are messed up, we prefer to try to spot options misplaced in a pack rather
 194 ;; than directly an unknown option. That's what a "potential" pack is: a pack
 195 ;; composed of single character options that are potentially misused.
 196 ;; Potential misuse means non switch-based in a negated pack, options with
 197 ;; mandatory arguments in the middle of a pack and so on.
 198 (defun potential-pack-char (option &optional as-string)
 199   "Return OPTION's potential pack character, if any.
 200 If AS-STRING, return a string of that character."
 201   (with-slots (short-name) option
 202     (when (and short-name (= (length short-name) 1))
 203       (if as-string
 204           short-name
 205         (coerce short-name 'character)))))
 206
 207 (defgeneric short-pack-char (option &optional as-string)
 208   (:documentation "Return OPTION's short pack character, if any.
 209 If AS-STRING, return a string of that character.")
 210   ;; #### NOTE: this method currently only applies to flags.
 211   (:method ((option option) &optional as-string)
 212     "Return OPTION's potential pack character."
 213     ;; Since non-valued options don't take any argument, being short-pack'able
 214     ;; is the same as being potentially packable.
 215     (potential-pack-char option as-string)))
 216
 217 (defgeneric negated-pack-char (option &optional as-string)
 218   (:documentation "Return OPTION's negated pack character, if any.
 219 If AS-STRING, return a string of that character.")
 220   (:method ((option option) &optional as-string)
 221     "Return nil (only the switch hierarchy is negated-pack'able)."
 222     (declare (ignore as-string))
 223     #+ecl (declare (ignore option))
 224     nil))
 225
 226
 227
 228 ;; ==========================================================================
 229 ;; Option Instance Creation
 230 ;; ==========================================================================
 231
 232 (defmethod initialize-instance :before
 233     ((option option) &key short-name long-name description internal)
 234   "Check validity of the name-related initargs."
 235   (when internal
 236     (assert (not (or (zerop (length long-name))
 237                      (zerop (length description))))))
 238   (unless (or short-name long-name)
 239     (error "Option ~A: no name given." option))
 240   (when (and long-name (zerop (length long-name)))
 241     (error "Option ~A: empty long name." option))
 242   (when (and short-name (zerop (length short-name)))
 243     (error "Option ~A: empty short name." option))
 244   (when (and short-name long-name (string= short-name long-name))
 245     (error "Option ~A: short and long names identical." option))
 246   ;; Short names can't begin with a dash because that would conflict with
 247   ;; the long name syntax.
 248   (when (and short-name (beginning-of-string-p "-" short-name))
 249     (error "Option ~A: short name begins with a dash." option))
 250   ;; Clon uses only long names, not short ones. But it's preferable to
 251   ;; reserve the prefix in both cases.
 252   (unless internal
 253     (dolist (name (list short-name long-name))
 254       (when (and name (or (string= name "clon")
 255                           (beginning-of-string-p "clon-" name)))
 256         (error "Option ~A: name ~S reserved by Clon." option name)))))
 257
 258 (defmethod initialize-instance :around
 259     ((option option) &rest keys &key long-name env-var internal)
 260   "If INTERNAL, prefix LONG-NAME with \"clon-\" and ENV-VAR with \"CLON_\"."
 261   (when internal
 262     ;; #### NOTE: technically, the calls to REMOVE-KEYS below are not needed
 263     ;; because in case of duplication, the leftmost initarg is used (see
 264     ;; section 7.1.4 "Rules for Initialization Arguments" of the Hyperspec).
 265     (setq long-name (concatenate 'string "clon-" long-name))
 266     (setq keys (list* :long-name long-name (remove-keys keys :long-name)))
 267     (when env-var
 268       (setq env-var (concatenate 'string "CLON_" env-var))
 269       (setq keys (list* :env-var env-var (remove-keys keys :env-var)))))
 270   (apply #'call-next-method option keys))
 271
 272
 273 ;;; option.lisp ends here