-;;; 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 <spiegel@gnu.org>
;;;
(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.
(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.
(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"))
(choice string
function)))
:version "21.1"
- :group 'vc)
+ :group 'vc-rcs)
\f
;;; Properties of the backend
(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
;; 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
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)
(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)
(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)
(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.
;; 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)
(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"
(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*"
;; 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
(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.
(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.
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)
"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)
;;; 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)
(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
(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."
(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
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))
;; 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))
;; 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
;; `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)
;; 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)
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".
`(,(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))
HCoop / bpt / emacs.git / blobdiff