From: ······@panix.com
Subject: acl-emacs-vc.cl: Emacs style backup names for ACL...
Date:
Message-ID: <lhrwug6b9s7.fsf@panix2.panix.com>
ACL provides a hook for renaming files when using
':if-exists :rename'; these functions make it more emacs like.
enjoy,
harley.
---8<---snip---8<---snip---8<---snip---8<---snip---8<---
;;; acl-emacs-vc.cl --- make emacs-style backup files
;;
;; ~/acl-emacs-vc/acl-emacs-vc.cl ---
;;
;; $Id: acl-emacs-vc.cl,v 1.7 2003/06/01 06:14:30 harley Exp $
;;
;; Author: harley <······@panix.com>
;; URL: http://www.mahalito.net/~harley/cl/acl-emacs-vc.cl
;; License: free - no warranty.
;;; Commentary:
;; * Do Emacs style VC for backup files. (file.~10~)
;; * To enable this:
;; (setf *open-rename-function* #'emacsvc-make-backup-name)
;; and use ":if-exists :rename" in your opens
;;; History:
;;; Code:
(defvar *emacsvc-original-rename-function* *open-rename-function*)
(defvar *emacsvc-version-control*
(or (sys:getenv "VERSION_CONTROL") t))
;; (setf *emacsvc-version-control* t)
;;; util functions
(defun emacsvc-find-backups (origpath)
"Find the backups for ORIGPATH."
(let* ((o-name (pathname-name origpath))
(o-type (pathname-type origpath))
;; name.type as name to get the '~ver~' suffixes.
(m-name (if o-type (concatenate 'string o-name "." o-type) o-name)) )
(loop
for file in (directory (make-pathname :name m-name :type :wild
:defaults origpath))
;;do (format t "~s" file)
collect file)))
;; (emacsvc-find-backups "./foo")
;; (emacsvc-find-backups "./foo.el")
(defun emacsvc-get-backup-version (farg)
"Get the version out of FARG like 'foo.~100~'."
(let ((ftype (pathname-type farg)))
;; bad type string?
(if (or (null ftype)
(char-not-equal #\~ (elt ftype (1- (length ftype)))) )
(return-from emacsvc-get-backup-version nil) )
(let* ((ver-end (- (length ftype) 1))
(ver-start (position #\~ ftype :from-end t :end ver-end)) )
(if (and ver-start (< (1+ ver-start) ver-end))
(read-from-string (subseq ftype (1+ ver-start) ver-end)) ))))
;; (mapcar 'emacsvc-get-version '("bar.~100~" "bar.~~" "bar.~" "nil" ""))
;;;; name generating functions
(defun emacsvc-name-none (origpath)
"Dont make a backup file for ORIGPATH."
(declare (ignore origpath))
nil)
;; (emacsvc-name-none "foo.el")
(defun emacsvc-name-simple (origpath)
"Make a simple backup name -- append '.bak' to ORIGPATH."
(make-pathname :type "bak"
:defaults origpath))
;; (emacsvc-name-simple "foo.el")
(defun emacsvc-name-original-func (origpath)
"Use the original function to make a backup name for ORIGPATH."
(funcall *emacsvc-original-rename-function* origpath))
;; (emacsvc-name-original "foo")
(defun emacsvc-name-numbered (origpath)
"Make a numbered backup name -- append ~ver~ to ORIGPATH."
(let ((ver-num 0))
;; find oldest version
(dolist (bak-path (emacsvc-find-backups origpath))
(let ((bak-num (emacsvc-get-backup-version bak-path)))
(if (numberp bak-num)
(setf ver-num (max ver-num bak-num)))))
;; paste name and type together to make room for '.~ver~'
(make-pathname :name (format nil ····@[.~a~]"
(pathname-name origpath)
(pathname-type origpath))
:type (format nil "~~~d~~" (1+ ver-num))
:defaults origpath) ))
;; (emacsvc-name-numbered "foo.el")
(defun emacsvc-make-backup-name (origpath)
"Make a backup name for the file ORIGPATH.
This attempts to match the args which might be supplied via
the VERSION_CONTROL env var."
(cond
;; the original acl function
((or (eq *emacsvc-version-control* 'originalfunc))
(emacsvc-name-original-func origpath))
;; let it get overwritten
((or (eq *emacsvc-version-control* 'off)
(equal *emacsvc-version-control* "off")
(equal *emacsvc-version-control* "none"))
(emacsvc-name-none origpath) )
;; .bak
((or (eq *emacsvc-version-control* 'simple)
(equal *emacsvc-version-control* "simple")
(equal *emacsvc-version-control* "never"))
(emacsvc-name-simple origpath))
;; foo.~100~
((or (eq *emacsvc-version-control* t)
(numberp *emacsvc-version-control*)
(equal *emacsvc-version-control* "numbered")
(equal *emacsvc-version-control* "t"))
(emacsvc-name-numbered origpath) )
(t
(error "Unknown emacsvc-version-control value: %s" *emacsvc-version-control*)) ))
;; (setf *open-rename-function* #'emacsvc-make-backup-name)
;; (with-open-file (f "foo.bar" :direction :output :if-exists :rename) (format f "barbar"))
;;; acl-emacs-vc.cl ends here