1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Excerpted from cl-getopt package
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Sep 2003
10 ;;;; $Id: package.lisp 7814 2003-09-10 12:56:02Z kevin $
12 ;;;; *************************************************************************
17 (defun is-short-option (arg)
18 (and (>= (length arg) 2)
19 (char= #\- (schar arg 0))
20 (char/= #\- (schar arg 1))))
22 (defun is-option-terminator (arg)
23 (and (= 2 (length arg))
24 (char= #\- (schar arg 0))
25 (char= #\- (schar arg 1))))
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))))
33 (defun decompose-arg (arg option-type)
34 "Returns base-name,argument"
35 (let ((start (ecase option-type
38 (name-end (position #\= arg)))
40 (values (subseq arg start name-end)
41 (when name-end (subseq arg (1+ name-end))))))
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)
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))))
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)))
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))))
68 ;;; EXPORTED functions
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))
75 (dotimes (i (length strings))
76 (let* ((s (nth i strings))
80 (when (string= abbr s)
81 (push (cons s i) matches)))
83 (when (string= abbr (subseq s 0 len))
84 (push (cons s i) matches))))))
85 (when (= 1 (length matches))
86 (cdr (first matches)))))
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))
101 ((null pos) (values (nreverse out-args) (nreverse out-opts) errors))
104 (push (car pos) out-args))
105 ((is-option-terminator (car pos))
106 (setq finished-options t))
108 (let ((arg (car pos)))
109 (multiple-value-bind (option-list option-type base-name argument)
110 (match-option (car pos) options)
115 (case (second option-list)
117 (push base-name errors))
119 (push (cons base-name argument) out-opts))))
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))
129 (push (cons base-name (second pos)) out-opts)
130 (setq pos (cdr pos))))))))
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))))))))))