From 77ab06cf9e2bd3dbe878df5bb07eadba5daddc47 Mon Sep 17 00:00:00 2001 From: "John S. Yates, Jr" Date: Wed, 25 Jan 2023 20:58:59 -0500 Subject: [PATCH 3/3] Introduce vc-bos: backup on save (to an RCS file) The dream of this vc-bos capability was what first got me working on vc-timemachine. From vc-bos.el's front-matter: ;; Modern version control systems, such as git, are wonderful. But they ;; have drawbacks when dealing with lightweight save operations: ;; ;; * Too invasive: new revisions are created only by explicitly action; ;; this includes supplying a commit message (even if empty) ;; * Too coarse: a revision captures an entire "project" ;; * Too smart: even files listed in .gitignore (or equivalent) remain ;; eligible for edting and hence deserve to get backed-up ;; * Requires setup: what about files that have no project? ;; ;; Enter vc-bos... ;; ;; vc-bos provides easy access to past revisions of edited files by ;; integrating with VC's timemachine functionality. To do this it ;; requires that VC's vc-cache-root be set and that it have '/RCS' as ;; one of its directory components (typically the last). ;; ;; Given such a configuration, vc-bos maintains a mirror tree of RCS ;; control files below vc-cache-root. A control file appears at the ;; same position and has exactly the same name as the file that it ;; tracks (meaning no ',v' suffix). This works because RCS treats ;; *any* file *anywhere* beneath an RCS directory as a control file. ;; ;; On FIRST change and EVERY subsequent save cx-bos: ;; ;; * Qualifies the buffer's path ;; * Ensures existence of a mirror directory beneath vc-cache-root ;; * Records the newly saved file as the latest RCS revision with ;; an empty commit message ;; ;; vc-bos's tracking is independent of whether a file is track by ;; any other VCS. Thus, vc-bos is both a minimally invasive way to capture save history for arbitrary files and a convenient way of access that history. ============================================================================ vc-bos leverages vc-timemachine to provide easy access to revisions recorded at the point of saving a file. It is implemented as a new minor mode. * vc-bos.el: new file; implements an extremely minimal vc backend * vc-rcs.el (vc-rcs-tm-revisions): split out vc-rcs-tm-revisions-parse-log so that it can be shared with vc-bos-tm-revisions. (vc-rcs-tm-revisions-parse-log): record empty subject as nil instead of "" * vc-timemachine (vc-tm-revision-head): when prefix arg is present bind new vc-force-bos to trigger use of vc-bos backend (even when file is registered with some other vc backend) (vc-tm--switch-to-revision): pass tmbuf--backend vc-find-revision so as to propagate bos handling (vc-tm--show-echo-area-details): if backend is 'bos then suppress worthless author and subject * vc.el (vc-ensure-vc-buffer): improve diagnostic when user attempt to initiate a timemachine on a file that is not register with any vc backend (vc-find-revision): call vc-bos-find-revision when backend is 'bos --- lisp/vc/vc-bos.el | 207 ++++++++++++++++++++++++++++++++++++++ lisp/vc/vc-git.el | 2 - lisp/vc/vc-rcs.el | 2 +- lisp/vc/vc-timemachine.el | 40 +++++--- lisp/vc/vc.el | 28 +++++- 5 files changed, 257 insertions(+), 22 deletions(-) create mode 100644 lisp/vc/vc-bos.el diff --git a/lisp/vc/vc-bos.el b/lisp/vc/vc-bos.el new file mode 100644 index 0000000000..e689a2cda3 --- /dev/null +++ b/lisp/vc/vc-bos.el @@ -0,0 +1,207 @@ +;;; vc-bos.el --- VC Backup On Save (to RCS) + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Benjamin Rutt +;; Maintainer: Conor Nash +;; Maintainer: John S. Yates, Jr. +;; Version: 0.8 + +;; This file 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, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Credits: +;; +;; Author: Benjamin Rutt +;; Maintainer: John S. Yates, Jr. + +;;; Commentary: + +;; Derived from and then heavily modified: +;; https://www.emacswiki.org/emacs/backup-each-save.el +;; +;; Modern version control system, such as git, are wonderful. But they +;; have drawbacks when dealing with lightweight save operations: +;; +;; * Too invasive: new revisions are created only by explicitly action; +;; this includes supplying a commit message (even if empty) +;; * Too coarse: a revision captures an entire "project" +;; * Too smart: even files listed in .gitignore (or equivalent) remain +;; eligible for edting and hence deserve to get backed-up +;; * Requires setup: what about files that have no project? +;; +;; Enter vc-bos... +;; +;; vc-bos provides easy access to past revisions of edited files by +;; integrating with VC's timemachine functionality. To do this it +;; requires that VC's vc-cache-root be set and that it have '/RCS' as +;; one of its directory components (typically the last). +;; +;; Given such a configuration, vc-bos maintains a mirror tree of RCS +;; control files below vc-cache-root. A control file appears at the +;; same position and has exactly the same name as the file that it +;; tracks (meaning no ',v' suffix). This works because RCS treats +;; *any* file *anywhere* beneath an RCS directory as a control file. +;; +;; On FIRST change and EVERY subsequent save cx-bos: +;; +;; * Qualifies the buffer's path +;; * Ensures existence of a mirror directory beneath vc-cache-root +;; * Records the newly saved file as the latest RCS revision with +;; an empty commit message +;; +;; vc-bos's tracking is independent of whether a file is track by +;; any other VCS. +;; +;; vc-bos requires that the rcs executable be available (typically +;; installed at /usr/bin/rcs). +;; +;; To activate globally, place this file in your `load-path', ensure +;; that vc-cache-root is set, then add the following to your init.el: +;; +;; (vc-bos-mode t) +;; +;; To filter which files vc-bos backs up, setup a custom function for +;; `vc-bos-filter-function'. For example, to filter out the saving of +;; gnus .newsrc.eld files, do: +;; +;; (defun vc-bos-no-newsrc-eld (filename) +;; (cond +;; ((string= (file-name-nondirectory filename) ".newsrc.eld") nil) +;; (t t))) +;; (setq vc-bos-filter-function 'bos-no-newsrc-eld) + +;;; Todo: +;; +;; * garbage collection: it would be nice to have a cron script to purge +;; ancient revisions + +;;; Notes: + +;;; Code: + +(require 'vc-hooks) +(require 'vc-rcs) + + +(defgroup vc-bos nil + "Backup On Save (to an RCS file)." + :group 'vc-timemachine + :group 'backup + :version "30.1") + +(defcustom vc-bos-remote-files nil + "Whether to backup remote files at each save (off by default)." + :type 'boolean + :group 'vc-bos + :version "30.1") + +(defcustom vc-bos-filter-function #'identity + "Function which should return non-nil if the file should be backed up." + :type 'function + :group 'vc-bos + :version "30.1") + +(defcustom vc-bos-size-limit 50000 + "Maximum size (in byte) beyond which a file will not get backed-up. +Setting this variable to nil disables the size check." + :type 'natnum + :group 'vc-bos + :version "30.1") + +(defcustom vc-bos-rcs "/usr/bin/rcs" + "Path to the rcs executable (required for vc-bos functionality)." + :type '(file :must-match t) + :group 'vc-bos + :version "30.1") + +(defconst vc-bos-witnesses-regex + "/\\(SCCS\\|RCS\\|CVS\\|MCVS\\|[.]src\\|[.]svn\\|[.]git\\|[.]hg\\|[.]bzr\\|_MTN\\|_darcs\\|[{]arch[}]\\)/" + "Writes to any point below one of these witnesses should be ignored. + +FIXME: This is a regex-ified copy of vc-hooks's vc-directory-exclusion-list.") + + +;; This implementation does not handle RCS branches. +;;;###autoload +(defun vc-bos-tm-revisions (file) + "Return data about backup-on-save revisions of FILE." + (let ((master-file (concat vc-cache-root file))) + (vc-do-command t 0 vc-bos-rcs master-file "log")) + (vc-rcs-tm-revisions-parse-log file)) + +;;;###autoload +(defun vc-bos-find-revision (file rev buffer) + "Return in BUFFER FILE's backup-on-save revision REV." + (let ((master-file (concat vc-cache-root file))) + (vc-do-command (or buffer "*vc*") 0 vc-bos-rcs master-file "co" "-q" (concat "-p" rev)))) + +;; ;;;###autoload +;; (defun vc-bos-tm-map-line (file from-revision from-line to-revision from-is-older) +;; "Return TO-REVISION's line corresponding to FROM-REVISION's FROM-LINE. +;; On entry the current-buffer is an empty temporary buffer." +;; +;; (message "\n == vc-bos-tm-map-line ==\n") +;; from-line) + +(defun vc-bos-add-revision () + "Record a new RCS 'backup on save' revision of buffer's file." + (setq vc-consult-headers nil) + (let ((bfn buffer-file-name)) + (when (and bfn + (not (string-match-p vc-bos-witnesses-regex bfn)) + (or vc-bos-remote-files + (not (file-remote-p bfn))) + (or (not vc-bos-size-limit) + (<= (buffer-size) vc-bos-size-limit)) + (funcall vc-bos-filter-function bfn)) + (let* ((mirror-file (vc-bos--mirror-file bfn))) + (call-process vc-bos-rcs + nil (get-buffer-create "*vc-bos-log*") nil + "ci" "-l" "-m''" "-t-''" bfn mirror-file))))) + +(defun vc-bos--mirror-file (file) + "Return path to FILE's RCS control file within vc-cache-root." + (let* ((dir (file-name-directory file)) + (file (file-name-nondirectory file)) + (mirror-dir (concat (expand-file-name vc-cache-root) dir)) + (mirror-file (concat mirror-dir file))) + (unless (file-exists-p mirror-dir) + (make-directory mirror-dir t)) + mirror-file)) + +(define-minor-mode vc-bos-mode + "Silently backup saved files as new RCS revisions beneath vc-cache-root. + +Visit saved revisions using vc-tm-revision-head: (C-u C-x v ,)." + :global t + :group 'backup + :group 'vc-bos + :version "30.1" + :lighter " BoS" + (when vc-bos-mode + (unless (and (stringp vc-cache-root) + (string-match-p "/RCS$" vc-cache-root)) + (setq vc-bos-mode nil) + (error "vc-bos-mode requires vc-cache-root (%s) to contains a '/RCS' component" vc-cache-root)) + (add-hook 'first-change-hook #'vc-bos-add-revision) + (add-hook 'after-save-hook #'vc-bos-add-revision)) + (unless vc-bos-mode + (remove-hook 'first-change-hook #'vc-bos-add-revision) + (remove-hook 'after-save-hook #'vc-bos-add-revision))) + +(provide 'vc-bos) + +;;; vc-bos.el ends here diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 1f45aa7e96..745a275294 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -104,8 +104,6 @@ (require 'cl-lib) (require 'vc-dispatcher) -(require 'transient) -(require 'vc-timemachine) (eval-when-compile (require 'subr-x) ; for string-trim-right (require 'vc) diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 9f52587f6f..92246c3ce7 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -859,7 +859,7 @@ vc-rcs-tm-revisions-parse-log (forward-line 1)) (setq new-subject (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (when (equal new-subject "*** empty log message ***") - (setq new-subject "")) + (setq new-subject nil)) (unless (equal subject new-subject) (setq subject new-subject)) (push (list revision date subject author file) revision-infos))) diff --git a/lisp/vc/vc-timemachine.el b/lisp/vc/vc-timemachine.el index ac3b936334..4ed7a2b8b3 100644 --- a/lisp/vc/vc-timemachine.el +++ b/lisp/vc/vc-timemachine.el @@ -58,6 +58,8 @@ ;;; Code: +(declare-function vc-bos-tm-revisions "vc-bos" (abs-file)) + (require 'vc) (defgroup vc-timemachine nil @@ -155,7 +157,7 @@ vc-tm--time-machine (let* ((parent vc-parent-buffer) (abs-file (buffer-file-name)) - (backend (vc-backend abs-file)) + (backend (if vc-force-bos 'bos (vc-backend abs-file))) (work-rev (vc-working-revision abs-file)) (tmbuf vc--time-machine)) @@ -188,7 +190,10 @@ vc-tm--time-machine (with-temp-buffer (prog2 (message "Enumerating revisions...") - (let* ((vec (cl-coerce (vc-call-backend backend 'tm-revisions abs-file) 'vector)) + (let* ((vec (cl-coerce (if (eq backend 'bos) + (vc-bos-tm-revisions abs-file) + (vc-call-backend backend 'tm-revisions abs-file)) + 'vector)) (branch (nreverse vec))) branch) (message "Enumerating revisions...done")))))) @@ -197,11 +202,14 @@ vc-tm--time-machine tmbuf)))) ;;;###autoload -(defun vc-tm-revision-head () - "Show work file's current revision on checked-out branch." - (interactive) - (with-current-buffer (vc-tm--time-machine) - (vc-tm--switch-to-revision 1))) +(defun vc-tm-revision-head (&optional bos) + "Show work file's current revision on checked-out branch. +With a prefix argument, disregard any registration under any +other VCS and show vc-bos backup-on-save revisions." + (interactive "P") + (let ((vc-force-bos bos)) + (with-current-buffer (vc-tm--time-machine) + (vc-tm--switch-to-revision 1)))) (defun vc-tm-revision-next () "Show work file's next revision on checked-out branch." @@ -301,13 +309,17 @@ vc-default-tm-map-line (defun vc-tm--show-echo-area-details (revision-info) "Show details for REVISION-INFO in echo-area." - (let* ((date (nth 1 revision-info)) - (author (if vc-tm-show-author (concat " | " (nth 3 revision-info)) "")) - (sha-or-subject (if (eq vc-tm-echo-area-detail 'commit) (car revision-info) (nth 2 revision-info)))) - (message "%s%s: %s" - date - (propertize author 'face 'vc-tm-echo-area-author-face) - (propertize sha-or-subject 'face 'vc-tm-echo-area-detail-face)))) + (let ((date (nth 1 revision-info))) + (if (eq tmbuf--backend 'bos) + (message "%s" date) + (let* ((author (if vc-tm-echo-area-author (concat " | " (nth 3 revision-info)) "")) + (sha-or-subject (if (eq vc-tm-echo-area-detail 'commit) + (car revision-info) + (nth 2 revision-info)))) + (message "%s%s: %s" + date + (propertize author 'face 'vc-tm-echo-area-author-face) + (propertize sha-or-subject 'face 'vc-tm-echo-area-detail-face)))))) (defun vc-tm-format-date (date) "Return date formatted per the user's vc-tm-date-format." diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 88ec3376c4..7e9852312f 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -809,6 +809,7 @@ (declare-function diff-setup-whitespace "diff-mode" ()) (declare-function diff-setup-buffer-type "diff-mode" ()) +(declare-function vc-bos-find-revision "vc-bos" (abs-file rev buffer)) (eval-when-compile (require 'dired)) @@ -961,6 +962,9 @@ vc-comment-alist (defcustom vc-find-revision-cache nil "When non-nil, `vc-find-revision' caches a local copy of returned revision." :type 'boolean + :group 'backup + :group 'vc-bos + :group 'vc-timemachine :version "30.1") (defcustom vc-cache-root nil @@ -972,8 +976,13 @@ vc-cache-root To use `vc-bos-mode', `vc-cache-root' must include a /RCS component." :type 'string + :group 'backup + :group 'vc-bos + :group 'vc-timemachine :version "30.1") +(defvar vc-force-bos nil + "Non-nil indicates retrieving vc-bos revisions.") ;; File property caching @@ -1234,11 +1243,18 @@ vc-ensure-vc-buffer ;; current buffer are the same buffer. (not (eq vc-parent-buffer (current-buffer)))) (set-buffer vc-parent-buffer)))) - (cond - ((not buffer-file-name) - (error "Buffer '%s' is not associated with a file" (buffer-name))) - ((unless (vc-backend buffer-file-name) - (error "File '%s' is not under version control" buffer-file-name))))) + (let ((bos-file (concat vc-cache-root buffer-file-name))) + (cond + ((not buffer-file-name) + (error "Buffer '%s' is not associated with a file" (buffer-name))) + (vc-force-bos + (unless (file-exists-p bos-file) + (error "File '%s' has no backup-on-save revisions" buffer-file-name))) + ((unless (vc-backend buffer-file-name) + (error "File '%s' is not under version control%s" + buffer-file-name + (when (file-exists-p bos-file) + " but backups from saves are available"))))))) ;;; Support for the C-x v v command. ;; This is where all the single-file-oriented code from before the fileset @@ -2389,6 +2405,8 @@ vc-find-revision ;; A cached file is viable IFF it is not writable. ((and (file-exists-p save-file) (not (file-writable-p save-file))) (insert-file-contents save-file t)) + ((eq backend 'bos) + (vc-bos-find-revision file revision revbuf)) (backend (vc-call-backend backend 'find-revision file revision revbuf)) (t -- 2.37.2