;;;; -*- 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 (>= (length arg) 2)
       (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 option-type)
  "returns base-name,argument"
  (let ((start (ecase option-type
		 (:long 2)
		 (:short 1)))
	(name-end (position #\= arg)))

    (values (subseq arg start name-end)
	    (when name-end (subseq arg (1+ name-end))))))

(defun analyze-arg (arg)
  "Analyzes an argument. Returns option-type,base-name,argument"
  (let* ((option-type (cond ((is-short-option arg) :short)
			    ((is-long-option arg) :long)
			    (t :arg))))
    (if (or (eq option-type :short) (eq option-type :long))
	(multiple-value-bind (base arg) (arg->base-name arg option-type)
	  (values option-type base arg))
	(values :arg arg nil))))


(defun find-option (name options)
  "Find an option in option list. Handles using unique abbreviations"
  (let* ((option-names (mapcar #'car options))
	 (pos (match-unique-abbreviation name option-names)))
    (when pos
      (nth pos options))))

(defun match-option (arg options)
  "Matches an argument to an option. Returns option-list,option-type,base-name,argument"
  (multiple-value-bind (option-type base-name argument) (analyze-arg arg)
    (let ((match (find-option base-name options)))
      (values match option-type (when match (car match)) argument))))

(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
      (let ((arg (car pos)))
	(multiple-value-bind (option-list option-type base-name argument)
	    (match-option (car pos) options)
	  (cond
	    (option-list
	     (cond
	       (argument
		(case (second option-list)
		  (:none
		   (push base-name errors))
		  (t
		   (push (cons base-name argument) out-opts))))
	       ((null argument)
		(if (and (eq :required (second option-list)) (null (cdr pos)))
		    (push base-name errors)
		    (if (or (is-short-option (second pos))
			    (is-long-option (second pos)))
			(if (eq :required (second option-list))
			    (push base-name errors)
			    (push (cons base-name (third option-list)) out-args))
			(progn
			  (push (cons base-name (second pos)) out-opts)
			  (setq pos (cdr pos))))))))
	    (t
	     (if (in option-type :long :short)
		 (push (nth-value 0 (arg->base-name arg option-type)) errors)
		 (push arg out-args))))))))))