X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/99a33b77e15b9a075024701d060d912b2fd87caf..f4be80b783f23a54b18dfe43ca649a2f4f31b2a5:/lisp/vc/vc-rcs.el diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 488efaa352..6b064260f9 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 +;;; vc-rcs.el --- support for RCS version-control -*- lexical-binding:t -*- -;; Copyright (C) 1992-2011 Free Software Foundation, Inc. +;; Copyright (C) 1992-2014 Free Software Foundation, Inc. ;; Author: FSF (see vc.el for full credits) ;; Maintainer: Andre Spiegel @@ -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 @@ -192,6 +200,8 @@ For a description of possible values, see `vc-check-master-templates'." (vc-rcs-state file)))) (vc-rcs-state file))))) +(autoload 'vc-expand-dirs "vc") + (defun vc-rcs-dir-status (dir update-function) ;; FIXME: this function should be rewritten or `vc-expand-dirs' ;; should be changed to take a backend parameter. Using @@ -262,6 +272,8 @@ When VERSION is given, perform check for that version." ;; RCS is totally file-oriented, so all we have to do is make the directory. (make-directory "RCS")) +(autoload 'vc-switches "vc") + (defun vc-rcs-register (files &optional rev comment) "Register FILES into the RCS version-control system. REV is the optional revision number for the files. COMMENT can be used @@ -282,7 +294,7 @@ expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." nil ".*,v$" t)) (yes-or-no-p "Create RCS subdirectory? ") (make-directory subdir)) - (apply 'vc-do-command "*vc*" 0 "ci" file + (apply #'vc-do-command "*vc*" 0 "ci" file ;; if available, use the secure registering option (and (vc-rcs-release-p "5.6.4") "-i") (concat (if vc-keep-workfiles "-u" "-r") rev) @@ -314,7 +326,10 @@ expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." (defun vc-rcs-responsible-p (file) "Return non-nil if RCS thinks it would be responsible for registering FILE." ;; TODO: check for all the patterns in vc-rcs-master-templates - (file-directory-p (expand-file-name "RCS" (file-name-directory file)))) + (file-directory-p (expand-file-name "RCS" + (if (file-directory-p file) + file + (file-name-directory file))))) (defun vc-rcs-receive-file (file rev) "Implementation of receive-file for RCS." @@ -360,7 +375,7 @@ whether to remove it." (setq switches (cons "-f" switches))) (if (and (not rev) old-version) (setq rev (vc-branch-part old-version))) - (apply 'vc-do-command "*vc*" 0 "ci" (vc-name file) + (apply #'vc-do-command "*vc*" 0 "ci" (vc-name file) ;; if available, use the secure check-in option (and (vc-rcs-release-p "5.6.4") "-j") (concat (if vc-keep-workfiles "-u" "-r") rev) @@ -396,7 +411,7 @@ whether to remove it." (concat "-u" old-version))))))))) (defun vc-rcs-find-revision (file rev buffer) - (apply 'vc-do-command + (apply #'vc-do-command (or buffer "*vc*") 0 "co" (vc-name file) "-q" ;; suppress diagnostic output (concat "-p" rev) @@ -428,7 +443,7 @@ attempt the checkout for all registered files beneath it." (and rev (string= rev "") (vc-rcs-set-default-branch file nil)) ;; now do the checkout - (apply 'vc-do-command + (apply #'vc-do-command "*vc*" 0 "co" (vc-name file) ;; If locking is not strict, force to overwrite ;; the writable workfile. @@ -505,7 +520,7 @@ expanded to all registered subfiles in them." ;; No, it was some other error: re-signal it. (signal (car err) (cdr err))))))))) -(defun vc-rcs-revert (file &optional contents-done) +(defun vc-rcs-revert (file &optional _contents-done) "Revert FILE to the version it was based on. If FILE is a directory, revert all registered files beneath it." (if (file-directory-p file) @@ -556,17 +571,21 @@ directory the operation is applied to all registered files beneath it." (when (looking-at "[\b\t\n\v\f\r ]+") (delete-char (- (match-end 0) (match-beginning 0)))))) -(defun vc-rcs-print-log (files buffer &optional shortlog start-revision-ignored limit) - "Get change log associated with FILE. If FILE is a -directory the operation is applied to all registered files beneath it." - (vc-do-command (or buffer "*vc*") 0 "rlog" (mapcar 'vc-name (vc-expand-dirs files))) +(defun vc-rcs-print-log (files buffer &optional _shortlog + _start-revision-ignored limit) + "Print commit log associated with FILES into specified BUFFER. +Remaining arguments are ignored. +If FILE is a directory the operation is applied to all registered +files beneath it." + (vc-do-command (or buffer "*vc*") 0 "rlog" + (mapcar 'vc-name (vc-expand-dirs files))) (with-current-buffer (or buffer "*vc*") (vc-rcs-print-log-cleanup)) (when limit 'limit-unsupported)) (defun vc-rcs-diff (files &optional oldvers newvers buffer) "Get a difference report using RCS between two sets of files." - (apply 'vc-do-command (or buffer "*vc-diff*") + (apply #'vc-do-command (or buffer "*vc-diff*") 1 ;; Always go synchronous, the repo is local "rcsdiff" (vc-expand-dirs files) (append (list "-q" @@ -574,6 +593,10 @@ directory the operation is applied to all registered files beneath it." (and newvers (concat "-r" newvers))) (vc-switches 'RCS 'diff)))) +(defun vc-rcs-find-admin-dir (file) + "Return the administrative directory of FILE." + (vc-find-root file "RCS")) + (defun vc-rcs-comment-history (file) "Return a string with all log entries stored in BACKEND for FILE." (with-current-buffer "*vc*" @@ -671,9 +694,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 @@ -697,17 +720,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. @@ -729,14 +752,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. @@ -761,16 +784,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) @@ -788,7 +811,7 @@ Optional arg REVISION is a revision to annotate from." "Return the current time, based at midnight of the current day, and encoded as fractional days." (vc-annotate-convert-time - (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time)))))) + (apply #'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time)))))) (defun vc-rcs-annotate-time () "Return the time of the next annotation (as fraction of days) @@ -806,9 +829,12 @@ systime, or nil if there is none. Also, reposition point." ;;; Tag system ;;; -(defun vc-rcs-create-tag (backend dir name branchp) +(autoload 'vc-tag-precondition "vc") +(declare-function vc-file-tree-walk "vc" (dirname func &rest args)) + +(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) @@ -831,7 +857,7 @@ systime, or nil if there is none. Also, reposition point." (string-match "[0-9]+\\'" rev) (substring rev (match-beginning 0) (match-end 0))) -(defun vc-rcs-previous-revision (file rev) +(defun vc-rcs-previous-revision (_file rev) "Return the revision number immediately preceding REV for FILE, or nil if there is no previous revision. This default implementation works for MAJOR.MINOR-style revision numbers as @@ -860,6 +886,24 @@ and CVS." (minor-num (string-to-number (vc-rcs-minor-part rev)))) (concat branch "." (number-to-string (1+ minor-num)))))) +;; You might think that this should be distributed with RCS, but +;; apparently not. CVS sometimes provides a version of it. +;; http://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00288.html +(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').") + +(autoload 'vc-buffer-sync "vc-dispatcher") + (defun vc-rcs-update-changelog (files) "Default implementation of update-changelog. Uses `rcs2log' which only works for RCS and CVS." @@ -890,9 +934,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 @@ -928,6 +970,8 @@ Uses `rcs2log' which only works for RCS and CVS." nil t) (replace-match "$\\1$")))) +(autoload 'vc-rename-master "vc") + (defun vc-rcs-rename-file (old new) ;; Just move the master file (using vc-rcs-master-templates). (vc-rename-master (vc-name old) new vc-rcs-master-templates)) @@ -1283,50 +1327,50 @@ 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))) + (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 (b e @-holes) + (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))) + (gather1 () (gather b e @-holes)) + (k-one@ (name &optional later) + (tok+val #'to-one@ name (if later (lambda () t) #'gather1)))) (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)) @@ -1367,8 +1411,8 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." ;; same algorithm used in RCS 5.7. (when (< (car ls) 100) (setcar ls (+ 1900 (car ls)))) - (apply 'encode-time (nreverse ls))))) - ,@(mapcar 'k-semi '(author state)) + (apply #'encode-time (nreverse ls))))) + ,@(mapcar #'k-semi '(author state)) ,(k-semi 'branches (lambda () (split-string @@ -1396,18 +1440,20 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." ;; `incg' or `buffer-substring-no-properties'. (This is ;; for speed; strictly speaking, it is sufficient to use ;; only the former since it behaves identically to the - ;; latter in the absense of "@@".) + ;; 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) + (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 b e @-holes)))) (while (and (sw) (not (eobp)) (setq context (to-eol) @@ -1423,11 +1469,11 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." ;; other revisions, replace the `text' tag+value with `:insn' ;; plus value, always scanning in-place. (if (string= context (cdr (assq 'head headers))) - (setcdr (cadr rev) (gather)) + (setcdr (cadr rev) (gather b e @-holes)) (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) @@ -1436,7 +1482,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". @@ -1450,7 +1496,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))