1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Command line option processing a la GNU getopt_long
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Sep 2003
10 ;;;; $Id: package.lisp 7814 2003-09-10 12:56:02Z kevin $
12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; KMRCL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
22 (defun is-short-option (arg)
23 (and (= 2 (length arg))
24 (char= #\- (schar arg 0))
25 (char/= #\- (schar arg 1))))
27 (defun is-option-terminator (arg)
28 (and (= 2 (length arg))
29 (char= #\- (schar arg 0))
30 (char= #\- (schar arg 1))))
32 (defun is-long-option (arg)
33 (and (> (length arg) 2)
34 (char= #\- (schar arg 0))
35 (char= #\- (schar arg 1))
36 (char/= #\- (schar arg 3))))
38 (defun arg->base-name (arg)
42 ((is-short-option arg)
47 (defun match-option (arg options)
48 "Matches an argument to an option. Returns match,is-long"
51 (values (find (subseq arg 2) options :key #'car :test #'equal) :long))
52 ((is-short-option arg)
53 (values (find (subseq arg 1) options :key #'car :test #'equal) :short))
57 (defun getopt (args options)
58 "Processes a list of arguments and options. Returns filtered argument
59 list and alist of options.
60 opts is a list of option lists. The fields of the list are
61 - NAME name of the long option
62 - HAS-ARG with legal values of :NONE, :REQUIRED, :OPTIONAL
63 - VAL value to return for a option with no arguments
65 (do ((pos args (cdr pos))
70 ((null pos) (values (nreverse out-args) (nreverse out-opts) errors))
73 (push (car pos) out-args))
74 ((is-option-terminator (car pos))
75 (setq finished-options t))
77 (multiple-value-bind (match is-long) (match-option (car pos) options)
80 ((and (eq :required (second match)) (null (cdr pos)))
81 (push (arg->base-name (car pos)) errors))
83 (push (cons (arg->base-name (car pos)) (second pos)) out-opts)
84 (setq pos (cdr pos))))
85 (push (car pos) out-args)))))))