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