cgit.sxemacs.org Git - packages/blob - xemacs-packages/patcher/lisp/patcher-mail.el

   1 ;;; patcher-mail.el --- Mail management
   2
   3 ;; Copyright (C) 2008, 2009, 2010, 2011 Didier Verna
   4 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007 Didier Verna
   5
   6 ;; Author:        Didier Verna <didier@xemacs.org>
   7 ;; Maintainer:    Didier Verna <didier@xemacs.org>
   8 ;; Created:       Mon Feb 15 15:26:26 2010
   9 ;; Last Revision: Thu Dec  8 08:53:32 2011
  10 ;; Keywords:      maint
  11
  12
  13 ;; This file is part of Patcher.
  14
  15 ;; Patcher is free software; you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License version 3,
  17 ;; as published by the Free Software Foundation.
  18
  19 ;; Patcher is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with this program; if not, write to the Free Software
  26 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  27
  28
  29 ;;; Commentary:
  30
  31 ;; Contents management by FCM version 0.1.
  32
  33
  34 ;;; Code:
  35
  36 (require 'cl)
  37
  38 (eval-when-compile (require 'patcher-cutil))
  39 (require 'patcher-util)
  40 (require 'patcher-project)
  41 (require 'patcher-instance)
  42 (require 'patcher-source)
  43 (require 'patcher-change-log)
  44 (require 'patcher-diff)
  45 (require 'patcher-cmtcmd)
  46 (require 'patcher-logmsg)
  47
  48
  49 ;; Require 'sendmail for getting `mail-header-separator'.
  50 ;; #### Now that a fake mail sending function exists, sendmail shouldn't be
  51 ;; #### systematically required like this.  However, since most users will
  52 ;; #### really want do send real messages, it probably doesn't hurt to keep
  53 ;; #### things as-is.
  54 (require 'sendmail)
  55
  56
  57 \f
  58 ;; ==========================================================================
  59 ;; Utilities
  60 ;; ==========================================================================
  61
  62 (make-variable-buffer-local
  63  (defvar patcher-change-logs-marker nil
  64    ;; Marker indicating the beginning of the ChangeLog entries, when they are
  65    ;; separated from the patch.
  66    ))
  67
  68 (make-variable-buffer-local
  69  (defvar patcher-diff-marker nil
  70    ;; Marker indicating the beginning of the diff.
  71    ))
  72
  73 (defun patcher-goto-subject ()
  74   ;; Move point to the beginning of the Subject: header's contents.
  75   (goto-char (point-min))
  76   (re-search-forward "^Subject: "))
  77
  78 (defun patcher-goto-signature ()
  79   ;; Move point to the beginning of the mail signature (actually, in front of
  80   ;; the signature separator), if any.  Otherwise, move point to the end of
  81   ;; the message. Return that position.
  82   (goto-char (point-min))
  83   (if (re-search-forward
  84        (cond ((eq major-mode 'mail-mode)
  85               ;; this is hard-wired in sendmail.el
  86               "\n\n-- \n")
  87              ((eq major-mode 'message-mode)
  88               (declare-boundp message-signature-separator))
  89              (t
  90               (patcher-warning "\
  91 Major mode: %s.
  92 Your mailing method is not fully supported by Patcher.
  93 This is not critical though: Patcher may not find the message signature
  94 correctly.
  95
  96 Please report to <didier@xemacs.org>."
  97                                major-mode)
  98               ;; Use the standard one by default.
  99               "\n\n-- \n"))
 100        nil t)
 101       (goto-char (match-beginning 0))
 102     ;; else: no signature
 103     (goto-char (point-max))))
 104
 105
 106
 107 \f
 108 ;; ==========================================================================
 109 ;; Diff generation
 110 ;; ==========================================================================
 111
 112 (globally-declare-boundp 'unused)
 113
 114 (defun* patcher-diff-project
 115     (project
 116      &aux (buffer (patcher-project-process-buffer project))
 117           (updating (patcher-project-option project :change-logs-updating))
 118           (appearance (patcher-project-option project
 119                         :change-logs-appearance)))
 120   ;; (Re)generate PROJECT's diff and insert items in the current mail buffer.
 121   ;; Depending on PROJECT settings (ChangeLogs updating mode and appearance),
 122   ;; insertion of ChangeLog entries or even the diff itself might be delayed.
 123   (patcher-condition-case condition
 124       ;; Note that in case of a diff regeneration, PROJECT may contain old
 125       ;; source or ChangeLog references, and also maybe retained ChangeLog
 126       ;; skeletons. We need to deal with that by doing some additional cleanup
 127       ;; (like forgetting about obsolete source or ChangeLog files) or some
 128       ;; additional work (like generating newly required skeletons).
 129       (multiple-value-bind (sources change-logs)
 130           (patcher-diff-specification project)
 131         ;; First, figure out what's new and what's obsolete. When we end up
 132         ;; with obsolete source or ChangeLog files, it's like they never
 133         ;; existed, so there's no point in honoring the :kill-*-after-sending
 134         ;; options.
 135         (multiple-value-bind (unused obsolete-sources new-sources)
 136             (patcher-list= (patcher-project-sources project) sources
 137               :test #'string=)
 138           (patcher-unlink-sources project
 139             :sources obsolete-sources
 140             :override-kill t)
 141           (patcher-link-sources project new-sources))
 142         (multiple-value-bind (unused obsolete-change-logs new-change-logs)
 143             (patcher-list= (patcher-project-change-logs project) change-logs
 144               :test #'string=)
 145           ;; Having obsolete ChangeLogs that still contain skeletons is very
 146           ;; likely to be an error.
 147           (when (eq updating 'automatic)
 148             (let (generated-change-log-buffers)
 149               (dolist (obsolete-change-log obsolete-change-logs)
 150                 (multiple-value-bind (obsolete-change-log-buffer)
 151                     (patcher-change-log-buffer project obsolete-change-log)
 152                   (when (and obsolete-change-log-buffer
 153                              (patcher-change-log-extent project
 154                                obsolete-change-log-buffer))
 155                     (patcher-endpush obsolete-change-log-buffer
 156                                      generated-change-log-buffers))))
 157               (when generated-change-log-buffers
 158                 (case (patcher-with-message
 159                           (format "\
 160 WARNING: some ChangeLog skeletons remain in obsolete ChangeLog files (not
 161 involved with the project anymore). The relevant ChangeLog files are the
 162 following: %s.
 163
 164 By answering the question below, you have the possibility to keep those
 165 skeletons (n), remove them all (y) or choose interactively (i).
 166
 167 Note that if you keep some of them, you may run into trouble later..."
 168                               (patcher-buffers-string
 169                                generated-change-log-buffers))
 170                         (patcher-read-char
 171                          "Remove obsolete ChangeLog skeletons? " "yni"))
 172                   (?y (patcher-ungenerate-change-logs project
 173                         generated-change-log-buffers))
 174                   (?i (patcher-ungenerate-change-logs project
 175                         generated-change-log-buffers
 176                         :interactive t
 177                         :prompt "Remove this obsolete skeleton? "))))))
 178           (patcher-unlink-change-logs project
 179             :change-logs obsolete-change-logs
 180             :override-kill t)
 181           (patcher-link-change-logs project new-change-logs)
 182           ;; Now, insert whatever possible in the mail buffer, perform some
 183           ;; sanity checks based on what we know and generate ChangeLog
 184           ;; skeletons if needed.
 185           (case updating
 186             ;; No ChangeLog. The diff we already have is good enough so we can
 187             ;; insert it right now.
 188             ((nil)
 189              (patcher-insert-diff project patcher-diff-marker)
 190              (patcher-message "\
 191 To commit your changes, type \\[patcher-mail-commit]."))
 192             ;; Automatic mode. ChangeLogs insertion, if required, is postponed
 193             ;; but we might still be able to insert the diff right now.
 194             (automatic
 195              ;; New ChangeLogs must be clean. Otherwise the project is out of
 196              ;; date. Note that except for new ChangeLogs, the current diff
 197              ;; might still contain ChangeLog entries: obsolete ones that were
 198              ;; generated and not removed, and correct ones that were not
 199              ;; ungenerated.
 200              (patcher-detect-spurious-change-logs project new-change-logs)
 201              ;; When ChangeLogs are inserted in a separate place, we can
 202              ;; already insert the source diff.
 203              (when (member appearance '(verbatim pack nil))
 204                (patcher-insert-diff project patcher-diff-marker))
 205              ;; Finally, we need to generate the missing skeletons. Since
 206              ;; patch-to-change-log doesn't know if some of them have been
 207              ;; generated already, I need to remove from the process buffer
 208              ;; all source diffs that would contribute to an already generated
 209              ;; skeleton. I definitely need to write my own version of
 210              ;; patch-to-change-log.
 211              ;; #### WARNING: it seems unsafe to delete extents from within
 212              ;; mapcar-extents (I got cases where the mapping were interrupted
 213              ;; before all extents were processed).
 214              (dolist (extent (patcher-source-extents buffer))
 215                (multiple-value-bind (change-log)
 216                    (patcher-change-log-buffer project
 217                        (patcher-locate-change-log project
 218                          (extent-property extent 'patcher-source)))
 219                  (when (and change-log
 220                             (patcher-change-log-extent project change-log))
 221                    (patcher-delete-extent-and-region extent))))
 222              (patcher-generate-change-logs project)
 223              (patcher-message "Please annotate the ChangeLog skeletons%s."
 224                               (case appearance
 225                                 (verbatim
 226                                  "\
 227 , and type \\[patcher-mail-insert-change-logs] to insert them")
 228                                 (pack
 229                                  "\
 230 , and type \\[patcher-mail-insert-change-logs] to diff them")
 231                                 (patch "\
 232 , and type \\[patcher-mail-insert-change-logs] to create the whole diff")
 233                                 ((nil)
 234                                  (if (patcher-project-option project
 235                                        :commit-privilege)
 236                                      " before sending your message"
 237                                    "\
 238 , and type \\[patcher-mail-commit] to commit your project."))
 239                                 (otherwise
 240                                  (patcher-error 'invalid-project-option
 241                                                 :change-logs-appearance
 242                                                 appearance)))))
 243             ;; Manual mode. ChangeLogs are supposed to be written already so
 244             ;; insertion can always be done right now.
 245             (manual
 246              ;; Without a specification, the diff is global so this is an
 247              ;; opportunity to check for ChangeLogs consistency.
 248              (unless (patcher-project-specification project)
 249                (patcher-detect-inconsistent-change-logs project))
 250              (case appearance
 251                (verbatim
 252                 (patcher-insert-diff project patcher-diff-marker)
 253                 ;; #### NOTE: when ChangeLog entries are part of the diff, we
 254                 ;; could try to convert the diff to a verbatim version instead
 255                 ;; of calling `patcher-insert-change-log-contents'.
 256                 (patcher-insert-change-log-contents
 257                  project patcher-change-logs-marker))
 258                (pack
 259                 (patcher-detect-ephemeral-change-logs project)
 260                 (let ((command (patcher-project-option project
 261                                  :change-logs-diff-command)))
 262                   (cond (command
 263                          ;; The diff command is different. We need to rediff
 264                          ;; the ChangeLogs in all situations.
 265                          (patcher-insert-diff project patcher-diff-marker)
 266                          (patcher-diff-change-logs project)
 267                          (patcher-insert-diff project
 268                            patcher-change-logs-marker :change-logs))
 269                         (t
 270                          ;; We use the same diff command:
 271                          (cond ((patcher-project-specification project)
 272                                 ;; Some ChangeLogs may not be there. We must
 273                                 ;; rediff them all.
 274                                 (patcher-insert-diff project
 275                                   patcher-diff-marker)
 276                                 (patcher-diff-change-logs project)
 277                                 (patcher-insert-diff project
 278                                   patcher-change-logs-marker :change-logs))
 279                                (t
 280                                 ;; All ChangeLogs appear in the diff.
 281                                 (patcher-insert-diff project
 282                                   patcher-diff-marker)
 283                                 (patcher-insert-diff project
 284                                   patcher-change-logs-marker
 285                                   :change-logs)))))))
 286                (patch
 287                 (patcher-detect-ephemeral-change-logs project)
 288                 (cond ((patcher-project-specification project)
 289                        ;; Some ChangeLogs not be there. We must rediff the
 290                        ;; whole thing.
 291                        (patcher-diff-all project)
 292                        (patcher-insert-diff project patcher-diff-marker
 293                                             :mixed))
 294                       (t
 295                        ;; All ChangeLogs appear in the diff.
 296                        (when (patcher-project-option project
 297                                :change-logs-diff-command)
 298                          (patcher-convert-change-logs-diff project))
 299                        (patcher-insert-diff project patcher-diff-marker
 300                                             :mixed))))
 301                ((nil)
 302                 (patcher-insert-diff project patcher-diff-marker))
 303                (otherwise
 304                 (patcher-error 'invalid-project-option
 305                                :change-logs-appearance appearance)))
 306              (patcher-message "\
 307 To commit your changes, type \\[patcher-mail-commit]."))
 308             (otherwise
 309              (patcher-error 'invalid-project-option
 310                             :change-logs-updating updating)))))
 311     (diff
 312      (display-buffer (patcher-project-process-buffer patcher-project) t)
 313      (beep)
 314      (patcher-message "\
 315 Error during diff. Type \\[patcher-mail-diff] to try again."))
 316     (change-logs-consistency
 317      (patcher-display-error-message
 318       (concat (patcher-inconsistent-change-logs-description
 319                (nth 1 condition)
 320                (nth 2 condition))
 321               "\
 322 \nPlease fix the problem and type \\[patcher-mail-diff] to try again.")))
 323     (sources-consistency
 324      (patcher-display-error-message
 325       (concat (patcher-inconsistent-sources-description
 326                (nth 1 condition)
 327                (nth 2 condition))
 328               "\
 329 \nPlease fix the problem and type \\[patcher-mail-diff] to try again.")))))
 330
 331
 332 \f
 333 ;; ===========================================================================
 334 ;; Patcher mail minor mode
 335 ;; ===========================================================================
 336
 337 (defun patcher-mail-change-subject ()
 338   "Read a new subject for the current project.
 339
 340 The new subject is propagated to all relevant buffers."
 341   (interactive)
 342   (patcher-change-subject patcher-project))
 343
 344 (defun patcher-mail-diff (&optional arg)
 345   "Regenerate the diff in the current Patcher mail buffer.
 346
 347 When called interactively, use a prefix to override the diff command
 348 used for this project.
 349
 350 Note that this is *not* the way to specify files affected by this patch.
 351 For that, either define a permanent subproject (see  `patcher-subprojects')
 352 or call `patcher-mail' with a prefix argument."
 353   (interactive "P")
 354   (patcher-detect-undiffable-project patcher-project)
 355   (when (or (not (patcher-project-sources patcher-project))
 356             (y-or-n-p "Really regenerate the diff ? "))
 357     (when arg
 358       (setf (patcher-project-diff-command patcher-project)
 359             (read-shell-command "Diff command: "
 360                                 (patcher-project-diff-command
 361                                  patcher-project))))
 362     (let ((change-log-buffers
 363            (patcher-generated-change-logs patcher-project)))
 364       (when change-log-buffers
 365         (case (patcher-with-message
 366                   (format "\
 367 Some ChangeLog skeletons for this patch have already been generated%s.
 368 The relevant ChangeLog files are the following: %s.
 369
 370 Before regenerating the diff, please answer the question below to keep the
 371 current skeletons (n), regenerate all of them (y) or choose interactively (i).
 372
 373 Beware that if you regenerate the skeletons, you will loose what you have
 374 possibly already filled in."
 375                       (if (patcher-extent 'change-logs)
 376                           "\nand inserted into the current mail buffer"
 377                         "")
 378                     (patcher-buffers-string change-log-buffers))
 379                 (patcher-read-char "Regenerate ChangeLog skeletons? " "yni"))
 380           (?y (patcher-ungenerate-change-logs patcher-project
 381                 change-log-buffers))
 382           (?i (patcher-ungenerate-change-logs patcher-project
 383                 change-log-buffers
 384                 :interactive t
 385                 :prompt "Regenerate this skeleton? ")))))
 386     ;; #### NOTE: it is too complicated to decide whether or not to keep
 387     ;; inserted ChangeLog entries in the mail buffer here. For instance, the
 388     ;; user might have decided to keep the skeletons, but further modify them
 389     ;; after the diff. So let's just remove them.
 390     (patcher-delete-extent-and-region (patcher-extent 'change-logs))
 391     (patcher-delete-extent-and-region (patcher-extent 'diff))
 392     (patcher-diff-project patcher-project)))
 393
 394 (defun patcher-mail-insert-change-logs (&optional arg)
 395   "(Re)Insert ChangeLog entries in the current Patcher mail buffer.
 396
 397 When called interactively, use a prefix argument to temporarily override
 398 the ChangeLogs appearance."
 399   (interactive "P")
 400   (let ((updating (patcher-project-option patcher-project
 401                     :change-logs-updating)))
 402     (patcher-condition-case condition
 403         (case updating
 404           ((nil)
 405            (patcher-error "This project does not use ChangeLogs"))
 406           ((automatic manual)
 407            (when (or (and (not (patcher-extent 'change-logs))
 408                           (not (patcher-change-logs)))
 409                      (y-or-n-p "\
 410 ChangeLog entries already inserted.  Replace? "))
 411              (let ((appearance (patcher-project-option patcher-project
 412                                  :change-logs-appearance)))
 413                (when (or (not appearance) arg)
 414                  (setq appearance
 415                        (let ((table '(("verbatim" . verbatim)
 416                                       ("pack"     . pack)
 417                                       ("patch"    . patch)
 418                                       ("none"     . nil))))
 419                          (patcher-with-message (format "\
 420 %sWhich type of appearance would you like to use?"
 421                                                    (if appearance
 422                                                        ""
 423                                                      "\
 424 This project is set to not include ChangeLogs in mail buffers.\n"))
 425                            (cdr (assoc
 426                                  (completing-read "\
 427 Select a ChangeLog appearance (verbatim by default): "
 428                                      table nil t nil nil "verbatim")
 429                                  table))))))
 430                (patcher-delete-extent-and-region (patcher-extent 'change-logs))
 431                (patcher-within-extent (unused 'diff)
 432                  (dolist (extent (patcher-change-log-extents))
 433                    (patcher-delete-extent-and-region extent)))
 434                (case appearance
 435                  ((nil))
 436                  (verbatim
 437                   (patcher-insert-change-log-contents
 438                    patcher-project patcher-change-logs-marker))
 439                  (pack
 440                   (patcher-detect-ephemeral-change-logs patcher-project)
 441                   (patcher-detect-undiffable-project patcher-project)
 442                   (patcher-diff-change-logs patcher-project)
 443                   (patcher-insert-diff patcher-project
 444                     patcher-change-logs-marker :change-logs))
 445                  (patch
 446                   (patcher-detect-ephemeral-change-logs patcher-project)
 447                   (patcher-detect-undiffable-project patcher-project)
 448                   (patcher-delete-extent-and-region (patcher-extent 'diff))
 449                   (patcher-diff-all patcher-project)
 450                   (patcher-insert-diff patcher-project patcher-diff-marker
 451                                        :mixed))
 452                  (t
 453                   (patcher-error 'invalid-project-option
 454                                  :change-logs-appearance appearance))))))
 455           (t
 456            (patcher-error 'invalid-project-option
 457                           :change-logs-updating updating)))
 458       (committed
 459        (patcher-display-error-message "\
 460 This project has already been committed, so it is impossible to show the
 461 ChangeLog entries as a diff because the diff would be empty."))
 462       (diff
 463        (display-buffer (patcher-project-process-buffer patcher-project) t)
 464        (beep)
 465        (patcher-message "\
 466 Error during diff. Type \\[patcher-mail-insert-change-logs] to try again."))
 467       (change-logs-consistency
 468        (patcher-display-error-message
 469         (concat
 470          (patcher-inconsistent-change-logs-description (nth 1 condition)
 471                                                         (nth 2 condition))
 472          "\
 473 \nPlease fix the problem and type \\[patcher-mail-insert-change-logs] to try again.")))
 474       (sources-consistency
 475        (patcher-display-error-message
 476         (concat
 477          (patcher-inconsistent-sources-description (nth 1 condition)
 478                                                     (nth 2 condition))
 479          "\
 480 \nPlease fix the problem and type \\[patcher-mail-insert-change-logs] to try again."))))))
 481
 482 (defun patcher-mail-first-change-log ()
 483   "Switch to first ChangeLog buffer."
 484   (interactive)
 485   (patcher-switch-to-first-change-log patcher-project))
 486
 487 (defun patcher-mail-last-change-log ()
 488   "Switch to the last ChangeLog buffer."
 489   (interactive)
 490   (patcher-switch-to-last-change-log patcher-project))
 491
 492 (defun patcher-mail-commit (&optional arg)
 493   "Prepare to, and possibly commit a change to a project's repository.
 494 The change is the one that is announced in the mail buffer.
 495
 496 When called interactively, use a prefix (ARG) to override the commit
 497 command to use.  Note that this is not meant to modify the source and
 498 ChangeLog files affected by the commit: they are computed automatically."
 499   (interactive "P")
 500   (patcher-detect-committed-project patcher-project)
 501   (when arg
 502     (setf (patcher-project-commit-command patcher-project)
 503           (read-shell-command "Commit command: "
 504                               (patcher-project-commit-command
 505                                patcher-project))))
 506   (setf (patcher-project-window-configuration patcher-project)
 507         (current-window-configuration))
 508   (let ((buffer (patcher-project-logmsg-buffer patcher-project)))
 509     (if buffer
 510         (erase-buffer buffer)
 511       (setq buffer
 512             (setf (patcher-project-logmsg-buffer patcher-project)
 513                   (generate-new-buffer
 514                    (format "*%s Patcher Project Log Message*"
 515                        (patcher-project-name patcher-project)))))
 516       ;; Do it first! It kills local variables.
 517       (with-current-buffer buffer
 518         (patcher-logmsg-mode))
 519       (patcher-setup-auxiliary-buffer patcher-project buffer)))
 520   (if (not (patcher-project-option patcher-project :edit-log-message))
 521       (with-current-buffer (patcher-project-logmsg-buffer patcher-project)
 522         (patcher-logmsg-init)
 523         (patcher-condition-case nil
 524             (patcher-logmsg-commit)
 525           (commit
 526            (display-buffer (patcher-project-process-buffer patcher-project) t)
 527            (with-current-buffer (patcher-project-mail-buffer patcher-project)
 528              (beep)
 529              (patcher-message "\
 530 Error during commit. Type \\[patcher-mail-commit] to try again.")))))
 531     (pop-to-buffer (patcher-project-logmsg-buffer patcher-project))
 532     (patcher-logmsg-init)))
 533
 534 (defun patcher-mail-kill ()
 535   "Kill the project related to the current mail buffer."
 536   (interactive)
 537   (patcher-kill-project patcher-project))
 538
 539 (defcustom patcher-mail-minor-mode-string " Patch"
 540   "*Patcher mail minor mode modeline string."
 541   :group 'patcher
 542   :type 'string)
 543
 544 (defcustom patcher-mail-minor-mode-hook nil
 545   "*Hooks to run after setting up Patcher mail minor mode."
 546   :group 'patcher
 547   :type 'hook)
 548
 549 (defvar patcher-mail-minor-mode-map
 550   (let ((map (make-sparse-keymap 'patcher-mail-minor-mode-map)))
 551     (define-key map [(control c) (control p) S] 'patcher-mail-change-subject)
 552     (define-key map [(control c) (control p) d] 'patcher-mail-diff)
 553     (define-key map [(control c) (control p) l]
 554       'patcher-mail-insert-change-logs)
 555     (define-key map [(control c) (control p) n] 'patcher-mail-first-change-log)
 556     (define-key map [(control c) (control p) p] 'patcher-mail-last-change-log)
 557     (define-key map [(control c) (control p) c] 'patcher-mail-commit)
 558     (define-key map [(control c) (control p) k] 'patcher-mail-kill)
 559     (define-key map [(control c) (control p) v] 'patcher-version)
 560     map)
 561   ;; Patcher minor mode keymap.
 562   )
 563
 564 (make-variable-buffer-local
 565  (defvar patcher-mail-minor-mode nil))
 566
 567 (defun patcher-insert-patcher-header ()
 568   ;; Insert a Patcher version header in the message.
 569   (save-excursion
 570     (goto-char (point-min))
 571     (unless (re-search-forward "^X-Generated-By: Patcher " nil t)
 572       ;; This search can fail in case of fake mail method.
 573       (when (re-search-forward
 574              (concat "^" (regexp-quote mail-header-separator)) nil t)
 575         (goto-char (point-at-bol))
 576         (insert "X-Generated-By: " (patcher-version) "\n")))))
 577
 578 (defun patcher-mail-minor-mode (&optional arg)
 579   "Toggles Patcher mail minor mode.
 580
 581 Used for mails prepared with `patcher-mail'.  You're not supposed to use
 582 this, unless you know what you're doing.
 583
 584 The Patcher Mail minor mode provides the following commands:
 585 \\{patcher-mail-minor-mode-map}"
 586   (interactive "*P")
 587   (let ((was-off (not patcher-mail-minor-mode)))
 588     (setq patcher-mail-minor-mode
 589           (if (null arg)
 590               was-off
 591             (> (prefix-numeric-value arg) 0)))
 592     (when (and patcher-mail-minor-mode was-off)
 593       (patcher-insert-patcher-header)
 594       (run-hooks 'patcher-mail-minor-mode-hook))))
 595
 596 (add-minor-mode 'patcher-mail-minor-mode
 597                 patcher-mail-minor-mode-string
 598                 patcher-mail-minor-mode-map)
 599
 600
 601
 602 \f
 603 ;; ===========================================================================
 604 ;; Mail preparation routines
 605 ;; ===========================================================================
 606
 607 (defgroup patcher-mail nil
 608   "Patcher settings for mail buffers."
 609   :group 'patcher)
 610
 611 (defun patcher-before-send ()
 612   ;; Function hooked in the different mailing methods to perform some
 613   ;; checkings prior to sending the message.
 614
 615   ;; #### NOTE: it is currently impossible (and probably not worth it) to
 616   ;; #### offer an automatic ChangeLog insertion or commit operation at that
 617   ;; #### point: we're already in an interactive call (the message sending
 618   ;; #### pocess) and a complex trickery would be necessary in case of
 619   ;; #### operation failure.  So it's simpler to just abort the sending, let
 620   ;; #### the user manually fix things, and re-send the message.
 621
 622   ;; Check for a diff:
 623   (or (patcher-extent 'diff)
 624       (patcher-error "There's no diff in this message !"))
 625   ;; Check for ChangeLogs:
 626   (let ((check-insertion (patcher-project-option patcher-project
 627                            :check-change-logs-insertion)))
 628     (when (and check-insertion
 629                (patcher-project-option patcher-project :change-logs-appearance)
 630                (not (patcher-change-logs))
 631                (or (eq check-insertion t)
 632                    ;; all other values are considered to be like 'ask
 633                    (not (y-or-n-p "\
 634 You did not insert the ChangeLog entries.  Proceed with sending anyway ? "))))
 635       (patcher-error "\
 636 Sending aborted.  Please insert the ChangeLogs first.")))
 637   ;; Check commit operation:
 638   (let ((check-commit (patcher-project-option patcher-project :check-commit)))
 639     (when (and check-commit
 640                (patcher-project-option patcher-project :commit-privilege)
 641                (not (patcher-project-committed-p patcher-project))
 642                (or (eq check-commit t)
 643                    ;; all other values are considered to be like 'ask
 644                    (not (y-or-n-p "\
 645 You did not commit your changes.  Proceed with sending anyway ? "))))
 646       (patcher-error "\
 647 Sending aborted.  Please commit your changes first."))))
 648
 649 (defun patcher-after-send (&optional unused)
 650   ;; Function hooked in the different mailing methods to clean up the place
 651   ;; when a Patcher mail is sent.
 652   (patcher-delete-project patcher-project))
 653
 654 (defun patcher-install-send-hooks ()
 655   ;; Install before- and after-send hooks into the MUA.
 656   (cond ((eq major-mode 'mail-mode)
 657          (add-local-hook 'mail-send-hook 'patcher-before-send)
 658          (push '(patcher-after-send) mail-send-actions))
 659         ((eq major-mode 'message-mode)
 660          (add-local-hook 'message-send-hook 'patcher-before-send)
 661          ;; `message-exit-actions' is probably more appropriate than
 662          ;; `message-send-actions' to perform the cleanup.
 663          (with-boundp 'message-exit-actions
 664            (push '(patcher-after-send) message-exit-actions)))
 665         (t
 666          (patcher-warning "\
 667 Major mode: %s.
 668 This mailing method is not fully supported by Patcher.
 669 This is not critical though: Patcher won't be able to perform checks or
 670 cleanups during mail sending.
 671
 672 Please report to <didier@xemacs.org>."
 673                           major-mode))))
 674
 675
 676 ;; Patcher FakeMail mode ====================================================
 677
 678 (defun patcher-fakemail-send ()
 679   "Pretend to send a fake Patcher mail.
 680
 681 Only perform the usual cleanup after real Patcher mails are sent."
 682   (interactive)
 683   (patcher-before-send)
 684   (patcher-after-send)
 685   (kill-buffer (current-buffer)))
 686
 687 (defvar patcher-fakemail-mode-map
 688   (let ((map (make-sparse-keymap 'patcher-fakemail-mode-map)))
 689     (define-key map [(control c) (control c)] 'patcher-fakemail-send)
 690     map))
 691
 692 (defun patcher-fakemail-mode ()
 693   "Sets up Patcher-FakeMail major mode.
 694
 695 Used for editing a fake Patcher mail.
 696
 697 The following command are available in a Fake Mail buffer:
 698 \\{patcher-fakemail-mode-map}"
 699   (interactive)
 700   (kill-all-local-variables)
 701   (setq major-mode 'patcher-fakemail)
 702   (setq mode-name "Patcher-FakeMail")
 703   (use-local-map patcher-fakemail-mode-map)
 704   (run-hooks 'patcher-logmsg-mode-hook))
 705
 706
 707 ;; Interface to the different mailing methods ================================
 708
 709 (put 'patcher-with-mail-parameters 'lisp-indent-function 1)
 710 (defmacro* patcher-with-mail-parameters (project &body body)
 711   ;; Wrap BODY in a let construct possibly defining user-full-name and
 712   ;; user-mail-address by Patcher options.
 713   ;; Return the value of BODY execution.
 714   ;; #### NOTE: why is it called like this ? Because I'm sure one day or
 715   ;; #### another, some sucker will ask for more parameters, like the mail
 716   ;; #### signature for instance ;-)
 717   `(let ((user-full-name (or (patcher-project-option ,project :user-name)
 718                              user-full-name))
 719          (user-mail-address (or (patcher-project-option ,project :user-mail)
 720                                 user-mail-address)))
 721      ,@body))
 722
 723
 724 (defun patcher-mail-compose-mail (project subject)
 725   "Prepare a patch-related mail with the `compose-mail' function.
 726
 727 This function uses the `:to-address' project option to determine the email
 728 address for sending the message.  Otherwise, the address is prompted for.
 729
 730 See also the `mail-user-agent' variable."
 731   (patcher-with-mail-parameters project
 732     (compose-mail (or (patcher-project-option project :to-address)
 733                       (read-string "To address: "))
 734                   subject))
 735   (patcher-install-send-hooks))
 736
 737
 738 (defun patcher-mail-sendmail (project subject)
 739   "Prepare a patch-related mail with the `mail' function.
 740 This method requires the `sendmail' library.
 741
 742 This function uses the `:to-address' project option to determine the email
 743 address for sending the message.  Otherwise, the address is prompted for."
 744   (require 'sendmail)
 745   (patcher-with-mail-parameters project
 746     (mail nil (or (patcher-project-option project :to-address)
 747                   (read-string "To address: "))
 748           subject))
 749   (patcher-install-send-hooks))
 750
 751 (defun patcher-mail-message (project subject)
 752   "Prepare a patch-related mail with the `message-mail' function.
 753 This method requires the `message' library.
 754
 755 This function uses the `:to-address' project option to determine the email
 756 address for sending the message.  Otherwise, the address is prompted for."
 757   (require 'message)
 758   (patcher-with-mail-parameters project
 759     (message-mail (or (patcher-project-option project :to-address)
 760                       (read-string "To address: "))
 761                   subject))
 762   (patcher-install-send-hooks))
 763
 764 (defcustom patcher-mail-run-gnus 'prompt
 765   "*Whether Patcher should run Gnus.
 766
 767 The 'gnus mailing method of Patcher needs a running Gnus session.
 768 If Gnus is not running at the time it is needed, Patcher can start
 769 it (or not) depending on this variable:
 770 - if nil, Patcher will abort execution,
 771 - it 'prompt (the default), Patcher will ask you what to do,
 772 - if t Patcher will unconditionally start Gnus.
 773
 774 See also the function `patcher-mail-gnus'."
 775   :group 'patcher-mail
 776   :type '(radio (const :tag "never" nil)
 777                 (const :tag "ask user" prompt)
 778                 (const :tag "as needed" t)))
 779
 780 (defcustom patcher-mail-run-gnus-other-frame t
 781   "*Whether Patcher should start Gnus in a new frame.
 782
 783 This is used in case Patcher has to start Gnus by itself \(see the
 784 variable `patcher-mail-run-gnus').  Possible values are:
 785 - nil:     start Gnus in the current frame,
 786 - t:       start Gnus in a new frame,
 787 - 'follow: start Gnus in a new frame, and also use this frame to prepare
 788            the new Patcher message."
 789   :group 'patcher-mail
 790   :type '(radio (const :tag "Use current frame" nil)
 791                 (const :tag "Create new frame" t)
 792                 (const :tag "Create new frame, and use it for patcher"
 793                        follow)))
 794
 795 (defun patcher-mail-run-gnus ()
 796   ;; Start a gnus session.
 797   (require 'gnus)
 798   (save-excursion
 799     (cond ((eq patcher-mail-run-gnus-other-frame t)
 800            (save-selected-frame (gnus-other-frame)))
 801           ((eq patcher-mail-run-gnus-other-frame 'follow)
 802            (gnus-other-frame))
 803           ((not patcher-mail-run-gnus-other-frame)
 804            (gnus))
 805           (t
 806            (patcher-error "\
 807 Invalid value for `patcher-mail-run-gnus-other-frame': "
 808                           patcher-mail-run-gnus-other-frame)))))
 809
 810 (globally-declare-boundp 'gnus-article-copy)
 811
 812 (defun patcher-mail-gnus (project subject)
 813   "Prepare a patch-related mail with the `gnus-post-news' function.
 814 Don't worry, this function can also send mails ;-).  This method
 815 requires that you have Gnus *running* in your XEmacs session \(see
 816 the variable `patcher-mail-run-gnus').
 817
 818 This function uses the `:gnus-group' project option to determine the Gnus
 819 group to use \(as if you had typed `C-u a' on that group in the Group
 820 buffer).  Otherwise, the group is prompted for."
 821   (require 'gnus-util)
 822   (with-fboundp '(gnus-alive-p gnus-post-news message-goto-body)
 823     (unless (gnus-alive-p)
 824       (cond ((not patcher-mail-run-gnus)
 825              (patcher-error
 826               "The 'gnus mailing method requires a running Gnus session"))
 827             ((eq patcher-mail-run-gnus t)
 828              (patcher-mail-run-gnus))
 829             ((eq patcher-mail-run-gnus 'prompt)
 830              (if (y-or-n-p "Gnus is not currently running.  Start it ? ")
 831                  (patcher-mail-run-gnus)
 832                (patcher-error
 833                 "The 'gnus mailing method requires a running Gnus session")))
 834             (t
 835              (patcher-error "Invalid value for `patcher-mail-run-gnus': "
 836                             patcher-mail-run-gnus))))
 837     (let ((gnus-newsgroup-name (or (patcher-project-option project
 838                                      :gnus-group)
 839                                    (read-string "Gnus group name: ")))
 840           gnus-article-copy)
 841       (patcher-with-mail-parameters project
 842         (gnus-post-news 'post gnus-newsgroup-name)))
 843     (patcher-goto-subject)
 844     (insert subject)
 845     (message-goto-body)
 846     (patcher-install-send-hooks)))
 847
 848 (defun* patcher-mail-fake
 849     (project subject &aux (buffer (generate-new-buffer "*Patcher Fake Mail*")))
 850   "Prepare a patch-related fake mail.
 851 Use this function if you want to do all that Patcher can do, apart from
 852 sending a real mail.  This function generates a fake mail buffer which acts
 853 as a standard Patcher mail buffer, apart from the fact that when you type
 854 \\<patcher-fakemail-mode-map>\\[patcher-fakemail-send] in it, it doesn't
 855 really send a mail, but just clean things up."
 856   (switch-to-buffer buffer)
 857   (insert "Subject: " subject "\n")
 858   (patcher-fakemail-mode))
 859
 860 (defun patcher-mail-setup (project)
 861   ;; Setup patcher-mail-minor-mode and initialize Patcher local variables in
 862   ;; mails (both generated or adapted).
 863   (setf (patcher-project-mail-buffer project) (current-buffer))
 864   (patcher-mail-minor-mode t)
 865   (cd (patcher-project-command-directory project))
 866   (setq patcher-project project))
 867
 868
 869 ;; Mail generation entry point ==============================================
 870
 871 ;;;###autoload
 872 (defun* patcher-mail (project)
 873   "Prepare a mail about a patch to apply on PROJECT.
 874
 875 When called interactively, prompt for a project name
 876 \(see the variables `patcher-projects' and `patcher-subprojects') and
 877 a subject for the mail.
 878
 879 With a additional prefix argument, create a temporary subproject by
 880 prompting for an optional subdirectory and specific files as well. Files,
 881 directories and even wildcards are acceptable in your specification.
 882
 883 With a prefix of 1, offer to relocate the project to another directory.
 884 With a prefix of -1, do the same, but also create a temporary subproject of
 885 the relocated project."
 886   (interactive (patcher-project-interactive current-prefix-arg))
 887   (funcall (intern (concat "patcher-mail-"
 888                            (symbol-name
 889                             (patcher-project-option project :mail-method t))))
 890            project
 891            (patcher-prefixed-subject project))
 892   (patcher-mail-setup project)
 893   (let ((mail-prologue (patcher-project-option project :mail-prologue)))
 894     (unless (zerop (length mail-prologue))
 895       (insert "\n" mail-prologue)))
 896   (save-excursion
 897     (insert "\n\n")
 898     (when (patcher-project-option project :change-logs-updating)
 899       (let ((appearance
 900              (patcher-project-option project :change-logs-appearance)))
 901         (when (and appearance (not (eq appearance 'patch)))
 902           (setq patcher-change-logs-marker (point-marker))
 903           (insert "\n"))))
 904     (setq patcher-diff-marker (point-marker))
 905     (patcher-diff-project project)))
 906
 907
 908 ;; Mail adaptation entry point ==============================================
 909
 910 ;;;###autoload
 911 (defun patcher-mail-adapt (project)
 912   "Same as `patcher-mail', but for existing mails."
 913   (interactive (patcher-project-interactive current-prefix-arg))
 914   (patcher-goto-subject)
 915   (let ((beg (point))
 916         end
 917         old-subject)
 918     (while (progn (forward-line 1)
 919                   (looking-at "[ \t]")))
 920     (backward-char 1)
 921     (setq end (point))
 922     (skip-chars-backward " \t")
 923     (setq old-subject (buffer-substring beg (point)))
 924     (delete-region beg end)
 925     (while (string-match "\n[\t ]+" old-subject)
 926       (setq old-subject (replace-match " " t t old-subject)))
 927     (insert (patcher-prefixed-subject project old-subject)))
 928   (patcher-install-send-hooks)
 929   (patcher-mail-setup project)
 930   ;; #### NOTE: currently, I have simply discarded the mail-prologue
 931   ;; #### insertion for adapted mails. This is because mail adaptation is
 932   ;; #### mostly for replies in which you probably don't want the standard
 933   ;; #### prologue. However, this could be turned into a standard option.
 934   ;;  (let ((mail-prologue (patcher-project-option project :mail-prologue)))
 935   ;;    (unless (zerop (length mail-prologue))
 936   ;;      (insert "\n" mail-prologue)))
 937   (patcher-goto-signature)
 938   (when (patcher-project-option project :change-logs-updating)
 939     (let ((appearance
 940            (patcher-project-option project :change-logs-appearance)))
 941       (when (and appearance (not (eq appearance 'patch)))
 942         (setq patcher-change-logs-marker (point-marker))
 943         (insert "\n"))))
 944   (setq patcher-diff-marker (point-marker))
 945   (patcher-diff-project project))
 946
 947
 948
 949 \f
 950 ;; ==========================================================================
 951 ;; Gnus insinuation
 952 ;; ==========================================================================
 953
 954 ;; Patcher Gnus Summary minor mode ==========================================
 955
 956 (defun patcher-gnus-summary-followup (&optional arg)
 957   "Prepare a Patcher followup from the Gnus Summary buffer.
 958 See `patcher-mail' for more information."
 959   (interactive "P")
 960   (declare-fboundp (gnus-summary-followup nil))
 961   (call-interactively 'patcher-mail-adapt))
 962
 963 (defun patcher-gnus-summary-followup-with-original (&optional arg)
 964   "Prepare a Patcher followup from the Gnus Summary buffer.
 965 The original message is yanked.
 966 See `patcher-mail' for more information."
 967   (interactive "P")
 968   (declare-fboundp (gnus-summary-followup-with-original nil))
 969   (call-interactively 'patcher-mail-adapt))
 970
 971 (defun patcher-gnus-summary-reply (&optional arg)
 972   "Prepare a Patcher reply from the Gnus Summary buffer.
 973 See `patcher-mail' for more information."
 974   (interactive "P")
 975   ;; #### NOTE: it is strange that this function's first argument is not
 976   ;; #### mandatory, as in the 3 other ones.
 977   (declare-fboundp (gnus-summary-reply))
 978   (call-interactively 'patcher-mail-adapt))
 979
 980 (defun patcher-gnus-summary-reply-with-original (&optional arg)
 981   "Prepare a Patcher reply from the Gnus Summary buffer.
 982 The original message is yanked.
 983 See `patcher-mail' for more information."
 984   (interactive "P")
 985   (declare-fboundp (gnus-summary-reply-with-original nil))
 986   (call-interactively 'patcher-mail-adapt))
 987
 988 (defcustom patcher-gnus-summary-minor-mode-string " Patch"
 989   "*Patcher Gnus Summary minor mode modeline string."
 990   :group 'patcher
 991   :type 'string)
 992
 993 (defcustom patcher-gnus-summary-minor-mode-hook nil
 994   "*Hooks to run after setting up Patcher Gnus Summary minor mode."
 995   :group 'patcher
 996   :type 'hook)
 997
 998 (defvar patcher-gnus-summary-minor-mode-map
 999   (let ((map (make-sparse-keymap 'patcher-gnus-summary-minor-mode-map)))
1000     (define-key map [(control c) (control p) f]
1001       'patcher-gnus-summary-followup)
1002     (define-key map [(control c) (control p) F]
1003       'patcher-gnus-summary-followup-with-original)
1004     (define-key map [(control c) (control p) r]
1005       'patcher-gnus-summary-reply)
1006     (define-key map [(control c) (control p) R]
1007       'patcher-gnus-summary-reply-with-original)
1008     map)
1009   ;; Patcher Gnus Summary minor mode keymap.
1010   )
1011
1012 (make-variable-buffer-local
1013  (defvar patcher-gnus-summary-minor-mode nil))
1014
1015 (defun patcher-gnus-summary-minor-mode (&optional arg)
1016   "Toggles Patcher Gnus Summary minor mode.
1017
1018 Used for Patcher messages composed as Gnus replies and followups.
1019 You're not supposed to use this, unless you know what you're doing.
1020
1021 The Patcher Gnus Summary minor mode provides the following commands:
1022 \\{patcher-gnus-summary-minor-mode-map}"
1023   (interactive "*P")
1024   (let ((was-off (not patcher-gnus-summary-minor-mode)))
1025     (setq patcher-gnus-summary-minor-mode
1026           (if (null arg)
1027               was-off
1028             (> (prefix-numeric-value arg) 0)))
1029     (when (and patcher-gnus-summary-minor-mode was-off)
1030       (run-hooks 'patcher-gnus-summary-minor-mode-hook))))
1031
1032 (add-minor-mode
1033  'patcher-gnus-summary-minor-mode
1034  patcher-gnus-summary-minor-mode-string
1035  patcher-gnus-summary-minor-mode-map)
1036
1037
1038 ;; Patcher Gnus Article minor mode ==========================================
1039
1040 (defcustom patcher-gnus-article-minor-mode-string " Patch"
1041   "*Patcher Gnus Article minor mode modeline string."
1042   :group 'patcher
1043   :type 'string)
1044
1045 (defcustom patcher-gnus-article-minor-mode-hook nil
1046   "*Hooks to run after setting up Patcher Gnus Article minor mode."
1047   :group 'patcher
1048   :type 'hook)
1049
1050 (defvar patcher-gnus-article-minor-mode-map
1051   (let ((map (make-sparse-keymap 'patcher-gnus-article-minor-mode-map)))
1052     (define-key map [(control c) (control p) f]
1053       'patcher-gnus-summary-followup)
1054     (define-key map [(control c) (control p) F]
1055       'patcher-gnus-summary-followup-with-original)
1056     (define-key map [(control c) (control p) r]
1057       'patcher-gnus-summary-reply)
1058     (define-key map [(control c) (control p) R]
1059       'patcher-gnus-summary-reply-with-original)
1060     map)
1061   ;; Patcher Gnus Article minor mode keymap.
1062   )
1063
1064 (make-variable-buffer-local
1065  (defvar patcher-gnus-article-minor-mode nil))
1066
1067 (defun patcher-gnus-article-minor-mode (&optional arg)
1068   "Toggles Patcher Gnus Article minor mode.
1069
1070 Used for Patcher messages composed as Gnus replies and followups.
1071 You're not supposed to use this, unless you know what you're doing.
1072
1073 The Patcher Gnus Article minor mode provides the following commands:
1074 \\{patcher-gnus-article-minor-mode-map}"
1075   (interactive "*P")
1076   (let ((was-off (not patcher-gnus-article-minor-mode)))
1077     (setq patcher-gnus-article-minor-mode
1078           (if (null arg)
1079               was-off
1080             (> (prefix-numeric-value arg) 0)))
1081     (when (and patcher-gnus-article-minor-mode was-off)
1082       (run-hooks 'patcher-gnus-article-minor-mode-hook))))
1083
1084 (add-minor-mode
1085  'patcher-gnus-article-minor-mode
1086  patcher-gnus-article-minor-mode-string
1087  patcher-gnus-article-minor-mode-map)
1088
1089
1090 ;; Insinuation ==============================================================
1091
1092 ;;;###autoload
1093 (defun patcher-insinuate-gnus ()
1094   "Hook Patcher functionality into Gnus.
1095
1096 This function should be called from your gnusrc file."
1097   (add-hook 'gnus-summary-mode-hook
1098             (lambda () (patcher-gnus-summary-minor-mode t)))
1099   (add-hook 'gnus-article-mode-hook
1100             (lambda () (patcher-gnus-article-minor-mode t))))
1101
1102
1103 (provide 'patcher-mail)
1104
1105 ;;; patcher-mail.el ends here