Mercurial > hg > xemacs-beta

comparison lisp/dired/dired-rcs.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;;; dired-rcs.el - RCS support for Tree Dired
2
3 (defconst dired-rcs-version (substring "!Revision: 1.6 !" 11 -2)
4 "I don't speak RCS-ese")
5
6 ;; Originally written by Sebastian Kremer <sk@thp.uni-koeln.de>
7 ;; Rewritten by Heiko Muenkel <muenkel@tnt.uni-hannover.de>
8
9 ;; Copyright (C) 1991 by Sebastian Kremer <sk@thp.uni-koeln.de>
10 ;; Copyright (C) 1994 by Heiko Muenkel <muenkel@tnt.uni-hannover.de>
11
12 ;; This program is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 1, or (at your option)
15 ;; any later version.
16 ;;
17 ;; This program is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
21 ;;
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with this program; if not, write to the Free Software
24 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
25
26 ;; INSTALLATION ======================================================
27 ;;
28 ;; This will not work with classic (18.xx) Dired, you'll need Tree Dired,
29 ;; available via anonymous ftp from
30 ;;
31 ;; ftp.thp.Uni-Koeln.DE[134.95.64.1]:/pub/gnu/emacs/diredall.tar.Z
32 ;;
33 ;; Put this file into your load-path and the following in your ~/.emacs:
34 ;;
35 ;; (autoload 'dired-rcs-mark-rcs-locked-files "dired-rcs")
36 ;; (autoload 'dired-rcs-mark-rcs-files "dired-rcs")
37 ;;
38 ;; Put this inside your dired-load-hook:
39 ;;
40 ;; (define-key dired-mode-map "," 'dired-rcs-mark-rcs-files)
41 ;; (define-key dired-mode-map "\M-," 'dired-rcs-mark-rcs-locked-files)
42 ;;
43
44 (require 'dired)
45
46 ;;;###autoload
47 (defun dired-rcs-mark-rcs-locked-files (&optional unflag-p)
48 "Mark all files that are under RCS control and RCS-locked.
49 With prefix argument, unflag all those files.
50 Mentions RCS files for which a working file was not found in this buffer.
51 Type \\[dired-why] to see them again."
52 (interactive "P")
53 (dired-rcs-mark-rcs-files unflag-p t))
54
55 ;;;###autoload
56 (defun dired-rcs-mark-rcs-files (&optional unflag-p locked)
57 "Mark all files that are under RCS control.
58 With prefix argument, unflag all those files.
59 Mentions RCS files for which a working file was not found in this buffer.
60 Type \\[dired-why] to see them again."
61 ;; Returns list of failures, or nil on success.
62 ;; Optional arg LOCKED means just mark RCS-locked files.
63 (interactive "P")
64 (message "%s %sRCS controlled files..."
65 (if unflag-p "Unmarking" "Marking")
66 (if locked "locked " ""))
67 (let ((dired-marker-char (if unflag-p ?\ dired-marker-char))
68 rcs-files wf failures count total)
69 ;; Loop over subdirs to set `rcs-files'
70 (mapcar
71 (function
72 (lambda (dir)
73 (or (equal (file-name-nondirectory (directory-file-name dir))
74 "RCS")
75 ;; skip inserted RCS subdirs
76 (setq rcs-files
77 (append (if locked
78 ;; these two functions from sk's rcs.el
79 (rcs-locked-files dir)
80 (rcs-files dir))
81 rcs-files)))))
82 (mapcar (function car) dired-subdir-alist))
83 (setq total (length rcs-files))
84 (while rcs-files
85 (setq wf (rcs-working-file (car rcs-files))
86 rcs-files (cdr rcs-files))
87 (save-excursion (if (dired-goto-file wf)
88 (dired-mark-file 1)
89 (dired-log "RCS working file not found: %s\n" wf)
90 (setq failures (cons (dired-make-relative wf)
91 failures)))))
92 (if (null failures)
93 (message "%d %sRCS file%s %smarked."
94 total
95 (if locked "locked " "")
96 (dired-plural-s total)
97 (if unflag-p "un" ""))
98 (setq count (length failures))
99 (dired-log-summary "RCS working file not found %s" failures)
100 (message "%d %sRCS file%s: %d %smarked - %d not found %s."
101 total
102 (if locked "locked " "")
103 (dired-plural-s total) (- total count)
104 (if unflag-p "un" "") count failures))
105 failures))
106
107 (defun rcs-files (directory)
108 "Return list of RCS data files for all RCS controlled files in DIRECTORY."
109 (setq directory (file-name-as-directory directory))
110 (let ((rcs-dir (file-name-as-directory (expand-file-name "RCS" directory)))
111 (rcs-files (directory-files directory t ",v$")))
112 (if (file-directory-p rcs-dir)
113 (setq rcs-files
114 (append (directory-files rcs-dir t ",v$")
115 rcs-files)))
116 rcs-files))
117
118 (defvar rcs-output-buffer "*RCS-output*"
119 "If non-nil, buffer name used by function `rcs-get-output-buffer' (q.v.).
120 If nil, a new buffer is used each time.")
121
122 (defun rcs-get-output-buffer (file)
123 ;; Get a buffer for RCS output for FILE, make it writable and clean
124 ;; it up. Return the buffer.
125 ;; The buffer used is named according to variable
126 ;; `rcs-output-buffer'. If the caller wants to be reentrant, it
127 ;; should let-bind this to nil: a new buffer will be chosen.
128 (let* ((default-major-mode 'fundamental-mode);; no frills!
129 (buf (get-buffer-create (or rcs-output-buffer "*RCS-output*"))))
130 (if rcs-output-buffer
131 nil
132 (setq buf (generate-new-buffer "*RCS-output*")))
133 (save-excursion
134 (set-buffer buf)
135 (setq buffer-read-only nil
136 default-directory (file-name-directory (expand-file-name file)))
137 (erase-buffer))
138 buf))
139
140 (defun rcs-locked-files (directory)
141 "Return list of RCS data file names of all RCS-locked files in DIRECTORY."
142 (let ((output-buffer (rcs-get-output-buffer directory))
143 (rcs-files (rcs-files directory))
144 result)
145 (and rcs-files
146 (save-excursion
147 (set-buffer output-buffer)
148 (apply (function call-process) "rlog" nil t nil "-L" "-R" rcs-files)
149 (goto-char (point-min))
150 (while (not (eobp))
151 (setq result (cons (buffer-substring (point)
152 (progn (forward-line 1)
153 (1- (point))))
154 result)))
155 result))))
156
157 (defun rcs-working-file (filename)
158 "Convert an RCS file name to a working file name.
159 That is, convert `...foo,v' and `...RCS/foo,v' to `...foo'.
160 If FILENAME doesn't end in `,v' it is returned unchanged."
161 (if (not (string-match ",v$" filename))
162 filename
163 (setq filename (substring filename 0 -2))
164 (let ((dir (file-name-directory filename)))
165 (if (null dir)
166 filename
167 (let ((dir-file (directory-file-name dir)))
168 (if (equal "RCS" (file-name-nondirectory dir-file))
169 ;; Working file for ./RCS/foo,v is ./foo.
170 ;; Don't use expand-file-name as this converts "" -> pwd
171 ;; and thus forces a relative FILENAME to be relative to
172 ;; the current value of default-directory, which may not
173 ;; what the caller wants. Besides, we want to change
174 ;; FILENAME only as much as necessary.
175 (concat (file-name-directory dir-file)
176 (file-name-nondirectory filename))
177 filename))))))
178
179 (defun dired-do-vc-register (&optional arg)
180 "Register the marked (or next ARG) files under version control."
181 (interactive "P")
182 (dired-mark-map-check (function dired-vc-register) arg 'register t))
183
184 (defun dired-vc-register ()
185 (let ((file (dired-get-filename)) failure)
186 (condition-case err
187 (save-window-excursion
188 (find-file file)
189 (vc-register))
190 (error (setq failure err)))
191 (if (not failure)
192 nil
193 (dired-log "Register error for %s:\n%s\n" file failure)
194 (dired-make-relative file))))
195
196 (provide 'dired-rcs)