X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/906cbe4568735cd8184b72399588c13918111346..937640a621a4ce2e5e56eaecca37a2a28a584318:/lisp/pcvs.el diff --git a/lisp/pcvs.el b/lisp/pcvs.el index a1ff378bd5..0c8fe92f2d 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 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.48 2003/02/10 21:48:38 monnier Exp $ ;; This file is part of GNU Emacs. @@ -202,6 +201,8 @@ ;;;; Mouse bindings and mode motion ;;;; +(defvar cvs-minor-current-files) + (defun cvs-menu (e) "Popup the CVS menu." (interactive "e") @@ -368,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 @@ -443,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) @@ -655,6 +669,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 @@ -729,7 +751,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 @@ -743,7 +764,7 @@ 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." @@ -902,6 +923,21 @@ With a prefix argument, prompt for cvs FLAGS to use." (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. @@ -964,6 +1000,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") @@ -1058,7 +1095,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 @@ -1067,6 +1104,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) @@ -1170,11 +1209,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 () @@ -1240,7 +1280,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") @@ -1280,17 +1321,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)) @@ -1424,6 +1461,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." @@ -1542,6 +1580,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." @@ -1556,9 +1606,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!")) @@ -1591,6 +1639,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 @@ -1638,8 +1687,14 @@ Signal an error if there is no backup file." ;; Discard stderr output to work around the CVS+SSH+libc ;; problem when stdout and stderr are the same. ;; FIXME: this doesn't seem to make any difference :-( - (let ((res (call-process cvs-program nil '(t . nil) nil - "-q" "update" "-p" "-r" rev file))) + (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) @@ -1723,7 +1778,7 @@ 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) @@ -1743,7 +1798,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)))) @@ -1754,8 +1809,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)) @@ -1773,14 +1827,13 @@ POSTPROC is a list of expressions to be evaluated at the very end (after (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 @@ -1850,24 +1903,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))) @@ -1884,6 +1940,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 @@ -1894,14 +1962,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-face cvs-filename-face)))) + (error "Not a file name")) (cvs-mode! (lambda (&optional rev) (interactive (list (cvs-prefix-get 'cvs-branch-prefix))) @@ -1920,8 +1990,10 @@ With a prefix, opens the buffer in an OTHER window." (let ((buf (if rev (cvs-retrieve-revision fi rev) (find-file-noselect (cvs-fileinfo->full-path 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))) @@ -2019,7 +2091,16 @@ Returns a list of FIS that should be `cvs remove'd." (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) @@ -2042,7 +2123,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)) @@ -2078,8 +2162,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))))) @@ -2225,7 +2309,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) @@ -2279,4 +2368,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