1 ;;; pcvs.el --- a front-end to CVS
3 ;; Copyright (C) 1991,92,93,94,95,95,97,98,99,2000,2002
4 ;; Free Software Foundation, Inc.
6 ;; Author: (The PCL-CVS Trust) pcl-cvs@cyclic.com
7 ;; (Per Cederqvist) ceder@lysator.liu.se
8 ;; (Greg A. Woods) woods@weird.com
9 ;; (Jim Blandy) jimb@cyclic.com
10 ;; (Karl Fogel) kfogel@floss.red-bean.com
11 ;; (Jim Kingdon) kingdon@cyclic.com
12 ;; (Stefan Monnier) monnier@cs.yale.edu
13 ;; (Greg Klanderman) greg@alphatech.com
14 ;; (Jari Aalto+mail.emacs) jari.aalto@poboxes.com
15 ;; Maintainer: (Stefan Monnier) monnier+lists/cvs/pcl@flint.cs.yale.edu
16 ;; Keywords: CVS, version control, release management
17 ;; Revision: $Id: pcvs.el,v 1.40 2002/09/13 18:25:26 monnier Exp $
19 ;; This file is part of GNU Emacs.
21 ;; GNU Emacs is free software; you can redistribute it and/or modify
22 ;; it under the terms of the GNU General Public License as published by
23 ;; the Free Software Foundation; either version 2, or (at your option)
26 ;; GNU Emacs is distributed in the hope that it will be useful,
27 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
28 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
29 ;; GNU General Public License for more details.
31 ;; You should have received a copy of the GNU General Public License
32 ;; along with GNU Emacs; see the file COPYING. If not, write to the
33 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
34 ;; Boston, MA 02111-1307, USA.
38 ;; PCL-CVS is a front-end to the CVS version control system. For people
39 ;; familiar with VC, it is somewhat like VC-dired: it presents the status of
40 ;; all the files in your working area and allows you to commit/update several
41 ;; of them at a time. Compared to VC-dired, it is considerably better and
42 ;; faster (but only for CVS).
44 ;; PCL-CVS was originally written by Per Cederqvist many years ago. This
45 ;; version derives from the XEmacs-21 version, itself based on the 2.0b2
46 ;; version (last release from Per). It is a thorough rework.
48 ;; Contrary to what you'd expect, PCL-CVS is not a replacement for VC but only
49 ;; for VC-dired. As such, I've tried to make PCL-CVS and VC interoperate
50 ;; seamlessly (I also use VC).
52 ;; To use PCL-CVS just use `M-x cvs-examine RET <dir> RET'.
53 ;; There is a TeXinfo manual, which can be helpful to get started.
57 ;; - Extracting an old version seems not to recognize encoding correctly.
58 ;; That's probably because it's done via a process rather than a file.
62 ;; ******** FIX THE DOCUMENTATION *********
64 ;; - rework the displaying of error messages.
65 ;; - allow to flush messages only
66 ;; - allow to protect files like ChangeLog from flushing
67 ;; - automatically cvs-mode-insert files from find-file-hook
68 ;; (and don't flush them as long as they are visited)
69 ;; - query the user for cvs-get-marked (for some cmds or if nothing's selected)
70 ;; - don't return the first (resp last) FI if the cursor is before
72 ;; - allow cvs-confirm-removals to force always confirmation.
73 ;; - cvs-checkout should ask for a revision (with completion).
74 ;; - removal confirmation should allow specifying another file name.
76 ;; - hide fileinfos without getting rid of them (will require ewok work).
77 ;; - add toolbar entries
79 ;; marking directories should jump to just after the dir.
80 ;; allow (un)marking directories at a time with the mouse.
81 ;; allow cvs-cmd-do to either clear the marks or not.
82 ;; add a "marks active" notion, like transient-mark-mode does.
83 ;; - liveness indicator
84 ;; - indicate in docstring if the cmd understands the `b' prefix(es).
85 ;; - call smerge-mode when opening CONFLICT files.
86 ;; - have vc-checkin delegate to cvs-mode-commit when applicable
87 ;; - higher-level CVS operations
90 ;; - module-level commands
91 ;; add support for parsing 'modules' file ("cvs co -c")
96 ;; C-u M-x cvs-checkout should ask for a cvsroot
97 ;; cvs-mode-handle-new-vendor-version
98 ;; - checks out module, or alternately does update join
99 ;; - does "cvs -n tag LAST_VENDOR" to find old files into *cvs*
101 ;; (with completion on tag names and hooks to help generate full releases)
102 ;; - display stickiness information. And current CVS/Tag as well.
103 ;; - write 'cvs-mode-admin' to do arbitrary 'cvs admin' commands
104 ;; Most interesting would be version removal and log message replacement.
105 ;; The last one would be neat when called from log-view-mode.
106 ;; - cvs-mode-incorporate
107 ;; It would merge in the status from one *cvs* buffer into another.
108 ;; This would be used to populate such a buffer that had been created with
109 ;; a `cvs {update,status,checkout} -l'.
110 ;; - cvs-mode-(i)diff-other-{file,buffer,cvs-buffer}
111 ;; - offer the choice to kill the process when the user kills the cvs buffer.
112 ;; right now, it's killed without further ado.
113 ;; - make `cvs-mode-ignore' allow manually entering a pattern.
114 ;; to which dir should it apply ?
115 ;; - cvs-mode-ignore should try to remove duplicate entries.
116 ;; - maybe poll/check CVS/Entries files to react to external `cvs' commands ?
117 ;; - some kind of `cvs annotate' support ?
118 ;; but vc-annotate can be used instead.
119 ;; - proper `g' that passes safe args and uses either cvs-status or cvs-examine
120 ;; maybe also use cvs-update depending on I-don't-know-what.
121 ;; - add message-levels so that we can hide some levels of messages
125 (eval-when-compile (require 'cl
))
126 (require 'ewoc
) ;Ewoc was once cookie
129 (require 'pcvs-parse
)
137 (defvar cvs-cookies
) ;;nil
138 ;;"Handle for the cookie structure that is displayed in the *cvs* buffer.")
139 ;;(make-variable-buffer-local 'cvs-cookies)
142 ;;;; Dynamically scoped variables
145 (defvar cvs-from-vc nil
"Bound to t inside VC advice.")
151 (defun cvs-defaults (&rest defs
)
152 (let ((defs (cvs-first defs cvs-shared-start
)))
154 (make-list (- cvs-shared-start
(length defs
)) (car defs
))
157 ;; For cvs flags, we need to add "-f" to override the cvsrc settings
158 ;; we also want to evict the annoying -q and -Q options that hide useful
159 ;; information from pcl-cvs.
160 (cvs-flags-define cvs-cvs-flags
'(("-f")))
162 (cvs-flags-define cvs-checkout-flags
(cvs-defaults '("-P")))
163 (cvs-flags-define cvs-status-flags
(cvs-defaults '("-v") nil
))
164 (cvs-flags-define cvs-log-flags
(cvs-defaults nil
))
165 (cvs-flags-define cvs-diff-flags
(cvs-defaults '("-u" "-N") '("-c" "-N") '("-u" "-b")))
166 (cvs-flags-define cvs-tag-flags
(cvs-defaults nil
))
167 (cvs-flags-define cvs-add-flags
(cvs-defaults nil
))
168 (cvs-flags-define cvs-commit-flags
(cvs-defaults nil
))
169 (cvs-flags-define cvs-remove-flags
(cvs-defaults nil
))
170 ;;(cvs-flags-define cvs-undo-flags (cvs-defaults nil))
171 (cvs-flags-define cvs-update-flags
(cvs-defaults '("-d" "-P")))
173 (defun cvs-reread-cvsrc ()
174 "Reset the default arguments to those in the `cvs-cvsrc-file'."
178 (insert-file-contents cvs-cvsrc-file
)
180 (dolist (cmd '("cvs" "checkout" "status" "log" "diff" "tag"
181 "add" "commit" "remove" "update"))
182 (goto-char (point-min))
183 (when (re-search-forward
184 (concat "^" cmd
"\\(\\s-+\\(.*\\)\\)?$") nil t
)
185 (let* ((sym (intern (concat "cvs-" cmd
"-flags")))
186 (val (cvs-string->strings
(or (match-string 2) ""))))
187 (cvs-flags-set sym
0 val
))))
188 ;; ensure that cvs doesn't have -q or -Q
189 (cvs-flags-set 'cvs-cvs-flags
0
192 (lambda (x) (member x
'("-q" "-Q" "-f")))
193 (cvs-flags-query 'cvs-cvs-flags
197 ;; initialize to cvsrc's default values
202 ;;;; Mouse bindings and mode motion
206 "Popup the CVS menu."
208 (let ((cvs-minor-current-files
209 (list (ewoc-data (ewoc-locate
210 cvs-cookies
(posn-point (event-end e
)))))))
211 (popup-menu cvs-menu e
)))
213 (defvar cvs-mode-line-process nil
214 "Mode-line control for displaying info on cvs process status.")
218 ;;;; Query-Type-Descriptor for Tags
221 (autoload 'cvs-status-get-tags
"cvs-status")
222 (defun cvs-tags-list ()
223 "Return a list of acceptable tags, ready for completions."
224 (assert (cvs-buffer-p))
225 (let ((marked (cvs-get-marked)))
226 (list* '("BASE") '("HEAD")
229 (call-process cvs-program
231 t
;output to current-buffer
232 nil
;don't update display while running
235 (cvs-fileinfo->full-path
(car marked
)))
236 (goto-char (point-min))
237 (let ((tags (cvs-status-get-tags)))
238 (when (listp tags
) tags
)))))))
240 (defvar cvs-tag-history nil
)
241 (defconst cvs-qtypedesc-tag
242 (cvs-qtypedesc-create 'identity
'identity
'cvs-tags-list
'cvs-tag-history
))
246 (defun cvs-mode! (&optional -cvs-mode
!-fun -cvs-mode
!-noerror
)
247 "Switch to the *cvs* buffer.
248 If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer
249 and with its window selected. Else, the *cvs* buffer is simply selected.
250 If -CVS-MODE!-NOERROR is non-nil, then failure to find a *cvs* buffer does
251 not generate an error and the current buffer is kept selected.
252 -CVS-MODE!-FUN is called interactively if applicable and else with no argument."
253 (let* ((-cvs-mode!-buf
(current-buffer))
254 (cvsbuf (cond ((cvs-buffer-p) (current-buffer))
255 ((and cvs-buffer
(cvs-buffer-p cvs-buffer
)) cvs-buffer
)
256 (-cvs-mode!-noerror
(current-buffer))
257 (t (error "can't find the *cvs* buffer"))))
258 (-cvs-mode!-wrapper cvs-minor-wrap-function
)
259 (-cvs-mode!-cont
(lambda ()
261 (if (commandp -cvs-mode
!-fun
)
262 (call-interactively -cvs-mode
!-fun
)
263 (funcall -cvs-mode
!-fun
))))))
264 (if (not -cvs-mode
!-fun
) (set-buffer cvsbuf
)
265 (let ((cvs-mode!-buf
(current-buffer))
266 (cvs-mode!-owin
(selected-window))
267 (cvs-mode!-nwin
(get-buffer-window cvsbuf
'visible
)))
271 (when cvs-mode
!-nwin
(select-window cvs-mode
!-nwin
))
272 (if -cvs-mode
!-wrapper
273 (funcall -cvs-mode
!-wrapper -cvs-mode
!-buf -cvs-mode
!-cont
)
274 (funcall -cvs-mode
!-cont
)))
275 (set-buffer cvs-mode
!-buf
)
276 (when (and cvs-mode
!-nwin
(eq cvs-mode
!-nwin
(selected-window)))
277 ;; the selected window has not been changed by FUN
278 (select-window cvs-mode
!-owin
)))))))
284 (defvar cvs-branches
(list cvs-vendor-branch
"HEAD" "HEAD"))
285 (cvs-prefix-define cvs-branch-prefix
286 "Current selected branch."
288 (cons cvs-vendor-branch cvs-branches
)
291 (defun cvs-set-branch-prefix (arg)
292 "Set the branch prefix to take action at the next command.
293 See `cvs-prefix-set' for a further the description of the behavior.
294 \\[universal-argument] 1 selects the vendor branch
295 and \\[universal-argument] 2 selects the HEAD."
298 (cvs-prefix-set 'cvs-branch-prefix arg
))
300 (defun cvs-add-branch-prefix (flags &optional arg
)
301 "Add branch selection argument if the branch prefix was set.
302 The argument is added (or not) to the list of FLAGS and is constructed
303 by appending the branch to ARG which defaults to \"-r\"."
304 (let ((branch (cvs-prefix-get 'cvs-branch-prefix
)))
305 ;; deactivate the secondary prefix, even if not used.
306 (cvs-prefix-get 'cvs-secondary-branch-prefix
)
307 (if branch
(cons (concat (or arg
"-r") branch
) flags
) flags
)))
309 (cvs-prefix-define cvs-secondary-branch-prefix
310 "Current secondary selected branch."
312 (cons cvs-vendor-branch cvs-branches
)
315 (defun cvs-set-secondary-branch-prefix (arg)
316 "Set the branch prefix to take action at the next command.
317 See `cvs-prefix-set' for a further the description of the behavior.
318 \\[universal-argument] 1 selects the vendor branch
319 and \\[universal-argument] 2 selects the HEAD."
322 (cvs-prefix-set 'cvs-secondary-branch-prefix arg
))
324 (defun cvs-add-secondary-branch-prefix (flags &optional arg
)
325 "Add branch selection argument if the secondary branch prefix was set.
326 The argument is added (or not) to the list of FLAGS and is constructed
327 by appending the branch to ARG which defaults to \"-r\".
328 Since the `cvs-secondary-branch-prefix' is only active if the primary
329 prefix is active, it is important to read the secondary prefix before
330 the primay since reading the primary can deactivate it."
331 (let ((branch (and (cvs-prefix-get 'cvs-branch-prefix
'read-only
)
332 (cvs-prefix-get 'cvs-secondary-branch-prefix
))))
333 (if branch
(cons (concat (or arg
"-r") branch
) flags
) flags
)))
337 (define-minor-mode cvs-minor-mode
338 "This mode is used for buffers related to a main *cvs* buffer.
339 All the `cvs-mode' buffer operations are simply rebound under
340 the \\[cvs-mode-map] prefix."
342 (put 'cvs-minor-mode
'permanent-local t
)
345 (defvar cvs-temp-buffers nil
)
346 (defun cvs-temp-buffer (&optional cmd normal nosetup
)
347 "Create a temporary buffer to run CMD in.
348 If CMD is a string, use it to lookup `cvs-buffer-name-alist' to find
349 the buffer name to be used and its `major-mode'.
351 The selected window will not be changed. The new buffer will not maintain undo
352 information and will be read-only unless NORMAL is non-nil. It will be emptied
353 \(unless NOSETUP is non-nil\) and its `default-directory' will be inherited
354 from the current buffer."
355 (let* ((cvs-buf (current-buffer))
356 (info (cdr (assoc cmd cvs-buffer-name-alist
)))
357 (name (eval (nth 0 info
)))
359 (dir default-directory
)
361 (name (cvs-get-buffer-create name
))
362 ((and (bufferp cvs-temp-buffer
) (buffer-name cvs-temp-buffer
))
365 (set (make-local-variable 'cvs-temp-buffer
)
366 (cvs-get-buffer-create
367 (eval cvs-temp-buffer-name
) 'noreuse
))))))
369 ;; handle the potential pre-existing process
370 (let ((proc (get-buffer-process buf
)))
371 (when (and (not normal
) (processp proc
)
372 (memq (process-status proc
) '(run stop
)))
373 (error "Can not run two cvs processes simultaneously")))
375 (if (not name
) (kill-local-variable 'other-window-scroll-buffer
)
376 ;; Strangely, if no window is created, `display-buffer' ends up
377 ;; doing a `switch-to-buffer' which does a `set-buffer', hence
378 ;; the need for `save-excursion'.
379 (unless nosetup
(save-excursion (display-buffer buf
)))
380 ;; FIXME: this doesn't do the right thing if the user later on
381 ;; does a `find-file-other-window' and `scroll-other-window'
382 (set (make-local-variable 'other-window-scroll-buffer
) buf
))
384 (add-to-list 'cvs-temp-buffers buf
)
386 (with-current-buffer buf
387 (setq buffer-read-only nil
)
388 (setq default-directory dir
)
389 (unless nosetup
(erase-buffer))
390 (set (make-local-variable 'cvs-buffer
) cvs-buf
)
392 (let ((lbd list-buffers-directory
))
393 (if (fboundp mode
) (funcall mode
) (fundamental-mode))
394 (when lbd
(set (make-local-variable 'list-buffers-directory
) lbd
)))
396 ;;(set (make-local-variable 'cvs-buffer) cvs-buf)
398 (setq buffer-read-only t
)
399 (buffer-disable-undo))
402 (defun cvs-mode-kill-buffers ()
403 "Kill all the \"temporary\" buffers created by the *cvs* buffer."
405 (dolist (buf cvs-temp-buffers
) (ignore-errors (kill-buffer buf
))))
407 (defun cvs-make-cvs-buffer (dir &optional new
)
408 "Create the *cvs* buffer for directory DIR.
409 If non-nil, NEW means to create a new buffer no matter what."
410 ;; the real cvs-buffer creation
411 (setq dir
(cvs-expand-dir-name dir
))
412 (let* ((buffer-name (eval cvs-buffer-name
))
415 (eq cvs-reuse-cvs-buffer
'current
)
416 (cvs-buffer-p) ;reuse the current buffer if possible
418 ;; look for another cvs buffer visiting the same directory
421 (dolist (buffer (cons (current-buffer) (buffer-list)))
424 (case cvs-reuse-cvs-buffer
427 (or (cvs-string-prefix-p default-directory dir
)
428 (cvs-string-prefix-p dir default-directory
)))
429 (samedir (string= default-directory dir
)))
431 ;; we really have to create a new buffer:
432 ;; we temporarily bind cwd to "" to prevent
433 ;; create-file-buffer from using directory info
434 ;; unless it is explicitly in the cvs-buffer-name.
435 (cvs-get-buffer-create buffer-name new
))))
436 (with-current-buffer buffer
438 (and (string= dir default-directory
) (cvs-buffer-p)
441 (cvs-cleanup-collection cvs-cookies nil nil t
)
443 ;; setup from scratch
445 (setq default-directory dir
)
446 (setq buffer-read-only nil
)
449 Repository : " (directory-file-name (cvs-get-cvsroot)) "
450 Module : " (cvs-get-module) "
451 Working dir: " (abbreviate-file-name dir
) "
454 (setq buffer-read-only t
)
456 (set (make-local-variable 'list-buffers-directory
) buffer-name
)
457 ;;(set (make-local-variable 'cvs-temp-buffer) (cvs-temp-buffer))
458 (let ((cookies (ewoc-create 'cvs-fileinfo-pp
"\n" "")))
459 (set (make-local-variable 'cvs-cookies
) cookies
)
460 (add-hook 'kill-buffer-hook
462 (ignore-errors (kill-buffer cvs-temp-buffer
)))
467 (defun* cvs-cmd-do
(cmd dir flags fis new
468 &key cvsargs noexist dont-change-disc noshow
)
469 (let* ((dir (file-name-as-directory
470 (abbreviate-file-name (expand-file-name dir
))))
471 (cvsbuf (cvs-make-cvs-buffer dir new
)))
472 ;; Check that dir is under CVS control.
473 (unless (file-directory-p dir
)
474 (error "%s is not a directory" dir
))
475 (unless (or noexist
(file-directory-p (expand-file-name "CVS" dir
))
476 (file-expand-wildcards (expand-file-name "*/CVS" dir
)))
477 (error "%s does not contain CVS controlled files" dir
))
480 (cvs-mode-run cmd flags fis
481 :cvsargs cvsargs
:dont-change-disc dont-change-disc
)
484 (let ((pop-up-windows nil
)) (pop-to-buffer cvsbuf
)))))
485 ;; (funcall (if (and (boundp 'pop-up-frames) pop-up-frames)
486 ;; 'pop-to-buffer 'switch-to-buffer)
489 (defun cvs-run-process (args fis postprocess
&optional single-dir
)
490 (assert (cvs-buffer-p cvs-buffer
))
492 (let ((procbuf (current-buffer))
494 (single-dir (or single-dir
(eq cvs-execute-single-dir t
))))
497 (goto-char (point-max))
498 (unless (bolp) (let ((inhibit-read-only t
)) (insert "\n")))
499 ;; find the set of files we'll process in this round
500 (let* ((dir+files
+rest
501 (if (or (null fis
) (not single-dir
))
502 ;; not single-dir mode: just process the whole thing
503 (list "" (mapcar 'cvs-fileinfo-
>full-path fis
) nil
)
504 ;; single-dir mode: extract the same-dir-elements
505 (let ((dir (cvs-fileinfo->dir
(car fis
))))
506 ;; output the concerned dir so the parser can translate paths
507 (let ((inhibit-read-only t
))
508 (insert "pcl-cvs: descending directory " dir
"\n"))
509 ;; loop to find the same-dir-elems
510 (do* ((files () (cons (cvs-fileinfo->file fi
) files
))
512 (fi (car fis
) (car fis
)))
513 ((not (and fis
(string= dir
(cvs-fileinfo->dir fi
))))
514 (list dir files fis
))))))
515 (dir (nth 0 dir
+files
+rest
))
516 (files (nth 1 dir
+files
+rest
))
517 (rest (nth 2 dir
+files
+rest
)))
519 ;; setup the (current) process buffer
520 (set (make-local-variable 'cvs-postprocess
)
522 ;; this is the last invocation
524 ;; else, we have to register ourselves to be rerun on the rest
525 `(cvs-run-process ',args
',rest
',postprocess
',single-dir
)))
526 (add-hook 'kill-buffer-hook
528 (let ((proc (get-buffer-process (current-buffer))))
529 (when (processp proc
)
530 (set-process-filter proc nil
)
531 (set-process-sentinel proc nil
)
532 (delete-process proc
))))
535 ;; create the new process and setup the procbuffer correspondingly
536 (let* ((args (append (cvs-flags-query 'cvs-cvs-flags nil
'noquery
)
537 (if cvs-cvsroot
(list "-d" cvs-cvsroot
))
540 ;; If process-connection-type is nil and the repository
541 ;; is accessed via SSH, a bad interaction between libc,
542 ;; CVS and SSH can lead to garbled output.
543 ;; It might be a glibc-specific problem.
544 ;; Until the problem is cleared, we'll use a pty rather than
546 ;; (process-connection-type nil) ; Use a pipe, not a pty.
548 ;; the process will be run in the selected dir
549 (let ((default-directory (cvs-expand-dir-name dir
)))
550 (apply 'start-process
"cvs" procbuf cvs-program args
))))
551 (set-process-sentinel process
'cvs-sentinel
)
552 (set-process-filter process
'cvs-update-filter
)
553 (set-marker (process-mark process
) (point-max))
554 (ignore-errors (process-send-eof process
)) ;close its stdin to avoid hangs
556 ;; now finish setting up the cvs-buffer
558 (setq cvs-mode-line-process
(symbol-name (process-status process
)))
559 (force-mode-line-update)))))
561 ;; The following line is said to improve display updates on some
562 ;; emacsen. It shouldn't be needed, but it does no harm.
565 (defun cvs-update-header (args fis
) ; inline
567 (args (mapcar (lambda (arg)
569 ;; filter out the largish commit message
570 ((and (eq lastarg nil
) (string= arg
"commit"))
571 (setq lastarg
'commit
) arg
)
572 ((and (eq lastarg
'commit
) (string= arg
"-m"))
573 (setq lastarg
'-m
) arg
)
575 (setq lastarg
'done
) "<log message>")
576 ;; filter out the largish `admin -mrev:msg' message
577 ((and (eq lastarg nil
) (string= arg
"admin"))
578 (setq lastarg
'admin
) arg
)
579 ((and (eq lastarg
'admin
)
580 (string-match "\\`-m[^:]*:" arg
))
582 (concat (match-string 0 arg
) "<log message>"))
583 ;; Keep the rest as is.
586 ;; turn them into a string
587 (arg (cvs-strings->string
588 (append (cvs-flags-query 'cvs-cvs-flags nil
'noquery
)
589 (if cvs-cvsroot
(list "-d" cvs-cvsroot
))
591 (mapcar 'cvs-fileinfo-
>full-path fis
))))
592 (str (if args
(concat "-- Running " cvs-program
" " arg
" ...\n")
594 (if nil
(insert str
) ;inline
595 ;;(with-current-buffer cvs-buffer
596 (let* ((prev-msg (car (ewoc-get-hf cvs-cookies
)))
597 (tin (ewoc-nth cvs-cookies
0)))
598 ;; look for the first *real* fileinfo (to determine emptyness)
601 (memq (cvs-fileinfo->type
(ewoc-data tin
))
602 '(MESSAGE DIRCHANGE
)))
603 (setq tin
(ewoc-next cvs-cookies tin
)))
604 ;; cleanup the prev-msg
605 (when (string-match "Running \\(.*\\) ...\n" prev-msg
)
609 (match-string 1 prev-msg
)
611 ;; set the new header and footer
612 (ewoc-set-hf cvs-cookies
613 str
(concat "\n--------------------- "
614 (if tin
"End" "Empty")
615 " ---------------------\n"
619 (defun cvs-sentinel (proc msg
)
620 "Sentinel for the cvs update process.
621 This is responsible for parsing the output from the cvs update when
623 (when (memq (process-status proc
) '(signal exit
))
624 (if (null (buffer-name (process-buffer proc
)))
625 ;;(set-process-buffer proc nil)
626 (error "cvs' process buffer was killed")
627 (let* ((obuf (current-buffer))
628 (procbuffer (process-buffer proc
)))
629 (set-buffer (with-current-buffer procbuffer cvs-buffer
))
630 (setq cvs-mode-line-process
(symbol-name (process-status proc
)))
631 (force-mode-line-update)
632 (set-buffer procbuffer
)
633 (let ((cvs-postproc cvs-postprocess
))
634 ;; Since the buffer and mode line will show that the
635 ;; process is dead, we can delete it now. Otherwise it
636 ;; will stay around until M-x list-processes.
637 (delete-process proc
)
638 (setq cvs-postprocess nil
)
639 ;; do the postprocessing like parsing and such
640 (save-excursion (eval cvs-postproc
))
641 ;; check whether something is left
642 (unless cvs-postprocess
643 ;; IIRC, we enable undo again once the process is finished
644 ;; for cases where the output was inserted in *vc-diff* or
645 ;; in a file-like buffer. -stef
647 (with-current-buffer cvs-buffer
648 (cvs-update-header nil nil
) ;FIXME: might need to be inline
649 (message "CVS process has completed"))))
650 ;; This might not even be necessary
651 (set-buffer obuf
)))))
653 (defun cvs-parse-process (dcd &optional subdir old-fis
)
654 "Parse the output of a cvs process.
655 DCD is the `dont-change-disc' flag to use when parsing that output.
656 SUBDIR is the subdirectory (if any) where this command was run.
657 OLD-FIS is the list of fileinfos on which the cvs command was applied and
658 which should be considered up-to-date if they are missing from the output."
659 (let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir
))
661 (with-current-buffer cvs-buffer
662 ;; Expand OLD-FIS to actual files.
665 (setq fis
(if (eq (cvs-fileinfo->type fi
) 'DIRCHANGE
)
666 (nconc (ewoc-collect cvs-cookies
'cvs-dir-member-p
667 (cvs-fileinfo->dir fi
))
671 ;; Drop OLD-FIS which were already up-to-date.
674 (unless (eq (cvs-fileinfo->type fi
) 'UP-TO-DATE
) (push fi fis
)))
676 ;; Add the new fileinfos to the ewoc.
677 (dolist (fi fileinfos
)
678 (setq last
(cvs-addto-collection cvs-cookies fi last
))
679 ;; This FI was in the output, so remove it from OLD-FIS.
680 (setq old-fis
(delq (ewoc-data last
) old-fis
)))
681 ;; Process the "silent output" (i.e. absence means up-to-date).
683 (setf (cvs-fileinfo->type fi
) 'UP-TO-DATE
)
684 (setq last
(cvs-addto-collection cvs-cookies fi last
)))
685 (setq fileinfos
(nconc old-fis fileinfos
))
686 ;; Clean up the ewoc as requested by the user.
687 (cvs-cleanup-collection cvs-cookies
688 (eq cvs-auto-remove-handled t
)
689 cvs-auto-remove-directories
691 ;; Revert buffers if necessary.
692 (when (and cvs-auto-revert
(not dcd
) (not cvs-from-vc
))
693 (cvs-revert-if-needed fileinfos
)))))
695 (defmacro defun-cvs-mode
(fun args docstring interact
&rest body
)
696 "Define a function to be used in a *cvs* buffer.
697 This will look for a *cvs* buffer and execute BODY in it.
698 Since the interactive arguments might need to be queried after
699 switching to the *cvs* buffer, the generic code is rather ugly,
700 but luckily we can often use simpler alternatives.
702 FUN can be either a symbol (i.e. STYLE is nil) or a cons (FUN . STYLE).
703 ARGS and DOCSTRING are the normal argument list.
704 INTERACT is the interactive specification or nil for non-commands.
706 STYLE can be either SIMPLE, NOARGS or DOUBLE. It's an error for it
707 to have any other value, unless other details of the function make it
708 clear what alternative to use.
709 - SIMPLE will get all the interactive arguments from the original buffer.
710 - NOARGS will get all the arguments from the *cvs* buffer and will
711 always behave as if called interactively.
712 - DOUBLE is the generic case."
713 (declare (debug (&define sexp lambda-list stringp
("interactive" interactive
) def-body
)))
714 (let ((style (cvs-cdr fun
))
717 ;; a trivial interaction, no need to move it
718 ((or (eq style
'SIMPLE
)
719 (null (nth 1 interact
))
720 (stringp (nth 1 interact
)))
721 `(defun ,fun
,args
,docstring
,interact
722 (cvs-mode! (lambda () ,@body
))))
724 ;; fun is only called interactively: move all the args to the inner fun
726 `(defun ,fun
() ,docstring
(interactive)
727 (cvs-mode! (lambda ,args
,interact
,@body
))))
731 (string-match ".*" docstring
)
732 (let ((line1 (match-string 0 docstring
))
733 (restdoc (substring docstring
(match-end 0)))
734 (fun-1 (intern (concat (symbol-name fun
) "-1"))))
737 ,(concat docstring
"\nThis function only works within a *cvs* buffer.
738 For interactive use, use `" (symbol-name fun
) "' instead.")
742 ,(concat line1
"\nWrapper function that switches to a *cvs* buffer
743 before calling the real function `" (symbol-name fun-1
) "'.\n")
745 (cvs-mode! ',fun-1
)))))
747 (t (error "unknown style %s in `defun-cvs-mode'" style
)))))
749 (defun-cvs-mode cvs-mode-kill-process
()
750 "Kill the temporary buffer and associated process."
752 (when (and (bufferp cvs-temp-buffer
) (buffer-name cvs-temp-buffer
))
753 (let ((proc (get-buffer-process cvs-temp-buffer
)))
754 (when proc
(delete-process proc
)))))
757 ;; Maintaining the collection in the face of updates
760 (defun cvs-addto-collection (c fi
&optional tin
)
761 "Add FI to C and return FI's corresponding tin.
762 FI is inserted in its proper place or maybe even merged with a preexisting
763 fileinfo if applicable.
764 TIN specifies an optional starting point."
765 (unless tin
(setq tin
(ewoc-nth c
0)))
766 (while (and tin
(cvs-fileinfo< fi
(ewoc-data tin
)))
767 (setq tin
(ewoc-prev c tin
)))
768 (if (null tin
) (ewoc-enter-first c fi
) ;empty collection
769 (assert (not (cvs-fileinfo< fi
(ewoc-data tin
))))
770 (let ((next-tin (ewoc-next c tin
)))
771 (while (not (or (null next-tin
)
772 (cvs-fileinfo< fi
(ewoc-data next-tin
))))
773 (setq tin next-tin next-tin
(ewoc-next c next-tin
)))
774 (if (or (cvs-fileinfo< (ewoc-data tin
) fi
)
775 (eq (cvs-fileinfo->type fi
) 'MESSAGE
))
776 ;; tin < fi < next-tin
777 (ewoc-enter-after c tin fi
)
779 (cvs-fileinfo-update (ewoc-data tin
) fi
)
780 (ewoc-invalidate c tin
)
781 ;; Move cursor back to where it belongs.
782 (when (bolp) (cvs-move-to-goal-column))
785 (defcustom cvs-cleanup-functions nil
786 "Functions to tweak the cleanup process.
787 The functions are called with a single argument (a FILEINFO) and should
788 return a non-nil value if that fileinfo should be removed."
790 :type
'(hook :options
(cvs-cleanup-removed)))
792 (defun cvs-cleanup-removed (fi)
793 "Non-nil if FI has been cvs-removed but still exists.
794 This is intended for use on `cvs-cleanup-functions' when you have cvs-removed
795 automatically generated files (which should hence not be under CVS control)
796 but can't commit the removal because the repository's owner doesn't understand
798 (and (or (eq (cvs-fileinfo->type fi
) 'REMOVED
)
799 (and (eq (cvs-fileinfo->type fi
) 'CONFLICT
)
800 (eq (cvs-fileinfo->subtype fi
) 'REMOVED
)))
801 (file-exists-p (cvs-fileinfo->full-path fi
))))
803 ;; called at the following times:
804 ;; - postparse ((eq cvs-auto-remove-handled t) cvs-auto-remove-directories nil)
805 ;; - pre-run ((eq cvs-auto-remove-handled 'delayed) nil t)
806 ;; - remove-handled (t (or cvs-auto-remove-directories 'handled) t)
807 ;; - cvs-cmd-do (nil nil t)
808 ;; - post-ignore (nil nil nil)
809 ;; - acknowledge (nil nil nil)
810 ;; - remove (nil nil nil)
811 (defun cvs-cleanup-collection (c rm-handled rm-dirs rm-msgs
)
812 "Remove undesired entries.
814 RM-HANDLED if non-nil means remove handled entries.
815 RM-DIRS behaves like `cvs-auto-remove-directories'.
816 RM-MSGS if non-nil means remove messages."
817 (let (last-fi first-dir
(rerun t
))
821 (setq last-fi
(cvs-create-fileinfo 'DEAD
"../" "" "")) ;place-holder
824 (let* ((type (cvs-fileinfo->type fi
))
825 (subtype (cvs-fileinfo->subtype fi
))
828 ;; remove temp messages and keep the others
829 (MESSAGE (not (or rm-msgs
(eq subtype
'TEMP
))))
833 (UP-TO-DATE (not rm-handled
))
835 (t (not (run-hook-with-args-until-success
836 'cvs-cleanup-functions fi
))))))
838 ;; mark dirs for removal
839 (when (and keep rm-dirs
840 (eq (cvs-fileinfo->type last-fi
) 'DIRCHANGE
)
841 (not (when first-dir
(setq first-dir nil
) t
))
842 (or (eq rm-dirs
'all
)
843 (not (cvs-string-prefix-p
844 (cvs-fileinfo->dir last-fi
)
845 (cvs-fileinfo->dir fi
)))
846 (and (eq type
'DIRCHANGE
) (eq rm-dirs
'empty
))
847 (eq subtype
'FOOTER
)))
848 (setf (cvs-fileinfo->type last-fi
) 'DEAD
)
850 (when keep
(setq last-fi fi
)))))
851 ;; remove empty last dir
854 (eq (cvs-fileinfo->type last-fi
) 'DIRCHANGE
))
855 (setf (cvs-fileinfo->type last-fi
) 'DEAD
)
858 (defun cvs-get-cvsroot ()
859 "Gets the CVSROOT for DIR."
860 (let ((cvs-cvsroot-file (expand-file-name "Root" "CVS")))
861 (or (cvs-file-to-string cvs-cvsroot-file t
)
866 (defun cvs-get-module ()
867 "Return the current CVS module.
868 This usually doesn't really work but is a handy initval in a prompt."
869 (let* ((repfile (expand-file-name "Repository" "CVS"))
870 (rep (cvs-file-to-string repfile t
)))
873 ((not (file-name-absolute-p rep
)) rep
)
875 (let* ((root (cvs-get-cvsroot))
876 (str (concat (file-name-as-directory (or root
"/")) " || " rep
)))
877 (if (and root
(string-match "\\(.*\\) || \\1\\(.*\\)\\'" str
))
879 (file-name-nondirectory rep
)))))))
884 ;;;; running a "cvs checkout".
888 (defun cvs-checkout (modules dir flags
)
889 "Run a 'cvs checkout MODULES' in DIR.
890 Feed the output to a *cvs* buffer, display it in the current window,
891 and run `cvs-mode' on it.
893 With a prefix argument, prompt for cvs FLAGS to use."
895 (list (cvs-string->strings
(read-string "Module(s): " (cvs-get-module)))
896 (read-file-name "CVS Checkout Directory: "
897 nil default-directory nil
)
898 (cvs-add-branch-prefix
899 (cvs-flags-query 'cvs-checkout-flags
"cvs checkout flags"))))
901 (setf flags
(cvs-flags-query 'cvs-checkout-flags nil
'noquery
)))
902 (cvs-cmd-do "checkout" (or dir default-directory
)
903 (append flags modules
) nil
'new
908 ;;;; The code for running a "cvs update" and friends in various ways.
911 (defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE
)
912 (&optional ignore-auto noconfirm
)
913 "Rerun `cvs-examine' on the current directory with the default flags."
915 (cvs-examine default-directory t
))
917 (defun cvs-query-directory (msg)
918 ;; last-command-char = ?\r hints that the command was run via M-x
919 (if (and (cvs-buffer-p)
920 (not current-prefix-arg
)
921 (not (eq last-command-char ?
\r)))
923 (read-file-name msg nil default-directory nil
)))
926 (defun cvs-quickdir (dir &optional flags noshow
)
927 "Open a *cvs* buffer on DIR without running cvs.
928 With a prefix argument, prompt for a directory to use.
929 A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
930 prevents reuse of an existing *cvs* buffer.
931 Optional argument NOSHOW if non-nil means not to display the buffer.
933 (interactive (list (cvs-query-directory "CVS quickdir (directory): ")))
934 ;; FIXME: code duplication with cvs-cmd-do and cvs-parse-process
935 (let* ((dir (file-name-as-directory
936 (abbreviate-file-name (expand-file-name dir
))))
937 (new (> (prefix-numeric-value current-prefix-arg
) 8))
938 (cvsbuf (cvs-make-cvs-buffer dir new
))
940 ;; Check that dir is under CVS control.
941 (unless (file-directory-p dir
)
942 (error "%s is not a directory" dir
))
943 (unless (file-directory-p (expand-file-name "CVS" dir
))
944 (error "%s does not contain CVS controlled files" dir
))
946 (dolist (fi (cvs-fileinfo-from-entries ""))
947 (setq last
(cvs-addto-collection cvs-cookies fi last
)))
948 (cvs-cleanup-collection cvs-cookies
949 (eq cvs-auto-remove-handled t
)
950 cvs-auto-remove-directories
953 (let ((pop-up-windows nil
)) (pop-to-buffer cvsbuf
)))))
956 (defun cvs-examine (directory flags
&optional noshow
)
957 "Run a `cvs -n update' in the specified DIRECTORY.
958 That is, check what needs to be done, but don't change the disc.
959 Feed the output to a *cvs* buffer and run `cvs-mode' on it.
960 With a prefix argument, prompt for a directory and cvs FLAGS to use.
961 A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
962 prevents reuse of an existing *cvs* buffer.
963 Optional argument NOSHOW if non-nil means not to display the buffer."
964 (interactive (list (cvs-query-directory "CVS Examine (directory): ")
965 (cvs-flags-query 'cvs-update-flags
"cvs -n update flags")))
967 (setf flags
(cvs-flags-query 'cvs-update-flags nil
'noquery
)))
968 (cvs-cmd-do "update" directory flags nil
969 (> (prefix-numeric-value current-prefix-arg
) 8)
972 :dont-change-disc t
))
976 (defun cvs-update (directory flags
)
977 "Run a `cvs update' in the current working DIRECTORY.
978 Feed the output to a *cvs* buffer and run `cvs-mode' on it.
979 With a prefix argument, prompt for a directory and cvs FLAGS to use.
980 A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
981 prevents reuse of an existing *cvs* buffer."
982 (interactive (list (cvs-query-directory "CVS Update (directory): ")
983 (cvs-flags-query 'cvs-update-flags
"cvs update flags")))
985 (setf flags
(cvs-flags-query 'cvs-update-flags nil
'noquery
)))
986 (cvs-cmd-do "update" directory flags nil
987 (> (prefix-numeric-value current-prefix-arg
) 8)))
991 (defun cvs-status (directory flags
&optional noshow
)
992 "Run a `cvs status' in the current working DIRECTORY.
993 Feed the output to a *cvs* buffer and run `cvs-mode' on it.
994 With a prefix argument, prompt for a directory and cvs FLAGS to use.
995 A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
996 prevents reuse of an existing *cvs* buffer.
997 Optional argument NOSHOW if non-nil means not to display the buffer."
998 (interactive (list (cvs-query-directory "CVS Status (directory): ")
999 (cvs-flags-query 'cvs-status-flags
"cvs status flags")))
1001 (setf flags
(cvs-flags-query 'cvs-status-flags nil
'noquery
)))
1002 (cvs-cmd-do "status" directory flags nil
1003 (> (prefix-numeric-value current-prefix-arg
) 8)
1004 :noshow noshow
:dont-change-disc t
))
1006 (defun cvs-update-filter (proc string
)
1007 "Filter function for pcl-cvs.
1008 This function gets the output that CVS sends to stdout. It inserts
1009 the STRING into (process-buffer PROC) but it also checks if CVS is waiting
1010 for a lock file. If so, it inserts a message cookie in the *cvs* buffer."
1012 (with-current-buffer (process-buffer proc
)
1013 (let ((inhibit-read-only t
))
1015 ;; Insert the text, moving the process-marker.
1016 (goto-char (process-mark proc
))
1018 (set-marker (process-mark proc
) (point))
1019 ;; FIXME: Delete any old lock message
1020 ;;(if (tin-nth cookies 1)
1021 ;; (tin-delete cookies
1022 ;; (tin-nth cookies 1)))
1023 ;; Check if CVS is waiting for a lock.
1024 (beginning-of-line 0) ;Move to beginning of last complete line.
1025 (when (looking-at "^[ a-z]+: \\(.*waiting for .*lock in \\(.*\\)\\)$")
1026 (let ((msg (match-string 1))
1027 (lock (match-string 2)))
1028 (with-current-buffer cvs-buffer
1029 (set (make-local-variable 'cvs-lock-file
) lock
)
1030 ;; display the lock situation in the *cvs* buffer:
1033 (cvs-create-fileinfo
1036 (when (file-exists-p lock
)
1037 (substitute-command-keys
1038 "\n\t(type \\[cvs-mode-delete-lock] to delete it)")))
1040 (pop-to-buffer (current-buffer))
1041 (goto-char (point-max))
1046 ;;;; The cvs-mode and its associated commands.
1049 (cvs-prefix-define cvs-force-command
"" "" '("/F") cvs-qtypedesc-string1
)
1050 (defun-cvs-mode cvs-mode-force-command
(arg)
1051 "Force the next cvs command to operate on all the selected files.
1052 By default, cvs commands only operate on files on which the command
1053 \"makes sense\". This overrides the safety feature on the next cvs command.
1054 It actually behaves as a toggle. If prefixed by \\[universal-argument] \\[universal-argument],
1055 the override will persist until the next toggle."
1057 (cvs-prefix-set 'cvs-force-command arg
))
1059 (put 'cvs-mode
'mode-class
'special
)
1060 (define-derived-mode cvs-mode fundamental-mode
"CVS"
1061 "Mode used for PCL-CVS, a frontend to CVS.
1062 Full documentation is in the Texinfo file."
1063 (setq mode-line-process
1064 '("" cvs-force-command cvs-ignore-marks-modif
1065 ":" (cvs-branch-prefix
1066 ("" cvs-branch-prefix
(cvs-secondary-branch-prefix
1067 ("->" cvs-secondary-branch-prefix
))))
1068 " " cvs-mode-line-process
))
1069 (buffer-disable-undo)
1070 ;;(set (make-local-variable 'goal-column) cvs-cursor-column)
1071 (set (make-local-variable 'revert-buffer-function
) 'cvs-mode-revert-buffer
)
1072 (setq truncate-lines t
)
1073 (cvs-prefix-make-local 'cvs-branch-prefix
)
1074 (cvs-prefix-make-local 'cvs-secondary-branch-prefix
)
1075 (cvs-prefix-make-local 'cvs-force-command
)
1076 (cvs-prefix-make-local 'cvs-ignore-marks-modif
)
1077 (make-local-variable 'cvs-mode-line-process
)
1078 (make-local-variable 'cvs-temp-buffers
))
1081 (defun cvs-buffer-p (&optional buffer
)
1082 "Return whether the (by default current) BUFFER is a `cvs-mode' buffer."
1084 (if buffer
(set-buffer buffer
))
1085 (and (eq major-mode
'cvs-mode
))))
1087 (defun cvs-buffer-check ()
1088 "Check that the current buffer follows cvs-buffer's conventions."
1089 (let ((buf (current-buffer))
1091 (or (and (setq check
'collection
)
1092 (eq (ewoc-buffer cvs-cookies
) buf
)
1093 (setq check
'cvs-temp-buffer
)
1094 (or (null cvs-temp-buffer
)
1095 (null (buffer-name cvs-temp-buffer
))
1096 (and (eq (with-current-buffer cvs-temp-buffer cvs-buffer
) buf
)
1097 (equal (with-current-buffer cvs-temp-buffer
1099 default-directory
)))
1101 (error "Inconsistent %s in buffer %s" check
(buffer-name buf
)))))
1104 (defun cvs-mode-quit ()
1105 "Quit PCL-CVS, killing the *cvs* buffer."
1107 (and (y-or-n-p "Quit pcl-cvs? ") (kill-buffer (current-buffer))))
1112 "Display help for various PCL-CVS commands."
1114 (if (eq last-command
'cvs-help
)
1115 (describe-function 'cvs-mode
) ; would need minor-mode for log-edit-mode
1117 (substitute-command-keys
1118 "`\\[cvs-help]':help `\\[cvs-mode-add]':add `\\[cvs-mode-commit]':commit \
1119 `\\[cvs-mode-diff-map]':diff* `\\[cvs-mode-log]':log \
1120 `\\[cvs-mode-remove]':remove `\\[cvs-mode-status]':status \
1121 `\\[cvs-mode-undo]':undo"))))
1123 ;; Move around in the buffer
1125 (defun cvs-move-to-goal-column ()
1126 (let* ((eol (line-end-position))
1127 (fpos (next-single-property-change (point) 'cvs-goal-column nil eol
)))
1131 (defun-cvs-mode cvs-mode-previous-line
(arg)
1132 "Go to the previous line.
1133 If a prefix argument is given, move by that many lines."
1135 (ewoc-goto-prev cvs-cookies arg
)
1136 (cvs-move-to-goal-column))
1138 (defun-cvs-mode cvs-mode-next-line
(arg)
1139 "Go to the next line.
1140 If a prefix argument is given, move by that many lines."
1142 (ewoc-goto-next cvs-cookies arg
)
1143 (cvs-move-to-goal-column))
1149 (defun-cvs-mode cvs-mode-mark
(&optional arg
)
1150 "Mark the fileinfo on the current line.
1151 If the fileinfo is a directory, all the contents of that directory are
1152 marked instead. A directory can never be marked."
1154 (let* ((tin (ewoc-locate cvs-cookies
))
1155 (fi (ewoc-data tin
)))
1156 (if (eq (cvs-fileinfo->type fi
) 'DIRCHANGE
)
1157 ;; it's a directory: let's mark all files inside
1160 (when (cvs-dir-member-p f dir
)
1161 (setf (cvs-fileinfo->marked f
)
1162 (not (if (eq arg
'toggle
) (cvs-fileinfo->marked f
) arg
)))
1163 t
)) ;Tell cookie to redisplay this cookie.
1165 (cvs-fileinfo->dir fi
))
1166 ;; not a directory: just do the obvious
1167 (setf (cvs-fileinfo->marked fi
)
1168 (not (if (eq arg
'toggle
) (cvs-fileinfo->marked fi
) arg
)))
1169 (ewoc-invalidate cvs-cookies tin
)
1170 (cvs-mode-next-line 1))))
1172 (defun cvs-mouse-toggle-mark (e)
1173 "Toggle the mark of the entry under the mouse."
1177 (cvs-mode-mark 'toggle
)))
1179 (defun-cvs-mode cvs-mode-unmark
()
1180 "Unmark the fileinfo on the current line."
1184 (defun-cvs-mode cvs-mode-mark-all-files
()
1187 (ewoc-map (lambda (cookie)
1188 (unless (eq (cvs-fileinfo->type cookie
) 'DIRCHANGE
)
1189 (setf (cvs-fileinfo->marked cookie
) t
)))
1192 (defun-cvs-mode (cvs-mode-mark-on-state . SIMPLE
) (state)
1193 "Mark all files in state STATE."
1201 (cvs-mode-marked nil nil
:read-only t
:one t
:noquery t
))))
1207 "Mark files in state" (if default
(concat " [" default
"]")) ": ")
1209 (list (downcase (symbol-name (car x
)))))
1211 nil t nil nil default
))))))
1212 (ewoc-map (lambda (fi)
1213 (when (eq (cvs-fileinfo->type fi
) state
)
1214 (setf (cvs-fileinfo->marked fi
) t
)))
1217 (defun-cvs-mode cvs-mode-mark-matching-files
(regex)
1218 "Mark all files matching REGEX."
1219 (interactive "sMark files matching: ")
1220 (ewoc-map (lambda (cookie)
1221 (when (and (not (eq (cvs-fileinfo->type cookie
) 'DIRCHANGE
))
1222 (string-match regex
(cvs-fileinfo->file cookie
)))
1223 (setf (cvs-fileinfo->marked cookie
) t
)))
1226 (defun-cvs-mode cvs-mode-unmark-all-files
()
1228 Directories are also unmarked, but that doesn't matter, since
1229 they should always be unmarked."
1231 (ewoc-map (lambda (cookie)
1232 (setf (cvs-fileinfo->marked cookie
) nil
)
1236 (defun-cvs-mode cvs-mode-unmark-up
()
1237 "Unmark the file on the previous line."
1239 (let ((tin (ewoc-goto-prev cvs-cookies
1)))
1241 (setf (cvs-fileinfo->marked
(ewoc-data tin
)) nil
)
1242 (ewoc-invalidate cvs-cookies tin
))))
1244 (defconst cvs-ignore-marks-alternatives
1245 '(("toggle-marks" .
"/TM")
1246 ("force-marks" .
"/FM")
1247 ("ignore-marks" .
"/IM")))
1249 (cvs-prefix-define cvs-ignore-marks-modif
1250 "Prefix to decide whether to ignore marks or not."
1252 (mapcar 'cdr cvs-ignore-marks-alternatives
)
1253 (cvs-qtypedesc-create
1254 (lambda (str) (cdr (assoc str cvs-ignore-marks-alternatives
)))
1255 (lambda (obj) (car (rassoc obj cvs-ignore-marks-alternatives
)))
1256 (lambda () cvs-ignore-marks-alternatives
)
1259 (defun-cvs-mode cvs-mode-toggle-marks
(arg)
1260 "Toggle whether the next CVS command uses marks.
1261 See `cvs-prefix-set' for further description of the behavior.
1262 \\[universal-argument] 1 selects `force-marks',
1263 \\[universal-argument] 2 selects `ignore-marks',
1264 \\[universal-argument] 3 selects `toggle-marks'."
1266 (cvs-prefix-set 'cvs-ignore-marks-modif arg
))
1268 (defun cvs-ignore-marks-p (cmd &optional read-only
)
1269 (let ((default (if (member cmd cvs-invert-ignore-marks
)
1270 (not cvs-default-ignore-marks
)
1271 cvs-default-ignore-marks
))
1272 (modif (cvs-prefix-get 'cvs-ignore-marks-modif read-only
)))
1274 ((equal modif
"/IM") t
)
1275 ((equal modif
"/TM") (not default
))
1276 ((equal modif
"/FM") nil
)
1279 (defun cvs-mode-mark-get-modif (cmd)
1280 (if (cvs-ignore-marks-p cmd
'read-only
) "/IM" "/FM"))
1282 (defvar cvs-minor-current-files
)
1283 (defun cvs-get-marked (&optional ignore-marks ignore-contents
)
1284 "Return a list of all selected fileinfos.
1285 If there are any marked tins, and IGNORE-MARKS is nil, return them.
1286 Otherwise, if the cursor selects a directory, and IGNORE-CONTENTS is
1287 nil, return all files in it, else return just the directory.
1288 Otherwise return (a list containing) the file the cursor points to, or
1289 an empty list if it doesn't point to a file at all.
1291 Args: &optional IGNORE-MARKS IGNORE-CONTENTS."
1294 (dolist (fi (if (and (boundp 'cvs-minor-current-files
)
1295 (consp cvs-minor-current-files
))
1298 (if (cvs-fileinfo-p f
) f
1299 (let ((f (file-relative-name f
)))
1300 (if (file-directory-p f
)
1301 (cvs-create-fileinfo
1302 'DIRCHANGE
(file-name-as-directory f
) "." "")
1303 (let ((dir (file-name-directory f
))
1304 (file (file-name-nondirectory f
)))
1305 (cvs-create-fileinfo
1306 'UNKNOWN
(or dir
"") file
""))))))
1307 cvs-minor-current-files
)
1308 (or (and (not ignore-marks
)
1309 (ewoc-collect cvs-cookies
'cvs-fileinfo-
>marked
))
1310 (list (ewoc-data (ewoc-locate cvs-cookies
))))))
1312 (if (or ignore-contents
(not (eq (cvs-fileinfo->type fi
) 'DIRCHANGE
)))
1314 ;; If a directory is selected, return members, if any.
1316 (append (ewoc-collect
1317 cvs-cookies
'cvs-dir-member-p
(cvs-fileinfo->dir fi
))
1321 (defun* cvs-mode-marked
(filter &optional cmd
1322 &key read-only one file noquery
)
1323 "Get the list of marked FIS.
1324 CMD is used to determine whether to use the marks or not.
1325 Only files for which FILTER is applicable are returned.
1326 If READ-ONLY is non-nil, the current toggling is left intact.
1327 If ONE is non-nil, marks are ignored and a single FI is returned.
1328 If FILE is non-nil, directory entries won't be selected."
1329 (unless cmd
(setq cmd
(symbol-name filter
)))
1330 (let* ((fis (cvs-get-marked (or one
(cvs-ignore-marks-p cmd read-only
))
1332 (cvs-applicable-p 'DIRCHANGE filter
))))
1333 (force (cvs-prefix-get 'cvs-force-command
))
1334 (fis (car (cvs-partition
1335 (lambda (fi) (cvs-applicable-p fi
(and (not force
) filter
)))
1337 (when (and (or (null fis
) (and one
(cdr fis
))) (not noquery
))
1338 (message (if (null fis
)
1339 "`%s' is not applicable to any of the selected files."
1340 "`%s' is only applicable to a single file.") cmd
)
1342 (setq fis
(list (cvs-insert-file
1343 (read-file-name (format "File to %s: " cmd
))))))
1344 (if one
(car fis
) fis
)))
1346 (defun cvs-enabledp (filter)
1347 "Determine whether FILTER applies to at least one of the selected files."
1348 (ignore-errors (cvs-mode-marked filter nil
:read-only t
:noquery t
)))
1350 (defun cvs-mode-files (&rest -cvs-mode-files-args
)
1353 (mapcar 'cvs-fileinfo-
>full-path
1354 (apply 'cvs-mode-marked -cvs-mode-files-args
)))))
1357 ;; Interface between Log-Edit and PCL-CVS
1360 (defun cvs-mode-commit-setup ()
1361 "Run `cvs-mode-commit' with setup."
1363 (cvs-mode-commit 'force
))
1365 (defcustom cvs-mode-commit-hook nil
1366 "Hook run after setting up the commit buffer."
1368 :options
'(cvs-mode-diff))
1370 (defun cvs-mode-commit (setup)
1371 "Check in all marked files, or the current file.
1372 The user will be asked for a log message in a buffer.
1373 The buffer's mode and name is determined by the \"message\" setting
1374 of `cvs-buffer-name-alist'.
1375 The POSTPROC specified there (typically `log-edit') is then called,
1376 passing it the SETUP argument."
1378 ;; It seems that the save-excursion that happens if I use the better
1379 ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which
1380 ;; end up being rather annoying (like log-edit-mode's message being
1381 ;; displayed in the wrong minibuffer).
1383 (let ((buf (cvs-temp-buffer "message" 'normal
'nosetup
))
1384 (lbd list-buffers-directory
)
1385 (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist
)))
1387 (funcall setupfun
'cvs-do-commit setup
'cvs-commit-filelist buf
)
1388 (set (make-local-variable 'cvs-minor-wrap-function
) 'cvs-commit-minor-wrap
)
1389 (set (make-local-variable 'list-buffers-directory
) lbd
)
1390 (run-hooks 'cvs-mode-commit-hook
)))
1392 (defun cvs-commit-minor-wrap (buf f
)
1393 (let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit")))
1396 (defun cvs-commit-filelist ()
1397 (cvs-mode-files 'commit nil
:read-only t
:file t
:noquery t
))
1399 (defun cvs-do-commit (flags)
1400 "Do the actual commit, using the current buffer as the log message."
1401 (interactive (list (cvs-flags-query 'cvs-commit-flags
"cvs commit flags")))
1402 (let ((msg (buffer-substring-no-properties (point-min) (point-max))))
1404 ;;(pop-to-buffer cvs-buffer)
1405 (cvs-mode-do "commit" (list* "-m" msg flags
) 'commit
)))
1408 ;;;; Editing existing commit log messages.
1410 (defun cvs-edit-log-text-at-point ()
1413 (when (re-search-backward "^revision " nil t
)
1415 (if (looking-at "date:") (forward-line 1))
1416 (if (looking-at "branches:") (forward-line 1))
1419 (if (re-search-forward
1420 "^\\(-\\{28\\}\\|=\\{77\\}\\|revision [.0-9]+\\)$"
1425 (defun cvs-mode-edit-log (rev &optional text
)
1426 "Edit the log message at point.
1427 This is best called from a `log-view-mode' buffer."
1430 (or (cvs-mode! (lambda () (cvs-prefix-get 'cvs-branch-prefix
)))
1431 (read-string "Revision to edit: "))
1432 (cvs-edit-log-text-at-point)))
1433 ;; It seems that the save-excursion that happens if I use the better
1434 ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which
1435 ;; end up being rather annoying (like log-edit-mode's message being
1436 ;; displayed in the wrong minibuffer).
1438 (let ((buf (cvs-temp-buffer "message" 'normal
'nosetup
))
1439 (lbd list-buffers-directory
)
1440 (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist
)))
1442 (funcall setupfun
'cvs-do-edit-log nil
'cvs-edit-log-filelist buf
)
1443 (when text
(erase-buffer) (insert text
))
1444 (set (make-local-variable 'cvs-edit-log-revision
) rev
)
1445 (set (make-local-variable 'cvs-minor-wrap-function
) 'cvs-edit-log-minor-wrap
)
1446 (set (make-local-variable 'list-buffers-directory
) lbd
)
1447 ;; (run-hooks 'cvs-mode-commit-hook)
1450 (defun cvs-edit-log-minor-wrap (buf f
)
1451 (let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit")))
1454 (defun cvs-edit-log-filelist ()
1455 (cvs-mode-files nil nil
:read-only t
:file t
:noquery t
))
1457 (defun cvs-do-edit-log (rev)
1458 "Do the actual commit, using the current buffer as the log message."
1459 (interactive (list cvs-edit-log-revision
))
1460 (let ((msg (buffer-substring-no-properties (point-min) (point-max))))
1462 (cvs-mode-do "admin" (list (concat "-m" rev
":" msg
)) nil
)))
1466 ;;;; CVS Mode commands
1469 (defun-cvs-mode (cvs-mode-insert . NOARGS
) (file)
1470 "Insert an entry for a specific file into the current listing.
1471 This is typically used if the file is up-to-date (or has been added
1472 outside of PCL-CVS) and one wants to do some operation on it."
1474 (list (read-file-name
1476 ;; Can't use ignore-errors here because interactive
1477 ;; specs aren't byte-compiled.
1479 (file-name-as-directory
1482 (cvs-mode-marked nil nil
:read-only t
:one t
:noquery t
))))
1484 (cvs-insert-file file
))
1486 (defun cvs-insert-file (file)
1487 "Insert FILE (and its contents if it's a dir) and return its FI."
1488 (let ((file (file-relative-name (directory-file-name file
))) last
)
1489 (dolist (fi (cvs-fileinfo-from-entries file
))
1490 (setq last
(cvs-addto-collection cvs-cookies fi last
)))
1491 ;; There should have been at least one entry.
1492 (goto-char (ewoc-location last
))
1495 (defun cvs-mark-fis-dead (fis)
1496 ;; Helper function, introduced because of the need for macro-expansion.
1498 (setf (cvs-fileinfo->type fi
) 'DEAD
)))
1500 (defun-cvs-mode (cvs-mode-add . SIMPLE
) (flags)
1501 "Add marked files to the cvs repository.
1502 With prefix argument, prompt for cvs flags."
1503 (interactive (list (cvs-flags-query 'cvs-add-flags
"cvs add flags")))
1504 (let ((fis (cvs-mode-marked 'add
))
1505 (needdesc nil
) (dirs nil
))
1506 ;; find directories and look for fis needing a description
1509 ((file-directory-p (cvs-fileinfo->full-path fi
)) (push fi dirs
))
1510 ((eq (cvs-fileinfo->type fi
) 'UNKNOWN
) (setq needdesc t
))))
1511 ;; prompt for description if necessary
1512 (let* ((msg (if (and needdesc
1513 (or current-prefix-arg
(not cvs-add-default-message
)))
1514 (read-from-minibuffer "Enter description: ")
1515 (or cvs-add-default-message
"")))
1516 (flags (list* "-m" msg flags
))
1518 ;; setup postprocessing for the directory entries
1520 `((cvs-run-process (list "-n" "update")
1522 '(cvs-parse-process t
))
1523 (cvs-mark-fis-dead ',dirs
)))))
1524 (cvs-mode-run "add" flags fis
:postproc postproc
))))
1526 (defun-cvs-mode (cvs-mode-diff . DOUBLE
) (flags)
1527 "Diff the selected files against the repository.
1528 This command compares the files in your working area against the
1529 revision which they are based upon."
1531 (list (cvs-add-branch-prefix
1532 (cvs-add-secondary-branch-prefix
1533 (cvs-flags-query 'cvs-diff-flags
"cvs diff flags")))))
1534 (cvs-mode-do "diff" flags
'diff
1535 :show t
)) ;; :ignore-exit t
1537 (defun-cvs-mode (cvs-mode-diff-head . SIMPLE
) (flags)
1538 "Diff the selected files against the head of the current branch.
1539 See ``cvs-mode-diff'' for more info."
1540 (interactive (list (cvs-flags-query 'cvs-diff-flags
"cvs diff flags")))
1541 (cvs-mode-diff-1 (cons "-rHEAD" flags
)))
1543 (defun-cvs-mode (cvs-mode-diff-vendor . SIMPLE
) (flags)
1544 "Diff the selected files against the head of the vendor branch.
1545 See ``cvs-mode-diff'' for more info."
1546 (interactive (list (cvs-flags-query 'cvs-diff-flags
"cvs diff flags")))
1547 (cvs-mode-diff-1 (cons (concat "-r" cvs-vendor-branch
) flags
)))
1549 ;; sadly, this is not provided by cvs, so we have to roll our own
1550 (defun-cvs-mode (cvs-mode-diff-backup . SIMPLE
) (flags)
1551 "Diff the files against the backup file.
1552 This command can be used on files that are marked with \"Merged\"
1553 or \"Conflict\" in the *cvs* buffer."
1554 (interactive (list (cvs-flags-query 'cvs-diff-flags
"diff flags")))
1555 (unless (listp flags
) (error "flags should be a list of strings"))
1557 (let* ((filter 'diff
)
1558 (marked (cvs-get-marked (cvs-ignore-marks-p "diff")))
1559 ;;(tins (cvs-filter-applicable filter marked))
1560 (fis (car (cvs-partition 'cvs-fileinfo-
>backup-file marked
))))
1562 (error "No files with a backup file selected!"))
1563 ;; let's extract some info into the environment for `buffer-name'
1564 (let* ((dir (cvs-fileinfo->dir
(car fis
)))
1565 (file (cvs-fileinfo->file
(car fis
))))
1566 (set-buffer (cvs-temp-buffer "diff")))
1567 (message "cvs diff backup...")
1568 (cvs-execute-single-file-list fis
'cvs-diff-backup-extractor
1569 cvs-diff-program flags
))
1570 (message "cvs diff backup... Done."))
1572 (defun cvs-diff-backup-extractor (fileinfo)
1573 "Return the filename and the name of the backup file as a list.
1574 Signal an error if there is no backup file."
1575 (let ((backup-file (cvs-fileinfo->backup-file fileinfo
)))
1577 (error "%s has no backup file" (cvs-fileinfo->full-path fileinfo
)))
1578 (list backup-file
(cvs-fileinfo->full-path fileinfo
))))
1583 (defun cvs-emerge-diff (b1 b2
) (emerge-buffers b1 b2 b1
))
1584 (defun cvs-emerge-merge (b1 b2 base out
)
1585 (emerge-buffers-with-ancestor b1 b2 base
(find-file-noselect out
)))
1591 (defvar ediff-after-quit-destination-buffer
)
1592 (defvar cvs-transient-buffers
)
1593 (defun cvs-ediff-startup-hook ()
1594 (add-hook 'ediff-after-quit-hook-internal
1596 (cvs-ediff-exit-hook
1597 ',ediff-after-quit-destination-buffer
',cvs-transient-buffers
))
1600 (defun cvs-ediff-exit-hook (cvs-buf tmp-bufs
)
1601 ;; kill the temp buffers (and their associated windows)
1602 (dolist (tb tmp-bufs
)
1603 (when (and tb
(buffer-live-p tb
) (not (buffer-modified-p tb
)))
1604 (let ((win (get-buffer-window tb t
)))
1606 (when (window-live-p win
) (ignore-errors (delete-window win
))))))
1607 ;; switch back to the *cvs* buffer
1608 (when (and cvs-buf
(buffer-live-p cvs-buf
)
1609 (not (get-buffer-window cvs-buf t
)))
1610 (ignore-errors (switch-to-buffer cvs-buf
))))
1612 (defun cvs-ediff-diff (b1 b2
)
1613 (let ((ediff-after-quit-destination-buffer (current-buffer))
1614 (startup-hook '(cvs-ediff-startup-hook)))
1615 (ediff-buffers b1 b2 startup-hook
'ediff-revision
)))
1617 (defun cvs-ediff-merge (b1 b2 base out
)
1618 (let ((ediff-after-quit-destination-buffer (current-buffer))
1619 (startup-hook '(cvs-ediff-startup-hook)))
1620 (ediff-merge-buffers-with-ancestor
1621 b1 b2 base startup-hook
1622 'ediff-merge-revisions-with-ancestor
1626 ;; Interactive merge/diff support.
1629 (defun cvs-retrieve-revision (fileinfo rev
)
1630 "Retrieve the given REVision of the file in FILEINFO into a new buffer."
1631 (let* ((file (cvs-fileinfo->full-path fileinfo
))
1632 (buffile (concat file
"." rev
)))
1633 (or (find-buffer-visiting buffile
)
1634 (with-current-buffer (create-file-buffer buffile
)
1635 (message "Retrieving revision %s..." rev
)
1636 (let ((res (call-process cvs-program nil t nil
1637 "-q" "update" "-p" "-r" rev file
)))
1638 (when (and res
(not (and (equal 0 res
))))
1639 (error "Something went wrong retrieving revision %s: %s" rev res
))
1640 (set-buffer-modified-p nil
)
1641 (let ((buffer-file-name (expand-file-name file
)))
1643 (toggle-read-only 1)
1644 (message "Retrieving revision %s... Done" rev
)
1645 (current-buffer))))))
1647 (eval-and-compile (autoload 'smerge-ediff
"smerge-mode"))
1649 ;; FIXME: The user should be able to specify ancestor/head/backup and we should
1650 ;; provide sensible defaults when merge info is unavailable (rather than rely
1651 ;; on smerge-ediff). Also provide sane defaults for need-merge files.
1652 (defun-cvs-mode cvs-mode-imerge
()
1653 "Merge interactively appropriate revisions of the selected file."
1655 (let ((fi (cvs-mode-marked 'merge nil
:one t
:file t
)))
1656 (let ((merge (cvs-fileinfo->merge fi
))
1657 (file (cvs-fileinfo->full-path fi
))
1658 (backup-file (cvs-fileinfo->backup-file fi
)))
1659 (if (not (and merge backup-file
))
1660 (let ((buf (find-file-noselect file
)))
1661 (message "Missing merge info or backup file, using VC.")
1662 (with-current-buffer buf
1664 (let* ((ancestor-buf (cvs-retrieve-revision fi
(car merge
)))
1665 (head-buf (cvs-retrieve-revision fi
(cdr merge
)))
1666 (backup-buf (let ((auto-mode-alist nil
))
1667 (find-file-noselect backup-file
)))
1668 ;; this binding is used by cvs-ediff-startup-hook
1669 (cvs-transient-buffers (list ancestor-buf backup-buf head-buf
)))
1670 (with-current-buffer backup-buf
1671 (let ((buffer-file-name (expand-file-name file
)))
1673 (funcall (cdr cvs-idiff-imerge-handlers
)
1674 backup-buf head-buf ancestor-buf file
))))))
1676 (cvs-flags-define cvs-idiff-version
1677 (list "BASE" cvs-vendor-branch cvs-vendor-branch
"BASE" "BASE")
1678 "version: " cvs-qtypedesc-tag
)
1680 (defun-cvs-mode (cvs-mode-idiff . NOARGS
) (&optional rev1 rev2
)
1681 "Diff interactively current file to revisions."
1683 (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix
))
1684 (rev2 (and rev1
(cvs-prefix-get 'cvs-secondary-branch-prefix
))))
1685 (list (or rev1
(cvs-flags-query 'cvs-idiff-version
))
1687 (let ((fi (cvs-mode-marked 'diff
"idiff" :one t
:file t
)))
1688 (let* ((file (cvs-fileinfo->full-path fi
))
1689 (rev1-buf (cvs-retrieve-revision fi
(or rev1
"BASE")))
1690 (rev2-buf (if rev2
(cvs-retrieve-revision fi rev2
)))
1691 ;; this binding is used by cvs-ediff-startup-hook
1692 (cvs-transient-buffers (list rev1-buf rev2-buf
)))
1693 (funcall (car cvs-idiff-imerge-handlers
)
1694 rev1-buf
(or rev2-buf
(find-file-noselect file
))))))
1696 (defun-cvs-mode (cvs-mode-idiff-other . NOARGS
) ()
1697 "Diff interactively current file to revisions."
1699 (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix
))
1700 (rev2 (and rev1
(cvs-prefix-get 'cvs-secondary-branch-prefix
)))
1701 (fis (cvs-mode-marked 'diff
"idiff" :file t
)))
1702 (when (> (length fis
) 2)
1703 (error "idiff-other cannot be applied to more than 2 files at a time"))
1704 (let* ((fi1 (car fis
))
1705 (rev1-buf (if rev1
(cvs-retrieve-revision fi1 rev1
)
1706 (find-file-noselect (cvs-fileinfo->full-path fi1
))))
1709 (let ((fi2 (nth 1 fis
)))
1711 (if rev2
(cvs-retrieve-revision fi2 rev2
)
1712 (find-file-noselect (cvs-fileinfo->full-path fi2
)))))
1713 (error "idiff-other doesn't know what other file/buffer to use"))
1714 (let* (;; this binding is used by cvs-ediff-startup-hook
1715 (cvs-transient-buffers (list rev1-buf rev2-buf
)))
1716 (funcall (car cvs-idiff-imerge-handlers
)
1717 rev1-buf rev2-buf
)))))
1720 (defun cvs-is-within-p (fis dir
)
1721 "Non-nil is buffer is inside one of FIS (in DIR)."
1722 (when (stringp buffer-file-name
)
1723 (setq buffer-file-name
(expand-file-name buffer-file-name
))
1725 (dolist (fi (or fis
(list (cvs-create-fileinfo 'DIRCHANGE
"" "." ""))))
1726 (when (cvs-string-prefix-p
1727 (expand-file-name (cvs-fileinfo->full-path fi
) dir
)
1732 (defun* cvs-mode-run
(cmd flags fis
1733 &key
(buf (cvs-temp-buffer))
1734 dont-change-disc cvsargs postproc
)
1735 "Generic cvs-mode-<foo> function.
1736 Executes `cvs CVSARGS CMD FLAGS FIS'.
1737 BUF is the buffer to be used for cvs' output.
1738 DONT-CHANGE-DISC non-nil indicates that the command will not change the
1739 contents of files. This is only used by the parser.
1740 POSTPROC is a list of expressions to be evaluated at the very end (after
1741 parsing if applicable). It will be prepended with `progn' is necessary."
1742 (let ((def-dir default-directory
))
1743 ;; Save the relevant buffers
1744 (save-some-buffers nil
(lambda () (cvs-is-within-p fis def-dir
))))
1745 (unless (listp flags
) (error "flags should be a list of strings"))
1746 (let* ((cvs-buf (current-buffer))
1747 (single-dir (or (not (listp cvs-execute-single-dir
))
1748 (member cmd cvs-execute-single-dir
)))
1749 (parse (member cmd cvs-parse-known-commands
))
1750 (args (append cvsargs
(list cmd
) flags
))
1751 (after-mode (nth 2 (cdr (assoc cmd cvs-buffer-name-alist
)))))
1752 (cvs-cleanup-collection cvs-cookies
;cleanup remaining messages
1753 (eq cvs-auto-remove-handled
'delayed
) nil t
)
1754 (when (fboundp after-mode
)
1755 (setq postproc
(append postproc
`((,after-mode
)))))
1758 (when (member cmd
'("status" "update")) ;FIXME: Yuck!!
1759 ;; absence of `cvs update' output has a specific meaning.
1760 (or fis
(list (cvs-create-fileinfo 'DIRCHANGE
"" "." ""))))))
1761 (push `(cvs-parse-process ',dont-change-disc nil
',old-fis
) postproc
)))
1762 (setq postproc
(if (cdr postproc
) (cons 'progn postproc
) (car postproc
)))
1763 (cvs-update-header args fis
)
1764 (with-current-buffer buf
1765 ;;(set (make-local-variable 'cvs-buffer) cvs-buf)
1766 (let ((inhibit-read-only t
)) (erase-buffer))
1767 (message "Running cvs %s ..." cmd
)
1768 (cvs-run-process args fis postproc single-dir
))))
1771 (defun* cvs-mode-do
(cmd flags filter
1772 &key show dont-change-disc parse cvsargs postproc
)
1773 "Generic cvs-mode-<foo> function.
1774 Executes `cvs CVSARGS CMD FLAGS' on the selected files.
1775 FILTER is passed to `cvs-applicable-p' to only apply the command to
1776 files for which it makes sense.
1777 SHOW indicates that CMD should be not be run in the default temp buffer and
1778 should be shown to the user. The buffer and mode to be used is determined
1779 by `cvs-buffer-name-alist'.
1780 DONT-CHANGE-DISC non-nil indicates that the command will not change the
1781 contents of files. This is only used by the parser."
1782 (cvs-mode-run cmd flags
(cvs-mode-marked filter cmd
)
1783 :buf
(cvs-temp-buffer (when show cmd
))
1784 :dont-change-disc dont-change-disc
1786 :postproc postproc
))
1788 (defun-cvs-mode (cvs-mode-status . SIMPLE
) (flags)
1789 "Show cvs status for all marked files.
1790 With prefix argument, prompt for cvs flags."
1791 (interactive (list (cvs-flags-query 'cvs-status-flags
"cvs status flags")))
1792 (cvs-mode-do "status" flags nil
:dont-change-disc t
:show t
1793 :postproc
(when (eq cvs-auto-remove-handled
'status
)
1794 '((with-current-buffer ,(current-buffer)
1795 (cvs-mode-remove-handled))))))
1797 (defun-cvs-mode (cvs-mode-tree . SIMPLE
) (flags)
1798 "Call cvstree using the file under the point as a keyfile."
1799 (interactive (list (cvs-flags-query 'cvs-status-flags
"cvs status flags")))
1800 (cvs-mode-run "status" (cons "-v" flags
) (cvs-mode-marked nil
"status")
1801 :buf
(cvs-temp-buffer "tree")
1803 :postproc
'((cvs-status-cvstrees))))
1807 (defun-cvs-mode (cvs-mode-log . NOARGS
) (flags)
1808 "Display the cvs log of all selected files.
1809 With prefix argument, prompt for cvs flags."
1810 (interactive (list (cvs-add-branch-prefix
1811 (cvs-flags-query 'cvs-log-flags
"cvs log flags"))))
1812 (cvs-mode-do "log" flags nil
:show t
))
1815 (defun-cvs-mode (cvs-mode-update . NOARGS
) (flags)
1816 "Update all marked files.
1817 With a prefix argument, prompt for cvs flags."
1819 (list (cvs-add-branch-prefix
1820 (cvs-add-secondary-branch-prefix
1821 (cvs-flags-query 'cvs-update-flags
"cvs update flags")
1823 (cvs-mode-do "update" flags
'update
))
1826 (defun-cvs-mode (cvs-mode-examine . NOARGS
) (flags)
1827 "Re-examine all marked files.
1828 With a prefix argument, prompt for cvs flags."
1830 (list (cvs-add-branch-prefix
1831 (cvs-add-secondary-branch-prefix
1832 (cvs-flags-query 'cvs-update-flags
"cvs -n update flags")
1834 (cvs-mode-do "update" flags nil
:cvsargs
'("-n") :dont-change-disc t
))
1837 (defun-cvs-mode cvs-mode-ignore
(&optional pattern
)
1838 "Arrange so that CVS ignores the selected files.
1839 This command ignores files that are not flagged as `Unknown'."
1841 (dolist (fi (cvs-mode-marked 'ignore
))
1842 (cvs-append-to-ignore (cvs-fileinfo->dir fi
) (cvs-fileinfo->file fi
))
1843 (setf (cvs-fileinfo->type fi
) 'DEAD
))
1844 (cvs-cleanup-collection cvs-cookies nil nil nil
))
1847 (defun cvs-append-to-ignore (dir str
)
1848 "Add STR to the .cvsignore file in DIR."
1849 (save-window-excursion
1850 (set-buffer (find-file-noselect (expand-file-name ".cvsignore" dir
)))
1851 (when (ignore-errors
1852 (and buffer-read-only
1853 (eq 'CVS
(vc-backend buffer-file-name
))
1854 (not (vc-editable-p buffer-file-name
))))
1855 ;; CVSREAD=on special case
1856 (vc-toggle-read-only))
1857 (goto-char (point-max))
1858 (unless (zerop (current-column)) (insert "\n"))
1860 (if cvs-sort-ignore-file
(sort-lines nil
(point-min) (point-max)))
1864 (defun cvs-mode-find-file-other-window (e)
1865 "Select a buffer containing the file in another window."
1866 (interactive (list last-input-event
))
1867 (cvs-mode-find-file e t
))
1870 (defun cvs-mode-display-file (e)
1871 "Show a buffer containing the file in another window."
1872 (interactive (list last-input-event
))
1873 (cvs-mode-find-file e
'dont-select
))
1876 (defun cvs-find-modif (fi)
1878 (call-process cvs-program nil
(current-buffer) nil
1879 "-f" "diff" (cvs-fileinfo->file fi
))
1880 (goto-char (point-min))
1881 (if (re-search-forward "^\\([0-9]+\\)" nil t
)
1882 (string-to-number (match-string 1))
1886 (defun cvs-mode-find-file (e &optional other
)
1887 "Select a buffer containing the file.
1888 With a prefix, opens the buffer in an OTHER window."
1889 (interactive (list last-input-event current-prefix-arg
))
1890 (when (ignore-errors (mouse-set-point e
) t
) ;for invocation via the mouse
1891 (unless (memq (get-text-property (1- (line-end-position)) 'face
)
1892 '(cvs-header-face cvs-filename-face
))
1893 (error "Not a file name")))
1895 (lambda (&optional rev
)
1896 (interactive (list (cvs-prefix-get 'cvs-branch-prefix
)))
1897 (let* ((cvs-buf (current-buffer))
1898 (fi (cvs-mode-marked nil nil
:one t
)))
1899 (if (eq (cvs-fileinfo->type fi
) 'DIRCHANGE
)
1900 (let ((odir default-directory
))
1901 (setq default-directory
1902 (cvs-expand-dir-name (cvs-fileinfo->dir fi
)))
1903 (cond ((eq other
'dont-select
)
1904 (display-buffer (find-file-noselect default-directory
)))
1905 (other (dired-other-window default-directory
))
1906 (t (dired default-directory
)))
1907 (set-buffer cvs-buf
)
1908 (setq default-directory odir
))
1909 (let ((buf (if rev
(cvs-retrieve-revision fi rev
)
1910 (find-file-noselect (cvs-fileinfo->full-path fi
)))))
1911 (funcall (cond ((eq other
'dont-select
) 'display-buffer
)
1912 (other 'switch-to-buffer-other-window
)
1913 (t 'switch-to-buffer
))
1915 (when (and cvs-find-file-and-jump
(cvs-applicable-p fi
'diff-base
))
1916 (goto-line (cvs-find-modif fi
)))
1920 (defun-cvs-mode (cvs-mode-undo . SIMPLE
) (flags)
1921 "Undo local changes to all marked files.
1922 The file is removed and `cvs update FILE' is run."
1923 ;;"With prefix argument, prompt for cvs FLAGS."
1924 (interactive (list nil
));; (cvs-flags-query 'cvs-undo-flags "undo flags")
1925 (if current-prefix-arg
(call-interactively 'cvs-mode-revert-to-rev
)
1926 (let* ((fis (cvs-do-removal 'undo
"update" 'all
))
1927 (removedp (lambda (fi)
1928 (or (eq (cvs-fileinfo->type fi
) 'REMOVED
)
1929 (and (eq (cvs-fileinfo->type fi
) 'CONFLICT
)
1930 (eq (cvs-fileinfo->subtype fi
) 'REMOVED
)))))
1931 (fis-split (cvs-partition removedp fis
))
1932 (fis-removed (car fis-split
))
1933 (fis-other (cdr fis-split
)))
1934 (if (null fis-other
)
1935 (when fis-removed
(cvs-mode-run "add" nil fis-removed
))
1936 (cvs-mode-run "update" flags fis-other
1939 `((with-current-buffer ,(current-buffer)
1940 (cvs-mode-run "add" nil
',fis-removed
)))))))))
1943 (defun-cvs-mode (cvs-mode-revert-to-rev . NOARGS
) (rev)
1944 "Revert the selected files to an old revision."
1946 (list (or (cvs-prefix-get 'cvs-branch-prefix
)
1947 (let ((current-prefix-arg '(4)))
1948 (cvs-flags-query 'cvs-idiff-version
)))))
1949 (let* ((fis (cvs-mode-marked 'revert
"revert" :file t
))
1950 (tag (concat "tmp_pcl_tag_" (make-temp-name "")))
1951 (untag `((with-current-buffer ,(current-buffer)
1952 (cvs-mode-run "tag" (list "-d" ',tag
) ',fis
))))
1953 (update `((with-current-buffer ,(current-buffer)
1954 (cvs-mode-run "update" (list "-j" ',tag
"-j" ',rev
) ',fis
1955 :postproc
',untag
)))))
1956 (cvs-mode-run "tag" (list tag
) fis
:postproc update
)))
1959 (defun-cvs-mode cvs-mode-delete-lock
()
1960 "Delete the lock file that CVS is waiting for.
1961 Note that this can be dangerous. You should only do this
1962 if you are convinced that the process that created the lock is dead."
1964 (let* ((default-directory (cvs-expand-dir-name cvs-lock-file
))
1965 (locks (directory-files default-directory nil cvs-lock-file-regexp
)))
1967 ((not locks
) (error "No lock files found"))
1968 ((yes-or-no-p (concat "Really delete locks in " cvs-lock-file
"? "))
1969 (dolist (lock locks
)
1970 (cond ((file-directory-p lock
) (delete-directory lock
))
1971 ((file-exists-p lock
) (delete-file lock
))))))))
1974 (defun-cvs-mode cvs-mode-remove-handled
()
1975 "Remove all lines that are handled.
1976 Empty directories are removed."
1978 (cvs-cleanup-collection cvs-cookies
1979 t
(or cvs-auto-remove-directories
'handled
) t
))
1982 (defun-cvs-mode cvs-mode-acknowledge
()
1983 "Remove all marked files from the buffer."
1985 (dolist (fi (cvs-get-marked (cvs-ignore-marks-p "acknowledge") t
))
1986 (setf (cvs-fileinfo->type fi
) 'DEAD
))
1987 (cvs-cleanup-collection cvs-cookies nil nil nil
))
1989 (defun cvs-do-removal (filter &optional cmd all
)
1991 Returns a list of FIS that should be `cvs remove'd."
1992 (let* ((files (cvs-mode-marked filter cmd
:file t
:read-only t
))
1993 (fis (cdr (cvs-partition (lambda (fi)
1994 (eq (cvs-fileinfo->type fi
) 'UNKNOWN
))
1995 (cvs-mode-marked filter cmd
))))
1996 (silent (or (not cvs-confirm-removals
)
1997 (cvs-every (lambda (fi)
1998 (or (not (file-exists-p
1999 (cvs-fileinfo->full-path fi
)))
2000 (cvs-applicable-p fi
'safe-rm
)))
2002 (tmpbuf (cvs-temp-buffer)))
2003 (when (and (not silent
) (equal cvs-confirm-removals
'list
))
2004 (with-current-buffer tmpbuf
2005 (let ((inhibit-read-only t
))
2006 (cvs-insert-strings (mapcar 'cvs-fileinfo-
>full-path fis
))
2007 (cvs-pop-to-buffer-same-frame (current-buffer))
2008 (shrink-window-if-larger-than-buffer))))
2011 (yes-or-no-p (format "Delete %d files? " (length files
)))
2012 (cvs-bury-buffer tmpbuf cvs-buffer
))))
2013 (progn (message "Aborting") nil
)
2015 (let* ((type (cvs-fileinfo->type fi
))
2016 (file (cvs-fileinfo->full-path fi
)))
2017 (when (or all
(eq type
'UNKNOWN
))
2018 (when (file-exists-p file
) (delete-file file
))
2019 (unless all
(setf (cvs-fileinfo->type fi
) 'DEAD
) t
))))
2022 (defun-cvs-mode (cvs-mode-remove . SIMPLE
) (flags)
2023 "Remove all marked files.
2024 With prefix argument, prompt for cvs flags."
2025 (interactive (list (cvs-flags-query 'cvs-remove-flags
"cvs remove flags")))
2026 (let ((fis (cvs-do-removal 'remove
)))
2027 (if fis
(cvs-mode-run "remove" (cons "-f" flags
) fis
)
2028 (cvs-cleanup-collection cvs-cookies nil nil nil
))))
2031 (defvar cvs-tag-name
"")
2032 (defun-cvs-mode (cvs-mode-tag . SIMPLE
) (tag &optional flags
)
2033 "Run `cvs tag TAG' on all selected files.
2034 With prefix argument, prompt for cvs flags."
2036 (list (setq cvs-tag-name
2037 (cvs-query-read cvs-tag-name
"Tag name: " cvs-qtypedesc-tag
))
2038 (cvs-flags-query 'cvs-tag-flags
"tag flags")))
2039 (cvs-mode-do "tag" (append flags
(list tag
))
2040 (when cvs-force-dir-tag
'tag
)))
2042 (defun-cvs-mode (cvs-mode-untag . SIMPLE
) (tag &optional flags
)
2043 "Run `cvs tag -d TAG' on all selected files.
2044 With prefix argument, prompt for cvs flags."
2046 (list (setq cvs-tag-name
2047 (cvs-query-read cvs-tag-name
"Tag to delete: " cvs-qtypedesc-tag
))
2048 (cvs-flags-query 'cvs-tag-flags
"tag flags")))
2049 (cvs-mode-do "tag" (append '("-d") flags
(list tag
))
2050 (when cvs-force-dir-tag
'tag
)))
2053 ;; Byte compile files.
2055 (defun-cvs-mode cvs-mode-byte-compile-files
()
2056 "Run byte-compile-file on all selected files that end in '.el'."
2058 (let ((marked (cvs-get-marked (cvs-ignore-marks-p "byte-compile"))))
2060 (let ((filename (cvs-fileinfo->full-path fi
)))
2061 (when (string-match "\\.el\\'" filename
)
2062 (byte-compile-file filename
))))))
2064 ;; ChangeLog support.
2066 (defun-cvs-mode cvs-mode-add-change-log-entry-other-window
()
2067 "Add a ChangeLog entry in the ChangeLog of the current directory."
2069 (dolist (fi (cvs-mode-marked nil nil
))
2070 (let ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi
)))
2071 (buffer-file-name (expand-file-name (cvs-fileinfo->file fi
))))
2072 (kill-local-variable 'change-log-default-name
)
2073 (save-excursion (add-change-log-entry-other-window)))))
2075 ;; interactive commands to set optional flags
2077 (defun cvs-mode-set-flags (flag)
2078 "Ask for new setting of cvs-FLAG-flags."
2080 (list (completing-read
2082 '("cvs" "diff" "update" "status" "log" "tag" ;"rtag"
2083 "commit" "remove" "undo" "checkout")
2085 (let* ((sym (intern (concat "cvs-" flag
"-flags"))))
2086 (let ((current-prefix-arg '(16)))
2087 (cvs-flags-query sym
(concat flag
" flags")))))
2091 ;;;; Utilities for the *cvs* buffer
2094 (defun cvs-dir-member-p (fileinfo dir
)
2095 "Return true if FILEINFO represents a file in directory DIR."
2096 (and (not (eq (cvs-fileinfo->type fileinfo
) 'DIRCHANGE
))
2097 (cvs-string-prefix-p dir
(cvs-fileinfo->dir fileinfo
))))
2099 (defun cvs-execute-single-file (fi extractor program constant-args
)
2100 "Internal function for `cvs-execute-single-file-list'."
2101 (let* ((arg-list (funcall extractor fi
))
2102 (inhibit-read-only t
))
2104 ;; Execute the command unless extractor returned t.
2105 (when (listp arg-list
)
2106 (let* ((args (append constant-args arg-list
)))
2108 (insert (format "=== %s %s\n\n"
2109 program
(cvs-strings->string args
)))
2111 ;; FIXME: return the exit status?
2112 (apply 'call-process program nil t t args
)
2113 (goto-char (point-max))))))
2115 ;; FIXME: make this run in the background ala cvs-run-process...
2116 (defun cvs-execute-single-file-list (fis extractor program constant-args
)
2117 "Run PROGRAM on all elements on FIS.
2118 CONSTANT-ARGS is a list of strings to pass as arguments to PROGRAM.
2119 The arguments given to the program will be CONSTANT-ARGS followed by
2120 the list that EXTRACTOR returns.
2122 EXTRACTOR will be called once for each file on FIS. It is given
2123 one argument, the cvs-fileinfo. It can return t, which means ignore
2124 this file, or a list of arguments to send to the program."
2126 (cvs-execute-single-file fi extractor program constant-args
)))
2129 (defun cvs-revert-if-needed (fis)
2130 (dolist (fileinfo fis
)
2131 (let* ((file (cvs-fileinfo->full-path fileinfo
))
2132 (buffer (find-buffer-visiting file
)))
2133 ;; For a revert to happen the user must be editing the file...
2134 (unless (or (null buffer
)
2135 (eq (cvs-fileinfo->type fileinfo
) 'MESSAGE
)
2136 ;; FIXME: check whether revert is really needed.
2137 ;; `(verify-visited-file-modtime buffer)' doesn't cut it
2138 ;; because it only looks at the time stamp (it ignores
2139 ;; read-write changes) which is not changed by `commit'.
2140 (buffer-modified-p buffer
))
2141 (with-current-buffer buffer
2143 (revert-buffer 'ignore-auto
'dont-ask
'preserve-modes
)
2144 ;; `preserve-modes' avoids changing the (minor) modes. But we
2145 ;; do want to reset the mode for VC, so we do it explicitly.
2147 (when (eq (cvs-fileinfo->type fileinfo
) 'CONFLICT
)
2148 (smerge-mode 1))))))))
2151 (defun cvs-change-cvsroot (newroot)
2152 "Change the cvsroot."
2153 (interactive "DNew repository: ")
2154 (if (or (file-directory-p (expand-file-name "CVSROOT" newroot
))
2155 (y-or-n-p (concat "Warning: no CVSROOT found inside repository."
2156 " Change cvs-cvsroot anyhow?")))
2157 (setq cvs-cvsroot newroot
)))
2160 ;;;; useful global settings
2164 (add-to-list 'completion-ignored-extensions
"CVS/")
2167 ;; Hook to allow calling PCL-CVS by visiting the /CVS subdirectory
2171 (defcustom cvs-dired-action
'cvs-quickdir
2172 "The action to be performed when opening a CVS directory.
2173 Sensible values are `cvs-examine', `cvs-status' and `cvs-quickdir'."
2175 :type
'(choice (const cvs-examine
) (const cvs-status
) (const cvs-quickdir
)))
2178 (defcustom cvs-dired-use-hook
'(4)
2179 "Whether or not opening a CVS directory should run PCL-CVS.
2180 nil means never do it.
2181 ALWAYS means to always do it unless a prefix argument is given to the
2182 command that prompted the opening of the directory.
2183 Anything else means to do it only if the prefix arg is equal to this value."
2185 :type
'(choice (const :tag
"Never" nil
)
2186 (const :tag
"Always" always
)
2187 (const :tag
"Prefix" (4))))
2190 (progn (defun cvs-dired-noselect (dir)
2191 "Run `cvs-examine' if DIR is a CVS administrative directory.
2192 The exact behavior is determined also by `cvs-dired-use-hook'."
2194 (setq dir
(directory-file-name dir
))
2195 (when (and (string= "CVS" (file-name-nondirectory dir
))
2196 (file-readable-p (expand-file-name "Entries" dir
))
2198 (if (eq cvs-dired-use-hook
'always
)
2199 (not current-prefix-arg
)
2200 (equal current-prefix-arg cvs-dired-use-hook
)))
2202 (funcall cvs-dired-action
(file-name-directory dir
) t t
))))))
2208 (add-hook 'vc-post-command-functions
'cvs-vc-command-advice
)
2210 (defun cvs-vc-command-advice (command file flags
)
2211 (when (and (equal command
"cvs")
2213 (while (and (stringp (car flags
))
2214 (string-match "\\`-" (car flags
)))
2216 ;; don't parse output we don't understand.
2217 (member (car flags
) cvs-parse-known-commands
)))
2218 (save-current-buffer
2219 (let ((buffer (current-buffer))
2220 (dir default-directory
)
2222 (dolist (cvs-buf (buffer-list))
2223 (set-buffer cvs-buf
)
2224 ;; look for a corresponding pcl-cvs buffer
2225 (when (and (eq major-mode
'cvs-mode
)
2226 (cvs-string-prefix-p default-directory dir
))
2227 (let ((subdir (substring dir
(length default-directory
))))
2229 (set (make-local-variable 'cvs-buffer
) cvs-buf
)
2230 ;; `cvs -q add file' produces no useful output :-(
2231 (when (and (equal (car flags
) "add")
2232 (goto-char (point-min))
2233 (looking-at ".*to add this file permanently\n\\'"))
2234 (insert "cvs add: scheduling file `"
2235 (file-name-nondirectory file
)
2236 "' for addition\n"))
2237 ;; VC never (?) does `cvs -n update' so dcd=nil
2238 ;; should probably always be the right choice.
2239 (cvs-parse-process nil subdir
))))))))
2242 ;; Hook into write-buffer
2245 (defun cvs-mark-buffer-changed ()
2246 (let* ((file (expand-file-name buffer-file-name
))
2247 (version (and (fboundp 'vc-backend
)
2248 (eq (vc-backend file
) 'CVS
)
2249 (vc-workfile-version file
))))
2252 (dolist (cvs-buf (buffer-list))
2253 (set-buffer cvs-buf
)
2254 ;; look for a corresponding pcl-cvs buffer
2255 (when (and (eq major-mode
'cvs-mode
)
2256 (cvs-string-prefix-p default-directory file
))
2257 (let* ((file (substring file
(length default-directory
)))
2258 (fi (cvs-create-fileinfo
2259 (if (string= "0" version
)
2261 (or (file-name-directory file
) "")
2262 (file-name-nondirectory file
)
2263 "cvs-mark-buffer-changed")))
2264 (cvs-addto-collection cvs-cookies fi
))))))))
2266 (add-hook 'after-save-hook
'cvs-mark-buffer-changed
)
2271 ;;; pcvs.el ends here