From 861345b43569790e39df152c6b495b14e7dab360 Mon Sep 17 00:00:00 2001 From: mdw Date: Thu, 25 Aug 2005 08:46:18 +0000 Subject: [PATCH] Initial checkin. --- collect.lisp | 70 +++++ mdw-base.lisp | 199 ++++++++++++++ mdw.asd | 15 ++ optparse-test | 78 ++++++ optparse.lisp | 817 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ safely.lisp | 155 +++++++++++ str.lisp | 138 ++++++++++ sys-base.lisp | 57 ++++ unix.lisp | 170 ++++++++++++ 9 files changed, 1699 insertions(+) create mode 100644 collect.lisp create mode 100644 mdw-base.lisp create mode 100644 mdw.asd create mode 100755 optparse-test create mode 100644 optparse.lisp create mode 100644 safely.lisp create mode 100644 str.lisp create mode 100644 sys-base.lisp create mode 100644 unix.lisp diff --git a/collect.lisp b/collect.lisp new file mode 100644 index 0000000..caa691a --- /dev/null +++ b/collect.lisp @@ -0,0 +1,70 @@ +;;; -*-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 -------------------------------------------------- diff --git a/mdw-base.lisp b/mdw-base.lisp new file mode 100644 index 0000000..3111832 --- /dev/null +++ b/mdw-base.lisp @@ -0,0 +1,199 @@ +;;; -*-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 -------------------------------------------------- diff --git a/mdw.asd b/mdw.asd new file mode 100644 index 0000000..d65d502 --- /dev/null +++ b/mdw.asd @@ -0,0 +1,15 @@ +;;; -*-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) diff --git a/optparse-test b/optparse-test new file mode 100755 index 0000000..cd38066 --- /dev/null +++ b/optparse-test @@ -0,0 +1,78 @@ +#! /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*) + + + diff --git a/optparse.lisp b/optparse.lisp new file mode 100644 index 0000000..9599604 --- /dev/null +++ b/optparse.lisp @@ -0,0 +1,817 @@ +;;; -*-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 + "#" + (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 -------------------------------------------------- diff --git a/safely.lisp b/safely.lisp new file mode 100644 index 0000000..6153060 --- /dev/null +++ b/safely.lisp @@ -0,0 +1,155 @@ +;;; -*-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 -------------------------------------------------- diff --git a/str.lisp b/str.lisp new file mode 100644 index 0000000..9f43ed8 --- /dev/null +++ b/str.lisp @@ -0,0 +1,138 @@ +;;; -*-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 -------------------------------------------------- diff --git a/sys-base.lisp b/sys-base.lisp new file mode 100644 index 0000000..fdbf4fb --- /dev/null +++ b/sys-base.lisp @@ -0,0 +1,57 @@ +;;; -*-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 -------------------------------------------------- diff --git a/unix.lisp b/unix.lisp new file mode 100644 index 0000000..8f9cd3e --- /dev/null +++ b/unix.lisp @@ -0,0 +1,170 @@ +;;; -*-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 -------------------------------------------------- -- 2.11.0