;;; patcher.el --- Utility for mailing patch information

;; Copyright (C) 1999-2000 Didier Verna.

;; Author:        Didier Verna <didier@xemacs.org>
;; Maintainer:    Didier Verna <didier@xemacs.org>
;; Created:       Tue Sep 28 18:12:43 1999
;; Last Revision: Tue Jun 20 09:53:21 2000
;; Keywords:      maint

;; This file is part of Patcher.

;; Patcher is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.

;; Patcher is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.


;;; Commentary:

;; Contents management by FCM version 0.1.

;; This package automates the process of building and submitting patches for
;; archive-based projects you're working on. In one or two keystrokes, it
;; prepares a mail with a patch corresponding to the differences between your
;; working version and the archive state, and prepares a skeleton for the
;; ChangeLog entries, that you can fill in and insert into the message before
;; sending.

;; Here's a typical usage:

;; 1/ After loading the package, customize the variable `patcher-projects' to
;;    suit your needs.
;; 2/ Once you have made modifications to one of these project and you'd like
;;    to submit them, type `M-x patcher-mail' (see the docstring). The message
;;    will be prepared and the ChangeLog skeletons built.
;; 3/ Edit the different ChangeLog buffers that have opened, and fill in the
;;    skeletons. Save the buffers afterwards, BUT DON't KILL THEM !!
;; 4/ Return to the message buffer, and move to a point where you want to see
;;    the ChangeLogs inserted. Then, type `M-x patcher-insert-changelogs'.
;; 5/ That's all folks. You can now send the message and kill the buffers.

;; Requirements:

;; In addition to the 'add-log librariy, this package needs Gnus for two
;; reasons: first it uses it to prepare the message, and second it requires
;; that you have a Gnus group associated with each project. This is the way
;; the messages are personalized on a project basis (for instance with
;; different email adresses and stuff).

;; Project archive:

;; Patcher can currently handle projects whose archive are managed under PRCS
;; or CVS. If you want to add a new archive management system, say `foo', all
;; you basically have to do is provide a new function
;; `patcher-prepare-chagelogs-foo'.

;;; Code:

(require 'gnus)
(require 'add-log)


;; Customizable part =========================================================

(defgroup patcher nil
  "Patch mailing utilities.")

(defcustom patcher-projects '()
  "List of projects for which you'd like to mail patches"
  :group 'patcher
  :type '(repeat
	  (group (string :tag "Project")
		 (cons :format "%v"
		       (const  :tag "" :value prologue)
		       (string :tag "Mail prologue"))
		 (cons :format "%v"
		       (const  :tag "" :value dir)
		       (string :tag "Project directory"))
		 (cons :format "%v"
		       (const  :tag "" :value diff)
		       (string :tag "Diff command"))
		 (cons :format "%v"
		       (const  :tag "" :value style)
		       (choice :tag "Diff style"
			       (const  :tag "cvs"  :value cvs)
			       (const  :tag "prcs" :value prcs)
			       (symbol :tag "other" :value nil)))
		 (cons :format "%v"
		       (const  :tag "" :value group)
		       (string :tag "Gnus group")))
	  ))


;; Internal variables ========================================================

;; $Format: "(defconst patcher-prcs-major-version \"$ProjectMajorVersion$\")"$
(defconst patcher-prcs-major-version "branch-0-1")
;; $Format: "(defconst patcher-prcs-minor-version \"$ProjectMinorVersion$\")"$
(defconst patcher-prcs-minor-version "1")
(defconst patcher-version
  (let ((level patcher-prcs-minor-version)
	major minor status)
    (string-match "\\(branch\\|version\\)-\\([0-9]+\\)-\\([0-9]+\\)"
		  patcher-prcs-major-version)
    (setq major (match-string 2 patcher-prcs-major-version)
	  minor (match-string 3 patcher-prcs-major-version)
	  status (match-string 1 patcher-prcs-major-version))
    (cond ((string= status "version")
	   (setq level (int-to-string (1- (string-to-int level))))
	   (if (string-equal level "0")
	       (concat major "." minor)
	     (concat major "." minor "." level)))
	  ((string= status "branch")
	   (concat major "." minor "-b" level)))
    ))

(defvar patcher-changelog-list
  ;; list of changelog files. Each element is of the form (BUFFER . EXTENT)
  ;; where BUFFER is the ChangeLog file's buffer and EXTENT covers the area
  ;; of the new ChangeLog entries.
 nil)
(make-variable-buffer-local 'patcher-changelog-list)


;; Internal routines =========================================================

;; this function is hacked from `add-changelog-entry'
(defun patcher-prepare-changelog (name address buffer)
  ;; Find change log file and add an entry for today.
  ;; Today's date is calculated according to `change-log-time-zone-rule' if
  ;; non-nil, otherwise in local time.
  (let ((defun (funcall (or add-log-current-defun-function
			    'add-log-current-defun)))
	(logfile (expand-file-name (find-change-log)))
	paragraph-end entry)
    (and buffer-file-name
	 ;; never add a change log entry for the ChangeLog file itself.
	 (not (string= buffer-file-name logfile))
	 (setq entry (if (string-match
			  (concat "^" (regexp-quote (file-name-directory
						     logfile)))
			  buffer-file-name)
			 (substring buffer-file-name (match-end 0))
		       (file-name-nondirectory buffer-file-name))))
    (push-window-configuration)
    (if (not (equal logfile buffer-file-name))
	(find-file-other-window logfile))
    (or (eq major-mode 'change-log-mode)
	(change-log-mode))
    (undo-boundary)
    (goto-char (point-min))
    ;; keep trace of this ChangeLog file
    (let ((buf (current-buffer)))
      (if (not (with-current-buffer buffer (assoc buf patcher-changelog-list)))
	  (let ((extent (make-extent (point) (point))))
	    (set-extent-properties extent '(end-open nil patcher t))
	    (with-current-buffer buffer
	      (push (cons buf extent) patcher-changelog-list)))
	))
    (let ((new-entry (concat (funcall add-log-time-format)
			     "  " name
			     "  <" address ">")))
      (if (looking-at (regexp-quote new-entry))
	  (forward-line 1)
	(insert new-entry "\n\n")))
    ;; search only within the first paragraph
    (if (looking-at "\n*[^\n* \t]")
	(skip-chars-forward "\n")
      (forward-paragraph 1))
    (setq paragraph-end (point))
    (goto-char (point-min))
    ;; now insert the new line for this entry
    (cond ((re-search-forward "^\\s *\\*\\s *$" paragraph-end t)
	   ;; put this file name into the existing empty entry
	   (if entry (insert entry)))
	  ((let (case-fold-search)
	     (re-search-forward
	      (concat (regexp-quote (concat "* " entry))
		      ;; don't accept `foo.bar' when looking for `foo'
		      "\\(\\s \\|[(),:]\\)")
	      paragraph-end t))
	   ;; add to the existing entry for the same file.
	   (re-search-forward "^\\s *$\\|^\\s \\*")
	   (goto-char (match-beginning 0))
	   ;; delete excess empty lines; make just 2.
	   (while (and (not (eobp)) (looking-at "^\\s *$"))
	     (delete-region (point) (save-excursion (forward-line 1) (point))))
	   (insert "\n\n")
	   (forward-line -2)
	   (indent-relative-maybe))
	  (t ;; make a new entry.
	   (forward-line 1)
	   (while (looking-at "\\sW")
	     (forward-line 1))
	   (while (and (not (eobp)) (looking-at "^\\s *$"))
	     (delete-region (point) (save-excursion (forward-line 1) (point))))
	   (insert "\n\n\n")
	   (forward-line -2)
	   (indent-to left-margin)
	   (insert "* " (or entry ""))))
    ;; Now insert the function name, if we have one: point is at the entry for
    ;; this file, either at the end of the line or at the first blank line.
    (if defun
	(progn
	  ;; make it easy to get rid of the function name
	  (undo-boundary)
	  (insert (if (save-excursion
			(beginning-of-line 1)
			(looking-at "\\s *$"))
		      ""
		    " ")
		  "(" defun "): "))
      ;; no function name, so put in a colon unless we have just a star
      (if (not (save-excursion
		 (beginning-of-line 1)
		 (looking-at "\\s *\\(\\*\\s *\\)?$")))
	  (insert ": ")))))

(defun patcher-prepare-changelogs-cvs (&optional arg)
  "Generate template ChangeLog entries for patches in the current buffer.
The ChangeLog prefix relies on the current values of `user-full-name'
and `user-mail-address'.

Optional argument (the prefix in interactive mode) means create a new
frame to display the ChangeLog files and their respective source files.

The current buffer is expected to contain `cvs diff -u' output."
  (interactive "P")
  (let ((name user-full-name)
	(address user-mail-address)
	(buffer (current-buffer)))
    (goto-char (point-min))
    ;; Reset everything, just in case ...
    (when patcher-changelog-list
      (mapcar (lambda (seq) (delete-extent (cdr seq)))
	      patcher-changelog-list)
      (setq patcher-changelog-list nil))
    (when arg (select-frame (make-frame)))
    (delete-other-windows)
    (split-window)
    (let ((cont t)
	  file)
      (while cont
	(with-current-buffer buffer
	  ;; The output of `cvs diff' gives an index starting in the root
	  ;; directory.
	  (setq cont (re-search-forward "^\
\\(Index: \\(.*\\)\\)\\|
\\(@@ -[0-9,]+ \\+\\([0-9]+\\),\\([0-9]+\\)\\)"
					nil  t))
	  (when cont
	    (if (match-string 1)
		(setq file (match-string 2))
	      (let ((pos (+ (string-to-int (match-string 4))
			    (/ (string-to-int (match-string 5))
			       2))))
		(find-file-other-window file)
		(goto-line pos)
		(patcher-prepare-changelog name address buffer))))
	  )))
    ))

(defun patcher-prepare-changelogs-prcs (&optional arg)
  "Generate template ChangeLog entries for patches in the current buffer.
The ChangeLog headers rely on the current values of `user-full-name'
and `user-mail-address'.

Optional argument (the prefix in interactive mode) means create a new
frame to display the ChangeLog files and their respective source files.

The current buffer is expected to contain `prcs diff -- -u' output."
  (interactive "P")
  (let ((name user-full-name)
	(address user-mail-address)
	(buffer (current-buffer)))
    (goto-char (point-min))
    ;; Reset everything, just in case ...
    (when patcher-changelog-list
      (mapcar (lambda (seq) (delete-extent (cdr seq)))
	      patcher-changelog-list)
      (setq patcher-changelog-list nil))
    (when arg (select-frame (make-frame)))
    (delete-other-windows)
    (split-window)
    (let ((cont t)
	  file)
      (while cont
	(with-current-buffer buffer
	  ;; The output of `prcs diff' gives an index starting with
	  ;; the project directory, so we must skip it.
	  (setq cont (re-search-forward "^\
\\(Index: [^/]+/\\(.*\\)\\)\\|
\\(@@ -[0-9,]+ \\+\\([0-9]+\\),\\([0-9]+\\)\\)"
					nil  t))
	  (when cont
	    (if (match-string 1)
		(setq file (match-string 2))
	      (let ((pos (+ (string-to-int (match-string 4))
			    (/ (string-to-int (match-string 5))
			       2))))
		(find-file-other-window file)
		(goto-line pos)
		(patcher-prepare-changelog name address buffer))))
	  )))
    ))


;; Mail preparation routines =================================================

(defun patcher-insert-changelogs ()
  "Insert all the ChangeLog entries you're supposed to have filled in
at the current position."
  (interactive)
  (save-excursion
    (let (entry)
      (while (setq entry (pop patcher-changelog-list))
	(insert (extent-string (cdr entry)))
	(delete-extent (cdr entry))))
    ))

;;;###autoload
(defun patcher-mail (project subject &optional command arg)
  "Send a mail about a patch to apply on a project.
PROJECT is the name of the project (see the variable `patcher-projects').
SUBJECT is the subject of the message to send.

When called interactively, use a prefix to override the default COMMAND
for this project.

Please note that you can have multiple occurences of a patcher mail at the
same time, provided that they concern different projects."
  (interactive
   (let* ((prj (assoc (completing-read "Project: " patcher-projects nil t)
		      patcher-projects))
	  (sbj (read-string "Subject: "))
	  (cmd (cdr (assoc 'diff prj))))
     (list prj sbj cmd current-prefix-arg)))
  ;; this binding is necessary to let message-mode hooks perform correctly
  (let ((gnus-newsgroup-name (cdr (assoc 'group project))))
    (gnus-post-news 'post gnus-newsgroup-name))
  (message-goto-subject)
  (insert "[PATCH] " subject)
  (cd (cdr (assoc 'dir project)))
  ;; do this only after we set up the proper directory !!
  (and (interactive-p) arg
       (setq command (read-shell-command "Diff command: " command)))
  (message-goto-body)
  (insert "\n" (cdr (assoc 'prologue project)))
  (let ((pos (point)))
    (insert "\n\n")
    (message "Generating the diff ...")
    (sit-for 0) ;; Let XEmacs redisplay the message buffer
    (shell-command command 'here)
    (message "Generating the diff ... done.")
    (goto-char pos))
  (funcall (intern (concat "patcher-prepare-changelogs-"
			   (symbol-name (cdr (assoc 'style project)))))
	   t))

;;;###autoload
(defun patcher-version ()
  "Show the current version of Patcher."
  (interactive)
  (message "Patcher version %s" patcher-version))


(provide 'patcher)

;;; patcher.el ends here