;;AUTOLOAD: getopts
;;AUTODOC: getopts "parses command line arguments"
"(getopts usage-string option-descs...)

getopts provide a very powerful and convenient way of parsing options for
klone scripts, and provinding usage texts.
Usage-string is a string descibing the usage of the command. In it, %0 is
expanded into the command name

Each option-desc is a list of:
(option-string number-of-parameters variable documentation options...)
    option-string is the full string of the option: \"-a\", \"-help\"
    number-of-parameters is () or the name of the argument (for online help)
    variable is the variable that will be set to t/() or the argument (string)
        variable can be a list, in this case, first arg is the variable name,
        second is the default value, and optionally third is the set value
        for options with 0 parameters when set (instead of t)
    documentation is a string printed in usage
    options are keywords followed by values to modify the behavior. know ones:
        :multiple t   (defaults ()) the option can be repeated N times, and
                      the variable will be set to the LIST of values rather
                      than to the last value given as is the default
        :hidden t     (defaults ()) the option will not be listed whith -help
                      Useful for internal or obscure debug options

Returns the list of the arguments after the options
single-char options can be collapsed in input, e.g:
    -u -v can be abbreviated -uv by the user
    -- indicates the end of options if some args begin with a -
    a single - is seen as an argument, not an option

an option description can also be the :allow-other-options keyword (defaults 
to ()), in which case unrecognized options are left in the arguments

(getopts :usage) exits the program with a message stating that bad arguments
were given and to give -help for help. An optional 2nd argument string can 
override this message with user text

e.g:
    (setq args (getopts \"USAGE: %0 [options]
        the text describing my program behavior\"
        (\"-v\" () verbose \"verbose operation\")
        (\"-p\" string (prefix \"xx\") \"use prefix instead of default xx\")
        (\"-x\" host list-of-hosts-to-exclude \"exclude this host\"
        :multiple t)
    )
"
(defvar getopts:optopts #(:multiple :hidden))     

(defunq getopts (getopts:usage &rest getopts:args &aux
    (arglen (length *arguments*))
    arg
    (i 1)
    opt
    optopts
    (optdescnum 0)
    done
    Err
    (re-minus-start (regcomp "^-"))
    (re-minus-invalid (regcomp "^--?$"))
    (optlen 2)
    (allow-other-options (with (p (seekq getopts:args :allow-other-options) 
	  v ())
	(if p (progn (delete getopts:args p) (setq v (get getopts:args p ::eof))
	    (if (or (eq v ())(eq v t)) (delete getopts:args p))
	    v
    ))))
    (options-left (list))
  )
  ;; check validity or argument description
  (setq getopts:usage (eval getopts:usage))
  (if (= :usage getopts:usage) (progn
      (print-format *standard-error* 
	"%0: bad arguments. type \"%0 -help\" for help\n"
	(match "^(.*[/])?([^/]*)" (get *arguments* 0 "") 2)
      )
      (exit 1)
    )
  )
  (if (not (typep getopts:usage String)) (progn
      (print-format "first getopt argument must be a string, not: %0\n"
	getopts:usage
      )
      (exit 1)
  ))
  (dolist (opt getopts:args)
    (setq Err t)
    (incf optdescnum 1)
    (if
      (or (not (typep opt List)) (< (length opt) 4))
      (print-format "An option must be a list of 4 elements:\n%0\noffending option is: %1\n"
	"(option-string number-of-parameters variable documentation options...)"
	opt
      )
      
      (and (setq optopts (subseq opt 4))
	(or (= 1 (mod (length optopts) 2))
	  (catch 'invalid (dohash (k v optopts)
	      (if (not (seek getopts:optopts k)) (throw 'invalid t))
	    )
	    ()
      )))
      (print-format
	"options %0 for option %1 must be a p-list indexed by keywords: %2\n"
	optopts (get opt 0) getopts:optopts
      )
      
      (not (typep (getn opt 0) String))
      (print-format "option string must be a string, not %0 in %1\n"
	(getn opt 0) opt
      )
      
      (progn (if
	  (= 0 (getn opt 1))
	  (put opt 1 ()) ;backwards compat
	  
	  (= 1 (getn opt 1)) 
	  (put opt 1 "arg"))
	
	(not (or (= () (getn opt 1)) (typep (getn opt 1) String))))
      (print-format "number-of-parameters must be () or param name, not %0 in %1\n"
	(getn opt 1) opt
      )
      
      (not (or (typep (getn opt 2) Atom)
	  (and (typep (getn opt 2) List)
	    (typep (getn (getn opt 2) 0) Atom)
      )))
      (print-format "variable must be an atom, or a list beginning with one, not %0 in %1\n"
	(getn opt 2) opt
      )
      
      (not (typep (getn opt 3) String))
      (print-format "documentation string must be a string, not %0 in %1\n"
	(getn opt 0) opt
      )
      
      (setq Err ())
    )
    (if Err (exit 1))
    ;; now undefine all option variables
    (if  (boundp (getopts:var opt))
      (makunbound (getopts:var opt))
    )
  )
  
  ;; actual parsing of options
  
  (while (and (not done) (< i arglen))
    (setq arg (getn *arguments* i))
					; -? or -help ==> help
    (if (or (= "-help" arg) (= "-?" arg)) (progn ;usage
	(print-format *standard-error* getopts:usage 
	  (match "^(.*[/])?([^/]*)" (get *arguments* 0 "") 2)
	)
	(write "\noptions:\n" *standard-error*)
	;; find option length
	(dolist (opt getopts:args)
	  (if (not (getopts:optopt opt :hidden))
	    (with (l (+ 3
		  (length (getn opt 0))
		  (length (if (getn opt 1) (+ " " (getn opt 1)) ""))
	      ))
	      (setq optlen (max l optlen))
	)))
	;; look at the options help strings and prints them
	(dolist (opt getopts:args)
	  (when (not (getopts:optopt opt :hidden))
	    (print-format *standard-error* "  %0%2%3%1\n"
	      (getn opt 0)
	      (getopts:reindent (if (getopts:optopt opt :multiple)
		  (+ (getn opt 3) "\nThis option can be repeated")
		  (getn opt 3))
	      )
	      (if (getn opt 1) (+ " " (getn opt 1)) "")
	      (getopts:expand-space (+ optlen 1) opt)
	)))
	(flush ())
	(exit 1)
    ))
					; -foo
    (if (and (regexec re-minus-start arg)
	(not (regexec re-minus-invalid arg))
      )
      (if (catch 'NotFound
	  (dolist (opt getopts:args)
	    (if (= arg (getn opt 0)) (progn
		(if (getn opt 1)
		  (progn
		    (++ i)
		    (if (getopts:optopt opt :multiple) 
		      (with (var (getopts:var opt))
			(if (or (not (boundp var)) (not (eval var))
			    (not (typep (eval var) List))
			  )
			  (set var (list (getn *arguments* i)))
			  (append-to-list (eval var) (getn *arguments* i))
			)
		      )
		      (set (getopts:var opt) (getn *arguments* i))
		    )
		  )
		  (set (getopts:var opt) (getopts:var opt t))
		)
		(throw 'NotFound ())
	  )))
	  t
	)
					;option not found
	;; look if option is not a combination of single letter options
	(if (not (getopts:decode-multiopt arg getopts:args))
	  (if allow-other-options (progn
	      (put options-left -1 arg)
	      (if (and (getn *arguments* (+ i 1)) ; remove arg if not option
		  (/= #\- (0 (getn *arguments* (+ i 1))))) 
		(put options-left -1 (getn *arguments* (setq i (+ i 1))))
	    ))
	    (progn
	      (print-format *standard-error*
		"%0: Unknown option: %1, -help for usage\n"
		(match "[^/]*$" (getn *arguments* 0) 0) arg
	      )
	      (flush ())
	      (exit 1)
	  ))
	)
      )
      (progn (setq done t)
	(-- i)
      )
    )
    (++ i)
  )
  ;; now fill undefined options
  (dolist (opt getopts:args)
    (if (not (boundp (getopts:var opt)))
      (set (getopts:var opt)(getopts:var opt ()))
  ))
  (makunbound 'getopts)			;free memory, getopts is used once
  (makunbound 'getopts:decode-multiopt)
  (makunbound 'getopts:var)
  (makunbound 'getopts:reindent)
  ;; return rest of args
  (if (= "--" (getn *arguments* i))	;remove --
    (+ options-left (subseq *arguments* (+ i 1)))
    (+ options-left (subseq *arguments* i))
  )
)

(defun getopts:decode-multiopt (optstring options &aux
    arg
  )
  (catch 'NotFound
    (dolist (optchar (subseq optstring 1))
      (catch 'Found
	(setq arg (put (copy "-") -1 optchar))
	(dolist (opt options)
	  (if (and (= arg (getn opt 0))
	      (not (getn opt 1))
	    )
	    (throw 'Found (set (getopts:var opt) (getopts:var opt t)))
	))
	(throw 'NotFound ())
    ))
    t
  )
)
   
;; what: not given: name, (): default val, t: set val
(defun getopts:var (opt &optional (what 'name))
  (if (= what 'name)
    (if (typep (getn opt 2) List)
      (getn (getn opt 2) 0)
      (getn opt 2)
    )
    what
    (if (typep (getn opt 2) List)
      (eval (get (getn opt 2) 2 t))
      t
    )
    
    (if (typep (getn opt 2) List)
      (eval (getn (getn opt 2) 1))
      ()
)))
  
(setq getopts:reindent-size 12)
(defun getopts:reindent (line &aux
    res
    next
    (re (regcomp "^([^\n]*)\n?(.*)$"))
  )
  (if (match "\n" line) (progn
      (regexec re line)
      (setq res (regsub re "\\1"))
      (setq next (regsub re "\\2"))
      (while (> (length next) 0)
	(regexec re next)
	(setq res (+ res "\n" (String (make-list getopts:reindent-size #\ ))
	    (regsub re "\\1")))
	(setq next (regsub re "\\2"))
      )
      res
    )
    line
  )
)

(defun getopts:expand-space (len opt &aux
    diff
    (maxlen 12)
    (proplen (- getopts:reindent-size 2))
    (l (+ (length (getn opt 0))
	(length (if (getn opt 1) (+ " " (getn opt 1)) ""))
    ))
  )
  ;; do not add more than maxlen blanks
  (setq diff (- len l))
  (if (> diff maxlen) (progn
      (while (> l proplen)
	(incf proplen 8)
      )
      (setq diff (- proplen l))
  ))
  (String (make-list diff #\ ))      
)

(defun getopts:optopt (opt key)
  (getn (subseq opt 4) key)
)
