#+(or cmu sbcl)
(eval-when (:compile-toplevel :execute)
(import #+cmu '(ext:unix-namestring unix:unix-link)
- #+sbcl '(sb-int:unix-namestring)))
+ #+sbcl '(sb-ext:native-namestring)))
+#+cmu
+(progn
+ (declaim (inline unix-namestring))
+ (defun native-namestring (pathname &key as-file)
+ (declare (ignore as-file))
+ (unix-namestring pathname nil)))
(defstruct (safely (:predicate safelyp))
"Stores information about how to commit or undo safe writes."
(safely-trail safe))
stream))
+(declaim (inline rename))
+(defun rename (old new)
+ #-clisp (rename-file old new)
+ #+clisp (posix:copy-file old new :method :rename))
+
(defun delete-file-without-moaning (file)
"Delete the FILE, ignoring errors."
(handler-case (delete-file file)
(defun rename-file-without-moaning (old new)
"Rename OLD to NEW, ignoring errors, and without doing any stupid name
mangling."
- (handler-case (rename-file old new)
+ (handler-case (rename old new)
(file-error () nil)))
(defun safely-unwind (trail)
;; Use link(2) where available.
(generate-fresh-file-name file tag
(lambda (name)
- (let ((from (unix-namestring file t))
- (to (unix-namestring name nil)))
+ (let ((from (native-namestring file
+ :as-file t))
+ (to (native-namestring name
+ :as-file t)))
(and from to
(unix-link from to)))))
+ #+clisp
+ (generate-fresh-file-name file tag
+ (lambda (name)
+ (posix:copy-file (namestring file)
+ (namestring name)
+ :method :hardlink
+ :if-exists nil)))
+
+
+
#-(or cmu sbcl)
;; Otherwise just copy the file contents and hope for the best.
(with-open-file (input file :element-type :default)
(push `(:rmtmp ,old) cleanup)
(push `(:revert ,old ,file) revert))
(push `(:rmtmp ,file) revert))
- (rename-file new file)))
+ (rename new file)))
(:delete (destructuring-bind (tag file) job
(declare (ignore tag))
(let ((old (safe-copy file "delete")))
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)))
+ (let ((,stream (safely-open-output-stream ,safe ,file ,@open-args)))
,@body))))
;;;----- That's all, folks --------------------------------------------------
(defpackage #:mdw.str
(:use #:common-lisp #:mdw.base)
- (:export #:join-strings #:str-next-word #:str-split-words))
+ (:export #:join-strings #:str-next-word #:str-split-words
+ #:str-beginsp #:str-endsp))
(in-package #:mdw.str)
(defun join-strings (del strs)
(incf n)))
(nreverse l)))
+(declaim (inline str-beginsp))
+(defun str-beginsp (string prefix &key (start1 0) end1 (start2 0) end2)
+ "Returns true if STRING (or the appropriate substring of it) begins with
+ PREFIX."
+ (setf-default end1 (length string)
+ end2 (length prefix))
+ (let ((strlen (- end1 start1))
+ (prelen (- end2 start2)))
+ (and (>= strlen prelen)
+ (string= string prefix
+ :start1 start1 :end1 (+ start1 prelen)
+ :start2 start2 :end2 end2))))
+
+(declaim (inline str-endsp))
+(defun str-endsp (string suffix &key (start1 0) end1 (start2 0) end2)
+ "Returns true if STRING (or the appropriate substring of it) ends with
+ SUFFIX."
+ (setf-default end1 (length string)
+ end2 (length suffix))
+ (let ((strlen (- end1 start1))
+ (suflen (- end2 start2)))
+ (and (>= strlen suflen)
+ (string= string suffix
+ :start1 (- end1 suflen) :end1 end1
+ :start2 start2 :end2 end2))))
+
;;;----- That's all, folks --------------------------------------------------