1 ;;; option.lisp --- Basic Option management
3 ;; Copyright (C) 2010, 2011 Didier Verna
5 ;; Author: Didier Verna <didier@lrde.epita.fr>
6 ;; Maintainer: Didier Verna <didier@lrde.epita.fr>
8 ;; This file is part of Clon.
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.
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.
25 ;; Contents management by FCM version 0.1.
30 (in-package :com.dvlsoft.clon
)
31 (in-readtable :com.dvlsoft.clon
)
34 ;; ==========================================================================
36 ;; ==========================================================================
38 (defabstract option
(item)
39 ((short-name :documentation
"The option's short name."
40 :type
(or null string
)
44 (long-name :documentation
"The option's long name."
45 :type
(or null string
)
49 (description :documentation
"The option's description."
50 :type
(or null string
)
54 (env-var :documentation
"The option's associated environment variable."
55 :type
(or null string
)
61 (:documentation
"The OPTION class.
62 This is the base class for all options."))
69 (defmethod untraverse ((option option
))
70 "OPTION is a terminal object: just return it."
74 ;; ---------------------------
75 ;; Help specification protocol
76 ;; ---------------------------
78 (defmethod help-spec ((option option
) &key
)
79 "Return OPTION's help specification."
84 (when (short-name option
)
85 (format nil
"-~A" (short-name option
)))))
88 (when (long-name option
)
89 (format nil
"--~A" (long-name option
))))))
91 (accumulate (description)
93 (when (env-var option
)
95 (header "Environment:")
96 (variable ,(env-var option
)))))))
100 ;; ==========================================================================
102 ;; ==========================================================================
104 (define-condition option-error
(error)
105 ((option :documentation
"The concerned option."
109 (:documentation
"An error related to an option."))
113 ;; ==========================================================================
114 ;; The Name Clash Check Protocol
115 ;; ==========================================================================
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
))
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
))
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
))))))
148 ;; ==========================================================================
149 ;; The Option Search protocol
150 ;; ==========================================================================
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
)))
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."
165 (when (string= short-name
(short-name option
))
168 (when (string= long-name
(long-name option
))
171 (defgeneric option-sticky-distance
(option namearg
)
172 (:documentation ~
"Try to match OPTION's short name with a sticky argument "
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
))
187 ;; ==========================================================================
188 ;; The Char Packs Protocol
189 ;; ==========================================================================
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))
205 (coerce short-name
'character
)))))
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
)))
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
))
228 ;; ==========================================================================
229 ;; Option Instance Creation
230 ;; ==========================================================================
232 (defmethod initialize-instance :before
233 ((option option
) &key short-name long-name description internal
)
234 "Check validity of the name-related initargs."
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.
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
)))))
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_\"."
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
)))
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
))
273 ;;; option.lisp ends here