lisp/mh-e/mh-identity.el

   1 ;;; mh-identity.el --- Multiple identify support for MH-E.
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006 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., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, 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 ;;(message "> mh-identity")
  43 (eval-when-compile (require 'mh-acros))
  44
  45 (require 'mh-comp)
  46 ;;(message "< mh-identity")
  47
  48 (autoload 'mml-insert-tag "mml")
  49
  50 (defvar mh-identity-pgg-default-user-id nil
  51   "Holds the GPG key ID to be used by pgg.el.
  52 This is normally set as part of an Identity in
  53 `mh-identity-list'.")
  54 (make-variable-buffer-local 'mh-identity-pgg-default-user-id)
  55
  56 ;;;###mh-autoload
  57 (defun mh-identity-make-menu ()
  58   "Build the Identity menu.
  59 This should be called any time `mh-identity-list' or
  60 `mh-auto-fields-list' change."
  61   (easy-menu-define mh-identity-menu mh-letter-mode-map
  62     "MH-E identity menu"
  63     (append
  64      '("Identity")
  65      ;; Dynamically render :type corresponding to `mh-identity-list'
  66      ;; e.g.:
  67      ;;  ["Home" (mh-insert-identity "Home")
  68      ;;   :style radio :active (not (equal mh-identity-local "Home"))
  69      ;;   :selected (equal mh-identity-local "Home")]
  70      '(["Insert Auto Fields"
  71         (mh-insert-auto-fields) mh-auto-fields-list]
  72        "--")
  73
  74      (mapcar (function
  75               (lambda (arg)
  76                 `[,arg  (mh-insert-identity ,arg) :style radio
  77                         :selected (equal mh-identity-local ,arg)]))
  78              (mapcar 'car mh-identity-list))
  79      '(["None"
  80         (mh-insert-identity "None") :style radio
  81         :selected (not mh-identity-local)]
  82        "--"
  83        ["Set Default for Session"
  84         (setq mh-identity-default mh-identity-local) t]
  85        ["Save as Default"
  86         (customize-save-variable 'mh-identity-default mh-identity-local) t]
  87        ["Customize Identities" (customize-variable 'mh-identity-list) t]
  88        ))))
  89
  90 ;;;###mh-autoload
  91 (defun mh-identity-list-set (symbol value)
  92   "Update the `mh-identity-list' variable, and rebuild the menu.
  93 Sets the default for SYMBOL (for example, `mh-identity-list') to
  94 VALUE (as set in customization). This is called after 'customize
  95 is used to alter `mh-identity-list'."
  96   (set-default symbol value)
  97   (mh-identity-make-menu))
  98
  99 (defvar mh-identity-local nil
 100   "Buffer-local variable that holds the identity currently in use.")
 101 (make-variable-buffer-local 'mh-identity-local)
 102
 103 (defun mh-header-field-delete (field value-only)
 104   "Delete header FIELD, or only its value if VALUE-ONLY is t.
 105 Return t if anything is deleted."
 106   (let ((field-colon (if (string-match "^.*:$" field)
 107                          field
 108                        (concat field ":"))))
 109     (when (mh-goto-header-field field-colon)
 110       (if (not value-only)
 111           (beginning-of-line)
 112         (forward-char))
 113       (delete-region (point)
 114                      (progn (mh-header-field-end)
 115                             (if (not value-only) (forward-char 1))
 116                             (point)))
 117       t)))
 118
 119 (defvar mh-identity-signature-start nil
 120   "Marker for the beginning of a signature inserted by `mh-insert-identity'.")
 121 (defvar mh-identity-signature-end nil
 122   "Marker for the end of a signature inserted by `mh-insert-identity'.")
 123
 124 (defun mh-identity-field-handler (field)
 125   "Return the handler for header FIELD or nil if none set.
 126 The field name is downcased. If the FIELD begins with the
 127 character \":\", then it must have a special handler defined in
 128 `mh-identity-handlers', else return an error since it is not a
 129 valid header field."
 130   (or (cdr (assoc-string field mh-identity-handlers t))
 131       (and (eq (aref field 0) ?:)
 132            (error "Field %s not found in `mh-identity-handlers'" field))
 133       (cdr (assoc ":default" mh-identity-handlers))
 134       'mh-identity-handler-default))
 135
 136 ;;;###mh-autoload
 137 (defun mh-insert-identity (identity)
 138   "Insert fields specified by given IDENTITY.
 139 See `mh-identity-list'."
 140   (interactive
 141    (list (completing-read
 142           "Identity: "
 143           (if mh-identity-local
 144               (cons '("None")
 145                     (mapcar 'list (mapcar 'car mh-identity-list)))
 146             (mapcar 'list (mapcar 'car mh-identity-list)))
 147           nil t)))
 148   (save-excursion
 149     ;;First remove old settings, if any.
 150     (when mh-identity-local
 151       (let ((pers-list (cadr (assoc mh-identity-local mh-identity-list))))
 152         (while pers-list
 153           (let* ((field (caar pers-list))
 154                  (handler (mh-identity-field-handler field)))
 155             (funcall handler field 'remove))
 156           (setq pers-list (cdr pers-list)))))
 157     ;; Then insert the replacement
 158     (when (not (equal "None" identity))
 159       (let ((pers-list (cadr (assoc identity mh-identity-list))))
 160         (while pers-list
 161           (let* ((field (caar pers-list))
 162                  (value (cdar pers-list))
 163                  (handler (mh-identity-field-handler field)))
 164             (funcall handler field 'add value))
 165           (setq pers-list (cdr pers-list))))))
 166   ;; Remember what is in use in this buffer
 167   (if (equal "None" identity)
 168       (setq mh-identity-local nil)
 169     (setq mh-identity-local identity)))
 170
 171 ;;;###mh-autoload
 172 (defun mh-identity-handler-gpg-identity (field action &optional value)
 173   "Process header FIELD \":pgg-default-user-id\".
 174 The ACTION is one of 'remove or 'add. If 'add, the VALUE is added.
 175 The buffer-local variable `mh-identity-pgg-default-user-id' is set to
 176 VALUE when action 'add is selected."
 177   (cond
 178    ((or (equal action 'remove)
 179         (not value)
 180         (string= value ""))
 181     (setq mh-identity-pgg-default-user-id nil))
 182    ((equal action 'add)
 183     (setq mh-identity-pgg-default-user-id value))))
 184
 185 ;;;###mh-autoload
 186 (defun mh-identity-handler-signature (field action &optional value)
 187   "Process header FIELD \":signature\".
 188 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 189 added."
 190   (cond
 191    ((equal action 'remove)
 192     (when (and (markerp mh-identity-signature-start)
 193                (markerp mh-identity-signature-end))
 194       (delete-region mh-identity-signature-start
 195                      mh-identity-signature-end)))
 196    (t
 197     ;; Insert "signature". Nil value means to use `mh-signature-file-name'.
 198     (when (not (mh-signature-separator-p)) ;...unless already present
 199       (goto-char (point-max))
 200       (save-restriction
 201         (narrow-to-region (point) (point))
 202         (if (null value)
 203             (mh-insert-signature)
 204           (mh-insert-signature value))
 205         (set (make-local-variable 'mh-identity-signature-start)
 206              (point-min-marker))
 207         (set-marker-insertion-type mh-identity-signature-start t)
 208         (set (make-local-variable 'mh-identity-signature-end)
 209              (point-max-marker)))))))
 210
 211 (defvar mh-identity-attribution-verb-start nil
 212   "Marker for the beginning of the attribution verb.")
 213 (defvar mh-identity-attribution-verb-end nil
 214   "Marker for the end of the attribution verb.")
 215
 216 ;;;###mh-autoload
 217 (defun mh-identity-handler-attribution-verb (field action &optional value)
 218   "Process header FIELD \":attribution-verb\".
 219 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 220 added."
 221   (when (and (markerp mh-identity-attribution-verb-start)
 222              (markerp mh-identity-attribution-verb-end))
 223     (delete-region mh-identity-attribution-verb-start
 224                    mh-identity-attribution-verb-end)
 225     (goto-char mh-identity-attribution-verb-start)
 226     (cond
 227      ((equal action 'remove)              ; Replace with default
 228       (mh-identity-insert-attribution-verb nil))
 229      (t                                   ; Insert attribution verb.
 230       (mh-identity-insert-attribution-verb value)))))
 231
 232 ;;;###mh-autoload
 233 (defun mh-identity-insert-attribution-verb (value)
 234   "Insert VALUE as attribution verb, setting up delimiting markers.
 235 If VALUE is nil, use `mh-extract-from-attribution-verb'."
 236   (save-restriction
 237     (narrow-to-region (point) (point))
 238     (if (null value)
 239         (insert mh-extract-from-attribution-verb)
 240       (insert value))
 241     (set (make-local-variable 'mh-identity-attribution-verb-start)
 242          (point-min-marker))
 243     (set-marker-insertion-type mh-identity-attribution-verb-start t)
 244     (set (make-local-variable 'mh-identity-attribution-verb-end)
 245          (point-max-marker))))
 246
 247 (defun mh-identity-handler-default (field action top &optional value)
 248   "Process header FIELD.
 249 The ACTION is one of 'remove or 'add. If TOP is non-nil, add the
 250 field and its VALUE at the top of the header, else add it at the
 251 bottom of the header. If action is 'add, the VALUE is added."
 252   (let ((field-colon (if (string-match "^.*:$" field)
 253                          field
 254                        (concat field ":"))))
 255     (cond
 256      ((equal action 'remove)
 257       (mh-header-field-delete field-colon nil))
 258      (t
 259       (cond
 260        ;; No value, remove field
 261        ((or (not value)
 262             (string= value ""))
 263         (mh-header-field-delete field-colon nil))
 264        ;; Existing field, replace
 265        ((mh-header-field-delete field-colon t)
 266         (insert value))
 267        ;; Other field, add at end or top
 268        (t
 269         (goto-char (point-min))
 270         (if (not top)
 271             (mh-goto-header-end 0))
 272         (insert field-colon " " value "\n")))))))
 273
 274 ;;;###mh-autoload
 275 (defun mh-identity-handler-top (field action &optional value)
 276   "Process header FIELD.
 277 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 278 added. If the field wasn't present, it is added to the top of the
 279 header."
 280   (mh-identity-handler-default field action t value))
 281
 282 ;;;###mh-autoload
 283 (defun mh-identity-handler-bottom (field action &optional value)
 284   "Process header FIELD.
 285 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 286 added. If the field wasn't present, it is added to the bottom of
 287 the header."
 288   (mh-identity-handler-default field action nil value))
 289
 290 (provide 'mh-identity)
 291
 292 ;; Local Variables:
 293 ;; indent-tabs-mode: nil
 294 ;; sentence-end-double-space: nil
 295 ;; End:
 296
 297 ;; arch-tag: 07d66ef6-8726-4ac6-9ecf-e566cd5bfb45
 298 ;;; mh-identity.el ends here