;;;; -*- 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))))))