comparison lisp/pcvs.el @ 30569:f7a0912532da

* pcvs.el (cvs-do-commit): Use `buffer-substring-no-properties' instead of `buffer-string'. (require 'cl): Always, not just when compiling. `ignore-errors' in `interactive', `list*', `defun*' &c make this necessary.

30568:904cda56fa16

;;      (Greg Klanderman) [e-mail]
;;      (Jari Aalto+mail.emacs) [e-mail]
;; Maintainer: (Stefan Monnier) monnier+lists/cvs/[e-mail]
;; Keywords: CVS, version control, release management
;; Version: $Name:  $
;; Revision: $Id: pcvs.el,v 1.3 2000/05/10 22:28:36 monnier Exp $

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by

;; it's not even worth looking at it.

;;; Todo:

;; ******** FIX THE DOCUMENTATION *********
;; 
;; - proper `g' that passes safe args and uses either cvs-status or cvs-examine
;; - add toolbar entries
;; - marking
;;    marking directories should jump to just after the dir.
;;    allow (un)marking directories at a time with the mouse.

;; 	instance.
;; - add message-levels so that we can hide some levels of messages

;;; Code:

(eval-when-compile (require 'cl))
(require 'ewoc)				;Ewoc was once cookie
(require 'pcvs-defs)
(require 'pcvs-util)
(require 'pcvs-parse)
(require 'pcvs-info)

;;;; Dynamically scoped variables
;;;;

(defvar cvs-from-vc nil "Bound to t inside VC advice.")

;;;; 
;;;; flags variables
;;;; 

(defun cvs-defaults (&rest defs)
  (let ((defs (cvs-first defs cvs-shared-start)))
    (append defs
	    (make-list (- cvs-shared-start (length defs)) (first defs))

(defvar cvs-mode-line-process nil
  "Mode-line control for displaying info on cvs process status.")


;;;; 
;;;; Query-Type-Descriptor for Tags
;;;; 

(autoload 'cvs-status-get-tags "cvs-status")
(defun cvs-tags-list ()
  "Return a list of acceptable tags, ready for completions."
  (assert (cvs-buffer-p))

(defvar cvs-tag-history nil)
(defconst cvs-qtypedesc-tag
  (cvs-qtypedesc-create 'identity 'identity 'cvs-tags-list 'cvs-tag-history))

;;;; 

(defun cvs-mode! (&optional -cvs-mode!-fun -cvs-mode!-noerror)
  "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.

	  (set-buffer cvs-mode!-buf)
	  (when (and cvs-mode!-nwin (eq cvs-mode!-nwin (selected-window)))
	    ;; the selected window has not been changed by FUN
	    (select-window cvs-mode!-owin)))))))

;;;; 
;;;; Prefixes
;;;; 

(defvar cvs-branches (list cvs-vendor-branch "HEAD" "HEAD"))
(cvs-prefix-define cvs-branch-prefix
  "Current selected branch."
  "version"

the primay since reading the primary can deactivate it."
  (let ((branch (and (cvs-prefix-get 'cvs-branch-prefix 'read-only)
		     (cvs-prefix-get 'cvs-secondary-branch-prefix))))
    (if branch (cons (concat (or arg "-r") branch) flags) flags)))

;;;; 

(define-minor-mode
 cvs-minor-mode
 "
This mode is used for buffers related to a main *cvs* buffer.

		cvs-temp-buffer)
	       (t
		(set (make-local-variable 'cvs-temp-buffer)
		     (cvs-get-buffer-create
		      (eval cvs-temp-buffer-name) 'noreuse))))))
    
    ;; handle the potential pre-existing process
    (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")))

  (assert (cvs-buffer-p cvs-buffer))
  (save-current-buffer
    (let ((procbuf (current-buffer))
	  (cvsbuf cvs-buffer)
	  (single-dir (or single-dir (eq cvs-execute-single-dir t))))
      
      (set-buffer procbuf)
      (goto-char (point-max))
      (unless (bolp) (let ((inhibit-read-only t)) (insert "\n")))
      ;; find the set of files we'll process in this round
      (let* ((dir+files+rest

		      ((not (and fis (string= dir (cvs-fileinfo->dir fi))))
		       (list dir files fis))))))
	     (dir (first dir+files+rest))
	     (files (second dir+files+rest))
	     (rest (third dir+files+rest)))
      
	;; setup the (current) process buffer
	(set (make-local-variable 'cvs-postprocess)
	     (if (null rest)
		 ;; this is the last invocation
		 postprocess

		  (apply 'start-process "cvs" procbuf cvs-program args))))
	  (set-process-sentinel process 'cvs-sentinel)
	  (set-process-filter process 'cvs-update-filter)
	  (set-marker (process-mark process) (point-max))
	  (ignore-errors (process-send-eof process)) ;close its stdin to avoid hangs
	
	  ;; now finish setting up the cvs-buffer
	  (set-buffer cvsbuf)
	  (setq cvs-mode-line-process (symbol-name (process-status process)))
	  (force-mode-line-update)))))

		     ;; handled also?
		     (UP-TO-DATE (not rm-handled))
		     ;; keep the rest
		     (t (not (run-hook-with-args-until-success
			      'cvs-cleanup-functions fi))))))
	     
	     ;; mark dirs for removal
	     (when (and keep rm-dirs
			(eq (cvs-fileinfo->type last-fi) 'DIRCHANGE)
			(not (when first-dir (setq first-dir nil) t))
			(or (eq rm-dirs 'all)

  (cvs-cmd-do "checkout" (or dir default-directory)
	      (append flags modules) nil 'new
	      :noexist t))


;;;; 
;;;; The code for running a "cvs update" and friends in various ways.
;;;; 

(defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE)
                (&optional ignore-auto noconfirm)
  "Rerun cvs-examine on the current directory with the defauls flags."
  (interactive)

		(ewoc-enter-last
		 cvs-cookies
		 (cvs-create-fileinfo
		  'MESSAGE "" " "
		  (concat msg
			  (substitute-command-keys 
			   "\n\t(type \\[cvs-mode-delete-lock] to delete it)"))
		  :subtype 'TEMP))
		(pop-to-buffer (current-buffer))
		(goto-char (point-max))
		(beep)))))))))

  "Go to the next line.
If a prefix argument is given, move by that many lines."
  (interactive "p")
  (ewoc-goto-next cvs-cookies (point) arg))

;;;; 
;;;; Mark handling
;;;; 

(defun-cvs-mode cvs-mode-mark (&optional arg)
  "Mark the fileinfo on the current line.
If the fileinfo is a directory, all the contents of that directory are
marked instead. A directory can never be marked."

  (cvs-qtypedesc-create
   (lambda (str) (cdr (assoc str cvs-ignore-marks-alternatives)))
   (lambda (obj) (caar (member* obj cvs-ignore-marks-alternatives :key 'cdr)))
   (lambda () cvs-ignore-marks-alternatives)
   nil t))
  
(defun-cvs-mode cvs-mode-toggle-marks (arg)
  "Toggle whether the next CVS command uses marks.
See `cvs-prefix-set' for further description of the behavior.
\\[universal-argument] 1 selects `force-marks',
\\[universal-argument] 2 selects `ignore-marks',
\\[universal-argument] 3 selects `toggle-marks'."
  (interactive "P")
  (cvs-prefix-set 'cvs-ignore-marks-modif arg))
      
(defun cvs-ignore-marks-p (cmd &optional read-only)
  (let ((default (if (member cmd cvs-invert-ignore-marks)
		     (not cvs-default-ignore-marks)
		   cvs-default-ignore-marks))
	(modif (cvs-prefix-get 'cvs-ignore-marks-modif read-only)))

		     cvs-minor-current-files)
		  (or (and (not ignore-marks)
			   (ewoc-collect cvs-cookies
					      'cvs-fileinfo->marked))
		      (list (ewoc-data (ewoc-locate cvs-cookies (point)))))))
      
      (if (or ignore-contents (not (eq (cvs-fileinfo->type fi) 'DIRCHANGE)))
	  (push fi fis)
	;; If a directory is selected, return members, if any.
	(setq fis
	      (append (ewoc-collect cvs-cookies

(defun cvs-commit-filelist () (cvs-mode-files 'commit nil :read-only t :file t))

(defun cvs-do-commit (flags)
  "Do the actual commit, using the current buffer as the log message."
  (interactive (list (cvs-flags-query 'cvs-commit-flags "cvs commit flags")))
  (let ((msg (buffer-string)))
    (cvs-mode!)
    ;;(pop-to-buffer cvs-buffer)
    (cvs-mode-do "commit" (list* "-m" msg flags) 'commit)))


;;;; 
;;;; CVS Mode commands
;;;; 

(defun-cvs-mode (cvs-mode-insert . NOARGS) (file)
  "Insert an entry for a specific file."
  (interactive
   (list (read-file-name "File to insert: " nil nil nil

(defun cvs-emerge-merge (b1 b2 base out)
  (emerge-buffers-with-ancestor b1 b2 base (find-file-noselect out)))

;;
;; Ediff support
;; 

(defvar ediff-after-quit-destination-buffer)
(defvar cvs-transient-buffers)
(defun cvs-ediff-startup-hook ()
  (add-hook 'ediff-after-quit-hook-internal

   (list (setq cvs-tag-name
	       (cvs-query-read cvs-tag-name "Tag to delete: " cvs-qtypedesc-tag))
	 (cvs-flags-query 'cvs-tag-flags "tag flags")))
  (cvs-mode-do "tag" (append '("-d") flags (list tag))
	       (when cvs-force-dir-tag 'tag)))
  

;; Byte compile files.

(defun-cvs-mode cvs-mode-byte-compile-files ()
  "Run byte-compile-file on all selected files that end in '.el'."

  "Internal function for `cvs-execute-single-file-list'."
  (let* ((cur-dir (cvs-fileinfo->dir fi))
	 (default-directory (cvs-expand-dir-name cur-dir))
	 (inhibit-read-only t)
	 (arg-list (funcall extractor fi)))
    
    ;; Execute the command unless extractor returned t.
    (when (listp arg-list)
      (let* ((args (append constant-args arg-list)))
	
	(insert (format "=== cd %s\n=== %s %s\n\n"
			cur-dir program (cvs-strings->string args)))
	
	;; FIXME: return the exit status?
	(apply 'call-process program nil t t args)
	(goto-char (point-max))))))

;; FIXME: make this run in the background ala cvs-run-process...

30569:f7a0912532da

;;      (Greg Klanderman) [e-mail]
;;      (Jari Aalto+mail.emacs) [e-mail]
;; Maintainer: (Stefan Monnier) monnier+lists/cvs/[e-mail]
;; Keywords: CVS, version control, release management
;; Version: $Name:  $
;; Revision: $Id: pcvs.el,v 1.4 2000/06/12 04:48:35 monnier Exp $

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by

;; it's not even worth looking at it.

;;; Todo:

;; ******** FIX THE DOCUMENTATION *********
;;
;; - proper `g' that passes safe args and uses either cvs-status or cvs-examine
;; - add toolbar entries
;; - marking
;;    marking directories should jump to just after the dir.
;;    allow (un)marking directories at a time with the mouse.

;; 	instance.
;; - add message-levels so that we can hide some levels of messages

;;; Code:

(require 'cl)
(require 'ewoc)				;Ewoc was once cookie
(require 'pcvs-defs)
(require 'pcvs-util)
(require 'pcvs-parse)
(require 'pcvs-info)

;;;; Dynamically scoped variables
;;;;

(defvar cvs-from-vc nil "Bound to t inside VC advice.")

;;;;
;;;; flags variables
;;;;

(defun cvs-defaults (&rest defs)
  (let ((defs (cvs-first defs cvs-shared-start)))
    (append defs
	    (make-list (- cvs-shared-start (length defs)) (first defs))

(defvar cvs-mode-line-process nil
  "Mode-line control for displaying info on cvs process status.")


;;;;
;;;; Query-Type-Descriptor for Tags
;;;;

(autoload 'cvs-status-get-tags "cvs-status")
(defun cvs-tags-list ()
  "Return a list of acceptable tags, ready for completions."
  (assert (cvs-buffer-p))

(defvar cvs-tag-history nil)
(defconst cvs-qtypedesc-tag
  (cvs-qtypedesc-create 'identity 'identity 'cvs-tags-list 'cvs-tag-history))

;;;;

(defun cvs-mode! (&optional -cvs-mode!-fun -cvs-mode!-noerror)
  "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.

	  (set-buffer cvs-mode!-buf)
	  (when (and cvs-mode!-nwin (eq cvs-mode!-nwin (selected-window)))
	    ;; the selected window has not been changed by FUN
	    (select-window cvs-mode!-owin)))))))

;;;;
;;;; Prefixes
;;;;

(defvar cvs-branches (list cvs-vendor-branch "HEAD" "HEAD"))
(cvs-prefix-define cvs-branch-prefix
  "Current selected branch."
  "version"

the primay since reading the primary can deactivate it."
  (let ((branch (and (cvs-prefix-get 'cvs-branch-prefix 'read-only)
		     (cvs-prefix-get 'cvs-secondary-branch-prefix))))
    (if branch (cons (concat (or arg "-r") branch) flags) flags)))

;;;;

(define-minor-mode
 cvs-minor-mode
 "
This mode is used for buffers related to a main *cvs* buffer.

		cvs-temp-buffer)
	       (t
		(set (make-local-variable 'cvs-temp-buffer)
		     (cvs-get-buffer-create
		      (eval cvs-temp-buffer-name) 'noreuse))))))

    ;; handle the potential pre-existing process
    (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")))

  (assert (cvs-buffer-p cvs-buffer))
  (save-current-buffer
    (let ((procbuf (current-buffer))
	  (cvsbuf cvs-buffer)
	  (single-dir (or single-dir (eq cvs-execute-single-dir t))))

      (set-buffer procbuf)
      (goto-char (point-max))
      (unless (bolp) (let ((inhibit-read-only t)) (insert "\n")))
      ;; find the set of files we'll process in this round
      (let* ((dir+files+rest

		      ((not (and fis (string= dir (cvs-fileinfo->dir fi))))
		       (list dir files fis))))))
	     (dir (first dir+files+rest))
	     (files (second dir+files+rest))
	     (rest (third dir+files+rest)))

	;; setup the (current) process buffer
	(set (make-local-variable 'cvs-postprocess)
	     (if (null rest)
		 ;; this is the last invocation
		 postprocess

		  (apply 'start-process "cvs" procbuf cvs-program args))))
	  (set-process-sentinel process 'cvs-sentinel)
	  (set-process-filter process 'cvs-update-filter)
	  (set-marker (process-mark process) (point-max))
	  (ignore-errors (process-send-eof process)) ;close its stdin to avoid hangs

	  ;; now finish setting up the cvs-buffer
	  (set-buffer cvsbuf)
	  (setq cvs-mode-line-process (symbol-name (process-status process)))
	  (force-mode-line-update)))))

		     ;; handled also?
		     (UP-TO-DATE (not rm-handled))
		     ;; keep the rest
		     (t (not (run-hook-with-args-until-success
			      'cvs-cleanup-functions fi))))))

	     ;; mark dirs for removal
	     (when (and keep rm-dirs
			(eq (cvs-fileinfo->type last-fi) 'DIRCHANGE)
			(not (when first-dir (setq first-dir nil) t))
			(or (eq rm-dirs 'all)

  (cvs-cmd-do "checkout" (or dir default-directory)
	      (append flags modules) nil 'new
	      :noexist t))


;;;;
;;;; The code for running a "cvs update" and friends in various ways.
;;;;

(defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE)
                (&optional ignore-auto noconfirm)
  "Rerun cvs-examine on the current directory with the defauls flags."
  (interactive)

		(ewoc-enter-last
		 cvs-cookies
		 (cvs-create-fileinfo
		  'MESSAGE "" " "
		  (concat msg
			  (substitute-command-keys
			   "\n\t(type \\[cvs-mode-delete-lock] to delete it)"))
		  :subtype 'TEMP))
		(pop-to-buffer (current-buffer))
		(goto-char (point-max))
		(beep)))))))))

  "Go to the next line.
If a prefix argument is given, move by that many lines."
  (interactive "p")
  (ewoc-goto-next cvs-cookies (point) arg))

;;;;
;;;; Mark handling
;;;;

(defun-cvs-mode cvs-mode-mark (&optional arg)
  "Mark the fileinfo on the current line.
If the fileinfo is a directory, all the contents of that directory are
marked instead. A directory can never be marked."

  (cvs-qtypedesc-create
   (lambda (str) (cdr (assoc str cvs-ignore-marks-alternatives)))
   (lambda (obj) (caar (member* obj cvs-ignore-marks-alternatives :key 'cdr)))
   (lambda () cvs-ignore-marks-alternatives)
   nil t))

(defun-cvs-mode cvs-mode-toggle-marks (arg)
  "Toggle whether the next CVS command uses marks.
See `cvs-prefix-set' for further description of the behavior.
\\[universal-argument] 1 selects `force-marks',
\\[universal-argument] 2 selects `ignore-marks',
\\[universal-argument] 3 selects `toggle-marks'."
  (interactive "P")
  (cvs-prefix-set 'cvs-ignore-marks-modif arg))

(defun cvs-ignore-marks-p (cmd &optional read-only)
  (let ((default (if (member cmd cvs-invert-ignore-marks)
		     (not cvs-default-ignore-marks)
		   cvs-default-ignore-marks))
	(modif (cvs-prefix-get 'cvs-ignore-marks-modif read-only)))

		     cvs-minor-current-files)
		  (or (and (not ignore-marks)
			   (ewoc-collect cvs-cookies
					      'cvs-fileinfo->marked))
		      (list (ewoc-data (ewoc-locate cvs-cookies (point)))))))

      (if (or ignore-contents (not (eq (cvs-fileinfo->type fi) 'DIRCHANGE)))
	  (push fi fis)
	;; If a directory is selected, return members, if any.
	(setq fis
	      (append (ewoc-collect cvs-cookies

(defun cvs-commit-filelist () (cvs-mode-files 'commit nil :read-only t :file t))

(defun cvs-do-commit (flags)
  "Do the actual commit, using the current buffer as the log message."
  (interactive (list (cvs-flags-query 'cvs-commit-flags "cvs commit flags")))
  (let ((msg (buffer-substring-no-properties (point-min) (point-max))))
    (cvs-mode!)
    ;;(pop-to-buffer cvs-buffer)
    (cvs-mode-do "commit" (list* "-m" msg flags) 'commit)))


;;;;
;;;; CVS Mode commands
;;;;

(defun-cvs-mode (cvs-mode-insert . NOARGS) (file)
  "Insert an entry for a specific file."
  (interactive
   (list (read-file-name "File to insert: " nil nil nil

(defun cvs-emerge-merge (b1 b2 base out)
  (emerge-buffers-with-ancestor b1 b2 base (find-file-noselect out)))

;;
;; Ediff support
;;

(defvar ediff-after-quit-destination-buffer)
(defvar cvs-transient-buffers)
(defun cvs-ediff-startup-hook ()
  (add-hook 'ediff-after-quit-hook-internal

   (list (setq cvs-tag-name
	       (cvs-query-read cvs-tag-name "Tag to delete: " cvs-qtypedesc-tag))
	 (cvs-flags-query 'cvs-tag-flags "tag flags")))
  (cvs-mode-do "tag" (append '("-d") flags (list tag))
	       (when cvs-force-dir-tag 'tag)))


;; Byte compile files.

(defun-cvs-mode cvs-mode-byte-compile-files ()
  "Run byte-compile-file on all selected files that end in '.el'."

  "Internal function for `cvs-execute-single-file-list'."
  (let* ((cur-dir (cvs-fileinfo->dir fi))
	 (default-directory (cvs-expand-dir-name cur-dir))
	 (inhibit-read-only t)
	 (arg-list (funcall extractor fi)))

    ;; Execute the command unless extractor returned t.
    (when (listp arg-list)
      (let* ((args (append constant-args arg-list)))

	(insert (format "=== cd %s\n=== %s %s\n\n"
			cur-dir program (cvs-strings->string args)))

	;; FIXME: return the exit status?
	(apply 'call-process program nil t t args)
	(goto-char (point-max))))))

;; FIXME: make this run in the background ala cvs-run-process...