Merge from trunk.
[emacs.git] / lisp / vc / pcvs.el
blob4bc3eaf8c2c0b6ee7190245bc2ee3e522dea1ff3
1 ;;; pcvs.el --- a front-end to CVS
3 ;; Copyright (C) 1991-2012 Free Software Foundation, Inc.
5 ;; Author: (The PCL-CVS Trust) pcl-cvs@cyclic.com
6 ;; (Per Cederqvist) ceder@lysator.liu.se
7 ;; (Greg A. Woods) woods@weird.com
8 ;; (Jim Blandy) jimb@cyclic.com
9 ;; (Karl Fogel) kfogel@floss.red-bean.com
10 ;; (Jim Kingdon) kingdon@cyclic.com
11 ;; (Stefan Monnier) monnier@cs.yale.edu
12 ;; (Greg Klanderman) greg@alphatech.com
13 ;; (Jari Aalto+mail.emacs) jari.aalto@poboxes.com
14 ;; Maintainer: (Stefan Monnier) monnier@gnu.org
15 ;; Keywords: CVS, vc, release management
17 ;; This file is part of GNU Emacs.
19 ;; GNU Emacs is free software: you can redistribute it and/or modify
20 ;; it under the terms of the GNU General Public License as published by
21 ;; the Free Software Foundation, either version 3 of the License, or
22 ;; (at your option) any later version.
24 ;; GNU Emacs is distributed in the hope that it will be useful,
25 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
26 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
27 ;; GNU General Public License for more details.
29 ;; You should have received a copy of the GNU General Public License
30 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
32 ;;; Commentary:
34 ;; PCL-CVS is a front-end to the CVS version control system.
35 ;; It presents the status of all the files in your working area and
36 ;; allows you to commit/update several of them at a time.
37 ;; Compare with the general Emacs utility vc-dir, which tries
38 ;; to be VCS-agnostic. You may find PCL-CVS better/faster for CVS.
40 ;; PCL-CVS was originally written by Per Cederqvist many years ago. This
41 ;; version derives from the XEmacs-21 version, itself based on the 2.0b2
42 ;; version (last release from Per). It is a thorough rework.
44 ;; PCL-CVS is not a replacement for VC, but adds extra functionality.
45 ;; As such, I've tried to make PCL-CVS and VC interoperate seamlessly
46 ;; (I also use VC).
48 ;; To use PCL-CVS just use `M-x cvs-examine RET <dir> RET'.
49 ;; There is a TeXinfo manual, which can be helpful to get started.
51 ;;; Bugs:
53 ;; - Extracting an old version seems not to recognize encoding correctly.
54 ;; That's probably because it's done via a process rather than a file.
56 ;;; Todo:
58 ;; ******** FIX THE DOCUMENTATION *********
60 ;; - rework the displaying of error messages.
61 ;; - allow to flush messages only
62 ;; - allow to protect files like ChangeLog from flushing
63 ;; - query the user for cvs-get-marked (for some cmds or if nothing's selected)
64 ;; - don't return the first (resp last) FI if the cursor is before
65 ;; (resp after) it.
66 ;; - allow cvs-confirm-removals to force always confirmation.
67 ;; - cvs-checkout should ask for a revision (with completion).
68 ;; - removal confirmation should allow specifying another file name.
70 ;; - hide fileinfos without getting rid of them (will require ewok work).
71 ;; - add toolbar entries
72 ;; - marking
73 ;; marking directories should jump to just after the dir.
74 ;; allow (un)marking directories at a time with the mouse.
75 ;; allow cvs-cmd-do to either clear the marks or not.
76 ;; add a "marks active" notion, like transient-mark-mode does.
77 ;; - liveness indicator
78 ;; - indicate in docstring if the cmd understands the `b' prefix(es).
79 ;; - call smerge-mode when opening CONFLICT files.
80 ;; - have vc-checkin delegate to cvs-mode-commit when applicable
81 ;; - higher-level CVS operations
82 ;; cvs-mode-rename
83 ;; cvs-mode-branch
84 ;; - module-level commands
85 ;; add support for parsing 'modules' file ("cvs co -c")
86 ;; cvs-mode-rcs2log
87 ;; cvs-rdiff
88 ;; cvs-release
89 ;; cvs-import
90 ;; C-u M-x cvs-checkout should ask for a cvsroot
91 ;; cvs-mode-handle-new-vendor-version
92 ;; - checks out module, or alternately does update join
93 ;; - does "cvs -n tag LAST_VENDOR" to find old files into *cvs*
94 ;; cvs-export
95 ;; (with completion on tag names and hooks to help generate full releases)
96 ;; - display stickiness information. And current CVS/Tag as well.
97 ;; - write 'cvs-mode-admin' to do arbitrary 'cvs admin' commands
98 ;; Most interesting would be version removal and log message replacement.
99 ;; The last one would be neat when called from log-view-mode.
100 ;; - cvs-mode-incorporate
101 ;; It would merge in the status from one *cvs* buffer into another.
102 ;; This would be used to populate such a buffer that had been created with
103 ;; a `cvs {update,status,checkout} -l'.
104 ;; - cvs-mode-(i)diff-other-{file,buffer,cvs-buffer}
105 ;; - offer the choice to kill the process when the user kills the cvs buffer.
106 ;; right now, it's killed without further ado.
107 ;; - make `cvs-mode-ignore' allow manually entering a pattern.
108 ;; to which dir should it apply ?
109 ;; - cvs-mode-ignore should try to remove duplicate entries.
110 ;; - maybe poll/check CVS/Entries files to react to external `cvs' commands ?
111 ;; - some kind of `cvs annotate' support ?
112 ;; but vc-annotate can be used instead.
113 ;; - proper `g' that passes safe args and uses either cvs-status or cvs-examine
114 ;; maybe also use cvs-update depending on I-don't-know-what.
115 ;; - add message-levels so that we can hide some levels of messages
117 ;;; Code:
119 (eval-when-compile (require 'cl-lib))
120 (require 'ewoc) ;Ewoc was once cookie
121 (require 'pcvs-defs)
122 (require 'pcvs-util)
123 (require 'pcvs-parse)
124 (require 'pcvs-info)
127 ;;;;
128 ;;;; global vars
129 ;;;;
131 (defvar cvs-cookies) ;;nil
132 ;;"Handle for the cookie structure that is displayed in the *cvs* buffer.")
133 ;;(make-variable-buffer-local 'cvs-cookies)
135 ;;;;
136 ;;;; Dynamically scoped variables
137 ;;;;
139 (defvar cvs-from-vc nil "Bound to t inside VC advice.")
141 ;;;;
142 ;;;; flags variables
143 ;;;;
145 (defun cvs-defaults (&rest defs)
146 (let ((defs (cvs-first defs cvs-shared-start)))
147 (append defs
148 (make-list (- cvs-shared-start (length defs)) (car defs))
149 cvs-shared-flags)))
151 ;; For cvs flags, we need to add "-f" to override the cvsrc settings
152 ;; we also want to evict the annoying -q and -Q options that hide useful
153 ;; information from pcl-cvs.
154 (cvs-flags-define cvs-cvs-flags '(("-f")))
156 (cvs-flags-define cvs-checkout-flags (cvs-defaults '("-P")))
157 (cvs-flags-define cvs-status-flags (cvs-defaults '("-v") nil))
158 (cvs-flags-define cvs-log-flags (cvs-defaults nil))
159 (cvs-flags-define cvs-diff-flags (cvs-defaults '("-u" "-N") '("-c" "-N") '("-u" "-b")))
160 (cvs-flags-define cvs-tag-flags (cvs-defaults nil))
161 (cvs-flags-define cvs-add-flags (cvs-defaults nil))
162 (cvs-flags-define cvs-commit-flags (cvs-defaults nil))
163 (cvs-flags-define cvs-remove-flags (cvs-defaults nil))
164 ;;(cvs-flags-define cvs-undo-flags (cvs-defaults nil))
165 (cvs-flags-define cvs-update-flags (cvs-defaults '("-d" "-P")))
167 (defun cvs-reread-cvsrc ()
168 "Reset the default arguments to those in the `cvs-cvsrc-file'."
169 (interactive)
170 (condition-case nil
171 (with-temp-buffer
172 (insert-file-contents cvs-cvsrc-file)
173 ;; fetch the values
174 (dolist (cmd '("cvs" "checkout" "status" "log" "diff" "tag"
175 "add" "commit" "remove" "update"))
176 (goto-char (point-min))
177 (when (re-search-forward
178 (concat "^" cmd "\\(\\s-+\\(.*\\)\\)?$") nil t)
179 (let* ((sym (intern (concat "cvs-" cmd "-flags")))
180 (val (split-string-and-unquote (or (match-string 2) ""))))
181 (cvs-flags-set sym 0 val))))
182 ;; ensure that cvs doesn't have -q or -Q
183 (cvs-flags-set 'cvs-cvs-flags 0
184 (cons "-f"
185 (cdr (cvs-partition
186 (lambda (x) (member x '("-q" "-Q" "-f")))
187 (cvs-flags-query 'cvs-cvs-flags
188 nil 'noquery))))))
189 (file-error nil)))
191 ;; initialize to cvsrc's default values
192 (cvs-reread-cvsrc)
195 ;;;;
196 ;;;; Mouse bindings and mode motion
197 ;;;;
199 (defvar cvs-minor-current-files)
201 (defun cvs-menu (e)
202 "Popup the CVS menu."
203 (interactive "e")
204 (let ((cvs-minor-current-files
205 (list (ewoc-data (ewoc-locate
206 cvs-cookies (posn-point (event-end e)))))))
207 (popup-menu cvs-menu e)))
209 (defvar cvs-mode-line-process nil
210 "Mode-line control for displaying info on cvs process status.")
213 ;;;;
214 ;;;; Query-Type-Descriptor for Tags
215 ;;;;
217 (autoload 'cvs-status-get-tags "cvs-status")
218 (defun cvs-tags-list ()
219 "Return a list of acceptable tags, ready for completions."
220 (cl-assert (cvs-buffer-p))
221 (let ((marked (cvs-get-marked)))
222 `(("BASE") ("HEAD")
223 ,@(when marked
224 (with-temp-buffer
225 (process-file cvs-program
226 nil ;no input
227 t ;output to current-buffer
228 nil ;don't update display while running
229 "status"
230 "-v"
231 (cvs-fileinfo->full-name (car marked)))
232 (goto-char (point-min))
233 (let ((tags (cvs-status-get-tags)))
234 (when (listp tags) tags)))))))
236 (defvar cvs-tag-history nil)
237 (defconst cvs-qtypedesc-tag
238 (cvs-qtypedesc-create 'identity 'identity 'cvs-tags-list 'cvs-tag-history))
240 ;;;;
242 (defun cvs-mode! (&optional -cvs-mode!-fun)
243 "Switch to the *cvs* buffer.
244 If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer
245 and with its window selected. Else, the *cvs* buffer is simply selected.
246 -CVS-MODE!-FUN is called interactively if applicable and else with no argument."
247 (let* ((-cvs-mode!-buf (current-buffer))
248 (cvsbuf (cond ((cvs-buffer-p) (current-buffer))
249 ((and cvs-buffer (cvs-buffer-p cvs-buffer)) cvs-buffer)
250 (t (error "can't find the *cvs* buffer"))))
251 (-cvs-mode!-wrapper cvs-minor-wrap-function)
252 (-cvs-mode!-cont (lambda ()
253 (save-current-buffer
254 (if (commandp -cvs-mode!-fun)
255 (call-interactively -cvs-mode!-fun)
256 (funcall -cvs-mode!-fun))))))
257 (if (not -cvs-mode!-fun) (set-buffer cvsbuf)
258 (let ((cvs-mode!-buf (current-buffer))
259 (cvs-mode!-owin (selected-window))
260 (cvs-mode!-nwin (get-buffer-window cvsbuf 'visible)))
261 (unwind-protect
262 (progn
263 (set-buffer cvsbuf)
264 (when cvs-mode!-nwin (select-window cvs-mode!-nwin))
265 (if -cvs-mode!-wrapper
266 (funcall -cvs-mode!-wrapper -cvs-mode!-buf -cvs-mode!-cont)
267 (funcall -cvs-mode!-cont)))
268 (set-buffer cvs-mode!-buf)
269 (when (and cvs-mode!-nwin (eq cvs-mode!-nwin (selected-window)))
270 ;; the selected window has not been changed by FUN
271 (select-window cvs-mode!-owin)))))))
273 ;;;;
274 ;;;; Prefixes
275 ;;;;
277 (defvar cvs-branches (list cvs-vendor-branch "HEAD" "HEAD"))
278 (cvs-prefix-define cvs-branch-prefix
279 "Current selected branch."
280 "version"
281 (cons cvs-vendor-branch cvs-branches)
282 cvs-qtypedesc-tag)
284 (defun cvs-set-branch-prefix (arg)
285 "Set the branch prefix to take action at the next command.
286 See `cvs-prefix-set' for a further the description of the behavior.
287 \\[universal-argument] 1 selects the vendor branch
288 and \\[universal-argument] 2 selects the HEAD."
289 (interactive "P")
290 (cvs-mode!)
291 (cvs-prefix-set 'cvs-branch-prefix arg))
293 (defun cvs-add-branch-prefix (flags &optional arg)
294 "Add branch selection argument if the branch prefix was set.
295 The argument is added (or not) to the list of FLAGS and is constructed
296 by appending the branch to ARG which defaults to \"-r\"."
297 (let ((branch (cvs-prefix-get 'cvs-branch-prefix)))
298 ;; deactivate the secondary prefix, even if not used.
299 (cvs-prefix-get 'cvs-secondary-branch-prefix)
300 (if branch (cons (concat (or arg "-r") branch) flags) flags)))
302 (cvs-prefix-define cvs-secondary-branch-prefix
303 "Current secondary selected branch."
304 "version"
305 (cons cvs-vendor-branch cvs-branches)
306 cvs-qtypedesc-tag)
308 (defun cvs-set-secondary-branch-prefix (arg)
309 "Set the branch prefix to take action at the next command.
310 See `cvs-prefix-set' for a further the description of the behavior.
311 \\[universal-argument] 1 selects the vendor branch
312 and \\[universal-argument] 2 selects the HEAD."
313 (interactive "P")
314 (cvs-mode!)
315 (cvs-prefix-set 'cvs-secondary-branch-prefix arg))
317 (defun cvs-add-secondary-branch-prefix (flags &optional arg)
318 "Add branch selection argument if the secondary branch prefix was set.
319 The argument is added (or not) to the list of FLAGS and is constructed
320 by appending the branch to ARG which defaults to \"-r\".
321 Since the `cvs-secondary-branch-prefix' is only active if the primary
322 prefix is active, it is important to read the secondary prefix before
323 the primary since reading the primary can deactivate it."
324 (let ((branch (and (cvs-prefix-get 'cvs-branch-prefix 'read-only)
325 (cvs-prefix-get 'cvs-secondary-branch-prefix))))
326 (if branch (cons (concat (or arg "-r") branch) flags) flags)))
328 ;;;;
330 (define-minor-mode cvs-minor-mode
331 "This mode is used for buffers related to a main *cvs* buffer.
332 All the `cvs-mode' buffer operations are simply rebound under
333 the \\[cvs-mode-map] prefix."
334 nil " CVS"
335 :group 'pcl-cvs)
336 (put 'cvs-minor-mode 'permanent-local t)
339 (defvar cvs-temp-buffers nil)
340 (defun cvs-temp-buffer (&optional cmd normal nosetup)
341 "Create a temporary buffer to run CMD in.
342 If CMD is a string, use it to lookup `cvs-buffer-name-alist' to find
343 the buffer name to be used and its `major-mode'.
345 The selected window will not be changed. The new buffer will not maintain undo
346 information and will be read-only unless NORMAL is non-nil. It will be emptied
347 \(unless NOSETUP is non-nil\) and its `default-directory' will be inherited
348 from the current buffer."
349 (let* ((cvs-buf (current-buffer))
350 (info (cdr (assoc cmd cvs-buffer-name-alist)))
351 (name (eval (nth 0 info)))
352 (mode (nth 1 info))
353 (dir default-directory)
354 (buf (cond
355 (name (cvs-get-buffer-create name))
356 ((and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer))
357 cvs-temp-buffer)
359 (set (make-local-variable 'cvs-temp-buffer)
360 (cvs-get-buffer-create
361 (eval cvs-temp-buffer-name) 'noreuse))))))
363 ;; handle the potential pre-existing process
364 (let ((proc (get-buffer-process buf)))
365 (when (and (not normal) (processp proc)
366 (memq (process-status proc) '(run stop)))
367 (if cmd
368 ;; When CMD is specified, the buffer is normally shown to the
369 ;; user, so interrupting the process is not harmful.
370 ;; Use `delete-process' rather than `kill-process' otherwise
371 ;; the pending output of the process will still get inserted
372 ;; after we erase the buffer.
373 (delete-process proc)
374 (error "Can not run two cvs processes simultaneously"))))
376 (if (not name) (kill-local-variable 'other-window-scroll-buffer)
377 ;; Strangely, if no window is created, `display-buffer' ends up
378 ;; doing a `switch-to-buffer' which does a `set-buffer', hence
379 ;; the need for `save-excursion'.
380 (unless nosetup (save-excursion (display-buffer buf)))
381 ;; FIXME: this doesn't do the right thing if the user later on
382 ;; does a `find-file-other-window' and `scroll-other-window'
383 (set (make-local-variable 'other-window-scroll-buffer) buf))
385 (add-to-list 'cvs-temp-buffers buf)
387 (with-current-buffer buf
388 (setq buffer-read-only nil)
389 (setq default-directory dir)
390 (unless nosetup
391 ;; Disable undo before calling erase-buffer since it may generate
392 ;; a very large and unwanted undo record.
393 (buffer-disable-undo)
394 (erase-buffer))
395 (set (make-local-variable 'cvs-buffer) cvs-buf)
396 ;;(cvs-minor-mode 1)
397 (let ((lbd list-buffers-directory))
398 (if (fboundp mode) (funcall mode) (fundamental-mode))
399 (when lbd (setq list-buffers-directory lbd)))
400 (cvs-minor-mode 1)
401 ;;(set (make-local-variable 'cvs-buffer) cvs-buf)
402 (if normal
403 (buffer-enable-undo)
404 (setq buffer-read-only t)
405 (buffer-disable-undo))
406 buf)))
408 (defun cvs-mode-kill-buffers ()
409 "Kill all the \"temporary\" buffers created by the *cvs* buffer."
410 (interactive)
411 (dolist (buf cvs-temp-buffers) (ignore-errors (kill-buffer buf))))
413 (defun cvs-make-cvs-buffer (dir &optional new)
414 "Create the *cvs* buffer for directory DIR.
415 If non-nil, NEW means to create a new buffer no matter what."
416 ;; the real cvs-buffer creation
417 (setq dir (cvs-expand-dir-name dir))
418 (let* ((buffer-name (eval cvs-buffer-name))
419 (buffer
420 (or (and (not new)
421 (eq cvs-reuse-cvs-buffer 'current)
422 (cvs-buffer-p) ;reuse the current buffer if possible
423 (current-buffer))
424 ;; look for another cvs buffer visiting the same directory
425 (save-excursion
426 (unless new
427 (cl-dolist (buffer (cons (current-buffer) (buffer-list)))
428 (set-buffer buffer)
429 (and (cvs-buffer-p)
430 (pcase cvs-reuse-cvs-buffer
431 (`always t)
432 (`subdir
433 (or (string-prefix-p default-directory dir)
434 (string-prefix-p dir default-directory)))
435 (`samedir (string= default-directory dir)))
436 (cl-return buffer)))))
437 ;; we really have to create a new buffer:
438 ;; we temporarily bind cwd to "" to prevent
439 ;; create-file-buffer from using directory info
440 ;; unless it is explicitly in the cvs-buffer-name.
441 (cvs-get-buffer-create buffer-name new))))
442 (with-current-buffer buffer
444 (and (string= dir default-directory) (cvs-buffer-p)
445 ;; just a refresh
446 (ignore-errors
447 (cvs-cleanup-collection cvs-cookies nil nil t)
448 (current-buffer)))
449 ;; setup from scratch
450 (progn
451 (setq default-directory dir)
452 (setq buffer-read-only nil)
453 (erase-buffer)
454 (insert "Repository : " (directory-file-name (cvs-get-cvsroot))
455 "\nModule : " (cvs-get-module)
456 "\nWorking dir: " (abbreviate-file-name dir)
457 (if (not (file-readable-p "CVS/Tag")) "\n"
458 (let ((tag (cvs-file-to-string "CVS/Tag")))
459 (cond
460 ((string-match "\\`T" tag)
461 (concat "\nTag : " (substring tag 1)))
462 ((string-match "\\`D" tag)
463 (concat "\nDate : " (substring tag 1)))
464 ("\n"))))
465 "\n")
466 (setq buffer-read-only t)
467 (cvs-mode)
468 (set (make-local-variable 'list-buffers-directory) buffer-name)
469 ;;(set (make-local-variable 'cvs-temp-buffer) (cvs-temp-buffer))
470 (let ((cookies (ewoc-create 'cvs-fileinfo-pp "\n\n" "\n" t)))
471 (set (make-local-variable 'cvs-cookies) cookies)
472 (add-hook 'kill-buffer-hook
473 (lambda ()
474 (ignore-errors (kill-buffer cvs-temp-buffer)))
475 nil t)
476 ;;(set-buffer buf)
477 buffer))))))
479 (cl-defun cvs-cmd-do (cmd dir flags fis new
480 &key cvsargs noexist dont-change-disc noshow)
481 (let* ((dir (file-name-as-directory
482 (abbreviate-file-name (expand-file-name dir))))
483 (cvsbuf (cvs-make-cvs-buffer dir new)))
484 ;; Check that dir is under CVS control.
485 (unless (file-directory-p dir)
486 (error "%s is not a directory" dir))
487 (unless (or noexist (file-directory-p (expand-file-name "CVS" dir))
488 (file-expand-wildcards (expand-file-name "*/CVS" dir)))
489 (error "%s does not contain CVS controlled files" dir))
491 (set-buffer cvsbuf)
492 (cvs-mode-run cmd flags fis
493 :cvsargs cvsargs :dont-change-disc dont-change-disc)
495 (if noshow cvsbuf
496 (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf)))))
497 ;; (funcall (if (and (boundp 'pop-up-frames) pop-up-frames)
498 ;; 'pop-to-buffer 'switch-to-buffer)
499 ;; cvsbuf))))
501 (defun cvs-run-process (args fis postprocess &optional single-dir)
502 (cl-assert (cvs-buffer-p cvs-buffer))
503 (save-current-buffer
504 (let ((procbuf (current-buffer))
505 (cvsbuf cvs-buffer)
506 (single-dir (or single-dir (eq cvs-execute-single-dir t))))
508 (set-buffer procbuf)
509 (goto-char (point-max))
510 (unless (bolp) (let ((inhibit-read-only t)) (insert "\n")))
511 ;; find the set of files we'll process in this round
512 (let* ((dir+files+rest
513 (if (or (null fis) (not single-dir))
514 ;; not single-dir mode: just process the whole thing
515 (list "" (mapcar 'cvs-fileinfo->full-name fis) nil)
516 ;; single-dir mode: extract the same-dir-elements
517 (let ((dir (cvs-fileinfo->dir (car fis))))
518 ;; output the concerned dir so the parser can translate paths
519 (let ((inhibit-read-only t))
520 (insert "pcl-cvs: descending directory " dir "\n"))
521 ;; loop to find the same-dir-elems
522 (cl-do* ((files () (cons (cvs-fileinfo->file fi) files))
523 (fis fis (cdr fis))
524 (fi (car fis) (car fis)))
525 ((not (and fis (string= dir (cvs-fileinfo->dir fi))))
526 (list dir files fis))))))
527 (dir (nth 0 dir+files+rest))
528 (files (nth 1 dir+files+rest))
529 (rest (nth 2 dir+files+rest)))
531 (add-hook 'kill-buffer-hook
532 (lambda ()
533 (let ((proc (get-buffer-process (current-buffer))))
534 (when (processp proc)
535 (set-process-filter proc nil)
536 ;; Abort postprocessing but leave the sentinel so it
537 ;; will update the list of running procs.
538 (process-put proc 'cvs-postprocess nil)
539 (interrupt-process proc))))
540 nil t)
542 ;; create the new process and setup the procbuffer correspondingly
543 (let* ((msg (cvs-header-msg args fis))
544 (args (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery)
545 (if cvs-cvsroot (list "-d" cvs-cvsroot))
546 args
547 files))
548 ;; If process-connection-type is nil and the repository
549 ;; is accessed via SSH, a bad interaction between libc,
550 ;; CVS and SSH can lead to garbled output.
551 ;; It might be a glibc-specific problem (but it can also happens
552 ;; under Mac OS X, it seems).
553 ;; It seems that using a pty can help circumvent the problem,
554 ;; but at the cost of screwing up when the process thinks it
555 ;; can ask for user input (such as password or host-key
556 ;; confirmation). A better workaround is to set CVS_RSH to
557 ;; an appropriate script, or to use a later version of CVS.
558 (process-connection-type nil) ; Use a pipe, not a pty.
559 (process
560 ;; the process will be run in the selected dir
561 (let ((default-directory (cvs-expand-dir-name dir)))
562 (apply 'start-file-process "cvs" procbuf cvs-program args))))
563 ;; setup the process.
564 (process-put process 'cvs-buffer cvs-buffer)
565 (with-current-buffer cvs-buffer (cvs-update-header msg 'add))
566 (process-put process 'cvs-header msg)
567 (process-put
568 process 'cvs-postprocess
569 (if (null rest)
570 ;; this is the last invocation
571 postprocess
572 ;; else, we have to register ourselves to be rerun on the rest
573 `(cvs-run-process ',args ',rest ',postprocess ',single-dir)))
574 (set-process-sentinel process 'cvs-sentinel)
575 (set-process-filter process 'cvs-update-filter)
576 (set-marker (process-mark process) (point-max))
577 (ignore-errors (process-send-eof process)) ;close its stdin to avoid hangs
579 ;; now finish setting up the cvs-buffer
580 (set-buffer cvsbuf)
581 (setq cvs-mode-line-process (symbol-name (process-status process)))
582 (force-mode-line-update)))))
584 ;; The following line is said to improve display updates on some
585 ;; emacsen. It shouldn't be needed, but it does no harm.
586 (sit-for 0))
588 (defun cvs-header-msg (args fis)
589 (let* ((lastarg nil)
590 (args (mapcar (lambda (arg)
591 (cond
592 ;; filter out the largish commit message
593 ((and (eq lastarg nil) (string= arg "commit"))
594 (setq lastarg 'commit) arg)
595 ((and (eq lastarg 'commit) (string= arg "-m"))
596 (setq lastarg '-m) arg)
597 ((eq lastarg '-m)
598 (setq lastarg 'done) "<log message>")
599 ;; filter out the largish `admin -mrev:msg' message
600 ((and (eq lastarg nil) (string= arg "admin"))
601 (setq lastarg 'admin) arg)
602 ((and (eq lastarg 'admin)
603 (string-match "\\`-m[^:]*:" arg))
604 (setq lastarg 'done)
605 (concat (match-string 0 arg) "<log message>"))
606 ;; Keep the rest as is.
607 (t arg)))
608 args)))
609 (concat cvs-program " "
610 (combine-and-quote-strings
611 (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery)
612 (if cvs-cvsroot (list "-d" cvs-cvsroot))
613 args
614 (mapcar 'cvs-fileinfo->full-name fis))))))
616 (defun cvs-update-header (cmd add)
617 (let* ((hf (ewoc-get-hf cvs-cookies))
618 (str (car hf))
619 (done "")
620 (tin (ewoc-nth cvs-cookies 0)))
621 ;; look for the first *real* fileinfo (to determine emptiness)
622 (while
623 (and tin
624 (memq (cvs-fileinfo->type (ewoc-data tin))
625 '(MESSAGE DIRCHANGE)))
626 (setq tin (ewoc-next cvs-cookies tin)))
627 (if add
628 (progn
629 ;; Remove the default empty line, if applicable.
630 (if (not (string-match "." str)) (setq str "\n"))
631 (setq str (concat "-- Running " cmd " ...\n" str)))
632 (if (not (string-match
633 ;; FIXME: If `cmd' is large, this will bump into the
634 ;; compiled-regexp size limit. We could drop the "^" anchor
635 ;; and use search-forward to circumvent the problem.
636 (concat "^-- Running " (regexp-quote cmd) " \\.\\.\\.\n") str))
637 (error "Internal PCL-CVS error while removing message")
638 (setq str (replace-match "" t t str))
639 ;; Re-add the default empty line, if applicable.
640 (if (not (string-match "." str)) (setq str "\n\n"))
641 (setq done (concat "-- last cmd: " cmd " --\n"))))
642 ;; set the new header and footer
643 (ewoc-set-hf cvs-cookies
644 str (concat "\n--------------------- "
645 (if tin "End" "Empty")
646 " ---------------------\n"
647 done))))
650 (defun cvs-sentinel (proc msg)
651 "Sentinel for the cvs update process.
652 This is responsible for parsing the output from the cvs update when
653 it is finished."
654 (when (memq (process-status proc) '(signal exit))
655 (let ((cvs-postproc (process-get proc 'cvs-postprocess))
656 (cvs-buf (process-get proc 'cvs-buffer))
657 (procbuf (process-buffer proc)))
658 (unless (buffer-live-p cvs-buf) (setq cvs-buf nil))
659 (unless (buffer-live-p procbuf) (setq procbuf nil))
660 ;; Since the buffer and mode line will show that the
661 ;; process is dead, we can delete it now. Otherwise it
662 ;; will stay around until M-x list-processes.
663 (process-put proc 'postprocess nil)
664 (delete-process proc)
665 ;; Don't do anything if the main buffer doesn't exist any more.
666 (when cvs-buf
667 (with-current-buffer cvs-buf
668 (cvs-update-header (process-get proc 'cvs-header) nil)
669 (setq cvs-mode-line-process (symbol-name (process-status proc)))
670 (force-mode-line-update)
671 (when cvs-postproc
672 (if (null procbuf)
673 ;;(set-process-buffer proc nil)
674 (error "cvs' process buffer was killed")
675 (with-current-buffer procbuf
676 ;; Do the postprocessing like parsing and such.
677 (save-excursion (eval cvs-postproc)))))))
678 ;; Check whether something is left.
679 (when (and procbuf (not (get-buffer-process procbuf)))
680 (with-current-buffer procbuf
681 ;; IIRC, we enable undo again once the process is finished
682 ;; for cases where the output was inserted in *vc-diff* or
683 ;; in a file-like buffer. --Stef
684 (buffer-enable-undo)
685 (with-current-buffer (or cvs-buf (current-buffer))
686 (message "CVS process has completed in %s"
687 (buffer-name))))))))
689 (defun cvs-parse-process (dcd &optional subdir old-fis)
690 "Parse the output of a cvs process.
691 DCD is the `dont-change-disc' flag to use when parsing that output.
692 SUBDIR is the subdirectory (if any) where this command was run.
693 OLD-FIS is the list of fileinfos on which the cvs command was applied and
694 which should be considered up-to-date if they are missing from the output."
695 (when (eq system-type 'darwin)
696 ;; Fixup the ^D^H^H inserted at beginning of buffer sometimes on MacOSX
697 ;; because of the call to `process-send-eof'.
698 (save-excursion
699 (goto-char (point-min))
700 (while (re-search-forward "^\\^D\b+" nil t)
701 (let ((inhibit-read-only t))
702 (delete-region (match-beginning 0) (match-end 0))))))
703 (let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir))
704 last)
705 (with-current-buffer cvs-buffer
706 ;; Expand OLD-FIS to actual files.
707 (let ((fis nil))
708 (dolist (fi old-fis)
709 (setq fis (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
710 (nconc (ewoc-collect cvs-cookies 'cvs-dir-member-p
711 (cvs-fileinfo->dir fi))
712 fis)
713 (cons fi fis))))
714 (setq old-fis fis))
715 ;; Drop OLD-FIS which were already up-to-date.
716 (let ((fis nil))
717 (dolist (fi old-fis)
718 (unless (eq (cvs-fileinfo->type fi) 'UP-TO-DATE) (push fi fis)))
719 (setq old-fis fis))
720 ;; Add the new fileinfos to the ewoc.
721 (dolist (fi fileinfos)
722 (setq last (cvs-addto-collection cvs-cookies fi last))
723 ;; This FI was in the output, so remove it from OLD-FIS.
724 (setq old-fis (delq (ewoc-data last) old-fis)))
725 ;; Process the "silent output" (i.e. absence means up-to-date).
726 (dolist (fi old-fis)
727 (setf (cvs-fileinfo->type fi) 'UP-TO-DATE)
728 (setq last (cvs-addto-collection cvs-cookies fi last)))
729 (setq fileinfos (nconc old-fis fileinfos))
730 ;; Clean up the ewoc as requested by the user.
731 (cvs-cleanup-collection cvs-cookies
732 (eq cvs-auto-remove-handled t)
733 cvs-auto-remove-directories
734 nil)
735 ;; Revert buffers if necessary.
736 (when (and cvs-auto-revert (not dcd) (not cvs-from-vc))
737 (cvs-revert-if-needed fileinfos)))))
739 (defmacro defun-cvs-mode (fun args docstring interact &rest body)
740 "Define a function to be used in a *cvs* buffer.
741 This will look for a *cvs* buffer and execute BODY in it.
742 Since the interactive arguments might need to be queried after
743 switching to the *cvs* buffer, the generic code is rather ugly,
744 but luckily we can often use simpler alternatives.
746 FUN can be either a symbol (i.e. STYLE is nil) or a cons (FUN . STYLE).
747 ARGS and DOCSTRING are the normal argument list.
748 INTERACT is the interactive specification or nil for non-commands.
750 STYLE can be either SIMPLE, NOARGS or DOUBLE. It's an error for it
751 to have any other value, unless other details of the function make it
752 clear what alternative to use.
753 - SIMPLE will get all the interactive arguments from the original buffer.
754 - NOARGS will get all the arguments from the *cvs* buffer and will
755 always behave as if called interactively.
756 - DOUBLE is the generic case."
757 (declare (debug (&define sexp lambda-list stringp ("interactive" interactive) def-body))
758 (doc-string 3))
759 (let ((style (cvs-cdr fun))
760 (fun (cvs-car fun)))
761 (cond
762 ;; a trivial interaction, no need to move it
763 ((or (eq style 'SIMPLE)
764 (null (nth 1 interact))
765 (stringp (nth 1 interact)))
766 `(defun ,fun ,args ,docstring ,interact
767 (cvs-mode! (lambda () ,@body))))
769 ;; fun is only called interactively: move all the args to the inner fun
770 ((eq style 'NOARGS)
771 `(defun ,fun () ,docstring (interactive)
772 (cvs-mode! (lambda ,args ,interact ,@body))))
774 ;; bad case
775 ((eq style 'DOUBLE)
776 (string-match ".*" docstring)
777 (let ((line1 (match-string 0 docstring))
778 (fun-1 (intern (concat (symbol-name fun) "-1"))))
779 `(progn
780 (defun ,fun-1 ,args
781 ,(concat docstring "\nThis function only works within a *cvs* buffer.
782 For interactive use, use `" (symbol-name fun) "' instead.")
783 ,interact
784 ,@body)
785 (put ',fun-1 'definition-name ',fun)
786 (defun ,fun ()
787 ,(concat line1 "\nWrapper function that switches to a *cvs* buffer
788 before calling the real function `" (symbol-name fun-1) "'.\n")
789 (interactive)
790 (cvs-mode! ',fun-1)))))
792 (t (error "Unknown style %s in `defun-cvs-mode'" style)))))
794 (defun-cvs-mode cvs-mode-kill-process ()
795 "Kill the temporary buffer and associated process."
796 (interactive)
797 (when (and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer))
798 (let ((proc (get-buffer-process cvs-temp-buffer)))
799 (when proc (delete-process proc)))))
802 ;; Maintaining the collection in the face of updates
805 (defun cvs-addto-collection (c fi &optional tin)
806 "Add FI to C and return FI's corresponding tin.
807 FI is inserted in its proper place or maybe even merged with a preexisting
808 fileinfo if applicable.
809 TIN specifies an optional starting point."
810 (unless tin (setq tin (ewoc-nth c 0)))
811 (while (and tin (cvs-fileinfo< fi (ewoc-data tin)))
812 (setq tin (ewoc-prev c tin)))
813 (if (null tin) (ewoc-enter-first c fi) ;empty collection
814 (cl-assert (not (cvs-fileinfo< fi (ewoc-data tin))))
815 (let ((next-tin (ewoc-next c tin)))
816 (while (not (or (null next-tin)
817 (cvs-fileinfo< fi (ewoc-data next-tin))))
818 (setq tin next-tin next-tin (ewoc-next c next-tin)))
819 (if (or (cvs-fileinfo< (ewoc-data tin) fi)
820 (eq (cvs-fileinfo->type fi) 'MESSAGE))
821 ;; tin < fi < next-tin
822 (ewoc-enter-after c tin fi)
823 ;; fi == tin
824 (cvs-fileinfo-update (ewoc-data tin) fi)
825 (ewoc-invalidate c tin)
826 ;; Move cursor back to where it belongs.
827 (when (bolp) (cvs-move-to-goal-column))
828 tin))))
830 (defcustom cvs-cleanup-functions nil
831 "Functions to tweak the cleanup process.
832 The functions are called with a single argument (a FILEINFO) and should
833 return a non-nil value if that fileinfo should be removed."
834 :group 'pcl-cvs
835 :type '(hook :options (cvs-cleanup-removed)))
837 (defun cvs-cleanup-removed (fi)
838 "Non-nil if FI has been cvs-removed but still exists.
839 This is intended for use on `cvs-cleanup-functions' when you have cvs-removed
840 automatically generated files (which should hence not be under CVS control)
841 but can't commit the removal because the repository's owner doesn't understand
842 the problem."
843 (and (or (eq (cvs-fileinfo->type fi) 'REMOVED)
844 (and (eq (cvs-fileinfo->type fi) 'CONFLICT)
845 (eq (cvs-fileinfo->subtype fi) 'REMOVED)))
846 (file-exists-p (cvs-fileinfo->full-name fi))))
848 ;; called at the following times:
849 ;; - postparse ((eq cvs-auto-remove-handled t) cvs-auto-remove-directories nil)
850 ;; - pre-run ((eq cvs-auto-remove-handled 'delayed) nil t)
851 ;; - remove-handled (t (or cvs-auto-remove-directories 'handled) t)
852 ;; - cvs-cmd-do (nil nil t)
853 ;; - post-ignore (nil nil nil)
854 ;; - acknowledge (nil nil nil)
855 ;; - remove (nil nil nil)
856 (defun cvs-cleanup-collection (c rm-handled rm-dirs rm-msgs)
857 "Remove undesired entries.
858 C is the collection
859 RM-HANDLED if non-nil means remove handled entries.
860 RM-DIRS behaves like `cvs-auto-remove-directories'.
861 RM-MSGS if non-nil means remove messages."
862 (let (last-fi first-dir (rerun t))
863 (while rerun
864 (setq rerun nil)
865 (setq first-dir t)
866 (setq last-fi (cvs-create-fileinfo 'DEAD "../" "" "")) ;place-holder
867 (ewoc-filter
868 c (lambda (fi)
869 (let* ((type (cvs-fileinfo->type fi))
870 (subtype (cvs-fileinfo->subtype fi))
871 (keep
872 (pcase type
873 ;; remove temp messages and keep the others
874 (`MESSAGE (not (or rm-msgs (eq subtype 'TEMP))))
875 ;; remove entries
876 (`DEAD nil)
877 ;; handled also?
878 (`UP-TO-DATE
879 (if (find-buffer-visiting (cvs-fileinfo->full-name fi))
881 (not rm-handled)))
882 ;; keep the rest
883 (_ (not (run-hook-with-args-until-success
884 'cvs-cleanup-functions fi))))))
886 ;; mark dirs for removal
887 (when (and keep rm-dirs
888 (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE)
889 (not (when first-dir (setq first-dir nil) t))
890 (or (eq rm-dirs 'all)
891 (not (string-prefix-p
892 (cvs-fileinfo->dir last-fi)
893 (cvs-fileinfo->dir fi)))
894 (and (eq type 'DIRCHANGE) (eq rm-dirs 'empty))
895 (eq subtype 'FOOTER)))
896 (setf (cvs-fileinfo->type last-fi) 'DEAD)
897 (setq rerun t))
898 (when keep (setq last-fi fi)))))
899 ;; remove empty last dir
900 (when (and rm-dirs
901 (not first-dir)
902 (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE))
903 (setf (cvs-fileinfo->type last-fi) 'DEAD)
904 (setq rerun t)))))
906 (defun cvs-get-cvsroot ()
907 "Gets the CVSROOT for DIR."
908 (let ((cvs-cvsroot-file (expand-file-name "Root" "CVS")))
909 (or (cvs-file-to-string cvs-cvsroot-file t)
910 cvs-cvsroot
911 (getenv "CVSROOT")
912 "?????")))
914 (defun cvs-get-module ()
915 "Return the current CVS module.
916 This usually doesn't really work but is a handy initval in a prompt."
917 (let* ((repfile (expand-file-name "Repository" "CVS"))
918 (rep (cvs-file-to-string repfile t)))
919 (cond
920 ((null rep) "")
921 ((not (file-name-absolute-p rep)) rep)
923 (let* ((root (cvs-get-cvsroot))
924 (str (concat (file-name-as-directory (or root "/")) " || " rep)))
925 (if (and root (string-match "\\(.*\\) || \\1\\(.*\\)\\'" str))
926 (match-string 2 str)
927 (file-name-nondirectory rep)))))))
931 ;;;;
932 ;;;; running a "cvs checkout".
933 ;;;;
935 ;;;###autoload
936 (defun cvs-checkout (modules dir flags &optional root)
937 "Run a 'cvs checkout MODULES' in DIR.
938 Feed the output to a *cvs* buffer, display it in the current window,
939 and run `cvs-mode' on it.
941 With a prefix argument, prompt for cvs FLAGS to use."
942 (interactive
943 (let ((root (cvs-get-cvsroot)))
944 (if (or (null root) current-prefix-arg)
945 (setq root (read-string "CVS Root: ")))
946 (list (split-string-and-unquote
947 (read-string "Module(s): " (cvs-get-module)))
948 (read-directory-name "CVS Checkout Directory: "
949 nil default-directory nil)
950 (cvs-add-branch-prefix
951 (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags"))
952 root)))
953 (when (eq flags t)
954 (setf flags (cvs-flags-query 'cvs-checkout-flags nil 'noquery)))
955 (let ((cvs-cvsroot root))
956 (cvs-cmd-do "checkout" (or dir default-directory)
957 (append flags modules) nil 'new
958 :noexist t)))
960 (defun-cvs-mode (cvs-mode-checkout . NOARGS) (dir)
961 "Run cvs checkout against the current branch.
962 The files are stored to DIR."
963 (interactive
964 (let* ((branch (cvs-prefix-get 'cvs-branch-prefix))
965 (prompt (format "CVS Checkout Directory for `%s%s': "
966 (cvs-get-module)
967 (if branch (format " (branch: %s)" branch)
968 ""))))
969 (list (read-directory-name prompt nil default-directory nil))))
970 (let ((modules (split-string-and-unquote (cvs-get-module)))
971 (flags (cvs-add-branch-prefix
972 (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")))
973 (cvs-cvsroot (cvs-get-cvsroot)))
974 (cvs-checkout modules dir flags)))
976 ;;;;
977 ;;;; The code for running a "cvs update" and friends in various ways.
978 ;;;;
980 (defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE)
981 (&optional ignore-auto noconfirm)
982 "Rerun `cvs-examine' on the current directory with the default flags."
983 (interactive)
984 (cvs-examine default-directory t))
986 (defun cvs-query-directory (prompt)
987 "Read directory name, prompting with PROMPT.
988 If in a *cvs* buffer, don't prompt unless a prefix argument is given."
989 (if (and (cvs-buffer-p)
990 (not current-prefix-arg))
991 default-directory
992 (read-directory-name prompt nil default-directory nil)))
994 ;;;###autoload
995 (defun cvs-quickdir (dir &optional flags noshow)
996 "Open a *cvs* buffer on DIR without running cvs.
997 With a prefix argument, prompt for a directory to use.
998 A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
999 prevents reuse of an existing *cvs* buffer.
1000 Optional argument NOSHOW if non-nil means not to display the buffer.
1001 FLAGS is ignored."
1002 (interactive (list (cvs-query-directory "CVS quickdir (directory): ")))
1003 ;; FIXME: code duplication with cvs-cmd-do and cvs-parse-process
1004 (let* ((dir (file-name-as-directory
1005 (abbreviate-file-name (expand-file-name dir))))
1006 (new (> (prefix-numeric-value current-prefix-arg) 8))
1007 (cvsbuf (cvs-make-cvs-buffer dir new))
1008 last)
1009 ;; Check that dir is under CVS control.
1010 (unless (file-directory-p dir)
1011 (error "%s is not a directory" dir))
1012 (unless (file-directory-p (expand-file-name "CVS" dir))
1013 (error "%s does not contain CVS controlled files" dir))
1014 (set-buffer cvsbuf)
1015 (dolist (fi (cvs-fileinfo-from-entries ""))
1016 (setq last (cvs-addto-collection cvs-cookies fi last)))
1017 (cvs-cleanup-collection cvs-cookies
1018 (eq cvs-auto-remove-handled t)
1019 cvs-auto-remove-directories
1020 nil)
1021 (if noshow cvsbuf
1022 (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf)))))
1024 ;;;###autoload
1025 (defun cvs-examine (directory flags &optional noshow)
1026 "Run a `cvs -n update' in the specified DIRECTORY.
1027 That is, check what needs to be done, but don't change the disc.
1028 Feed the output to a *cvs* buffer and run `cvs-mode' on it.
1029 With a prefix argument, prompt for a directory and cvs FLAGS to use.
1030 A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
1031 prevents reuse of an existing *cvs* buffer.
1032 Optional argument NOSHOW if non-nil means not to display the buffer."
1033 (interactive (list (cvs-query-directory "CVS Examine (directory): ")
1034 (cvs-flags-query 'cvs-update-flags "cvs -n update flags")))
1035 (when (eq flags t)
1036 (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery)))
1037 (when find-file-visit-truename (setq directory (file-truename directory)))
1038 (cvs-cmd-do "update" directory flags nil
1039 (> (prefix-numeric-value current-prefix-arg) 8)
1040 :cvsargs '("-n")
1041 :noshow noshow
1042 :dont-change-disc t))
1045 ;;;###autoload
1046 (defun cvs-update (directory flags)
1047 "Run a `cvs update' in the current working DIRECTORY.
1048 Feed the output to a *cvs* buffer and run `cvs-mode' on it.
1049 With a \\[universal-argument] prefix argument, prompt for a directory to use.
1050 A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
1051 prevents reuse of an existing *cvs* buffer.
1052 The prefix is also passed to `cvs-flags-query' to select the FLAGS
1053 passed to cvs."
1054 (interactive (list (cvs-query-directory "CVS Update (directory): ")
1055 (cvs-flags-query 'cvs-update-flags "cvs update flags")))
1056 (when (eq flags t)
1057 (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery)))
1058 (cvs-cmd-do "update" directory flags nil
1059 (> (prefix-numeric-value current-prefix-arg) 8)))
1062 ;;;###autoload
1063 (defun cvs-status (directory flags &optional noshow)
1064 "Run a `cvs status' in the current working DIRECTORY.
1065 Feed the output to a *cvs* buffer and run `cvs-mode' on it.
1066 With a prefix argument, prompt for a directory and cvs FLAGS to use.
1067 A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
1068 prevents reuse of an existing *cvs* buffer.
1069 Optional argument NOSHOW if non-nil means not to display the buffer."
1070 (interactive (list (cvs-query-directory "CVS Status (directory): ")
1071 (cvs-flags-query 'cvs-status-flags "cvs status flags")))
1072 (when (eq flags t)
1073 (setf flags (cvs-flags-query 'cvs-status-flags nil 'noquery)))
1074 (cvs-cmd-do "status" directory flags nil
1075 (> (prefix-numeric-value current-prefix-arg) 8)
1076 :noshow noshow :dont-change-disc t))
1078 (defun cvs-update-filter (proc string)
1079 "Filter function for pcl-cvs.
1080 This function gets the output that CVS sends to stdout. It inserts
1081 the STRING into (process-buffer PROC) but it also checks if CVS is waiting
1082 for a lock file. If so, it inserts a message cookie in the *cvs* buffer."
1083 (save-match-data
1084 (with-current-buffer (process-buffer proc)
1085 (let ((inhibit-read-only t))
1086 (save-excursion
1087 ;; Insert the text, moving the process-marker.
1088 (goto-char (process-mark proc))
1089 (insert string)
1090 (set-marker (process-mark proc) (point))
1091 ;; FIXME: Delete any old lock message
1092 ;;(if (tin-nth cookies 1)
1093 ;; (tin-delete cookies
1094 ;; (tin-nth cookies 1)))
1095 ;; Check if CVS is waiting for a lock.
1096 (beginning-of-line 0) ;Move to beginning of last complete line.
1097 (when (looking-at "^[ a-z]+: \\(.*waiting for .*lock in \\(.*\\)\\)$")
1098 (let ((msg (match-string 1))
1099 (lock (match-string 2)))
1100 (with-current-buffer cvs-buffer
1101 (set (make-local-variable 'cvs-lock-file) lock)
1102 ;; display the lock situation in the *cvs* buffer:
1103 (ewoc-enter-last
1104 cvs-cookies
1105 (cvs-create-fileinfo
1106 'MESSAGE "" " "
1107 (concat msg
1108 (when (file-exists-p lock)
1109 (substitute-command-keys
1110 "\n\t(type \\[cvs-mode-delete-lock] to delete it)")))
1111 :subtype 'TEMP))
1112 (pop-to-buffer (current-buffer))
1113 (goto-char (point-max))
1114 (beep)))))))))
1117 ;;;;
1118 ;;;; The cvs-mode and its associated commands.
1119 ;;;;
1121 (cvs-prefix-define cvs-force-command "" "" '("/F") cvs-qtypedesc-string1)
1122 (defun-cvs-mode cvs-mode-force-command (arg)
1123 "Force the next cvs command to operate on all the selected files.
1124 By default, cvs commands only operate on files on which the command
1125 \"makes sense\". This overrides the safety feature on the next cvs command.
1126 It actually behaves as a toggle. If prefixed by \\[universal-argument] \\[universal-argument],
1127 the override will persist until the next toggle."
1128 (interactive "P")
1129 (cvs-prefix-set 'cvs-force-command arg))
1131 (put 'cvs-mode 'mode-class 'special)
1132 (define-derived-mode cvs-mode nil "CVS"
1133 "Mode used for PCL-CVS, a frontend to CVS.
1134 Full documentation is in the Texinfo file."
1135 (setq mode-line-process
1136 '("" cvs-force-command cvs-ignore-marks-modif
1137 ":" (cvs-branch-prefix
1138 ("" cvs-branch-prefix (cvs-secondary-branch-prefix
1139 ("->" cvs-secondary-branch-prefix))))
1140 " " cvs-mode-line-process))
1141 (if buffer-file-name
1142 (error "Use M-x cvs-quickdir to get a *cvs* buffer"))
1143 (buffer-disable-undo)
1144 ;;(set (make-local-variable 'goal-column) cvs-cursor-column)
1145 (set (make-local-variable 'revert-buffer-function) 'cvs-mode-revert-buffer)
1146 (setq truncate-lines t)
1147 (cvs-prefix-make-local 'cvs-branch-prefix)
1148 (cvs-prefix-make-local 'cvs-secondary-branch-prefix)
1149 (cvs-prefix-make-local 'cvs-force-command)
1150 (cvs-prefix-make-local 'cvs-ignore-marks-modif)
1151 (make-local-variable 'cvs-mode-line-process)
1152 (make-local-variable 'cvs-temp-buffers))
1155 (defun cvs-buffer-p (&optional buffer)
1156 "Return whether the (by default current) BUFFER is a `cvs-mode' buffer."
1157 (save-excursion
1158 (if buffer (set-buffer buffer))
1159 (and (eq major-mode 'cvs-mode))))
1161 (defun cvs-buffer-check ()
1162 "Check that the current buffer follows cvs-buffer's conventions."
1163 (let ((buf (current-buffer))
1164 (check 'none))
1165 (or (and (setq check 'collection)
1166 (eq (ewoc-buffer cvs-cookies) buf)
1167 (setq check 'cvs-temp-buffer)
1168 (or (null cvs-temp-buffer)
1169 (null (buffer-live-p cvs-temp-buffer))
1170 (and (eq (with-current-buffer cvs-temp-buffer cvs-buffer) buf)
1171 (equal (with-current-buffer cvs-temp-buffer
1172 default-directory)
1173 default-directory)))
1175 (error "Inconsistent %s in buffer %s" check (buffer-name buf)))))
1178 (defun cvs-mode-quit ()
1179 "Quit PCL-CVS, killing the *cvs* buffer."
1180 (interactive)
1181 (and (y-or-n-p "Quit pcl-cvs? ") (kill-buffer (current-buffer))))
1183 ;; Give help....
1185 (defun cvs-help ()
1186 "Display help for various PCL-CVS commands."
1187 (interactive)
1188 (if (eq last-command 'cvs-help)
1189 (describe-function 'cvs-mode) ; would need minor-mode for log-edit-mode
1190 (message "%s"
1191 (substitute-command-keys
1192 "`\\[cvs-help]':help `\\[cvs-mode-add]':add `\\[cvs-mode-commit]':commit \
1193 `\\[cvs-mode-diff-map]':diff* `\\[cvs-mode-log]':log \
1194 `\\[cvs-mode-remove]':remove `\\[cvs-mode-status]':status \
1195 `\\[cvs-mode-undo]':undo"))))
1197 ;; Move around in the buffer
1199 (defun cvs-move-to-goal-column ()
1200 (let* ((eol (line-end-position))
1201 (fpos (next-single-property-change (point) 'cvs-goal-column nil eol)))
1202 (when (< fpos eol)
1203 (goto-char fpos))))
1205 (defun-cvs-mode cvs-mode-previous-line (arg)
1206 "Go to the previous line.
1207 If a prefix argument is given, move by that many lines."
1208 (interactive "p")
1209 (ewoc-goto-prev cvs-cookies arg)
1210 (cvs-move-to-goal-column))
1212 (defun-cvs-mode cvs-mode-next-line (arg)
1213 "Go to the next line.
1214 If a prefix argument is given, move by that many lines."
1215 (interactive "p")
1216 (ewoc-goto-next cvs-cookies arg)
1217 (cvs-move-to-goal-column))
1219 ;;;;
1220 ;;;; Mark handling
1221 ;;;;
1223 (defun-cvs-mode cvs-mode-mark (&optional arg)
1224 "Mark the fileinfo on the current line.
1225 If the fileinfo is a directory, all the contents of that directory are
1226 marked instead. A directory can never be marked."
1227 (interactive)
1228 (let* ((tin (ewoc-locate cvs-cookies))
1229 (fi (ewoc-data tin)))
1230 (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
1231 ;; it's a directory: let's mark all files inside
1232 (ewoc-map
1233 (lambda (f dir)
1234 (when (cvs-dir-member-p f dir)
1235 (setf (cvs-fileinfo->marked f)
1236 (not (if (eq arg 'toggle) (cvs-fileinfo->marked f) arg)))
1237 t)) ;Tell cookie to redisplay this cookie.
1238 cvs-cookies
1239 (cvs-fileinfo->dir fi))
1240 ;; not a directory: just do the obvious
1241 (setf (cvs-fileinfo->marked fi)
1242 (not (if (eq arg 'toggle) (cvs-fileinfo->marked fi) arg)))
1243 (ewoc-invalidate cvs-cookies tin)
1244 (cvs-mode-next-line 1))))
1246 (defalias 'cvs-mouse-toggle-mark 'cvs-mode-toggle-mark)
1247 (defun cvs-mode-toggle-mark (e)
1248 "Toggle the mark of the entry at point."
1249 (interactive (list last-input-event))
1250 (save-excursion
1251 (posn-set-point (event-end e))
1252 (cvs-mode-mark 'toggle)))
1254 (defun-cvs-mode cvs-mode-unmark ()
1255 "Unmark the fileinfo on the current line."
1256 (interactive)
1257 (cvs-mode-mark t))
1259 (defun-cvs-mode cvs-mode-mark-all-files ()
1260 "Mark all files."
1261 (interactive)
1262 (ewoc-map (lambda (cookie)
1263 (unless (eq (cvs-fileinfo->type cookie) 'DIRCHANGE)
1264 (setf (cvs-fileinfo->marked cookie) t)))
1265 cvs-cookies))
1267 (defun-cvs-mode (cvs-mode-mark-on-state . SIMPLE) (state)
1268 "Mark all files in state STATE."
1269 (interactive
1270 (list
1271 (let ((default
1272 (condition-case nil
1273 (downcase
1274 (symbol-name
1275 (cvs-fileinfo->type
1276 (cvs-mode-marked nil nil :read-only t :one t :noquery t))))
1277 (error nil))))
1278 (intern
1279 (upcase
1280 (completing-read
1281 (concat
1282 "Mark files in state" (if default (concat " [" default "]")) ": ")
1283 (mapcar (lambda (x)
1284 (list (downcase (symbol-name (car x)))))
1285 cvs-states)
1286 nil t nil nil default))))))
1287 (ewoc-map (lambda (fi)
1288 (when (eq (cvs-fileinfo->type fi) state)
1289 (setf (cvs-fileinfo->marked fi) t)))
1290 cvs-cookies))
1292 (defun-cvs-mode cvs-mode-mark-matching-files (regex)
1293 "Mark all files matching REGEX."
1294 (interactive "sMark files matching: ")
1295 (ewoc-map (lambda (cookie)
1296 (when (and (not (eq (cvs-fileinfo->type cookie) 'DIRCHANGE))
1297 (string-match regex (cvs-fileinfo->file cookie)))
1298 (setf (cvs-fileinfo->marked cookie) t)))
1299 cvs-cookies))
1301 (defun-cvs-mode cvs-mode-unmark-all-files ()
1302 "Unmark all files.
1303 Directories are also unmarked, but that doesn't matter, since
1304 they should always be unmarked."
1305 (interactive)
1306 (ewoc-map (lambda (cookie)
1307 (setf (cvs-fileinfo->marked cookie) nil)
1309 cvs-cookies))
1311 (defun-cvs-mode cvs-mode-unmark-up ()
1312 "Unmark the file on the previous line."
1313 (interactive)
1314 (let ((tin (ewoc-goto-prev cvs-cookies 1)))
1315 (when tin
1316 (setf (cvs-fileinfo->marked (ewoc-data tin)) nil)
1317 (ewoc-invalidate cvs-cookies tin)))
1318 (cvs-move-to-goal-column))
1320 (defconst cvs-ignore-marks-alternatives
1321 '(("toggle-marks" . "/TM")
1322 ("force-marks" . "/FM")
1323 ("ignore-marks" . "/IM")))
1325 (cvs-prefix-define cvs-ignore-marks-modif
1326 "Prefix to decide whether to ignore marks or not."
1327 "active"
1328 (mapcar 'cdr cvs-ignore-marks-alternatives)
1329 (cvs-qtypedesc-create
1330 (lambda (str) (cdr (assoc str cvs-ignore-marks-alternatives)))
1331 (lambda (obj) (car (rassoc obj cvs-ignore-marks-alternatives)))
1332 (lambda () cvs-ignore-marks-alternatives)
1333 nil t))
1335 (defun-cvs-mode cvs-mode-toggle-marks (arg)
1336 "Toggle whether the next CVS command uses marks.
1337 See `cvs-prefix-set' for further description of the behavior.
1338 \\[universal-argument] 1 selects `force-marks',
1339 \\[universal-argument] 2 selects `ignore-marks',
1340 \\[universal-argument] 3 selects `toggle-marks'."
1341 (interactive "P")
1342 (cvs-prefix-set 'cvs-ignore-marks-modif arg))
1344 (defun cvs-ignore-marks-p (cmd &optional read-only)
1345 (let ((default (if (member cmd cvs-invert-ignore-marks)
1346 (not cvs-default-ignore-marks)
1347 cvs-default-ignore-marks))
1348 (modif (cvs-prefix-get 'cvs-ignore-marks-modif read-only)))
1349 (cond
1350 ((equal modif "/IM") t)
1351 ((equal modif "/TM") (not default))
1352 ((equal modif "/FM") nil)
1353 (t default))))
1355 (defun cvs-mode-mark-get-modif (cmd)
1356 (if (cvs-ignore-marks-p cmd 'read-only) "/IM" "/FM"))
1358 (defun cvs-get-marked (&optional ignore-marks ignore-contents)
1359 "Return a list of all selected fileinfos.
1360 If there are any marked tins, and IGNORE-MARKS is nil, return them.
1361 Otherwise, if the cursor selects a directory, and IGNORE-CONTENTS is
1362 nil, return all files in it, else return just the directory.
1363 Otherwise return (a list containing) the file the cursor points to, or
1364 an empty list if it doesn't point to a file at all."
1365 (let ((fis nil))
1366 (dolist (fi (if (and (boundp 'cvs-minor-current-files)
1367 (consp cvs-minor-current-files))
1368 (mapcar
1369 (lambda (f)
1370 (if (cvs-fileinfo-p f) f
1371 (let ((f (file-relative-name f)))
1372 (if (file-directory-p f)
1373 (cvs-create-fileinfo
1374 'DIRCHANGE (file-name-as-directory f) "." "")
1375 (let ((dir (file-name-directory f))
1376 (file (file-name-nondirectory f)))
1377 (cvs-create-fileinfo
1378 'UNKNOWN (or dir "") file ""))))))
1379 cvs-minor-current-files)
1380 (or (and (not ignore-marks)
1381 (ewoc-collect cvs-cookies 'cvs-fileinfo->marked))
1382 (list (ewoc-data (ewoc-locate cvs-cookies))))))
1384 (if (or ignore-contents (not (eq (cvs-fileinfo->type fi) 'DIRCHANGE)))
1385 (push fi fis)
1386 ;; If a directory is selected, return members, if any.
1387 (setq fis
1388 (append (ewoc-collect
1389 cvs-cookies 'cvs-dir-member-p (cvs-fileinfo->dir fi))
1390 fis))))
1391 (nreverse fis)))
1393 (cl-defun cvs-mode-marked (filter &optional cmd
1394 &key read-only one file noquery)
1395 "Get the list of marked FIS.
1396 CMD is used to determine whether to use the marks or not.
1397 Only files for which FILTER is applicable are returned.
1398 If READ-ONLY is non-nil, the current toggling is left intact.
1399 If ONE is non-nil, marks are ignored and a single FI is returned.
1400 If FILE is non-nil, directory entries won't be selected."
1401 (unless cmd (setq cmd (symbol-name filter)))
1402 (let* ((fis (cvs-get-marked (or one (cvs-ignore-marks-p cmd read-only))
1403 (and (not file)
1404 (cvs-applicable-p 'DIRCHANGE filter))))
1405 (force (cvs-prefix-get 'cvs-force-command))
1406 (fis (car (cvs-partition
1407 (lambda (fi) (cvs-applicable-p fi (and (not force) filter)))
1408 fis))))
1409 (when (and (or (null fis) (and one (cdr fis))) (not noquery))
1410 (message (if (null fis)
1411 "`%s' is not applicable to any of the selected files."
1412 "`%s' is only applicable to a single file.") cmd)
1413 (sit-for 1)
1414 (setq fis (list (cvs-insert-file
1415 (read-file-name (format "File to %s: " cmd))))))
1416 (if one (car fis) fis)))
1418 (defun cvs-enabledp (filter)
1419 "Determine whether FILTER applies to at least one of the selected files."
1420 (ignore-errors (cvs-mode-marked filter nil :read-only t :noquery t)))
1422 (defun cvs-mode-files (&rest -cvs-mode-files-args)
1423 (cvs-mode!
1424 (lambda ()
1425 (mapcar 'cvs-fileinfo->full-name
1426 (apply 'cvs-mode-marked -cvs-mode-files-args)))))
1429 ;; Interface between Log-Edit and PCL-CVS
1432 (defun cvs-mode-commit-setup ()
1433 "Run `cvs-mode-commit' with setup."
1434 (interactive)
1435 (cvs-mode-commit 'force))
1437 (defcustom cvs-mode-commit-hook nil
1438 "Hook run after setting up the commit buffer."
1439 :type 'hook
1440 :options '(cvs-mode-diff)
1441 :group 'pcl-cvs)
1443 (defun cvs-mode-commit (setup)
1444 "Check in all marked files, or the current file.
1445 The user will be asked for a log message in a buffer.
1446 The buffer's mode and name is determined by the \"message\" setting
1447 of `cvs-buffer-name-alist'.
1448 The POSTPROC specified there (typically `log-edit') is then called,
1449 passing it the SETUP argument."
1450 (interactive "P")
1451 ;; It seems that the save-excursion that happens if I use the better
1452 ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which
1453 ;; end up being rather annoying (like log-edit-mode's message being
1454 ;; displayed in the wrong minibuffer).
1455 (cvs-mode!)
1456 (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup))
1457 (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist)))
1458 'log-edit)))
1459 (funcall setupfun 'cvs-do-commit setup
1460 '((log-edit-listfun . cvs-commit-filelist)
1461 (log-edit-diff-function . cvs-mode-diff)) buf)
1462 (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-commit-minor-wrap)
1463 (run-hooks 'cvs-mode-commit-hook)))
1465 (defun cvs-commit-minor-wrap (buf f)
1466 (let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit")))
1467 (funcall f)))
1469 (defun cvs-commit-filelist ()
1470 (cvs-mode-files 'commit nil :read-only t :file t :noquery t))
1472 (defun cvs-do-commit (flags)
1473 "Do the actual commit, using the current buffer as the log message."
1474 (interactive (list (cvs-flags-query 'cvs-commit-flags "cvs commit flags")))
1475 (let ((msg (buffer-substring-no-properties (point-min) (point-max))))
1476 (cvs-mode!)
1477 ;;(pop-to-buffer cvs-buffer)
1478 (cvs-mode-do "commit" `("-m" ,msg ,@flags) 'commit)))
1481 ;;;; Editing existing commit log messages.
1483 (defun cvs-edit-log-text-at-point ()
1484 (save-excursion
1485 (end-of-line)
1486 (when (re-search-backward "^revision " nil t)
1487 (forward-line 1)
1488 (if (looking-at "date:") (forward-line 1))
1489 (if (looking-at "branches:") (forward-line 1))
1490 (buffer-substring
1491 (point)
1492 (if (re-search-forward
1493 "^\\(-\\{28\\}\\|=\\{77\\}\\|revision [.0-9]+\\)$"
1494 nil t)
1495 (match-beginning 0)
1496 (point))))))
1498 (defvar cvs-edit-log-revision)
1499 (defvar cvs-edit-log-files) (put 'cvs-edit-log-files 'permanent-local t)
1500 (defun cvs-mode-edit-log (file rev &optional text)
1501 "Edit the log message at point.
1502 This is best called from a `log-view-mode' buffer."
1503 (interactive
1504 (list
1505 (or (cvs-mode! (lambda ()
1506 (car (cvs-mode-files nil nil
1507 :read-only t :file t :noquery t))))
1508 (read-string "File name: "))
1509 (or (cvs-mode! (lambda () (cvs-prefix-get 'cvs-branch-prefix)))
1510 (read-string "Revision to edit: "))
1511 (cvs-edit-log-text-at-point)))
1512 ;; It seems that the save-excursion that happens if I use the better
1513 ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which
1514 ;; end up being rather annoying (like log-edit-mode's message being
1515 ;; displayed in the wrong minibuffer).
1516 (cvs-mode!)
1517 (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup))
1518 (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist)))
1519 'log-edit)))
1520 (with-current-buffer buf
1521 ;; Set the filename before, so log-edit can correctly setup its
1522 ;; log-edit-initial-files variable.
1523 (set (make-local-variable 'cvs-edit-log-files) (list file)))
1524 (funcall setupfun 'cvs-do-edit-log nil
1525 '((log-edit-listfun . cvs-edit-log-filelist)
1526 (log-edit-diff-function . cvs-mode-diff))
1527 buf)
1528 (when text (erase-buffer) (insert text))
1529 (set (make-local-variable 'cvs-edit-log-revision) rev)
1530 (set (make-local-variable 'cvs-minor-wrap-function)
1531 'cvs-edit-log-minor-wrap)
1532 ;; (run-hooks 'cvs-mode-commit-hook)
1535 (defun cvs-edit-log-minor-wrap (buf f)
1536 (let ((cvs-branch-prefix (with-current-buffer buf cvs-edit-log-revision))
1537 (cvs-minor-current-files
1538 (with-current-buffer buf cvs-edit-log-files))
1539 ;; FIXME: I need to force because the fileinfos are UNKNOWN
1540 (cvs-force-command "/F"))
1541 (funcall f)))
1543 (defun cvs-edit-log-filelist ()
1544 (if cvs-minor-wrap-function
1545 (cvs-mode-files nil nil :read-only t :file t :noquery t)
1546 cvs-edit-log-files))
1548 (defun cvs-do-edit-log (rev)
1549 "Do the actual commit, using the current buffer as the log message."
1550 (interactive (list cvs-edit-log-revision))
1551 (let ((msg (buffer-substring-no-properties (point-min) (point-max))))
1552 (cvs-mode!
1553 (lambda ()
1554 (cvs-mode-do "admin" (list (concat "-m" rev ":" msg)) nil)))))
1557 ;;;;
1558 ;;;; CVS Mode commands
1559 ;;;;
1561 (defun-cvs-mode (cvs-mode-insert . NOARGS) (file)
1562 "Insert an entry for a specific file into the current listing.
1563 This is typically used if the file is up-to-date (or has been added
1564 outside of PCL-CVS) and one wants to do some operation on it."
1565 (interactive
1566 (list (read-file-name
1567 "File to insert: "
1568 ;; Can't use ignore-errors here because interactive
1569 ;; specs aren't byte-compiled.
1570 (condition-case nil
1571 (file-name-as-directory
1572 (expand-file-name
1573 (cvs-fileinfo->dir
1574 (cvs-mode-marked nil nil :read-only t :one t :noquery t))))
1575 (error nil)))))
1576 (cvs-insert-file file))
1578 (defun cvs-insert-file (file)
1579 "Insert FILE (and its contents if it's a dir) and return its FI."
1580 (let ((file (file-relative-name (directory-file-name file))) last)
1581 (dolist (fi (cvs-fileinfo-from-entries file))
1582 (setq last (cvs-addto-collection cvs-cookies fi last)))
1583 ;; There should have been at least one entry.
1584 (goto-char (ewoc-location last))
1585 (ewoc-data last)))
1587 (defun cvs-mark-fis-dead (fis)
1588 ;; Helper function, introduced because of the need for macro-expansion.
1589 (dolist (fi fis)
1590 (setf (cvs-fileinfo->type fi) 'DEAD)))
1592 (defun-cvs-mode (cvs-mode-add . SIMPLE) (flags)
1593 "Add marked files to the cvs repository.
1594 With prefix argument, prompt for cvs flags."
1595 (interactive (list (cvs-flags-query 'cvs-add-flags "cvs add flags")))
1596 (let ((fis (cvs-mode-marked 'add))
1597 (needdesc nil) (dirs nil))
1598 ;; find directories and look for fis needing a description
1599 (dolist (fi fis)
1600 (cond
1601 ((file-directory-p (cvs-fileinfo->full-name fi)) (push fi dirs))
1602 ((eq (cvs-fileinfo->type fi) 'UNKNOWN) (setq needdesc t))))
1603 ;; prompt for description if necessary
1604 (let* ((msg (if (and needdesc
1605 (or current-prefix-arg (not cvs-add-default-message)))
1606 (read-from-minibuffer "Enter description: ")
1607 (or cvs-add-default-message "")))
1608 (flags `("-m" ,msg ,@flags))
1609 (postproc
1610 ;; setup postprocessing for the directory entries
1611 (when dirs
1612 `((cvs-run-process (list "-n" "update")
1613 ',dirs
1614 '(cvs-parse-process t))
1615 (cvs-mark-fis-dead ',dirs)))))
1616 (cvs-mode-run "add" flags fis :postproc postproc))))
1618 (defun-cvs-mode (cvs-mode-diff . DOUBLE) (flags)
1619 "Diff the selected files against the repository.
1620 This command compares the files in your working area against the
1621 revision which they are based upon.
1622 See also `cvs-diff-ignore-marks'."
1623 (interactive
1624 (list (cvs-add-branch-prefix
1625 (cvs-add-secondary-branch-prefix
1626 (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))))
1627 (cvs-mode-do "diff" flags 'diff
1628 :show t)) ;; :ignore-exit t
1630 (defun-cvs-mode (cvs-mode-diff-head . SIMPLE) (flags)
1631 "Diff the selected files against the head of the current branch.
1632 See ``cvs-mode-diff'' for more info."
1633 (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
1634 (cvs-mode-diff-1 (cons "-rHEAD" flags)))
1636 (defun-cvs-mode (cvs-mode-diff-repository . SIMPLE) (flags)
1637 "Diff the files for changes in the repository since last co/update/commit.
1638 See ``cvs-mode-diff'' for more info."
1639 (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
1640 (cvs-mode-diff-1 (cons "-rBASE" (cons "-rHEAD" flags))))
1642 (defun-cvs-mode (cvs-mode-diff-yesterday . SIMPLE) (flags)
1643 "Diff the selected files against yesterday's head of the current branch.
1644 See ``cvs-mode-diff'' for more info."
1645 (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
1646 (cvs-mode-diff-1 (cons "-Dyesterday" flags)))
1648 (defun-cvs-mode (cvs-mode-diff-vendor . SIMPLE) (flags)
1649 "Diff the selected files against the head of the vendor branch.
1650 See ``cvs-mode-diff'' for more info."
1651 (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
1652 (cvs-mode-diff-1 (cons (concat "-r" cvs-vendor-branch) flags)))
1654 ;; sadly, this is not provided by cvs, so we have to roll our own
1655 (defun-cvs-mode (cvs-mode-diff-backup . SIMPLE) (flags)
1656 "Diff the files against the backup file.
1657 This command can be used on files that are marked with \"Merged\"
1658 or \"Conflict\" in the *cvs* buffer."
1659 (interactive (list (cvs-flags-query 'cvs-diff-flags "diff flags")))
1660 (unless (listp flags) (error "flags should be a list of strings"))
1661 (save-some-buffers)
1662 (let* ((marked (cvs-get-marked (cvs-ignore-marks-p "diff")))
1663 (fis (car (cvs-partition 'cvs-fileinfo->backup-file marked))))
1664 (unless (consp fis)
1665 (error "No files with a backup file selected!"))
1666 ;; let's extract some info into the environment for `buffer-name'
1667 (let* ((dir (cvs-fileinfo->dir (car fis)))
1668 (file (cvs-fileinfo->file (car fis))))
1669 (set-buffer (cvs-temp-buffer "diff")))
1670 (message "cvs diff backup...")
1671 (cvs-execute-single-file-list fis 'cvs-diff-backup-extractor
1672 cvs-diff-program flags))
1673 (message "cvs diff backup... Done."))
1675 (defun cvs-diff-backup-extractor (fileinfo)
1676 "Return the filename and the name of the backup file as a list.
1677 Signal an error if there is no backup file."
1678 (let ((backup-file (cvs-fileinfo->backup-file fileinfo)))
1679 (unless backup-file
1680 (error "%s has no backup file" (cvs-fileinfo->full-name fileinfo)))
1681 (list backup-file (cvs-fileinfo->full-name fileinfo))))
1684 ;; Emerge support
1686 (defun cvs-emerge-diff (b1 b2) (emerge-buffers b1 b2 b1))
1687 (defun cvs-emerge-merge (b1 b2 base out)
1688 (emerge-buffers-with-ancestor b1 b2 base (find-file-noselect out)))
1691 ;; Ediff support
1694 (defvar ediff-after-quit-destination-buffer)
1695 (defvar ediff-after-quit-hook-internal)
1696 (defvar cvs-transient-buffers)
1697 (defun cvs-ediff-startup-hook ()
1698 (add-hook 'ediff-after-quit-hook-internal
1699 `(lambda ()
1700 (cvs-ediff-exit-hook
1701 ',ediff-after-quit-destination-buffer ',cvs-transient-buffers))
1702 nil 'local))
1704 (defun cvs-ediff-exit-hook (cvs-buf tmp-bufs)
1705 ;; kill the temp buffers (and their associated windows)
1706 (dolist (tb tmp-bufs)
1707 (when (and tb (buffer-live-p tb) (not (buffer-modified-p tb)))
1708 (let ((win (get-buffer-window tb t)))
1709 (kill-buffer tb)
1710 (when (window-live-p win) (ignore-errors (delete-window win))))))
1711 ;; switch back to the *cvs* buffer
1712 (when (and cvs-buf (buffer-live-p cvs-buf)
1713 (not (get-buffer-window cvs-buf t)))
1714 (ignore-errors (switch-to-buffer cvs-buf))))
1716 (defun cvs-ediff-diff (b1 b2)
1717 (let ((ediff-after-quit-destination-buffer (current-buffer))
1718 (startup-hook '(cvs-ediff-startup-hook)))
1719 (ediff-buffers b1 b2 startup-hook 'ediff-revision)))
1721 (defun cvs-ediff-merge (b1 b2 base out)
1722 (let ((ediff-after-quit-destination-buffer (current-buffer))
1723 (startup-hook '(cvs-ediff-startup-hook)))
1724 (ediff-merge-buffers-with-ancestor
1725 b1 b2 base startup-hook
1726 'ediff-merge-revisions-with-ancestor
1727 out)))
1730 ;; Interactive merge/diff support.
1733 (defun cvs-retrieve-revision (fileinfo rev)
1734 "Retrieve the given REVision of the file in FILEINFO into a new buffer."
1735 (let* ((file (cvs-fileinfo->full-name fileinfo))
1736 (buffile (concat file "." rev)))
1737 (or (find-buffer-visiting buffile)
1738 (with-current-buffer (create-file-buffer buffile)
1739 (message "Retrieving revision %s..." rev)
1740 ;; Discard stderr output to work around the CVS+SSH+libc
1741 ;; problem when stdout and stderr are the same.
1742 (let ((res
1743 (let ((coding-system-for-read 'binary))
1744 (apply 'process-file cvs-program nil '(t nil) nil
1745 "-q" "update" "-p"
1746 ;; If `rev' is HEAD, don't pass it at all:
1747 ;; the default behavior is to get the head
1748 ;; of the current branch whereas "-r HEAD"
1749 ;; stupidly gives you the head of the trunk.
1750 (append (unless (equal rev "HEAD") (list "-r" rev))
1751 (list file))))))
1752 (when (and res (not (and (equal 0 res))))
1753 (error "Something went wrong retrieving revision %s: %s" rev res))
1754 ;; Figure out the encoding used and decode the byte-sequence
1755 ;; into a sequence of chars.
1756 (decode-coding-inserted-region
1757 (point-min) (point-max) file t nil nil t)
1758 ;; Set buffer-file-coding-system.
1759 (after-insert-file-set-coding (buffer-size) t)
1760 (set-buffer-modified-p nil)
1761 (let ((buffer-file-name (expand-file-name file)))
1762 (after-find-file))
1763 (setq buffer-read-only t)
1764 (message "Retrieving revision %s... Done" rev)
1765 (current-buffer))))))
1767 ;; FIXME: The user should be able to specify ancestor/head/backup and we should
1768 ;; provide sensible defaults when merge info is unavailable (rather than rely
1769 ;; on smerge-ediff). Also provide sane defaults for need-merge files.
1770 (defun-cvs-mode cvs-mode-imerge ()
1771 "Merge interactively appropriate revisions of the selected file."
1772 (interactive)
1773 (let ((fi (cvs-mode-marked 'merge nil :one t :file t)))
1774 (let ((merge (cvs-fileinfo->merge fi))
1775 (file (cvs-fileinfo->full-name fi))
1776 (backup-file (cvs-fileinfo->backup-file fi)))
1777 (if (not (and merge backup-file))
1778 (let ((buf (find-file-noselect file)))
1779 (message "Missing merge info or backup file, using VC.")
1780 (with-current-buffer buf
1781 (smerge-ediff)))
1782 (let* ((ancestor-buf (cvs-retrieve-revision fi (car merge)))
1783 (head-buf (cvs-retrieve-revision fi (cdr merge)))
1784 (backup-buf (let ((auto-mode-alist nil))
1785 (find-file-noselect backup-file)))
1786 ;; this binding is used by cvs-ediff-startup-hook
1787 (cvs-transient-buffers (list ancestor-buf backup-buf head-buf)))
1788 (with-current-buffer backup-buf
1789 (let ((buffer-file-name (expand-file-name file)))
1790 (after-find-file)))
1791 (funcall (cdr cvs-idiff-imerge-handlers)
1792 backup-buf head-buf ancestor-buf file))))))
1794 (cvs-flags-define cvs-idiff-version
1795 (list "BASE" cvs-vendor-branch cvs-vendor-branch "BASE" "BASE")
1796 "version: " cvs-qtypedesc-tag)
1798 (defun-cvs-mode (cvs-mode-idiff . NOARGS) (&optional rev1 rev2)
1799 "Diff interactively current file to revisions."
1800 (interactive
1801 (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix))
1802 (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix))))
1803 (list (or rev1 (cvs-flags-query 'cvs-idiff-version))
1804 rev2)))
1805 (let ((fi (cvs-mode-marked 'diff "idiff" :one t :file t)))
1806 (let* ((file (cvs-fileinfo->full-name fi))
1807 (rev1-buf (cvs-retrieve-revision fi (or rev1 "BASE")))
1808 (rev2-buf (if rev2 (cvs-retrieve-revision fi rev2)))
1809 ;; this binding is used by cvs-ediff-startup-hook
1810 (cvs-transient-buffers (list rev1-buf rev2-buf)))
1811 (funcall (car cvs-idiff-imerge-handlers)
1812 rev1-buf (or rev2-buf (find-file-noselect file))))))
1814 (defun-cvs-mode (cvs-mode-idiff-other . NOARGS) ()
1815 "Diff interactively current file to revisions."
1816 (interactive)
1817 (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix))
1818 (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix)))
1819 (fis (cvs-mode-marked 'diff "idiff" :file t)))
1820 (when (> (length fis) 2)
1821 (error "idiff-other cannot be applied to more than 2 files at a time"))
1822 (let* ((fi1 (car fis))
1823 (rev1-buf (if rev1 (cvs-retrieve-revision fi1 rev1)
1824 (find-file-noselect (cvs-fileinfo->full-name fi1))))
1825 rev2-buf)
1826 (if (cdr fis)
1827 (let ((fi2 (nth 1 fis)))
1828 (setq rev2-buf
1829 (if rev2 (cvs-retrieve-revision fi2 rev2)
1830 (find-file-noselect (cvs-fileinfo->full-name fi2)))))
1831 (error "idiff-other doesn't know what other file/buffer to use"))
1832 (let* (;; this binding is used by cvs-ediff-startup-hook
1833 (cvs-transient-buffers (list rev1-buf rev2-buf)))
1834 (funcall (car cvs-idiff-imerge-handlers)
1835 rev1-buf rev2-buf)))))
1838 (defun cvs-is-within-p (fis dir)
1839 "Non-nil if buffer is inside one of FIS (in DIR)."
1840 (when (stringp buffer-file-name)
1841 (setq buffer-file-name (expand-file-name buffer-file-name))
1842 (let (ret)
1843 (dolist (fi (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." ""))))
1844 (when (string-prefix-p
1845 (expand-file-name (cvs-fileinfo->full-name fi) dir)
1846 buffer-file-name)
1847 (setq ret t)))
1848 ret)))
1850 (cl-defun cvs-mode-run (cmd flags fis
1851 &key (buf (cvs-temp-buffer))
1852 dont-change-disc cvsargs postproc)
1853 "Generic cvs-mode-<foo> function.
1854 Executes `cvs CVSARGS CMD FLAGS FIS'.
1855 BUF is the buffer to be used for cvs' output.
1856 DONT-CHANGE-DISC non-nil indicates that the command will not change the
1857 contents of files. This is only used by the parser.
1858 POSTPROC is a list of expressions to be evaluated at the very end (after
1859 parsing if applicable). It will be prepended with `progn' if necessary."
1860 (let ((def-dir default-directory))
1861 ;; Save the relevant buffers
1862 (save-some-buffers nil (lambda () (cvs-is-within-p fis def-dir))))
1863 (unless (listp flags) (error "flags should be a list of strings"))
1864 ;; Some w32 versions of CVS don't like an explicit . too much.
1865 (when (and (car fis) (null (cdr fis))
1866 (eq (cvs-fileinfo->type (car fis)) 'DIRCHANGE)
1867 ;; (equal (cvs-fileinfo->file (car fis)) ".")
1868 (equal (cvs-fileinfo->dir (car fis)) ""))
1869 (setq fis nil))
1870 (let* ((single-dir (or (not (listp cvs-execute-single-dir))
1871 (member cmd cvs-execute-single-dir)))
1872 (parse (member cmd cvs-parse-known-commands))
1873 (args (append cvsargs (list cmd) flags))
1874 (after-mode (nth 2 (cdr (assoc cmd cvs-buffer-name-alist)))))
1875 (cvs-cleanup-collection cvs-cookies ;cleanup remaining messages
1876 (eq cvs-auto-remove-handled 'delayed) nil t)
1877 (when (fboundp after-mode)
1878 (setq postproc (append postproc `((,after-mode)))))
1879 (when parse
1880 (let ((old-fis
1881 (when (member cmd '("status" "update")) ;FIXME: Yuck!!
1882 ;; absence of `cvs update' output has a specific meaning.
1883 (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." ""))))))
1884 (push `(cvs-parse-process ',dont-change-disc nil ',old-fis) postproc)))
1885 (setq postproc (if (cdr postproc) (cons 'progn postproc) (car postproc)))
1886 (with-current-buffer buf
1887 (let ((inhibit-read-only t)) (erase-buffer))
1888 (message "Running cvs %s ..." cmd)
1889 (cvs-run-process args fis postproc single-dir))))
1892 (cl-defun cvs-mode-do (cmd flags filter
1893 &key show dont-change-disc cvsargs postproc)
1894 "Generic cvs-mode-<foo> function.
1895 Executes `cvs CVSARGS CMD FLAGS' on the selected files.
1896 FILTER is passed to `cvs-applicable-p' to only apply the command to
1897 files for which it makes sense.
1898 SHOW indicates that CMD should be not be run in the default temp buffer and
1899 should be shown to the user. The buffer and mode to be used is determined
1900 by `cvs-buffer-name-alist'.
1901 DONT-CHANGE-DISC non-nil indicates that the command will not change the
1902 contents of files. This is only used by the parser."
1903 (cvs-mode-run cmd flags (cvs-mode-marked filter cmd)
1904 :buf (cvs-temp-buffer (when show cmd))
1905 :dont-change-disc dont-change-disc
1906 :cvsargs cvsargs
1907 :postproc postproc))
1909 (defun-cvs-mode (cvs-mode-status . SIMPLE) (flags)
1910 "Show cvs status for all marked files.
1911 With prefix argument, prompt for cvs flags."
1912 (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags")))
1913 (cvs-mode-do "status" flags nil :dont-change-disc t :show t
1914 :postproc (when (eq cvs-auto-remove-handled 'status)
1915 `((with-current-buffer ,(current-buffer)
1916 (cvs-mode-remove-handled))))))
1918 (defun-cvs-mode (cvs-mode-tree . SIMPLE) (flags)
1919 "Call cvstree using the file under the point as a keyfile."
1920 (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags")))
1921 (cvs-mode-run "status" (cons "-v" flags) (cvs-mode-marked nil "status")
1922 :buf (cvs-temp-buffer "tree")
1923 :dont-change-disc t
1924 :postproc '((cvs-status-cvstrees))))
1926 ;; cvs log
1928 (defun-cvs-mode (cvs-mode-log . NOARGS) (flags)
1929 "Display the cvs log of all selected files.
1930 With prefix argument, prompt for cvs flags."
1931 (interactive (list (cvs-add-branch-prefix
1932 (cvs-flags-query 'cvs-log-flags "cvs log flags"))))
1933 (cvs-mode-do "log" flags nil :show t))
1936 (defun-cvs-mode (cvs-mode-update . NOARGS) (flags)
1937 "Update all marked files.
1938 With a prefix argument, prompt for cvs flags."
1939 (interactive
1940 (list (cvs-add-branch-prefix
1941 (cvs-add-secondary-branch-prefix
1942 (cvs-flags-query 'cvs-update-flags "cvs update flags")
1943 "-j") "-j")))
1944 (cvs-mode-do "update" flags 'update))
1947 (defun-cvs-mode (cvs-mode-examine . NOARGS) (flags)
1948 "Re-examine all marked files.
1949 With a prefix argument, prompt for cvs flags."
1950 (interactive
1951 (list (cvs-add-branch-prefix
1952 (cvs-add-secondary-branch-prefix
1953 (cvs-flags-query 'cvs-update-flags "cvs -n update flags")
1954 "-j") "-j")))
1955 (cvs-mode-do "update" flags nil :cvsargs '("-n") :dont-change-disc t))
1958 (defun-cvs-mode cvs-mode-ignore (&optional pattern)
1959 "Arrange so that CVS ignores the selected files.
1960 This command ignores files that are not flagged as `Unknown'."
1961 (interactive)
1962 (dolist (fi (cvs-mode-marked 'ignore))
1963 (cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi)
1964 (eq (cvs-fileinfo->subtype fi) 'NEW-DIR))
1965 (setf (cvs-fileinfo->type fi) 'DEAD))
1966 (cvs-cleanup-collection cvs-cookies nil nil nil))
1968 (declare-function vc-editable-p "vc" (file))
1969 (declare-function vc-checkout "vc" (file &optional writable rev))
1971 (defun cvs-append-to-ignore (dir str &optional old-dir)
1972 "Add STR to the .cvsignore file in DIR.
1973 If OLD-DIR is non-nil, then this is a directory that we don't want
1974 to hear about anymore."
1975 (with-current-buffer
1976 (find-file-noselect (expand-file-name ".cvsignore" dir))
1977 (when (ignore-errors
1978 (and buffer-read-only
1979 (eq 'CVS (vc-backend buffer-file-name))
1980 (not (vc-editable-p buffer-file-name))))
1981 ;; CVSREAD=on special case
1982 (vc-checkout buffer-file-name t))
1983 (goto-char (point-max))
1984 (unless (bolp) (insert "\n"))
1985 (insert str (if old-dir "/\n" "\n"))
1986 (if cvs-sort-ignore-file (sort-lines nil (point-min) (point-max)))
1987 (save-buffer)))
1990 (defun cvs-mode-find-file-other-window (e)
1991 "Select a buffer containing the file in another window."
1992 (interactive (list last-input-event))
1993 (cvs-mode-find-file e t))
1996 (defun cvs-mode-display-file (e)
1997 "Show a buffer containing the file in another window."
1998 (interactive (list last-input-event))
1999 (cvs-mode-find-file e 'dont-select))
2002 (defun cvs-mode-view-file (e)
2003 "View the file."
2004 (interactive (list last-input-event))
2005 (cvs-mode-find-file e nil t))
2008 (defun cvs-mode-view-file-other-window (e)
2009 "View the file."
2010 (interactive (list last-input-event))
2011 (cvs-mode-find-file e t t))
2014 (defun cvs-find-modif (fi)
2015 (with-temp-buffer
2016 (process-file cvs-program nil (current-buffer) nil
2017 "-f" "diff" (cvs-fileinfo->file fi))
2018 (goto-char (point-min))
2019 (if (re-search-forward "^\\([0-9]+\\)" nil t)
2020 (string-to-number (match-string 1))
2021 1)))
2024 (defun cvs-mode-find-file (e &optional other view)
2025 "Select a buffer containing the file.
2026 With a prefix, opens the buffer in an OTHER window."
2027 (interactive (list last-input-event current-prefix-arg))
2028 ;; If the event moves point, check that it moves it to a valid location.
2029 (when (and (/= (point) (progn (posn-set-point (event-end e)) (point)))
2030 (not (memq (get-text-property (1- (line-end-position))
2031 'font-lock-face)
2032 '(cvs-header cvs-filename))))
2033 (error "Not a file name"))
2034 (cvs-mode!
2035 (lambda (&optional rev)
2036 (interactive (list (cvs-prefix-get 'cvs-branch-prefix)))
2037 (let* ((cvs-buf (current-buffer))
2038 (fi (cvs-mode-marked nil nil :one t)))
2039 (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
2040 (let ((odir default-directory))
2041 (setq default-directory
2042 (cvs-expand-dir-name (cvs-fileinfo->dir fi)))
2043 (cond ((eq other 'dont-select)
2044 (display-buffer (find-file-noselect default-directory)))
2045 (other (dired-other-window default-directory))
2046 (t (dired default-directory)))
2047 (set-buffer cvs-buf)
2048 (setq default-directory odir))
2049 (let ((buf (if rev (cvs-retrieve-revision fi rev)
2050 (find-file-noselect (cvs-fileinfo->full-name fi)))))
2051 (funcall (cond ((eq other 'dont-select) 'display-buffer)
2052 (other
2053 (if view 'view-buffer-other-window
2054 'switch-to-buffer-other-window))
2055 (t (if view 'view-buffer 'switch-to-buffer)))
2056 buf)
2057 (when (and cvs-find-file-and-jump (cvs-applicable-p fi 'diff-base))
2058 (save-restriction
2059 (widen)
2060 (goto-char (point-min))
2061 (forward-line (1- (cvs-find-modif fi)))))
2062 buf))))))
2065 (defun-cvs-mode (cvs-mode-undo . SIMPLE) (flags)
2066 "Undo local changes to all marked files.
2067 The file is removed and `cvs update FILE' is run."
2068 ;;"With prefix argument, prompt for cvs FLAGS."
2069 (interactive (list nil));; (cvs-flags-query 'cvs-undo-flags "undo flags")
2070 (if current-prefix-arg (call-interactively 'cvs-mode-revert-to-rev)
2071 (let* ((fis (cvs-do-removal 'undo "update" 'all))
2072 (removedp (lambda (fi)
2073 (or (eq (cvs-fileinfo->type fi) 'REMOVED)
2074 (and (eq (cvs-fileinfo->type fi) 'CONFLICT)
2075 (eq (cvs-fileinfo->subtype fi) 'REMOVED)))))
2076 (fis-split (cvs-partition removedp fis))
2077 (fis-removed (car fis-split))
2078 (fis-other (cdr fis-split)))
2079 (if (null fis-other)
2080 (when fis-removed (cvs-mode-run "add" nil fis-removed))
2081 (cvs-mode-run "update" flags fis-other
2082 :postproc
2083 (when fis-removed
2084 `((with-current-buffer ,(current-buffer)
2085 (cvs-mode-run "add" nil ',fis-removed)))))))))
2088 (defun-cvs-mode (cvs-mode-revert-to-rev . NOARGS) (rev)
2089 "Revert the selected files to an old revision."
2090 (interactive
2091 (list (or (cvs-prefix-get 'cvs-branch-prefix)
2092 (let ((current-prefix-arg '(4)))
2093 (cvs-flags-query 'cvs-idiff-version)))))
2094 (let* ((fis (cvs-mode-marked 'revert "revert" :file t))
2095 (tag (concat "tmp_pcl_tag_" (make-temp-name "")))
2096 (untag `((with-current-buffer ,(current-buffer)
2097 (cvs-mode-run "tag" (list "-d" ',tag) ',fis))))
2098 (update `((with-current-buffer ,(current-buffer)
2099 (cvs-mode-run "update" (list "-j" ',tag "-j" ',rev) ',fis
2100 :postproc ',untag)))))
2101 (cvs-mode-run "tag" (list tag) fis :postproc update)))
2104 (defun-cvs-mode cvs-mode-delete-lock ()
2105 "Delete the lock file that CVS is waiting for.
2106 Note that this can be dangerous. You should only do this
2107 if you are convinced that the process that created the lock is dead."
2108 (interactive)
2109 (let* ((default-directory (cvs-expand-dir-name cvs-lock-file))
2110 (locks (directory-files default-directory nil cvs-lock-file-regexp)))
2111 (cond
2112 ((not locks) (error "No lock files found"))
2113 ((yes-or-no-p (concat "Really delete locks in " cvs-lock-file "? "))
2114 (dolist (lock locks)
2115 (cond ((file-directory-p lock) (delete-directory lock))
2116 ((file-exists-p lock) (delete-file lock))))))))
2119 (defun-cvs-mode cvs-mode-remove-handled ()
2120 "Remove all lines that are handled.
2121 Empty directories are removed."
2122 (interactive)
2123 (cvs-cleanup-collection cvs-cookies
2124 t (or cvs-auto-remove-directories 'handled) t))
2127 (defun-cvs-mode cvs-mode-acknowledge ()
2128 "Remove all marked files from the buffer."
2129 (interactive)
2130 (dolist (fi (cvs-get-marked (cvs-ignore-marks-p "acknowledge") t))
2131 (setf (cvs-fileinfo->type fi) 'DEAD))
2132 (cvs-cleanup-collection cvs-cookies nil nil nil))
2134 (defun cvs-do-removal (filter &optional cmd all)
2135 "Remove files.
2136 Returns a list of FIS that should be `cvs remove'd."
2137 (let* ((files (cvs-mode-marked filter cmd :file t :read-only t))
2138 (fis (cdr (cvs-partition (lambda (fi)
2139 (eq (cvs-fileinfo->type fi) 'UNKNOWN))
2140 (cvs-mode-marked filter cmd))))
2141 (silent (or (not cvs-confirm-removals)
2142 (cvs-every (lambda (fi)
2143 (or (not (file-exists-p
2144 (cvs-fileinfo->full-name fi)))
2145 (cvs-applicable-p fi 'safe-rm)))
2146 files)))
2147 (tmpbuf (cvs-temp-buffer)))
2148 (when (and (not silent) (equal cvs-confirm-removals 'list))
2149 (with-current-buffer tmpbuf
2150 (let ((inhibit-read-only t))
2151 (cvs-insert-strings (mapcar 'cvs-fileinfo->full-name fis))
2152 (cvs-pop-to-buffer-same-frame (current-buffer))
2153 (shrink-window-if-larger-than-buffer))))
2154 (if (not (or silent
2155 (unwind-protect
2156 (yes-or-no-p
2157 (let ((nfiles (length files))
2158 (verb (if (eq filter 'undo) "Undo" "Delete")))
2159 (if (= 1 nfiles)
2160 (format "%s file: \"%s\" ? "
2161 verb
2162 (cvs-fileinfo->file (car files)))
2163 (format "%s %d files? "
2164 verb
2165 nfiles))))
2166 (cvs-bury-buffer tmpbuf cvs-buffer))))
2167 (progn (message "Aborting") nil)
2168 (dolist (fi files)
2169 (let* ((type (cvs-fileinfo->type fi))
2170 (file (cvs-fileinfo->full-name fi)))
2171 (when (or all (eq type 'UNKNOWN))
2172 (when (file-exists-p file) (delete-file file))
2173 (unless all (setf (cvs-fileinfo->type fi) 'DEAD) t))))
2174 fis)))
2176 (defun-cvs-mode (cvs-mode-remove . SIMPLE) (flags)
2177 "Remove all marked files.
2178 With prefix argument, prompt for cvs flags."
2179 (interactive (list (cvs-flags-query 'cvs-remove-flags "cvs remove flags")))
2180 (let ((fis (cvs-do-removal 'remove)))
2181 (if fis (cvs-mode-run "remove" (cons "-f" flags) fis)
2182 (cvs-cleanup-collection cvs-cookies nil nil nil))))
2185 (defvar cvs-tag-name "")
2186 (defun-cvs-mode (cvs-mode-tag . SIMPLE) (tag &optional flags)
2187 "Run `cvs tag TAG' on all selected files.
2188 With prefix argument, prompt for cvs flags.
2189 By default this can only be used on directories.
2190 Use \\[cvs-mode-force-command] or change `cvs-force-dir-tag' if you need
2191 to use it on individual files."
2192 (interactive
2193 (list (setq cvs-tag-name
2194 (cvs-query-read cvs-tag-name "Tag name: " cvs-qtypedesc-tag))
2195 (cvs-flags-query 'cvs-tag-flags "tag flags")))
2196 (cvs-mode-do "tag" (append flags (list tag))
2197 (when cvs-force-dir-tag 'tag)))
2199 (defun-cvs-mode (cvs-mode-untag . SIMPLE) (tag &optional flags)
2200 "Run `cvs tag -d TAG' on all selected files.
2201 With prefix argument, prompt for cvs flags."
2202 (interactive
2203 (list (setq cvs-tag-name
2204 (cvs-query-read cvs-tag-name "Tag to delete: " cvs-qtypedesc-tag))
2205 (cvs-flags-query 'cvs-tag-flags "tag flags")))
2206 (cvs-mode-do "tag" (append '("-d") flags (list tag))
2207 (when cvs-force-dir-tag 'tag)))
2210 ;; Byte compile files.
2212 (defun-cvs-mode cvs-mode-byte-compile-files ()
2213 "Run byte-compile-file on all selected files that end in '.el'."
2214 (interactive)
2215 (let ((marked (cvs-get-marked (cvs-ignore-marks-p "byte-compile"))))
2216 (dolist (fi marked)
2217 (let ((filename (cvs-fileinfo->full-name fi)))
2218 (when (string-match "\\.el\\'" filename)
2219 (byte-compile-file filename))))))
2221 ;; ChangeLog support.
2223 (defun-cvs-mode cvs-mode-add-change-log-entry-other-window ()
2224 "Add a ChangeLog entry in the ChangeLog of the current directory."
2225 (interactive)
2226 ;; Require `add-log' explicitly, because if it gets autoloaded when we call
2227 ;; add-change-log-entry-other-window below, the
2228 ;; add-log-buffer-file-name-function ends up unbound when we leave the `let'.
2229 (require 'add-log)
2230 (dolist (fi (cvs-mode-marked nil nil))
2231 (let* ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi)))
2232 (add-log-buffer-file-name-function
2233 (lambda ()
2234 (let ((file (expand-file-name (cvs-fileinfo->file fi))))
2235 (if (file-directory-p file)
2236 ;; Be careful to use a directory name, otherwise add-log
2237 ;; starts looking for a ChangeLog file in the
2238 ;; parent dir.
2239 (file-name-as-directory file)
2240 file)))))
2241 (kill-local-variable 'change-log-default-name)
2242 (save-excursion (add-change-log-entry-other-window)))))
2244 ;; interactive commands to set optional flags
2246 (defun cvs-mode-set-flags (flag)
2247 "Ask for new setting of cvs-FLAG-flags."
2248 (interactive
2249 (list (completing-read
2250 "Which flag: "
2251 '("cvs" "diff" "update" "status" "log" "tag" ;"rtag"
2252 "commit" "remove" "undo" "checkout")
2253 nil t)))
2254 (let* ((sym (intern (concat "cvs-" flag "-flags"))))
2255 (let ((current-prefix-arg '(16)))
2256 (cvs-flags-query sym (concat flag " flags")))))
2259 ;;;;
2260 ;;;; Utilities for the *cvs* buffer
2261 ;;;;
2263 (defun cvs-dir-member-p (fileinfo dir)
2264 "Return true if FILEINFO represents a file in directory DIR."
2265 (and (not (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE))
2266 (string-prefix-p dir (cvs-fileinfo->dir fileinfo))))
2268 (defun cvs-execute-single-file (fi extractor program constant-args)
2269 "Internal function for `cvs-execute-single-file-list'."
2270 (let* ((arg-list (funcall extractor fi))
2271 (inhibit-read-only t))
2273 ;; Execute the command unless extractor returned t.
2274 (when (listp arg-list)
2275 (let* ((args (append constant-args arg-list)))
2277 (insert (format "=== %s %s\n\n"
2278 program (split-string-and-unquote args)))
2280 ;; FIXME: return the exit status?
2281 (apply 'process-file program nil t t args)
2282 (goto-char (point-max))))))
2284 ;; FIXME: make this run in the background ala cvs-run-process...
2285 (defun cvs-execute-single-file-list (fis extractor program constant-args)
2286 "Run PROGRAM on all elements on FIS.
2287 CONSTANT-ARGS is a list of strings to pass as arguments to PROGRAM.
2288 The arguments given to the program will be CONSTANT-ARGS followed by
2289 the list that EXTRACTOR returns.
2291 EXTRACTOR will be called once for each file on FIS. It is given
2292 one argument, the cvs-fileinfo. It can return t, which means ignore
2293 this file, or a list of arguments to send to the program."
2294 (dolist (fi fis)
2295 (cvs-execute-single-file fi extractor program constant-args)))
2298 (defun cvs-revert-if-needed (fis)
2299 (dolist (fileinfo fis)
2300 (let* ((file (cvs-fileinfo->full-name fileinfo))
2301 (buffer (find-buffer-visiting file)))
2302 ;; For a revert to happen the user must be editing the file...
2303 (unless (or (null buffer)
2304 (memq (cvs-fileinfo->type fileinfo) '(MESSAGE UNKNOWN))
2305 ;; FIXME: check whether revert is really needed.
2306 ;; `(verify-visited-file-modtime buffer)' doesn't cut it
2307 ;; because it only looks at the time stamp (it ignores
2308 ;; read-write changes) which is not changed by `commit'.
2309 (buffer-modified-p buffer))
2310 (with-current-buffer buffer
2311 (ignore-errors
2312 (revert-buffer 'ignore-auto 'dont-ask 'preserve-modes)
2313 ;; `preserve-modes' avoids changing the (minor) modes. But we
2314 ;; do want to reset the mode for VC, so we do it explicitly.
2315 (vc-find-file-hook)
2316 (when (eq (cvs-fileinfo->type fileinfo) 'CONFLICT)
2317 (smerge-start-session))))))))
2320 (defun cvs-change-cvsroot (newroot)
2321 "Change the cvsroot."
2322 (interactive "DNew repository: ")
2323 (if (or (file-directory-p (expand-file-name "CVSROOT" newroot))
2324 (y-or-n-p (concat "Warning: no CVSROOT found inside repository."
2325 " Change cvs-cvsroot anyhow? ")))
2326 (setq cvs-cvsroot newroot)))
2328 ;;;;
2329 ;;;; useful global settings
2330 ;;;;
2333 ;; Hook to allow calling PCL-CVS by visiting the /CVS subdirectory
2336 ;;;###autoload
2337 (defcustom cvs-dired-action 'cvs-quickdir
2338 "The action to be performed when opening a CVS directory.
2339 Sensible values are `cvs-examine', `cvs-status' and `cvs-quickdir'."
2340 :group 'pcl-cvs
2341 :type '(choice (const cvs-examine) (const cvs-status) (const cvs-quickdir)))
2343 ;;;###autoload
2344 (defcustom cvs-dired-use-hook '(4)
2345 "Whether or not opening a CVS directory should run PCL-CVS.
2346 A value of nil means never do it.
2347 ALWAYS means to always do it unless a prefix argument is given to the
2348 command that prompted the opening of the directory.
2349 Anything else means to do it only if the prefix arg is equal to this value."
2350 :group 'pcl-cvs
2351 :type '(choice (const :tag "Never" nil)
2352 (const :tag "Always" always)
2353 (const :tag "Prefix" (4))))
2355 ;;;###autoload
2356 (progn (defun cvs-dired-noselect (dir)
2357 "Run `cvs-examine' if DIR is a CVS administrative directory.
2358 The exact behavior is determined also by `cvs-dired-use-hook'."
2359 (when (stringp dir)
2360 (setq dir (directory-file-name dir))
2361 (when (and (string= "CVS" (file-name-nondirectory dir))
2362 (file-readable-p (expand-file-name "Entries" dir))
2363 cvs-dired-use-hook
2364 (if (eq cvs-dired-use-hook 'always)
2365 (not current-prefix-arg)
2366 (equal current-prefix-arg cvs-dired-use-hook)))
2367 (save-excursion
2368 (funcall cvs-dired-action (file-name-directory dir) t t))))))
2371 ;; hook into VC
2374 (add-hook 'vc-post-command-functions 'cvs-vc-command-advice)
2376 (defun cvs-vc-command-advice (command files flags)
2377 (when (and (equal command "cvs")
2378 (progn
2379 (while (and (stringp (car flags))
2380 (string-match "\\`-" (car flags)))
2381 (pop flags))
2382 ;; don't parse output we don't understand.
2383 (member (car flags) cvs-parse-known-commands))
2384 ;; Don't parse "update -p" output.
2385 (not (and (member (car flags) '("update" "checkout"))
2386 (let ((found-p nil))
2387 (dolist (flag flags found-p)
2388 (if (equal flag "-p") (setq found-p t)))))))
2389 (save-current-buffer
2390 (let ((buffer (current-buffer))
2391 (dir default-directory)
2392 (cvs-from-vc t))
2393 (dolist (cvs-buf (buffer-list))
2394 (set-buffer cvs-buf)
2395 ;; look for a corresponding pcl-cvs buffer
2396 (when (and (eq major-mode 'cvs-mode)
2397 (string-prefix-p default-directory dir))
2398 (let ((subdir (substring dir (length default-directory))))
2399 (set-buffer buffer)
2400 (set (make-local-variable 'cvs-buffer) cvs-buf)
2401 ;; `cvs -q add file' produces no useful output :-(
2402 (when (and (equal (car flags) "add")
2403 (goto-char (point-min))
2404 (looking-at ".*to add this file permanently\n\\'"))
2405 (dolist (file (if (listp files) files (list files)))
2406 (insert "cvs add: scheduling file `"
2407 (file-name-nondirectory file)
2408 "' for addition\n")))
2409 ;; VC never (?) does `cvs -n update' so dcd=nil
2410 ;; should probably always be the right choice.
2411 (cvs-parse-process nil subdir))))))))
2414 ;; Hook into write-buffer
2417 (defun cvs-mark-buffer-changed ()
2418 (let* ((file (expand-file-name buffer-file-name))
2419 (version (and (fboundp 'vc-backend)
2420 (eq (vc-backend file) 'CVS)
2421 (vc-working-revision file))))
2422 (when version
2423 (save-excursion
2424 (dolist (cvs-buf (buffer-list))
2425 (set-buffer cvs-buf)
2426 ;; look for a corresponding pcl-cvs buffer
2427 (when (and (eq major-mode 'cvs-mode)
2428 (string-prefix-p default-directory file))
2429 (let* ((file (substring file (length default-directory)))
2430 (fi (cvs-create-fileinfo
2431 (if (string= "0" version)
2432 'ADDED 'MODIFIED)
2433 (or (file-name-directory file) "")
2434 (file-name-nondirectory file)
2435 "cvs-mark-buffer-changed")))
2436 (cvs-addto-collection cvs-cookies fi))))))))
2438 (add-hook 'after-save-hook 'cvs-mark-buffer-changed)
2440 (defun cvs-insert-visited-file ()
2441 (let* ((file (expand-file-name buffer-file-name))
2442 (version (and (fboundp 'vc-backend)
2443 (eq (vc-backend file) 'CVS)
2444 (vc-working-revision file))))
2445 (when version
2446 (save-current-buffer
2447 (dolist (cvs-buf (buffer-list))
2448 (set-buffer cvs-buf)
2449 ;; look for a corresponding pcl-cvs buffer
2450 (when (and (eq major-mode 'cvs-mode)
2451 (string-prefix-p default-directory file))
2452 (cvs-insert-file file)))))))
2454 (add-hook 'find-file-hook 'cvs-insert-visited-file 'append)
2456 (provide 'pcvs)
2458 ;;; pcvs.el ends here