X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/7ae1e293e573e57213a8970d4af8bb8982fc07cb..797d92ed1f986579ab155e1f2df346eb31cc4085:/lisp/pcvs.el diff --git a/lisp/pcvs.el b/lisp/pcvs.el index 32631c09da..f5564155ff 100644 --- a/lisp/pcvs.el +++ b/lisp/pcvs.el @@ -1,7 +1,7 @@ ;;; pcvs.el --- a front-end to CVS -;; Copyright (C) 1991,92,93,94,95,95,97,98,99,2000,2002 -;; Free Software Foundation, Inc. +;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +;; 2000, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. ;; Author: (The PCL-CVS Trust) pcl-cvs@cyclic.com ;; (Per Cederqvist) ceder@lysator.liu.se @@ -12,9 +12,8 @@ ;; (Stefan Monnier) monnier@cs.yale.edu ;; (Greg Klanderman) greg@alphatech.com ;; (Jari Aalto+mail.emacs) jari.aalto@poboxes.com -;; Maintainer: (Stefan Monnier) monnier+lists/cvs/pcl@flint.cs.yale.edu +;; Maintainer: (Stefan Monnier) monnier@gnu.org ;; Keywords: CVS, version control, release management -;; Revision: $Id: pcvs.el,v 1.45 2002/11/18 20:53:24 rost Exp $ ;; This file is part of GNU Emacs. @@ -30,8 +29,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -60,7 +59,7 @@ ;;; Todo: ;; ******** FIX THE DOCUMENTATION ********* -;; +;; ;; - rework the displaying of error messages. ;; - allow to flush messages only ;; - allow to protect files like ChangeLog from flushing @@ -72,7 +71,7 @@ ;; - allow cvs-confirm-removals to force always confirmation. ;; - cvs-checkout should ask for a revision (with completion). ;; - removal confirmation should allow specifying another file name. -;; +;; ;; - hide fileinfos without getting rid of them (will require ewok work). ;; - add toolbar entries ;; - marking @@ -202,6 +201,8 @@ ;;;; Mouse bindings and mode motion ;;;; +(defvar cvs-minor-current-files) + (defun cvs-menu (e) "Popup the CVS menu." (interactive "e") @@ -232,7 +233,7 @@ nil ;don't update display while running "status" "-v" - (cvs-fileinfo->full-path (car marked))) + (cvs-fileinfo->full-name (car marked))) (goto-char (point-min)) (let ((tags (cvs-status-get-tags))) (when (listp tags) tags))))))) @@ -243,17 +244,14 @@ ;;;; -(defun cvs-mode! (&optional -cvs-mode!-fun -cvs-mode!-noerror) +(defun cvs-mode! (&optional -cvs-mode!-fun) "Switch to the *cvs* buffer. If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer and with its window selected. Else, the *cvs* buffer is simply selected. -If -CVS-MODE!-NOERROR is non-nil, then failure to find a *cvs* buffer does - not generate an error and the current buffer is kept selected. -CVS-MODE!-FUN is called interactively if applicable and else with no argument." (let* ((-cvs-mode!-buf (current-buffer)) (cvsbuf (cond ((cvs-buffer-p) (current-buffer)) ((and cvs-buffer (cvs-buffer-p cvs-buffer)) cvs-buffer) - (-cvs-mode!-noerror (current-buffer)) (t (error "can't find the *cvs* buffer")))) (-cvs-mode!-wrapper cvs-minor-wrap-function) (-cvs-mode!-cont (lambda () @@ -360,7 +358,7 @@ from the current buffer." (dir default-directory) (buf (cond (name (cvs-get-buffer-create name)) - ((and (bufferp cvs-temp-buffer) (buffer-name cvs-temp-buffer)) + ((and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer)) cvs-temp-buffer) (t (set (make-local-variable 'cvs-temp-buffer) @@ -371,7 +369,14 @@ from the current buffer." (let ((proc (get-buffer-process buf))) (when (and (not normal) (processp proc) (memq (process-status proc) '(run stop))) - (error "Can not run two cvs processes simultaneously"))) + (if cmd + ;; When CMD is specified, the buffer is normally shown to the + ;; user, so interrupting the process is not harmful. + ;; Use `delete-process' rather than `kill-process' otherwise + ;; the pending output of the process will still get inserted + ;; after we erase the buffer. + (delete-process proc) + (error "Can not run two cvs processes simultaneously")))) (if (not name) (kill-local-variable 'other-window-scroll-buffer) ;; Strangely, if no window is created, `display-buffer' ends up @@ -446,12 +451,18 @@ If non-nil, NEW means to create a new buffer no matter what." (setq default-directory dir) (setq buffer-read-only nil) (erase-buffer) - (insert "\ -Repository : " (directory-file-name (cvs-get-cvsroot)) " -Module : " (cvs-get-module) " -Working dir: " (abbreviate-file-name dir) " - -") + (insert "Repository : " (directory-file-name (cvs-get-cvsroot)) + "\nModule : " (cvs-get-module) + "\nWorking dir: " (abbreviate-file-name dir) + (if (not (file-readable-p "CVS/Tag")) "\n" + (let ((tag (cvs-file-to-string "CVS/Tag"))) + (cond + ((string-match "\\`T" tag) + (concat "\nTag : " (substring tag 1))) + ((string-match "\\`D" tag) + (concat "\nDate : " (substring tag 1))) + ("\n")))) + "\n") (setq buffer-read-only t) (cvs-mode) (set (make-local-variable 'list-buffers-directory) buffer-name) @@ -501,7 +512,7 @@ Working dir: " (abbreviate-file-name dir) " (let* ((dir+files+rest (if (or (null fis) (not single-dir)) ;; not single-dir mode: just process the whole thing - (list "" (mapcar 'cvs-fileinfo->full-path fis) nil) + (list "" (mapcar 'cvs-fileinfo->full-name fis) nil) ;; single-dir mode: extract the same-dir-elements (let ((dir (cvs-fileinfo->dir (car fis)))) ;; output the concerned dir so the parser can translate paths @@ -517,38 +528,49 @@ Working dir: " (abbreviate-file-name dir) " (files (nth 1 dir+files+rest)) (rest (nth 2 dir+files+rest))) - ;; setup the (current) process buffer - (set (make-local-variable 'cvs-postprocess) - (if (null rest) - ;; this is the last invocation - postprocess - ;; else, we have to register ourselves to be rerun on the rest - `(cvs-run-process ',args ',rest ',postprocess ',single-dir))) (add-hook 'kill-buffer-hook (lambda () (let ((proc (get-buffer-process (current-buffer)))) (when (processp proc) (set-process-filter proc nil) - (set-process-sentinel proc nil) - (delete-process proc)))) + ;; Abort postprocessing but leave the sentinel so it + ;; will update the list of running procs. + (process-put proc 'cvs-postprocess nil) + (interrupt-process proc)))) nil t) ;; create the new process and setup the procbuffer correspondingly - (let* ((args (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) + (let* ((msg (cvs-header-msg args fis)) + (args (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) (if cvs-cvsroot (list "-d" cvs-cvsroot)) args files)) ;; If process-connection-type is nil and the repository ;; is accessed via SSH, a bad interaction between libc, ;; CVS and SSH can lead to garbled output. - ;; It might be a glibc-specific problem. - ;; Until the problem is cleared, we'll use a pty rather than - ;; a pipe. - ;; (process-connection-type nil) ; Use a pipe, not a pty. + ;; It might be a glibc-specific problem (but it can also happens + ;; under Mac OS X, it seems). + ;; It seems that using a pty can help circumvent the problem, + ;; but at the cost of screwing up when the process thinks it + ;; can ask for user input (such as password or host-key + ;; confirmation). A better workaround is to set CVS_RSH to + ;; an appropriate script, or to use a later version of CVS. + (process-connection-type nil) ; Use a pipe, not a pty. (process ;; the process will be run in the selected dir (let ((default-directory (cvs-expand-dir-name dir))) (apply 'start-process "cvs" procbuf cvs-program args)))) + ;; setup the process. + (process-put process 'cvs-buffer cvs-buffer) + (with-current-buffer cvs-buffer (cvs-update-header msg 'add)) + (process-put process 'cvs-header msg) + (process-put + process 'cvs-postprocess + (if (null rest) + ;; this is the last invocation + postprocess + ;; else, we have to register ourselves to be rerun on the rest + `(cvs-run-process ',args ',rest ',postprocess ',single-dir))) (set-process-sentinel process 'cvs-sentinel) (set-process-filter process 'cvs-update-filter) (set-marker (process-mark process) (point-max)) @@ -563,7 +585,7 @@ Working dir: " (abbreviate-file-name dir) " ;; emacsen. It shouldn't be needed, but it does no harm. (sit-for 0)) -(defun cvs-update-header (args fis) ; inline +(defun cvs-header-msg (args fis) (let* ((lastarg nil) (args (mapcar (lambda (arg) (cond @@ -583,38 +605,40 @@ Working dir: " (abbreviate-file-name dir) " (concat (match-string 0 arg) "")) ;; Keep the rest as is. (t arg))) - args)) - ;; turn them into a string - (arg (cvs-strings->string - (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) - (if cvs-cvsroot (list "-d" cvs-cvsroot)) - args - (mapcar 'cvs-fileinfo->full-path fis)))) - (str (if args (concat "-- Running " cvs-program " " arg " ...\n") - "\n"))) - (if nil (insert str) ;inline - ;;(with-current-buffer cvs-buffer - (let* ((prev-msg (car (ewoc-get-hf cvs-cookies))) - (tin (ewoc-nth cvs-cookies 0))) - ;; look for the first *real* fileinfo (to determine emptyness) - (while - (and tin - (memq (cvs-fileinfo->type (ewoc-data tin)) - '(MESSAGE DIRCHANGE))) - (setq tin (ewoc-next cvs-cookies tin))) - ;; cleanup the prev-msg - (when (string-match "Running \\(.*\\) ...\n" prev-msg) - (setq prev-msg - (concat - "-- last cmd: " - (match-string 1 prev-msg) - " --"))) - ;; set the new header and footer - (ewoc-set-hf cvs-cookies - str (concat "\n--------------------- " - (if tin "End" "Empty") - " ---------------------\n" - prev-msg)))))) + args))) + (concat cvs-program " " + (cvs-strings->string + (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery) + (if cvs-cvsroot (list "-d" cvs-cvsroot)) + args + (mapcar 'cvs-fileinfo->full-name fis)))))) + +(defun cvs-update-header (cmd add) + (let* ((hf (ewoc-get-hf cvs-cookies)) + (str (car hf)) + (done "") + (tin (ewoc-nth cvs-cookies 0))) + (if (eq (length str) 1) (setq str "")) + ;; look for the first *real* fileinfo (to determine emptyness) + (while + (and tin + (memq (cvs-fileinfo->type (ewoc-data tin)) + '(MESSAGE DIRCHANGE))) + (setq tin (ewoc-next cvs-cookies tin))) + (if add + (setq str (concat "-- Running " cmd " ...\n" str)) + (if (not (string-match + (concat "^-- Running " (regexp-quote cmd) " \\.\\.\\.\n") str)) + (error "Internal PCL-CVS error while removing message") + (setq str (replace-match "" t t str)) + (if (zerop (length str)) (setq str "\n")) + (setq done (concat "-- last cmd: " cmd " --")))) + ;; set the new header and footer + (ewoc-set-hf cvs-cookies + str (concat "\n--------------------- " + (if tin "End" "Empty") + " ---------------------\n" + done)))) (defun cvs-sentinel (proc msg) @@ -622,34 +646,35 @@ Working dir: " (abbreviate-file-name dir) " This is responsible for parsing the output from the cvs update when it is finished." (when (memq (process-status proc) '(signal exit)) - (if (null (buffer-name (process-buffer proc))) - ;;(set-process-buffer proc nil) - (error "cvs' process buffer was killed") - (let* ((obuf (current-buffer)) - (procbuffer (process-buffer proc))) - (set-buffer (with-current-buffer procbuffer cvs-buffer)) - (setq cvs-mode-line-process (symbol-name (process-status proc))) - (force-mode-line-update) - (set-buffer procbuffer) - (let ((cvs-postproc cvs-postprocess)) - ;; Since the buffer and mode line will show that the - ;; process is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc) - (setq cvs-postprocess nil) - ;; do the postprocessing like parsing and such - (save-excursion (eval cvs-postproc)) - ;; check whether something is left - (unless cvs-postprocess - ;; IIRC, we enable undo again once the process is finished - ;; for cases where the output was inserted in *vc-diff* or - ;; in a file-like buffer. -stef - (buffer-enable-undo) - (with-current-buffer cvs-buffer - (cvs-update-header nil nil) ;FIXME: might need to be inline - (message "CVS process has completed in %s" (buffer-name))))) - ;; This might not even be necessary - (set-buffer obuf))))) + (let ((cvs-postproc (process-get proc 'cvs-postprocess)) + (cvs-buf (process-get proc 'cvs-buffer))) + ;; Since the buffer and mode line will show that the + ;; process is dead, we can delete it now. Otherwise it + ;; will stay around until M-x list-processes. + (process-put proc 'postprocess nil) + (delete-process proc) + ;; Don't do anything if the main buffer doesn't exist any more. + (when (buffer-live-p cvs-buf) + (with-current-buffer cvs-buf + (cvs-update-header (process-get proc 'cvs-header) nil) + (setq cvs-mode-line-process (symbol-name (process-status proc))) + (force-mode-line-update) + (when cvs-postproc + (if (null (buffer-live-p (process-buffer proc))) + ;;(set-process-buffer proc nil) + (error "cvs' process buffer was killed") + (with-current-buffer (process-buffer proc) + ;; do the postprocessing like parsing and such + (save-excursion (eval cvs-postproc)) + ;; check whether something is left + (unless (get-buffer-process (current-buffer)) + ;; IIRC, we enable undo again once the process is finished + ;; for cases where the output was inserted in *vc-diff* or + ;; in a file-like buffer. --Stef + (buffer-enable-undo) + (with-current-buffer cvs-buffer + (message "CVS process has completed in %s" + (buffer-name)))))))))))) (defun cvs-parse-process (dcd &optional subdir old-fis) "Parse the output of a cvs process. @@ -657,6 +682,14 @@ DCD is the `dont-change-disc' flag to use when parsing that output. SUBDIR is the subdirectory (if any) where this command was run. OLD-FIS is the list of fileinfos on which the cvs command was applied and which should be considered up-to-date if they are missing from the output." + (when (eq system-type 'darwin) + ;; Fixup the ^D^H^H inserted at beginning of buffer sometimes on MacOSX + ;; because of the call to `process-send-eof'. + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^\\^D+" nil t) + (let ((inhibit-read-only t)) + (delete-region (match-beginning 0) (match-end 0)))))) (let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir)) last) (with-current-buffer cvs-buffer @@ -731,7 +764,6 @@ clear what alternative to use. ((eq style 'DOUBLE) (string-match ".*" docstring) (let ((line1 (match-string 0 docstring)) - (restdoc (substring docstring (match-end 0))) (fun-1 (intern (concat (symbol-name fun) "-1")))) `(progn (defun ,fun-1 ,args @@ -745,12 +777,12 @@ before calling the real function `" (symbol-name fun-1) "'.\n") (interactive) (cvs-mode! ',fun-1))))) - (t (error "unknown style %s in `defun-cvs-mode'" style))))) + (t (error "Unknown style %s in `defun-cvs-mode'" style))))) (defun-cvs-mode cvs-mode-kill-process () "Kill the temporary buffer and associated process." (interactive) - (when (and (bufferp cvs-temp-buffer) (buffer-name cvs-temp-buffer)) + (when (and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer)) (let ((proc (get-buffer-process cvs-temp-buffer))) (when proc (delete-process proc))))) @@ -799,7 +831,7 @@ the problem." (and (or (eq (cvs-fileinfo->type fi) 'REMOVED) (and (eq (cvs-fileinfo->type fi) 'CONFLICT) (eq (cvs-fileinfo->subtype fi) 'REMOVED))) - (file-exists-p (cvs-fileinfo->full-path fi)))) + (file-exists-p (cvs-fileinfo->full-name fi)))) ;; called at the following times: ;; - postparse ((eq cvs-auto-remove-handled t) cvs-auto-remove-directories nil) @@ -886,24 +918,44 @@ This usually doesn't really work but is a handy initval in a prompt." ;;;; ;;;###autoload -(defun cvs-checkout (modules dir flags) +(defun cvs-checkout (modules dir flags &optional root) "Run a 'cvs checkout MODULES' in DIR. Feed the output to a *cvs* buffer, display it in the current window, and run `cvs-mode' on it. With a prefix argument, prompt for cvs FLAGS to use." (interactive - (list (cvs-string->strings (read-string "Module(s): " (cvs-get-module))) - (read-directory-name "CVS Checkout Directory: " - nil default-directory nil) - (cvs-add-branch-prefix - (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")))) + (let ((root (cvs-get-cvsroot))) + (if (or (null root) current-prefix-arg) + (setq root (read-string "CVS Root: "))) + (list (cvs-string->strings (read-string "Module(s): " (cvs-get-module))) + (read-directory-name "CVS Checkout Directory: " + nil default-directory nil) + (cvs-add-branch-prefix + (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")) + root))) (when (eq flags t) (setf flags (cvs-flags-query 'cvs-checkout-flags nil 'noquery))) - (cvs-cmd-do "checkout" (or dir default-directory) - (append flags modules) nil 'new - :noexist t)) - + (let ((cvs-cvsroot root)) + (cvs-cmd-do "checkout" (or dir default-directory) + (append flags modules) nil 'new + :noexist t))) + +(defun-cvs-mode (cvs-mode-checkout . NOARGS) (dir) + "Run cvs checkout against the current branch. +The files are stored to DIR." + (interactive + (let* ((branch (cvs-prefix-get 'cvs-branch-prefix)) + (prompt (format "CVS Checkout Directory for `%s%s': " + (cvs-get-module) + (if branch (format " (branch: %s)" branch) + "")))) + (list (read-directory-name prompt nil default-directory nil)))) + (let ((modules (cvs-string->strings (cvs-get-module))) + (flags (cvs-add-branch-prefix + (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags"))) + (cvs-cvsroot (cvs-get-cvsroot))) + (cvs-checkout modules dir flags))) ;;;; ;;;; The code for running a "cvs update" and friends in various ways. @@ -966,6 +1018,7 @@ Optional argument NOSHOW if non-nil means not to display the buffer." (cvs-flags-query 'cvs-update-flags "cvs -n update flags"))) (when (eq flags t) (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery))) + (when find-file-visit-truename (setq directory (file-truename directory))) (cvs-cmd-do "update" directory flags nil (> (prefix-numeric-value current-prefix-arg) 8) :cvsargs '("-n") @@ -1060,7 +1113,7 @@ the override will persist until the next toggle." (cvs-prefix-set 'cvs-force-command arg)) (put 'cvs-mode 'mode-class 'special) -(define-derived-mode cvs-mode fundamental-mode "CVS" +(define-derived-mode cvs-mode nil "CVS" "Mode used for PCL-CVS, a frontend to CVS. Full documentation is in the Texinfo file." (setq mode-line-process @@ -1069,6 +1122,8 @@ Full documentation is in the Texinfo file." ("" cvs-branch-prefix (cvs-secondary-branch-prefix ("->" cvs-secondary-branch-prefix)))) " " cvs-mode-line-process)) + (if buffer-file-name + (error "Use M-x cvs-quickdir to get a *cvs* buffer")) (buffer-disable-undo) ;;(set (make-local-variable 'goal-column) cvs-cursor-column) (set (make-local-variable 'revert-buffer-function) 'cvs-mode-revert-buffer) @@ -1095,7 +1150,7 @@ Full documentation is in the Texinfo file." (eq (ewoc-buffer cvs-cookies) buf) (setq check 'cvs-temp-buffer) (or (null cvs-temp-buffer) - (null (buffer-name cvs-temp-buffer)) + (null (buffer-live-p cvs-temp-buffer)) (and (eq (with-current-buffer cvs-temp-buffer cvs-buffer) buf) (equal (with-current-buffer cvs-temp-buffer default-directory) @@ -1172,11 +1227,12 @@ marked instead. A directory can never be marked." (ewoc-invalidate cvs-cookies tin) (cvs-mode-next-line 1)))) -(defun cvs-mouse-toggle-mark (e) - "Toggle the mark of the entry under the mouse." - (interactive "e") +(defalias 'cvs-mouse-toggle-mark 'cvs-mode-toggle-mark) +(defun cvs-mode-toggle-mark (e) + "Toggle the mark of the entry at point." + (interactive (list last-input-event)) (save-excursion - (mouse-set-point e) + (posn-set-point (event-end e)) (cvs-mode-mark 'toggle))) (defun-cvs-mode cvs-mode-unmark () @@ -1242,7 +1298,8 @@ they should always be unmarked." (let ((tin (ewoc-goto-prev cvs-cookies 1))) (when tin (setf (cvs-fileinfo->marked (ewoc-data tin)) nil) - (ewoc-invalidate cvs-cookies tin)))) + (ewoc-invalidate cvs-cookies tin))) + (cvs-move-to-goal-column)) (defconst cvs-ignore-marks-alternatives '(("toggle-marks" . "/TM") @@ -1282,17 +1339,13 @@ See `cvs-prefix-set' for further description of the behavior. (defun cvs-mode-mark-get-modif (cmd) (if (cvs-ignore-marks-p cmd 'read-only) "/IM" "/FM")) -(defvar cvs-minor-current-files) (defun cvs-get-marked (&optional ignore-marks ignore-contents) "Return a list of all selected fileinfos. If there are any marked tins, and IGNORE-MARKS is nil, return them. Otherwise, if the cursor selects a directory, and IGNORE-CONTENTS is nil, return all files in it, else return just the directory. Otherwise return (a list containing) the file the cursor points to, or -an empty list if it doesn't point to a file at all. - -Args: &optional IGNORE-MARKS IGNORE-CONTENTS." - +an empty list if it doesn't point to a file at all." (let ((fis nil)) (dolist (fi (if (and (boundp 'cvs-minor-current-files) (consp cvs-minor-current-files)) @@ -1353,7 +1406,7 @@ If FILE is non-nil, directory entries won't be selected." (defun cvs-mode-files (&rest -cvs-mode-files-args) (cvs-mode! (lambda () - (mapcar 'cvs-fileinfo->full-path + (mapcar 'cvs-fileinfo->full-name (apply 'cvs-mode-marked -cvs-mode-files-args))))) ;; @@ -1385,12 +1438,10 @@ The POSTPROC specified there (typically `log-edit') is then called, ;; displayed in the wrong minibuffer). (cvs-mode!) (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup)) - (lbd list-buffers-directory) (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist))) 'log-edit))) (funcall setupfun 'cvs-do-commit setup 'cvs-commit-filelist buf) (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-commit-minor-wrap) - (set (make-local-variable 'list-buffers-directory) lbd) (run-hooks 'cvs-mode-commit-hook))) (defun cvs-commit-minor-wrap (buf f) @@ -1426,6 +1477,7 @@ The POSTPROC specified there (typically `log-edit') is then called, (match-beginning 0) (point)))))) +(defvar cvs-edit-log-revision) (defun cvs-mode-edit-log (rev &optional text) "Edit the log message at point. This is best called from a `log-view-mode' buffer." @@ -1440,14 +1492,12 @@ This is best called from a `log-view-mode' buffer." ;; displayed in the wrong minibuffer). (cvs-mode!) (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup)) - (lbd list-buffers-directory) (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist))) 'log-edit))) (funcall setupfun 'cvs-do-edit-log nil 'cvs-edit-log-filelist buf) (when text (erase-buffer) (insert text)) (set (make-local-variable 'cvs-edit-log-revision) rev) (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-edit-log-minor-wrap) - (set (make-local-variable 'list-buffers-directory) lbd) ;; (run-hooks 'cvs-mode-commit-hook) )) @@ -1510,7 +1560,7 @@ With prefix argument, prompt for cvs flags." ;; find directories and look for fis needing a description (dolist (fi fis) (cond - ((file-directory-p (cvs-fileinfo->full-path fi)) (push fi dirs)) + ((file-directory-p (cvs-fileinfo->full-name fi)) (push fi dirs)) ((eq (cvs-fileinfo->type fi) 'UNKNOWN) (setq needdesc t)))) ;; prompt for description if necessary (let* ((msg (if (and needdesc @@ -1544,6 +1594,18 @@ See ``cvs-mode-diff'' for more info." (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) (cvs-mode-diff-1 (cons "-rHEAD" flags))) +(defun-cvs-mode (cvs-mode-diff-repository . SIMPLE) (flags) + "Diff the files for changes in the repository since last co/update/commit. +See ``cvs-mode-diff'' for more info." + (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) + (cvs-mode-diff-1 (cons "-rBASE" (cons "-rHEAD" flags)))) + +(defun-cvs-mode (cvs-mode-diff-yesterday . SIMPLE) (flags) + "Diff the selected files against yesterday's head of the current branch. +See ``cvs-mode-diff'' for more info." + (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags"))) + (cvs-mode-diff-1 (cons "-Dyesterday" flags))) + (defun-cvs-mode (cvs-mode-diff-vendor . SIMPLE) (flags) "Diff the selected files against the head of the vendor branch. See ``cvs-mode-diff'' for more info." @@ -1558,9 +1620,7 @@ or \"Conflict\" in the *cvs* buffer." (interactive (list (cvs-flags-query 'cvs-diff-flags "diff flags"))) (unless (listp flags) (error "flags should be a list of strings")) (save-some-buffers) - (let* ((filter 'diff) - (marked (cvs-get-marked (cvs-ignore-marks-p "diff"))) - ;;(tins (cvs-filter-applicable filter marked)) + (let* ((marked (cvs-get-marked (cvs-ignore-marks-p "diff"))) (fis (car (cvs-partition 'cvs-fileinfo->backup-file marked)))) (unless (consp fis) (error "No files with a backup file selected!")) @@ -1578,8 +1638,8 @@ or \"Conflict\" in the *cvs* buffer." Signal an error if there is no backup file." (let ((backup-file (cvs-fileinfo->backup-file fileinfo))) (unless backup-file - (error "%s has no backup file" (cvs-fileinfo->full-path fileinfo))) - (list backup-file (cvs-fileinfo->full-path fileinfo)))) + (error "%s has no backup file" (cvs-fileinfo->full-name fileinfo))) + (list backup-file (cvs-fileinfo->full-name fileinfo)))) ;; ;; Emerge support @@ -1593,6 +1653,7 @@ Signal an error if there is no backup file." ;; (defvar ediff-after-quit-destination-buffer) +(defvar ediff-after-quit-hook-internal) (defvar cvs-transient-buffers) (defun cvs-ediff-startup-hook () (add-hook 'ediff-after-quit-hook-internal @@ -1632,13 +1693,21 @@ Signal an error if there is no backup file." (defun cvs-retrieve-revision (fileinfo rev) "Retrieve the given REVision of the file in FILEINFO into a new buffer." - (let* ((file (cvs-fileinfo->full-path fileinfo)) + (let* ((file (cvs-fileinfo->full-name fileinfo)) (buffile (concat file "." rev))) (or (find-buffer-visiting buffile) (with-current-buffer (create-file-buffer buffile) (message "Retrieving revision %s..." rev) - (let ((res (call-process cvs-program nil t nil - "-q" "update" "-p" "-r" rev file))) + ;; Discard stderr output to work around the CVS+SSH+libc + ;; problem when stdout and stderr are the same. + (let ((res (apply 'call-process cvs-program nil '(t nil) nil + "-q" "update" "-p" + ;; If `rev' is HEAD, don't pass it at all: + ;; the default behavior is to get the head + ;; of the current branch whereas "-r HEAD" + ;; stupidly gives you the head of the trunk. + (append (unless (equal rev "HEAD") (list "-r" rev)) + (list file))))) (when (and res (not (and (equal 0 res)))) (error "Something went wrong retrieving revision %s: %s" rev res)) (set-buffer-modified-p nil) @@ -1648,8 +1717,6 @@ Signal an error if there is no backup file." (message "Retrieving revision %s... Done" rev) (current-buffer)))))) -(eval-and-compile (autoload 'smerge-ediff "smerge-mode")) - ;; FIXME: The user should be able to specify ancestor/head/backup and we should ;; provide sensible defaults when merge info is unavailable (rather than rely ;; on smerge-ediff). Also provide sane defaults for need-merge files. @@ -1658,7 +1725,7 @@ Signal an error if there is no backup file." (interactive) (let ((fi (cvs-mode-marked 'merge nil :one t :file t))) (let ((merge (cvs-fileinfo->merge fi)) - (file (cvs-fileinfo->full-path fi)) + (file (cvs-fileinfo->full-name fi)) (backup-file (cvs-fileinfo->backup-file fi))) (if (not (and merge backup-file)) (let ((buf (find-file-noselect file))) @@ -1689,7 +1756,7 @@ Signal an error if there is no backup file." (list (or rev1 (cvs-flags-query 'cvs-idiff-version)) rev2))) (let ((fi (cvs-mode-marked 'diff "idiff" :one t :file t))) - (let* ((file (cvs-fileinfo->full-path fi)) + (let* ((file (cvs-fileinfo->full-name fi)) (rev1-buf (cvs-retrieve-revision fi (or rev1 "BASE"))) (rev2-buf (if rev2 (cvs-retrieve-revision fi rev2))) ;; this binding is used by cvs-ediff-startup-hook @@ -1707,13 +1774,13 @@ Signal an error if there is no backup file." (error "idiff-other cannot be applied to more than 2 files at a time")) (let* ((fi1 (car fis)) (rev1-buf (if rev1 (cvs-retrieve-revision fi1 rev1) - (find-file-noselect (cvs-fileinfo->full-path fi1)))) + (find-file-noselect (cvs-fileinfo->full-name fi1)))) rev2-buf) (if (cdr fis) (let ((fi2 (nth 1 fis))) (setq rev2-buf (if rev2 (cvs-retrieve-revision fi2 rev2) - (find-file-noselect (cvs-fileinfo->full-path fi2))))) + (find-file-noselect (cvs-fileinfo->full-name fi2))))) (error "idiff-other doesn't know what other file/buffer to use")) (let* (;; this binding is used by cvs-ediff-startup-hook (cvs-transient-buffers (list rev1-buf rev2-buf))) @@ -1722,13 +1789,13 @@ Signal an error if there is no backup file." (defun cvs-is-within-p (fis dir) - "Non-nil is buffer is inside one of FIS (in DIR)." + "Non-nil if buffer is inside one of FIS (in DIR)." (when (stringp buffer-file-name) (setq buffer-file-name (expand-file-name buffer-file-name)) (let (ret) (dolist (fi (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." "")))) (when (cvs-string-prefix-p - (expand-file-name (cvs-fileinfo->full-path fi) dir) + (expand-file-name (cvs-fileinfo->full-name fi) dir) buffer-file-name) (setq ret t))) ret))) @@ -1742,7 +1809,7 @@ BUF is the buffer to be used for cvs' output. DONT-CHANGE-DISC non-nil indicates that the command will not change the contents of files. This is only used by the parser. POSTPROC is a list of expressions to be evaluated at the very end (after - parsing if applicable). It will be prepended with `progn' is necessary." + parsing if applicable). It will be prepended with `progn' if necessary." (let ((def-dir default-directory)) ;; Save the relevant buffers (save-some-buffers nil (lambda () (cvs-is-within-p fis def-dir)))) @@ -1753,8 +1820,7 @@ POSTPROC is a list of expressions to be evaluated at the very end (after ;; (equal (cvs-fileinfo->file (car fis)) ".") (equal (cvs-fileinfo->dir (car fis)) "")) (setq fis nil)) - (let* ((cvs-buf (current-buffer)) - (single-dir (or (not (listp cvs-execute-single-dir)) + (let* ((single-dir (or (not (listp cvs-execute-single-dir)) (member cmd cvs-execute-single-dir))) (parse (member cmd cvs-parse-known-commands)) (args (append cvsargs (list cmd) flags)) @@ -1770,16 +1836,14 @@ POSTPROC is a list of expressions to be evaluated at the very end (after (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." "")))))) (push `(cvs-parse-process ',dont-change-disc nil ',old-fis) postproc))) (setq postproc (if (cdr postproc) (cons 'progn postproc) (car postproc))) - (cvs-update-header args fis) (with-current-buffer buf - ;;(set (make-local-variable 'cvs-buffer) cvs-buf) (let ((inhibit-read-only t)) (erase-buffer)) (message "Running cvs %s ..." cmd) (cvs-run-process args fis postproc single-dir)))) (defun* cvs-mode-do (cmd flags filter - &key show dont-change-disc parse cvsargs postproc) + &key show dont-change-disc cvsargs postproc) "Generic cvs-mode- function. Executes `cvs CVSARGS CMD FLAGS' on the selected files. FILTER is passed to `cvs-applicable-p' to only apply the command to @@ -1849,24 +1913,27 @@ With a prefix argument, prompt for cvs flags." This command ignores files that are not flagged as `Unknown'." (interactive) (dolist (fi (cvs-mode-marked 'ignore)) - (cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi)) + (cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi) + (eq (cvs-fileinfo->subtype fi) 'NEW-DIR)) (setf (cvs-fileinfo->type fi) 'DEAD)) (cvs-cleanup-collection cvs-cookies nil nil nil)) -(defun cvs-append-to-ignore (dir str) - "Add STR to the .cvsignore file in DIR." - (save-window-excursion - (set-buffer (find-file-noselect (expand-file-name ".cvsignore" dir))) +(defun cvs-append-to-ignore (dir str &optional old-dir) + "Add STR to the .cvsignore file in DIR. +If OLD-DIR is non-nil, then this is a directory that we don't want +to hear about anymore." + (with-current-buffer + (find-file-noselect (expand-file-name ".cvsignore" dir)) (when (ignore-errors (and buffer-read-only (eq 'CVS (vc-backend buffer-file-name)) (not (vc-editable-p buffer-file-name)))) ;; CVSREAD=on special case - (vc-toggle-read-only)) + (vc-checkout buffer-file-name t)) (goto-char (point-max)) - (unless (zerop (current-column)) (insert "\n")) - (insert str "\n") + (unless (bolp) (insert "\n")) + (insert str (if old-dir "/\n" "\n")) (if cvs-sort-ignore-file (sort-lines nil (point-min) (point-max))) (save-buffer))) @@ -1883,6 +1950,18 @@ This command ignores files that are not flagged as `Unknown'." (cvs-mode-find-file e 'dont-select)) +(defun cvs-mode-view-file (e) + "View the file." + (interactive (list last-input-event)) + (cvs-mode-find-file e nil t)) + + +(defun cvs-mode-view-file-other-window (e) + "View the file." + (interactive (list last-input-event)) + (cvs-mode-find-file e t t)) + + (defun cvs-find-modif (fi) (with-temp-buffer (call-process cvs-program nil (current-buffer) nil @@ -1893,14 +1972,16 @@ This command ignores files that are not flagged as `Unknown'." 1))) -(defun cvs-mode-find-file (e &optional other) +(defun cvs-mode-find-file (e &optional other view) "Select a buffer containing the file. With a prefix, opens the buffer in an OTHER window." (interactive (list last-input-event current-prefix-arg)) - (when (ignore-errors (mouse-set-point e) t) ;for invocation via the mouse - (unless (memq (get-text-property (1- (line-end-position)) 'font-lock-face) - '(cvs-header-face cvs-filename-face)) - (error "Not a file name"))) + ;; If the event moves point, check that it moves it to a valid location. + (when (and (/= (point) (progn (posn-set-point (event-end e)) (point))) + (not (memq (get-text-property (1- (line-end-position)) + 'font-lock-face) + '(cvs-header cvs-filename)))) + (error "Not a file name")) (cvs-mode! (lambda (&optional rev) (interactive (list (cvs-prefix-get 'cvs-branch-prefix))) @@ -1917,10 +1998,12 @@ With a prefix, opens the buffer in an OTHER window." (set-buffer cvs-buf) (setq default-directory odir)) (let ((buf (if rev (cvs-retrieve-revision fi rev) - (find-file-noselect (cvs-fileinfo->full-path fi))))) + (find-file-noselect (cvs-fileinfo->full-name fi))))) (funcall (cond ((eq other 'dont-select) 'display-buffer) - (other 'switch-to-buffer-other-window) - (t 'switch-to-buffer)) + (other + (if view 'view-buffer-other-window + 'switch-to-buffer-other-window)) + (t (if view 'view-buffer 'switch-to-buffer))) buf) (when (and cvs-find-file-and-jump (cvs-applicable-p fi 'diff-base)) (goto-line (cvs-find-modif fi))) @@ -2006,24 +2089,33 @@ Returns a list of FIS that should be `cvs remove'd." (silent (or (not cvs-confirm-removals) (cvs-every (lambda (fi) (or (not (file-exists-p - (cvs-fileinfo->full-path fi))) + (cvs-fileinfo->full-name fi))) (cvs-applicable-p fi 'safe-rm))) files))) (tmpbuf (cvs-temp-buffer))) (when (and (not silent) (equal cvs-confirm-removals 'list)) (with-current-buffer tmpbuf (let ((inhibit-read-only t)) - (cvs-insert-strings (mapcar 'cvs-fileinfo->full-path fis)) + (cvs-insert-strings (mapcar 'cvs-fileinfo->full-name fis)) (cvs-pop-to-buffer-same-frame (current-buffer)) (shrink-window-if-larger-than-buffer)))) (if (not (or silent (unwind-protect - (yes-or-no-p (format "Delete %d files? " (length files))) + (yes-or-no-p + (let ((nfiles (length files)) + (verb (if (eq filter 'undo) "Undo" "Delete"))) + (if (= 1 nfiles) + (format "%s file: \"%s\" ? " + verb + (cvs-fileinfo->file (car files))) + (format "%s %d files? " + verb + nfiles)))) (cvs-bury-buffer tmpbuf cvs-buffer)))) (progn (message "Aborting") nil) (dolist (fi files) (let* ((type (cvs-fileinfo->type fi)) - (file (cvs-fileinfo->full-path fi))) + (file (cvs-fileinfo->full-name fi))) (when (or all (eq type 'UNKNOWN)) (when (file-exists-p file) (delete-file file)) (unless all (setf (cvs-fileinfo->type fi) 'DEAD) t)))) @@ -2041,7 +2133,10 @@ With prefix argument, prompt for cvs flags." (defvar cvs-tag-name "") (defun-cvs-mode (cvs-mode-tag . SIMPLE) (tag &optional flags) "Run `cvs tag TAG' on all selected files. -With prefix argument, prompt for cvs flags." +With prefix argument, prompt for cvs flags. +By default this can only be used on directories. +Use \\[cvs-mode-force-command] or change `cvs-force-dir-tag' if you need +to use it on individual files." (interactive (list (setq cvs-tag-name (cvs-query-read cvs-tag-name "Tag name: " cvs-qtypedesc-tag)) @@ -2067,7 +2162,7 @@ With prefix argument, prompt for cvs flags." (interactive) (let ((marked (cvs-get-marked (cvs-ignore-marks-p "byte-compile")))) (dolist (fi marked) - (let ((filename (cvs-fileinfo->full-path fi))) + (let ((filename (cvs-fileinfo->full-name fi))) (when (string-match "\\.el\\'" filename) (byte-compile-file filename)))))) @@ -2077,8 +2172,8 @@ With prefix argument, prompt for cvs flags." "Add a ChangeLog entry in the ChangeLog of the current directory." (interactive) (dolist (fi (cvs-mode-marked nil nil)) - (let ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi))) - (buffer-file-name (expand-file-name (cvs-fileinfo->file fi)))) + (let* ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi))) + (buffer-file-name (expand-file-name (cvs-fileinfo->file fi)))) (kill-local-variable 'change-log-default-name) (save-excursion (add-change-log-entry-other-window))))) @@ -2138,7 +2233,7 @@ this file, or a list of arguments to send to the program." (defun cvs-revert-if-needed (fis) (dolist (fileinfo fis) - (let* ((file (cvs-fileinfo->full-path fileinfo)) + (let* ((file (cvs-fileinfo->full-name fileinfo)) (buffer (find-buffer-visiting file))) ;; For a revert to happen the user must be editing the file... (unless (or (null buffer) @@ -2224,7 +2319,12 @@ The exact behavior is determined also by `cvs-dired-use-hook'." (string-match "\\`-" (car flags))) (pop flags)) ;; don't parse output we don't understand. - (member (car flags) cvs-parse-known-commands))) + (member (car flags) cvs-parse-known-commands)) + ;; Don't parse "update -p" output. + (not (and (member (car flags) '("update" "checkout")) + (let ((found-p nil)) + (dolist (flag flags found-p) + (if (equal flag "-p") (setq found-p t))))))) (save-current-buffer (let ((buffer (current-buffer)) (dir default-directory) @@ -2278,4 +2378,5 @@ The exact behavior is determined also by `cvs-dired-use-hook'." (provide 'pcvs) +;; arch-tag: 8e3a7494-0453-4389-9ab3-a557ce9fab61 ;;; pcvs.el ends here