--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; $Id$
+;;;
+;;; Collecting things into lists
+;;;
+;;; (c) 2005 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:mdw.collect
+ (:use #:common-lisp #:mdw.base)
+ (:export #:collecting #:with-collection #:collect))
+(in-package mdw.collect)
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (defvar *collecting-anon-list-name* (gensym)
+ "The default name for anonymous `collecting' lists.")
+ (defun make-collector ()
+ (let ((c (cons nil nil)))
+ (cons c c))))
+(defmacro collecting (vars &body body)
+ "Collect items into lists. The VARS are a list of collection variables --
+their values are unspecified, except that they may be passed to `collect' and
+`collect-tail' If VARS is empty then *collecting-anon-list-name* is used.
+VARS may be an atom instead of a singleton list. The form produces multiple
+values, one for each list constructed."
+ (cond ((null vars) (setf vars (list *collecting-anon-list-name*)))
+ ((atom vars) (setf vars (list vars))))
+ `(let ,(mapcar (lambda (v) `(,v (make-collector))) vars)
+ ,@body
+ (values ,@(mapcar (lambda (v) `(cdar ,v)) vars))))
+(defmacro with-collection (vars collection &body body)
+ "Collect items into lists VARS according to the form COLLECTION; then
+evaluate BODY with VARS bound to those lists."
+ `(multiple-value-bind
+ ,(listify vars)
+ (collecting ,vars ,collection)
+ ,@body))
+(defmacro collect (x &optional (name *collecting-anon-list-name*))
+ "Add item X to the `collecting' list NAME (or *collecting-anon-list-name*
+by default)."
+ (with-gensyms tmp
+ `(let ((,tmp (cons ,x nil)))
+ (setf (cddr ,name) ,tmp)
+ (setf (cdr ,name) ,tmp))))
+(defmacro collect-tail (x &optional (name *collecting-anon-list-name*))
+ "Make item X be the tail of `collecting' list NAME (or
+*collecting-anon-list-name* by default). It is an error to continue trying
+to add stuff to the list."
+ `(progn
+ (setf (cddr ,name) ,x)
+ (setf (cdr ,name) nil)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; $Id$
+;;;
+;;; Basic definitions
+;;;
+;;; (c) 2005 Mark Wooding
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:mdw.base
+ (:use #:common-lisp)
+ (:export #:compile-time-defun
+ #:show
+ #:stringify #:listify #:fix-pair #:pairify
+ #:whitespace-char-p
+ #:slot-uninitialized
+ #:with-gensyms #:let*/gensyms #:with-places
+ #:locp #:locf #:ref #:with-locatives))
+(in-package #:mdw.base)
+
+(defmacro compile-time-defun (name args &body body)
+ "Define a function which can be used by macros during the compilation
+process."
+ `(eval-when (:compile-toplevel :load-toplevel)
+ (defun ,name ,args ,@body)))
+
+(defmacro show (x)
+ "Debugging tool: print the expression X and its value."
+ (let ((tmp (gensym)))
+ `(let ((,tmp ,x))
+ (format t "~&~S: ~S~%" ',x ,tmp)
+ ,tmp)))
+
+(defun stringify (str)
+ "Return a string representation of STR. Strings are returned unchanged;
+symbols are converted to their names (unqualified!). Other objects are
+converted to their print representations."
+ (typecase str
+ (string str)
+ (symbol (symbol-name str))
+ (t (with-output-to-string (s)
+ (princ str s)))))
+(compile-time-defun listify (x)
+ "If X is a (possibly empty) list, return X; otherwise return (list X)."
+ (if (listp x) x (list x)))
+(compile-time-defun do-fix-pair (x y defaultp)
+ "Helper function for fix-pair and pairify."
+ (flet ((singleton (x) (values x (if defaultp y x))))
+ (cond ((atom x) (singleton x))
+ ((null (cdr x)) (singleton (car x)))
+ ((atom (cdr x)) (values (car x) (cdr x)))
+ ((cddr x) (error "Too many elements for a pair."))
+ (t (values (car x) (cadr x))))))
+(compile-time-defun fix-pair (x &optional (y nil defaultp))
+ "Return two values extracted from X. It works as follows:
+ (A) -> A, Y
+ (A B) -> A, B
+ (A B . C) -> error
+ (A . B) -> A, B
+ A -> A, Y
+where Y defaults to A if not specified."
+ (do-fix-pair x y defaultp))
+(compile-time-defun pairify (x &optional (y nil defaultp))
+ "As for fix-pair, but returns a list instead of two values."
+ (multiple-value-call #'list (do-fix-pair x y defaultp)))
+
+(defun whitespace-char-p (ch)
+ "Return whether CH is a whitespace character or not."
+ (case ch
+ ((#\space #\tab #\newline #\return #\vt #\formfeed) t)
+ (t nil)))
+
+(declaim (ftype (function nil ()) slot-unitialized))
+(defun slot-uninitialized ()
+ "A function which signals an error. Can be used as an initializer form in
+structure definitions without doom ensuing."
+ (error "No initializer for slot."))
+
+(defmacro with-gensyms (syms &body body)
+ "Everyone's favourite macro helper."
+ `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
+ (listify syms)))
+ ,@body))
+
+(defmacro let*/gensyms (binds &body body)
+ "A macro helper. BINDS is a list of binding pairs (VAR VALUE), where VALUE
+defaults to VAR. The result is that BODY is evaluated in a context where
+each VAR is bound to a gensym, and in the final expansion, each of those
+gensyms will be bound to the corresponding VALUE."
+ (labels ((more (binds)
+ (let ((tmp (gensym "TMP")) (bind (car binds)))
+ `((let ((,tmp ,(cadr bind))
+ (,(car bind) (gensym ,(symbol-name (car bind)))))
+ `(let ((,,(car bind) ,,tmp))
+ ,,@(if (cdr binds)
+ (more (cdr binds))
+ body)))))))
+ (if (null binds)
+ `(progn ,@body)
+ (car (more (mapcar #'pairify (listify binds)))))))
+
+(defmacro %place-ref (getform setform newtmp)
+ "Grim helper macro for with-places."
+ (declare (ignore setform newtmp))
+ getform)
+(define-setf-expander %place-ref (getform setform newtmp)
+ "Grim helper macro for with-places."
+ (values nil nil newtmp setform getform))
+(defmacro with-places ((&key environment) places &body body)
+ "A hairy helper, for writing setf-like macros. PLACES is a list of binding
+pairs (VAR PLACE), where PLACE defaults to VAR. The result is that BODY is
+evaluated in a context where each VAR is bound to a gensym, and in the final
+expansion, each of those gensyms will be bound to a symbol-macro capable of
+reading or setting the value of the corresponding PLACE."
+ (if (null places)
+ `(progn ,@body)
+ (let*/gensyms (environment)
+ (labels
+ ((more (places)
+ (let ((place (car places)))
+ (with-gensyms (tmp valtmps valforms
+ newtmps setform getform)
+ `((let ((,tmp ,(cadr place))
+ (,(car place)
+ (gensym ,(symbol-name (car place)))))
+ (multiple-value-bind
+ (,valtmps ,valforms
+ ,newtmps ,setform ,getform)
+ (get-setf-expansion ,tmp
+ ,environment)
+ (list 'let*
+ (mapcar #'list ,valtmps ,valforms)
+ `(symbol-macrolet ((,,(car place)
+ (%place-ref ,,getform
+ ,,setform
+ ,,newtmps)))
+ ,,@(if (cdr places)
+ (more (cdr places))
+ body))))))))))
+ (car (more (mapcar #'pairify (listify places))))))))
+
+(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
+ "Locative data type. See `locf' and `ref'."
+ (reader (slot-uninitialized) :type function)
+ (writer (slot-uninitialized) :type function))
+(defmacro locf (place &environment env)
+ "Slightly cheesy locatives. (locf PLACE) returns an object which, using
+the `ref' function, can be used to read or set the value of PLACE. It's
+cheesy because it uses closures rather than actually taking the address of
+something. Also, unlike Zetalisp, we don't overload `car' to do our dirty
+work."
+ (multiple-value-bind
+ (valtmps valforms newtmps setform getform)
+ (get-setf-expansion place env)
+ `(let* (,@(mapcar #'list valtmps valforms))
+ (make-loc (lambda () ,getform)
+ (lambda (,@newtmps) ,setform)))))
+(declaim (inline loc (setf loc)))
+(defun ref (loc)
+ "Fetch the value referred to by a locative."
+ (funcall (loc-reader loc)))
+(defun (setf ref) (new loc)
+ "Store a new value in the place referred to by a locative."
+ (funcall (loc-writer loc) new))
+(defmacro with-locatives (locs &body body)
+ "LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
+symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it
+defaults to SYM. As an abbreviation for a common case, LOCS may be a symbol
+instead of a list. The BODY is evaluated in an environment where each SYM is
+a symbol macro which expands to (ref LOC-EXPR) -- or, in fact, something
+similar which doesn't break if LOC-EXPR has side-effects. Thus, references,
+including `setf' forms, fetch or modify the thing referred to by the
+LOC-EXPR. Useful for covering over where something uses a locative."
+ (setf locs (mapcar #'pairify (listify locs)))
+ (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
+ (ll (mapcar #'cadr locs))
+ (ss (mapcar #'car locs)))
+ `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll))
+ (symbol-macrolet (,@(mapcar (lambda (sym tmp)
+ `(,sym (ref ,tmp))) ss tt))
+ ,@body))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+
+(defpackage #:mdw.asdf
+ (:use #:common-lisp #:asdf))
+(in-package #:mdw.asdf)
+
+(defsystem "mdw"
+ :components ((:file "mdw-base")
+ (:file "sys-base")
+ (:file "str")
+ (:file "collect")
+ (:file "unix")
+ (:file "safely")
+ (:file "optparse"))
+ :serial t)
--- /dev/null
+#! /usr/local/bin/runlisp
+;;; -*-lisp-*-
+
+;; (format t "Startup!~%")
+(asdf:operate 'asdf:load-op 'mdw :verbose nil)
+(use-package '#:mdw.optparse)
+
+(defvar opt-bool nil)
+(defvar opt-int nil)
+(defvar opt-list nil)
+(defvar opt-int-list nil)
+(defvar opt-string nil)
+(defvar opt-keyword nil)
+(defvar opt-enum nil)
+(defvar opt-counter 2)
+
+(defconstant options
+ (options
+ "Help options"
+ (#\h "help"
+ (lambda (arg)
+ (declare (ignore arg))
+ (show-help *program-name* "1.0.0" "usage-blah" options)
+ (exit 0))
+ ("Show this help text."))
+ ( "version"
+ (lambda (arg)
+ (declare (ignore arg))
+ (format t "~A, version ~A~%" *program-name* "1.0.0")
+ (exit 0))
+ ("Show ~A's version number." *program-name*))
+ "Test options"
+ (#\b "boolean" (set opt-bool) (clear opt-bool)
+ ("Set (or clear, if negated) the boolean flag."))
+ (#\i "integer" (:arg "INT") (int opt-int :min -10 :max 10)
+ ("Set an integer between -10 and +10."))
+ (#\l "list" (:arg "STRING") (list opt-list)
+ ("Stash an item in the string list."))
+ (#\I "int-list" (:arg "INT")
+ (list opt-int-list 'int :min -10 :max 10)
+ ("Stash an integer between -10 and +10 in the int list."))
+ (#\s "string" (:arg "STRING") (string opt-string)
+ ("Set a string."))
+ (#\q "quiet" (dec opt-counter 0)
+ ("Be more quiet."))
+ (#\v "verbose" (inc opt-counter 5)
+ ("Be more verbose."))
+ (#\Q "very-quiet" (dec opt-counter 0 3)
+ ("Be much more quiet."))
+ (#\V "very-verbose" (inc opt-counter 5 3)
+ ("Be much more verbose."))
+ (#\k "keywword" (:arg "KEYWORD") (keyword opt-keyword)
+ ("Set an arbitrary keyword."))
+ (#\e "enumeration" (:arg "ENUM")
+ (keyword opt-enum :apple :apple-pie :abacus :banana)
+ ("Set a keyword from a fixed set."))))
+
+(defun test (args)
+ (let ((op (make-option-parser (cdr args) options)))
+ (unless (option-parse-try
+ (loop
+ (multiple-value-bind (opt arg) (option-parse-next op)
+ (unless opt (return))
+ (format t "Option ~S: `~A'~%" opt arg))))
+ (exit 1))
+ (format t "Non-option arguments: ~S~%" (option-parse-remainder op))
+ (format t "boolean: ~S~%" opt-bool)
+ (format t "integer: ~S~%" opt-int)
+ (format t "list: ~S~%" opt-list)
+ (format t "int-list: ~S~%" opt-int-list)
+ (format t "string : ~S~%" opt-string)
+ (format t "counter: ~S~%" opt-counter)
+ (format t "keyword: ~S~%" opt-keyword)
+ (format t "enum: ~S~%" opt-enum)))
+(test *command-line-strings*)
+
+
+
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; $Id$
+;;;
+;;; Option parser, standard issue
+;;;
+;;; (c) 2005 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:mdw.optparse
+ (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str)
+ (:export #:exit #:*program-name* #:*command-line-strings*
+ #:moan #:die
+ #:option #:optionp #:make-option
+ #:opt-short-name #:opt-long-name #:opt-tag #:opt-negated-tag
+ #:opt-arg-name #:opt-arg-optional-p #:opt-documentation
+ #:option-parser #:make-option-parser #:option-parser-p
+ #:op-options #:op-non-option #:op-long-only-p #:op-numeric-p
+ #:op-negated-numeric-p #:op-negated-p
+ #:option-parse-error
+ #:option-parse-remainder #:option-parse-next #:option-parse-try
+ #:with-unix-error-reporting
+ #:defopthandler #:invoke-option-handler
+ #:set #:clear #:inc #:dec #:read #:int #:string
+ #:keyword #:list
+ #:parse-option-form #:options
+ #:simple-usage #:show-usage #:show-version #:show-help
+ #:sanity-check-option-list))
+
+(in-package #:mdw.optparse)
+
+;;; Standard error-reporting functions.
+
+(defun moan (msg &rest args)
+ "Report an error message in the usual way."
+ (format *error-output* "~&~A: ~?~%" *program-name* msg args))
+(defun die (&rest args)
+ "Report an error message and exit."
+ (apply #'moan args)
+ (exit 1))
+
+;;; The main option parser.
+
+(defstruct (option (:predicate optionp)
+ (:conc-name opt-)
+ (:print-function
+ (lambda (o s k)
+ (declare (ignore k))
+ (format s
+ "#<option~@[ -~C,~]~@[ --~A~]~:[~2*~;~:[=~A~;[=~A]~]~]~@[ ~S~]>"
+ (opt-short-name o)
+ (opt-long-name o)
+ (opt-arg-name o)
+ (opt-arg-optional-p o)
+ (opt-arg-name o)
+ (opt-documentation o))))
+ (:constructor %make-option)
+ (:constructor make-option
+ (long-name
+ short-name
+ &optional
+ arg-name
+ &key
+ (tag (intern (string-upcase long-name)
+ :keyword))
+ negated-tag
+ arg-optional-p
+ doc
+ (documentation doc))))
+ "Describes a command-line option. Slots:
+
+LONG-NAME The option's long name. If this is null, the `option' is
+ just a banner to be printed in the program's help text.
+
+TAG The value to be returned if this option is encountered. If
+ this is a function, instead, the function is called with the
+ option's argument or nil.
+
+NEGATED-TAG As for TAG, but used if the negated form of the option is
+ found. If this is nil (the default), the option cannot be
+ negated.
+
+SHORT-NAME The option's short name. This must be a single character, or
+ nil if the option has no short name.
+
+ARG-NAME The name of the option's argument, a string. If this is nil,
+ the option doesn't accept an argument. The name is shown in
+ the help text.
+
+ARG-OPTIONAL-P If non-nil, the option's argument is optional. This is
+ ignored unless ARG-NAME is non-null.
+
+DOCUMENTATION The help text for this option. It is automatically
+ line-wrapped. If nil, the option is omitted from the help
+ text.
+
+Usually, one won't use make-option, but use the option macro instead."
+ (long-name nil :type (or null string))
+ (tag nil :type t)
+ (negated-tag nil :type t)
+ (short-name nil :type (or null character))
+ (arg-name nil :type (or null string))
+ (arg-optional-p nil :type t)
+ (documentation nil :type (or null string)))
+
+(defstruct (option-parser (:conc-name op-)
+ (:constructor make-option-parser
+ (argstmp
+ options
+ &key
+ (non-option :skip)
+ ((:numericp numeric-p))
+ negated-numeric-p
+ long-only-p
+ &aux
+ (args (cons nil argstmp))
+ (next args)
+ (negated-p (or negated-numeric-p
+ (some
+ #'opt-negated-tag
+ options))))))
+ "An option parser object. Slots:
+
+ARGS The arguments to be parsed. Usually this will be
+ *command-line-strings*.
+
+OPTIONS List of option structures describing the acceptable options.
+
+NON-OPTION Behaviour when encountering a non-option argument. The
+ default is :skip. Allowable values are:
+ :skip -- pretend that it appeared after the option
+ arguments; this is the default behaviour of GNU getopt
+ :stop -- stop parsing options, leaving the remaining
+ command line unparsed
+ :return -- return :non-option and the argument word
+
+NUMERIC-P Non-nil tag (as for options) if numeric options (e.g., -43)
+ are to be allowed. The default is nil. (Anomaly: the
+ keyword for this argument is :numericp.)
+
+NEGATED-NUMERIC-P
+ Non-nil tag (as for options) if numeric options (e.g., -43)
+ can be negated. This is not the same thing as a negative
+ numeric option!
+
+LONG-ONLY-P A misnomer inherited from GNU getopt. Whether to allow
+ long options to begin with a single dash. Short options are
+ still allowed, and may be cuddled as usual. The default is
+ nil."
+ (args nil :type list)
+ (options nil :type list)
+ (non-option :skip :type (or function (member :skip :stop :return)))
+ (next nil :type list)
+ (short-opt nil :type (or null string))
+ (short-opt-index 0 :type fixnum)
+ (short-opt-neg-p nil :type t)
+ (long-only-p nil :type t)
+ (numeric-p nil :type t)
+ (negated-numeric-p nil :type t)
+ (negated-p nil :type t))
+
+(define-condition option-parse-error (error simple-condition)
+ ()
+ (:documentation "Indicates an error found while parsing options. Probably
+not that useful."))
+
+(defun option-parse-error (msg &rest args)
+ "Signal an option-parse-error with the given message and arguments."
+ (error (make-condition 'option-parse-error
+ :format-control msg
+ :format-arguments args)))
+
+(defun option-parse-remainder (op)
+ "Returns the unparsed remainder of the command line."
+ (cdr (op-args op)))
+
+(defun option-parse-next (op)
+ "The main option-parsing function. OP is an option-parser object,
+initialized appropriately. Returns two values, OPT and ARG: OPT is the tag
+of the next option read, and ARG is the argument attached to it, or nil if
+there was no argument. If there are no more options, returns nil twice.
+Options whose TAG is a function aren't returned; instead, the tag function is
+called, with the option argument (or nil) as the only argument. It is safe
+for tag functions to throw out of option-parse-next, if they desparately need
+to. (This is the only way to actually get option-parse-next to return a
+function value, should that be what you want.)
+
+While option-parse-next is running, there is a restart `skip-option' which
+moves on to the next option. Error handlers should use this to resume after
+parsing errors."
+ (loop
+ (labels ((ret (opt &optional arg)
+ (return-from option-parse-next (values opt arg)))
+ (finished ()
+ (setf (op-next op) nil)
+ (ret nil nil))
+ (peek-arg ()
+ (cadr (op-next op)))
+ (more-args-p ()
+ (and (op-next op)
+ (cdr (op-next op))))
+ (skip-arg ()
+ (setf (op-next op) (cdr (op-next op))))
+ (eat-arg ()
+ (setf (cdr (op-next op)) (cddr (op-next op))))
+ (get-arg ()
+ (prog1 (peek-arg) (eat-arg)))
+ (process-option (o name negp &key arg argfunc)
+ (cond ((not (opt-arg-name o))
+ (when arg
+ (option-parse-error
+ "Option `~A' does not accept arguments"
+ name)))
+ (arg)
+ (argfunc
+ (setf arg (funcall argfunc)))
+ ((opt-arg-optional-p o))
+ ((more-args-p)
+ (setf arg (get-arg)))
+ (t
+ (option-parse-error "Option `~A' requires an argument"
+ name)))
+ (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
+ (if (functionp how)
+ (funcall how arg)
+ (ret how arg))))
+ (process-long-option (arg start negp)
+ (when (and (not negp)
+ (op-negated-p op)
+ (> (length arg) (+ start 3))
+ (string= arg "no-"
+ :start1 start :end1 (+ start 3)))
+ (incf start 3)
+ (setf negp t))
+ (let* ((matches nil)
+ (eqpos (position #\= arg :start start))
+ (len (or eqpos (length arg)))
+ (optname (subseq arg 0 len))
+ (len-2 (- len start)))
+ (dolist (o (op-options op))
+ (cond ((or (not (stringp (opt-long-name o)))
+ (and negp (not (opt-negated-tag o)))
+ (< (length (opt-long-name o)) len-2)
+ (string/= optname (opt-long-name o)
+ :start1 start :end2 len-2)))
+ ((= (length (opt-long-name o)) len-2)
+ (setf matches (list o))
+ (return))
+ (t
+ (push o matches))))
+ (cond ((null matches)
+ (option-parse-error "Unknown option `~A'" optname))
+ ((cdr matches)
+ (option-parse-error
+ "~
+Ambiguous long option `~A' -- could be any of:~{~% --~A~}"
+ optname
+ (mapcar #'opt-long-name matches))))
+ (process-option (car matches)
+ optname
+ negp
+ :arg (and eqpos
+ (subseq arg (1+ eqpos)))))))
+ (with-simple-restart (skip-option "Skip this bogus option.")
+ (cond
+ ;;
+ ;; We're embroiled in short options: handle them.
+ ((op-short-opt op)
+ (if (>= (op-short-opt-index op) (length (op-short-opt op)))
+ (setf (op-short-opt op) nil)
+ (let* ((str (op-short-opt op))
+ (i (op-short-opt-index op))
+ (ch (char str i))
+ (negp (op-short-opt-neg-p op))
+ (name (format nil "~C~A" (if negp #\+ #\-) ch))
+ (o (find ch (op-options op) :key #'opt-short-name)))
+ (incf i)
+ (setf (op-short-opt-index op) i)
+ (when (or (not o)
+ (and negp (not (opt-negated-tag o))))
+ (option-parse-error "Unknown option `~A'" name))
+ (process-option o
+ name
+ negp
+ :argfunc
+ (and (< i (length str))
+ (lambda ()
+ (prog1
+ (subseq str i)
+ (setf (op-short-opt op)
+ nil))))))))
+ ;;
+ ;; End of the list. Say we've finished.
+ ((not (more-args-p))
+ (finished))
+ ;;
+ ;; Process the next option.
+ (t
+ (let ((arg (peek-arg)))
+ (cond
+ ;;
+ ;; Non-option. Decide what to do.
+ ((or (<= (length arg) 1)
+ (and (char/= (char arg 0) #\-)
+ (or (char/= (char arg 0) #\+)
+ (not (op-negated-p op)))))
+ (case (op-non-option op)
+ (:skip (skip-arg))
+ (:stop (finished))
+ (:return (eat-arg)
+ (ret :non-option arg))
+ (t (eat-arg)
+ (funcall (op-non-option op) arg))))
+ ;;
+ ;; Double-hyphen. Stop right now.
+ ((string= arg "--")
+ (eat-arg)
+ (finished))
+ ;;
+ ;; Numbers. Check these before long options, since `--43' is
+ ;; not a long option.
+ ((and (op-numeric-p op)
+ (or (char= (char arg 0) #\-)
+ (op-negated-numeric-p op))
+ (or (and (digit-char-p (char arg 1))
+ (every #'digit-char-p (subseq arg 2)))
+ (and (or (char= (char arg 1) #\-)
+ (char= (char arg 1) #\+))
+ (>= (length arg) 3)
+ (digit-char-p (char arg 2))
+ (every #'digit-char-p (subseq arg 3)))))
+ (eat-arg)
+ (let ((negp (char= (char arg 0) #\+))
+ (num (parse-integer arg :start 1)))
+ (when (and negp (eq (op-negated-numeric-p op) :-))
+ (setf num (- num))
+ (setf negp nil))
+ (let ((how (if negp
+ (op-negated-numeric-p op)
+ (op-numeric-p op))))
+ (if (functionp how)
+ (funcall how num)
+ (ret (if negp :negated-numeric :numeric) num)))))
+ ;;
+ ;; Long option. Find the matching option-spec and process
+ ;; it.
+ ((and (char= (char arg 0) #\-)
+ (char= (char arg 1) #\-))
+ (eat-arg)
+ (process-long-option arg 2 nil))
+ ;;
+ ;; Short options. All that's left.
+ (t
+ (eat-arg)
+ (let ((negp (char= (char arg 0) #\+))
+ (ch (char arg 1)))
+ (cond ((and (op-long-only-p op)
+ (not (member ch (op-options op)
+ :key #'opt-short-name)))
+ (process-long-option arg 1 negp))
+ (t
+ (setf (op-short-opt op) arg
+ (op-short-opt-index op) 1
+ (op-short-opt-neg-p op) negp)))))))))))))
+
+(defmacro option-parse-try (&body body)
+ "Report errors encountered while parsing options, and continue struggling
+along. Also establishes a restart `stop-parsing'. Returns t if parsing
+completed successfully, or nil if errors occurred."
+ (with-gensyms (retcode)
+ `(let ((,retcode t))
+ (restart-case
+ (handler-bind
+ ((option-parse-error
+ (lambda (cond)
+ (setf ,retcode nil)
+ (moan "~A" cond)
+ (dolist (rn '(skip-option stop-parsing))
+ (let ((r (find-restart rn)))
+ (when r (invoke-restart r)))))))
+ ,@body)
+ (stop-parsing ()
+ :report "Give up parsing options."
+ (setf ,retcode nil)))
+ ,retcode)))
+
+(defmacro with-unix-error-reporting ((&key) &body body)
+ "Evaluate BODY with errors reported in the standard Unix fashion."
+ (with-gensyms (cond)
+ `(handler-case
+ (progn ,@body)
+ (simple-condition (,cond)
+ (die (simple-condition-format-control ,cond)
+ (simple-condition-format-arguments ,cond)))
+ (error (,cond)
+ (die "~A" ,cond)))))
+
+;;; Standard option handlers.
+
+(defmacro defopthandler (name (var &optional (arg (gensym)))
+ (&rest args)
+ &body body)
+ "Define an option handler function NAME. Option handlers update a
+generalized variable, which may be referred to as VAR in the BODY, based on
+some parameters (the ARGS) and the value of an option-argument named ARG."
+ (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
+ `(progn
+ (setf (get ',name 'opthandler) ',func)
+ (defun ,func (,var ,arg ,@args)
+ (with-locatives ,var
+ (declare (ignorable ,arg))
+ ,@body))
+ ',name)))
+
+(defun parse-c-integer (string &key radix (start 0) end)
+ "Parse STRING, or at least the parts of it between START and END, according
+to the standard C rules. Well, almost: the 0 and 0x prefixes are accepted,
+but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS is accepted,
+for any radix between 2 and 36. Prefixes are only accepted if RADIX is nil.
+Returns two values: the integer parsed (or nil if there wasn't enough for a
+sensible parse), and the index following the characters of the integer."
+ (unless end (setf end (length string)))
+ (labels ((simple (a i r goodp sgn)
+ (loop
+ (when (>= i end)
+ (return (values (and goodp (* a sgn)) i)))
+ (let ((d (digit-char-p (char string i) r)))
+ (unless d
+ (return (values (and goodp (* a sgn)) i)))
+ (setf a (+ (* a r) d))
+ (setf goodp t)
+ (incf i))))
+ (get-radix (i r sgn)
+ (cond (r (simple 0 i r nil sgn))
+ ((>= i end) (values nil i))
+ ((and (char= (char string i) #\0)
+ (>= (- end i) 2))
+ (case (char string (1+ i))
+ (#\x (simple 0 (+ i 2) 16 nil sgn))
+ (#\o (simple 0 (+ i 2) 8 nil sgn))
+ (#\b (simple 0 (+ i 2) 2 nil sgn))
+ (t (simple 0 (1+ i) 8 t sgn))))
+ (t
+ (multiple-value-bind
+ (r i)
+ (simple 0 i 10 nil +1)
+ (cond ((not r) (values nil i))
+ ((and (< i end)
+ (char= (char string i) #\_)
+ (<= 2 r 36))
+ (simple 0 (1+ i) r nil sgn))
+ (t
+ (values (* r sgn) i))))))))
+ (cond ((>= start end) (values nil start))
+ ((char= (char string start) #\-)
+ (get-radix (1+ start) radix -1))
+ ((char= (char string start) #\+)
+ (get-radix (1+ start) radix +1))
+ (t
+ (get-radix start radix +1)))))
+
+(defun invoke-option-handler (handler loc arg args)
+ "Call the HANDLER function, giving it LOC to update, the option-argument
+ARG, and the remaining ARGS."
+ (apply (if (functionp handler) handler
+ (fdefinition (get handler 'opthandler)))
+ loc
+ arg
+ args))
+
+(defopthandler set (var) (&optional (value t))
+ "Sets VAR to VALUE; defaults to t."
+ (setf var value))
+(defopthandler clear (var) (&optional (value nil))
+ "Sets VAR to VALUE; defaults to nil."
+ (setf var value))
+(defopthandler inc (var) (&optional max (step 1))
+ "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
+nil for no maximum). No errors are signalled."
+ (incf var step)
+ (when (>= var max)
+ (setf var max)))
+(defopthandler dec (var) (&optional min (step 1))
+ "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
+for no maximum). No errors are signalled."
+ (decf var step)
+ (when (<= var min)
+ (setf var min)))
+(defopthandler read (var arg) ()
+ "Stores in VAR the Lisp object found by reading the ARG. Evaluation is
+forbidden while reading ARG. If there is an error during reading, an error
+of type option-parse-error is signalled."
+ (handler-case
+ (let ((*read-eval* nil))
+ (multiple-value-bind (x end) (read-from-string arg t)
+ (unless (>= end (length arg))
+ (option-parse-error "Junk at end of argument `~A'" arg))
+ (setf var x)))
+ (error (cond)
+ (option-parse-error (format nil "~A" cond)))))
+(defopthandler int (var arg) (&key radix min max)
+ "Stores in VAR the integer read from the ARG. Integers are parsed
+according to C rules, which is normal in Unix; the RADIX may be nil to allow
+radix prefixes, or an integer between 2 and 36. An option-parse-error is
+signalled if the ARG is not a valid integer, or if it is not between MIN and
+MAX (either of which may be nil if no lower resp. upper bound is wanted)."
+ (multiple-value-bind (v end) (parse-c-integer arg :radix radix)
+ (unless (and v (>= end (length arg)))
+ (option-parse-error "Bad integer `~A'" arg))
+ (when (or (and min (< v min))
+ (and max (> v max)))
+ (option-parse-error
+ "Integer ~A out of range (must have ~@[~D <= ~]x~@[ <= ~D~])"
+ arg min max))
+ (setf var v)))
+(defopthandler string (var arg) ()
+ "Stores ARG in VAR, just as it is."
+ (setf var arg))
+(defopthandler keyword (var arg) (&rest valid)
+ (if (null valid)
+ (setf var (intern (string-upcase arg) :keyword))
+ (let ((matches nil)
+ (guess (string-upcase arg))
+ (len (length arg)))
+ (dolist (k valid)
+ (let* ((kn (symbol-name k))
+ (klen (length kn)))
+ (cond ((string= kn guess)
+ (setf matches (list k))
+ (return))
+ ((and (< len klen)
+ (string= guess kn :end2 len))
+ (push k matches)))))
+ (case (length matches)
+ (0 (option-parse-error "Argument `~A' invalid: must be one of:~
+ ~{~%~8T~(~A~)~}"
+ arg valid))
+ (1 (setf var (car matches)))
+ (t (option-parse-error "Argument `~A' ambiguous: may be any of:~
+ ~{~%~8T~(~A~)~}"
+ arg matches))))))
+(defopthandler list (var arg) (&optional handler &rest handler-args)
+ "Collect ARGs in a list at VAR. ARGs are translated by the HANDLER first,
+if specified. If not, it's as if you asked for `string'."
+ (when handler
+ (invoke-option-handler handler (locf arg) arg handler-args))
+ (setf var (nconc var (list arg))))
+
+(compile-time-defun parse-option-form (form)
+ "Does the heavy lifting for parsing an option form. See the docstring for
+the `option' macro for details of the syntax."
+ (flet ((doc (form)
+ (cond ((stringp form) form)
+ ((null (cdr form)) (car form))
+ (t `(format nil ,@form))))
+ (docp (form)
+ (or (stringp form)
+ (and (consp form)
+ (stringp (car form))))))
+ (if (and (docp (car form))
+ (null (cdr form)))
+ `(%make-option :documentation ,(doc (car form)))
+ (let (long-name short-name
+ arg-name arg-optional-p
+ tag negated-tag
+ doc)
+ (dolist (f form)
+ (cond ((and (or (not tag) (not negated-tag))
+ (or (keywordp f)
+ (and (consp f)
+ (member (car f) '(lambda function)))))
+ (if tag
+ (setf negated-tag f)
+ (setf tag f)))
+ ((and (not long-name)
+ (or (rationalp f)
+ (symbolp f)
+ (stringp f)))
+ (setf long-name (if (stringp f) f
+ (format nil "~(~A~)" f))))
+ ((and (not short-name)
+ (characterp f))
+ (setf short-name f))
+ ((and (not doc)
+ (docp f))
+ (setf doc (doc f)))
+ ((and (consp f) (symbolp (car f)))
+ (case (car f)
+ (:arg (setf arg-name (cadr f)))
+ (:opt-arg (setf arg-name (cadr f))
+ (setf arg-optional-p t))
+ (:doc (setf doc (doc (cdr f))))
+ (t (let ((handler (get (car f) 'opthandler)))
+ (unless handler
+ (error "No handler `~S' defined." (car f)))
+ (let* ((var (cadr f))
+ (arg (gensym))
+ (thunk `#'(lambda (,arg)
+ (,handler (locf ,var)
+ ,arg
+ ,@(cddr f)))))
+ (if tag
+ (setf negated-tag thunk)
+ (setf tag thunk)))))))
+ (t
+ (error "Unexpected thing ~S in option form." f))))
+ `(make-option ,long-name ,short-name ,arg-name
+ ,@(and arg-optional-p `(:arg-optional-p t))
+ ,@(and tag `(:tag ,tag))
+ ,@(and negated-tag `(:negated-tag ,negated-tag))
+ ,@(and doc `(:documentation ,doc)))))))
+
+(defmacro options (&rest optlist)
+ "More convenient way of initializing options. The OPTLIST is a list of
+OPTFORMS. Each OPTFORM is either a banner string, or a list of
+items. Acceptable items are interpreted as follows:
+
+ KEYWORD or FUNCTION
+ If no TAG is set yet, then as a TAG; otherwise as the NEGATED-TAG.
+
+ STRING (or SYMBOL or RATIONAL)
+ If no LONG-NAME seen yet, then the LONG-NAME. For symbols and rationals,
+ the item is converted to a string and squashed to lower-case.
+
+ CHARACTER
+ The SHORT-NAME.
+
+ STRING or (STRING STUFF...)
+ If no DOCUMENTATION set yet, then the DOCUMENTATION string. A string is
+ used as-is; a list is considered to be a `format' string and its
+ arguments. This is evaluated at standard evaluation time: the option
+ structure returned contains a simple documentation string.
+
+ (:ARG NAME)
+ Set the ARG-NAME.
+
+ (:OPT-ARG NAME)
+ Set the ARG-NAME, and also set ARG-OPTIONAL-P.
+
+ (HANDLER VAR ARGS...)
+ If no TAG is set yet, attach the HANDLER to this option, giving it ARGS.
+ Otherwise, set the NEGATED-TAG."
+ `(list ,@(mapcar (lambda (form)
+ (if (stringp form)
+ `(%make-option :documentation ,form)
+ (parse-option-form form)))
+ optlist)))
+
+;;; Support stuff for help and usage messages
+
+(defun print-text (string
+ &optional
+ (stream *standard-output*)
+ &key
+ (start 0)
+ (end nil))
+ "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
+newlines in the obvious way. Stuff between square brackets is not broken:
+this makes usage messages work better."
+ (let ((i start)
+ (nest 0)
+ (splitp nil))
+ (flet ((emit ()
+ (write-string string stream :start start :end i)
+ (setf start i)))
+ (unless end
+ (setf end (length string)))
+ (loop
+ (unless (< i end)
+ (emit)
+ (return))
+ (let ((ch (char string i)))
+ (cond ((char= ch #\newline)
+ (emit)
+ (incf start)
+ (pprint-newline :mandatory stream))
+ ((whitespace-char-p ch)
+ (when (zerop nest)
+ (setf splitp t)))
+ (t
+ (when splitp
+ (emit)
+ (pprint-newline :fill stream))
+ (setf splitp nil)
+ (case ch
+ (#\[ (incf nest))
+ (#\] (when (plusp nest) (decf nest))))))
+ (incf i))))))
+
+(defun simple-usage (opts &optional mandatory-args)
+ "Build a simple usage list from a list of options, and (optionally)
+mandatory argument names."
+ (let (short-simple long-simple short-arg long-arg)
+ (dolist (o opts)
+ (cond ((not (and (opt-documentation o)
+ (opt-long-name o))))
+ ((and (opt-short-name o) (opt-arg-name o))
+ (push o short-arg))
+ ((opt-short-name o)
+ (push o short-simple))
+ ((opt-arg-name o)
+ (push o long-arg))
+ (t
+ (push o long-simple))))
+ (list
+ (nconc (and short-simple
+ (list (format nil "[-~{~C~}]"
+ (sort (mapcar #'opt-short-name short-simple)
+ #'char<))))
+ (and long-simple
+ (mapcar (lambda (o)
+ (format nil "[--~A]" (opt-long-name o)))
+ (sort long-simple #'string< :key #'opt-long-name)))
+ (and short-arg
+ (mapcar (lambda (o)
+ (format nil "~:[[-~C ~A]~;[-~C[~A]]~]"
+ (opt-arg-optional-p o)
+ (opt-short-name o)
+ (opt-arg-name o)))
+ (sort short-arg #'char-lessp
+ :key #'opt-short-name)))
+ (and long-arg
+ (mapcar (lambda (o)
+ (format nil "~:[[--~A ~A]~;[--~A[=~A]]~]"
+ (opt-arg-optional-p o)
+ (opt-long-name o)
+ (opt-arg-name o)))
+ (sort long-arg #'string-lessp
+ :key #'opt-long-name)))
+ (listify mandatory-args)))))
+
+(defun show-usage (prog usage &optional (stream *standard-output*))
+ "Basic usage-showing function. PROG is the program name, probable from
+*command-line-strings*. USAGE is a list of possible usages of the program,
+each of which is a list of items to be supplied by the user. In simple
+cases, a single string is sufficient."
+ (pprint-logical-block (stream nil :prefix "Usage: ")
+ (dolist (u (listify usage))
+ (pprint-logical-block (stream nil :prefix (format nil "~A " prog))
+ (format stream "~{~A ~:_~}" (listify u)))
+ (pprint-newline :mandatory stream))))
+
+(defun show-help (prog ver usage opts &optional (stream *standard-output*))
+ "Basic help-showing function. PROG is the program name, probably from
+*command-line-strings*. VER is the program's version number. USAGE is a
+list of the possible usages of the program, each of which may be a list of
+items to be supplied. OPTS is the list of supported options, as provided to
+the options parser. STREAM is the stream to write on."
+ (format stream "~A, version ~A~2%" prog ver)
+ (show-usage prog usage stream)
+ (terpri stream)
+ (let (newlinep)
+ (dolist (o opts)
+ (let ((doc (opt-documentation o)))
+ (cond ((not o))
+ ((not (opt-long-name o))
+ (when newlinep
+ (terpri stream)
+ (setf newlinep nil))
+ (pprint-logical-block (stream nil)
+ (print-text doc stream))
+ (terpri stream))
+ (t
+ (setf newlinep t)
+ (pprint-logical-block (stream nil :prefix " ")
+ (pprint-indent :block 30 stream)
+ (format stream "~:[ ~;-~:*~C,~] --~A"
+ (opt-short-name o)
+ (opt-long-name o))
+ (when (opt-arg-name o)
+ (format stream "~:[=~A~;[=~A]~]"
+ (opt-arg-optional-p o)
+ (opt-arg-name o)))
+ (write-string " " stream)
+ (pprint-tab :line 30 1 stream)
+ (print-text doc stream))
+ (terpri stream)))))))
+
+(defun sanity-check-option-list (opts)
+ "Check the option list OPTS for basic sanity. Reused short and long option
+names are diagnosed. Maybe other problems will be reported later. Returns a
+list of warning strings."
+ (let ((problems nil)
+ (longs (make-hash-table :test #'equal))
+ (shorts (make-hash-table)))
+ (flet ((problem (msg &rest args)
+ (push (apply #'format nil msg args) problems)))
+ (dolist (o opts)
+ (push o (gethash (opt-long-name o) longs))
+ (push o (gethash (opt-short-name o) shorts)))
+ (maphash (lambda (k v)
+ (when (and k (cdr v))
+ (problem "Long name `--~A' reused in ~S" k v)))
+ longs)
+ (maphash (lambda (k v)
+ (when (and k (cdr v))
+ (problem "Short name `-~C' reused in ~S" k v)))
+ shorts)
+ problems)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; $Id$
+;;;
+;;; Safely modify collections of files
+;;;
+;;; (c) 2005 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:mdw.safely
+ (:use #:common-lisp #:mdw.base #:mdw.unix)
+ (:export #:safely #:safely-close #:safely-delete-file
+ #:safely-open-output-stream #:safely-bail #:safely-commit
+ #:safely-writing))
+(in-package #:mdw.safely)
+
+(defstruct (safely (:predicate safelyp))
+ "Stores information about how to commit or undo safe writes."
+ (streams nil)
+ (trail nil))
+(defun safely-close (safe stream)
+ "Make sure that STREAM is closed when SAFE is finished."
+ (push stream (safely-streams safe)))
+(defun safely-delete-file (safe file)
+ "Delete FILE when SAFE is committed."
+ (push `(:delete ,file ,(fresh-file-name file "del")) (safely-trail safe)))
+(defun fresh-file-name (base tag)
+ "Return a fresh file name constructed from BASE and TAG in the current
+directory. Do not assume that this filename will be good by the time you try
+to create the file."
+ (let ((name (format nil "~A.~A-~X"
+ base tag (random most-positive-fixnum))))
+ (if (probe-file name) (fresh-file-name base tag) name)))
+(defun safely-open-output-stream (safe file &rest open-args)
+ "Create an output stream which will be named FILE when SAFE is committed.
+Other OPEN-ARGS are passed to open."
+ (let* ((new (fresh-file-name file "new"))
+ (stream (apply #'open
+ new
+ :direction :output
+ :if-exists :error
+ open-args)))
+ (safely-close safe stream)
+ (push `(:shunt ,new ,file ,(fresh-file-name file "old"))
+ (safely-trail safe))
+ stream))
+(defun delete-file-without-moaning (file)
+ "Delete the FILE, ignoring errors."
+ (when (probe-file file)
+ (unix-try unlink file)))
+(defun rename-file-without-moaning (old new)
+ "Rename OLD to NEW, ignoring errors, and without doing any stupid name
+mangling."
+ (when (probe-file old)
+ (unix-try rename old new)))
+(defun safely-unwind (trail)
+ "Roll back the TRAIL of operations."
+ (dolist (job trail)
+ (ecase (car job)
+ (:shunt (destructuring-bind (tag new file old) job
+ (declare (ignore tag file))
+ (delete-file-without-moaning old)
+ (delete-file-without-moaning new)))
+ (:delete)
+ (:rmtmp (destructuring-bind (tag file) job
+ (declare (ignore tag))
+ (delete-file-without-moaning file)))
+ (:revert (destructuring-bind (tag old new) job
+ (declare (ignore tag))
+ (rename-file-without-moaning old new))))))
+(defun safely-reset (safe)
+ "Reset SAFE to its initial state."
+ (setf (safely-streams safe) nil)
+ (setf (safely-trail safe) nil))
+(defun safely-bail (safe)
+ "Abort the operations in SAFE, unwinding all the things that have been
+done. Streams are closed, new files are removed."
+ (dolist (stream (safely-streams safe))
+ (close stream :abort t))
+ (safely-unwind (safely-trail safe))
+ (safely-reset safe))
+(defun safely-commit (safe)
+ "Commit SAFE. The files deleted by safely-delete-file are deleted; the
+files created by safely-open-output-stream are renamed over the old versions,
+if any. If a problem occurs during this stage, everything is rewound and no
+changes are made."
+ (let ((trail (safely-trail safe))
+ (revert nil)
+ (cleanup nil))
+ (unwind-protect
+ (progn
+ (dolist (stream (safely-streams safe))
+ (close stream))
+ (loop
+ (unless trail
+ (return))
+ (let ((job (pop trail)))
+ (ecase (car job)
+ (:shunt (destructuring-bind (tag new file old) job
+ (declare (ignore tag))
+ (push `(:rmtmp ,old) cleanup)
+ (push `(:rmtmp ,new) revert)
+ (if (probe-file file)
+ (progn
+ (copy-file file old)
+ (push `(:revert ,old ,file) revert))
+ (push `(:rmtmp ,file) revert))
+ (unix-try rename new file)))
+ (:delete (destructuring-bind (tag file old) job
+ (declare (ignore tag))
+ (push `(:revert ,old ,file) revert)
+ (unix-try rename file old)
+ (push `(:rmtmp old) cleanup))))))
+ (setf revert nil))
+ (safely-unwind trail)
+ (safely-unwind revert)
+ (safely-unwind cleanup)
+ (safely-reset safe))))
+(defmacro safely ((safe &key) &body body)
+ "Do stuff within the BODY safely. If BODY completes without errors, the
+SAFE is committed; otherwise it's bailed."
+ `(let ((,safe (make-safely)))
+ (unwind-protect
+ (progn
+ ,@body
+ (safely-commit ,safe)
+ (setf ,safe nil))
+ (when ,safe
+ (safely-bail ,safe)))))
+(defmacro safely-writing ((stream file &rest open-args) &body body)
+ "Simple macro for writing a single file safely. STREAM is opened onto a
+temporary file, and if BODY completes, it is renamed to FILE."
+ (with-gensyms safe
+ `(safely (,safe)
+ (let ((,stream (apply #'safely-open-output-stream
+ ,safe ,file ,open-args)))
+ ,@body))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; $Id$
+;;;
+;;; String utilities of various kinds
+;;;
+;;; (c) 2005 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:mdw.str
+ (:use #:common-lisp #:mdw.base)
+ (:export #:join-strings #:str-next-word #:str-split-words))
+(in-package #:mdw.str)
+
+(defun join-strings (del strs)
+ "Join together the strings STRS with DEL between them. All the arguments
+are first converted to strings, as if by `stringify'. Otherwise, this is
+like Perl's join operator."
+ (setf del (stringify del))
+ (with-output-to-string (s)
+ (when strs
+ (loop
+ (princ (stringify (pop strs)) s)
+ (unless strs
+ (return))
+ (princ del s)))))
+
+(defun str-next-word (string &key quotedp start end)
+ "Extract a whitespace-delimited word from STRING, returning it and the
+index to continue parsing from. If no word is found, return nil twice. If
+QUOTEDP, then allow quoting and backslashifying; otherwise don't. The START
+and END arguments limit the portion of the string to be processed; the
+default to 0 and nil (end of string), as usual."
+ (unless start (setf start 0))
+ (unless end (setf end (length string)))
+ (let ((i start)
+ (q nil)
+ (e nil)
+ (w (make-array 0
+ :element-type 'character
+ :adjustable t
+ :fill-pointer t)))
+ ;;
+ ;; Find the start of the next word.
+ (loop
+ (unless (< i end)
+ (return-from str-next-word (values nil nil)))
+ (let ((ch (char string i)))
+ (unless (whitespace-char-p ch)
+ (return)))
+ (incf i))
+ ;;
+ ;; Now pull off a word.
+ (loop
+ (unless (< i end)
+ (return))
+ (let ((ch (char string i)))
+ (cond ((and quotedp (eql ch #\\))
+ (setf e t))
+ (e
+ (vector-push-extend ch w)
+ (setf e nil))
+ ((eql ch q)
+ (setf q nil))
+ (q
+ (vector-push-extend ch w))
+ ((whitespace-char-p ch)
+ (return))
+ ((not quotedp)
+ (vector-push-extend ch w))
+ ((or (eql ch #\')
+ (eql ch #\"))
+ (setf q ch))
+ ((eql ch #\`)
+ (setf q #\'))
+ (t
+ (vector-push-extend ch w))))
+ (incf i))
+ ;;
+ ;; Skip to next word.
+ (loop
+ (unless (< i end)
+ (return))
+ (let ((ch (char string i)))
+ (unless (whitespace-char-p ch)
+ (return)))
+ (incf i))
+ ;;
+ ;; Done.
+ (values (make-array (length w)
+ :element-type 'character
+ :initial-contents w)
+ i)))
+
+(defun str-split-words (string &key quotedp start end max)
+ "Break STRING into words, like str-next-word does, returning the list of
+the individual words. If QUOTEDP, then allow quoting and backslashifying;
+otherwise don't. No more than MAX `words' are returned: if the maximum is
+hit, then the last `word' is unbroken, and may still contain quotes and
+escape characters. The START and END arguments limit the portion of the
+string to be processed in the usual way."
+ (when (equal max 0)
+ (return-from str-split-words nil))
+ (let ((l nil) (n 0))
+ (loop
+ (multiple-value-bind
+ (word nextstart)
+ (str-next-word string
+ :quotedp quotedp
+ :start start
+ :end end)
+ (unless word
+ (return))
+ (when (and max (= (1+ n) max))
+ (push (subseq string start end) l)
+ (return))
+ (setf start nextstart)
+ (push word l)
+ (incf n)))
+ (nreverse l)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; $Id$
+;;;
+;;; Basic system-specific stuff
+;;;
+;;; (c) 2005 Mark Wooding
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:mdw.runlisp
+ (:use #:common-lisp #:extensions)
+ (:export #:*lisp-interpreter* #:*command-line-strings*))
+(defpackage #:mdw.sys-base
+ (:use #:common-lisp #:extensions #:mdw.runlisp)
+ (:export #:exit #:hard-exit #:*program-name* #:*command-line-strings*))
+(in-package #:mdw.sys-base)
+
+;;; --- This is currently all a bit CMUCL-specific ---
+
+#+cmu
+(defun exit (&optional (code 0))
+ "Polite way to end a program. If running in an interactive Lisp, just
+return to the top-level REPL."
+ (if *batch-mode*
+ (throw 'lisp::%end-of-the-world code)
+ (progn
+ (unless (zerop code)
+ (format t "~&Exiting unsuccessfully with code ~D.~%" code))
+ (abort))))
+
+#+cmu
+(defun hard-exit (code)
+ "Stops the program immediately in its tracks. Does nothing else. Use
+after fork, for example, to avoid flushing buffers."
+ (unix::void-syscall ("_exit" c-call:int) code))
+
+#+cmu
+(defvar *program-name* (pathname-name (car *command-line-strings*))
+ "A plausible guess at the program's name, stripped of strange extensions.")
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*0
+;;;
+;;; $Id$
+;;;
+;;; Unix system call stuff
+;;;
+;;; (c) 2005 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:mdw.unix
+ (:use #:common-lisp #:mdw.base #:mdw.collect)
+ (:export #:unix-error #:errno-value #:with-errno-handlers
+ #:unix-try-func #:unix-try
+ #:stat
+ #:with-unix-open #:copy-file))
+(in-package #:mdw.unix)
+
+(defmacro with-buffer ((var len) &body body)
+ "Evaluate BODY with VAR bound to a pointer (a SAP, if you must know) to a
+buffer of LEN bytes."
+ (with-gensyms lenvar
+ `(let ((,lenvar ,len)
+ (,var nil))
+ (unwind-protect
+ (progn
+ (setf ,var (system:allocate-system-memory ,lenvar))
+ ,@body)
+ (when ,var (system:deallocate-system-memory ,var ,lenvar))))))
+(define-condition unix-error (error)
+ ((func :initform 'unknown :initarg :func :reader unix-error-func)
+ (args :initform nil :initarg :args :reader unix-error-args)
+ (errno :initform 0 :initarg :errno :reader unix-error-errno))
+ (:report (lambda (c s)
+ (format s "Error from ~A: ~A (~D)"
+ (cons (unix-error-func c) (unix-error-args c))
+ (unix:get-unix-error-msg (unix-error-errno c))
+ (unix-error-errno c))))
+ (:documentation "Reports an error from a Unix system call."))
+(compile-time-defun errno-value (err)
+ "Returns the numeric value corresponding to an errno name."
+ (etypecase err
+ (integer err)
+ (symbol (symbol-value (intern (symbol-name err) :unix)))))
+(defmacro with-errno-handlers ((&key cond
+ (errno (gensym))
+ errstring)
+ form &rest clauses)
+ "Evaluate FORM but trap Unix errors according to CLAUSES. Each clause has
+the form of a `case' clause, but may contain symbolic errno names as well as
+numbers."
+ (flet ((fix (sw)
+ (cond ((eq sw t) 't)
+ ((atom sw) (list (errno-value sw)))
+ (t (mapcar #'errno-value sw)))))
+ (with-gensyms (block condtmp formfunc)
+ (let ((labels (mapcar (lambda (cl)
+ (declare (ignore cl))
+ (gensym))
+ clauses)))
+ `(let (,@(when cond `(,cond))
+ ,@(when errstring `(,errstring))
+ ,errno
+ (,formfunc (lambda () ,form)))
+ (block ,block
+ (tagbody
+ (handler-bind
+ ((unix-error
+ (lambda (,condtmp)
+ (setf ,errno (unix-error-errno ,condtmp))
+ ,@(when cond
+ `((setf ,cond ,condtmp)))
+ ,@(when errstring
+ `((setf ,errstring
+ (unix:get-unix-error-msg ,errno))))
+ (case ,errno
+ ,@(mapcar (lambda (cl lab)
+ `(,(fix (car cl)) (go ,lab)))
+ clauses
+ labels)))))
+ (return-from ,block (funcall ,formfunc)))
+ ,@(collecting ()
+ (mapc (lambda (cl lab)
+ (collect lab)
+ (collect `(return-from ,block
+ (progn ,@(cdr cl)))))
+ clauses
+ labels)))))))))
+(defun unix-try-func (name func &rest args)
+ "Call Unix system call FUNC, passing it ARGS. If it returns an error,
+signal the unix-error condition, with NAME and ARGS."
+ (multiple-value-call (lambda (rc &rest stuff)
+ (unless rc
+ (error 'unix-error
+ :func name
+ :args args
+ :errno (car stuff)))
+ (apply #'values rc stuff))
+ (apply func args)))
+(defmacro unix-try (syscall &rest args)
+ "Wrapper for unix-try-func. Call Unix system-call SYSCALL (without the
+`unix-' prefix or other stuff), passing it ARGS."
+ (let ((func (intern (format nil "UNIX-~A" (symbol-name syscall)) :unix)))
+ `(unix-try-func ',syscall #',func ,@args)))
+(macrolet ((doit (slots)
+ `(defstruct (stat (:predicate statp)
+ (:conc-name st-)
+ (:constructor %make-stat-boa ,slots))
+ "Structure representing all the useful information `stat'
+returns about a file."
+ ,@slots)))
+ (doit (dev ino mode nlink uid gid rdev size
+ atime mtime ctime blksize blocks)))
+(defun stat (file)
+ "Return information about FILE in a structure rather than as inconvenient
+multiple values."
+ (multiple-value-call (lambda (rc &rest results)
+ (unless rc
+ (error 'unix-error :func 'stat :args (list file)
+ :error (car results)))
+ (apply #'%make-stat-boa results))
+ (unix:unix-stat file)))
+(defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body)
+ "Evaluate BODY with FD bound to a file descriptor obtained from a Unix
+`open' syscall with arguments FILE, HOW and MODE. Close the file descriptor
+when BODY is done."
+ `(let (,fd)
+ (unwind-protect
+ (progn
+ (setf ,fd (unix-try open ,file ,how ,mode))
+ ,@body)
+ (when ,fd (unix-try close ,fd)))))
+(defun copy-file (from to &optional (how 0))
+ "Make a copy of the file FROM called TO. The copy has the same permissions
+and timestamps (except for ctime) and attempts to have the same owner and
+group as the original."
+ (let ((st (stat from)))
+ (with-unix-open (in from unix:o_rdonly)
+ (with-unix-open (out
+ to
+ (logior unix:o_wronly unix:o_creat how)
+ (logand (st-mode st) #o777))
+ (unix-try fchmod out (st-mode st))
+ (unix-try utimes to (st-atime st) 0 (st-mtime st) 0)
+ (with-errno-handlers ()
+ (unix-try fchown out (st-uid st) (st-gid st))
+ (eperm nil))
+ (with-buffer (buf 16384)
+ (loop
+ (let ((n (unix-try read in buf 16384)))
+ (when (zerop n)
+ (return))
+ (unix-try write out buf 0 n))))))))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / commitdiff