+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: getopt.lisp
+;;;; Purpose: Command line option processing a la GNU getopt_long
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Sep 2003
+;;;;
+;;;; $Id: package.lisp 7814 2003-09-10 12:56:02Z kevin $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmr)
+
+
+(defun is-short-option (arg)
+ (and (= 2 (length arg))
+ (char= #\- (schar arg 0))
+ (char/= #\- (schar arg 1))))
+
+(defun is-option-terminator (arg)
+ (and (= 2 (length arg))
+ (char= #\- (schar arg 0))
+ (char= #\- (schar arg 1))))
+
+(defun is-long-option (arg)
+ (and (> (length arg 2))
+ (char= #- (schar 0))
+ (char= #- (schar 1))
+ (char/= #- (schar 3))))
+
+(defun match-option (arg options)
+ "Matches an argument to an option. Returns match,is-long"
+ (cond
+ ((is-long-option arg)
+ (values (find (subseq arg 2) options :key #'car :test #'equal) :long))
+ ((is-short-option arg)
+ (values (find (subseq arg 1) options :key #'car :test #'equal) :short))
+ (t
+ (values nil nil))))
+
+(defun getopt (args opts)
+ "Processes a list of arguments and options. Returns filtered argument
+list and alist of options.
+opts is a list of option lists. The fields of the list are
+ - NAME name of the long option
+ - HAS-ARG with legal values of :NONE, :REQUIRED, :OPTIONAL
+ - VAL value to return for a option with no arguments
+"
+ (do ((pos args)
+ (out-opts)
+ (out-args)
+ (errors))
+ ((null pos) (values out-args out-opts errors))
+ (multiple-value-bind (match is-long) (match-option (car pos) options))
+ (if match
+ (progn
+ (push (cons (car pos) (second pos)) out-opts)
+ (setq pos (cddr pos))))))
+