From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Wed, 10 Sep 2003 17:17:14 +0000 (+0000)
Subject: r7816: initial import, not yet finished
X-Git-Tag: v1.96~126
X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=commitdiff_plain;h=904e59aef16b462d7b9a6f1060a9f93ec70e0c4e

r7816: initial import, not yet finished
---

diff --git a/getopt.lisp b/getopt.lisp
new file mode 100644
index 0000000..ba4cd94
--- /dev/null
+++ b/getopt.lisp
@@ -0,0 +1,66 @@
+;;;; -*- 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))))))
+