Download
(eval-when-compile
(defvar byte-compile-dynamic)
(set (make-local-variable 'byte-compile-dynamic) t)
(require 'message)
(defvar message-reply-buffer)
(defvar message-signature-separator)
(defvar message-mode-map)
)
(defgroup gnus-alias nil
"Alternate identity mechanism for Gnus."
:group 'message)
(defun gnus-alias-customize ()
"Customization of the group 'gnus-alias'."
(interactive)
(customize-group "gnus-alias"))
(defcustom gnus-alias-identity-alist ()
"Association list of Identities.
Each Identity in the alist has an Alias as its key. The Identity
itself is composed of one or more of the following elements:
o Refers to - allows one Identity to refer to another for part of
its definition. The reference Identity is applied first, and then
the current Identity is overlaid on top of the first one.
o From - sets the 'From' header, designating who the mail or post is
from. It must be a valid format; examples:
- emacs@northbound-train.com
- \"Joe Casadonte\" <emacs@northbound-train.com>
o Organization - sets the 'Organization' header (a common, optional
header). Note: this may be overridden by your ISP.
o Extra headers - a list of arbitrary headers to set (e.g. X-Archive:
no). This can be used to setup any header you'd like)
o Body - adds text to the body of the message (just above the signature)
o Signature - adds a signature to the message
The value for each element can be a string (which will be used as-is),
a function that is expected to return a string, or a variable (also a
string). In addition, 'Body' & 'Signature' can also be the name of a
file, the contents of which will be used (you guessed it, as a string)."
:type '(repeat
(cons :tag "Identity"
(string :tag "Alias")
(list :tag "Dossier - please fill in one or more of the following"
(choice :tag "-Refers to" (string) (function) (variable))
(choice :tag "-From" (string :tag "String (e.g. \"First Last\" <email@address.com>)") (function) (variable))
(choice :tag "-Organization" (string) (function) (variable))
(repeat :tag "-Extra Headers"
(cons
(choice :tag "Header (no ':')" (string) (function) (variable))
(choice :tag "Value" (string) (function) (variable))))
(choice :tag "-Body" (string) (function) (variable) (file))
(choice :tag "-Signature" (string) (function) (variable) (file))
)))
:group 'gnus-alias)
(defcustom gnus-alias-default-identity ""
"Identity to use if none is chosen via `gnus-alias-identity-rules'.
Set this to the Alias of one of your defined Identities."
:type 'string
:group 'gnus-alias)
(defcustom gnus-alias-overlay-identities nil
"Overlays one Identity on top of another (instead of replacing it).
If non-nil, the old Identity is not removed when applying a new
Identity. This allows for a manual `gnus-posting-styles' effect of
building up an Identity in layers. So, if the old Identity had an
Organization defined but the new one did not, overlaying the old one
with the new one will result in the message having an Organization
defined.
If nil, the old Identity is completely removed before the new one is
added. So in the previous example, overlaying the old Identity with
the new one will result in the message NOT having an Organization
defined."
:type 'boolean
:group 'gnus-alias)
(defcustom gnus-alias-identity-rules nil
"Rules used to choose Identity whenever a new message is created.
The rules are evaluated to determine which Identity to use when
creating a new message (new email or article, a reply to an email or
article or follow-up to an article or a forwarded email or article).
Rules are individually evaluated by `gnus-alias-determine-identity' in
the order that they are defined in, until one of them results in an
Identity being chosen. If this results in an invalid Identity being
chosen, what happens next is determined by
`gnus-alias-unknown-identity-rule' \(which see). If no valid Identites
are found,`gnus-alias-default-identity' is used instead.
Each rule has a NAME/DESCRIPTION, which is used mainly as
documentation for yourself, and is referenced when debugging is turned
on. Then, one of two RULE METHODs are used:
o Header Match - matches a REGEXP (regular expression) to the value in
the header field identified by HEADER SYMBOL (which is either a key
into a list of headers defined by `gnus-alias-lookup-abbrev-alist',
or the name of an actual header). When replying to an email or
following up to a post, both the original set of headers and the new
message's headers are available to be matched against (with a new
message, only the current set is available). HEADER SET determines
which set of headers are matched against. Options are: current,
previous or both (previous, and if that's empty, current).
o Function - this method is simply a function that returns either nil
or non-nil. Non-nil indicates that a match of whatever kind was
achieved, and the specified Identity should be used. This function
can literally be anything you want from Message's `message-news-p'
to a custom function (e.g. `my-identity-fn').
If the regexp matches or the function returns non-nil, the Identity
specified by IDENTITY is validated. This can either be a key from
`gnus-alias-identity-alist' or a substitution scheme that results in
such a key (Header Match only). Substitution is done just like in
normal regular expression processing, using \\\\D (where D is a number
corresponding to a sub-expression from the last match).
For example, given the following rule:
NAME: Domain Match
RULE METHOD: Header Match
HEADER SYMBOL: to
REGEXP: <\\\\(.+\\\\)@northbound-train.com
HEADER SET: both
IDENTITY: nt-\\\\1
Matching on \"CC: <emacs@northbound-train.com>\" would result in
the \"nt-emacs\" Identity being used.
See the Regular Expressions info node for more details on regexp
patterns and substitution:
M-: (Info-goto-node \"(emacs)regexps\") RET"
:type '(repeat
(list :format "%v"
(string :tag "Name/Description")
(choice :tag "Rule Method"
(list :tag "Header Match"
(string :tag "Header Symbol")
(regexp :tag "Regexp")
(choice :tag "Header set"
(const :tag "Current Headers only" current)
(const :tag "Previous Headers only" previous)
(const :tag "Previous Headers, then Current" both)))
(function :tag "Function"))
(string :tag "Identity")
))
:group 'gnus-alias)
(defcustom gnus-alias-unknown-identity-rule 'continue
"Tells 'gnus-alias' what to do when it finds an unknown Identity.
If during the course of determining an Identity via
`gnus-alias-identity-rules' an Identity is chosen that
does not appear in `gnus-alias-identity-alist', this variable
determines what happens next. Possible choices are:
o error - generate an error and stop all processing
o continue - ignore it and continue on, checking the next Identity rule
o default - use the default Identity
o identity - specify an Identity to use
o function - call specified function with the unknown Identity,
which should return a valid Identity
Regardless, logging occurs if debugging is on."
:type '(choice :tag "Method"
(const :tag "Error" error)
(const :tag "Continue" continue)
(const :tag "Default" default)
(string :tag "Identity")
(function :tag "Function" ))
:group 'gnus-alias)
(defvar gnus-alias-lookup-abbrev-cache (list)
"Caches resolution of abbrev alist (is cleared when alist is reset).")
(defcustom gnus-alias-lookup-abbrev-alist '(("mail" "mailer-daemon postmaster uucp")
("to" "to cc apparently-to resent-to resent-cc")
("from" "from sender resent-from")
("any" "[from] [to]")
("newsgroup" "newsgroups")
("ngroupto" "[to] [newsgroup]"))
"Alist of abbreviations allowed in `gnus-alias-identity-rules'.
SYMBOL is any mnemonic or abbreviation that makes sense for you.
HEADER LIST is a space-separated list of headers that will be used in
determining which Identity the new message should use. You can refer
to a previously defined header list by putting its mnemonic in
square brackets in the new header list; see 'ngroupto' as an example.
This variable must be set/reset via Custom in order for changes to
take place without re-starting Emacs."
:type '(repeat
(list :format "%v"
(string :tag "Symbol")
(string :tag "Header list")))
:set (lambda (sym val)
(set-default sym val)
(setq gnus-alias-lookup-abbrev-cache (list)))
:group 'gnus-alias)
(defcustom gnus-alias-extra-header-pos-alist ' (("Gcc" "Bcc Fcc In-Reply-To Subject")
("Bcc" "Fcc In-Reply-To Subject")
("Fcc" "In-Reply-To Subject")
("Organization" "Date Gcc Bcc Fcc In-Reply-To Subject"))
"Association list of Extra Header positions.
For the truly anal who want their headers in a prescribed order. The
alist key is a Header and the value is a space-separated list of
headers that will be passed to `message-position-on-field' in order to
place the header/key properly.
\[Note: as far as I know, this is useful only to make the display look
the way you'd like it to. I don't know of an RFC mandating the
positions of the headers that would normally be set via the Extra
Headers mechanism. If there is such a creature, please let me know.]"
:type '(repeat
(list :format "%v"
(string :tag "Header (no ':')")
(string :tag "Position(s)")))
:group 'gnus-alias)
(defadvice message-forward (around message-forward-with-reply-buffer)
"Set `gnus-alias-reply-buffer' to message being forwarded."
(let ((gnus-alias-reply-buffer (current-buffer)))
ad-do-it))
(defcustom gnus-alias-allow-forward-as-reply nil
"Allows access to original headers of a forwarded message.
Normally, when `message-forward' is called, no reply buffer is set up,
and consequently the previous headers can not be used to determine the
Identity of the forwarded message. By setting this option to a
non-nil value, a piece of advice is enabled that allows access to the
headers of the forwarded message as if it were a message being replied
to.
This variable must be set/reset via Custom in order for changes to
take place without re-starting Emacs."
:type 'boolean
:set (lambda (sym val)
(set-default sym val)
(if val
(ad-enable-advice 'message-forward
'around 'message-forward-with-reply-buffer)
(ad-disable-advice 'message-forward
'around 'message-forward-with-reply-buffer))
(ad-activate 'message-forward))
:group 'gnus-alias)
(defadvice message-send-and-exit (around message-send-and-exit-special-user-mail-address)
"Temporarily change the value of `user-mail-address' (maybe)."
(let ((user-mail-address
(save-restriction
(message-narrow-to-headers)
(message-fetch-field "From" t))))
ad-do-it))
(defcustom gnus-alias-override-user-mail-address nil
"Allow your Return-Path to be set properly.
Normally, even though you can successfully change your identity with
gnus-alias, not all headers are changed. Return-Path: is typically set
from the value of `user-mail-address'. Setting this variable to a
non-nil value will activate some defadvice for
`message-send-and-exit', essentially giving `user-mail-address' a
temporary value equal to your From: address.
Note: some mail servers will not allow this; there's nothing that can
be done about that except to contact the SysAdmin (good luck!)."
:type 'boolean
:set (lambda (sym val)
(set-default sym val)
(if val
(ad-enable-advice 'message-send-and-exit
'around 'message-send-and-exit-special-user-mail-address)
(ad-disable-advice 'message-send-and-exit
'around 'message-send-and-exit-special-user-mail-address))
(ad-activate 'message-send-and-exit))
:group 'gnus-alias)
(defcustom gnus-alias-point-position 'empty-header-or-body
"After an Identity is used, where should point be moved to?
After a call to `gnus-alias-use-identity', where should point be left?
Choices are:
o empty-header-or-body - leave point on first empty header, or
start of body if there are no empty headers
o empty-header-or-sig - leave point on first empty header, or
start of signature if there are no empty headers
o start-of-body - leave point at the start of body
o start-of-sig - leave point at the start of signature, or the ned
of body if there is no signature"
:type '(choice
(const :tag "First Empty Header or Start of Body" empty-header-or-body)
(const :tag "First Empty Header or Start of Signature" empty-header-or-sig)
(const :tag "Start of Body" start-of-body)
(const :tag "Start of Signature" start-of-sig))
:group 'gnus-alias)
(defcustom gnus-alias-add-identity-menu t
"Controls whether or not an Identity menu is added to Message mode.
If non-nil, an Identity menu is added to Message mode, from which you
can choose which Identity to use. If nil, no menu is added.
This variable must be set/reset via Custom in order for changes to
take place without re-starting Emacs."
:type '(boolean)
:set (lambda (sym val)
(set-default sym val)
(if gnus-alias-add-identity-menu
(add-hook 'message-mode-hook 'gnus-alias-create-identity-menu)
(remove-hook 'message-mode-hook 'gnus-alias-create-identity-menu)))
:group 'gnus-alias)
(defcustom gnus-alias-use-buttonized-from t
"Controls whether or not the 'From' header is buttonized.
If non-nil, the 'From' header becomes a button that you can click on
to bring up an Identity menu to select from. If nil, then it's not."
:type 'boolean
:group 'gnus-alias)
(defcustom gnus-alias-verbosity 0
"Level of verbosity -- 0 is least, 9 is most.
0 = no output
1 = message output only
2-9 = ever-increasing amounts of debug output
See also `gnus-alias-debug-buffer-name'."
:type 'integer
:group 'gnus-alias)
(defcustom gnus-alias-debug-buffer-name "*gnus-alias debug*"
"Name of debug buffer (see `gnus-alias-verbosity')."
:type 'string
:group 'gnus-alias)
(defcustom gnus-alias-load-hook nil
"Hook run when 'gnus-alias' is first loaded."
:type 'hook
:group 'gnus-alias)
(defconst gnus-alias-version
"$Revision: 1.4 $"
"Version number for 'gnus-alias' package.")
(defun gnus-alias-version-number ()
"Return 'gnus-alias' version number."
(let ((version))
(save-match-data
(string-match "[0123456789.]+" gnus-alias-version)
(setq version (match-string 0 gnus-alias-version)))
version))
(defun gnus-alias-version ()
"Display 'gnus-alias' version."
(interactive)
(message "gnus-alias version <%s>." (gnus-alias-version-number)))
(defvar gnus-alias-current-identity nil
"[INTERNAL] The last Identity used.
This is needed to clean up the message when switching Identities.")
(make-variable-buffer-local 'gnus-alias-current-identity)
(defvar gnus-alias-reply-buffer nil
"[INTERNAL] Used to make forward act like reply.
If for some reason you want to set this variable, please do so in a
`let' form, so that its value is cleared when you're done doing whatever
it is you're doing. Also, NEVER make this variable buffer-local via
`make-variable-buffer-local'; it will no longer work as desired.")
(defun gnus-alias-init ()
"Add gnus-alias call to message mode hook."
(interactive)
(add-hook 'message-setup-hook 'gnus-alias-determine-identity))
(defun gnus-alias-select-identity ()
"Prompt user for an identity and use it."
(interactive)
(gnus-alias-use-identity (gnus-alias-identity-prompt)))
(defun gnus-alias-use-identity (&optional identity)
"Use an Identity defined in `gnus-alias-identity-alist'.
IDENTITY must be a valid entry in `gnus-alias-identity-alist',
otherwise an error will occur (NOTE: this behavior has changed
significantly from that found in 'gnus-pers').
If called interactively with no identity, user will be prompted for
one."
(interactive)
(gnus-alias-ensure-message-mode)
(when (and (not identity) (interactive-p))
(setq identity (gnus-alias-identity-prompt)))
(gnus-alias-use-identity-1 identity)
(cond
((equal gnus-alias-point-position 'empty-header-or-body)
(gnus-alias-goto-first-empty-header t))
((equal gnus-alias-point-position 'empty-header-or-sig)
(gnus-alias-goto-first-empty-header nil))
((equal gnus-alias-point-position 'start-of-sig)
(gnus-alias-goto-sig))
(t (message-goto-body))
))
(defun gnus-alias-ensure-message-mode ()
"Assert that the current buffer is a message buffer."
(when (not (eq major-mode 'message-mode))
(gnus-alias-error "Must be in `message-mode'.? ")))
(defun gnus-alias-determine-identity (&optional lookup-only)
"Function that chooses a Identity based on message headers.
See `gnus-alias-identity-rules' for more information. Optional
LOOKUP-ONLY is a boolean that, when non-nil, says to determine the
Identity, but don't actually use it (just return it)"
(let ((rules-list gnus-alias-identity-rules)
(message-reply-buffer (or gnus-alias-reply-buffer
message-reply-buffer))
current-choice first-elem class regexp which-headers
header header-list header-value potential-identity identity
rule-name)
(gnus-alias-dump-headers "[GADI] ")
(while (and (not identity) rules-list)
(setq current-choice (car rules-list))
(setq rule-name (car current-choice))
(setq current-choice (cdr current-choice))
(gnus-alias-debug 2 "[GADI] Evaluating <%s>\n" rule-name)
(setq first-elem (car current-choice))
(cond
((listp first-elem)
(setq class (nth 0 first-elem)
regexp (nth 1 first-elem)
which-headers (nth 2 first-elem))
(setq header-list (gnus-alias-resolve-alist-abbrev class))
(when (not header-list)
(setq header-list (list class)))
(while (and (not identity) header-list)
(setq header (car header-list))
(cond
((equal which-headers 'previous)
(setq header-value (message-fetch-reply-field header)))
((equal which-headers 'both)
(setq header-value (message-fetch-reply-field header))
(when (not header-value)
(setq header-value (message-fetch-field header))))
(t (setq header-value (message-fetch-field header)))
)
(save-match-data
(when (and header-value
(string-match regexp header-value))
(setq potential-identity (cadr current-choice))
(let ((orig-match-data (match-data))
potential-match-data match-num newtext)
(while (string-match "\\\\\\([0-9]\\)" potential-identity)
(setq potential-match-data (match-data))
(setq match-num (string-to-number (match-string 1 potential-identity)))
(set-match-data orig-match-data)
(setq newtext (match-string match-num header-value))
(set-match-data potential-match-data)
(setq potential-identity
(replace-match newtext nil nil
potential-identity))
))
(setq identity potential-identity)
))
(setq header-list (cdr header-list))
))
((functionp first-elem)
(when (funcall first-elem)
(setq identity (cadr current-choice))
))
(t))
(when (and identity
(not (assoc-string
identity gnus-alias-identity-alist t)))
(gnus-alias-debug 2 "[GADI] Unknown Identity found:\n")
(gnus-alias-debug 2 " Rule: <%s>\n" rule-name)
(gnus-alias-debug 2 " Identity: <%s>\n" identity)
(gnus-alias-debug 2 " Action: <%s>\n"
(if (symbolp gnus-alias-unknown-identity-rule)
(symbol-name gnus-alias-unknown-identity-rule)
gnus-alias-unknown-identity-rule))
(cond
((equal gnus-alias-unknown-identity-rule 'error)
(gnus-alias-error "Unknown Identity: <%s>" identity))
((equal gnus-alias-unknown-identity-rule 'default)
(setq identity gnus-alias-default-identity))
((stringp gnus-alias-unknown-identity-rule)
(setq identity gnus-alias-unknown-identity-rule))
((functionp gnus-alias-unknown-identity-rule)
(setq identity (funcall gnus-alias-unknown-identity-rule
identity)))
(t (setq identity nil))
))
(setq rules-list (cdr rules-list))
)
(when (and (not identity) gnus-alias-default-identity)
(setq identity gnus-alias-default-identity))
(unless (or lookup-only (not identity))
(gnus-alias-debug 1 "Using the <%s> Identity" identity)
(gnus-alias-use-identity identity))
identity))
(defun gnus-alias-message-x-completion (which-header)
"Can be used to select identifies in new mail after tab-completion.
WHICH-HEADER should be set to the header that completion was just
performed on.
When tab-completion is performed in the To: header, a new identity
will be selected according to the rules set up in
`gnus-alias-identity-alist' (which see).
This particular function expects an argument, and as such should only
be used with the `message-x-after-completion-functions'hook:
(add-hook 'message-x-after-completion-functions
'gnus-alias-message-x-completion)
This should be place in the `message-load-hook' (see gnus-alias file
for details). If such an argument is not needed in the current
context, `gnus-alias-determine-identity' may be used directly in a hook."
(when (string= which-header "to")
(gnus-alias-determine-identity)))
(defun gnus-alias-resolve-alist-abbrev (abbreviation &optional seen)
"Return a list of headers from `gnus-alias-lookup-abbrev-alist'.
ABBREVIATION is used as a key into `gnus-alias-lookup-abbrev-alist'.
Function returns a list of strings of the headers in the alist, or nil
if ABBREVIATION is not in the alist.
SEEN is a variable used in recursive calls to this function, and
should not be set by an external caller."
(let ((rv (assoc-string abbreviation gnus-alias-lookup-abbrev-cache t))
(first-in (not seen))
header-list lookup elem match recurse)
(when (not rv)
(setq rv (list))
(setq lookup (assoc-string abbreviation gnus-alias-lookup-abbrev-alist t))
(when lookup
(setq header-list (split-string (cadr lookup))))
(when (not seen)
(setq seen (list (cons (concat "[" abbreviation "]") t))))
(while header-list
(setq elem (car header-list))
(save-match-data
(if (string-match "^\\[\\(.+\\)\\]$" elem)
(when (not (assoc elem seen))
(setq seen (append (list (cons elem t)) seen))
(setq recurse
(gnus-alias-resolve-alist-abbrev (match-string 1 elem) seen))
(setq rv (nconc rv (car recurse)))
(setq seen (cdr recurse)))
(setq rv (nconc rv (list elem)))))
(setq header-list (cdr header-list)))
)
(if first-in rv (cons rv seen))
))
(defun gnus-alias-identity-prompt ()
"Prompt user for an identity."
(gnus-alias-ensure-message-mode)
(let ((completion-ignore-case t)
rv)
(setq rv (car
(assoc-string
(completing-read "Identity: " gnus-alias-identity-alist nil t)
gnus-alias-identity-alist t)))
rv))
(defsubst gnus-alias-get-something (ID N)
"Return the Nth something from ID."
(let ((rv (nth N ID)))
(if (and (stringp rv) (= (length rv) 0)) nil rv)))
(defun gnus-alias-get-reference (ID)
"Return the FROM portion of ID."
(gnus-alias-get-something ID 1))
(defun gnus-alias-get-from (ID)
"Return the FROM portion of ID."
(gnus-alias-get-something ID 2))
(defun gnus-alias-get-org (ID)
"Return the ORGANIZATION portion of ID."
(gnus-alias-get-something ID 3))
(defun gnus-alias-get-extras (ID)
"Return the EXTRA HEADERS portion of ID."
(gnus-alias-get-something ID 4))
(defun gnus-alias-get-body (ID)
"Return the BODY portion of ID."
(gnus-alias-get-something ID 5))
(defun gnus-alias-get-sig (ID)
"Return the SIGNATURE portion of ID."
(gnus-alias-get-something ID 6))
(defun gnus-alias-position-on-field (header)
"Lookup afters value for HEADER and call `message-position-on-field'.
If HEADER is in `gnus-alias-extra-header-pos-alist', look up its value
and pass into `message-position-on-field' as the value for AFTERS. If
it's not, simply position the field at the end of the header list (not
the beginning as is normal)."
(let ((afters (car-safe
(cdr-safe
(assoc-string header gnus-alias-extra-header-pos-alist t)
))))
(setq afters
(if afters
(split-string afters)
(message-goto-eoh)
(forward-line -1)
(save-match-data
(re-search-forward "^\\(.+\\):")
(list (match-string-no-properties 1)))
))
(apply 'message-position-on-field header afters)))
(defun gnus-alias-use-identity-1 (identity &optional suppress-error)
"Use an Identity defined in `gnus-alias-identity-alist'.
IDENTITY must be a valid entry in `gnus-alias-identity-alist',
otherwise an error will occur (NOTE: this behavior has changed
significantly from that found in 'gnus-pers').
SUPPRESS-ERROR will cause the function to silently fail under the
above circumstances rather then generate an error."
(let ((ID (assoc-string identity gnus-alias-identity-alist t))
reference from org extras body sig extras-list current-extra
extra-hdr extra-val afters)
(if (not ID)
(when (not suppress-error)
(gnus-alias-error "Unknown Identity: <%s>" identity))
(unless gnus-alias-overlay-identities
(gnus-alias-remove-identity gnus-alias-current-identity)
(setq gnus-alias-current-identity nil))
(setq reference (gnus-alias-get-reference ID)
from (gnus-alias-get-from ID)
org (gnus-alias-get-org ID)
extras (gnus-alias-get-extras ID)
body (gnus-alias-get-body ID)
sig (gnus-alias-get-sig ID))
(when reference
(gnus-alias-use-identity-1 (gnus-alias-get-value reference)))
(when from
(gnus-alias-remove-header "From")
(message-position-on-field "From")
(insert (gnus-alias-get-value from))
(when gnus-alias-use-buttonized-from
))
(when org
(gnus-alias-remove-header "Organization")
(gnus-alias-position-on-field "Organization")
(insert (gnus-alias-get-value org)))
(when extras
(setq extras-list extras)
(while extras-list
(setq current-extra (car extras-list))
(setq extra-hdr (gnus-alias-get-value (car current-extra)))
(setq extra-val (gnus-alias-get-value (cdr current-extra)))
(gnus-alias-remove-header extra-hdr)
(gnus-alias-position-on-field extra-hdr)
(insert extra-val)
(setq extras-list (cdr extras-list))
))
(when body
(gnus-alias-remove-current-body)
(gnus-alias-goto-sig)
(forward-line -1)
(unless (bolp) (insert "\n"))
(insert (gnus-alias-get-value body)))
(gnus-alias-remove-sig)
(when sig
(goto-char (point-max))
(unless (bolp) (insert "\n"))
(insert "-- \n")
(insert (gnus-alias-get-value sig)))
(setq gnus-alias-current-identity identity)))
(message-goto-body))
(defun gnus-alias-get-value (element)
"Determine type of ELEMENT and return value accordingly.
ELEMENT may be one of: File String Function Variable
If a File, return the contents of the file.
If a String, simply return that.
If a Function, call it and return value.
If a Variable, return it's value.
If none of the above, return \"\"."
(cond
((stringp element)
(cond
((and (> (length element) 0)
(file-exists-p element))
(with-temp-buffer
(insert-file-contents element nil)
(buffer-string)))
(t element)))
((functionp element)
(funcall element))
((boundp element)
(symbol-value element))
(t "")))
(defun gnus-alias-remove-identity (identity)
"Remove all traces of IDENTITY from the current message.
IDENTITY must be a valid key in `gnus-alias-identity-alist' or nil,
otherwise an error will occur.
This function depends on the fact that the definition of IDENTITY has
not changed, and any functions used for defining values return the
same value as it did previously (this latter piece is necessary only
for the header name in Extra Headers and the text auto-inserted into
the Body). If such is not the case, chaos will ensue (i.e. I'm not
responsible for the subsequent mess)."
(gnus-alias-ensure-message-mode)
(when identity
(let ((ID (assoc-string identity gnus-alias-identity-alist t))
from org extras body sig extras-list current-extra extra-hdr)
(if (not ID)
(gnus-alias-error "Unknown Identity: <%s>" identity)
(setq from (gnus-alias-get-from ID)
org (gnus-alias-get-org ID)
extras (gnus-alias-get-extras ID)
body (gnus-alias-get-body ID)
sig (gnus-alias-get-sig ID))
(when from (gnus-alias-remove-header "From"))
(when org (gnus-alias-remove-header "Organization"))
(when extras
(setq extras-list extras)
(while extras-list
(setq current-extra (car extras-list))
(setq extra-hdr (gnus-alias-get-value (car current-extra)))
(gnus-alias-remove-header extra-hdr)
(setq extras-list (cdr extras-list))
))
(when body (gnus-alias-remove-current-body))
(when sig (gnus-alias-remove-sig))
))))
(defun gnus-alias-remove-header (tag)
"Find and remove TAG from headers."
(message-position-on-field tag)
(let ((beg) (end))
(beginning-of-line)
(setq beg (point))
(end-of-line)
(setq end (+ (point) 1))
(delete-region beg end)))
(defun gnus-alias-remove-sig ()
"Find and remove signature."
(gnus-alias-goto-sig)
(delete-region (point) (point-max)))
(defun gnus-alias-remove-current-body ()
"Find and remove current Identity's body."
(when gnus-alias-current-identity
(let* ((ID (assoc-string gnus-alias-current-identity
gnus-alias-identity-alist t))
(current-body (when ID (gnus-alias-get-body ID)))
start end)
(when current-body
(save-restriction
(widen)
(message-goto-eoh)
(forward-line 1)
(setq start (point))
(gnus-alias-goto-sig)
(setq end (point))
(narrow-to-region start end)
(goto-char (point-min))
(save-match-data
(when (re-search-forward
(regexp-quote (gnus-alias-get-value current-body)) nil t)
(replace-match "")))
))
)))
(defun gnus-alias-goto-sig ()
"Goto beginning of signature or end of buffer."
(goto-char (point-min))
(save-match-data
(re-search-forward message-signature-separator nil 'move))
(beginning-of-line))
(defun gnus-alias-goto-first-empty-header (or-body)
"Move point to first empty header.
If there are no empty headers, the value of OR-BODY will determine
whether point is move to the start of body or sig."
(let ((found))
(save-restriction
(message-narrow-to-headers)
(save-match-data
(setq found (re-search-forward "^.+:\\s-*$" nil t))))
(when (not found)
(if or-body
(message-goto-body)
(gnus-alias-goto-sig)))))
(defun gnus-alias-debug (level fmt &rest args)
"Debug function.
LEVEL = level of message (1 = message, 2-9 = debug message)
FMT = string format passed to `message' or `insert'
ARGS = arguments for FMT"
(when (> gnus-alias-verbosity 0)
(if (= level 1)
(progn
(gnus-alias-debug 2 (concat "[MSG] " fmt "\n") args)
(apply 'message fmt args))
(save-excursion
(set-buffer (get-buffer-create gnus-alias-debug-buffer-name))
(insert (apply 'format fmt args)))
)))
(defun gnus-alias-error (fmt &rest args)
"Log the error and then call `error'.
FMT is the format of the error message, and ARGS are its arguments."
(gnus-alias-debug 2 (concat "[ERROR] " fmt "\n") args)
(apply 'error fmt args))
(defun gnus-alias-dump-headers (&optional prefix)
"Dump headers to debug buffer (verbosity >= 4).
PREFIX is an optional prefeix to each header block."
(interactive)
(when (>= gnus-alias-verbosity 4)
(let (tmp)
(when (and message-reply-buffer
(buffer-name message-reply-buffer))
(save-excursion
(save-restriction
(set-buffer message-reply-buffer)
(message-narrow-to-headers)
(setq tmp (buffer-string))
(gnus-alias-debug 4 "%sOld Headers\n%s===========\n%s\n\n" prefix prefix tmp))))
(save-excursion
(save-restriction
(message-narrow-to-headers)
(setq tmp (buffer-string))
(gnus-alias-debug 4 "%sNew Headers\n%s===========\n%s\n\n" prefix prefix tmp)))
)))
(defun gnus-alias-create-identity-menu ()
"Add Identity menu in Message mode (see `gnus-alias-add-identity-menu')."
(easy-menu-define message-mode-menu message-mode-map "Identity Menu."
'("Identity"
:filter gnus-alias-identity-menu-filter)))
(defun gnus-alias-identity-menu-filter (menu)
"Create Identity MENU from all defined Identities."
(let ((identities gnus-alias-identity-alist)
alias)
(mapcar (lambda (identity)
(setq alias (car identity))
(vector alias `(gnus-alias-use-identity ,alias) t))
identities)))
(provide 'gnus-alias)
(run-hooks 'gnus-alias-load-hook)