:type '(repeat sexp)) ; Fixme: improve this
(defcustom message-required-headers '((optional . References) From)
- "*Headers to be generated or promted for when sending a message.
+ "*Headers to be generated or prompted for when sending a message.
Also see `message-required-news-headers' and
-1message-required-mail-headers'."
+`message-required-mail-headers'."
:group 'message-news
:group 'message-headers
:type '(repeat sexp))
:group 'message-sending
:type 'boolean)
+(defcustom message-sendmail-envelope-from nil
+ "*Envelope-from when sending mail with sendmail.
+If this is nil, use `user-mail-address'. If it is the symbol
+`header', use the From: header of the message."
+ :type '(choice (string :tag "From name")
+ (const :tag "Use From: header from message" header)
+ (const :tag "Use `user-mail-address'" nil))
+ :group 'message-sending)
+
;; qmail-related stuff
(defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
"Location of the qmail-inject program."
(or (not (listp message-shoot-gnksa-feet))
(memq feature message-shoot-gnksa-feet)))
+(defcustom message-hidden-headers nil
+ "Regexp of headers to be hidden when composing new messages.
+This can also be a list of regexps to match headers. Or a list
+starting with `not' and followed by regexps.."
+ :group 'message
+ :type '(repeat regexp))
+
;;; Internal variables.
;;; Well, not really internal.
The cdr of each entry is a function for applying the face to a region.")
(defcustom message-send-hook nil
- "Hook run before sending messages."
+ "Hook run before sending messages.
+This hook is run quite early when sending."
:group 'message-various
:options '(ispell-message)
:type 'hook)
(defcustom message-send-mail-hook nil
- "Hook run before sending mail messages."
+ "Hook run before sending mail messages.
+This hook is run very late -- just before the message is sent as
+mail."
:group 'message-various
:type 'hook)
(defcustom message-send-news-hook nil
- "Hook run before sending news messages."
+ "Hook run before sending news messages.
+This hook is run very late -- just before the message is sent as
+news."
:group 'message-various
:type 'hook)
:group 'message-headers
:type 'boolean)
+(defcustom message-user-fqdn nil
+ "*Domain part of Messsage-Ids."
+ :group 'message-headers
+ :link '(custom-manual "(message)News Headers")
+ :type 'string)
+
+(defcustom message-use-idna (and (condition-case nil (require 'idna)
+ (file-error))
+ (fboundp 'coding-system-p)
+ (coding-system-p 'utf-8)
+ 'ask)
+ "Whether to encode non-ASCII in domain names into ASCII according to IDNA."
+ :group 'message-headers
+ :type '(choice (const :tag "Ask" ask)
+ (const :tag "Never" nil)
+ (const :tag "Always" t)))
+
;;; Internal variables.
(defvar message-sending-message "Sending...")
;; We want to match the results of any of these manglings.
;; The following regexp rejects names whose first characters are
;; obviously bogus, but after that anything goes.
- "\\([^\0-\b\n-\r\^?].*\\)? "
+ "\\([^\0-\b\n-\r\^?].*\\)?"
;; The time the message was sent.
"\\([^\0-\r \^?]+\\) +" ; day of the week
(defvar message-bogus-system-names "^localhost\\."
"The regexp of bogus system names.")
+(defcustom message-valid-fqdn-regexp
+ (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain.
+ ;; valid TLDs:
+ "\\([a-z][a-z]" ;; two letter country TDLs
+ "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org"
+ "\\|aero\\|coop\\|info\\|name\\|museum"
+ "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style?
+ "\\)")
+ "Regular expression that matches a valid FQDN."
+ ;; see also: gnus-button-valid-fqdn-regexp
+ :group 'message-headers
+ :type 'regexp)
+
(eval-and-compile
(autoload 'message-setup-toolbar "messagexmas")
(autoload 'mh-new-draft-name "mh-comp")
`(delete-region (progn (beginning-of-line) (point))
(progn (forward-line ,(or n 1)) (point))))
+(defun message-mark-active-p ()
+ "Non-nil means the mark and region are currently active in this buffer."
+ mark-active)
+
(defun message-unquote-tokens (elems)
"Remove double quotes (\") from strings in list ELEMS."
(mapcar (lambda (item)
(defun message-fetch-reply-field (header)
"Fetch field HEADER from the message we're replying to."
(message-with-reply-buffer
- (message-fetch-field header)))
+ (save-restriction
+ (mail-narrow-to-head)
+ (message-fetch-field header))))
(defun message-set-work-buffer ()
(if (get-buffer " *message work*")
(not (string-match (regexp-quote target-group)
(message-fetch-field "Newsgroups"))))
(end-of-line)
- (insert-string (concat "," target-group))))
+ (insert (concat "," target-group))))
(end-of-line) ; ensure Followup: comes after Newsgroups:
;; unless new followup would be identical to Newsgroups line
;; make a new Followup-To line
(define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
(define-key message-mode-map "\C-c\C-t" 'message-insert-to)
- (define-key message-mode-map "\C-c\M-t" 'message-insert-wide-reply)
+ (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply)
(define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
(define-key message-mode-map "\C-c\C-l" 'message-to-list-only)
(define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
(define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
;;(define-key message-mode-map "\M-q" 'message-fill-paragraph)
+ (define-key message-mode-map [remap split-line] 'message-split-line)
(define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
(easy-menu-define
message-mode-menu message-mode-map "Message Menu."
`("Message"
- ["Yank Original" message-yank-original t]
+ ["Yank Original" message-yank-original message-reply-buffer]
["Fill Yanked Message" message-fill-yanked-message t]
["Insert Signature" message-insert-signature t]
["Caesar (rot13) Message" message-caesar-buffer-body t]
- ["Caesar (rot13) Region" message-caesar-region (mark t)]
- ["Elide Region" message-elide-region (mark t)]
- ["Delete Outside Region" message-delete-not-region (mark t)]
+ ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)]
+ ["Elide Region" message-elide-region
+ :active (message-mark-active-p)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Replace text in region with an ellipsis"))]
+ ["Delete Outside Region" message-delete-not-region
+ :active (message-mark-active-p)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Delete all quoted text outside region"))]
["Kill To Signature" message-kill-to-signature t]
["Newline and Reformat" message-newline-and-reformat t]
["Rename buffer" message-rename-buffer t]
'(:help "Spellcheck this message"))]
"----"
["Insert Region Marked" message-mark-inserted-region
- ,@(if (featurep 'xemacs) '(t)
+ :active (message-mark-active-p)
+ ,@(if (featurep 'xemacs) nil
'(:help "Mark region with enclosing tags"))]
["Insert File Marked..." message-mark-insert-file
,@(if (featurep 'xemacs) '(t)
(easy-menu-define
message-mode-field-menu message-mode-map ""
- '("Field"
+ `("Field"
["Fetch To" message-insert-to t]
["Fetch Newsgroups" message-insert-newsgroups t]
"----"
["Reduce To: to Cc:" message-reduce-to-to-cc t]
"----"
["Sort Headers" message-sort-headers t]
+ ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t]
["Goto Body" message-goto-body t]
["Goto Signature" message-goto-signature t]))
;; No reason this should be clutter up customize. We make it a
;; property list (rather than a list of property symbols), to be
;; directly useful for `remove-text-properties'.
- '(field nil read-only nil intangible nil invisible nil
+ '(field nil read-only nil invisible nil intangible nil
mouse-face nil modification-hooks nil insert-in-front-hooks nil
insert-behind-hooks nil point-entered nil point-left nil)
;; Other special properties:
See also `message-forbidden-properties'."
(when (and message-strip-special-text-properties
(message-tamago-not-in-use-p begin))
- (remove-text-properties begin end message-forbidden-properties)))
+ (while (not (= begin end))
+ (when (not (get-text-property begin 'message-hidden))
+ (remove-text-properties begin (1+ begin)
+ message-forbidden-properties))
+ (incf begin))))
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
(set (make-local-variable 'message-checksum) nil)
(set (make-local-variable 'message-mime-part) 0)
(message-setup-fill-variables)
+ (set
+ (make-local-variable 'paragraph-separate)
+ (format "\\(%s\\)\\|\\(%s\\)"
+ paragraph-separate
+ "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
;; Allow using comment commands to add/remove quoting.
(set (make-local-variable 'comment-start) message-yank-prefix)
(if (featurep 'xemacs)
(when (funcall (cadr elem))
(when (and (or (not (memq (car elem)
message-sent-message-via))
+ (not (message-fetch-field "supersedes"))
(if (or (message-gnksa-enable-p 'multiple-copies)
(not (eq (car elem) 'news)))
(y-or-n-p
(goto-char (point-max))
(unless (bolp)
(insert "\n"))
- ;; Delete all invisible text.
+ ;; Make the hidden headers visible.
+ (let ((points (message-text-with-property 'message-hidden)))
+ (when points
+ (goto-char (car points))
+ (dolist (point points)
+ (add-text-properties point (1+ point)
+ '(invisible nil intangible nil)))))
+ ;; Make invisible text visible.
(message-check 'invisible-text
(let ((points (message-text-with-property 'invisible)))
(when points
(goto-char (car points))
(dolist (point points)
(add-text-properties point (1+ point)
- '(invisible nil highlight t)))
+ '(invisible nil face highlight
+ font-lock-face highlight)))
(unless (yes-or-no-p
"Invisible text found and made visible; continue posting? ")
(error "Invisible text found and made visible")))))
(memq (char-charset char)
'(eight-bit-control eight-bit-graphic
control-1)))))
- (add-text-properties (point) (1+ (point)) '(highlight t))
+ (add-text-properties (point) (1+ (point))
+ '(font-lock-face highlight face highlight))
(setq found t))
(forward-char)
(skip-chars-forward mm-7bit-chars))
(when found
(setq choice
(gnus-multiple-choice
- "Illegible text found. Continue posting? "
+ "Illegible text found. Continue posting?"
'((?d "Remove and continue posting")
(?r "Replace with dots and continue posting")
(?i "Ignore and continue posting")
'(eight-bit-control eight-bit-graphic
control-1)))))
(if (eq choice ?i)
- (remove-text-properties (point) (1+ (point)) '(highlight t))
+ (remove-text-properties (point) (1+ (point))
+ '(font-lock-face highlight face highlight))
(delete-char 1)
- (if (eq choice ?r)
- (insert "."))))
+ (when (eq choice ?r)
+ (insert "."))))
(forward-char)
(skip-chars-forward mm-7bit-chars))))))
(message-remove-header "Lines")
(goto-char (point-max))
(insert "Mime-Version: 1.0\n")
- (setq header (buffer-substring (point-min) (point-max))))
+ (setq header (buffer-string)))
(goto-char (point-max))
(insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n"
id n total))
(message-narrow-to-headers)
(and news
(or (message-fetch-field "cc")
+ (message-fetch-field "bcc")
(message-fetch-field "to"))
(let ((content-type (message-fetch-field "content-type")))
(or
The size limit is controlled by `message-send-mail-partially-limit'.
If you always want Gnus to send messages in one piece, set
-`message-send-mail-partially-limit' to `nil'.
+`message-send-mail-partially-limit' to nil.
")))
(mm-with-unibyte-current-buffer
(message "Sending via mail...")
;; But some systems are more broken with -f, so
;; we'll let users override this.
(if (null message-sendmail-f-is-evil)
- (list "-f" (message-make-address)))
+ (list "-f" (message-sendmail-envelope-from)))
;; These mean "report errors by mail"
;; and "deliver in background".
(if (null message-interactive) '("-oem" "-odb"))
(replace-match "; "))
(if (not (zerop (buffer-size)))
(error "Sending...failed to %s"
- (buffer-substring (point-min) (point-max)))))))
+ (buffer-string))))))
(when (bufferp errbuf)
(kill-buffer errbuf)))))
;; Check long header lines.
(message-check 'long-header-lines
(let ((start (point))
+ (header nil)
+ (length 0)
found)
(while (and (not found)
(re-search-forward "^\\([^ \t:]+\\): " nil t))
- (when (> (- (point) start) 998)
- (setq found t))
+ (if (> (- (point) (match-beginning 0)) 998)
+ (setq found t
+ length (- (point) (match-beginning 0)))
+ (setq header (match-string-no-properties 1)))
(setq start (match-beginning 0))
(forward-line 1))
(if found
- (y-or-n-p (format "Your %s header is too long. Really post? "
- (match-string 1)))
+ (y-or-n-p (format "Your %s header is too long (%d). Really post? "
+ header length))
t)))
;; Check for multiple identical headers.
(message-check 'multiple-headers
;; Check "Shoot me".
(message-check 'shoot
(if (re-search-forward
- "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t)
+ "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t)
(y-or-n-p "You appear to have a misconfigured system. Really post? ")
t))
;; Check for Approved.
(gnus-groups-from-server method)))
errors)
(while groups
- (unless (or (equal (car groups) "poster")
- (member (car groups) known-groups))
+ (when (and (not (equal (car groups) "poster"))
+ (not (member (car groups) known-groups))
+ (not (member (car groups) errors)))
(push (car groups) errors))
(pop groups))
(cond
(date (mail-header-date message-reply-headers))
(msg-id (mail-header-message-id message-reply-headers)))
(when from
- (let ((stop-pos
- (string-match " *at \\| *@ \\| *(\\| *<" from)))
+ (let ((name (mail-extract-address-components from)))
(concat msg-id (if msg-id " (")
- (if (and stop-pos
- (not (zerop stop-pos)))
- (substring from 0 stop-pos) from)
+ (or (car name)
+ (nth 1 name))
"'s message of \""
(if (or (not date) (string= date ""))
"(unknown date)" date)
(defun message-user-mail-address ()
"Return the pertinent part of `user-mail-address'."
- (when user-mail-address
+ (when (and user-mail-address
+ (string-match "@.*\\." user-mail-address))
(if (string-match " " user-mail-address)
(nth 1 (mail-extract-address-components user-mail-address))
user-mail-address)))
+(defun message-sendmail-envelope-from ()
+ "Return the envelope from."
+ (cond ((eq message-sendmail-envelope-from 'header)
+ (nth 1 (mail-extract-address-components
+ (message-fetch-field "from"))))
+ ((stringp message-sendmail-envelope-from)
+ message-sendmail-envelope-from)
+ (t
+ (message-make-address))))
+
(defun message-make-fqdn ()
"Return user's fully qualified domain name."
- (let ((system-name (system-name))
- (user-mail (message-user-mail-address)))
+ (let* ((system-name (system-name))
+ (user-mail (message-user-mail-address))
+ (user-domain
+ (if (and user-mail
+ (string-match "@\\(.*\\)\\'" user-mail))
+ (match-string 1 user-mail))))
(cond
- ((and (string-match "[^.]\\.[^.]" system-name)
+ ((and message-user-fqdn
+ (stringp message-user-fqdn)
+ (string-match message-valid-fqdn-regexp message-user-fqdn)
+ (not (string-match message-bogus-system-names message-user-fqdn)))
+ message-user-fqdn)
+ ;; `message-user-fqdn' seems to be valid
+ ((and (string-match message-valid-fqdn-regexp system-name)
(not (string-match message-bogus-system-names system-name)))
;; `system-name' returned the right result.
system-name)
;; Try `mail-host-address'.
((and (boundp 'mail-host-address)
(stringp mail-host-address)
- (string-match "\\." mail-host-address))
+ (string-match message-valid-fqdn-regexp mail-host-address)
+ (not (string-match message-bogus-system-names mail-host-address)))
mail-host-address)
;; We try `user-mail-address' as a backup.
- ((and user-mail
- (string-match "\\." user-mail)
- (string-match "@\\(.*\\)\\'" user-mail))
- (match-string 1 user-mail))
+ ((and user-domain
+ (stringp user-domain)
+ (string-match message-valid-fqdn-regexp user-domain)
+ (not (string-match message-bogus-system-names user-domain)))
+ user-domain)
;; Default to this bogus thing.
(t
(concat system-name ".i-did-not-set--mail-host-address--so-tickle-me")))))
list
msg-recipients))))))
+(defun message-idna-inside-rhs-p ()
+ "Return t iff point is inside a RHS (heuristically).
+Only works properly if header contains mailbox-list or address-list.
+I.e., calling it on a Subject: header is useless."
+ (save-restriction
+ (narrow-to-region (save-excursion (or (re-search-backward "^[^ \t]" nil t)
+ (point-min)))
+ (save-excursion (or (re-search-forward "^[^ \t]" nil t)
+ (point-max))))
+ (if (re-search-backward "[\\\n\r\t ]"
+ (save-excursion (search-backward "@" nil t)) t)
+ ;; whitespace between @ and point
+ nil
+ (let ((dquote 1) (paren 1))
+ (while (save-excursion (re-search-backward "[^\\]\"" nil t dquote))
+ (incf dquote))
+ (while (save-excursion (re-search-backward "[^\\]\(" nil t paren))
+ (incf paren))
+ (and (= (% dquote 2) 1) (= (% paren 2) 1))))))
+
+(autoload 'idna-to-ascii "idna")
+
+(defun message-idna-to-ascii-rhs-1 (header)
+ "Interactively potentially IDNA encode domain names in HEADER."
+ (let (rhs ace start startpos endpos ovl)
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^" header) nil t)
+ (while (re-search-forward "@\\([^ \t\r\n>]+\\)"
+ (or (save-excursion
+ (re-search-forward "^[^ \t]" nil t))
+ (point-max))
+ t)
+ (setq rhs (match-string-no-properties 1)
+ startpos (match-beginning 1)
+ endpos (match-end 1))
+ (when (save-match-data
+ (and (message-idna-inside-rhs-p)
+ (setq ace (idna-to-ascii rhs))
+ (not (string= rhs ace))
+ (if (eq message-use-idna 'ask)
+ (unwind-protect
+ (progn
+ (setq ovl (message-make-overlay startpos
+ endpos))
+ (message-overlay-put ovl 'face 'highlight)
+ (y-or-n-p
+ (format "Replace with `%s'? " ace)))
+ (message "")
+ (message-delete-overlay ovl))
+ message-use-idna)))
+ (replace-match (concat "@" ace)))))))
+
+(defun message-idna-to-ascii-rhs ()
+ "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
+See `message-idna-encode'."
+ (interactive)
+ (when message-use-idna
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-head)
+ (message-idna-to-ascii-rhs-1 "From")
+ (message-idna-to-ascii-rhs-1 "To")
+ (message-idna-to-ascii-rhs-1 "Cc")))))
+
(defun message-generate-headers (headers)
"Prepare article HEADERS.
Headers already prepared in the buffer are not modified."
(User-Agent message-newsreader)
(Expires (message-make-expires))
(case-fold-search t)
+ (optionalp nil)
header value elem)
;; First we remove any old generated headers.
(let ((headers message-deletable-headers))
(setq elem (pop headers))
(if (consp elem)
(if (eq (car elem) 'optional)
- (setq header (cdr elem))
+ (setq header (cdr elem)
+ optionalp t)
(setq header (car elem)))
(setq header elem))
(when (or (not (re-search-forward
;; The header was found. We insert a space after the
;; colon, if there is none.
(if (/= (char-after) ? ) (insert " ") (forward-char 1))
- ;; Find out whether the header is empty...
+ ;; Find out whether the header is empty.
(looking-at "[ \t]*\n[^ \t]")))
;; So we find out what value we should insert.
(setq value
;; The value of this header was empty, so we clear
;; totally and insert the new value.
(delete-region (point) (gnus-point-at-eol))
- (insert value))
+ ;; If the header is optional, and the header was
+ ;; empty, we con't insert it anyway.
+ (unless optionalp
+ (insert value)))
;; Add the deletable property to the headers that require it.
(and (memq header message-deletable-headers)
(progn (beginning-of-line) (looking-at "[^:]+: "))
(beginning-of-line))
(when (or (message-news-p)
(string-match "@.+\\.." secure-sender))
- (insert "Sender: " secure-sender "\n")))))))
+ (insert "Sender: " secure-sender "\n"))))
+ ;; Check for IDNA
+ (message-idna-to-ascii-rhs))))
(defun message-insert-courtesy-copy ()
"Insert a courtesy message in mail copies of combined messages."
(widen)
(forward-line 1)))
+(defun message-split-line ()
+ "Split current line, moving portion beyond point vertically down.
+If the current line has `message-yank-prefix', insert it on the new line."
+ (interactive "*")
+ (condition-case nil
+ (split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg.
+ (error
+ (split-line))))
+
+
(defun message-fill-header (header value)
(let ((begin (point))
(fill-column 78)
(mm-disable-multibyte-mule4)
(insert
(with-current-buffer forward-buffer
- (mm-string-as-unibyte (buffer-string))))
+ (mm-with-unibyte-current-buffer-mule4 (buffer-string))))
(mm-enable-multibyte-mule4)
(mime-to-mml)
(goto-char (point-min))
(unless (message-mail-user-agent)
(set-buffer (get-buffer-create " *message resend*"))
(erase-buffer))
- (let ((message-this-is-mail t))
+ (let ((message-this-is-mail t)
+ message-setup-hook)
(message-setup `((To . ,address))))
;; Insert our usual headers.
(message-generate-headers '(From Date To))
(message-narrow-to-headers)
+ ;; Remove X-Draft-From header etc.
+ (message-remove-header message-ignored-mail-headers t)
;; Rename them all to "Resent-*".
+ (goto-char (point-min))
(while (re-search-forward "^[A-Za-z]" nil t)
(forward-char -1)
(insert "Resent-"))
(delete-char -2))))))
(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
+(defalias 'message-make-overlay 'make-overlay)
+(defalias 'message-delete-overlay 'delete-overlay)
+(defalias 'message-overlay-put 'overlay-put)
;; Support for toolbar
(eval-when-compile
'mml-attach-file "attach" tool-bar-map mml-mode-map)
(message-tool-bar-local-item-from-menu
'ispell-message "spell" tool-bar-map message-mode-map)
+ (message-tool-bar-local-item-from-menu
+ 'mml-preview "preview"
+ tool-bar-map mml-mode-map)
(message-tool-bar-local-item-from-menu
'message-insert-importance-high "important"
tool-bar-map message-mode-map)
(if (and (or to cc) bcc) ", ")
(or bcc "")))))))
+(defun message-hide-headers ()
+ "Hide headers based on the `message-hidden-headers' variable."
+ (let ((regexps (if (stringp message-hidden-headers)
+ (list message-hidden-headers)
+ message-hidden-headers))
+ (inhibit-point-motion-hooks t)
+ (after-change-functions nil))
+ (when regexps
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (not (message-hide-header-p regexps))
+ (message-next-header)
+ (let ((begin (point)))
+ (message-next-header)
+ (add-text-properties begin (point)
+ '(intangible t invisible t
+ message-hidden t))))))))))
+
+(defun message-hide-header-p (regexps)
+ (let ((result nil)
+ (reverse nil))
+ (when (eq (car regexps) 'not)
+ (setq reverse t)
+ (pop regexps))
+ (dolist (regexp regexps)
+ (setq result (or result (looking-at regexp))))
+ (if reverse
+ (not result)
+ result)))
+
(when (featurep 'xemacs)
(require 'messagexmas)
(message-xmas-redefine))