getopt-excerpt.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          getopt.lisp
   6 ;;;; Purpose:       Excerpted from cl-getopt package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Sep 2003
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; *************************************************************************
  13
  14 (in-package vcs-tree)
  15
  16
  17 (defun is-short-option (arg)
  18   (and (>= (length arg) 2)
  19        (char= #\- (schar arg 0))
  20        (char/= #\- (schar arg 1))))
  21
  22 (defun is-option-terminator (arg)
  23   (and (= 2 (length arg))
  24        (char= #\- (schar arg 0))
  25        (char= #\- (schar arg 1))))
  26
  27 (defun is-long-option (arg)
  28   (and (> (length arg) 2)
  29        (char= #\- (schar arg 0))
  30        (char= #\- (schar arg 1))
  31        (char/= #\- (schar arg 3))))
  32
  33 (defun decompose-arg (arg option-type)
  34   "Returns base-name,argument"
  35   (let ((start (ecase option-type
  36                  (:long 2)
  37                  (:short 1)))
  38         (name-end (position #\= arg)))
  39
  40     (values (subseq arg start name-end)
  41             (when name-end (subseq arg (1+ name-end))))))
  42
  43 (defun analyze-arg (arg)
  44   "Analyzes an argument. Returns option-type,base-name,argument"
  45   (let* ((option-type (cond ((is-short-option arg) :short)
  46                             ((is-long-option arg) :long)
  47                             (t :arg))))
  48     (if (or (eq option-type :short) (eq option-type :long))
  49         (multiple-value-bind (base arg) (decompose-arg arg option-type)
  50           (values option-type base arg))
  51         (values :arg arg nil))))
  52
  53
  54 (defun find-option (name options)
  55   "Find an option in option list. Handles using unique abbreviations"
  56   (let* ((option-names (mapcar #'car options))
  57          (pos (match-unique-abbreviation name option-names)))
  58     (when pos
  59       (nth pos options))))
  60
  61 (defun match-option (arg options)
  62   "Matches an argument to an option. Returns option-list,option-type,base-name,argument"
  63   (multiple-value-bind (option-type base-name argument) (analyze-arg arg)
  64     (let ((match (find-option base-name options)))
  65       (values match option-type (when match (car match)) argument))))
  66
  67
  68 ;;; EXPORTED functions
  69
  70 (defun match-unique-abbreviation (abbr strings)
  71   "Returns position of ABBR in STRINGS. ABBR may be a unique abbreviation.
  72 Returns NIL if no match found."
  73   (let ((len (length abbr))
  74         (matches nil))
  75     (dotimes (i (length strings))
  76       (let* ((s (nth i strings))
  77              (l (length s)))
  78         (cond
  79           ((= len l)
  80            (when (string= abbr s)
  81              (push (cons s i) matches)))
  82           ((< len l)
  83            (when (string= abbr (subseq s 0 len))
  84              (push (cons s i) matches))))))
  85     (when (= 1 (length matches))
  86       (cdr (first matches)))))
  87
  88
  89 (defun getopt (args options)
  90   "Processes a list of arguments and options. Returns filtered argument
  91 list and alist of options.
  92 opts is a list of option lists. The fields of the list are
  93  - NAME name of the long option
  94  - HAS-ARG with legal values of :NONE, :REQUIRED, :OPTIONAL
  95  - VAL value to return for a option with no arguments"
  96   (do ((pos args (cdr pos))
  97        (finished-options)
  98        (out-opts)
  99        (out-args)
 100        (errors))
 101       ((null pos) (values (nreverse out-args) (nreverse out-opts) errors))
 102     (cond
 103      (finished-options
 104       (push (car pos) out-args))
 105      ((is-option-terminator (car pos))
 106       (setq finished-options t))
 107      (t
 108       (let ((arg (car pos)))
 109         (multiple-value-bind (option-list option-type base-name argument)
 110             (match-option (car pos) options)
 111           (cond
 112             (option-list
 113              (cond
 114                (argument
 115                 (case (second option-list)
 116                   (:none
 117                    (push base-name errors))
 118                   (t
 119                    (push (cons base-name argument) out-opts))))
 120                ((null argument)
 121                 (if (and (eq :required (second option-list)) (null (cdr pos)))
 122                     (push base-name errors)
 123                     (if (or (is-short-option (second pos))
 124                             (is-long-option (second pos)))
 125                         (if (eq :required (second option-list))
 126                             (push base-name errors)
 127                             (push (cons base-name (third option-list)) out-args))
 128                         (progn
 129                           (push (cons base-name (second pos)) out-opts)
 130                           (setq pos (cdr pos))))))))
 131             (t
 132              (if (or (eq :long option-type)
 133                      (eq :short option-type))
 134                  (push (nth-value 0 (decompose-arg arg option-type)) errors)
 135                (push arg out-args))))))))))
 136