;;;; -*- 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 #:kmrcl)


(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 arg 0))
       (char= #\- (schar arg 1))
       (char/= #\- (schar arg 3))))

(defun arg->base-name (arg)
  (cond
   ((is-long-option arg)
    (subseq arg 2))
   ((is-short-option arg)
    (subseq arg 1))
   (t
    arg)))
  
(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 options)
  "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 (cdr pos))
       (finished-options)
       (out-opts)
       (out-args)
       (errors))
      ((null pos) (values (nreverse out-args) (nreverse out-opts) errors))
    (cond
     (finished-options
      (push (car pos) out-args))
     ((is-option-terminator (car pos))
      (setq finished-options t))
     (t
      (multiple-value-bind (match is-long) (match-option (car pos) options)
	(if match
	    (cond 
	     ((and (eq :required (second match)) (null (cdr pos)))
	      (push  (arg->base-name (car pos)) errors))
	     (t
	      (push (cons (arg->base-name (car pos)) (second pos)) out-opts)
	      (setq pos (cdr pos))))
	  (push (car pos) out-args)))))))