getopt.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          getopt.lisp
   6 ;;;; Purpose:       Command line option processing a la GNU getopt_long
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Sep 2003
   9 ;;;;
  10 ;;;; $Id: package.lisp 7814 2003-09-10 12:56:02Z kevin $
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; KMRCL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:kmrcl)
  20
  21
  22 (defun is-short-option (arg)
  23   (and (>= (length arg) 2)
  24        (char= #\- (schar arg 0))
  25        (char/= #\- (schar arg 1))))
  26
  27 (defun is-option-terminator (arg)
  28   (and (= 2 (length arg))
  29        (char= #\- (schar arg 0))
  30        (char= #\- (schar arg 1))))
  31
  32 (defun is-long-option (arg)
  33   (and (> (length arg) 2)
  34        (char= #\- (schar arg 0))
  35        (char= #\- (schar arg 1))
  36        (char/= #\- (schar arg 3))))
  37
  38 (defun arg->base-name (arg option-type)
  39   "returns base-name,argument"
  40   (let ((start (ecase option-type
  41                  (:long 2)
  42                  (:short 1)))
  43         (name-end (position #\= arg)))
  44
  45     (values (subseq arg start name-end)
  46             (when name-end (subseq arg (1+ name-end))))))
  47
  48 (defun analyze-arg (arg)
  49   "Analyzes an argument. Returns option-type,base-name,argument"
  50   (let* ((option-type (cond ((is-short-option arg) :short)
  51                             ((is-long-option arg) :long)
  52                             (t :arg))))
  53     (if (or (eq option-type :short) (eq option-type :long))
  54         (multiple-value-bind (base arg) (arg->base-name arg option-type)
  55           (values option-type base arg))
  56         (values :arg arg nil))))
  57
  58
  59 (defun find-option (name options)
  60   "Find an option in option list. Handles using unique abbreviations"
  61   (let* ((option-names (mapcar #'car options))
  62          (pos (match-unique-abbreviation name option-names)))
  63     (when pos
  64       (nth pos options))))
  65
  66 (defun match-option (arg options)
  67   "Matches an argument to an option. Returns option-list,option-type,base-name,argument"
  68   (multiple-value-bind (option-type base-name argument) (analyze-arg arg)
  69     (let ((match (find-option base-name options)))
  70       (values match option-type (when match (car match)) argument))))
  71
  72 (defun getopt (args options)
  73   "Processes a list of arguments and options. Returns filtered argument
  74 list and alist of options.
  75 opts is a list of option lists. The fields of the list are
  76  - NAME name of the long option
  77  - HAS-ARG with legal values of :NONE, :REQUIRED, :OPTIONAL
  78  - VAL value to return for a option with no arguments
  79 "
  80   (do ((pos args (cdr pos))
  81        (finished-options)
  82        (out-opts)
  83        (out-args)
  84        (errors))
  85       ((null pos) (values (nreverse out-args) (nreverse out-opts) errors))
  86     (cond
  87      (finished-options
  88       (push (car pos) out-args))
  89      ((is-option-terminator (car pos))
  90       (setq finished-options t))
  91      (t
  92       (let ((arg (car pos)))
  93         (multiple-value-bind (option-list option-type base-name argument)
  94             (match-option (car pos) options)
  95           (cond
  96             (option-list
  97              (cond
  98                (argument
  99                 (case (second option-list)
 100                   (:none
 101                    (push base-name errors))
 102                   (t
 103                    (push (cons base-name argument) out-opts))))
 104                ((null argument)
 105                 (if (and (eq :required (second option-list)) (null (cdr pos)))
 106                     (push base-name errors)
 107                     (if (or (is-short-option (second pos))
 108                             (is-long-option (second pos)))
 109                         (if (eq :required (second option-list))
 110                             (push base-name errors)
 111                             (push (cons base-name (third option-list)) out-args))
 112                         (progn
 113                           (push (cons base-name (second pos)) out-opts)
 114                           (setq pos (cdr pos))))))))
 115             (t
 116              (if (in option-type :long :short)
 117                  (push (nth-value 0 (arg->base-name arg option-type)) errors)
 118                  (push arg out-args))))))))))
 119