diff options
Diffstat (limited to 'lisp/vc/vc-rcs.el')
| -rw-r--r-- | lisp/vc/vc-rcs.el | 225 |
1 files changed, 125 insertions, 100 deletions
diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 39c583b8a0d..baaf0c3a926 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -1,6 +1,6 @@ ;;; vc-rcs.el --- support for RCS version-control -;; Copyright (C) 1992-2011 Free Software Foundation, Inc. +;; Copyright (C) 1992-2012 Free Software Foundation, Inc. ;; Author: FSF (see vc.el for full credits) ;; Maintainer: Andre Spiegel <spiegel@gnu.org> @@ -38,16 +38,21 @@ ;;; (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'vc)) +(defgroup vc-rcs nil + "VC RCS backend." + :version "24.1" + :group 'vc) + (defcustom vc-rcs-release nil "The release number of your RCS installation, as a string. If nil, VC itself computes this value when it is first needed." :type '(choice (const :tag "Auto" nil) (string :tag "Specified") (const :tag "Unknown" unknown)) - :group 'vc) + :group 'vc-rcs) (defcustom vc-rcs-register-switches nil "Switches for registering a file in RCS. @@ -59,7 +64,7 @@ If t, use no switches." (string :tag "Argument String") (repeat :tag "Argument List" :value ("") string)) :version "21.1" - :group 'vc) + :group 'vc-rcs) (defcustom vc-rcs-diff-switches nil "String or list of strings specifying switches for RCS diff under VC. @@ -69,21 +74,24 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." (string :tag "Argument String") (repeat :tag "Argument List" :value ("") string)) :version "21.1" - :group 'vc) + :group 'vc-rcs) (defcustom vc-rcs-header '("\$Id\$") "Header keywords to be inserted by `vc-insert-headers'." :type '(repeat string) :version "24.1" ; no longer consult the obsolete vc-header-alist - :group 'vc) + :group 'vc-rcs) (defcustom vc-rcsdiff-knows-brief nil "Indicates whether rcsdiff understands the --brief option. The value is either `yes', `no', or nil. If it is nil, VC tries to use --brief and sets this variable to remember whether it worked." :type '(choice (const :tag "Work out" nil) (const yes) (const no)) - :group 'vc) + :group 'vc-rcs) +;; This needs to be autoloaded because vc-rcs-registered uses it (via +;; vc-default-registered), and vc-hooks needs to be able to check +;; for a registered backend without loading every backend. ;;;###autoload (defcustom vc-rcs-master-templates (purecopy '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s")) @@ -95,7 +103,7 @@ For a description of possible values, see `vc-check-master-templates'." (choice string function))) :version "21.1" - :group 'vc) + :group 'vc-rcs) ;;; Properties of the backend @@ -674,9 +682,9 @@ Optional arg REVISION is a revision to annotate from." ;; Apply reverse-chronological edits on the trunk, computing and ;; accumulating forward-chronological edits after some point, for ;; later. - (flet ((r/d/a () (vector pre - (cdr (assq 'date meta)) - (cdr (assq 'author meta))))) + (cl-flet ((r/d/a () (vector pre + (cdr (assq 'date meta)) + (cdr (assq 'author meta))))) (while (when (setq pre cur cur (cdr (assq 'next meta))) (not (string= "" cur))) (setq @@ -700,17 +708,17 @@ Optional arg REVISION is a revision to annotate from." (goto-char (point-min)) (forward-line (1- (pop insn))) (setq p (point)) - (case (pop insn) - (k (setq s (buffer-substring-no-properties - p (progn (forward-line (car insn)) - (point)))) - (when prda - (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path)) - (delete-region p (point))) - (i (setq s (car insn)) - (when prda - (push `(,p . ,(length s)) path)) - (insert s))))) + (pcase (pop insn) + (`k (setq s (buffer-substring-no-properties + p (progn (forward-line (car insn)) + (point)))) + (when prda + (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path)) + (delete-region p (point))) + (`i (setq s (car insn)) + (when prda + (push `(,p . ,(length s)) path)) + (insert s))))) ;; For the initial revision, setting `:vc-rcs-r/d/a' directly is ;; equivalent to pushing an insert instruction (of the entire buffer ;; contents) onto `path' then erasing the buffer, but less wasteful. @@ -732,14 +740,14 @@ Optional arg REVISION is a revision to annotate from." (dolist (insn (cdr (assq :insn meta))) (goto-char (point-min)) (forward-line (1- (pop insn))) - (case (pop insn) - (k (delete-region - (point) (progn (forward-line (car insn)) - (point)))) - (i (insert (propertize - (car insn) - :vc-rcs-r/d/a - (or prda (setq prda (r/d/a)))))))) + (pcase (pop insn) + (`k (delete-region + (point) (progn (forward-line (car insn)) + (point)))) + (`i (insert (propertize + (car insn) + :vc-rcs-r/d/a + (or prda (setq prda (r/d/a)))))))) (prog1 (not (string= (if nbls (caar nbls) revision) pre)) (setq pre (cdr (assq 'next meta))))))))) ;; Lastly, for each line, insert at bol nicely-formatted history info. @@ -764,16 +772,16 @@ Optional arg REVISION is a revision to annotate from." ht) (setq maxw (max w maxw)))) (let ((padding (make-string maxw 32))) - (flet ((pad (w) (substring-no-properties padding w)) - (render (rda &rest ls) - (propertize - (apply 'concat - (format-time-string "%Y-%m-%d" (aref rda 1)) - " " - (aref rda 0) - ls) - :vc-annotate-prefix t - :vc-rcs-r/d/a rda))) + (cl-flet ((pad (w) (substring-no-properties padding w)) + (render (rda &rest ls) + (propertize + (apply 'concat + (format-time-string "%Y-%m-%d" (aref rda 1)) + " " + (aref rda 0) + ls) + :vc-annotate-prefix t + :vc-rcs-r/d/a rda))) (maphash (if all-me (lambda (rda w) @@ -809,9 +817,9 @@ systime, or nil if there is none. Also, reposition point." ;;; Tag system ;;; -(defun vc-rcs-create-tag (backend dir name branchp) +(defun vc-rcs-create-tag (dir name branchp) (when branchp - (error "RCS backend %s does not support module branches" backend)) + (error "RCS backend does not support module branches")) (let ((result (vc-tag-precondition dir))) (if (stringp result) (error "File %s is not up-to-date" result) @@ -863,6 +871,23 @@ and CVS." (minor-num (string-to-number (vc-rcs-minor-part rev)))) (concat branch "." (number-to-string (1+ minor-num)))))) +;; Note that most GNU/Linux distributions seem to supply rcs2log in a +;; standard bin directory. Eg both Red Hat and Debian include it in +;; their cvs packages. It's not obvious why Emacs still needs to +;; provide it as well... +(defvar vc-rcs-rcs2log-program + (let (exe) + (cond ((file-executable-p + (setq exe (expand-file-name "rcs2log" exec-directory))) + exe) + ;; In the unlikely event that someone is running an + ;; uninstalled Emacs and wants to do something RCS-related. + ((file-executable-p + (setq exe (expand-file-name "lib-src/rcs2log" source-directory))) + exe) + (t "rcs2log"))) + "Path to the `rcs2log' program (normally in `exec-directory').") + (defun vc-rcs-update-changelog (files) "Default implementation of update-changelog. Uses `rcs2log' which only works for RCS and CVS." @@ -893,9 +918,7 @@ Uses `rcs2log' which only works for RCS and CVS." (unwind-protect (progn (setq default-directory odefault) - (if (eq 0 (apply 'call-process - (expand-file-name "rcs2log" - exec-directory) + (if (eq 0 (apply 'call-process vc-rcs-rcs2log-program nil (list t tempfile) nil "-c" changelog "-u" (concat login-name @@ -1286,50 +1309,51 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." ;; to "de-@@-format" the printed representation as the first step ;; to translating it into some value. See internal func `gather'. @-holes) - (flet ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]' - (at (tag) (save-excursion (eq tag (read buffer)))) - (to-eol () (buffer-substring-no-properties - (point) (progn (forward-line 1) - (1- (point))))) - (to-semi () (setq b (point) - e (progn (search-forward ";") - (1- (point))))) - (to-one@ () (setq @-holes nil - b (progn (search-forward "@") (point)) - e (progn (while (and (search-forward "@") - (= ?@ (char-after)) - (progn - (push (point) @-holes) - (forward-char 1) - (push (point) @-holes)))) - (1- (point))))) - (tok+val (set-b+e name &optional proc) - (unless (eq name (setq tok (read buffer))) - (error "Missing `%s' while parsing %s" name context)) - (sw) - (funcall set-b+e) - (cons tok (if proc - (funcall proc) - (buffer-substring-no-properties b e)))) - (k-semi (name &optional proc) (tok+val 'to-semi name proc)) - (gather () (let ((pairs `(,e ,@@-holes ,b)) - acc) - (while pairs - (push (buffer-substring-no-properties - (cadr pairs) (car pairs)) - acc) - (setq pairs (cddr pairs))) - (apply 'concat acc))) - (k-one@ (name &optional later) (tok+val 'to-one@ name - (if later - (lambda () t) - 'gather)))) + (cl-flet* + ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]' + (at (tag) (save-excursion (eq tag (read buffer)))) + (to-eol () (buffer-substring-no-properties + (point) (progn (forward-line 1) + (1- (point))))) + (to-semi () (setq b (point) + e (progn (search-forward ";") + (1- (point))))) + (to-one@ () (setq @-holes nil + b (progn (search-forward "@") (point)) + e (progn (while (and (search-forward "@") + (= ?@ (char-after)) + (progn + (push (point) @-holes) + (forward-char 1) + (push (point) @-holes)))) + (1- (point))))) + (tok+val (set-b+e name &optional proc) + (unless (eq name (setq tok (read buffer))) + (error "Missing `%s' while parsing %s" name context)) + (sw) + (funcall set-b+e) + (cons tok (if proc + (funcall proc) + (buffer-substring-no-properties b e)))) + (k-semi (name &optional proc) (tok+val #'to-semi name proc)) + (gather () (let ((pairs `(,e ,@@-holes ,b)) + acc) + (while pairs + (push (buffer-substring-no-properties + (cadr pairs) (car pairs)) + acc) + (setq pairs (cddr pairs))) + (apply 'concat acc))) + (k-one@ (name &optional later) (tok+val #'to-one@ name + (if later + (lambda () t) + #'gather)))) (save-excursion (goto-char (point-min)) ;; headers (setq context 'headers) - (flet ((hpush (name &optional proc) - (push (k-semi name proc) headers))) + (cl-flet ((hpush (name &optional proc) + (push (k-semi name proc) headers))) (hpush 'head) (when (at 'branch) (hpush 'branch)) @@ -1371,7 +1395,7 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." (when (< (car ls) 100) (setcar ls (+ 1900 (car ls)))) (apply 'encode-time (nreverse ls))))) - ,@(mapcar 'k-semi '(author state)) + ,@(mapcar #'k-semi '(author state)) ,(k-semi 'branches (lambda () (split-string @@ -1401,16 +1425,17 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." ;; only the former since it behaves identically to the ;; latter in the absence of "@@".) sub) - (flet ((incg (beg end) (let ((b beg) (e end) @-holes) - (while (and asc (< (car asc) e)) - (push (pop asc) @-holes)) - ;; Self-deprecate when work is done. - ;; Folding many dimensions into one. - ;; Thanks B.Mandelbrot, for complex sum. - ;; O beauteous math! --the Unvexed Bum - (unless asc - (setq sub 'buffer-substring-no-properties)) - (gather)))) + (cl-flet ((incg (beg end) + (let ((b beg) (e end) @-holes) + (while (and asc (< (car asc) e)) + (push (pop asc) @-holes)) + ;; Self-deprecate when work is done. + ;; Folding many dimensions into one. + ;; Thanks B.Mandelbrot, for complex sum. + ;; O beauteous math! --the Unvexed Bum + (unless asc + (setq sub #'buffer-substring-no-properties)) + (gather)))) (while (and (sw) (not (eobp)) (setq context (to-eol) @@ -1429,8 +1454,8 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." (setcdr (cadr rev) (gather)) (if @-holes (setq asc (nreverse @-holes) - sub 'incg) - (setq sub 'buffer-substring-no-properties)) + sub #'incg) + (setq sub #'buffer-substring-no-properties)) (goto-char b) (setq acc nil) (while (< (point) e) @@ -1439,7 +1464,7 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." start (read (current-buffer)) act (read (current-buffer))) (forward-char 1) - (push (case cmd + (push (pcase cmd (?d ;; `d' means "delete lines". ;; For Emacs spirit, we use `k' for "kill". @@ -1453,7 +1478,7 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." `(,(1+ start) i ,(funcall sub (point) (progn (forward-line act) (point))))) - (t (error "Bad command `%c' in `text' for rev `%s'" + (_ (error "Bad command `%c' in `text' for rev `%s'" cmd context))) acc)) (goto-char (1+ e)) |