;;;
;;; author:    russ mcmanus
;;; $Id: arg-proc.scm,v 1.1 2000/06/18 04:33:09 rlb Exp $
;;;

(define-module (gs getopt-gnu-style))

(define (split-arg-list arg-ls)
  "given an arg-ls, decide which part to process for options.  
everything before an arg of \"--\" is fair game, everything 
after it should not be processed.  the \"--\" is discarded.
a cons pair is returned whose car is the list to process for
options, and whose cdr is the list to not process."
  (let loop ((process-ls '())
	     (not-process-ls arg-ls))
    (cond ((null? not-process-ls)
	   (cons process-ls '()))
	  ((equal? "--" (car not-process-ls))
	   (cons process-ls (cdr not-process-ls)))
	  (#t
	   (loop (cons (car not-process-ls) process-ls)
		 (cdr not-process-ls))))))

(define arg-rx (make-regexp "^--[^=]+="))
(define no-arg-rx (make-regexp "^--[^=]+$"))

(define (getopt-gnu-style arg-ls)
  "given a list of program arguments, return an association list of option 
descriptions.  each item in the list of program arguments is examined to see 
if it meets the syntax of a gnu option specification.  the car of each pair in 
the returned alist is a keyword identifying the option.  the cdr of each pair 
in the returned alist is the option value, which is either the string that 
follows the equal sign in the argument, or #t if no equal sign appears in the 
argument.

as a special case, the returned alist also contains a pair whose car is the
symbol 'rest'.  the cdr of this pair is a list containing all the items in
the argument list that are not gnu style options.

the argument \"--\" is treated specially: all items in the argument list
appearing after such an argument are not examined, and are returned in the
special 'rest' list."
  (let* ((pair (split-arg-list arg-ls))
	 (eligible-arg-ls (car pair))
	 (ineligible-arg-ls (cdr pair)))
    (let loop ((arg-ls eligible-arg-ls)
	       (alist (list (cons 'rest ineligible-arg-ls))))
      (if (null? arg-ls) alist
	  (let ((first (car arg-ls))
		(rest (cdr arg-ls))
		(result #f))
	    (cond ((begin (set! result (regexp-exec arg-rx first)) result)
		   (loop rest 
			 (cons (cons (symbol->keyword 
				      (string->symbol
				       (substring first 2 (- (cdr (vector-ref result 1)) 1))))
				     (substring first (cdr (vector-ref result 1))))
			       alist)))
		  ((begin (set! result (regexp-exec no-arg-rx first)) result)
		   (loop rest
			 (cons (cons (symbol->keyword
				      (string->symbol
				       (substring first 2 (cdr (vector-ref result 1)))))
				     #t)
			       alist)))
		  (#t
		   (let ((pair (assq 'rest alist)))
		     (set-cdr! pair (cons first (cdr pair)))
		     (loop rest alist)))))))))

(define-public getopt-gnu-style getopt-gnu-style)

--
"Crime does not pay... as well as politics."
             --A. E. Newman