;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
Don't touch this variable unless you really know what you're doing.
-Checks include `approved', `continuation-headers', `control-chars',
-`empty', `existing-newsgroups', `from', `illegible-text',
+Checks include `approved', `bogus-recipient', `continuation-headers',
+`control-chars', `empty', `existing-newsgroups', `from', `illegible-text',
`invisible-text', `long-header-lines', `long-lines', `message-id',
`multiple-headers', `new-text', `newsgroups', `quoting-style',
`repeated-newsgroups', `reply-to', `sender', `sendsys', `shoot',
:link '(custom-manual "(message)Mail Headers")
:type 'regexp)
-(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:"
+(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-ID:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:"
"*Header lines matching this regexp will be deleted before posting.
It's best to delete old Path and Date headers before posting to avoid
any confusion."
:type 'regexp)
(defcustom message-cite-prefix-regexp
- (if (string-match "[[:digit:]]" "1") ;; support POSIX?
- "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+"
+ (if (string-match "[[:digit:]]" "1")
+ ;; Support POSIX? XEmacs 21.5.27 doesn't.
+ "\\([ \t]*[_.[:word:]]+>+\\|[ \t]*[]>|}]\\)+"
;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
(let (non-word-constituents)
(with-syntax-table text-mode-syntax-table
(setq non-word-constituents
(concat
- (if (string-match "\\w" "-") "" "-")
(if (string-match "\\w" "_") "" "_")
(if (string-match "\\w" ".") "" "."))))
(if (equal non-word-constituents "")
- "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+"
+ "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}]\\)+"
(concat "\\([ \t]*\\(\\w\\|["
non-word-constituents
- "]\\)+>+\\|[ \t]*[]>|}+]\\)+"))))
+ "]\\)+>+\\|[ \t]*[]>|}]\\)+"))))
"*Regexp matching the longest possible citation prefix on a line."
:version "22.1"
:group 'message-insertion
"*Function called to insert the \"Whomever writes:\" line.
Predefined functions include `message-insert-citation-line' and
-`message-insert-formated-citation-line' (see the variable
+`message-insert-formatted-citation-line' (see the variable
`message-citation-line-format').
Note that Gnus provides a feature where the reader can click on
configuration. See the variable `gnus-cite-attribution-suffix'."
:type '(choice
(function-item :tag "plain" message-insert-citation-line)
- (function-item :tag "formatted" message-insert-formated-citation-line)
+ (function-item :tag "formatted" message-insert-formatted-citation-line)
(function :tag "Other"))
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
(defcustom message-use-idna (and (condition-case nil (require 'idna)
(file-error))
(mm-coding-system-p 'utf-8)
- (executable-find idna-program)
+ (executable-find (symbol-value 'idna-program))
(string= (idna-to-ascii "räksmörgås")
"xn--rksmrgs-5wao1o")
t)
(forward-line 1))))
(goto-char start))
+(defun message-remove-blank-cited-lines (&optional remove)
+ "Remove cited lines containing only blanks.
+If REMOVE is non-nil, remove newlines, too.
+
+To use this automatically, you may add this function to
+`gnus-message-setup-hook'."
+ (interactive "P")
+ (let ((citexp
+ (concat
+ "^\\("
+ (when (boundp 'message-yank-cited-prefix)
+ (concat message-yank-cited-prefix "\\|"))
+ message-yank-prefix
+ "\\)+ *\n"
+ )))
+ (gnus-message 8 "removing `%s'" citexp)
+ (save-excursion
+ (message-goto-body)
+ (while (re-search-forward citexp nil t)
+ (replace-match (if remove "" "\n"))))))
+
(defvar message-cite-reply-above nil
"If non-nil, start own text above the quote.
"Cite function in the standard Message manner."
(message-cite-original-1 nil))
-(defun message-insert-formated-citation-line (&optional from date)
- "Function that inserts a formated citation line.
+(defun message-insert-formatted-citation-line (&optional from date)
+ "Function that inserts a formatted citation line.
See `message-citation-line-format'."
;; The optional args are for testing/debugging. They will disappear later.
;; Example:
;; (with-temp-buffer
- ;; (message-insert-formated-citation-line
+ ;; (message-insert-formatted-citation-line
;; "John Doe <john.doe@example.invalid>"
;; (current-time))
;; (buffer-string))
(setq start next)))
(nreverse regions)))
+(defcustom message-bogus-address-regexp nil ;; "noreply\\|nospam\\|invalid"
+ "Regexp of potentially bogus mail addresses."
+ :version "23.0" ;; No Gnus
+ :group 'message-headers
+ :type 'regexp)
+
(defun message-fix-before-sending ()
"Do various things to make the message nice before sending it."
;; Make sure there's a newline at the end of the message.
"Invisible text found and made visible; continue sending? ")
(error "Invisible text found and made visible")))))
(message-check 'illegible-text
- (let (found choice)
+ (let (char found choice)
(message-goto-body)
- (skip-chars-forward mm-7bit-chars)
- (while (not (eobp))
- (when (let ((char (char-after)))
- (or (< (mm-char-int char) 128)
- (and (mm-multibyte-p)
- (memq (char-charset char)
- '(eight-bit-control eight-bit-graphic
- control-1))
- (not (get-text-property
- (point) 'untranslated-utf-8)))))
+ (while (progn
+ (skip-chars-forward mm-7bit-chars)
+ (when (get-text-property (point) 'no-illegible-text)
+ ;; There is a signed or encrypted raw message part
+ ;; that is considered to be safe.
+ (goto-char (or (next-single-property-change
+ (point) 'no-illegible-text)
+ (point-max))))
+ (setq char (char-after)))
+ (when (or (< (mm-char-int char) 128)
+ (and (mm-multibyte-p)
+ (memq (char-charset char)
+ '(eight-bit-control eight-bit-graphic
+ control-1))
+ (not (get-text-property
+ (point) 'untranslated-utf-8))))
(message-overlay-put (message-make-overlay (point) (1+ (point)))
'face 'highlight)
(setq found t))
- (forward-char)
- (skip-chars-forward mm-7bit-chars))
+ (forward-char))
(when found
(setq choice
(gnus-multiple-choice
(when (eq choice ?r)
(insert message-replacement-char))))
(forward-char)
- (skip-chars-forward mm-7bit-chars))))))
+ (skip-chars-forward mm-7bit-chars)))))
+ (message-check 'bogus-recipient
+ ;; Warn before composing or sending a mail to an invalid address.
+ (message-check-recipients)))
+
+(defun message-bogus-recipient-p (recipients)
+ "Check if a mail address in RECIPIENTS looks bogus.
+
+RECIPIENTS is a mail header. Return a list of potentially bogus
+addresses. If none is found, return nil.
+
+An addresses might be bogus if the domain part is not fully
+qualified, see `message-valid-fqdn-regexp', or if it matches
+`message-bogus-address-regexp'."
+ ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"?
+ (let (found)
+ (mapc (lambda (address)
+ (setq address (cadr address))
+ (when
+ (or (not
+ (or
+ (not (string-match "@" address))
+ (string-match
+ (concat ".@.*\\("
+ message-valid-fqdn-regexp "\\)\\'") address)))
+ (and (stringp message-bogus-address-regexp)
+ (string-match message-bogus-address-regexp address)))
+ (push address found)))
+ ;;
+ (mail-extract-address-components recipients t))
+ found))
+
+(defun message-check-recipients ()
+ "Warn before composing or sending a mail to an invalid address.
+
+This function could be useful in `message-setup-hook'."
+ (interactive)
+ (save-restriction
+ (message-narrow-to-headers)
+ (dolist (hdr '("To" "Cc" "Bcc"))
+ (let ((addr (message-fetch-field hdr)))
+ (when (stringp addr)
+ (dolist (bog (message-bogus-recipient-p addr))
+ (and bog
+ (not (y-or-n-p
+ (format
+ "Address `%s' might be bogus. Continue? " bog)))
+ (error "Bogus address."))))))))
(defun message-add-action (action &rest types)
"Add ACTION to be performed when doing an exit of type TYPES."
(concat message-user-path "!" login-name))
(t login-name))))
-(defun message-make-from (&optional name address )
+(defun message-make-from (&optional name address)
"Make a From header."
(let* ((style message-from-style)
(login (or address (message-make-address)))
(mapcar 'downcase
(mapcar
'car (mail-header-parse-addresses field))))))
- (setq ace (downcase (idna-to-ascii rhs)))
+ (setq ace (if (string-match "\\`[[:ascii:]]+\\'" rhs)
+ rhs
+ (downcase (idna-to-ascii rhs))))
(when (and (not (equal rhs ace))
(or (not (eq message-use-idna 'ask))
(y-or-n-p (format "Replace %s with %s in %s:? "
'car-less-than-car)))
new)))))
-(defun message-pop-to-buffer (name)
+(defun message-pop-to-buffer (name &optional switch-function)
"Pop to buffer NAME, and warn if it already exists and is modified."
(let ((buffer (get-buffer name)))
(if (and buffer
(progn
(gnus-select-frame-set-input-focus (window-frame window))
(select-window window))
- (set-buffer (pop-to-buffer buffer)))
+ (funcall (or switch-function 'pop-to-buffer) buffer)
+ (set-buffer buffer))
(when (and (buffer-modified-p)
(not (prog1
(y-or-n-p
"Message already being composed; erase? ")
(message nil))))
(error "Message being composed")))
- (set-buffer (pop-to-buffer name)))
+ (funcall (or switch-function 'pop-to-buffer) name)
+ (set-buffer name))
(erase-buffer)
(message-mode)))
(interactive)
(let ((message-this-is-mail t) replybuffer)
(unless (message-mail-user-agent)
- (funcall
- (or switch-function 'message-pop-to-buffer)
+ (message-pop-to-buffer
;; Search for the existing message buffer if `continue' is non-nil.
(let ((message-generate-new-buffers
(when (or (not continue)
(eq message-generate-new-buffers 'standard)
(functionp message-generate-new-buffers))
message-generate-new-buffers)))
- (message-buffer-name "mail" to))))
+ (message-buffer-name "mail" to))
+ switch-function))
;; FIXME: message-mail should do something if YANK-ACTION is not
;; insert-buffer.
(and (consp yank-action) (eq (car yank-action) 'insert-buffer)
(message-remove-header elem t))))))
(defun message-forward-make-body-mime (forward-buffer)
- (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
- (let ((b (point)) e)
+ (let ((b (point)))
+ (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
(save-restriction
(narrow-to-region (point) (point))
(mml-insert-buffer forward-buffer)
(when (looking-at "From ")
(replace-match "X-From-Line: "))
(goto-char (point-max)))
- (setq e (point))
- (insert "<#/part>\n")))
+ (insert "<#/part>\n")
+ ;; Consider there is no illegible text.
+ (add-text-properties
+ b (point)
+ `(no-illegible-text t rear-nonsticky t start-open t))))
(defun message-forward-make-body-mml (forward-buffer)
(insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
(with-output-to-temp-buffer " *MESSAGE information message*"
(set-buffer " *MESSAGE information message*")
(fundamental-mode) ; for Emacs 20.4+
- (mapcar 'princ text)
+ (mapc 'princ text)
(goto-char (point-min))))
(funcall ask question))
(funcall ask question)))
(defun message-display-abbrev (&optional choose)
"Display the next possible abbrev for the text before point."
(interactive (list t))
- (when (and (member (char-after (point-at-bol)) '(?C ?T ? ))
+ (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? ))
(message-point-in-header-p)
(save-excursion
- (save-restriction
- (message-narrow-to-field)
- (goto-char (point-min))
- (looking-at "To\\|Cc"))))
+ (beginning-of-line)
+ (while (and (memq (char-after) '(?\t ? ))
+ (zerop (forward-line -1))))
+ (looking-at "To:\\|Cc:")))
(let* ((end (point))
(start (save-excursion
(and (re-search-backward "[\n\t ]" nil t)
projects / gnus / blobdiff