lisp/mh-e/mh-identity.el

   1 ;;; mh-identity.el --- multiple identify support for MH-E
   2
   3 ;; Copyright (C) 2002-2013 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 of the License, or
  15 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; Multiple identity support for MH-E.
  28
  29 ;; Used to easily set different fields such as From and Organization,
  30 ;; as well as different signature files.
  31
  32 ;; Customize the variable `mh-identity-list' and see the Identity menu
  33 ;; in MH-Letter mode. The command `mh-insert-identity' can be used
  34 ;; to manually insert an identity.
  35
  36 ;;; Change Log:
  37
  38 ;;; Code:
  39
  40 (require 'mh-e)
  41
  42 (autoload 'mml-insert-tag "mml")
  43
  44 (defvar mh-identity-pgg-default-user-id nil
  45   "Holds the GPG key ID to be used by pgg.el.
  46 This is normally set as part of an Identity in
  47 `mh-identity-list'.")
  48 (make-variable-buffer-local 'mh-identity-pgg-default-user-id)
  49
  50 (defvar mh-identity-menu nil
  51   "The Identity menu.")
  52
  53 (defalias 'mh-identity-make-menu-no-autoload 'mh-identity-make-menu)
  54
  55 ;;;###mh-autoload
  56 (defun mh-identity-make-menu ()
  57   "Build the Identity menu.
  58 This should be called any time `mh-identity-list' or
  59 `mh-auto-fields-list' change.
  60 See `mh-identity-add-menu'."
  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-add-menu ()
  92   "Add the current Identity menu.
  93 See `mh-identity-make-menu'."
  94   (if mh-identity-menu
  95       (easy-menu-add mh-identity-menu)))
  96
  97 (defvar mh-identity-local nil
  98   "Buffer-local variable that holds the identity currently in use.")
  99 (make-variable-buffer-local 'mh-identity-local)
 100
 101 (defun mh-header-field-delete (field value-only)
 102   "Delete header FIELD, or only its value if VALUE-ONLY is t.
 103 Return t if anything is deleted."
 104   (let ((field-colon (if (string-match "^.*:$" field)
 105                          field
 106                        (concat field ":"))))
 107     (when (mh-goto-header-field field-colon)
 108       (if (not value-only)
 109           (beginning-of-line)
 110         (forward-char))
 111       (delete-region (point)
 112                      (progn (mh-header-field-end)
 113                             (if (not value-only) (forward-char 1))
 114                             (point)))
 115       t)))
 116
 117 (defvar mh-identity-signature-start nil
 118   "Marker for the beginning of a signature inserted by `mh-insert-identity'.")
 119 (defvar mh-identity-signature-end nil
 120   "Marker for the end of a signature inserted by `mh-insert-identity'.")
 121
 122 (defun mh-identity-field-handler (field)
 123   "Return the handler for header FIELD or nil if none set.
 124 The field name is downcased. If the FIELD begins with the
 125 character \":\", then it must have a special handler defined in
 126 `mh-identity-handlers', else return an error since it is not a
 127 valid header field."
 128   (or (cdr (mh-assoc-string field mh-identity-handlers t))
 129       (and (eq (aref field 0) ?:)
 130            (error "Field %s not found in `mh-identity-handlers'" field))
 131       (cdr (assoc ":default" mh-identity-handlers))
 132       'mh-identity-handler-default))
 133
 134 ;;;###mh-autoload
 135 (defun mh-insert-identity (identity &optional maybe-insert)
 136   "Insert fields specified by given IDENTITY.
 137
 138 In a program, do not insert fields if MAYBE-INSERT is non-nil,
 139 `mh-identity-default' is non-nil, and fields have already been
 140 inserted.
 141
 142 See `mh-identity-list'."
 143   (interactive
 144    (list (completing-read
 145           "Identity: "
 146           (if mh-identity-local
 147               (cons '("None")
 148                     (mapcar 'list (mapcar 'car mh-identity-list)))
 149             (mapcar 'list (mapcar 'car mh-identity-list)))
 150           nil t)
 151          nil))
 152
 153   (when (or (not maybe-insert)
 154             (and (boundp 'mh-identity-default)
 155                  mh-identity-default
 156                  (not mh-identity-local)))
 157     (save-excursion
 158       ;;First remove old settings, if any.
 159       (when mh-identity-local
 160         (let ((pers-list (cadr (assoc mh-identity-local mh-identity-list))))
 161           (while pers-list
 162             (let* ((field (caar pers-list))
 163                    (handler (mh-identity-field-handler field)))
 164               (funcall handler field 'remove))
 165             (setq pers-list (cdr pers-list)))))
 166       ;; Then insert the replacement
 167       (when (not (equal "None" identity))
 168         (let ((pers-list (cadr (assoc identity mh-identity-list))))
 169           (while pers-list
 170             (let* ((field (caar pers-list))
 171                    (value (cdar pers-list))
 172                    (handler (mh-identity-field-handler field)))
 173               (funcall handler field 'add value))
 174             (setq pers-list (cdr pers-list))))))
 175     ;; Remember what is in use in this buffer
 176     (if (equal "None" identity)
 177         (setq mh-identity-local nil)
 178       (setq mh-identity-local identity))))
 179
 180 ;;;###mh-autoload
 181 (defun mh-identity-handler-gpg-identity (field action &optional value)
 182   "Process header FIELD \":pgg-default-user-id\".
 183 The ACTION is one of 'remove or 'add. If 'add, the VALUE is added.
 184 The buffer-local variable `mh-identity-pgg-default-user-id' is set to
 185 VALUE when action 'add is selected."
 186   (cond
 187    ((or (equal action 'remove)
 188         (not value)
 189         (string= value ""))
 190     (setq mh-identity-pgg-default-user-id nil))
 191    ((equal action 'add)
 192     (setq mh-identity-pgg-default-user-id value))))
 193
 194 ;;;###mh-autoload
 195 (defun mh-identity-handler-signature (field action &optional value)
 196   "Process header FIELD \":signature\".
 197 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 198 added."
 199   (cond
 200    ((equal action 'remove)
 201     (when (and (markerp mh-identity-signature-start)
 202                (markerp mh-identity-signature-end))
 203       (delete-region mh-identity-signature-start
 204                      mh-identity-signature-end)))
 205    (t
 206     ;; Insert "signature". Nil value means to use `mh-signature-file-name'.
 207     (when (not (mh-signature-separator-p)) ;...unless already present
 208       (goto-char (point-max))
 209       (save-restriction
 210         (narrow-to-region (point) (point))
 211         (if (null value)
 212             (mh-insert-signature)
 213           (mh-insert-signature value))
 214         (set (make-local-variable 'mh-identity-signature-start)
 215              (point-min-marker))
 216         (set-marker-insertion-type mh-identity-signature-start t)
 217         (set (make-local-variable 'mh-identity-signature-end)
 218              (point-max-marker)))))))
 219
 220 (defvar mh-identity-attribution-verb-start nil
 221   "Marker for the beginning of the attribution verb.")
 222 (defvar mh-identity-attribution-verb-end nil
 223   "Marker for the end of the attribution verb.")
 224
 225 ;;;###mh-autoload
 226 (defun mh-identity-handler-attribution-verb (field action &optional value)
 227   "Process header FIELD \":attribution-verb\".
 228 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 229 added."
 230   (when (and (markerp mh-identity-attribution-verb-start)
 231              (markerp mh-identity-attribution-verb-end))
 232     (delete-region mh-identity-attribution-verb-start
 233                    mh-identity-attribution-verb-end)
 234     (goto-char mh-identity-attribution-verb-start)
 235     (cond
 236      ((equal action 'remove)              ; Replace with default
 237       (mh-identity-insert-attribution-verb nil))
 238      (t                                   ; Insert attribution verb.
 239       (mh-identity-insert-attribution-verb value)))))
 240
 241 ;;;###mh-autoload
 242 (defun mh-identity-insert-attribution-verb (value)
 243   "Insert VALUE as attribution verb, setting up delimiting markers.
 244 If VALUE is nil, use `mh-extract-from-attribution-verb'."
 245   (save-restriction
 246     (narrow-to-region (point) (point))
 247     (if (null value)
 248         (insert mh-extract-from-attribution-verb)
 249       (insert value))
 250     (set (make-local-variable 'mh-identity-attribution-verb-start)
 251          (point-min-marker))
 252     (set-marker-insertion-type mh-identity-attribution-verb-start t)
 253     (set (make-local-variable 'mh-identity-attribution-verb-end)
 254          (point-max-marker))))
 255
 256 (defun mh-identity-handler-default (field action top &optional value)
 257   "Process header FIELD.
 258 The ACTION is one of 'remove or 'add. If TOP is non-nil, add the
 259 field and its VALUE at the top of the header, else add it at the
 260 bottom of the header. If action is 'add, the VALUE is added."
 261   (let ((field-colon (if (string-match "^.*:$" field)
 262                          field
 263                        (concat field ":"))))
 264     (cond
 265      ((equal action 'remove)
 266       (mh-header-field-delete field-colon nil))
 267      (t
 268       (cond
 269        ;; No value, remove field
 270        ((or (not value)
 271             (string= value ""))
 272         (mh-header-field-delete field-colon nil))
 273        ;; Existing field, replace
 274        ((mh-header-field-delete field-colon t)
 275         (insert value))
 276        ;; Other field, add at end or top
 277        (t
 278         (goto-char (point-min))
 279         (if (not top)
 280             (mh-goto-header-end 0))
 281         (insert field-colon " " value "\n")))))))
 282
 283 ;;;###mh-autoload
 284 (defun mh-identity-handler-top (field action &optional value)
 285   "Process header FIELD.
 286 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 287 added. If the field wasn't present, it is added to the top of the
 288 header."
 289   (mh-identity-handler-default field action t value))
 290
 291 ;;;###mh-autoload
 292 (defun mh-identity-handler-bottom (field action &optional value)
 293   "Process header FIELD.
 294 The ACTION is one of 'remove or 'add. If 'add, the VALUE is
 295 added. If the field wasn't present, it is added to the bottom of
 296 the header."
 297   (mh-identity-handler-default field action nil value))
 298
 299 (provide 'mh-identity)
 300
 301 ;; Local Variables:
 302 ;; indent-tabs-mode: nil
 303 ;; sentence-end-double-space: nil
 304 ;; End:
 305
 306 ;;; mh-identity.el ends here