lisp/mh-e/mh-identity.el

   1 ;;; mh-identity.el --- Multiple identify support for MH-E.
   2
   3 ;; Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   4
   5 ;; Author: Peter S. Galbraith <psg@debian.org>
   6 ;; Maintainer: Bill Wohler <wohler@newt.com>
   7 ;; Keywords: mail
   8 ;; See: mh-e.el
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Multiple identity support for MH-E.
  30 ;;
  31 ;; Used to easily set different fields such as From and Organization, as
  32 ;; well as different signature files.
  33 ;;
  34 ;; Customize the variable `mh-identity-list' and an Identity menu will
  35 ;; appear in mh-letter-mode.  The command 'mh-insert-identity can be used
  36 ;; from the command line.
  37
  38 ;;; Change Log:
  39
  40 ;;; Code:
  41
  42 (eval-when-compile (require 'mh-acros))
  43 (mh-require-cl)
  44 (require 'mh-comp)
  45
  46 (autoload 'mml-insert-tag "mml")
  47
  48 (defvar mh-identity-pgg-default-user-id nil
  49   "Holds the GPG key ID to be used by pgg.el.
  50 This is normally set as part of an Identity in `mh-identity-list'.")
  51 (make-variable-buffer-local 'mh-identity-pgg-default-user-id)
  52
  53 ;;;###mh-autoload
  54 (defun mh-identity-make-menu ()
  55   "Build the Identity menu.
  56 This should be called any time `mh-identity-list' or `mh-auto-fields-list'
  57 change."
  58   (easy-menu-define mh-identity-menu mh-letter-mode-map
  59     "MH-E identity menu"
  60     (append
  61      '("Identity")
  62      ;; Dynamically render :type corresponding to `mh-identity-list'
  63      ;; e.g.:
  64      ;;  ["Home" (mh-insert-identity "Home")
  65      ;;   :style radio :active (not (equal mh-identity-local "Home"))
  66      ;;   :selected (equal mh-identity-local "Home")]
  67      '(["Insert Auto Fields"
  68         (mh-insert-auto-fields) mh-auto-fields-list]
  69        "--")
  70
  71      (mapcar (function
  72               (lambda (arg)
  73                 `[,arg  (mh-insert-identity ,arg) :style radio
  74                         :selected (equal mh-identity-local ,arg)]))
  75              (mapcar 'car mh-identity-list))
  76      '(["None"
  77         (mh-insert-identity "None") :style radio
  78         :selected (not mh-identity-local)]
  79        "--"
  80        ["Set Default for Session"
  81         (setq mh-identity-default mh-identity-local) t]
  82        ["Save as Default"
  83         (customize-save-variable 'mh-identity-default mh-identity-local) t]
  84        ["Customize Identities" (customize-variable 'mh-identity-list) t]
  85        ))))
  86
  87 ;;;###mh-autoload
  88 (defun mh-identity-list-set (symbol value)
  89   "Update the `mh-identity-list' variable, and rebuild the menu.
  90 Sets the default for SYMBOL (e.g. `mh-identity-list') to VALUE (as set in
  91 customization).  This is called after 'customize is used to alter
  92 `mh-identity-list'."
  93   (set-default symbol value)
  94   (mh-identity-make-menu))
  95
  96 (defvar mh-identity-local nil
  97   "Buffer-local variable holding the identity currently in use.")
  98 (make-variable-buffer-local 'mh-identity-local)
  99
 100 (defun mh-header-field-delete (field value-only)
 101   "Delete FIELD in the mail header, or only its value if VALUE-ONLY is t.
 102 Return t if anything is deleted."
 103   (let ((field-colon (if (string-match "^.*:$" field)
 104                          field
 105                        (concat field ":"))))
 106     (when (mh-goto-header-field field-colon)
 107       (if (not value-only)
 108           (beginning-of-line)
 109         (forward-char))
 110       (delete-region (point)
 111                      (progn (mh-header-field-end)
 112                             (if (not value-only) (forward-char 1))
 113                             (point)))
 114       t)))
 115
 116 (defvar mh-identity-signature-start nil
 117   "Marker for the beginning of a signature inserted by `mh-insert-identity'.")
 118 (defvar mh-identity-signature-end nil
 119   "Marker for the end of a signature inserted by `mh-insert-identity'.")
 120
 121 (defun mh-identity-field-handler (field)
 122   "Return the handler for a FIELD or nil if none set.
 123 The field name is downcased. If the FIELD begins with the character
 124 `:', then it must have a special handler defined in
 125 `mh-identity-handlers', else return an error since it is not a legal
 126 message header."
 127   (or (cdr (assoc (downcase field) mh-identity-handlers))
 128       (and (eq (aref field 0) ?:)
 129            (error (format "Field %s - unknown mh-identity-handler" field)))
 130       (cdr (assoc ":default" mh-identity-handlers))
 131       'mh-identity-handler-default))
 132
 133 ;;;###mh-autoload
 134 (defun mh-insert-identity (identity)
 135   "Insert proper fields for given IDENTITY.
 136 Edit the `mh-identity-list' variable to define identity."
 137   (interactive
 138    (list (completing-read
 139           "Identity: "
 140           (if mh-identity-local
 141               (cons '("None")
 142                     (mapcar 'list (mapcar 'car mh-identity-list)))
 143             (mapcar 'list (mapcar 'car mh-identity-list)))
 144           nil t)))
 145   (save-excursion
 146     ;;First remove old settings, if any.
 147     (when mh-identity-local
 148       (let ((pers-list (cadr (assoc mh-identity-local mh-identity-list))))
 149         (while pers-list
 150           (let* ((field (caar pers-list))
 151                  (handler (mh-identity-field-handler field)))
 152             (funcall handler field 'remove))
 153           (setq pers-list (cdr pers-list)))))
 154     ;; Then insert the replacement
 155     (when (not (equal "None" identity))
 156       (let ((pers-list (cadr (assoc identity mh-identity-list))))
 157         (while pers-list
 158           (let* ((field (caar pers-list))
 159                  (value (cdar pers-list))
 160                  (handler (mh-identity-field-handler field)))
 161             (funcall handler field 'add value))
 162           (setq pers-list (cdr pers-list))))))
 163   ;; Remember what is in use in this buffer
 164   (if (equal "None" identity)
 165       (setq mh-identity-local nil)
 166     (setq mh-identity-local identity)))
 167
 168 ;;;###mh-autoload
 169 (defun mh-identity-handler-gpg-identity (field action &optional value)
 170   "For FIELD \"pgg-default-user-id\", process for ACTION 'remove or 'add.
 171 The buffer-local variable `mh-identity-pgg-default-user-id' is set to VALUE
 172 when action 'add is selected."
 173   (cond
 174    ((or (equal action 'remove)
 175         (not value)
 176         (string= value ""))
 177     (setq mh-identity-pgg-default-user-id nil))
 178    ((equal action 'add)
 179     (setq mh-identity-pgg-default-user-id value))))
 180
 181 ;;;###mh-autoload
 182 (defun mh-identity-handler-signature (field action &optional value)
 183   "For FIELD \"signature\", process headers for ACTION 'remove or 'add.
 184 The VALUE is added."
 185   (cond
 186    ((equal action 'remove)
 187     (when (and (markerp mh-identity-signature-start)
 188                (markerp mh-identity-signature-end))
 189       (delete-region mh-identity-signature-start
 190                      mh-identity-signature-end)))
 191    (t
 192     ;; Insert "signature". Nil value means to use `mh-signature-file-name'.
 193     (when (not (mh-signature-separator-p)) ;...unless already present
 194       (goto-char (point-max))
 195       (save-restriction
 196         (narrow-to-region (point) (point))
 197         (if (null value)
 198             (mh-insert-signature)
 199           (mh-insert-signature value))
 200         (set (make-local-variable 'mh-identity-signature-start)
 201              (point-min-marker))
 202         (set-marker-insertion-type mh-identity-signature-start t)
 203         (set (make-local-variable 'mh-identity-signature-end)
 204              (point-max-marker)))))))
 205
 206 (defvar mh-identity-attribution-verb-start nil
 207   "Marker for the beginning of the attribution verb.")
 208 (defvar mh-identity-attribution-verb-end nil
 209   "Marker for the end of the attribution verb.")
 210
 211 ;;;###mh-autoload
 212 (defun mh-identity-handler-attribution-verb (field action &optional value)
 213   "For FIELD \"attribution_verb\", process headers for ACTION 'remove or 'add.
 214 The VALUE is added."
 215   (when (and (markerp mh-identity-attribution-verb-start)
 216              (markerp mh-identity-attribution-verb-end))
 217     (delete-region mh-identity-attribution-verb-start
 218                    mh-identity-attribution-verb-end)
 219     (goto-char mh-identity-attribution-verb-start)
 220     (cond
 221      ((equal action 'remove)              ; Replace with default
 222       (mh-identity-insert-attribution-verb nil))
 223      (t                                   ; Insert attribution verb.
 224       (mh-identity-insert-attribution-verb value)))))
 225
 226 ;;;###mh-autoload
 227 (defun mh-identity-insert-attribution-verb (value)
 228   "Insert VALUE as attribution verb, setting up delimiting markers.
 229 If VALUE is nil, use `mh-extract-from-attribution-verb'."
 230   (save-restriction
 231     (narrow-to-region (point) (point))
 232     (if (null value)
 233         (insert mh-extract-from-attribution-verb)
 234       (insert value))
 235     (set (make-local-variable 'mh-identity-attribution-verb-start)
 236          (point-min-marker))
 237     (set-marker-insertion-type mh-identity-attribution-verb-start t)
 238     (set (make-local-variable 'mh-identity-attribution-verb-end)
 239          (point-max-marker))))
 240
 241 (defun mh-identity-handler-default (field action top &optional value)
 242   "For FIELD, process mh-identity headers for ACTION 'remove or 'add.
 243 if TOP is non-nil, add the field and it's VALUE at the top of the header, else
 244 add it at the bottom of the header."
 245   (let ((field-colon (if (string-match "^.*:$" field)
 246                          field
 247                        (concat field ":"))))
 248     (cond
 249      ((equal action 'remove)
 250       (mh-header-field-delete field-colon nil))
 251      (t
 252       (cond
 253        ;; No value, remove field
 254        ((or (not value)
 255             (string= value ""))
 256         (mh-header-field-delete field-colon nil))
 257        ;; Existing field, replace
 258        ((mh-header-field-delete field-colon t)
 259         (insert value))
 260        ;; Other field, add at end or top
 261        (t
 262         (goto-char (point-min))
 263         (if (not top)
 264             (mh-goto-header-end 0))
 265         (insert field-colon " " value "\n")))))))
 266
 267 ;;;###mh-autoload
 268 (defun mh-identity-handler-top (field action &optional value)
 269   "For FIELD, process mh-identity headers for ACTION 'remove or 'add.
 270 If the field wasn't present, the VALUE is added at the top of the header."
 271   (mh-identity-handler-default field action t value))
 272
 273 ;;;###mh-autoload
 274 (defun mh-identity-handler-bottom (field action &optional value)
 275   "For FIELD, process mh-identity headers for ACTION 'remove or 'add.
 276 If the field wasn't present, the VALUE is added at the bottom of the header."
 277   (mh-identity-handler-default field action nil value))
 278
 279 (provide 'mh-identity)
 280
 281 ;;; Local Variables:
 282 ;;; indent-tabs-mode: nil
 283 ;;; sentence-end-double-space: nil
 284 ;;; End:
 285
 286 ;;; arch-tag: 07d66ef6-8726-4ac6-9ecf-e566cd5bfb45
 287 ;;; mh-identity.el ends here