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