|
0
|
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)
|
