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, 2007 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 3, 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,
  32 ;; as well as different signature files.
  33
  34 ;; Customize the variable `mh-identity-list' and see the Identity menu
  35 ;; in MH-Letter mode. The command `mh-insert-identity' can be used
  36 ;; to manually insert an identity.
  37
  38 ;;; Change Log:
  39
  40 ;;; Code:
  41
  42 (require 'mh-e)
  43
  44 (autoload 'mml-insert-tag "mml")
  45
  46 (defvar mh-identity-pgg-default-user-id nil
  47   "Holds the GPG key ID to be used by pgg.el.
  48 This is normally set as part of an Identity in
  49 `mh-identity-list'.")
  50 (make-variable-buffer-local 'mh-identity-pgg-default-user-id)
  51
  52 (defvar mh-identity-menu nil
  53   "The Identity menu.")
  54
  55 (defalias 'mh-identity-make-menu-no-autoload 'mh-identity-make-menu)
  56
  57 ;;;###mh-autoload
  58 (defun mh-identity-make-menu ()
  59   "Build the Identity menu.
  60 This should be called any time `mh-identity-list' or
  61 `mh-auto-fields-list' change.
  62 See `mh-identity-add-menu'."
  63   (easy-menu-define mh-identity-menu mh-letter-mode-map
  64     "MH-E identity menu"
  65     (append
  66      '("Identity")
  67      ;; Dynamically render :type corresponding to `mh-identity-list'
  68      ;; e.g.:
  69      ;;  ["Home" (mh-insert-identity "Home")
  70      ;;   :style radio :active (not (equal mh-identity-local "Home"))
  71      ;;   :selected (equal mh-identity-local "Home")]
  72      '(["Insert Auto Fields"
  73         (mh-insert-auto-fields) mh-auto-fields-list]
  74        "--")
  75
  76      (mapcar (function
  77               (lambda (arg)
  78                 `[,arg  (mh-insert-identity ,arg) :style radio
  79                         :selected (equal mh-identity-local ,arg)]))
  80              (mapcar 'car mh-identity-list))
  81      '(["None"
  82         (mh-insert-identity "None") :style radio
  83         :selected (not mh-identity-local)]
  84        "--"
  85        ["Set Default for Session"
  86         (setq mh-identity-default mh-identity-local) t]
  87        ["Save as Default"
  88         (customize-save-variable 'mh-identity-default mh-identity-local) t]
  89        ["Customize Identities" (customize-variable 'mh-identity-list) t]
  90        ))))
  91
  92 ;;;###mh-autoload
  93 (defun mh-identity-add-menu ()
  94   "Add the current Identity menu.
  95 See `mh-identity-make-menu'."
  96   (if mh-identity-menu
  97       (easy-menu-add mh-identity-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 (mh-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 &optional maybe-insert)
 138   "Insert fields specified by given IDENTITY.
 139
 140 In a program, do not insert fields if MAYBE-INSERT is non-nil,
 141 `mh-identity-default' is non-nil, and fields have already been
 142 inserted.
 143
 144 See `mh-identity-list'."
 145   (interactive
 146    (list (completing-read
 147           "Identity: "
 148           (if mh-identity-local
 149               (cons '("None")
 150                     (mapcar 'list (mapcar 'car mh-identity-list)))
 151             (mapcar 'list (mapcar 'car mh-identity-list)))
 152           nil t)
 153          nil))
 154
 155   (when (or (not maybe-insert)
 156             (and (boundp 'mh-identity-default)
 157                  mh-identity-default
 158                  (not mh-identity-local)))
 159     (save-excursion
 160       ;;First remove old settings, if any.
 161       (when mh-identity-local
 162         (let ((pers-list (cadr (assoc mh-identity-local mh-identity-list))))
 163           (while pers-list
 164             (let* ((field (caar pers-list))
 165                    (handler (mh-identity-field-handler field)))
 166               (funcall handler field 'remove))
 167             (setq pers-list (cdr pers-list)))))
 168       ;; Then insert the replacement
 169       (when (not (equal "None" identity))
 170         (let ((pers-list (cadr (assoc identity mh-identity-list))))
 171           (while pers-list
 172             (let* ((field (caar pers-list))
 173                    (value (cdar pers-list))
 174                    (handler (mh-identity-field-handler field)))
 175               (funcall handler field 'add value))
 176             (setq pers-list (cdr pers-list))))))
 177     ;; Remember what is in use in this buffer
 178     (if (equal "None" identity)
 179         (setq mh-identity-local nil)
 180       (setq mh-identity-local identity))))
 181
 182 ;;;###mh-autoload
 183 (defun mh-identity-handler-gpg-identity (field action &optional value)
 184   "Process header FIELD \":pgg-default-user-id\".
 185 The ACTION is one of 'remove or 'add. If 'add, the VALUE is added.
 186 The buffer-local variable `mh-identity-pgg-default-user-id' is set to
 187 VALUE when action 'add is selected."
 188   (cond
 189    ((or (equal action 'remove)
 190         (not value)
 191         (string= value ""))
 192     (setq mh-identity-pgg-default-user-id nil))
 193    ((equal action 'add)
 194     (setq mh-identity-pgg-default-user-id value))))
 195
 196 ;;;###mh-autoload
 197 (defun mh-identity-handler-signature (field action &optional value)
 198   "Process header FIELD \":signature\".
 199 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 200 added."
 201   (cond
 202    ((equal action 'remove)
 203     (when (and (markerp mh-identity-signature-start)
 204                (markerp mh-identity-signature-end))
 205       (delete-region mh-identity-signature-start
 206                      mh-identity-signature-end)))
 207    (t
 208     ;; Insert "signature". Nil value means to use `mh-signature-file-name'.
 209     (when (not (mh-signature-separator-p)) ;...unless already present
 210       (goto-char (point-max))
 211       (save-restriction
 212         (narrow-to-region (point) (point))
 213         (if (null value)
 214             (mh-insert-signature)
 215           (mh-insert-signature value))
 216         (set (make-local-variable 'mh-identity-signature-start)
 217              (point-min-marker))
 218         (set-marker-insertion-type mh-identity-signature-start t)
 219         (set (make-local-variable 'mh-identity-signature-end)
 220              (point-max-marker)))))))
 221
 222 (defvar mh-identity-attribution-verb-start nil
 223   "Marker for the beginning of the attribution verb.")
 224 (defvar mh-identity-attribution-verb-end nil
 225   "Marker for the end of the attribution verb.")
 226
 227 ;;;###mh-autoload
 228 (defun mh-identity-handler-attribution-verb (field action &optional value)
 229   "Process header FIELD \":attribution-verb\".
 230 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 231 added."
 232   (when (and (markerp mh-identity-attribution-verb-start)
 233              (markerp mh-identity-attribution-verb-end))
 234     (delete-region mh-identity-attribution-verb-start
 235                    mh-identity-attribution-verb-end)
 236     (goto-char mh-identity-attribution-verb-start)
 237     (cond
 238      ((equal action 'remove)              ; Replace with default
 239       (mh-identity-insert-attribution-verb nil))
 240      (t                                   ; Insert attribution verb.
 241       (mh-identity-insert-attribution-verb value)))))
 242
 243 ;;;###mh-autoload
 244 (defun mh-identity-insert-attribution-verb (value)
 245   "Insert VALUE as attribution verb, setting up delimiting markers.
 246 If VALUE is nil, use `mh-extract-from-attribution-verb'."
 247   (save-restriction
 248     (narrow-to-region (point) (point))
 249     (if (null value)
 250         (insert mh-extract-from-attribution-verb)
 251       (insert value))
 252     (set (make-local-variable 'mh-identity-attribution-verb-start)
 253          (point-min-marker))
 254     (set-marker-insertion-type mh-identity-attribution-verb-start t)
 255     (set (make-local-variable 'mh-identity-attribution-verb-end)
 256          (point-max-marker))))
 257
 258 (defun mh-identity-handler-default (field action top &optional value)
 259   "Process header FIELD.
 260 The ACTION is one of 'remove or 'add. If TOP is non-nil, add the
 261 field and its VALUE at the top of the header, else add it at the
 262 bottom of the header. If action is 'add, the VALUE is added."
 263   (let ((field-colon (if (string-match "^.*:$" field)
 264                          field
 265                        (concat field ":"))))
 266     (cond
 267      ((equal action 'remove)
 268       (mh-header-field-delete field-colon nil))
 269      (t
 270       (cond
 271        ;; No value, remove field
 272        ((or (not value)
 273             (string= value ""))
 274         (mh-header-field-delete field-colon nil))
 275        ;; Existing field, replace
 276        ((mh-header-field-delete field-colon t)
 277         (insert value))
 278        ;; Other field, add at end or top
 279        (t
 280         (goto-char (point-min))
 281         (if (not top)
 282             (mh-goto-header-end 0))
 283         (insert field-colon " " value "\n")))))))
 284
 285 ;;;###mh-autoload
 286 (defun mh-identity-handler-top (field action &optional value)
 287   "Process header FIELD.
 288 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 289 added. If the field wasn't present, it is added to the top of the
 290 header."
 291   (mh-identity-handler-default field action t value))
 292
 293 ;;;###mh-autoload
 294 (defun mh-identity-handler-bottom (field action &optional value)
 295   "Process header FIELD.
 296 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 297 added. If the field wasn't present, it is added to the bottom of
 298 the header."
 299   (mh-identity-handler-default field action nil value))
 300
 301 (provide 'mh-identity)
 302
 303 ;; Local Variables:
 304 ;; indent-tabs-mode: nil
 305 ;; sentence-end-double-space: nil
 306 ;; End:
 307
 308 ;; arch-tag: 07d66ef6-8726-4ac6-9ecf-e566cd5bfb45
 309 ;;; mh-identity.el ends here