src/context.lisp

   1 ;;; context.lisp --- Context 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 (defvar *current-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 short call: ~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 negated call: ~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 *default-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 *current-context*))
 197   "Return CONTEXT's program name."
 198   (slot-value context 'progname))
 199
 200 (defun remainder (&key (context *current-context*))
 201   "Return CONTEXT's remainder."
 202   (slot-value context 'remainder))
 203
 204 (defun cmdline-options-p (&key (context *current-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 *current-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 *current-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 (defun search-option
 320     (context &rest keys &key short-name long-name partial-name)
 321   "Search for an option in CONTEXT.
 322 The search is done with SHORT-NAME, LONG-NAME, or PARTIAL-NAME.
 323 In case of a PARTIAL-NAME search, look for an option the long name of which
 324 begins with it.
 325 In case of multiple matches by PARTIAL-NAME, the longest match is selected.
 326 When such an option exists, return wo values:
 327 - the option itself,
 328 - the name used to find the option, possibly completed if partial."
 329   (econd ((or short-name long-name)
 330           (apply #'search-option-by-name context keys))
 331          (partial-name
 332           (search-option-by-abbreviation context partial-name))))
 333
 334 (defun search-sticky-option (context namearg)
 335   "Search for a sticky option in CONTEXT, matching NAMEARG.
 336 NAMEARG is the concatenation of the option's short name and its argument.
 337 In case of multiple matches, the option with the longest name is selected.
 338 When such an option exists, return two values:
 339 - the option itself,
 340 - the argument part of NAMEARG."
 341   (let ((longest-distance 0)
 342         closest-option)
 343     (do-options (option context)
 344       (let ((distance (option-sticky-distance option namearg)))
 345         (when (> distance longest-distance)
 346           (setq longest-distance distance)
 347           (setq closest-option option))))
 348     (when closest-option
 349       (values closest-option (subseq namearg longest-distance)))))
 350
 351
 352
 353 ;; ==========================================================================
 354 ;; The Option Retrieval Protocol
 355 ;; ==========================================================================
 356
 357 (defun getopt (&rest keys
 358                &key (context *current-context*) short-name long-name option)
 359   "Get an option's value in CONTEXT.
 360 The option can be specified either by SHORT-NAME, LONG-NAME, or directly via
 361 an OPTION object.
 362 Return two values:
 363 - the retrieved value,
 364 - the value's source."
 365   (unless option
 366     (setq option
 367           (apply #'search-option context (remove-keys keys :context))))
 368   (unless option
 369     (error "Getting option ~S from synopsis ~A in context ~A: unknown option."
 370            (or short-name long-name)
 371            (synopsis context)
 372            context))
 373   ;; Try the command-line:
 374   (let ((cmdline-options (list)))
 375     (do ((cmdline-option
 376           (pop (cmdline-options context))
 377           (pop (cmdline-options context))))
 378         ((null cmdline-option))
 379       (cond ((eq (cmdline-option-option cmdline-option) option)
 380              (setf (cmdline-options context)
 381                    ;; Actually, I *do* have a use for nreconc ;-)
 382                    (nreconc cmdline-options (cmdline-options context)))
 383              (return-from getopt
 384                (values (cmdline-option-value cmdline-option)
 385                        (list (cmdline-option-source cmdline-option)
 386                              (cmdline-option-name cmdline-option)))))
 387             (t
 388              (push cmdline-option cmdline-options))))
 389     (setf (cmdline-options context) (nreverse cmdline-options)))
 390   ;; Try an environment variable:
 391   (with-context-error-handler context
 392     (let* ((env-var (env-var option))
 393            (env-val (getenv env-var)))
 394       (when env-val
 395         (return-from getopt
 396           (values (retrieve-from-environment option env-val)
 397                   (list :environement env-var))))))
 398   ;; Try a default value:
 399   (when (and (typep option 'valued-option)
 400              (slot-boundp option 'default-value))
 401     (values (default-value option) :default)))
 402
 403 (defun getopt-cmdline (&key (context *current-context*))
 404   "Get the next command-line option in CONTEXT.
 405 When there is no next command-line option, return nil.
 406 Otherwise, return four values:
 407 - the option object,
 408 - the option's name used on the command-line,
 409 - the retrieved value,
 410 - the value source."
 411   (let ((cmdline-option (pop (cmdline-options context))))
 412     (when cmdline-option
 413       (values (cmdline-option-option cmdline-option)
 414               (cmdline-option-name cmdline-option)
 415               (cmdline-option-value cmdline-option)
 416               (cmdline-option-source cmdline-option)))))
 417
 418 (defmacro multiple-value-getopt-cmdline
 419     ((option name value source &key context) &body body)
 420   "Get the next command-line option in CONTEXT. and evaluate BODY.
 421 OPTION, NAME and VALUE are bound to the values returned by GETOPT-CMDLINE.
 422 BODY is executed only if there is a next command-line option."
 423   `(multiple-value-bind (,option ,name ,value ,source)
 424     (getopt-cmdline :context (or ,context *current-context*))
 425     (when ,option
 426       ,@body)))
 427
 428 (defmacro do-cmdline-options
 429     ((option name value source &key context) &body body)
 430   "Evaluate BODY over all command-line options in CONTEXT.
 431 OPTION, NAME and VALUE are bound to each option's object, name used on the
 432 command-line and retrieved value."
 433   (let ((ctx (gensym "context")))
 434     `(let ((,ctx (or ,context *current-context*)))
 435       (do () ((null (cmdline-options ,ctx)))
 436         (multiple-value-getopt-cmdline
 437             (,option ,name ,value ,source :context ,ctx)
 438           ,@body)))))
 439
 440
 441
 442 ;; ==========================================================================
 443 ;; Context Instance Creation
 444 ;; ==========================================================================
 445
 446 (defun read-long-name ()
 447   "Read an option's long name from standard input."
 448   (format t "Please type in the correct option's long name:~%")
 449   (let (line)
 450     (loop (setq line (read-line))
 451         (if (position #\= line)
 452             (format t "Option names can't contain equal signs. Try again:~%")
 453             (return (list line))))))
 454
 455 (defun read-call (&optional negated)
 456   "Read an option's call or pack from standard input.
 457 If NEGATED, read a negated call or pack. Otherwise, read a short call or pack."
 458   (format t "Please type in the correct ~
 459             ~:[short~;negated~] call or pack:~%"
 460     negated)
 461   (list (read-line)))
 462
 463 (defmethod initialize-instance :after ((context context) &key cmdline)
 464   "Parse CMDLINE."
 465   (setf (slot-value context 'progname) (pop cmdline))
 466   ;; #### WARNING: we have a chicken-and-egg problem here. The error handler
 467   ;; is supposed to be set from the --clon-error-handler option, but in order
 468   ;; to retrieve this option, we need to parse the command-line, which might
 469   ;; trigger some errors. Since we want the correct error handler to be set as
 470   ;; soon as possible, we need to treat this option in a very special way.
 471   ;; Here is what we do.
 472   ;; 1/ A very early value of :quit is provided in the class definition,
 473   ;;    thanks to an :initform.
 474   ;; 2/ Before doing anything else, we try to get a value from the
 475   ;;    environment. This is actually very simple: we can already use our
 476   ;;    context, eventhough it is not completely initialized yet. The only
 477   ;;    thing we need is a nil CMDLINE-OPTIONS slot, so that GETOPT directly
 478   ;;    goes to environment retrieval. If there's an error during this
 479   ;;    process, the handler is :quit. If nothing is found in the environment
 480   ;;    variable, the default value is retrieved, which is also :quit.
 481   (setf (slot-value context 'error-handler)
 482         (getopt :long-name "clon-error-handler" :context context))
 483   ;; 3/ Finally, during command-line parsing, we check if we got that
 484   ;; particular option, and handle it immediately.
 485   ;; Step one: parse the command-line =======================================
 486   (let ((cmdline-options (list))
 487         (remainder (list)))
 488     (macrolet ((push-cmdline-option (place &rest body)
 489                  "Push a new CMDLINE-OPTION created with BODY onto PLACE."
 490                  `(push (make-cmdline-option ,@body) ,place))
 491                (push-retrieved-option (place func option
 492                                        &optional cmdline-value cmdline)
 493                    "Retrieve OPTION from a FUNC call and push it onto PLACE.
 494 - FUNC must be either :short or :negated,
 495 - CMDLINE-VALUE is a potentially already parsed option argument,
 496 - CMDILNE is where to find a potentially required argument."
 497                    (let* ((value (gensym "value"))
 498                           (source (gensym "source"))
 499                           (vars (list source value))
 500                           (call (list option
 501                                       (find-symbol (concatenate 'string
 502                                                      "RETRIEVE-FROM-"
 503                                                      (symbol-name func)
 504                                                      "-CALL")
 505                                                    :com.dvlsoft.clon)))
 506                           new-cmdline)
 507                      (when cmdline-value
 508                        (push cmdline-value call))
 509                      (when cmdline
 510                        (setq new-cmdline (gensym "new-cmdline"))
 511                        (push new-cmdline vars)
 512                        (unless cmdline-value
 513                          (push nil call))
 514                        (push cmdline call))
 515                      `(multiple-value-bind ,(reverse vars) ,(reverse call)
 516                        ,(when cmdline `(setq ,cmdline ,new-cmdline))
 517                        (push-cmdline-option ,place
 518                         :name (short-name ,option)
 519                         :option ,option
 520                         :value ,value
 521                         :source ,source))))
 522                (do-pack ((option pack context) &body body)
 523                  "Evaluate BODY with OPTION bound to each option from PACK.
 524 CONTEXT is where to look for the options."
 525                  (let ((char (gensym "char"))
 526                        (name (gensym "name")))
 527                    `(loop :for ,char :across ,pack
 528                      :do (let* ((,name (make-string 1 :initial-element ,char))
 529                                 (,option (search-option ,context
 530                                            :short-name ,name)))
 531                            (assert ,option)
 532                            ,@body)))))
 533       (with-context-error-handler context
 534         (do ((arg (pop cmdline) (pop cmdline)))
 535             ((null arg))
 536           (cond ((string= arg "--")
 537                  ;; The Clon separator.
 538                  (setq remainder cmdline)
 539                  (setq cmdline nil))
 540                 ((beginning-of-string-p "--" arg)
 541                  ;; A long call.
 542                  (let* ((value-start (position #\= arg :start 2))
 543                         (cmdline-name (subseq arg 2 value-start))
 544                         (cmdline-value (when value-start
 545                                          (subseq arg (1+ value-start))))
 546                         option-name option)
 547                    (tagbody find-option
 548                       (setq option-name cmdline-name)
 549                       (setq option
 550                             (search-option context :long-name cmdline-name))
 551                       (unless option
 552                         (multiple-value-setq (option option-name)
 553                           (search-option context :partial-name cmdline-name)))
 554                       (if option
 555                           (multiple-value-bind (value source new-cmdline)
 556                               (retrieve-from-long-call option
 557                                                        option-name
 558                                                        cmdline-value
 559                                                        cmdline)
 560                             (setq cmdline new-cmdline)
 561                             ;; #### NOTE: see comment at the top of this
 562                             ;; function about this hack.
 563                             (if (string= (long-name option)
 564                                          "clon-error-handler")
 565                                 (setf (slot-value context 'error-handler)
 566                                       value)
 567                               (push-cmdline-option cmdline-options
 568                                                    :name option-name
 569                                                    :option option
 570                                                    :value value
 571                                                    :source source)))
 572                         (restart-case (error 'unknown-cmdline-option-error
 573                                              :name cmdline-name
 574                                              :argument cmdline-value)
 575                           (discard ()
 576                             :report "Discard unknown option."
 577                             nil)
 578                           (fix-option-name (new-cmdline-name)
 579                             :report "Fix the option's long name."
 580                             :interactive read-long-name
 581                             (setq cmdline-name new-cmdline-name)
 582                             (go find-option)))))))
 583                 ;; A short call, or a short pack.
 584                 ((beginning-of-string-p "-" arg)
 585                  (tagbody figure-this-short-call
 586                     (let* ((value-start (position #\= arg :start 2))
 587                            (cmdline-name (subseq arg 1 value-start))
 588                            (cmdline-value (when value-start
 589                                             (subseq arg (1+ value-start))))
 590                            option)
 591                       (when cmdline-value
 592                         (restart-case
 593                             (error 'invalid-short-equal-syntax :item arg)
 594                           (discard-argument ()
 595                             :report "Discard the argument."
 596                             (setq cmdline-value nil))
 597                           (stick-argument ()
 598                             :report "Stick argument to option name."
 599                             (setq cmdline-name (concatenate 'string
 600                                                  cmdline-name cmdline-value))
 601                             (setq cmdline-value nil))
 602                           (separate-argument ()
 603                              :report "Separate option from its argument."
 604                              (push cmdline-value cmdline)
 605                              (setq cmdline-value nil))))
 606                       (setq option
 607                             (search-option context :short-name cmdline-name))
 608                       (unless option
 609                         (multiple-value-setq (option cmdline-value)
 610                           (search-sticky-option context cmdline-name)))
 611                       (cond (option
 612                              (push-retrieved-option cmdline-options :short
 613                                                     option cmdline-value
 614                                                     cmdline))
 615                             ((potential-pack-p cmdline-name context)
 616                              ;; #### NOTE: When parsing a short pack, only the
 617                              ;; last option gets a cmdline argument because
 618                              ;; only the last one is allowed to retrieve an
 619                              ;; argument from there.
 620                              (do-pack (option
 621                                        (subseq cmdline-name 0
 622                                                (1- (length cmdline-name)))
 623                                        context)
 624                                (push-retrieved-option cmdline-options :short
 625                                                       option))
 626                              (let* ((name (subseq cmdline-name
 627                                                   (1- (length cmdline-name))))
 628                                     (option (search-option context
 629                                                            :short-name name)))
 630                                (assert option)
 631                                (push-retrieved-option
 632                                 cmdline-options :short option nil cmdline)))
 633                             (t
 634                              (restart-case
 635                                  (error 'unrecognized-short-call-error
 636                                         :short-call cmdline-name)
 637                                (discard ()
 638                                  :report "Discard this short call."
 639                                  nil)
 640                                (fix-short-call (new-cmdline-name)
 641                                  :report "Fix this short call."
 642                                  :interactive (lambda () (read-call))
 643                                  (setq arg (concatenate 'string
 644                                              "-" new-cmdline-name))
 645                                  (go figure-this-short-call))))))))
 646                 ;; A negated call or pack.
 647                 ((beginning-of-string-p "+" arg)
 648                  (block processing-negated-call
 649                    (tagbody figure-this-negated-call
 650                       (let* ((value-start (position #\= arg :start 2))
 651                              (cmdline-name (subseq arg 1 value-start))
 652                              (cmdline-value (when value-start
 653                                               (subseq arg (1+ value-start))))
 654                              option)
 655                         (when cmdline-value
 656                           (restart-case
 657                               (error 'invalid-negated-equal-syntax :item arg)
 658                             (discard-argument ()
 659                               :report "Discard the argument."
 660                               (setq cmdline-value nil))
 661                             (convert-to-short-and-stick ()
 662                               :report
 663                               "Convert to short call and stick argument."
 664                               (push (concatenate 'string
 665                                       "-" cmdline-name cmdline-value)
 666                                     cmdline)
 667                               (return-from processing-negated-call))
 668                             (convert-to-short-and-split ()
 669                               :report
 670                               "Convert to short call and split argument."
 671                               (push cmdline-value cmdline)
 672                               (push (concatenate 'string "-" cmdline-name)
 673                                     cmdline)
 674                               (return-from processing-negated-call))))
 675                         ;; #### NOTE: in theory, we could allow partial
 676                         ;; matches on short names when they're used with the
 677                         ;; negated syntax, because there's no sticky argument
 678                         ;; or whatever. But we don't. That's all. Short names
 679                         ;; are not meant to be long (otherwise, that would be
 680                         ;; long names right?), so they're not meant to be
 681                         ;; abbreviated.
 682                         (setq option
 683                               (search-option context :short-name cmdline-name))
 684                         (cond (option
 685                                (push-retrieved-option cmdline-options :negated
 686                                                       option))
 687                               ((potential-pack-p cmdline-name context)
 688                                (do-pack (option cmdline-name context)
 689                                  (push-retrieved-option cmdline-options
 690                                                         :negated option)))
 691                               (t
 692                                (restart-case
 693                                    (error 'unrecognized-negated-call-error
 694                                           :negated-call cmdline-name)
 695                                  (discard ()
 696                                    :report "Discard this negated call."
 697                                    nil)
 698                                  (fix-negated-call (new-cmdline-name)
 699                                    :report "Fix this negated call."
 700                                    :interactive (lambda ()
 701                                                   (read-call :negated))
 702                                    (setq arg (concatenate 'string
 703                                                "+" new-cmdline-name))
 704                                    (go figure-this-negated-call)))))))))
 705                 (t
 706                  ;; Not an option call. Consider this as an implicit remainder
 707                  ;; if one is expected. Contrary to the case of an explicit
 708                  ;; one however (separated from the rest of the cmdline by
 709                  ;; --), trigger an error if a remainder is not expected.
 710                  (cond ((null (postfix context))
 711                         (setq arg (cons arg cmdline))
 712                         (setq cmdline nil)
 713                         ;; Note that here, the whole remainder of the
 714                         ;; cmdline might be discraded at once.
 715                         (restartable-cmdline-junk-error arg))
 716                        (t
 717                         (setq remainder (cons arg cmdline))
 718                         (setq cmdline nil)))))))
 719       (setf (cmdline-options context) (nreverse cmdline-options))
 720       (setf (slot-value context 'remainder) remainder)))
 721   ;; Step two: handle internal options ======================================
 722   (when (getopt :context context :long-name "clon-banner")
 723     (format t "~A's command-line is powered by Clon,
 724 the Command-Line Options Nuker library, version ~A,
 725 written by Didier Verna <didier@lrde.epita.fr>.
 726
 727 Copyright (C) 2010, 2011 Didier Verna.
 728 Clon is released under the terms of a BSD style, open source license.
 729 See http://www.opensource.org/licenses/bsd-license for more information.
 730 Clon is provided with NO warranty; not even for MERCHANTABILITY
 731 or FITNESS FOR A PARTICULAR PURPOSE.~%"
 732       (pathname-name (progname :context context))
 733       (version :long))
 734     (exit))
 735   (let ((version-format (getopt :context context :long-name "clon-version")))
 736     (when version-format
 737       (format t "~A~%" (version version-format))
 738       (exit)))
 739   (setf (slot-value context 'search-path)
 740         (getopt :context context :long-name "clon-search-path"))
 741   (setf (slot-value context 'theme)
 742         (getopt :context context :long-name "clon-theme"))
 743   (setf (slot-value context 'line-width)
 744         (getopt :context context :long-name "clon-line-width"))
 745   (setf (slot-value context 'highlight)
 746         (getopt :context context :long-name "clon-highlight"))
 747   (when (getopt :context context :long-name "clon-help")
 748     (help :context context :item (clon-options-group context))
 749     (exit)))
 750
 751 (defun make-context (&rest keys &key synopsis cmdline (make-current t))
 752   "Make a new context.
 753 - SYNOPSIS is the program synopsis to use in that context.
 754   It defaults to *DEFAULT-SYNOPSIS*.
 755 - CMDLINE is the argument list (strings) to process.
 756   It defaults to a POSIX conformant argv.
 757 - If MAKE-CURRENT, make the new context current."
 758   (declare (ignore synopsis cmdline))
 759   (let ((context (apply #'make-instance 'context
 760                         (remove-keys keys :make-current))))
 761     (when make-current
 762       (setq *current-context* context))
 763     context))
 764
 765
 766
 767 ;; ==========================================================================
 768 ;; Context Manipulation Utilities
 769 ;; ==========================================================================
 770
 771 (defmacro with-context (context &body body)
 772   "Execute BODY with *current-context* bound to CONTEXT."
 773   `(let ((*current-context* ,context))
 774     ,@body))
 775
 776
 777 ;;; context.lisp ends here