Mercurial > emacs
comparison lisp/vc/vc-cvs.el @ 109063:c77749185234
merge trunk
author | Kenichi Handa <handa@etlken> |
---|---|
date | Thu, 24 Jun 2010 15:10:43 +0900 |
parents | lisp/vc-cvs.el@1918e70c8b37 lisp/vc-cvs.el@6ff48295959a |
children | 1b626601d32d |
comparison
equal
deleted
inserted
replaced
108814:9d7ea82188d8 | 109063:c77749185234 |
---|---|
1 ;;; vc-cvs.el --- non-resident support for CVS version-control | |
2 | |
3 ;; Copyright (C) 1995, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, | |
4 ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. | |
5 | |
6 ;; Author: FSF (see vc.el for full credits) | |
7 ;; Maintainer: Andre Spiegel <spiegel@gnu.org> | |
8 | |
9 ;; This file is part of GNU Emacs. | |
10 | |
11 ;; GNU Emacs is free software: you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation, either version 3 of the License, or | |
14 ;; (at your option) any later version. | |
15 | |
16 ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 ;; GNU General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
23 | |
24 ;;; Commentary: | |
25 | |
26 ;;; Code: | |
27 | |
28 (eval-when-compile (require 'cl) (require 'vc)) | |
29 | |
30 ;; Clear up the cache to force vc-call to check again and discover | |
31 ;; new functions when we reload this file. | |
32 (put 'CVS 'vc-functions nil) | |
33 | |
34 ;;; Properties of the backend. | |
35 | |
36 (defun vc-cvs-revision-granularity () 'file) | |
37 | |
38 (defun vc-cvs-checkout-model (files) | |
39 "CVS-specific version of `vc-checkout-model'." | |
40 (if (getenv "CVSREAD") | |
41 'announce | |
42 (let* ((file (if (consp files) (car files) files)) | |
43 (attrib (file-attributes file))) | |
44 (or (vc-file-getprop file 'vc-checkout-model) | |
45 (vc-file-setprop | |
46 file 'vc-checkout-model | |
47 (if (and attrib ;; don't check further if FILE doesn't exist | |
48 ;; If the file is not writable (despite CVSREAD being | |
49 ;; undefined), this is probably because the file is being | |
50 ;; "watched" by other developers. | |
51 ;; (If vc-mistrust-permissions was t, we actually shouldn't | |
52 ;; trust this, but there is no other way to learn this from | |
53 ;; CVS at the moment (version 1.9).) | |
54 (string-match "r-..-..-." (nth 8 attrib))) | |
55 'announce | |
56 'implicit)))))) | |
57 | |
58 ;;; | |
59 ;;; Customization options | |
60 ;;; | |
61 | |
62 (defcustom vc-cvs-global-switches nil | |
63 "Global switches to pass to any CVS command." | |
64 :type '(choice (const :tag "None" nil) | |
65 (string :tag "Argument String") | |
66 (repeat :tag "Argument List" | |
67 :value ("") | |
68 string)) | |
69 :version "22.1" | |
70 :group 'vc) | |
71 | |
72 (defcustom vc-cvs-register-switches nil | |
73 "Switches for registering a file into CVS. | |
74 A string or list of strings passed to the checkin program by | |
75 \\[vc-register]. If nil, use the value of `vc-register-switches'. | |
76 If t, use no switches." | |
77 :type '(choice (const :tag "Unspecified" nil) | |
78 (const :tag "None" t) | |
79 (string :tag "Argument String") | |
80 (repeat :tag "Argument List" :value ("") string)) | |
81 :version "21.1" | |
82 :group 'vc) | |
83 | |
84 (defcustom vc-cvs-diff-switches nil | |
85 "String or list of strings specifying switches for CVS diff under VC. | |
86 If nil, use the value of `vc-diff-switches'. If t, use no switches." | |
87 :type '(choice (const :tag "Unspecified" nil) | |
88 (const :tag "None" t) | |
89 (string :tag "Argument String") | |
90 (repeat :tag "Argument List" :value ("") string)) | |
91 :version "21.1" | |
92 :group 'vc) | |
93 | |
94 (defcustom vc-cvs-header (or (cdr (assoc 'CVS vc-header-alist)) '("\$Id\$")) | |
95 "Header keywords to be inserted by `vc-insert-headers'." | |
96 :version "21.1" | |
97 :type '(repeat string) | |
98 :group 'vc) | |
99 | |
100 (defcustom vc-cvs-use-edit t | |
101 "Non-nil means to use `cvs edit' to \"check out\" a file. | |
102 This is only meaningful if you don't use the implicit checkout model | |
103 \(i.e. if you have $CVSREAD set)." | |
104 :type 'boolean | |
105 :version "21.1" | |
106 :group 'vc) | |
107 | |
108 (defcustom vc-cvs-stay-local 'only-file | |
109 "Non-nil means use local operations when possible for remote repositories. | |
110 This avoids slow queries over the network and instead uses heuristics | |
111 and past information to determine the current status of a file. | |
112 | |
113 If value is the symbol `only-file' `vc-dir' will connect to the | |
114 server, but heuristics will be used to determine the status for | |
115 all other VC operations. | |
116 | |
117 The value can also be a regular expression or list of regular | |
118 expressions to match against the host name of a repository; then VC | |
119 only stays local for hosts that match it. Alternatively, the value | |
120 can be a list of regular expressions where the first element is the | |
121 symbol `except'; then VC always stays local except for hosts matched | |
122 by these regular expressions." | |
123 :type '(choice (const :tag "Always stay local" t) | |
124 (const :tag "Only for file operations" only-file) | |
125 (const :tag "Don't stay local" nil) | |
126 (list :format "\nExamine hostname and %v" | |
127 :tag "Examine hostname ..." | |
128 (set :format "%v" :inline t | |
129 (const :format "%t" :tag "don't" except)) | |
130 (regexp :format " stay local,\n%t: %v" | |
131 :tag "if it matches") | |
132 (repeat :format "%v%i\n" :inline t (regexp :tag "or")))) | |
133 :version "23.1" | |
134 :group 'vc) | |
135 | |
136 (defcustom vc-cvs-sticky-date-format-string "%c" | |
137 "Format string for mode-line display of sticky date. | |
138 Format is according to `format-time-string'. Only used if | |
139 `vc-cvs-sticky-tag-display' is t." | |
140 :type '(string) | |
141 :version "22.1" | |
142 :group 'vc) | |
143 | |
144 (defcustom vc-cvs-sticky-tag-display t | |
145 "Specify the mode-line display of sticky tags. | |
146 Value t means default display, nil means no display at all. If the | |
147 value is a function or macro, it is called with the sticky tag and | |
148 its' type as parameters, in that order. TYPE can have three different | |
149 values: `symbolic-name' (TAG is a string), `revision-number' (TAG is a | |
150 string) and `date' (TAG is a date as returned by `encode-time'). The | |
151 return value of the function or macro will be displayed as a string. | |
152 | |
153 Here's an example that will display the formatted date for sticky | |
154 dates and the word \"Sticky\" for sticky tag names and revisions. | |
155 | |
156 (lambda (tag type) | |
157 (cond ((eq type 'date) (format-time-string | |
158 vc-cvs-sticky-date-format-string tag)) | |
159 ((eq type 'revision-number) \"Sticky\") | |
160 ((eq type 'symbolic-name) \"Sticky\"))) | |
161 | |
162 Here's an example that will abbreviate to the first character only, | |
163 any text before the first occurrence of `-' for sticky symbolic tags. | |
164 If the sticky tag is a revision number, the word \"Sticky\" is | |
165 displayed. Date and time is displayed for sticky dates. | |
166 | |
167 (lambda (tag type) | |
168 (cond ((eq type 'date) (format-time-string \"%Y%m%d %H:%M\" tag)) | |
169 ((eq type 'revision-number) \"Sticky\") | |
170 ((eq type 'symbolic-name) | |
171 (condition-case nil | |
172 (progn | |
173 (string-match \"\\\\([^-]*\\\\)\\\\(.*\\\\)\" tag) | |
174 (concat (substring (match-string 1 tag) 0 1) \":\" | |
175 (substring (match-string 2 tag) 1 nil))) | |
176 (error tag))))) ; Fall-back to given tag name. | |
177 | |
178 See also variable `vc-cvs-sticky-date-format-string'." | |
179 :type '(choice boolean function) | |
180 :version "22.1" | |
181 :group 'vc) | |
182 | |
183 ;;; | |
184 ;;; Internal variables | |
185 ;;; | |
186 | |
187 | |
188 ;;; | |
189 ;;; State-querying functions | |
190 ;;; | |
191 | |
192 ;;;###autoload (defun vc-cvs-registered (f) | |
193 ;;;###autoload (when (file-readable-p (expand-file-name | |
194 ;;;###autoload "CVS/Entries" (file-name-directory f))) | |
195 ;;;###autoload (load "vc-cvs") | |
196 ;;;###autoload (vc-cvs-registered f))) | |
197 | |
198 (defun vc-cvs-registered (file) | |
199 "Check if FILE is CVS registered." | |
200 (let ((dirname (or (file-name-directory file) "")) | |
201 (basename (file-name-nondirectory file)) | |
202 ;; make sure that the file name is searched case-sensitively | |
203 (case-fold-search nil)) | |
204 (if (file-readable-p (expand-file-name "CVS/Entries" dirname)) | |
205 (or (string= basename "") | |
206 (with-temp-buffer | |
207 (vc-cvs-get-entries dirname) | |
208 (goto-char (point-min)) | |
209 (cond ((re-search-forward | |
210 (concat "^/" (regexp-quote basename) "/[^/]") nil t) | |
211 (beginning-of-line) | |
212 (vc-cvs-parse-entry file) | |
213 t) | |
214 (t nil)))) | |
215 nil))) | |
216 | |
217 (defun vc-cvs-state (file) | |
218 "CVS-specific version of `vc-state'." | |
219 (if (vc-stay-local-p file 'CVS) | |
220 (let ((state (vc-file-getprop file 'vc-state))) | |
221 ;; If we should stay local, use the heuristic but only if | |
222 ;; we don't have a more precise state already available. | |
223 (if (memq state '(up-to-date edited nil)) | |
224 (vc-cvs-state-heuristic file) | |
225 state)) | |
226 (with-temp-buffer | |
227 (cd (file-name-directory file)) | |
228 (let (process-file-side-effects) | |
229 (vc-cvs-command t 0 file "status")) | |
230 (vc-cvs-parse-status t)))) | |
231 | |
232 (defun vc-cvs-state-heuristic (file) | |
233 "CVS-specific state heuristic." | |
234 ;; If the file has not changed since checkout, consider it `up-to-date'. | |
235 ;; Otherwise consider it `edited'. | |
236 (let ((checkout-time (vc-file-getprop file 'vc-checkout-time)) | |
237 (lastmod (nth 5 (file-attributes file)))) | |
238 (cond | |
239 ((equal checkout-time lastmod) 'up-to-date) | |
240 ((string= (vc-working-revision file) "0") 'added) | |
241 ((null checkout-time) 'unregistered) | |
242 (t 'edited)))) | |
243 | |
244 (defun vc-cvs-working-revision (file) | |
245 "CVS-specific version of `vc-working-revision'." | |
246 ;; There is no need to consult RCS headers under CVS, because we | |
247 ;; get the workfile version for free when we recognize that a file | |
248 ;; is registered in CVS. | |
249 (vc-cvs-registered file) | |
250 (vc-file-getprop file 'vc-working-revision)) | |
251 | |
252 (defun vc-cvs-mode-line-string (file) | |
253 "Return string for placement into the modeline for FILE. | |
254 Compared to the default implementation, this function does two things: | |
255 Handle the special case of a CVS file that is added but not yet | |
256 committed and support display of sticky tags." | |
257 (let* ((sticky-tag (vc-file-getprop file 'vc-cvs-sticky-tag)) | |
258 help-echo | |
259 (string | |
260 (let ((def-ml (vc-default-mode-line-string 'CVS file))) | |
261 (setq help-echo | |
262 (get-text-property 0 'help-echo def-ml)) | |
263 def-ml))) | |
264 (propertize | |
265 (if (zerop (length sticky-tag)) | |
266 string | |
267 (setq help-echo (format "%s on the '%s' branch" | |
268 help-echo sticky-tag)) | |
269 (concat string "[" sticky-tag "]")) | |
270 'help-echo help-echo))) | |
271 | |
272 | |
273 ;;; | |
274 ;;; State-changing functions | |
275 ;;; | |
276 | |
277 (defun vc-cvs-register (files &optional rev comment) | |
278 "Register FILES into the CVS version-control system. | |
279 COMMENT can be used to provide an initial description of FILES. | |
280 Passes either `vc-cvs-register-switches' or `vc-register-switches' | |
281 to the CVS command." | |
282 ;; Register the directories if needed. | |
283 (let (dirs) | |
284 (dolist (file files) | |
285 (and (not (vc-cvs-responsible-p file)) | |
286 (vc-cvs-could-register file) | |
287 (push (directory-file-name (file-name-directory file)) dirs))) | |
288 (if dirs (vc-cvs-register dirs))) | |
289 (apply 'vc-cvs-command nil 0 files | |
290 "add" | |
291 (and comment (string-match "[^\t\n ]" comment) | |
292 (concat "-m" comment)) | |
293 (vc-switches 'CVS 'register))) | |
294 | |
295 (defun vc-cvs-responsible-p (file) | |
296 "Return non-nil if CVS thinks it is responsible for FILE." | |
297 (file-directory-p (expand-file-name "CVS" | |
298 (if (file-directory-p file) | |
299 file | |
300 (file-name-directory file))))) | |
301 | |
302 (defun vc-cvs-could-register (file) | |
303 "Return non-nil if FILE could be registered in CVS. | |
304 This is only possible if CVS is managing FILE's directory or one of | |
305 its parents." | |
306 (let ((dir file)) | |
307 (while (and (stringp dir) | |
308 (not (equal dir (setq dir (file-name-directory dir)))) | |
309 dir) | |
310 (setq dir (if (file-exists-p | |
311 (expand-file-name "CVS/Entries" dir)) | |
312 t | |
313 (directory-file-name dir)))) | |
314 (eq dir t))) | |
315 | |
316 (defun vc-cvs-checkin (files rev comment &optional extra-args-ignored) | |
317 "CVS-specific version of `vc-backend-checkin'." | |
318 (unless (or (not rev) (vc-cvs-valid-revision-number-p rev)) | |
319 (if (not (vc-cvs-valid-symbolic-tag-name-p rev)) | |
320 (error "%s is not a valid symbolic tag name" rev) | |
321 ;; If the input revison is a valid symbolic tag name, we create it | |
322 ;; as a branch, commit and switch to it. | |
323 (apply 'vc-cvs-command nil 0 files "tag" "-b" (list rev)) | |
324 (apply 'vc-cvs-command nil 0 files "update" "-r" (list rev)) | |
325 (mapc (lambda (file) (vc-file-setprop file 'vc-cvs-sticky-tag rev)) | |
326 files))) | |
327 (let ((status (apply 'vc-cvs-command nil 1 files | |
328 "ci" (if rev (concat "-r" rev)) | |
329 (concat "-m" comment) | |
330 (vc-switches 'CVS 'checkin)))) | |
331 (set-buffer "*vc*") | |
332 (goto-char (point-min)) | |
333 (when (not (zerop status)) | |
334 ;; Check checkin problem. | |
335 (cond | |
336 ((re-search-forward "Up-to-date check failed" nil t) | |
337 (mapc (lambda (file) (vc-file-setprop file 'vc-state 'needs-merge)) | |
338 files) | |
339 (error "%s" (substitute-command-keys | |
340 (concat "Up-to-date check failed: " | |
341 "type \\[vc-next-action] to merge in changes")))) | |
342 (t | |
343 (pop-to-buffer (current-buffer)) | |
344 (goto-char (point-min)) | |
345 (shrink-window-if-larger-than-buffer) | |
346 (error "Check-in failed")))) | |
347 ;; Single-file commit? Then update the revision by parsing the buffer. | |
348 ;; Otherwise we can't necessarily tell what goes with what; clear | |
349 ;; its properties so they have to be refetched. | |
350 (if (= (length files) 1) | |
351 (vc-file-setprop | |
352 (car files) 'vc-working-revision | |
353 (vc-parse-buffer "^\\(new\\|initial\\) revision: \\([0-9.]+\\)" 2)) | |
354 (mapc 'vc-file-clearprops files)) | |
355 ;; Anyway, forget the checkout model of the file, because we might have | |
356 ;; guessed wrong when we found the file. After commit, we can | |
357 ;; tell it from the permissions of the file (see | |
358 ;; vc-cvs-checkout-model). | |
359 (mapc (lambda (file) (vc-file-setprop file 'vc-checkout-model nil)) | |
360 files) | |
361 | |
362 ;; if this was an explicit check-in (does not include creation of | |
363 ;; a branch), remove the sticky tag. | |
364 (if (and rev (not (vc-cvs-valid-symbolic-tag-name-p rev))) | |
365 (vc-cvs-command nil 0 files "update" "-A")))) | |
366 | |
367 (defun vc-cvs-find-revision (file rev buffer) | |
368 (apply 'vc-cvs-command | |
369 buffer 0 file | |
370 "-Q" ; suppress diagnostic output | |
371 "update" | |
372 (and rev (not (string= rev "")) | |
373 (concat "-r" rev)) | |
374 "-p" | |
375 (vc-switches 'CVS 'checkout))) | |
376 | |
377 (defun vc-cvs-checkout (file &optional editable rev) | |
378 "Checkout a revision of FILE into the working area. | |
379 EDITABLE non-nil means that the file should be writable. | |
380 REV is the revision to check out." | |
381 (message "Checking out %s..." file) | |
382 ;; Change buffers to get local value of vc-checkout-switches. | |
383 (with-current-buffer (or (get-file-buffer file) (current-buffer)) | |
384 (if (and (file-exists-p file) (not rev)) | |
385 ;; If no revision was specified, just make the file writable | |
386 ;; if necessary (using `cvs-edit' if requested). | |
387 (and editable (not (eq (vc-cvs-checkout-model (list file)) 'implicit)) | |
388 (if vc-cvs-use-edit | |
389 (vc-cvs-command nil 0 file "edit") | |
390 (set-file-modes file (logior (file-modes file) 128)) | |
391 (if (equal file buffer-file-name) (toggle-read-only -1)))) | |
392 ;; Check out a particular revision (or recreate the file). | |
393 (vc-file-setprop file 'vc-working-revision nil) | |
394 (apply 'vc-cvs-command nil 0 file | |
395 (and editable "-w") | |
396 "update" | |
397 (when rev | |
398 (unless (eq rev t) | |
399 ;; default for verbose checkout: clear the | |
400 ;; sticky tag so that the actual update will | |
401 ;; get the head of the trunk | |
402 (if (string= rev "") | |
403 "-A" | |
404 (concat "-r" rev)))) | |
405 (vc-switches 'CVS 'checkout))) | |
406 (vc-mode-line file 'CVS)) | |
407 (message "Checking out %s...done" file)) | |
408 | |
409 (defun vc-cvs-delete-file (file) | |
410 (vc-cvs-command nil 0 file "remove" "-f")) | |
411 | |
412 (defun vc-cvs-revert (file &optional contents-done) | |
413 "Revert FILE to the working revision on which it was based." | |
414 (vc-default-revert 'CVS file contents-done) | |
415 (unless (eq (vc-cvs-checkout-model (list file)) 'implicit) | |
416 (if vc-cvs-use-edit | |
417 (vc-cvs-command nil 0 file "unedit") | |
418 ;; Make the file read-only by switching off all w-bits | |
419 (set-file-modes file (logand (file-modes file) 3950))))) | |
420 | |
421 (defun vc-cvs-merge (file first-revision &optional second-revision) | |
422 "Merge changes into current working copy of FILE. | |
423 The changes are between FIRST-REVISION and SECOND-REVISION." | |
424 (vc-cvs-command nil 0 file | |
425 "update" "-kk" | |
426 (concat "-j" first-revision) | |
427 (concat "-j" second-revision)) | |
428 (vc-file-setprop file 'vc-state 'edited) | |
429 (with-current-buffer (get-buffer "*vc*") | |
430 (goto-char (point-min)) | |
431 (if (re-search-forward "conflicts during merge" nil t) | |
432 (progn | |
433 (vc-file-setprop file 'vc-state 'conflict) | |
434 ;; signal error | |
435 1) | |
436 (vc-file-setprop file 'vc-state 'edited) | |
437 ;; signal success | |
438 0))) | |
439 | |
440 (defun vc-cvs-merge-news (file) | |
441 "Merge in any new changes made to FILE." | |
442 (message "Merging changes into %s..." file) | |
443 ;; (vc-file-setprop file 'vc-working-revision nil) | |
444 (vc-file-setprop file 'vc-checkout-time 0) | |
445 (vc-cvs-command nil nil file "update") | |
446 ;; Analyze the merge result reported by CVS, and set | |
447 ;; file properties accordingly. | |
448 (with-current-buffer (get-buffer "*vc*") | |
449 (goto-char (point-min)) | |
450 ;; get new working revision | |
451 (if (re-search-forward | |
452 "^Merging differences between [0-9.]* and \\([0-9.]*\\) into" nil t) | |
453 (vc-file-setprop file 'vc-working-revision (match-string 1)) | |
454 (vc-file-setprop file 'vc-working-revision nil)) | |
455 ;; get file status | |
456 (prog1 | |
457 (if (eq (buffer-size) 0) | |
458 0 ;; there were no news; indicate success | |
459 (if (re-search-forward | |
460 (concat "^\\([CMUP] \\)?" | |
461 (regexp-quote | |
462 (substring file (1+ (length (expand-file-name | |
463 "." default-directory))))) | |
464 "\\( already contains the differences between \\)?") | |
465 nil t) | |
466 (cond | |
467 ;; Merge successful, we are in sync with repository now | |
468 ((or (match-string 2) | |
469 (string= (match-string 1) "U ") | |
470 (string= (match-string 1) "P ")) | |
471 (vc-file-setprop file 'vc-state 'up-to-date) | |
472 (vc-file-setprop file 'vc-checkout-time | |
473 (nth 5 (file-attributes file))) | |
474 0);; indicate success to the caller | |
475 ;; Merge successful, but our own changes are still in the file | |
476 ((string= (match-string 1) "M ") | |
477 (vc-file-setprop file 'vc-state 'edited) | |
478 0);; indicate success to the caller | |
479 ;; Conflicts detected! | |
480 (t | |
481 (vc-file-setprop file 'vc-state 'conflict) | |
482 1);; signal the error to the caller | |
483 ) | |
484 (pop-to-buffer "*vc*") | |
485 (error "Couldn't analyze cvs update result"))) | |
486 (message "Merging changes into %s...done" file)))) | |
487 | |
488 (defun vc-cvs-modify-change-comment (files rev comment) | |
489 "Modify the change comments for FILES on a specified REV. | |
490 Will fail unless you have administrative privileges on the repo." | |
491 (vc-cvs-command nil 0 files "admin" (concat "-m" rev ":" comment))) | |
492 | |
493 ;;; | |
494 ;;; History functions | |
495 ;;; | |
496 | |
497 (declare-function vc-rcs-print-log-cleanup "vc-rcs" ()) | |
498 | |
499 (defun vc-cvs-print-log (files buffer &optional shortlog start-revision-ignored limit) | |
500 "Get change logs associated with FILES." | |
501 (require 'vc-rcs) | |
502 ;; It's just the catenation of the individual logs. | |
503 (vc-cvs-command | |
504 buffer | |
505 (if (vc-stay-local-p files 'CVS) 'async 0) | |
506 files "log") | |
507 (with-current-buffer buffer | |
508 (vc-exec-after (vc-rcs-print-log-cleanup))) | |
509 (when limit 'limit-unsupported)) | |
510 | |
511 (defun vc-cvs-comment-history (file) | |
512 "Get comment history of a file." | |
513 (vc-call-backend 'RCS 'comment-history file)) | |
514 | |
515 (defun vc-cvs-diff (files &optional oldvers newvers buffer) | |
516 "Get a difference report using CVS between two revisions of FILE." | |
517 (let* (process-file-side-effects | |
518 (async (and (not vc-disable-async-diff) | |
519 (vc-stay-local-p files 'CVS))) | |
520 (invoke-cvs-diff-list nil) | |
521 status) | |
522 ;; Look through the file list and see if any files have backups | |
523 ;; that can be used to do a plain "diff" instead of "cvs diff". | |
524 (dolist (file files) | |
525 (let ((ov oldvers) | |
526 (nv newvers)) | |
527 (when (or (not ov) (string-equal ov "")) | |
528 (setq ov (vc-working-revision file))) | |
529 (when (string-equal nv "") | |
530 (setq nv nil)) | |
531 (let ((file-oldvers (vc-version-backup-file file ov)) | |
532 (file-newvers (if (not nv) | |
533 file | |
534 (vc-version-backup-file file nv))) | |
535 (coding-system-for-read (vc-coding-system-for-diff file))) | |
536 (if (and file-oldvers file-newvers) | |
537 (progn | |
538 ;; This used to append diff-switches and vc-diff-switches, | |
539 ;; which was consistent with the vc-diff-switches doc at that | |
540 ;; time, but not with the actual behavior of any other VC diff. | |
541 (apply 'vc-do-command (or buffer "*vc-diff*") 1 "diff" nil | |
542 ;; Not a CVS diff, does not use vc-cvs-diff-switches. | |
543 (append (vc-switches nil 'diff) | |
544 (list (file-relative-name file-oldvers) | |
545 (file-relative-name file-newvers)))) | |
546 (setq status 0)) | |
547 (push file invoke-cvs-diff-list))))) | |
548 (when invoke-cvs-diff-list | |
549 (setq status (apply 'vc-cvs-command (or buffer "*vc-diff*") | |
550 (if async 'async 1) | |
551 invoke-cvs-diff-list "diff" | |
552 (and oldvers (concat "-r" oldvers)) | |
553 (and newvers (concat "-r" newvers)) | |
554 (vc-switches 'CVS 'diff)))) | |
555 (if async 1 status))) ; async diff, pessimistic assumption | |
556 | |
557 (defconst vc-cvs-annotate-first-line-re "^[0-9]") | |
558 | |
559 (defun vc-cvs-annotate-process-filter (process string) | |
560 (setq string (concat (process-get process 'output) string)) | |
561 (if (not (string-match vc-cvs-annotate-first-line-re string)) | |
562 ;; Still waiting for the first real line. | |
563 (process-put process 'output string) | |
564 (let ((vc-filter (process-get process 'vc-filter))) | |
565 (set-process-filter process vc-filter) | |
566 (funcall vc-filter process (substring string (match-beginning 0)))))) | |
567 | |
568 (defun vc-cvs-annotate-command (file buffer &optional revision) | |
569 "Execute \"cvs annotate\" on FILE, inserting the contents in BUFFER. | |
570 Optional arg REVISION is a revision to annotate from." | |
571 (vc-cvs-command buffer | |
572 (if (vc-stay-local-p file 'CVS) | |
573 'async 0) | |
574 file "annotate" | |
575 (if revision (concat "-r" revision))) | |
576 ;; Strip the leading few lines. | |
577 (let ((proc (get-buffer-process buffer))) | |
578 (if proc | |
579 ;; If running asynchronously, use a process filter. | |
580 (progn | |
581 (process-put proc 'vc-filter (process-filter proc)) | |
582 (set-process-filter proc 'vc-cvs-annotate-process-filter)) | |
583 (with-current-buffer buffer | |
584 (goto-char (point-min)) | |
585 (re-search-forward vc-cvs-annotate-first-line-re) | |
586 (delete-region (point-min) (1- (point))))))) | |
587 | |
588 (declare-function vc-annotate-convert-time "vc-annotate" (time)) | |
589 | |
590 (defun vc-cvs-annotate-current-time () | |
591 "Return the current time, based at midnight of the current day, and | |
592 encoded as fractional days." | |
593 (vc-annotate-convert-time | |
594 (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time)))))) | |
595 | |
596 (defun vc-cvs-annotate-time () | |
597 "Return the time of the next annotation (as fraction of days) | |
598 systime, or nil if there is none." | |
599 (let* ((bol (point)) | |
600 (cache (get-text-property bol 'vc-cvs-annotate-time)) | |
601 (inhibit-read-only t) | |
602 (inhibit-modification-hooks t)) | |
603 (cond | |
604 (cache) | |
605 ((looking-at | |
606 "^\\S-+\\s-+\\S-+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): ") | |
607 (let ((day (string-to-number (match-string 1))) | |
608 (month (cdr (assq (intern (match-string 2)) | |
609 '((Jan . 1) (Feb . 2) (Mar . 3) | |
610 (Apr . 4) (May . 5) (Jun . 6) | |
611 (Jul . 7) (Aug . 8) (Sep . 9) | |
612 (Oct . 10) (Nov . 11) (Dec . 12))))) | |
613 (year (let ((tmp (string-to-number (match-string 3)))) | |
614 ;; Years 0..68 are 2000..2068. | |
615 ;; Years 69..99 are 1969..1999. | |
616 (+ (cond ((> 69 tmp) 2000) | |
617 ((> 100 tmp) 1900) | |
618 (t 0)) | |
619 tmp)))) | |
620 (put-text-property | |
621 bol (1+ bol) 'vc-cvs-annotate-time | |
622 (setq cache (cons | |
623 ;; Position at end makes for nicer overlay result. | |
624 ;; Don't put actual buffer pos here, but only relative | |
625 ;; distance, so we don't ever move backward in the | |
626 ;; goto-char below, even if the text is moved. | |
627 (- (match-end 0) (match-beginning 0)) | |
628 (vc-annotate-convert-time | |
629 (encode-time 0 0 0 day month year)))))))) | |
630 (when cache | |
631 (goto-char (+ bol (car cache))) ; Fontify from here to eol. | |
632 (cdr cache)))) ; days (float) | |
633 | |
634 (defun vc-cvs-annotate-extract-revision-at-line () | |
635 (save-excursion | |
636 (beginning-of-line) | |
637 (if (re-search-forward "^\\([0-9]+\\.[0-9]+\\(\\.[0-9]+\\)*\\) +(" | |
638 (line-end-position) t) | |
639 (match-string-no-properties 1) | |
640 nil))) | |
641 | |
642 (defun vc-cvs-previous-revision (file rev) | |
643 (vc-call-backend 'RCS 'previous-revision file rev)) | |
644 | |
645 (defun vc-cvs-next-revision (file rev) | |
646 (vc-call-backend 'RCS 'next-revision file rev)) | |
647 | |
648 ;; FIXME: This should probably be replaced by code using cvs2cl. | |
649 (defun vc-cvs-update-changelog (files) | |
650 (vc-call-backend 'RCS 'update-changelog files)) | |
651 | |
652 ;;; | |
653 ;;; Tag system | |
654 ;;; | |
655 | |
656 (defun vc-cvs-create-tag (dir name branchp) | |
657 "Assign to DIR's current revision a given NAME. | |
658 If BRANCHP is non-nil, the name is created as a branch (and the current | |
659 workspace is immediately moved to that new branch)." | |
660 (vc-cvs-command nil 0 dir "tag" "-c" (if branchp "-b") name) | |
661 (when branchp (vc-cvs-command nil 0 dir "update" "-r" name))) | |
662 | |
663 (defun vc-cvs-retrieve-tag (dir name update) | |
664 "Retrieve a tag at and below DIR. | |
665 NAME is the name of the tag; if it is empty, do a `cvs update'. | |
666 If UPDATE is non-nil, then update (resynch) any affected buffers." | |
667 (with-current-buffer (get-buffer-create "*vc*") | |
668 (let ((default-directory dir) | |
669 (sticky-tag)) | |
670 (erase-buffer) | |
671 (if (or (not name) (string= name "")) | |
672 (vc-cvs-command t 0 nil "update") | |
673 (vc-cvs-command t 0 nil "update" "-r" name) | |
674 (setq sticky-tag name)) | |
675 (when update | |
676 (goto-char (point-min)) | |
677 (while (not (eobp)) | |
678 (if (looking-at "\\([CMUP]\\) \\(.*\\)") | |
679 (let* ((file (expand-file-name (match-string 2) dir)) | |
680 (state (match-string 1)) | |
681 (buffer (find-buffer-visiting file))) | |
682 (when buffer | |
683 (cond | |
684 ((or (string= state "U") | |
685 (string= state "P")) | |
686 (vc-file-setprop file 'vc-state 'up-to-date) | |
687 (vc-file-setprop file 'vc-working-revision nil) | |
688 (vc-file-setprop file 'vc-checkout-time | |
689 (nth 5 (file-attributes file)))) | |
690 ((or (string= state "M") | |
691 (string= state "C")) | |
692 (vc-file-setprop file 'vc-state 'edited) | |
693 (vc-file-setprop file 'vc-working-revision nil) | |
694 (vc-file-setprop file 'vc-checkout-time 0))) | |
695 (vc-file-setprop file 'vc-cvs-sticky-tag sticky-tag) | |
696 (vc-resynch-buffer file t t)))) | |
697 (forward-line 1)))))) | |
698 | |
699 | |
700 ;;; | |
701 ;;; Miscellaneous | |
702 ;;; | |
703 | |
704 (defun vc-cvs-make-version-backups-p (file) | |
705 "Return non-nil if version backups should be made for FILE." | |
706 (vc-stay-local-p file 'CVS)) | |
707 | |
708 (defun vc-cvs-check-headers () | |
709 "Check if the current file has any headers in it." | |
710 (save-excursion | |
711 (goto-char (point-min)) | |
712 (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\ | |
713 \\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t))) | |
714 | |
715 | |
716 ;;; | |
717 ;;; Internal functions | |
718 ;;; | |
719 | |
720 (defun vc-cvs-command (buffer okstatus files &rest flags) | |
721 "A wrapper around `vc-do-command' for use in vc-cvs.el. | |
722 The difference to vc-do-command is that this function always invokes `cvs', | |
723 and that it passes `vc-cvs-global-switches' to it before FLAGS." | |
724 (apply 'vc-do-command (or buffer "*vc*") okstatus "cvs" files | |
725 (if (stringp vc-cvs-global-switches) | |
726 (cons vc-cvs-global-switches flags) | |
727 (append vc-cvs-global-switches | |
728 flags)))) | |
729 | |
730 (defun vc-cvs-stay-local-p (file) ;Back-compatibility. | |
731 (vc-stay-local-p file 'CVS)) | |
732 | |
733 (defun vc-cvs-repository-hostname (dirname) | |
734 "Hostname of the CVS server associated to workarea DIRNAME." | |
735 (let ((rootname (expand-file-name "CVS/Root" dirname))) | |
736 (when (file-readable-p rootname) | |
737 (with-temp-buffer | |
738 (let ((coding-system-for-read | |
739 (or file-name-coding-system | |
740 default-file-name-coding-system))) | |
741 (vc-insert-file rootname)) | |
742 (goto-char (point-min)) | |
743 (nth 2 (vc-cvs-parse-root | |
744 (buffer-substring (point) | |
745 (line-end-position)))))))) | |
746 | |
747 (defun vc-cvs-parse-uhp (path) | |
748 "parse user@host/path into (user@host /path)" | |
749 (if (string-match "\\([^/]+\\)\\(/.*\\)" path) | |
750 (list (match-string 1 path) (match-string 2 path)) | |
751 (list nil path))) | |
752 | |
753 (defun vc-cvs-parse-root (root) | |
754 "Split CVS ROOT specification string into a list of fields. | |
755 A CVS root specification of the form | |
756 [:METHOD:][[USER@]HOSTNAME]:?/path/to/repository | |
757 is converted to a normalized record with the following structure: | |
758 \(METHOD USER HOSTNAME CVS-ROOT). | |
759 The default METHOD for a CVS root of the form | |
760 /path/to/repository | |
761 is `local'. | |
762 The default METHOD for a CVS root of the form | |
763 [USER@]HOSTNAME:/path/to/repository | |
764 is `ext'. | |
765 For an empty string, nil is returned (invalid CVS root)." | |
766 ;; Split CVS root into colon separated fields (0-4). | |
767 ;; The `x:' makes sure, that leading colons are not lost; | |
768 ;; `HOST:/PATH' is then different from `:METHOD:/PATH'. | |
769 (let* ((root-list (cdr (split-string (concat "x:" root) ":"))) | |
770 (len (length root-list)) | |
771 ;; All syntactic varieties will get a proper METHOD. | |
772 (root-list | |
773 (cond | |
774 ((= len 0) | |
775 ;; Invalid CVS root | |
776 nil) | |
777 ((= len 1) | |
778 (let ((uhp (vc-cvs-parse-uhp (car root-list)))) | |
779 (cons (if (car uhp) "ext" "local") uhp))) | |
780 ((= len 2) | |
781 ;; [USER@]HOST:PATH => method `ext' | |
782 (and (not (equal (car root-list) "")) | |
783 (cons "ext" root-list))) | |
784 ((= len 3) | |
785 ;; :METHOD:PATH or :METHOD:USER@HOSTNAME/PATH | |
786 (cons (cadr root-list) | |
787 (vc-cvs-parse-uhp (caddr root-list)))) | |
788 (t | |
789 ;; :METHOD:[USER@]HOST:PATH | |
790 (cdr root-list))))) | |
791 (if root-list | |
792 (let ((method (car root-list)) | |
793 (uhost (or (cadr root-list) "")) | |
794 (root (nth 2 root-list)) | |
795 user host) | |
796 ;; Split USER@HOST | |
797 (if (string-match "\\(.*\\)@\\(.*\\)" uhost) | |
798 (setq user (match-string 1 uhost) | |
799 host (match-string 2 uhost)) | |
800 (setq host uhost)) | |
801 ;; Remove empty HOST | |
802 (and (equal host "") | |
803 (setq host)) | |
804 ;; Fix windows style CVS root `:local:C:\\project\\cvs\\some\\dir' | |
805 (and host | |
806 (equal method "local") | |
807 (setq root (concat host ":" root) host)) | |
808 ;; Normalize CVS root record | |
809 (list method user host root))))) | |
810 | |
811 ;; XXX: This does not work correctly for subdirectories. "cvs status" | |
812 ;; information is context sensitive, it contains lines like: | |
813 ;; cvs status: Examining DIRNAME | |
814 ;; and the file entries after that don't show the full path. | |
815 ;; Because of this VC directory listings only show changed files | |
816 ;; at the top level for CVS. | |
817 (defun vc-cvs-parse-status (&optional full) | |
818 "Parse output of \"cvs status\" command in the current buffer. | |
819 Set file properties accordingly. Unless FULL is t, parse only | |
820 essential information. Note that this can never set the 'ignored | |
821 state." | |
822 (let (file status missing) | |
823 (goto-char (point-min)) | |
824 (while (looking-at "? \\(.*\\)") | |
825 (setq file (expand-file-name (match-string 1))) | |
826 (vc-file-setprop file 'vc-state 'unregistered) | |
827 (forward-line 1)) | |
828 (when (re-search-forward "^File: " nil t) | |
829 (when (setq missing (looking-at "no file ")) | |
830 (goto-char (match-end 0))) | |
831 (cond | |
832 ((re-search-forward "\\=\\([^ \t]+\\)" nil t) | |
833 (setq file (expand-file-name (match-string 1))) | |
834 (setq status(if (re-search-forward "\\=[ \t]+Status: \\(.*\\)" nil t) | |
835 (match-string 1) "Unknown")) | |
836 (when (and full | |
837 (re-search-forward | |
838 "\\(RCS Version\\|RCS Revision\\|Repository revision\\):\ | |
839 \[\t ]+\\([0-9.]+\\)" | |
840 nil t)) | |
841 (vc-file-setprop file 'vc-latest-revision (match-string 2))) | |
842 (vc-file-setprop | |
843 file 'vc-state | |
844 (cond | |
845 ((string-match "Up-to-date" status) | |
846 (vc-file-setprop file 'vc-checkout-time | |
847 (nth 5 (file-attributes file))) | |
848 'up-to-date) | |
849 ((string-match "Locally Modified" status) 'edited) | |
850 ((string-match "Needs Merge" status) 'needs-merge) | |
851 ((string-match "Needs \\(Checkout\\|Patch\\)" status) | |
852 (if missing 'missing 'needs-update)) | |
853 ((string-match "Locally Added" status) 'added) | |
854 ((string-match "Locally Removed" status) 'removed) | |
855 ((string-match "File had conflicts " status) 'conflict) | |
856 ((string-match "Unknown" status) 'unregistered) | |
857 (t 'edited)))))))) | |
858 | |
859 (defun vc-cvs-after-dir-status (update-function) | |
860 ;; Heavily inspired by vc-cvs-parse-status. AKA a quick hack. | |
861 ;; This needs a lot of testing. | |
862 (let ((status nil) | |
863 (status-str nil) | |
864 (file nil) | |
865 (result nil) | |
866 (missing nil) | |
867 (ignore-next nil) | |
868 (subdir default-directory)) | |
869 (goto-char (point-min)) | |
870 (while | |
871 ;; Look for either a file entry, an unregistered file, or a | |
872 ;; directory change. | |
873 (re-search-forward | |
874 "\\(^=+\n\\([^=c?\n].*\n\\|\n\\)+\\)\\|\\(\\(^?? .*\n\\)+\\)\\|\\(^cvs status: \\(Examining\\|nothing\\) .*\n\\)" | |
875 nil t) | |
876 ;; FIXME: get rid of narrowing here. | |
877 (narrow-to-region (match-beginning 0) (match-end 0)) | |
878 (goto-char (point-min)) | |
879 ;; The subdir | |
880 (when (looking-at "cvs status: Examining \\(.+\\)") | |
881 (setq subdir (expand-file-name (match-string 1)))) | |
882 ;; Unregistered files | |
883 (while (looking-at "? \\(.*\\)") | |
884 (setq file (file-relative-name | |
885 (expand-file-name (match-string 1) subdir))) | |
886 (push (list file 'unregistered) result) | |
887 (forward-line 1)) | |
888 (when (looking-at "cvs status: nothing known about") | |
889 ;; We asked about a non existent file. The output looks like this: | |
890 | |
891 ;; cvs status: nothing known about `lisp/v.diff' | |
892 ;; =================================================================== | |
893 ;; File: no file v.diff Status: Unknown | |
894 ;; | |
895 ;; Working revision: No entry for v.diff | |
896 ;; Repository revision: No revision control file | |
897 ;; | |
898 | |
899 ;; Due to narrowing in this iteration we only see the "cvs | |
900 ;; status:" line, so just set a flag so that we can ignore the | |
901 ;; file in the next iteration. | |
902 (setq ignore-next t)) | |
903 ;; A file entry. | |
904 (when (re-search-forward "^File: \\(no file \\)?\\(.*[^ \t]\\)[ \t]+Status: \\(.*\\)" nil t) | |
905 (setq missing (match-string 1)) | |
906 (setq file (file-relative-name | |
907 (expand-file-name (match-string 2) subdir))) | |
908 (setq status-str (match-string 3)) | |
909 (setq status | |
910 (cond | |
911 ((string-match "Up-to-date" status-str) 'up-to-date) | |
912 ((string-match "Locally Modified" status-str) 'edited) | |
913 ((string-match "Needs Merge" status-str) 'needs-merge) | |
914 ((string-match "Needs \\(Checkout\\|Patch\\)" status-str) | |
915 (if missing 'missing 'needs-update)) | |
916 ((string-match "Locally Added" status-str) 'added) | |
917 ((string-match "Locally Removed" status-str) 'removed) | |
918 ((string-match "File had conflicts " status-str) 'conflict) | |
919 ((string-match "Unknown" status-str) 'unregistered) | |
920 (t 'edited))) | |
921 (if ignore-next | |
922 (setq ignore-next nil) | |
923 (unless (eq status 'up-to-date) | |
924 (push (list file status) result)))) | |
925 (goto-char (point-max)) | |
926 (widen)) | |
927 (funcall update-function result)) | |
928 ;; Alternative implementation: use the "update" command instead of | |
929 ;; the "status" command. | |
930 ;; (let ((result nil) | |
931 ;; (translation '((?? . unregistered) | |
932 ;; (?A . added) | |
933 ;; (?C . conflict) | |
934 ;; (?M . edited) | |
935 ;; (?P . needs-merge) | |
936 ;; (?R . removed) | |
937 ;; (?U . needs-update)))) | |
938 ;; (goto-char (point-min)) | |
939 ;; (while (not (eobp)) | |
940 ;; (if (looking-at "^[ACMPRU?] \\(.*\\)$") | |
941 ;; (push (list (match-string 1) | |
942 ;; (cdr (assoc (char-after) translation))) | |
943 ;; result) | |
944 ;; (cond | |
945 ;; ((looking-at "cvs update: warning: \\(.*\\) was lost") | |
946 ;; ;; Format is: | |
947 ;; ;; cvs update: warning: FILENAME was lost | |
948 ;; ;; U FILENAME | |
949 ;; (push (list (match-string 1) 'missing) result) | |
950 ;; ;; Skip the "U" line | |
951 ;; (forward-line 1)) | |
952 ;; ((looking-at "cvs update: New directory `\\(.*\\)' -- ignored") | |
953 ;; (push (list (match-string 1) 'unregistered) result)))) | |
954 ;; (forward-line 1)) | |
955 ;; (funcall update-function result))) | |
956 ) | |
957 | |
958 ;; Based on vc-cvs-dir-state-heuristic from Emacs 22. | |
959 ;; FIXME does not mention unregistered files. | |
960 (defun vc-cvs-dir-status-heuristic (dir update-function &optional basedir) | |
961 "Find the CVS state of all files in DIR, using only local information." | |
962 (let (file basename status result dirlist) | |
963 (with-temp-buffer | |
964 (vc-cvs-get-entries dir) | |
965 (goto-char (point-min)) | |
966 (while (not (eobp)) | |
967 (if (looking-at "D/\\([^/]*\\)////") | |
968 (push (expand-file-name (match-string 1) dir) dirlist) | |
969 ;; CVS-removed files are not taken under VC control. | |
970 (when (looking-at "/\\([^/]*\\)/[^/-]") | |
971 (setq basename (match-string 1) | |
972 file (expand-file-name basename dir) | |
973 status (or (vc-file-getprop file 'vc-state) | |
974 (vc-cvs-parse-entry file t))) | |
975 (unless (eq status 'up-to-date) | |
976 (push (list (if basedir | |
977 (file-relative-name file basedir) | |
978 basename) | |
979 status) result)))) | |
980 (forward-line 1))) | |
981 (dolist (subdir dirlist) | |
982 (setq result (append result | |
983 (vc-cvs-dir-status-heuristic subdir nil | |
984 (or basedir dir))))) | |
985 (if basedir result | |
986 (funcall update-function result)))) | |
987 | |
988 (defun vc-cvs-dir-status (dir update-function) | |
989 "Create a list of conses (file . state) for DIR." | |
990 ;; FIXME check all files in DIR instead? | |
991 (let ((local (vc-stay-local-p dir 'CVS))) | |
992 (if (and local (not (eq local 'only-file))) | |
993 (vc-cvs-dir-status-heuristic dir update-function) | |
994 (vc-cvs-command (current-buffer) 'async dir "-f" "status") | |
995 ;; Alternative implementation: use the "update" command instead of | |
996 ;; the "status" command. | |
997 ;; (vc-cvs-command (current-buffer) 'async | |
998 ;; (file-relative-name dir) | |
999 ;; "-f" "-n" "update" "-d" "-P") | |
1000 (vc-exec-after | |
1001 `(vc-cvs-after-dir-status (quote ,update-function)))))) | |
1002 | |
1003 (defun vc-cvs-dir-status-files (dir files default-state update-function) | |
1004 "Create a list of conses (file . state) for DIR." | |
1005 (apply 'vc-cvs-command (current-buffer) 'async dir "-f" "status" files) | |
1006 (vc-exec-after | |
1007 `(vc-cvs-after-dir-status (quote ,update-function)))) | |
1008 | |
1009 (defun vc-cvs-file-to-string (file) | |
1010 "Read the content of FILE and return it as a string." | |
1011 (condition-case nil | |
1012 (with-temp-buffer | |
1013 (insert-file-contents file) | |
1014 (goto-char (point-min)) | |
1015 (buffer-substring (point) (point-max))) | |
1016 (file-error nil))) | |
1017 | |
1018 (defun vc-cvs-dir-extra-headers (dir) | |
1019 "Extract and represent per-directory properties of a CVS working copy." | |
1020 (let ((repo | |
1021 (condition-case nil | |
1022 (with-temp-buffer | |
1023 (insert-file-contents "CVS/Root") | |
1024 (goto-char (point-min)) | |
1025 (and (looking-at ":ext:") (delete-char 5)) | |
1026 (concat (buffer-substring (point) (1- (point-max))) "\n")) | |
1027 (file-error nil))) | |
1028 (module | |
1029 (condition-case nil | |
1030 (with-temp-buffer | |
1031 (insert-file-contents "CVS/Repository") | |
1032 (goto-char (point-min)) | |
1033 (skip-chars-forward "^\n") | |
1034 (concat (buffer-substring (point-min) (point)) "\n")) | |
1035 (file-error nil)))) | |
1036 (concat | |
1037 (cond (repo | |
1038 (concat (propertize "Repository : " 'face 'font-lock-type-face) | |
1039 (propertize repo 'face 'font-lock-variable-name-face))) | |
1040 (t "")) | |
1041 (cond (module | |
1042 (concat (propertize "Module : " 'face 'font-lock-type-face) | |
1043 (propertize module 'face 'font-lock-variable-name-face))) | |
1044 (t "")) | |
1045 (if (file-readable-p "CVS/Tag") | |
1046 (let ((tag (vc-cvs-file-to-string "CVS/Tag"))) | |
1047 (cond | |
1048 ((string-match "\\`T" tag) | |
1049 (concat (propertize "Tag : " 'face 'font-lock-type-face) | |
1050 (propertize (substring tag 1) | |
1051 'face 'font-lock-variable-name-face))) | |
1052 ((string-match "\\`D" tag) | |
1053 (concat (propertize "Date : " 'face 'font-lock-type-face) | |
1054 (propertize (substring tag 1) | |
1055 'face 'font-lock-variable-name-face))) | |
1056 (t "")))) | |
1057 | |
1058 ;; In CVS, branch is a per-file property, not a per-directory property. | |
1059 ;; We can't really do this here without making dangerous assumptions. | |
1060 ;;(propertize "Branch: " 'face 'font-lock-type-face) | |
1061 ;;(propertize "ADD CODE TO PRINT THE BRANCH NAME\n" | |
1062 ;; 'face 'font-lock-warning-face) | |
1063 ))) | |
1064 | |
1065 (defun vc-cvs-get-entries (dir) | |
1066 "Insert the CVS/Entries file from below DIR into the current buffer. | |
1067 This function ensures that the correct coding system is used for that, | |
1068 which may not be the one that is used for the files' contents. | |
1069 CVS/Entries should only be accessed through this function." | |
1070 (let ((coding-system-for-read (or file-name-coding-system | |
1071 default-file-name-coding-system))) | |
1072 (vc-insert-file (expand-file-name "CVS/Entries" dir)))) | |
1073 | |
1074 (defun vc-cvs-valid-symbolic-tag-name-p (tag) | |
1075 "Return non-nil if TAG is a valid symbolic tag name." | |
1076 ;; According to the CVS manual, a valid symbolic tag must start with | |
1077 ;; an uppercase or lowercase letter and can contain uppercase and | |
1078 ;; lowercase letters, digits, `-', and `_'. | |
1079 (and (string-match "^[a-zA-Z]" tag) | |
1080 (not (string-match "[^a-z0-9A-Z-_]" tag)))) | |
1081 | |
1082 (defun vc-cvs-valid-revision-number-p (tag) | |
1083 "Return non-nil if TAG is a valid revision number." | |
1084 (and (string-match "^[0-9]" tag) | |
1085 (not (string-match "[^0-9.]" tag)))) | |
1086 | |
1087 (defun vc-cvs-parse-sticky-tag (match-type match-tag) | |
1088 "Parse and return the sticky tag as a string. | |
1089 `match-data' is protected." | |
1090 (let ((data (match-data)) | |
1091 (tag) | |
1092 (type (cond ((string= match-type "D") 'date) | |
1093 ((string= match-type "T") | |
1094 (if (vc-cvs-valid-symbolic-tag-name-p match-tag) | |
1095 'symbolic-name | |
1096 'revision-number)) | |
1097 (t nil)))) | |
1098 (unwind-protect | |
1099 (progn | |
1100 (cond | |
1101 ;; Sticky Date tag. Convert to a proper date value (`encode-time') | |
1102 ((eq type 'date) | |
1103 (string-match | |
1104 "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)" | |
1105 match-tag) | |
1106 (let* ((year-tmp (string-to-number (match-string 1 match-tag))) | |
1107 (month (string-to-number (match-string 2 match-tag))) | |
1108 (day (string-to-number (match-string 3 match-tag))) | |
1109 (hour (string-to-number (match-string 4 match-tag))) | |
1110 (min (string-to-number (match-string 5 match-tag))) | |
1111 (sec (string-to-number (match-string 6 match-tag))) | |
1112 ;; Years 0..68 are 2000..2068. | |
1113 ;; Years 69..99 are 1969..1999. | |
1114 (year (+ (cond ((> 69 year-tmp) 2000) | |
1115 ((> 100 year-tmp) 1900) | |
1116 (t 0)) | |
1117 year-tmp))) | |
1118 (setq tag (encode-time sec min hour day month year)))) | |
1119 ;; Sticky Tag name or revision number | |
1120 ((eq type 'symbolic-name) (setq tag match-tag)) | |
1121 ((eq type 'revision-number) (setq tag match-tag)) | |
1122 ;; Default is no sticky tag at all | |
1123 (t nil)) | |
1124 (cond ((eq vc-cvs-sticky-tag-display nil) nil) | |
1125 ((eq vc-cvs-sticky-tag-display t) | |
1126 (cond ((eq type 'date) (format-time-string | |
1127 vc-cvs-sticky-date-format-string | |
1128 tag)) | |
1129 ((eq type 'symbolic-name) tag) | |
1130 ((eq type 'revision-number) tag) | |
1131 (t nil))) | |
1132 ((functionp vc-cvs-sticky-tag-display) | |
1133 (funcall vc-cvs-sticky-tag-display tag type)) | |
1134 (t nil))) | |
1135 | |
1136 (set-match-data data)))) | |
1137 | |
1138 (defun vc-cvs-parse-entry (file &optional set-state) | |
1139 "Parse a line from CVS/Entries. | |
1140 Compare modification time to that of the FILE, set file properties | |
1141 accordingly. However, `vc-state' is set only if optional arg SET-STATE | |
1142 is non-nil." | |
1143 (cond | |
1144 ;; entry for a "locally added" file (not yet committed) | |
1145 ((looking-at "/[^/]+/0/") | |
1146 (vc-file-setprop file 'vc-checkout-time 0) | |
1147 (vc-file-setprop file 'vc-working-revision "0") | |
1148 (if set-state (vc-file-setprop file 'vc-state 'added))) | |
1149 ;; normal entry | |
1150 ((looking-at | |
1151 (concat "/[^/]+" | |
1152 ;; revision | |
1153 "/\\([^/]*\\)" | |
1154 ;; timestamp and optional conflict field | |
1155 "/\\([^/]*\\)/" | |
1156 ;; options | |
1157 "\\([^/]*\\)/" | |
1158 ;; sticky tag | |
1159 "\\(.\\|\\)" ;Sticky tag type (date or tag name, could be empty) | |
1160 "\\(.*\\)")) ;Sticky tag | |
1161 (vc-file-setprop file 'vc-working-revision (match-string 1)) | |
1162 (vc-file-setprop file 'vc-cvs-sticky-tag | |
1163 (vc-cvs-parse-sticky-tag (match-string 4) | |
1164 (match-string 5))) | |
1165 ;; Compare checkout time and modification time. | |
1166 ;; This is intentionally different from the algorithm that CVS uses | |
1167 ;; (which is based on textual comparison), because there can be problems | |
1168 ;; generating a time string that looks exactly like the one from CVS. | |
1169 (let* ((time (match-string 2)) | |
1170 (mtime (nth 5 (file-attributes file))) | |
1171 (parsed-time (progn (require 'parse-time) | |
1172 (parse-time-string (concat time " +0000"))))) | |
1173 (cond ((and (not (string-match "\\+" time)) | |
1174 (car parsed-time) | |
1175 (equal mtime (apply 'encode-time parsed-time))) | |
1176 (vc-file-setprop file 'vc-checkout-time mtime) | |
1177 (if set-state (vc-file-setprop file 'vc-state 'up-to-date))) | |
1178 (t | |
1179 (vc-file-setprop file 'vc-checkout-time 0) | |
1180 (if set-state (vc-file-setprop file 'vc-state 'edited)))))))) | |
1181 | |
1182 ;; Completion of revision names. | |
1183 ;; Just so I don't feel like I'm duplicating code from pcl-cvs, I'll use | |
1184 ;; `cvs log' so I can list all the revision numbers rather than only | |
1185 ;; tag names. | |
1186 | |
1187 (defun vc-cvs-revision-table (file) | |
1188 (let (process-file-side-effects | |
1189 (default-directory (file-name-directory file)) | |
1190 (res nil)) | |
1191 (with-temp-buffer | |
1192 (vc-cvs-command t nil file "log") | |
1193 (goto-char (point-min)) | |
1194 (when (re-search-forward "^symbolic names:\n" nil t) | |
1195 (while (looking-at "^ \\(.*\\): \\(.*\\)") | |
1196 (push (cons (match-string 1) (match-string 2)) res) | |
1197 (forward-line 1))) | |
1198 (while (re-search-forward "^revision \\([0-9.]+\\)" nil t) | |
1199 (push (match-string 1) res)) | |
1200 res))) | |
1201 | |
1202 (defun vc-cvs-revision-completion-table (files) | |
1203 (lexical-let ((files files) | |
1204 table) | |
1205 (setq table (lazy-completion-table | |
1206 table (lambda () (vc-cvs-revision-table (car files))))) | |
1207 table)) | |
1208 | |
1209 | |
1210 (provide 'vc-cvs) | |
1211 | |
1212 ;; arch-tag: 60e1402a-aa53-4607-927a-cf74f144b432 | |
1213 ;;; vc-cvs.el ends here |