src/context.lisp

   1 ;;; context.lisp --- Context management
   2
   3 ;; Copyright (C) 2010, 2011, 2012 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 (defvar *context* nil "The current context.")
  34
  35
  36
  37 ;; ==========================================================================
  38 ;; Command-line error management (not regarding known options)
  39 ;; ==========================================================================
  40
  41 (define-condition invalid-short-equal-syntax (cmdline-error)
  42   ()
  43   (:report (lambda (error stream)
  44              (format stream "Invalid = syntax in short call: ~S."
  45                (item error))))
  46   (:documentation "An error related to a short-equal syntax."))
  47
  48 (define-condition invalid-negated-equal-syntax (cmdline-error)
  49   ()
  50   (:report (lambda (error stream)
  51              (format stream "Invalid = syntax in negated call: ~S."
  52                (item error))))
  53   (:documentation "An error related to a negated-equal syntax."))
  54
  55 (define-condition cmdline-junk-error (cmdline-error)
  56   ((item ;; inherited from the CMDLINE-ERROR condition
  57     :documentation "The piece of junk appearing on the command-line."
  58     :initarg :junk
  59     :reader junk))
  60   (:report (lambda (error stream)
  61              (format stream "Junk on the command-line: ~S." (junk error))))
  62   (:documentation "An error related to a command-line piece of junk."))
  63
  64 (defun restartable-cmdline-junk-error (junk)
  65   (restart-case (error 'cmdline-junk-error :junk junk)
  66     (discard ()
  67       :report "Discard junk."
  68       nil)))
  69
  70 (define-condition unrecognized-short-call-error (cmdline-error)
  71   ((item ;; inherited from the CMDLINE-ERROR condition
  72     :documentation "The unrecognized short call on the command-line."
  73     :initarg :short-call
  74     :reader short-call))
  75   (:report (lambda (error stream)
  76              (format stream "Unrecognized option or short pack: ~S."
  77                (short-call error))))
  78   (:documentation "An error related to an unrecognized short call."))
  79
  80 (define-condition unrecognized-negated-call-error (cmdline-error)
  81   ((item ;; inherited from the CMDLINE-ERROR condition
  82     :documentation "The unrecognized negated call on the command-line."
  83     :initarg :negated-call
  84     :reader negated-call))
  85   (:report (lambda (error stream)
  86              (format stream "Unrecognized option or negated pack: ~S."
  87                (negated-call error))))
  88   (:documentation "An error related to an unrecognized negated call."))
  89
  90 (define-condition unknown-cmdline-option-error (cmdline-error)
  91   ((item ;; inherited from the CMDLINE-ERROR condition
  92     :documentation "The option's name as it appears on the command-line."
  93     :initarg :name
  94     :reader name)
  95    (argument :documentation "The option's command-line argument."
  96              :initarg :argument
  97              :reader argument))
  98   (:report (lambda (error stream)
  99              (format stream "Unknown command-line option ~
 100                             ~S~@[ with argument ~S~]."
 101                (name error)
 102                (argument error))))
 103   (:documentation "An error related to an unknown command-line option."))
 104
 105
 106 (defun print-error (error)
 107   "Print ERROR."
 108   (let (*print-escape*)
 109     (print-object error *error-output*))
 110   (terpri *error-output*))
 111
 112 (defun exit-abnormally (error)
 113   "Exit after ERROR occurred."
 114   (print-error error)
 115   (exit 1))
 116
 117 ;; Adapted from the Hyperspec
 118 (defun restart-on-error (error)
 119   "Print ERROR and offer available restarts."
 120   (print-error error)
 121   (format t "Available options:~%")
 122   (let ((restarts (compute-restarts)))
 123     (do ((i 0 (+ i 1)) (r restarts (cdr r))) ((null r))
 124       (format t "~&~D: ~A~%" i (car r)))
 125     (loop :with k := (length restarts) :and n := nil
 126           :until (and (typep n 'integer) (>= n 0) (< n k))
 127           :do (progn (format t "~&Option [0-~A]: " (1- k))
 128                      (finish-output)
 129                      (setq n (read))
 130                      (fresh-line))
 131           :finally (invoke-restart-interactively (nth n restarts)))))
 132
 133 ;; #### NOTE: this macro used to bind only for Clon errors, but other kinds of
 134 ;; errors may actually occur, for instance when retreiving a lispobj option's
 135 ;; value.
 136 (defmacro with-context-error-handler (context &body body)
 137   "Execute BODY with CONTEXT's error handler bound for CONDITION."
 138   `(handler-bind ((error
 139                     (lambda (error)
 140                       (ecase (error-handler ,context)
 141                         (:interactive
 142                          (restart-on-error error))
 143                         (:quit
 144                          (exit-abnormally error))
 145                         (:none)))))
 146      ,@body))
 147
 148
 149
 150 ;; ==========================================================================
 151 ;; The Context Class
 152 ;; ==========================================================================
 153
 154 (defstruct cmdline-option
 155   name ;; the option's name as used on the cmdline
 156   option ;; the corresponding option object
 157   value ;; the converted option's cmdline value
 158   source ;; the value source
 159   )
 160
 161 (defclass context ()
 162   ((synopsis :documentation "The program synopsis."
 163              :type synopsis
 164              :initarg :synopsis
 165              :reader synopsis
 166              :initform *synopsis*)
 167    (progname :documentation ~"The program name "
 168                             ~"as it appears on the command-line."
 169              :type string) ;; see below for reader
 170    (cmdline-options :documentation "The options from the command-line."
 171           :type list ;; of cmdline-option objects
 172           :initform nil  ;; see the warning in initialize-instance
 173           :accessor cmdline-options)
 174    (remainder :documentation "The non-Clon part of the command-line."
 175               :type list) ;; see below for reader
 176    (search-path :documentation "The search path for Clon files."
 177                 :reader search-path)
 178    (theme :documentation "The theme filename."
 179           :reader theme)
 180    (line-width :documentation "The line width for help display."
 181                :reader line-width
 182                :initform nil)
 183    (highlight :documentation "Clon's output highlight mode."
 184               :reader highlight)
 185    (error-handler :documentation ~"The behavior to adopt "
 186                                  ~"on option retrieval errors."
 187                   :type symbol
 188                   :initform :quit ;; see the warning in initialize-instance
 189                   :reader error-handler))
 190   (:default-initargs
 191    :cmdline (cmdline))
 192   (:documentation "The CONTEXT class.
 193 This class represents the associatiion of a synopsis and a set of command-line
 194 options based on it."))
 195
 196 (defun progname (&key (context *context*))
 197   "Return CONTEXT's program name."
 198   (slot-value context 'progname))
 199
 200 (defun remainder (&key (context *context*))
 201   "Return CONTEXT's remainder."
 202   (slot-value context 'remainder))
 203
 204 (defun cmdline-options-p (&key (context *context*))
 205   "Return T if CONTEXT has any unprocessed options left."
 206   (if (cmdline-options context) t nil))
 207
 208 (defun cmdline-p (&key (context *context*))
 209   "Return T if CONTEXT has anything on its command-line."
 210   (or (cmdline-options-p :context context)
 211       (remainder :context context)))
 212
 213
 214 ;; --------------------------------------------
 215 ;; Convenience wrappers around context synopsis
 216 ;; --------------------------------------------
 217
 218 (defmethod postfix ((context context))
 219   "Return the postfix of CONTEXT's synopsis."
 220   (postfix (synopsis context)))
 221
 222 (defmethod short-pack ((context context))
 223   "Return the short pack of CONTEXT's synopsis."
 224   (short-pack (synopsis context)))
 225
 226 (defmethod negated-pack ((context context))
 227   "Return the negated pack of CONTEXT's synopsis."
 228   (negated-pack (synopsis context)))
 229
 230 (defmethod clon-options-group ((context context))
 231   "Return the Clon options group of CONTEXT's synopsis."
 232   (clon-options-group (synopsis context)))
 233
 234 (defmethod potential-pack-p (pack (context context))
 235   "Return t if PACK (a string) is a potential pack in CONTEXT."
 236   (potential-pack-p pack (synopsis context)))
 237
 238
 239 ;; #### WARNING: the two wrappers below are here to make the DO-OPTIONS macro
 240 ;; work directly on contexts. Beware that both of them are needed.
 241
 242 (defmethod mapoptions (func (context context))
 243   "Map FUNC over all options in CONTEXT synopsis."
 244   (mapoptions func (synopsis context)))
 245
 246 (defmethod untraverse ((context context))
 247   "Untraverse CONTEXT synopsis."
 248   (untraverse (synopsis context)))
 249
 250
 251
 252 ;; =========================================================================
 253 ;; The Help Protocol
 254 ;; =========================================================================
 255
 256 ;; #### NOTE: all help related parameters but OUTPUT-STREAM have a
 257 ;; corresponding slot in contexts that act as a default value. The idea is
 258 ;; that users can in turn specify their preferences in the corresponding
 259 ;; environment variables. I don't think it would make much sense to provide an
 260 ;; option for OUTPUT-STREAM. At the end-user level, you can redirect to a file
 261 ;; from the shell.
 262
 263 (defun help (&key (context *context*)
 264                   (item (synopsis context))
 265                   (output-stream *standard-output*)
 266                   (search-path (search-path context))
 267                   (theme (theme context))
 268                   (line-width (line-width context))
 269                   (highlight (highlight context)))
 270   "Print CONTEXT's help."
 271   (let ((sheet (make-sheet :output-stream output-stream
 272                            :search-path search-path
 273                            :theme theme
 274                            :line-width line-width
 275                            :highlight highlight)))
 276     (print-help sheet
 277                 (help-spec item
 278                            :program (pathname-name (progname :context context))
 279                            :unhide t))
 280     (flush-sheet sheet)))
 281
 282
 283
 284 ;; =========================================================================
 285 ;; The Option Search Protocol
 286 ;; =========================================================================
 287
 288 (defun search-option-by-name (context &rest keys &key short-name long-name)
 289   "Search for option with either SHORT-NAME or LONG-NAME in CONTEXT.
 290 When such an option exists, return two values:
 291 - the option itself,
 292 - the name that matched."
 293   (declare (ignore short-name long-name))
 294   (do-options (option context)
 295     (let ((name (apply #'match-option option keys)))
 296       (when name
 297         (return-from search-option-by-name (values option name))))))
 298
 299 (defun search-option-by-abbreviation (context partial-name)
 300   "Search for option abbreviated with PARTIAL-NAME in CONTEXT.
 301 When such an option exists, return two values:
 302 - the option itself,
 303 - the completed name."
 304   (let ((shortest-distance most-positive-fixnum)
 305         closest-option)
 306     (do-options (option context)
 307       (let ((distance (option-abbreviation-distance option partial-name)))
 308         (when (< distance shortest-distance)
 309           (setq shortest-distance distance)
 310           (setq closest-option option))))
 311     (when closest-option
 312       (values closest-option
 313               ;; When long names are abbreviated (for instance --he instead of
 314               ;; --help), we register the command-line name like this: he(lp).
 315               ;; In case of error report, this will help the user spot where
 316               ;; he did something wrong.
 317               (complete-string partial-name (long-name closest-option))))))
 318
 319 #i(search-option 1)
 320 (defun search-option
 321     (context &rest keys &key short-name long-name partial-name)
 322   "Search for an option in CONTEXT.
 323 The search is done with SHORT-NAME, LONG-NAME, or PARTIAL-NAME.
 324 In case of a PARTIAL-NAME search, look for an option the long name of which
 325 begins with it.
 326 In case of multiple matches by PARTIAL-NAME, the longest match is selected.
 327 When such an option exists, return wo values:
 328 - the option itself,
 329 - the name used to find the option, possibly completed if partial."
 330   (econd ((or short-name long-name)
 331           (apply #'search-option-by-name context keys))
 332          (partial-name
 333           (search-option-by-abbreviation context partial-name))))
 334
 335 (defun search-sticky-option (context namearg)
 336   "Search for a sticky option in CONTEXT, matching NAMEARG.
 337 NAMEARG is the concatenation of the option's short name and its argument.
 338 In case of multiple matches, the option with the longest name is selected.
 339 When such an option exists, return two values:
 340 - the option itself,
 341 - the argument part of NAMEARG."
 342   (let ((longest-distance 0)
 343         closest-option)
 344     (do-options (option context)
 345       (let ((distance (option-sticky-distance option namearg)))
 346         (when (> distance longest-distance)
 347           (setq longest-distance distance)
 348           (setq closest-option option))))
 349     (when closest-option
 350       (values closest-option (subseq namearg longest-distance)))))
 351
 352
 353
 354 ;; ==========================================================================
 355 ;; The Option Retrieval Protocol
 356 ;; ==========================================================================
 357
 358 (defun getopt (&rest keys
 359                &key (context *context*) short-name long-name option)
 360   "Get an option's value in CONTEXT.
 361 The option can be specified either by SHORT-NAME, LONG-NAME, or directly via
 362 an OPTION object.
 363 Return two values:
 364 - the retrieved value,
 365 - the value's source."
 366   (unless option
 367     (setq option
 368           (apply #'search-option context (remove-keys keys :context))))
 369   (unless option
 370     (error "Getting option ~S from synopsis ~A in context ~A: unknown option."
 371            (or short-name long-name)
 372            (synopsis context)
 373            context))
 374   ;; Try the command-line:
 375   (let ((cmdline-options (list)))
 376     (do ((cmdline-option
 377           (pop (cmdline-options context))
 378           (pop (cmdline-options context))))
 379         ((null cmdline-option))
 380       (cond ((eq (cmdline-option-option cmdline-option) option)
 381              (setf (cmdline-options context)
 382                    ;; Actually, I *do* have a use for nreconc ;-)
 383                    (nreconc cmdline-options (cmdline-options context)))
 384              (return-from getopt
 385                (values (cmdline-option-value cmdline-option)
 386                        (list (cmdline-option-source cmdline-option)
 387                              (cmdline-option-name cmdline-option)))))
 388             (t
 389              (push cmdline-option cmdline-options))))
 390     (setf (cmdline-options context) (nreverse cmdline-options)))
 391   ;; Try an environment variable:
 392   (with-context-error-handler context
 393     (let* ((env-var (env-var option))
 394            (env-val (getenv env-var)))
 395       (when env-val
 396         (return-from getopt
 397           (values (retrieve-from-environment option env-val)
 398                   (list :environement env-var))))))
 399   ;; Try a default value:
 400   (when (and (typep option 'valued-option)
 401              (slot-boundp option 'default-value))
 402     (values (default-value option) :default)))
 403
 404 (defun getopt-cmdline (&key (context *context*))
 405   "Get the next command-line option in CONTEXT.
 406 When there is no next command-line option, return nil.
 407 Otherwise, return four values:
 408 - the option object,
 409 - the option's name used on the command-line,
 410 - the retrieved value,
 411 - the value source."
 412   (let ((cmdline-option (pop (cmdline-options context))))
 413     (when cmdline-option
 414       (values (cmdline-option-option cmdline-option)
 415               (cmdline-option-name cmdline-option)
 416               (cmdline-option-value cmdline-option)
 417               (cmdline-option-source cmdline-option)))))
 418
 419 (defmacro multiple-value-getopt-cmdline
 420     ((option name value source &key context) &body body)
 421   "Get the next command-line option in CONTEXT. and evaluate BODY.
 422 OPTION, NAME and VALUE are bound to the values returned by GETOPT-CMDLINE.
 423 BODY is executed only if there is a next command-line option."
 424   `(multiple-value-bind (,option ,name ,value ,source)
 425        (getopt-cmdline :context (or ,context *context*))
 426      (when ,option
 427        ,@body)))
 428
 429 (defmacro do-cmdline-options
 430     ((option name value source &key context) &body body)
 431   "Evaluate BODY over all command-line options in CONTEXT.
 432 OPTION, NAME and VALUE are bound to each option's object, name used on the
 433 command-line and retrieved value."
 434   (let ((ctx (gensym "context")))
 435     `(let ((,ctx (or ,context *context*)))
 436        (do () ((null (cmdline-options ,ctx)))
 437          (multiple-value-getopt-cmdline
 438              (,option ,name ,value ,source :context ,ctx)
 439            ,@body)))))
 440
 441
 442
 443 ;; ==========================================================================
 444 ;; Context Instance Creation
 445 ;; ==========================================================================
 446
 447 (defun read-long-name ()
 448   "Read an option's long name from standard input."
 449   (format t "Please type in the correct option's long name:~%")
 450   (let (line)
 451     (loop (setq line (read-line))
 452           (if (position #\= line)
 453               (format t "Option names can't contain equal signs. Try again:~%")
 454             (return (list line))))))
 455
 456 (defun read-call (&optional negated)
 457   "Read an option's call or pack from standard input.
 458 If NEGATED, read a negated call or pack. Otherwise, read a short call or pack."
 459   (format t "Please type in the correct ~
 460             ~:[short~;negated~] call or pack:~%"
 461     negated)
 462   (list (read-line)))
 463
 464 #i(push-cmdline-option 1)
 465 #i(push-retrieved-option 3)
 466 (defmethod initialize-instance :after ((context context) &key cmdline)
 467   "Parse CMDLINE."
 468   (setf (slot-value context 'progname) (pop cmdline))
 469   ;; #### WARNING: we have a chicken-and-egg problem here. The error handler
 470   ;; is supposed to be set from the --clon-error-handler option, but in order
 471   ;; to retrieve this option, we need to parse the command-line, which might
 472   ;; trigger some errors. Since we want the correct error handler to be set as
 473   ;; soon as possible, we need to treat this option in a very special way.
 474   ;; Here is what we do.
 475   ;; 1/ A very early value of :quit is provided in the class definition,
 476   ;;    thanks to an :initform.
 477   ;; 2/ Before doing anything else, we try to get a value from the
 478   ;;    environment. This is actually very simple: we can already use our
 479   ;;    context, eventhough it is not completely initialized yet. The only
 480   ;;    thing we need is a nil CMDLINE-OPTIONS slot, so that GETOPT directly
 481   ;;    goes to environment retrieval. If there's an error during this
 482   ;;    process, the handler is :quit. If nothing is found in the environment
 483   ;;    variable, the default value is retrieved, which is also :quit.
 484   (setf (slot-value context 'error-handler)
 485         (getopt :long-name "clon-error-handler" :context context))
 486   ;; 3/ Finally, during command-line parsing, we check if we got that
 487   ;; particular option, and handle it immediately.
 488   ;; Step one: parse the command-line =======================================
 489   (let ((cmdline-options (list))
 490         (remainder (list)))
 491     (macrolet ((push-cmdline-option (place &rest body)
 492                  "Push a new CMDLINE-OPTION created with BODY onto PLACE."
 493                  `(push (make-cmdline-option ,@body) ,place))
 494                (push-retrieved-option (place func option
 495                                              &optional cmdline-value cmdline)
 496                  "Retrieve OPTION from a FUNC call and push it onto PLACE.
 497 - FUNC must be either :short or :negated,
 498 - CMDLINE-VALUE is a potentially already parsed option argument,
 499 - CMDILNE is where to find a potentially required argument."
 500                  (let* ((value (gensym "value"))
 501                         (source (gensym "source"))
 502                         (vars (list source value))
 503                         (call (list option
 504                                     (find-symbol
 505                                      (concatenate 'string
 506                                        ;; #### NOTE: case portability
 507                                        (string :retrieve-from-)
 508                                        (symbol-name func)
 509                                        (string :-call))
 510                                      :com.dvlsoft.clon)))
 511                         new-cmdline)
 512                    (when cmdline-value
 513                      (push cmdline-value call))
 514                    (when cmdline
 515                      (setq new-cmdline (gensym "new-cmdline"))
 516                      (push new-cmdline vars)
 517                      (unless cmdline-value
 518                        (push nil call))
 519                      (push cmdline call))
 520                    `(multiple-value-bind ,(reverse vars) ,(reverse call)
 521                       ,(when cmdline `(setq ,cmdline ,new-cmdline))
 522                       (push-cmdline-option ,place
 523                         :name (short-name ,option)
 524                         :option ,option
 525                         :value ,value
 526                         :source ,source))))
 527                (do-pack ((option pack context) &body body)
 528                  "Evaluate BODY with OPTION bound to each option from PACK.
 529 CONTEXT is where to look for the options."
 530                  (let ((char (gensym "char"))
 531                        (name (gensym "name")))
 532                    `(loop :for ,char :across ,pack
 533                           :do (let* ((,name (make-string 1
 534                                               :initial-element ,char))
 535                                      (,option (search-option ,context
 536                                                 :short-name ,name)))
 537                                 (assert ,option)
 538                                 ,@body)))))
 539       (with-context-error-handler context
 540         (do ((arg (pop cmdline) (pop cmdline)))
 541             ((null arg))
 542           (cond ((string= arg "--")
 543                  ;; The Clon separator.
 544                  (setq remainder cmdline)
 545                  (setq cmdline nil))
 546                 ((beginning-of-string-p "--" arg)
 547                  ;; A long call.
 548                  (let* ((value-start (position #\= arg :start 2))
 549                         (cmdline-name (subseq arg 2 value-start))
 550                         (cmdline-value (when value-start
 551                                          (subseq arg (1+ value-start))))
 552                         option-name option)
 553                    (tagbody find-option
 554                       (setq option-name cmdline-name)
 555                       (setq option
 556                             (search-option context :long-name cmdline-name))
 557                       (unless option
 558                         (multiple-value-setq (option option-name)
 559                           (search-option context :partial-name cmdline-name)))
 560                       (if option
 561                           (multiple-value-bind (value source new-cmdline)
 562                               (retrieve-from-long-call option
 563                                                        option-name
 564                                                        cmdline-value
 565                                                        cmdline)
 566                             (setq cmdline new-cmdline)
 567                             ;; #### NOTE: see comment at the top of this
 568                             ;; function about this hack.
 569                             (if (string= (long-name option)
 570                                          "clon-error-handler")
 571                                 (setf (slot-value context 'error-handler)
 572                                       value)
 573                               (push-cmdline-option cmdline-options
 574                                 :name option-name
 575                                 :option option
 576                                 :value value
 577                                 :source source)))
 578                         (restart-case (error 'unknown-cmdline-option-error
 579                                              :name cmdline-name
 580                                              :argument cmdline-value)
 581                           (discard ()
 582                             :report "Discard unknown option."
 583                             nil)
 584                           (fix-option-name (new-cmdline-name)
 585                             :report "Fix the option's long name."
 586                             :interactive read-long-name
 587                             (setq cmdline-name new-cmdline-name)
 588                             (go find-option)))))))
 589                 ;; A short call, or a short pack.
 590                 ((beginning-of-string-p "-" arg)
 591                  (tagbody figure-this-short-call
 592                     (let* ((value-start (position #\= arg :start 2))
 593                            (cmdline-name (subseq arg 1 value-start))
 594                            (cmdline-value (when value-start
 595                                             (subseq arg (1+ value-start))))
 596                            option)
 597                       (when cmdline-value
 598                         (restart-case
 599                             (error 'invalid-short-equal-syntax :item arg)
 600                           (discard-argument ()
 601                             :report "Discard the argument."
 602                             (setq cmdline-value nil))
 603                           (stick-argument ()
 604                             :report "Stick argument to option name."
 605                             (setq cmdline-name
 606                                   (concatenate 'string
 607                                     cmdline-name cmdline-value))
 608                             (setq cmdline-value nil))
 609                           (separate-argument ()
 610                             :report "Separate option from its argument."
 611                             (push cmdline-value cmdline)
 612                             (setq cmdline-value nil))))
 613                       (setq option
 614                             (search-option context :short-name cmdline-name))
 615                       (unless option
 616                         (multiple-value-setq (option cmdline-value)
 617                           (search-sticky-option context cmdline-name)))
 618                       (cond (option
 619                              (push-retrieved-option cmdline-options :short
 620                                                     option cmdline-value
 621                                                     cmdline))
 622                             ((potential-pack-p cmdline-name context)
 623                              ;; #### NOTE: When parsing a short pack, only the
 624                              ;; last option gets a cmdline argument because
 625                              ;; only the last one is allowed to retrieve an
 626                              ;; argument from there.
 627                              (do-pack (option
 628                                        (subseq cmdline-name 0
 629                                                (1- (length cmdline-name)))
 630                                        context)
 631                                (push-retrieved-option cmdline-options :short
 632                                                       option))
 633                              (let* ((name (subseq cmdline-name
 634                                                   (1- (length cmdline-name))))
 635                                     (option (search-option context
 636                                               :short-name name)))
 637                                (assert option)
 638                                (push-retrieved-option
 639                                 cmdline-options :short option nil cmdline)))
 640                             (t
 641                              (restart-case
 642                                  (error 'unrecognized-short-call-error
 643                                         :short-call cmdline-name)
 644                                (discard ()
 645                                  :report "Discard this short call."
 646                                  nil)
 647                                (fix-short-call (new-cmdline-name)
 648                                  :report "Fix this short call."
 649                                  :interactive (lambda () (read-call))
 650                                  (setq arg (concatenate 'string
 651                                              "-" new-cmdline-name))
 652                                  (go figure-this-short-call))))))))
 653                 ;; A negated call or pack.
 654                 ((beginning-of-string-p "+" arg)
 655                  (block processing-negated-call
 656                    (tagbody figure-this-negated-call
 657                       (let* ((value-start (position #\= arg :start 2))
 658                              (cmdline-name (subseq arg 1 value-start))
 659                              (cmdline-value (when value-start
 660                                               (subseq arg (1+ value-start))))
 661                              option)
 662                         (when cmdline-value
 663                           (restart-case
 664                               (error 'invalid-negated-equal-syntax :item arg)
 665                             (discard-argument ()
 666                               :report "Discard the argument."
 667                               (setq cmdline-value nil))
 668                             (convert-to-short-and-stick ()
 669                               :report
 670                               "Convert to short call and stick argument."
 671                               (push (concatenate 'string
 672                                       "-" cmdline-name cmdline-value)
 673                                     cmdline)
 674                               (return-from processing-negated-call))
 675                             (convert-to-short-and-split ()
 676                               :report
 677                               "Convert to short call and split argument."
 678                               (push cmdline-value cmdline)
 679                               (push (concatenate 'string "-" cmdline-name)
 680                                     cmdline)
 681                               (return-from processing-negated-call))))
 682                         ;; #### NOTE: in theory, we could allow partial
 683                         ;; matches on short names when they're used with the
 684                         ;; negated syntax, because there's no sticky argument
 685                         ;; or whatever. But we don't. That's all. Short names
 686                         ;; are not meant to be long (otherwise, that would be
 687                         ;; long names right?), so they're not meant to be
 688                         ;; abbreviated.
 689                         (setq option
 690                               (search-option context :short-name cmdline-name))
 691                         (cond (option
 692                                (push-retrieved-option cmdline-options :negated
 693                                                       option))
 694                               ((potential-pack-p cmdline-name context)
 695                                (do-pack (option cmdline-name context)
 696                                  (push-retrieved-option cmdline-options
 697                                                         :negated option)))
 698                               (t
 699                                (restart-case
 700                                    (error 'unrecognized-negated-call-error
 701                                           :negated-call cmdline-name)
 702                                  (discard ()
 703                                    :report "Discard this negated call."
 704                                    nil)
 705                                  (fix-negated-call (new-cmdline-name)
 706                                    :report "Fix this negated call."
 707                                    :interactive (lambda ()
 708                                                   (read-call :negated))
 709                                    (setq arg (concatenate 'string
 710                                                "+" new-cmdline-name))
 711                                    (go figure-this-negated-call)))))))))
 712                 (t
 713                  ;; Not an option call. Consider this as an implicit remainder
 714                  ;; if one is expected. Contrary to the case of an explicit
 715                  ;; one however (separated from the rest of the cmdline by
 716                  ;; --), trigger an error if a remainder is not expected.
 717                  (cond ((null (postfix context))
 718                         (setq arg (cons arg cmdline))
 719                         (setq cmdline nil)
 720                         ;; Note that here, the whole remainder of the
 721                         ;; cmdline might be discraded at once.
 722                         (restartable-cmdline-junk-error arg))
 723                        (t
 724                         (setq remainder (cons arg cmdline))
 725                         (setq cmdline nil)))))))
 726       (setf (cmdline-options context) (nreverse cmdline-options))
 727       (setf (slot-value context 'remainder) remainder)))
 728   ;; Step two: handle internal options ======================================
 729   (when (getopt :context context :long-name "clon-banner")
 730     (format t "~A's command-line is powered by Clon,
 731 the Command-Line Options Nuker library, version ~A,
 732 written by Didier Verna <didier@lrde.epita.fr>.
 733
 734 Copyright (C) 2010, 2011 Didier Verna.
 735 Clon is released under the terms of the BSD license.
 736 See http://www.opensource.org/licenses/bsd-license for more information.
 737 Clon is provided with NO warranty; not even for MERCHANTABILITY
 738 or FITNESS FOR A PARTICULAR PURPOSE.~%"
 739       (pathname-name (progname :context context))
 740       (version :long))
 741     (exit))
 742   (let ((version-format (getopt :context context :long-name "clon-version")))
 743     (when version-format
 744       (format t "~A~%" (version version-format))
 745       (exit)))
 746   (when (getopt :context context :long-name "clon-lisp-information")
 747     (format t "~A ~A~%"
 748       (lisp-implementation-type)
 749       (lisp-implementation-version))
 750     (exit))
 751   (setf (slot-value context 'search-path)
 752         (getopt :context context :long-name "clon-search-path"))
 753   (setf (slot-value context 'theme)
 754         (getopt :context context :long-name "clon-theme"))
 755   (setf (slot-value context 'line-width)
 756         (getopt :context context :long-name "clon-line-width"))
 757   (setf (slot-value context 'highlight)
 758         (getopt :context context :long-name "clon-highlight"))
 759   ;; #### NOTE: do this one last because the output may depend on the values
 760   ;; from the above four.
 761   (when (getopt :context context :long-name "clon-help")
 762     (help :context context :item (clon-options-group context))
 763     (exit)))
 764
 765 (defun make-context (&rest keys &key synopsis cmdline (make-current t))
 766   "Make a new context.
 767 - SYNOPSIS is the program synopsis to use in that context.
 768   It defaults to *SYNOPSIS*.
 769 - CMDLINE is the argument list (strings) to process.
 770   It defaults to a POSIX conformant argv.
 771 - If MAKE-CURRENT, make the new context current."
 772   (declare (ignore synopsis cmdline))
 773   (let ((context (apply #'make-instance 'context
 774                         (remove-keys keys :make-current))))
 775     (when make-current
 776       (setq *context* context))
 777     context))
 778
 779
 780
 781 ;; ==========================================================================
 782 ;; Context Manipulation Utilities
 783 ;; ==========================================================================
 784
 785 (defmacro with-context (context &body body)
 786   "Execute BODY with *context* bound to CONTEXT."
 787   `(let ((*context* ,context))
 788      ,@body))
 789
 790
 791 ;;; context.lisp ends here