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