X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=c89d2c5aca7a9f9232469691d4c7945020db9080;hb=d811bd5951decd38fe11404abf88ae31aa62d87a;hp=9e998487f8a585ce89b904de50a1b051feed2500;hpb=b77b6ee7f199eea8f92d94219fdbd9bd98622274;p=gnus diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 9e998487f..c89d2c5ac 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -26,7 +26,9 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (defvar tool-bar-map)) (require 'gnus) (require 'gnus-sum) @@ -39,6 +41,7 @@ (require 'mm-view) (require 'wid-edit) (require 'mm-uu) +(require 'message) (autoload 'gnus-msg-mail "gnus-msg" nil t) (autoload 'gnus-button-mailto "gnus-msg") @@ -106,43 +109,47 @@ :group 'gnus-article) (defcustom gnus-ignored-headers - '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:" - "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:" - "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:" - "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:" - "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:" - "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face" - "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:" - "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:" - "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:" - "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:" - "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:" - "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" - "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:" - "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:" - "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:" - "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:" - "^MBOX-Line" "^Priority:" "^X400-[-A-Za-z]+:" - "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:" - "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:" - "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:" - "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:" - "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:" - "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:" - "^List-[A-Za-z]+:" "^X-Listprocessor-Version:" - "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:" - "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:" - "^X-Received:" "^Content-length:" "X-precedence:" - "^X-Authenticated-User:" "^X-Comment" "^X-Report:" "^X-Abuse-Info:" - "^X-HTTP-Proxy:" "^X-Mydeja-Info:" "^X-Copyright" "^X-No-Markup:" - "^X-Abuse-Info:" "^X-From_:" "^X-Accept-Language:" "^Errors-To:" - "^X-BeenThere:" "^X-Mailman-Version:" "^List-Help:" "^List-Post:" - "^List-Subscribe:" "^List-Id:" "^List-Unsubscribe:" "^List-Archive:" - "^X-Content-length:" "^X-Posting-Agent:" "^Original-Received:" - "^X-Request-PGP:" "^X-Fingerprint:" "^X-WRIEnvto:" "^X-WRIEnvfrom:" - "^X-Virus-Scanned:" "^X-Delivery-Agent:" "^Posted-Date:" "^X-Gateway:" - "^X-Local-Origin:" "^X-Local-Destination:" "^X-UserInfo1:" - "^X-Received-Date:" "^X-Hashcash:") + (mapcar + (lambda (header) + (concat "^" header ":")) + '("Path" "Expires" "Date-Received" "References" "Xref" "Lines" + "Relay-Version" "Message-ID" "Approved" "Sender" "Received" + "X-UIDL" "MIME-Version" "Return-Path" "In-Reply-To" + "Content-Type" "Content-Transfer-Encoding" "X-WebTV-Signature" + "X-MimeOLE" "X-MSMail-Priority" "X-Priority" "X-Loop" + "X-Authentication-Warning" "X-MIME-Autoconverted" "X-Face" + "X-Attribution" "X-Originating-IP" "Delivered-To" + "NNTP-[-A-Za-z]+" "Distribution" "X-no-archive" "X-Trace" + "X-Complaints-To" "X-NNTP-Posting-Host" "X-Orig.*" + "Abuse-Reports-To" "Cache-Post-Path" "X-Article-Creation-Date" + "X-Poster" "X-Mail2News-Path" "X-Server-Date" "X-Cache" + "Originator" "X-Problems-To" "X-Auth-User" "X-Post-Time" + "X-Admin" "X-UID" "Resent-[-A-Za-z]+" "X-Mailing-List" + "Precedence" "Original-[-A-Za-z]+" "X-filename" "X-Orcpt" + "Old-Received" "X-Pgp" "X-Auth" "X-From-Line" + "X-Gnus-Article-Number" "X-Majordomo" "X-Url" "X-Sender" + "MBOX-Line" "Priority" "X400-[-A-Za-z]+" + "Status" "X-Gnus-Mail-Source" "Cancel-Lock" + "X-FTN" "X-EXP32-SerialNo" "Encoding" "Importance" + "Autoforwarded" "Original-Encoded-Information-Types" "X-Ya-Pop3" + "X-Face-Version" "X-Vms-To" "X-ML-NAME" "X-ML-COUNT" + "Mailing-List" "X-finfo" "X-md5sum" "X-md5sum-Origin" + "X-Sun-Charset" "X-Accept-Language" "X-Envelope-Sender" + "List-[A-Za-z]+" "X-Listprocessor-Version" + "X-Received" "X-Distribute" "X-Sequence" "X-Juno-Line-Breaks" + "X-Notes-Item" "X-MS-TNEF-Correlator" "x-uunet-gateway" + "X-Received" "Content-length" "X-precedence" + "X-Authenticated-User" "X-Comment" "X-Report" "X-Abuse-Info" + "X-HTTP-Proxy" "X-Mydeja-Info" "X-Copyright" "X-No-Markup" + "X-Abuse-Info" "X-From_" "X-Accept-Language" "Errors-To" + "X-BeenThere" "X-Mailman-Version" "List-Help" "List-Post" + "List-Subscribe" "List-Id" "List-Unsubscribe" "List-Archive" + "X-Content-length" "X-Posting-Agent" "Original-Received" + "X-Request-PGP" "X-Fingerprint" "X-WRIEnvto" "X-WRIEnvfrom" + "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway" + "X-Local-Origin" "X-Local-Destination" "X-UserInfo1" + "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications" + "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer")) "*All headers that start with this regexp will be hidden. This variable can also be a list of regexps of headers to be ignored. If `gnus-visible-headers' is non-nil, this variable will be ignored." @@ -181,6 +188,8 @@ Possible values in this list are: 'empty Headers with no content. 'newsgroups Newsgroup identical to Gnus group. 'to-address To identical to To-address. + 'to-list To identical to To-list. + 'cc-list CC identical to To-list. 'followup-to Followup-to identical to Newsgroups. 'reply-to Reply-to identical to From. 'date Date less than four days old. @@ -189,6 +198,8 @@ Possible values in this list are: :type '(set (const :tag "Headers with no content." empty) (const :tag "Newsgroups identical to Gnus group." newsgroups) (const :tag "To identical to To-address." to-address) + (const :tag "To identical to To-list." to-list) + (const :tag "CC identical to To-list." cc-list) (const :tag "Followup-to identical to Newsgroups." followup-to) (const :tag "Reply-to identical to From." reply-to) (const :tag "Date less than four days old." date) @@ -196,6 +207,15 @@ Possible values in this list are: (const :tag "Multiple To and/or Cc headers." many-to)) :group 'gnus-article-hiding) +(defcustom gnus-article-skip-boring nil + "Skip over text that is not worth reading. +By default, if you set this t, then Gnus will display citations and +signatures, but will never scroll down to show you a page consisting +only of boring text. Boring text is controlled by +`gnus-article-boring-faces'." + :type 'boolean + :group 'gnus-article-hiding) + (defcustom gnus-signature-separator '("^-- $" "^-- *$") "Regexp matching signature separator. This can also be a list of regexps. In that case, it will be checked @@ -223,8 +243,8 @@ regexp. If it matches, the text in question is not a signature." :type 'sexp :group 'gnus-article-hiding) -;; Fixme: This isn't the right thing for mixed graphical and and -;; non-graphical frames in a session. +;; Fixme: This isn't the right thing for mixed graphical and non-graphical +;; frames in a session. (defcustom gnus-article-x-face-command (if (featurep 'xemacs) (if (or (gnus-image-type-available-p 'xface) @@ -376,7 +396,9 @@ and the latter avoids underlining any whitespace at all." Example: (_/*word*/_)." :group 'gnus-article-emphasis) -(defface gnus-emphasis-strikethru '((t (:strikethru t))) +(defface gnus-emphasis-strikethru (if (featurep 'xemacs) + '((t (:strikethru t))) + '((t (:strike-through t)))) "Face used for displaying strike-through text (-word-)." :group 'gnus-article-emphasis) @@ -540,10 +562,8 @@ The following additional specs are available: :type 'hook :group 'gnus-article-various) -(defcustom gnus-article-hide-pgp-hook nil - "*A hook called after successfully hiding a PGP signature." - :type 'hook - :group 'gnus-article-various) +(make-obsolete-variable 'gnus-article-hide-pgp-hook + "This variable is obsolete in Gnus 5.10.") (defcustom gnus-article-button-face 'bold "Face used for highlighting buttons in the article buffer. @@ -610,7 +630,9 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." (:foreground "MidnightBlue" :italic t)) (t (:italic t))) - "Face used for displaying newsgroups headers." + "Face used for displaying newsgroups headers. +In the default setup this face is only used for crossposted +articles." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -644,17 +666,17 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." ("Subject" nil gnus-header-subject-face) ("Newsgroups:.*," nil gnus-header-newsgroups-face) ("" gnus-header-name-face gnus-header-content-face)) - "*Controls highlighting of article header. + "*Controls highlighting of article headers. An alist of the form (HEADER NAME CONTENT). -HEADER is a regular expression which should match the name of an -header header and NAME and CONTENT are either face names or nil. +HEADER is a regular expression which should match the name of a +header and NAME and CONTENT are either face names or nil. The name of each header field will be displayed using the face -specified by the first element in the list where HEADER match the -header name and NAME is non-nil. Similarly, the content will be -displayed by the first non-nil matching CONTENT face." +specified by the first element in the list where HEADER matches +the header name and NAME is non-nil. Similarly, the content will +be displayed by the first non-nil matching CONTENT face." :group 'gnus-article-headers :group 'gnus-article-highlight :type '(repeat (list (regexp :tag "Header") @@ -667,7 +689,7 @@ displayed by the first non-nil matching CONTENT face." (defcustom gnus-article-decode-hook '(article-decode-charset article-decode-encoded-words - article-decode-group-name) + article-decode-group-name article-decode-idna-rhs) "*Hook run to decode charsets in articles." :group 'gnus-article-headers :type 'hook) @@ -788,7 +810,7 @@ This is meant for people who want to view first matched part. For `undisplayed-alternative' (default), the first undisplayed part or alternative part is used. For `undisplayed', the first undisplayed part is used. For a function, the first part which -the function return `t' is used. For `nil', the first part is +the function return t is used. For nil, the first part is used." :version "21.1" :group 'gnus-article-mime @@ -802,6 +824,7 @@ used." (defcustom gnus-mime-action-alist '(("save to file" . gnus-mime-save-part) ("save and strip" . gnus-mime-save-part-and-strip) + ("delete part" . gnus-mime-delete-part) ("display as text" . gnus-mime-inline-part) ("view the part" . gnus-mime-view-part) ("pipe to command" . gnus-mime-pipe-part) @@ -841,7 +864,7 @@ used." (defvar gnus-inhibit-treatment nil "Whether to inhibit treatment.") -(defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard")) +(defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard")) "Highlight the signature. Valid values are nil, t, `head', `last', an integer or a predicate. See Info node `(gnus)Customizing Articles'." @@ -962,13 +985,8 @@ See Info node `(gnus)Customizing Articles' for details." :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) -(defcustom gnus-treat-strip-pgp t - "Strip PGP signatures. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-custom) +(make-obsolete-variable 'gnus-treat-strip-pgp + "This option is obsolete in Gnus 5.10.") (defcustom gnus-treat-strip-pem nil "Strip PEM signatures. @@ -1129,11 +1147,15 @@ See Info node `(gnus)Customizing Articles' for details." :type gnus-article-treat-custom) (put 'gnus-treat-overstrike 'highlight t) -(defcustom gnus-treat-display-xface +(make-obsolete-variable 'gnus-treat-display-xface + 'gnus-treat-display-x-face) + +(defcustom gnus-treat-display-x-face (and (not noninteractive) (or (and (fboundp 'image-type-available-p) (image-type-available-p 'xbm) - (string-match "^0x" (shell-command-to-string "uncompface"))) + (string-match "^0x" (shell-command-to-string "uncompface")) + (executable-find "icontopbm")) (and (featurep 'xemacs) (featurep 'xface))) 'head) @@ -1145,19 +1167,43 @@ See Info node `(gnus)Customizing Articles' and Info node :version "21.1" :link '(custom-manual "(gnus)Customizing Articles") :link '(custom-manual "(gnus)X-Face") - :type gnus-article-treat-head-custom) -(put 'gnus-treat-display-xface 'highlight t) - -(defcustom gnus-treat-display-grey-xface + :type gnus-article-treat-head-custom + :set (lambda (symbol value) + (set-default + symbol + (cond ((or (boundp symbol) (get symbol 'saved-value)) + value) + ((boundp 'gnus-treat-display-xface) + (message "\ +** gnus-treat-display-xface is an obsolete variable;\ + use gnus-treat-display-x-face instead") + (default-value 'gnus-treat-display-xface)) + ((get 'gnus-treat-display-xface 'saved-value) + (message "\ +** gnus-treat-display-xface is an obsolete variable;\ + use gnus-treat-display-x-face instead") + (eval (car (get 'gnus-treat-display-xface 'saved-value)))) + (t + value))))) +(put 'gnus-treat-display-x-face 'highlight t) + +(defcustom gnus-treat-display-face (and (not noninteractive) - (string-match "^0x" (shell-command-to-string "uncompface")) - t) - "Display grey X-Face headers. -Valid values are nil, t." + (or (and (fboundp 'image-type-available-p) + (image-type-available-p 'png)) + (and (featurep 'xemacs) + (featurep 'png))) + 'head) + "Display Face headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' and Info node +`(gnus)X-Face' for details." :group 'gnus-article-treat - :version "21.3" - :type 'boolean) -(put 'gnus-treat-display-grey-xface 'highlight t) + :version "21.1" + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)X-Face") + :type gnus-article-treat-head-custom) +(put 'gnus-treat-display-face 'highlight t) (defcustom gnus-treat-display-smileys (if (or (and (featurep 'xemacs) @@ -1227,12 +1273,12 @@ See Info node `(gnus)Customizing Articles' and Info node gnus-treat-from-picon) 'head nil) "Draw a boundary at the end of the headers. -Valid values are nil, t, `head', `last', an integer or a predicate. +Valid values are nil and `head'. See Info node `(gnus)Customizing Articles' for details." :version "21.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-custom) + :type gnus-article-treat-head-custom) (defcustom gnus-treat-capitalize-sentences nil "Capitalize sentence-starting words. @@ -1301,6 +1347,19 @@ It is a string, such as \"PGP\". If nil, ask user." (defvar gnus-article-wash-function nil "Function used for converting HTML into text.") +(defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error)) + (mm-coding-system-p 'utf-8) + (executable-find idna-program)) + "Whether IDNA decoding of headers is used when viewing messages. +This requires GNU Libidn, and by default only enabled if it is found." + :group 'gnus-article-headers + :type 'boolean) + +(defcustom gnus-article-over-scroll nil + "If non-nil, allow scrolling the article buffer even when there no more text." + :group 'gnus-article + :type 'boolean) + ;;; Internal variables (defvar gnus-english-month-names @@ -1330,13 +1389,13 @@ It is a string, such as \"PGP\". If nil, ask user." (gnus-treat-date-original gnus-article-date-original) (gnus-treat-date-user-defined gnus-article-date-user) (gnus-treat-date-iso8601 gnus-article-date-iso8601) - (gnus-treat-display-xface gnus-article-display-x-face) + (gnus-treat-display-x-face gnus-article-display-x-face) + (gnus-treat-display-face gnus-article-display-face) (gnus-treat-hide-headers gnus-article-maybe-hide-headers) (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) (gnus-treat-hide-signature gnus-article-hide-signature) (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace) - (gnus-treat-strip-pgp gnus-article-hide-pgp) (gnus-treat-strip-pem gnus-article-hide-pem) (gnus-treat-from-picon gnus-treat-from-picon) (gnus-treat-mail-picon gnus-treat-mail-picon) @@ -1570,7 +1629,7 @@ always hide." (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t) (forward-line -1) (gnus-article-hide-text-type - (progn (beginning-of-line) (point)) + (gnus-point-at-bol) (progn (end-of-line) (if (re-search-forward "^[^ \t]" nil t) @@ -1599,21 +1658,57 @@ always hide." (nth 1 (mail-extract-address-components to)) to-address))) (gnus-article-hide-header "to")))) + ((eq elem 'to-list) + (let ((to (message-fetch-field "to")) + (to-list + (gnus-parameter-to-list + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name "")))) + (when (and to to-list + (ignore-errors + (gnus-string-equal + ;; only one address in To + (nth 1 (mail-extract-address-components to)) + to-list))) + (gnus-article-hide-header "to")))) + ((eq elem 'cc-list) + (let ((cc (message-fetch-field "cc")) + (to-list + (gnus-parameter-to-list + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name "")))) + (when (and cc to-list + (ignore-errors + (gnus-string-equal + ;; only one address in CC + (nth 1 (mail-extract-address-components cc)) + to-list))) + (gnus-article-hide-header "cc")))) ((eq elem 'followup-to) (when (gnus-string-equal (message-fetch-field "followup-to") (message-fetch-field "newsgroups")) (gnus-article-hide-header "followup-to"))) ((eq elem 'reply-to) - (let ((from (message-fetch-field "from")) - (reply-to (message-fetch-field "reply-to"))) - (when (and + (if (gnus-group-find-parameter + gnus-newsgroup-name 'broken-reply-to) + (gnus-article-hide-header "reply-to") + (let ((from (message-fetch-field "from")) + (reply-to (message-fetch-field "reply-to"))) + (when + (and from reply-to (ignore-errors - (gnus-string-equal - (nth 1 (mail-extract-address-components from)) - (nth 1 (mail-extract-address-components reply-to))))) - (gnus-article-hide-header "reply-to")))) + (equal + (sort (mapcar + (lambda (x) (downcase (cadr x))) + (mail-extract-address-components from t)) + 'string<) + (sort (mapcar + (lambda (x) (downcase (cadr x))) + (mail-extract-address-components reply-to t)) + 'string<)))) + (gnus-article-hide-header "reply-to"))))) ((eq elem 'date) (let ((date (message-fetch-field "date"))) (when (and date @@ -1660,7 +1755,7 @@ always hide." (goto-char (point-min)) (when (re-search-forward (concat "^" header ":") nil t) (gnus-article-hide-text-type - (progn (beginning-of-line) (point)) + (gnus-point-at-bol) (progn (end-of-line) (if (re-search-forward "^[^ \t]" nil t) @@ -1700,14 +1795,15 @@ always hide." (forward-line 1)))))) (defun article-treat-dumbquotes () - "Translate M****s*** sm*rtq**t*s into proper text. + "Translate M****s*** sm*rtq**t*s and other symbols into proper text. Note that this function guesses whether a character is a sm*rtq**t* or not, so it should only be used interactively. -Sm*rtq**t*s are M****s***'s unilateral extension to the character map -in an attempt to provide more quoting characters. If you see -something like \\222 or \\264 where you're expecting some kind of -apostrophe or quotation mark, then try this wash." +Sm*rtq**t*s are M****s***'s unilateral extension to the +iso-8859-1 character map in an attempt to provide more quoting +characters. If you see something like \\222 or \\264 where +you're expecting some kind of apostrophe or quotation mark, then +try this wash." (interactive) (article-translate-strings gnus-article-dumbquotes-map)) @@ -1776,7 +1872,7 @@ unfolded." (while (not (eobp)) (save-restriction (mail-header-narrow-to-field) - (let ((header (buffer-substring (point-min) (point-max)))) + (let ((header (buffer-string))) (with-temp-buffer (insert header) (goto-char (point-min)) @@ -1861,7 +1957,8 @@ unfolded." (while (not (eobp)) (end-of-line) (when (>= (current-column) (min fill-column width)) - (narrow-to-region (min (1+ (point)) (point-max)) (gnus-point-at-bol)) + (narrow-to-region (min (1+ (point)) (point-max)) + (gnus-point-at-bol)) (let ((goback (point-marker))) (fill-paragraph nil) (goto-char (marker-position goback))) @@ -1908,6 +2005,44 @@ unfolded." (forward-line 1) (point)))))) +(defun article-display-face () + "Display any Face headers in the header." + (interactive) + (let ((wash-face-p buffer-read-only)) + (gnus-with-article-headers + ;; When displaying parts, this function can be called several times on + ;; the same article, without any intended toggle semantic (as typing `W + ;; D d' would have). So face deletion must occur only when we come from + ;; an interactive command, that is when the *Article* buffer is + ;; read-only. + (if (and wash-face-p (memq 'face gnus-article-wash-types)) + (gnus-delete-images 'face) + (let (face faces) + (save-excursion + (when (and wash-face-p + (progn + (goto-char (point-min)) + (not (re-search-forward "^Face:[\t ]*" nil t))) + (gnus-buffer-live-p gnus-original-article-buffer)) + (set-buffer gnus-original-article-buffer)) + (save-restriction + (mail-narrow-to-head) + (while (gnus-article-goto-header "Face") + (push (mail-header-field-value) faces)))) + (while (setq face (pop faces)) + (let ((png (gnus-convert-face-to-png face)) + image) + (when png + (setq image (gnus-create-image png 'png t)) + (gnus-article-goto-header "from") + (when (bobp) + (insert "From: [no `from' set]\n") + (forward-char -17)) + (gnus-add-wash-type 'face) + (gnus-add-image 'face image) + (gnus-put-image image nil 'face)))))) + ))) + (defun article-display-x-face (&optional force) "Look for an X-Face header and display it if present." (interactive (list 'force)) @@ -1916,12 +2051,13 @@ unfolded." ;; Delete the old process, if any. (when (process-status "article-x-face") (delete-process "article-x-face")) - (if (memq 'xface gnus-article-wash-types) + ;; See the comment in `article-display-face'. + (if (and wash-face-p (memq 'xface gnus-article-wash-types)) ;; We have already displayed X-Faces, so we remove them ;; instead. (gnus-delete-images 'xface) ;; Display X-Faces. - (let (x-faces from face grey) + (let (x-faces from face) (save-excursion (when (and wash-face-p (progn @@ -1935,67 +2071,41 @@ unfolded." (set-buffer gnus-original-article-buffer)) (save-restriction (mail-narrow-to-head) - (if gnus-treat-display-grey-xface - (progn - (while (gnus-article-goto-header "X-Face\\(-[0-9]+\\)?") - (if (match-beginning 2) - (progn - (setq grey t) - (push (cons (- (string-to-number (match-string 2))) - (mail-header-field-value)) - x-faces)) - (push (cons 0 (mail-header-field-value)) x-faces))) - (dolist (x-face (prog1 - (if grey - (sort x-faces 'car-less-than-car) - (nreverse x-faces)) - (setq x-faces nil))) - (push (cdr x-face) x-faces))) - (while (gnus-article-goto-header "X-Face") - (push (mail-header-field-value) x-faces))) + (while (gnus-article-goto-header "X-Face") + (push (mail-header-field-value) x-faces)) (setq from (message-fetch-field "from")))) - (if grey - (let ((xpm (gnus-convert-gray-x-face-to-xpm x-faces)) - image) - (when xpm - (setq image (gnus-create-image xpm 'xpm t)) - (gnus-article-goto-header "from") - (when (bobp) - (insert "From: [no `from' set]\n") - (forward-char -17)) - (gnus-add-wash-type 'xface) - (gnus-add-image 'xface image) - (gnus-put-image image))) - ;; Sending multiple EOFs to xv doesn't work, so we only do a - ;; single external face. - (when (stringp gnus-article-x-face-command) - (setq x-faces (list (car x-faces)))) - (while (and (setq face (pop x-faces)) - gnus-article-x-face-command - (or force - ;; Check whether this face is censored. - (not gnus-article-x-face-too-ugly) - (and gnus-article-x-face-too-ugly from - (not (string-match gnus-article-x-face-too-ugly - from))))) - ;; We display the face. - (if (symbolp gnus-article-x-face-command) - ;; The command is a lisp function, so we call it. - (if (gnus-functionp gnus-article-x-face-command) - (funcall gnus-article-x-face-command face) - (error "%s is not a function" gnus-article-x-face-command)) - ;; The command is a string, so we interpret the command - ;; as a, well, command, and fork it off. - (let ((process-connection-type nil)) - (process-kill-without-query - (start-process - "article-x-face" nil shell-file-name shell-command-switch - gnus-article-x-face-command)) - (with-temp-buffer - (insert face) - (process-send-region "article-x-face" - (point-min) (point-max))) - (process-send-eof "article-x-face")))))))))) + ;; Sending multiple EOFs to xv doesn't work, so we only do a + ;; single external face. + (when (stringp gnus-article-x-face-command) + (setq x-faces (list (car x-faces)))) + (while (and (setq face (pop x-faces)) + gnus-article-x-face-command + (or force + ;; Check whether this face is censored. + (not gnus-article-x-face-too-ugly) + (and gnus-article-x-face-too-ugly from + (not (string-match gnus-article-x-face-too-ugly + from))))) + ;; We display the face. + (cond ((stringp gnus-article-x-face-command) + ;; The command is a string, so we interpret the command + ;; as a, well, command, and fork it off. + (let ((process-connection-type nil)) + (process-kill-without-query + (start-process + "article-x-face" nil shell-file-name + shell-command-switch gnus-article-x-face-command)) + (with-temp-buffer + (insert face) + (process-send-region "article-x-face" + (point-min) (point-max))) + (process-send-eof "article-x-face"))) + ((functionp gnus-article-x-face-command) + ;; The command is a lisp function, so we call it. + (funcall gnus-article-x-face-command face)) + (t + (error "%s is not a function" + gnus-article-x-face-command))))))))) (defun article-decode-mime-words () "Decode all MIME-encoded words in the article." @@ -2078,20 +2188,60 @@ If PROMPT (the prefix), prompt for a coding system to use." (when (and (or gnus-group-name-charset-method-alist gnus-group-name-charset-group-alist) (gnus-buffer-live-p gnus-original-article-buffer)) - (when (nnmail-fetch-field "Newsgroups") - (nnheader-replace-header "Newsgroups" - (gnus-decode-newsgroups - (with-current-buffer - gnus-original-article-buffer - (nnmail-fetch-field "Newsgroups")) - gnus-newsgroup-name method))) - (when (nnmail-fetch-field "Followup-To") - (nnheader-replace-header "Followup-To" - (gnus-decode-newsgroups - (with-current-buffer - gnus-original-article-buffer - (nnmail-fetch-field "Followup-To")) - gnus-newsgroup-name method)))))) + (save-restriction + (article-narrow-to-head) + (with-current-buffer gnus-original-article-buffer + (goto-char (point-min))) + (while (re-search-forward + "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t) + (replace-match (save-match-data + (gnus-decode-newsgroups + ;; XXX how to use data in article buffer? + (with-current-buffer gnus-original-article-buffer + (re-search-forward + "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" + nil t) + (match-string 1)) + gnus-newsgroup-name method)) + t t nil 1)) + (goto-char (point-min)) + (with-current-buffer gnus-original-article-buffer + (goto-char (point-min))) + (while (re-search-forward + "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t) + (replace-match (save-match-data + (gnus-decode-newsgroups + ;; XXX how to use data in article buffer? + (with-current-buffer gnus-original-article-buffer + (re-search-forward + "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" + nil t) + (match-string 1)) + gnus-newsgroup-name method)) + t t nil 1)))))) + +(autoload 'idna-to-unicode "idna") + +(defun article-decode-idna-rhs () + "Decode IDNA strings in RHS in From:, To: and Cc: headers in current buffer." + (when gnus-use-idna + (save-restriction + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (article-narrow-to-head) + (goto-char (point-min)) + (while (re-search-forward "\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t) + (let (ace unicode) + (when (save-match-data + (and (setq ace (match-string 1)) + (save-excursion + (and (re-search-backward "^[^ \t]" nil t) + (looking-at "From\\|To\\|Cc"))) + (save-excursion (backward-char) + (message-idna-inside-rhs-p)) + (setq unicode (idna-to-unicode ace)))) + (unless (string= ace unicode) + (replace-match unicode nil nil nil 1))))))))) (defun article-de-quoted-unreadable (&optional force read-charset) "Translate a quoted-printable-encoded article. @@ -2177,8 +2327,8 @@ If READ-CHARSET, ask for a coding system." (while (re-search-forward "^\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t) (replace-match "\\1\\3" t))) - (when (and gnus-display-mime-function (interactive-p)) - (funcall gnus-display-mime-function)))) + (when (interactive-p) + (gnus-treat-article nil)))) (defun article-wash-html (&optional read-charset) @@ -2211,7 +2361,7 @@ If READ-CHARSET, ask for a coding system." (when entry (setq func (cdr entry))) (cond - ((gnus-functionp func) + ((functionp func) (funcall func)) (t (apply (car func) (cdr func)))))))))) @@ -2235,7 +2385,6 @@ If READ-CHARSET, ask for a coding system." (let ((w3m-safe-url-regexp (if mm-inline-text-html-with-images nil "\\`cid:")) - (w3m-display-inline-images mm-inline-text-html-with-images) w3m-force-redisplay) (w3m-region (point-min) (point-max))) (when mm-inline-text-html-with-w3m-keymap @@ -2267,42 +2416,6 @@ The `gnus-list-identifiers' variable specifies what to do." "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t) (delete-region (match-beginning 1) (match-end 1)))))))) -(defun article-hide-pgp () - "Remove any PGP headers and signatures in the current article." - (interactive) - (save-excursion - (save-restriction - (let ((inhibit-point-motion-hooks t) - buffer-read-only beg end) - (article-goto-body) - ;; Hide the "header". - (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) - (gnus-add-wash-type 'pgp) - (delete-region (match-beginning 0) (match-end 0)) - ;; Remove armor headers (rfc2440 6.2) - (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t) - (point))) - (setq beg (point)) - ;; Hide the actual signature. - (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) - (setq end (1+ (match-beginning 0))) - (delete-region - end - (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) - (match-end 0) - ;; Perhaps we shouldn't hide to the end of the buffer - ;; if there is no end to the signature? - (point-max)))) - ;; Hide "- " PGP quotation markers. - (when (and beg end) - (narrow-to-region beg end) - (goto-char (point-min)) - (while (re-search-forward "^- " nil t) - (delete-region - (match-beginning 0) (match-end 0))) - (widen)) - (gnus-run-hooks 'gnus-article-hide-pgp-hook)))))) - (defun article-hide-pem (&optional arg) "Toggle hiding of any PEM headers and signatures in the current article. If given a negative prefix, always show; if given a positive prefix, @@ -2331,43 +2444,50 @@ always hide." (match-beginning 0) (match-end 0) 'pem))))))) (defun article-strip-banner () - "Strip the banner specified by the `banner' group parameter." + "Strip the banners specified by the `banner' group parameter and by +`gnus-article-address-banner-alist'." (interactive) + (save-excursion + (save-restriction + (let ((inhibit-point-motion-hooks t)) + (when (gnus-parameter-banner gnus-newsgroup-name) + (article-really-strip-banner + (gnus-parameter-banner gnus-newsgroup-name))) + (when gnus-article-address-banner-alist + (article-really-strip-banner + (let ((from (save-restriction + (widen) + (article-narrow-to-head) + (mail-fetch-field "from")))) + (when (and from + (setq from + (caar (mail-header-parse-addresses from)))) + (catch 'found + (dolist (pair gnus-article-address-banner-alist) + (when (string-match (car pair) from) + (throw 'found (cdr pair))))))))))))) + +(defun article-really-strip-banner (banner) + "Strip the banner specified by the argument." (save-excursion (save-restriction (let ((inhibit-point-motion-hooks t) - (banner (gnus-parameter-banner gnus-newsgroup-name)) (gnus-signature-limit nil) - buffer-read-only beg end) - (when (and gnus-article-address-banner-alist - (not banner)) - (setq banner - (let ((from (save-restriction - (widen) - (article-narrow-to-head) - (mail-fetch-field "from")))) - (when (and from - (setq from - (caar (mail-header-parse-addresses from)))) - (catch 'found - (dolist (pair gnus-article-address-banner-alist) - (when (string-match (car pair) from) - (throw 'found (cdr pair))))))))) - (when banner - (article-goto-body) - (cond - ((eq banner 'signature) - (when (gnus-article-narrow-to-signature) - (widen) - (forward-line -1) - (delete-region (point) (point-max)))) - ((symbolp banner) - (if (setq banner (cdr (assq banner gnus-article-banner-alist))) - (while (re-search-forward banner nil t) - (delete-region (match-beginning 0) (match-end 0))))) - ((stringp banner) - (while (re-search-forward banner nil t) - (delete-region (match-beginning 0) (match-end 0)))))))))) + buffer-read-only) + (article-goto-body) + (cond + ((eq banner 'signature) + (when (gnus-article-narrow-to-signature) + (widen) + (forward-line -1) + (delete-region (point) (point-max)))) + ((symbolp banner) + (if (setq banner (cdr (assq banner gnus-article-banner-alist))) + (while (re-search-forward banner nil t) + (delete-region (match-beginning 0) (match-end 0))))) + ((stringp banner) + (while (re-search-forward banner nil t) + (delete-region (match-beginning 0) (match-end 0))))))))) (defun article-babel () "Translate article using an online translation service." @@ -2515,7 +2635,7 @@ Point is left at the beginning of the narrowed-to region." (< (- (point-max) (point)) limit)) (and (floatp limit) (< (count-lines (point) (point-max)) limit)) - (and (gnus-functionp limit) + (and (functionp limit) (funcall limit)) (and (stringp limit) (not (re-search-forward limit nil t)))) @@ -2717,7 +2837,7 @@ should replace the \"Date:\" one, or should be added below it." gnus-article-time-format) (error nil)) gnus-article-time-format))) - (if (gnus-functionp format) + (if (functionp format) (funcall format time) (concat "Date: " (format-time-string format time))))) ;; ISO 8601. @@ -2827,9 +2947,12 @@ function and want to see what the date was before converting." (lambda (w) (set-buffer (window-buffer w)) (when (eq major-mode 'gnus-article-mode) - (goto-char (point-min)) - (when (re-search-forward "^X-Sent:" nil t) - (article-date-lapsed t)))) + (let ((mark (point-marker))) + (goto-char (point-min)) + (when (re-search-forward "^X-Sent:" nil t) + (article-date-lapsed t)) + (goto-char (marker-position mark)) + (move-marker mark nil)))) nil 'visible))))) (defun gnus-start-date-timer (&optional n) @@ -3088,6 +3211,7 @@ Directory to save to is default to `gnus-article-save-directory'." (save-restriction (widen) (if (and (file-readable-p filename) + (file-regular-p filename) (mail-file-babyl-p filename)) (rmail-output-to-rmail-file filename t) (gnus-output-to-mail filename))))) @@ -3161,9 +3285,17 @@ The directory to save in defaults to `gnus-article-save-directory'." (shell-command-on-region (point-min) (point-max) command nil))) (setq gnus-last-shell-command command)) +(defmacro gnus-read-string (prompt &optional initial-contents history + default-value) + "Like `read-string' but allow for older XEmacsen that don't have the 5th arg." + (if (and (featurep 'xemacs) + (< emacs-minor-version 2)) + `(read-string ,prompt ,initial-contents ,history) + `(read-string ,prompt ,initial-contents ,history ,default-value))) + (defun gnus-summary-pipe-to-muttprint (&optional command) "Pipe this article to muttprint." - (setq command (read-string + (setq command (gnus-read-string "Print using command: " gnus-summary-muttprint-program nil gnus-summary-muttprint-program)) (gnus-summary-save-in-pipe command)) @@ -3245,7 +3377,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is mml2015-use (mml2015-clear-verify-function)) (with-temp-buffer - (insert-buffer gnus-original-article-buffer) + (insert-buffer-substring gnus-original-article-buffer) (setq items (split-string sig)) (message-narrow-to-head) (let ((inhibit-point-motion-hooks t) @@ -3253,7 +3385,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is ;; Don't verify multiple headers. (setq headers (mapconcat (lambda (header) (concat header ": " - (mail-fetch-field header) "\n")) + (mail-fetch-field header) + "\n")) (split-string (nth 1 items) ",") ""))) (delete-region (point-min) (point-max)) (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n") @@ -3342,13 +3475,13 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-remove-cr article-remove-leading-whitespace article-display-x-face + article-display-face article-de-quoted-unreadable article-de-base64-unreadable article-decode-HZ article-wash-html article-unsplit-urls article-hide-list-identifiers - article-hide-pgp article-strip-banner article-babel article-hide-pem @@ -3451,9 +3584,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is (gnus-run-hooks 'gnus-article-menu-hook))) -;; Fixme: do something for the Emacs tool bar in Article mode a la -;; Summary. - (defun gnus-article-mode () "Major mode for displaying an article. @@ -3476,10 +3606,12 @@ commands: (make-local-variable 'minor-mode-alist) (use-local-map gnus-article-mode-map) (when (gnus-visual-p 'article-menu 'menu) - (gnus-article-make-menu-bar)) + (gnus-article-make-menu-bar) + (when gnus-summary-tool-bar-map + (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map))) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) - (make-local-variable 'gnus-page-broken) + (set (make-local-variable 'gnus-page-broken) nil) (make-local-variable 'gnus-button-marker-list) (make-local-variable 'gnus-article-current-summary) (make-local-variable 'gnus-article-mime-handles) @@ -3537,6 +3669,8 @@ commands: (setq gnus-article-mime-handle-alist nil) (buffer-disable-undo) (setq buffer-read-only t) + ;; This list just keeps growing if we don't reset it. + (setq gnus-button-marker-list nil) (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) (current-buffer)) @@ -3595,7 +3729,9 @@ If ALL-HEADERS is non-nil, no headers are hidden." (cons gnus-newsgroup-name article)) (set-buffer gnus-summary-buffer) (setq gnus-current-article article) - (if (memq article gnus-newsgroup-undownloaded) + (if (and (memq article gnus-newsgroup-undownloaded) + (not (gnus-online (gnus-find-method-for-group + gnus-newsgroup-name)))) (progn (gnus-summary-set-agent-mark article) (message "Message marked for downloading")) @@ -3659,10 +3795,8 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-article-prepare-display) ;; Do page break. (goto-char (point-min)) - (setq gnus-page-broken - (when gnus-break-pages - (gnus-narrow-to-page) - t))) + (when gnus-break-pages + (gnus-narrow-to-page))) (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) (gnus-set-mode-line 'article)) @@ -3725,13 +3859,14 @@ General format specifiers can also be used. See Info node (gnus-mime-view-part-as-charset "C" "View As charset...") (gnus-mime-save-part "o" "Save...") (gnus-mime-save-part-and-strip "\C-o" "Save and Strip") + (gnus-mime-delete-part "d" "Delete part") (gnus-mime-copy-part "c" "View As Text, In Other Buffer") (gnus-mime-inline-part "i" "View As Text, In This Buffer") (gnus-mime-view-part-internally "E" "View Internally") (gnus-mime-view-part-externally "e" "View Externally") (gnus-mime-print-part "p" "Print") (gnus-mime-pipe-part "|" "Pipe To Command...") - (gnus-mime-action-on-part "." "Take action on the part"))) + (gnus-mime-action-on-part "." "Take action on the part..."))) (defun gnus-article-mime-part-status () (if gnus-article-mime-handle-alist-1 @@ -3751,21 +3886,38 @@ General format specifiers can also be used. See Info node (define-key map (cadr c) (car c))) map)) -(defun gnus-mime-button-menu (event) - "Construct a context-sensitive menu of MIME commands." - (interactive "e") - (save-window-excursion - (let ((pos (event-start event))) - (select-window (posn-window pos)) - (goto-char (posn-point pos)) - (gnus-article-check-buffer) - (let ((response (x-popup-menu - t `("MIME Part" - ("" ,@(mapcar (lambda (c) - (cons (caddr c) (car c))) - gnus-mime-button-commands)))))) - (if response - (call-interactively response)))))) +(easy-menu-define + gnus-mime-button-menu gnus-mime-button-map "MIME button menu." + `("MIME Part" + ,@(mapcar (lambda (c) + (vector (caddr c) (car c) :enable t)) + gnus-mime-button-commands))) + +(eval-when-compile + (define-compiler-macro popup-menu (&whole form + menu &optional position prefix) + (if (and (fboundp 'popup-menu) + (not (memq 'popup-menu (assoc "lmenu" load-history)))) + form + ;; Gnus is probably running under Emacs 20. + `(let* ((menu (cdr ,menu)) + (response (x-popup-menu + t (list (car menu) + (cons "" (mapcar (lambda (c) + (cons (caddr c) (car c))) + (cdr menu))))))) + (if response + (call-interactively (nth 3 (assq response menu)))))))) + +(defun gnus-mime-button-menu (event prefix) + "Construct a context-sensitive menu of MIME commands." + (interactive "e\nP") + (save-window-excursion + (let ((pos (event-start event))) + (select-window (posn-window pos)) + (goto-char (posn-point pos)) + (gnus-article-check-buffer) + (popup-menu gnus-mime-button-menu nil prefix)))) (defun gnus-mime-view-all-parts (&optional handles) "View all the MIME parts." @@ -3827,9 +3979,7 @@ General format specifiers can also be used. See Info node (let ((mbl1 mml-buffer-list)) (setq mml-buffer-list mbl) (set (make-local-variable 'mml-buffer-list) mbl1)) - ;; LOCAL argument of add-hook differs between GNU Emacs - ;; and XEmacs. make-local-hook makes sure they are local. - (make-local-hook 'kill-buffer-hook) + (gnus-make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) `(lambda (no-highlight) (let ((mail-parse-charset (or gnus-article-charset @@ -3849,6 +3999,88 @@ General format specifiers can also be used. See Info node ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)))))) +(defun gnus-mime-delete-part () + "Delete the MIME part under point. +Replace it with some information about the removed part." + (interactive) + (gnus-article-check-buffer) + (unless (and gnus-novice-user + (not (gnus-yes-or-no-p + "Really delete attachment forever? "))) + (let* ((data (get-text-property (point) 'gnus-data)) + (handles gnus-article-mime-handles) + (none "(none)") + (description + (or + (mail-decode-encoded-word-string (or (mm-handle-description data) + none)))) + (filename + (or (mail-content-type-get (mm-handle-disposition data) 'filename) + none)) + (type (mm-handle-media-type data))) + (if (mm-multiple-handles gnus-article-mime-handles) + (error "This function is not implemented")) + (with-current-buffer (mm-handle-buffer data) + (let ((bsize (format "%s" (buffer-size)))) + (erase-buffer) + (insert + (concat + ",----\n" + "| The following attachment has been deleted:\n" + "|\n" + "| Type: " type "\n" + "| Filename: " filename "\n" + "| Size (encoded): " bsize " Byte\n" + "| Description: " description "\n" + "`----\n")) + (setcdr data + (cdr (mm-make-handle + nil `("text/plain") nil nil + (list "attachment") + (format "Deleted attachment (%s bytes)" bsize)))))) + (set-buffer gnus-summary-buffer) + ;; FIXME: maybe some of the following code (borrowed from + ;; `gnus-mime-save-part-and-strip') isn't necessary? + (gnus-article-edit-article + `(lambda () + (erase-buffer) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets)) + (mbl mml-buffer-list)) + (setq mml-buffer-list nil) + (insert-buffer gnus-original-article-buffer) + (mime-to-mml ',handles) + (setq gnus-article-mime-handles nil) + (let ((mbl1 mml-buffer-list)) + (setq mml-buffer-list mbl) + (set (make-local-variable 'mml-buffer-list) mbl1)) + (gnus-make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) + `(lambda (no-highlight) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (message-options message-options) + (message-options-set-recipient) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets))) + (mml-to-mime) + (mml-destroy-buffers) + (remove-hook 'kill-buffer-hook + 'mml-destroy-buffers t) + (kill-local-variable 'mml-buffer-list)) + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) + ,gnus-summary-buffer no-highlight))))) + ;; Not in `gnus-mime-save-part-and-strip': + (gnus-article-edit-done) + (gnus-summary-expand-window) + (gnus-summary-show-article)) + (defun gnus-mime-save-part () "Save the MIME part under point." (interactive) @@ -3931,7 +4163,7 @@ The uncompress method used is derived from `buffer-file-name'." (message "%s %s..." message basename)) (unwind-protect (unless (memq (apply 'call-process-region - (point-min) (point-max) + (point-min) (point-max) prog t (list t err-file) nil args) @@ -3940,7 +4172,9 @@ The uncompress method used is derived from `buffer-file-name'." (jka-compr-delete-temp-file err-file))))))) (defun gnus-mime-copy-part (&optional handle) - "Put the MIME part under point into a new buffer." + "Put the MIME part under point into a new buffer. +If `auto-compression-mode' is enabled, compressed files like .gz and .bz2 +are decompressed." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) @@ -3972,13 +4206,12 @@ The uncompress method used is derived from `buffer-file-name'." (let* ((handle (or handle (get-text-property (point) 'gnus-data))) (contents (and handle (mm-get-part handle))) (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory))) - (printer (mailcap-mime-info (mm-handle-type handle) "print"))) + (printer (mailcap-mime-info (mm-handle-media-type handle) "print"))) (when contents (if printer (unwind-protect (progn - (with-temp-file file - (insert contents)) + (mm-save-part-to-file handle file) (call-process shell-file-name nil (generate-new-buffer " *mm*") nil @@ -4071,7 +4304,8 @@ If no internal viewer is available, use an external viewer." (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) + gnus-newsgroup-ignored-charsets)) + buffer-read-only) (when handle (if (mm-handle-undisplayer handle) (mm-remove-part handle) @@ -4080,7 +4314,7 @@ If no internal viewer is available, use an external viewer." (defun gnus-mime-action-on-part (&optional action) "Do something with the MIME attachment at \(point\)." (interactive - (list (completing-read "Action: " gnus-mime-action-alist))) + (list (completing-read "Action: " gnus-mime-action-alist nil t))) (gnus-article-check-buffer) (let ((action-pair (assoc action gnus-mime-action-alist))) (if action-pair @@ -4116,7 +4350,8 @@ If no internal viewer is available, use an external viewer." (gnus-article-part-wrapper n 'gnus-mime-copy-part)) (defun gnus-article-view-part-as-charset (n) - "Copy MIME part N, which is the numerical prefix." + "View MIME part N using a specified charset. +N is the numerical prefix." (interactive "p") (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset)) @@ -4213,16 +4448,14 @@ If no internal viewer is available, use an external viewer." (if (window-live-p window) (select-window window))))) (goto-char point) - (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point))) + (gnus-delete-line) (gnus-insert-mime-button handle id (list (mm-handle-displayed-p handle))) (goto-char point)))) (defun gnus-article-goto-part (n) "Go to MIME part N." - (let ((point (text-property-any (point-min) (point-max) 'gnus-part n))) - (when point - (goto-char point)))) + (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n))) (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) (let ((gnus-tmp-name @@ -4258,7 +4491,10 @@ If no internal viewer is available, use an external viewer." gnus-part ,gnus-tmp-id article-type annotation gnus-data ,handle)) - (setq e (point)) + (setq e (if (bolp) + ;; Exclude a newline. + (1- (point)) + (point))) (widget-convert-button 'link b e :mime-handle handle @@ -4301,9 +4537,10 @@ If no internal viewer is available, use an external viewer." ;; We have to do this since selecting the window ;; may change the point. So we set the window point. (set-window-point window point))) - (let* ((handles (or ihandles (mm-dissect-buffer - nil gnus-article-loose-mime) - (mm-uu-dissect))) + (let* ((handles (or ihandles + (mm-dissect-buffer nil gnus-article-loose-mime) + (and gnus-article-emulate-mime + (mm-uu-dissect)))) buffer-read-only handle name type b e display) (when (and (not ihandles) (not gnus-displaying-mime)) @@ -4339,9 +4576,28 @@ If no internal viewer is available, use an external viewer." (narrow-to-region (point-min) (point)) (gnus-treat-article 'head)))))))) -(defvar gnus-mime-display-multipart-as-mixed nil) -(defvar gnus-mime-display-multipart-alternative-as-mixed nil) -(defvar gnus-mime-display-multipart-related-as-mixed nil) +(defcustom gnus-mime-display-multipart-as-mixed nil + "Display \"multipart\" parts as \"multipart/mixed\". + +If t, it overrides nil values of +`gnus-mime-display-multipart-alternative-as-mixed' and +`gnus-mime-display-multipart-related-as-mixed'." + :group 'gnus-article-mime + :type 'boolean) + +(defcustom gnus-mime-display-multipart-alternative-as-mixed nil + "Display \"multipart/alternative\" parts as \"multipart/mixed\"." + :group 'gnus-article-mime + :type 'boolean) + +(defcustom gnus-mime-display-multipart-related-as-mixed nil + "Display \"multipart/related\" parts as \"multipart/mixed\". + +If displaying \"text/html\" is discouraged \(see +`mm-discouraged-alternatives'\) images or other material inside a +\"multipart/related\" part might be overlooked when this variable is nil." + :group 'gnus-article-mime + :type 'boolean) (defun gnus-mime-display-part (handle) (cond @@ -4642,7 +4898,7 @@ is the string to use when it is inactive.") "Delete all images in CATEGORY." (let ((entry (assq category gnus-article-image-alist))) (dolist (image (cdr entry)) - (gnus-remove-image image)) + (gnus-remove-image image category)) (setq gnus-article-image-alist (delq entry gnus-article-image-alist)) (gnus-delete-wash-type category))) @@ -4686,27 +4942,32 @@ If given a numerical ARG, move forward ARG pages." (let ((buffer-read-only nil)) (gnus-remove-text-with-property 'gnus-prev) (gnus-remove-text-with-property 'gnus-next))) - (when + (if (cond ((< arg 0) (re-search-backward page-delimiter nil 'move (1+ (abs arg)))) ((> arg 0) (re-search-forward page-delimiter nil 'move arg))) - (goto-char (match-end 0))) - (narrow-to-region - (point) - (if (re-search-forward page-delimiter nil 'move) - (match-beginning 0) - (point))) - (when (and (gnus-visual-p 'page-marker) - (not (= (point-min) 1))) + (goto-char (match-end 0)) (save-excursion (goto-char (point-min)) - (gnus-insert-prev-page-button))) - (when (and (gnus-visual-p 'page-marker) - (< (+ (point-max) 2) (buffer-size))) - (save-excursion - (goto-char (point-max)) - (gnus-insert-next-page-button))))) + (setq gnus-page-broken + (and (re-search-forward page-delimiter nil t) t)))) + (when gnus-page-broken + (narrow-to-region + (point) + (if (re-search-forward page-delimiter nil 'move) + (match-beginning 0) + (point))) + (when (and (gnus-visual-p 'page-marker) + (not (= (point-min) 1))) + (save-excursion + (goto-char (point-min)) + (gnus-insert-prev-page-button))) + (when (and (gnus-visual-p 'page-marker) + (< (+ (point-max) 2) (buffer-size))) + (save-excursion + (goto-char (point-max)) + (gnus-insert-next-page-button)))))) ;; Article mode commands @@ -4717,12 +4978,28 @@ If given a numerical ARG, move forward ARG pages." (goto-char (point-min)) (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) + (defun gnus-article-goto-prev-page () - "Show the next page of the article." + "Show the previous page of the article." (interactive) - (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) + (if (bobp) + (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) (gnus-article-prev-page nil))) +;; This is cleaner but currently breaks `gnus-pick-mode': +;; +;; (defun gnus-article-goto-next-page () +;; "Show the next page of the article." +;; (interactive) +;; (gnus-eval-in-buffer-window gnus-summary-buffer +;; (gnus-summary-next-page))) +;; +;; (defun gnus-article-goto-prev-page () +;; "Show the next page of the article." +;; (interactive) +;; (gnus-eval-in-buffer-window gnus-summary-buffer +;; (gnus-summary-prev-page))) + (defun gnus-article-next-page (&optional lines) "Show the next page of the current article. If end of article, return non-nil. Otherwise return nil. @@ -4737,20 +5014,27 @@ Argument LINES specifies lines to be scrolled up." (if (or (not gnus-page-broken) (save-excursion (save-restriction - (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer? - t ;Nothing more. + (widen) + (eobp)))) ;Real end-of-buffer? + (progn + (when gnus-article-over-scroll + (gnus-article-next-page-1 lines)) + t) ;Nothing more. (gnus-narrow-to-page 1) ;Go to next page. nil) ;; More in this page. - (let ((scroll-in-place nil)) - (condition-case () - (scroll-up lines) - (end-of-buffer - ;; Long lines may cause an end-of-buffer error. - (goto-char (point-max))))) - (move-to-window-line 0) + (gnus-article-next-page-1 lines) nil)) +(defun gnus-article-next-page-1 (lines) + (let ((scroll-in-place nil)) + (condition-case () + (scroll-up lines) + (end-of-buffer + ;; Long lines may cause an end-of-buffer error. + (goto-char (point-max))))) + (move-to-window-line 0)) + (defun gnus-article-prev-page (&optional lines) "Show previous page of current article. Argument LINES specifies lines to be scrolled down." @@ -4771,17 +5055,33 @@ Argument LINES specifies lines to be scrolled down." (goto-char (point-min)))) (move-to-window-line 0))))) +(defun gnus-article-only-boring-p () + "Decide whether there is only boring text remaining in the article. +Something \"interesting\" is a word of at least two letters that does +not have a face in `gnus-article-boring-faces'." + (when (and gnus-article-skip-boring + (boundp 'gnus-article-boring-faces) + (symbol-value 'gnus-article-boring-faces)) + (save-excursion + (catch 'only-boring + (while (re-search-forward "\\b\\w\\w" nil t) + (forward-char -1) + (when (not (gnus-intersection + (gnus-faces-at (point)) + (symbol-value 'gnus-article-boring-faces))) + (throw 'only-boring nil))) + (throw 'only-boring t))))) + (defun gnus-article-refer-article () "Read article specified by message-id around point." (interactive) - (let ((point (point))) - (search-forward ">" nil t) ;Move point to end of "<....>". - (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t) - (let ((message-id (match-string 1))) - (goto-char point) + (save-excursion + (re-search-backward "[ \t]\\|^" (gnus-point-at-bol) t) + (re-search-forward "]+" (gnus-point-at-eol) t) + (let ((msg-id (concat "<" (match-string 0) ">"))) (set-buffer gnus-summary-buffer) - (gnus-summary-refer-article message-id)) - (goto-char (point)) + (gnus-summary-refer-article msg-id)) (error "No references around point")))) (defun gnus-article-show-summary () @@ -4949,46 +5249,47 @@ Argument LINES specifies lines to be scrolled down." The text in the region will be yanked. If the region isn't active, the entire article will be yanked." (interactive "P") - (let ((article (cdr gnus-article-current)) cont) - (if (not (mark t)) + (let ((article (cdr gnus-article-current)) + contents) + (if (not (gnus-mark-active-p)) (with-current-buffer gnus-summary-buffer (gnus-summary-reply (list (list article)) wide)) - (setq cont (buffer-substring (point) (mark t))) + (setq contents (buffer-substring (point) (mark t))) ;; Deactivate active regions. (when (and (boundp 'transient-mark-mode) transient-mark-mode) (setq mark-active nil)) (with-current-buffer gnus-summary-buffer (gnus-summary-reply - (list (list article cont)) wide))))) + (list (list article contents)) wide))))) (defun gnus-article-followup-with-original () "Compose a followup to the current article. The text in the region will be yanked. If the region isn't active, the entire article will be yanked." (interactive) - (let ((article (cdr gnus-article-current)) cont) - (if (not (mark t)) + (let ((article (cdr gnus-article-current)) + contents) + (if (not (gnus-mark-active-p)) (with-current-buffer gnus-summary-buffer (gnus-summary-followup (list (list article)))) - (setq cont (buffer-substring (point) (mark t))) + (setq contents (buffer-substring (point) (mark t))) ;; Deactivate active regions. (when (and (boundp 'transient-mark-mode) transient-mark-mode) (setq mark-active nil)) (with-current-buffer gnus-summary-buffer (gnus-summary-followup - (list (list article cont))))))) + (list (list article contents))))))) (defun gnus-article-hide (&optional arg force) "Hide all the gruft in the current article. -This means that PGP stuff, signatures, cited text and (some) -headers will be hidden. +This means that signatures, cited text and (some) headers will be +hidden. If given a prefix, show the hidden text instead." (interactive (append (gnus-article-hidden-arg) (list 'force))) (gnus-article-hide-headers arg) (gnus-article-hide-list-identifiers arg) - (gnus-article-hide-pgp arg) (gnus-article-hide-citation-maybe arg force) (gnus-article-hide-signature arg)) @@ -5099,9 +5400,7 @@ If given a prefix, show the hidden text instead." (gnus-cache-request-article article group)) 'article) ;; Check the agent cache. - ((and gnus-agent gnus-agent-cache gnus-plugged - (numberp article) - (gnus-agent-request-article article group)) + ((gnus-agent-request-article article group) 'article) ;; Get the article and put into the article buffer. ((or (stringp article) @@ -5223,7 +5522,7 @@ If given a prefix, show the hidden text instead." "\C-c\C-f\C-k" message-goto-keywords "\C-c\C-f\C-u" message-goto-summary "\C-c\C-f\C-i" message-insert-or-toggle-importance - "\C-c\C-f\C-a" message-gen-unsubscribed-mft + "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to "\C-c\C-b" message-goto-body "\C-c\C-i" message-goto-signature @@ -5340,7 +5639,8 @@ groups." (set-window-configuration winconf) (set-buffer buf) (set-window-start (get-buffer-window buf) start) - (set-window-point (get-buffer-window buf) (point)))) + (set-window-point (get-buffer-window buf) (point))) + (gnus-summary-show-article)) (defun gnus-article-edit-exit () "Exit the article editing without updating." @@ -5361,7 +5661,8 @@ groups." (save-current-buffer (set-buffer curbuf) (set-window-start (get-buffer-window (current-buffer)) window-start) - (goto-char p)))))) + (goto-char p)))) + (gnus-summary-show-article))) (defun gnus-article-edit-full-stops () "Interactively repair spacing at end of sentences." @@ -5382,20 +5683,14 @@ groups." (defcustom gnus-button-url-regexp (if (string-match "[[:digit:]]" "1") ;; support POSIX? - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~`%&*+|\\/:;.,[:word:]]+[-a-z0-9_=#$@~`%&*+|\\/[:word:]]\\)" - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)") + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~%&*+\\/:;.,[:word:]]+[-a-z0-9_=#$@~%&*+\\/[:word:]]\\)" + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)\\)") "Regular expression that matches URLs." :group 'gnus-article-buttons :type 'regexp) (defcustom gnus-button-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? - "\\)") + message-valid-fqdn-regexp "Regular expression that matches a valid FQDN." :group 'gnus-article-buttons :type 'regexp) @@ -5434,65 +5729,194 @@ The function must take one argument, the string naming the URL." :type '(choice (const "^/?tex-archive/\\|/") (regexp :tag "Other"))) +(defcustom gnus-button-ctan-directory-regexp + (concat + "\\("; Cannot use `\(?: ... \)' (compatibility with Emacs 20). + "biblio\\|digests\\|dviware\\|fonts\\|graphics\\|help\\|" + "indexing\\|info\\|language\\|macros\\|support\\|systems\\|" + "tds\\|tools\\|usergrps\\|web\\|nonfree\\|obsolete" + "\\)") + "Regular expression for ctan directories. +It should match all directories in the top level of `gnus-ctan-url'." + :group 'gnus-article-buttons + :type 'regexp) + (defcustom gnus-button-mid-or-mail-regexp - (concat "\\b\\(\")!;:,{}\n\t ]*@" + (concat "\\b\\(\")!;:,{}\n\t ]*@" + ;; Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de> gnus-button-valid-fqdn-regexp ">?\\)\\b") "Regular expression that matches a message ID or a mail address." :group 'gnus-article-buttons :type 'regexp) -(defcustom gnus-button-prefer-mid-or-mail 'guess - "What to do when the button on a string as \"foo123@bar.com\" is pushed. -Strings like this can be either a message ID or a mail address. If the -variable is set to the symbol `ask', query the user what do do. If it is the -symbol `guess', Gnus will do a guess and query the user what do do if it is -ambiguous. See the variable `gnus-button-guessed-mid-regexp' for details -concerning the guessing. If it is one of the sybols `mid' or `mail', Gnus -will always assume that the string is a message ID or a mail address, -respectivly." - ;; FIXME: doc-string could/should be improved. +(defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic + "What to do when the button on a string as \"foo123@bar.invalid\" is pushed. +Strings like this can be either a message ID or a mail address. If it is one +of the symbols `mid' or `mail', Gnus will always assume that the string is a +message ID or a mail address, respectively. If this variable is set to the +symbol `ask', always query the user what do do. If it is a function, this +function will be called with the string as it's only argument. The function +must return `mid', `mail', `invalid' or `ask'." :group 'gnus-article-buttons - :type '(choice (const ask) - (const guess) + :type '(choice (function-item :tag "Heuristic function" + gnus-button-mid-or-mail-heuristic) + (const ask) (const mid) (const mail))) -(defcustom gnus-button-guessed-mid-regexp - (concat - "^. I.e. translate the - ;; Perl-REs to Elisp-REs. +(defcustom gnus-button-mid-or-mail-heuristic-alist + '((-10.0 . ".+\\$.+@") + (-10.0 . "#") + (-10.0 . "\\*") + (-5.0 . "\\+[^+]*\\+.*@") ;; # two plus signs + (-5.0 . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i + (-5.0 . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i; + (-1.0 . "^[^a-z]+@") + ;; + (-5.0 . "\\.[0-9][0-9]+.*@") ;; "\.[0-9]{2,}.*\@" + (-5.0 . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@" + (-3.0 . "[A-Z][A-Z][a-z][a-z].*@") + (-5.0 . "\\...?.?@") ;; (-5.0 . "\..{1,3}\@") + ;; + (-2.0 . "^[0-9]") + (-1.0 . "^[0-9][0-9]") + ;; + ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/; + (-3.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") + ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/; + (-5.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") + ;; + (-3.0 . "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@" + (-3.0 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@") + ;; "[0-9]{8,}.*\@" + (-3.0 + . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@") + ;; "[0-9]{12,}.*\@" + ;; compensation for TDMA dated mail addresses: + (25.0 . "-dated-[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]+.*@") + ;; + (-20.0 . "\\.fsf@") ;; Gnus + (-20.0 . "^slrn") + (-20.0 . "^Pine") + (-20.0 . "_-_") ;; Subject change in thread + ;; + (-20.0 . "\\.ln@") ;; leafnode + (-30.0 . "@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de") + (-30.0 . "@4[Aa][Xx]\\.com") ;; Forte Agent + ;; + ;; (5.0 . "") ;; $local_part_len <= 7 + (10.0 . "^[^0-9]+@") + (3.0 . "^[^0-9]+[0-9][0-9]?[0-9]?@") + ;; ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part + (3.0 . "\@stud") + ;; + (2.0 . "[a-z][a-z][._-][A-Z][a-z].*@") + ;; + (0.5 . "^[A-Z][a-z]") + (0.5 . "^[A-Z][a-z][a-z]") + (1.5 . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3} + (2.0 . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4} + "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'. + +A negative RATE indicates a message IDs, whereas a positive indicates a mail +address. The REGEXP is processed with `case-fold-search' set to nil." :group 'gnus-article-buttons - :type 'regexp) + :type '(repeat (cons (number :tag "Rate") + (regexp :tag "Regexp")))) + +(defun gnus-button-mid-or-mail-heuristic (mid-or-mail) + "Guess whether MID-OR-MAIL is a message ID or a mail address. +Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail +address, `ask' if unsure and `invalid' if the string is invalid." + (let ((case-fold-search nil) + (list gnus-button-mid-or-mail-heuristic-alist) + (result 0) rate regexp lpartlen elem) + (setq lpartlen + (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1"))) + (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen) + ;; Certain special cases... + (when (string-match + (concat + "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$" "\\|" + "^[0-9]+\.[0-9]+\@compuserve") + mid-or-mail) + (gnus-message 8 "`%s' is a known mail address.") + (setq result 'mail)) + (when (string-match "@.*@\\| " mid-or-mail) + (gnus-message 8 "`%s' is invalid.") + (setq result 'invalid)) + ;; Nothing more to do, if result is not a number here... + (when (numberp result) + (while list + (setq elem (car list) + rate (car elem) + regexp (cdr elem) + list (cdr list)) + (when (string-match regexp mid-or-mail) + (setq result (+ result rate)) + (gnus-message + 9 "`%s' matched `%s', rate `%s', result `%s'." + mid-or-mail regexp rate result))) + (when (<= lpartlen 7) + (setq result (+ result 5.0)) + (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'." + mid-or-mail result)) + (when (>= lpartlen 12) + (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail) + (cond + ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail) + ;; Long local part should contain realname if e-mail address, + ;; too many digits: message-id. + ;; $score -= 5.0 + 0.1 * $local_part_len; + (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen)))) + (setq result (+ result rate)) + (gnus-message + 9 "Many digits in `%s', rate `%s', result `%s'." + mid-or-mail rate result)) + ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@" + mid-or-mail) + ;; Too few vowels [^aeiouy]{4,}.*\@ + (setq result (+ result -5.0)) + (gnus-message + 9 "Few vowels in `%s', rate `%s', result `%s'." + mid-or-mail -5.0 result)) + (t + (setq result (+ result 5.0)) + (gnus-message + 9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result))))) + (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result) + (cond + ;; Maybe we should make this a customizable alist: (condition . 'result) + ((< result -10.0) 'mid) + ((> result 10.0) 'mail) + (t 'ask)))) (defun gnus-button-handle-mid-or-mail (mid-or-mail) - (let* ((pref gnus-button-prefer-mid-or-mail) + (let* ((pref gnus-button-prefer-mid-or-mail) guessed (url-mid (concat "news" ":" mid-or-mail)) (url-mailto (concat "mailto" ":" mid-or-mail))) (gnus-message 9 "mid-or-mail=%s" mid-or-mail) - ;; If it looks like a MID (well known readers or servers) use 'mid, - ;; otherwise 'ask the user. - (if (eq pref 'guess) - (if (string-match gnus-button-guessed-mid-regexp mid-or-mail) - (setq pref 'mid) - (setq pref 'ask))) + (when (fboundp pref) + (setq guessed + ;; get rid of surrounding angles... + (funcall pref + (gnus-replace-in-string mid-or-mail "^<\\|>$" ""))) + (if (or (eq 'mid guessed) (eq 'mail guessed)) + (setq pref guessed) + (setq pref 'ask))) (if (eq pref 'ask) (save-window-excursion (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? ")) (setq pref 'mail) (setq pref 'mid)))) (cond ((eq pref 'mid) - (gnus-message 9 "calling `gnus-button-handle-news' %s" url-mid) + (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid) (gnus-button-handle-news url-mid)) ((eq pref 'mail) - (gnus-message 9 "calling `gnus-url-mailto' %s" url-mailto) - (gnus-url-mailto url-mailto))))) + (gnus-message 8 "calling `gnus-url-mailto' %s" url-mailto) + (gnus-url-mailto url-mailto)) + (t (gnus-message 3 "Invalid string."))))) (defun gnus-button-handle-custom (url) "Follow a Custom URL." @@ -5500,45 +5924,69 @@ respectivly." (defvar gnus-button-handle-describe-prefix "^\\(C-h\\|?\\)") +;; FIXME: Maybe we should merge some of the functions that do quite similar +;; stuff? + (defun gnus-button-handle-describe-function (url) - "Call describe-function when pushing the corresponding URL button." + "Call `describe-function' when pushing the corresponding URL button." (describe-function (intern (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))) (defun gnus-button-handle-describe-variable (url) - "Call describe-variable when pushing the corresponding URL button." + "Call `describe-variable' when pushing the corresponding URL button." (describe-variable (intern (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))) -;; FIXME: Is is possible to implement this? Else it should be removed here -;; and in `gnus-button-alist'. +(defun gnus-button-handle-symbol (url) +"Display help on variable or function. +Calls `describe-variable' or `describe-function'." + (let ((sym (intern url))) + (cond + ((fboundp sym) (describe-function sym)) + ((boundp sym) (describe-variable sym)) + (t (gnus-message 3 "`%s' is not a known function of variable." url))))) + (defun gnus-button-handle-describe-key (url) - "Call describe-key when pushing the corresponding URL button." - (error "not implemented")) + "Call `describe-key' when pushing the corresponding URL button." + (let* ((key-string + (gnus-replace-in-string url gnus-button-handle-describe-prefix "")) + (keys (ignore-errors (eval `(kbd ,key-string))))) + (if keys + (describe-key keys) + (gnus-message 3 "Invalid key sequence in button: %s" key-string)))) (defun gnus-button-handle-apropos (url) - "Call apropos when pushing the corresponding URL button." + "Call `apropos' when pushing the corresponding URL button." (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) (defun gnus-button-handle-apropos-command (url) - "Call apropos when pushing the corresponding URL button." + "Call `apropos' when pushing the corresponding URL button." (apropos-command (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) (defun gnus-button-handle-apropos-variable (url) - "Call apropos when pushing the corresponding URL button." + "Call `apropos' when pushing the corresponding URL button." (funcall (if (fboundp 'apropos-variable) 'apropos-variable 'apropos) (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) (defun gnus-button-handle-apropos-documentation (url) - "Call apropos when pushing the corresponding URL button." + "Call `apropos' when pushing the corresponding URL button." (funcall (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos) (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) +(defun gnus-button-handle-library (url) + "Call `locate-library' when pushing the corresponding URL button." + (gnus-message 9 "url=`%s'" url) + (let* ((lib (locate-library url)) + (file (gnus-replace-in-string (or lib "") "\.elc" ".el"))) + (if (not lib) + (gnus-message 1 "Cannot locale library `%s'." url) + (find-file-read-only file)))) + (defun gnus-button-handle-ctan (url) "Call `browse-url' when pushing a CTAN URL button." (funcall @@ -5551,7 +5999,7 @@ respectivly." "*Integer that says how many TeX-related buttons Gnus will show. The higher the number, the more buttons will appear and the more false positives are possible. Note that you can set this variable local to -specifific groups. Setting it higher in TeX groups is probably a good idea. +specific groups. Setting it higher in TeX groups is probably a good idea. See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on how to set variables in specific groups." :group 'gnus-article-buttons @@ -5562,7 +6010,7 @@ how to set variables in specific groups." "*Integer that says how many man-related buttons Gnus will show. The higher the number, the more buttons will appear and the more false positives are possible. Note that you can set this variable local to -specifific groups. Setting it higher in Unix groups is probably a good idea. +specific groups. Setting it higher in Unix groups is probably a good idea. See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on how to set variables in specific groups." :group 'gnus-article-buttons @@ -5573,43 +6021,81 @@ how to set variables in specific groups." "*Integer that says how many emacs-related buttons Gnus will show. The higher the number, the more buttons will appear and the more false positives are possible. Note that you can set this variable local to -specifific groups. Setting it higher in Emacs or Gnus related groups is +specific groups. Setting it higher in Emacs or Gnus related groups is probably a good idea. See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on how to set variables in specific groups." :group 'gnus-article-buttons :link '(custom-manual "(gnus)Group Parameters") :type 'integer) -(defcustom gnus-button-mail-level 5 - "*Integer that says how many buttons for message IDs or mail addresses will appear. +(defcustom gnus-button-message-level 5 + "*Integer that says how many buttons for news or mail messages will appear. +The higher the number, the more buttons will appear and the more false +positives are possible." + ;; mail addresses, MIDs, URLs for news, ... + :group 'gnus-article-buttons + :type 'integer) + +(defcustom gnus-button-browse-level 5 + "*Integer that says how many buttons for browsing will appear. The higher the number, the more buttons will appear and the more false positives are possible." + ;; stuff handled by `browse-url' or `gnus-button-embedded-url' :group 'gnus-article-buttons :type 'integer) (defcustom gnus-button-alist '(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" - 0 t gnus-button-handle-news 3) + 0 (>= gnus-button-message-level 0) gnus-button-handle-news 3) ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-handle-news 2) - ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" - 1 t - gnus-button-fetch-group 4) - ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2) - ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 - t gnus-button-message-id 3) - ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 2) - ("mailto:\\([-a-z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1) - ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) + ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" + 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5) + ("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)" + 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3) + ;; RFC 2392 (Don't allow `/' in domain part --> CID) + ("\\bmid:\\(//\\)?\\([^'\">\n\t ]+@[^'\">\n\t /]+\\)" + 0 (>= gnus-button-message-level 0) gnus-button-message-id 2) + ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" + 2 (>= gnus-button-message-level 0) gnus-button-message-id 3) + ("\\( \n\t]+\\)>" + 0 (>= gnus-button-message-level 0) gnus-url-mailto 2) + ;; RFC 2368 (The mailto URL scheme) + ("mailto:\\([-a-z.@_+0-9%=?&]+\\)" + 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) + ("\\bmailto:\\([^ \n\t]+\\)" + 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) ;; CTAN - ("\\bCTAN:[ \t\n]*\\([^>)!;:,\n\t ]*\\)" 0 (>= gnus-button-tex-level 1) - gnus-button-handle-ctan 1) - ;; This is info - ("\\binfo:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 - (>= gnus-button-emacs-level 1) gnus-button-handle-info 2) + ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\(" + gnus-button-ctan-directory-regexp + "[^][>)!;:,'\n\t ]+\\)") + 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1) + ((concat "\\btex-archive/\\(" + gnus-button-ctan-directory-regexp + "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)") + 1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1) + ((concat + "\\b\\(" + gnus-button-ctan-directory-regexp + "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)") + 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1) + ;; This is info (home-grown style) + ("\\binfo://\\([^'\">\n\t ]+\\)" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1) + ;; Info GNOME style + ("\\binfo:\\([^('\n\t\r \"><][^'\n\t\r \"><]*\\)" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1) + ;; Info KDE style + ("<\\(info:\\(([^)]+)[^>\n\r]*\\)\\)>" + 1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2) + ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0 + (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2) + ("\\b\\(C-h\\|?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET" + ;; Info links like `C-h i d m CC Mode RET' + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2) ;; This is custom - ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 - (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2) + ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)" + 0 (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2) ("M-x[ \t\n]customize-[^ ]+[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1) ;; Emacs help commands @@ -5622,43 +6108,66 @@ positives are possible." 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1) ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1) + ;; The following entries may lead to many false positives so don't enable + ;; them by default (use a high button level): + ("/\\([a-z][-a-z0-9]+\\.el\\)\\>" + 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) + ("`\\([a-z][-a-z0-9]+\\.el\\)'" + 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) + ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'" + 0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1) + ("`\\([a-z][a-z0-9]+-[a-z]+\\)'" + 0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1) + ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)" + 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1) + ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" + 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1) ("\\b\\(C-h\\|?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2) ("\\b\\(C-h\\|?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2) - ("\\b\\(C-h\\|?\\)[ \t\n]+k[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+" 0 - ;; this regexp needs to be fixed! - (>= gnus-button-emacs-level 9) gnus-button-handle-describe-key 2) - ;; This is how URLs _should_ be embedded in text... - ("]*\\)>" 1 t gnus-button-embedded-url 1) + ("`\\(\\b\\(C-h\\|?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'" + ;; Unlike the other regexps we really have to require quoting + ;; here to determine where it ends. + 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3) + ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... + ("]*\\)>" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; RFC 2396 (2.4.3., delims) ... + ("\"URL: *\\([^\"]*\\)\"" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; RFC 2396 (2.4.3., delims) ... + ("\"URL: *\\([^\"]*\\)\"" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) ;; Raw URLs. - (gnus-button-url-regexp 0 t browse-url 0) + (gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url 0) ;; man pages - ("\\b\\([a-z][a-z]+\\)([1-9])\\W" 0 - (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) + ("\\b\\([a-z][a-z]+\\)([1-9])\\W" + 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) gnus-button-handle-man 1) ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x) - ("\\b\\([a-z][-_.a-z0-9]+\\)([1-9])\\W" 0 - (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5)) + ("\\b\\([a-z][-_.a-z0-9]+\\)([1-9])\\W" + 0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5)) gnus-button-handle-man 1) ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm), - ;; SoWWWAnchor(3iv), XSelectInput(3X11) - ("\\b\\([a-z][-_.:a-z0-9]+\\)([1-9][X1a-z]*)\\W" 0 - (>= gnus-button-man-level 5) gnus-button-handle-man 1) + ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7) + ("\\b\\([a-z][-+_.:a-z0-9]+\\)([1-9][X1a-z]*)\\W\\|\\b\\(X\\)([1-9])\\W" + 0 (>= gnus-button-man-level 5) gnus-button-handle-man 1) ;; MID or mail: To avoid too many false positives we don't try to catch ;; all kind of allowed MIDs or mail addresses. Domain part must contain ;; at least one dot. TLD must contain two or three chars or be a know TLD ;; (info|name|...). Put this entry near the _end_ of `gnus-button-alist' ;; so that non-ambiguous entries (see above) match first. (gnus-button-mid-or-mail-regexp - 0 (>= gnus-button-mail-level 5) gnus-button-handle-mid-or-mail 1)) + 0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1)) "*Alist of regexps matching buttons in article bodies. Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where REGEXP: is the string (case insensitive) matching text around the button (can -also be lisp expression evaluating to a string), +also be Lisp expression evaluating to a string), BUTTON: is the number of the regexp grouping actually matching the button, -FORM: is a lisp expression which must eval to true for the button to +FORM: is a Lisp expression which must eval to true for the button to be added, CALLBACK: is the function to call when the user push this button, and each PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. @@ -5666,7 +6175,7 @@ PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. CALLBACK can also be a variable, in that case the value of that variable it the real callback function." :group 'gnus-article-buttons - :type '(repeat (list (choice regexp variable) + :type '(repeat (list (choice regexp variable sexp) (integer :tag "Button") (sexp :tag "Form") (function :tag "Callback") @@ -5675,17 +6184,22 @@ variable it the real callback function." (integer :tag "Regexp group"))))) (defcustom gnus-header-button-alist - '(("^\\(References\\|Message-I[Dd]\\):" "<[^<>]+>" - 0 t gnus-button-message-id 0) - ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) + '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>" + 0 (>= gnus-button-message-level 0) gnus-button-message-id 0) + ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" + 1 (>= gnus-button-message-level 0) gnus-button-reply 1) ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" - 0 t gnus-button-mailto 0) - ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp 0 t browse-url 0) - ("^Subject:" gnus-button-url-regexp 0 t browse-url 0) - ("^[^:]+:" gnus-button-url-regexp 0 t browse-url 0) - ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1) - ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t - gnus-button-message-id 3)) + 0 (>= gnus-button-message-level 0) gnus-button-mailto 0) + ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url 0) + ("^Subject:" gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url 0) + ("^[^:]+:" gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url 0) + ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&]+\\)" + 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) + ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)" + 1 (>= gnus-button-message-level 0) gnus-button-message-id 4)) "*Alist of headers and regexps to match buttons in article heads. This alist is very similar to `gnus-button-alist', except that each @@ -5698,7 +6212,7 @@ HEADER is a regexp to match a header. For a fuller explanation, see :group 'gnus-article-buttons :group 'gnus-article-headers :type '(repeat (list (regexp :tag "Header") - regexp + (choice regexp variable) (integer :tag "Button") (sexp :tag "Form") (function :tag "Callback") @@ -5733,8 +6247,8 @@ call it with the value of the `gnus-data' text property." If the text at point has a `gnus-callback' property, call it with the value of the `gnus-data' text property." (interactive) - (let* ((data (get-text-property (point) 'gnus-data)) - (fun (get-text-property (point) 'gnus-callback))) + (let ((data (get-text-property (point) 'gnus-data)) + (fun (get-text-property (point) 'gnus-callback))) (when fun (funcall fun data)))) @@ -6029,18 +6543,47 @@ specified by `gnus-button-alist'." "Fetch a man page." (funcall gnus-button-man-handler url)) -(defun gnus-button-handle-info (url) +(defun gnus-button-handle-info-url (url) "Fetch an info URL." - (if (string-match - "^\\([^:/]+\\)?/\\(.*\\)" - url) + (setq url (mm-subst-char-in-string ?+ ?\ url)) + (cond + ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url) + (gnus-info-find-node + (concat "(" (or (gnus-url-unhex-string (match-string 1 url)) + "Gnus") + ")" (gnus-url-unhex-string (match-string 2 url))))) + ((string-match "([^)\"]+)[^\"]+" url) + (setq url + (gnus-replace-in-string + (gnus-replace-in-string url "[\n\t ]+" " ") "\"" "")) + (gnus-info-find-node url)) + (t (error "Can't parse %s" url)))) + +(defun gnus-button-handle-info-url-gnome (url) + "Fetch GNOME style info URL." + (setq url (mm-subst-char-in-string ?_ ?\ url)) + (if (string-match "\\([^#]+\\)#?\\(.*\\)" url) (gnus-info-find-node - (concat "(" (or (gnus-url-unhex-string (match-string 1 url)) - "Gnus") + (concat "(" + (gnus-url-unhex-string + (match-string 1 url)) ")" - (gnus-url-unhex-string (match-string 2 url)))) + (or (gnus-url-unhex-string + (match-string 2 url)) + "Top"))) (error "Can't parse %s" url))) +(defun gnus-button-handle-info-url-kde (url) + "Fetch KDE style info URL." + (gnus-info-find-node (gnus-url-unhex-string url))) + +(defun gnus-button-handle-info-keystrokes (url) + "Call `info' when pushing the corresponding URL button." + ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'. + (info) + (Info-directory) + (Info-menu url)) + (defun gnus-button-message-id (message-id) "Fetch MESSAGE-ID." (save-excursion @@ -6090,12 +6633,14 @@ specified by `gnus-button-alist'." (when (string-match "mailto:/*\\(.*\\)" url) (setq url (substring url (match-beginning 1) nil))) (let (to args subject func) - (if (string-match (regexp-quote "?") url) - (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) - args (gnus-url-parse-query-string - (substring url (match-end 0) nil) t)) - (setq to (gnus-url-unhex-string url))) - (setq args (cons (list "to" to) args) + (setq args (gnus-url-parse-query-string + (if (string-match "^\\?" url) + (substring url 1) + (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) + (concat "to=" (match-string 1 url) "&" + (match-string 2 url)) + (concat "to=" url))) + t) subject (cdr-safe (assoc "subject" args))) (gnus-msg-mail) (while args @@ -6103,7 +6648,9 @@ specified by `gnus-button-alist'." (if (fboundp func) (funcall func) (message-position-on-field (caar args))) - (insert (mapconcat 'identity (cdar args) ", ")) + (insert (gnus-replace-in-string + (mapconcat 'identity (reverse (cdar args)) ", ") + "\r\n" "\n" t)) (setq args (cdr args))) (if subject (message-goto-body) @@ -6137,7 +6684,10 @@ specified by `gnus-button-alist'." gnus-callback gnus-article-button-prev-page article-type annotation)) (widget-convert-button - 'link b (point) + 'link b (if (bolp) + ;; Exclude a newline. + (1- (point)) + (point)) :action 'gnus-button-prev-page :button-keymap gnus-prev-page-map))) @@ -6184,7 +6734,10 @@ specified by `gnus-button-alist'." gnus-callback gnus-article-button-next-page article-type annotation)) (widget-convert-button - 'link b (point) + 'link b (if (bolp) + ;; Exclude a newline. + (1- (point)) + (point)) :action 'gnus-button-next-page :button-keymap gnus-next-page-map))) @@ -6210,7 +6763,7 @@ specified by `gnus-button-alist'." This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a -\(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups +\(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups whose names match REGEXP. For example: @@ -6357,7 +6910,7 @@ For example: (search-forward field nil t)) (prog2 (message-narrow-to-field) - (buffer-substring (point-min) (point-max)) + (buffer-string) (delete-region (point-min) (point-max)) (widen)))) '("Content-Type:" "Content-Transfer-Encoding:" @@ -6451,42 +7004,45 @@ For example: (defun gnus-mime-security-show-details (handle) (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) - (if details - (if gnus-mime-security-show-details-inline - (let ((gnus-mime-security-button-pressed t) - (gnus-mime-security-button-line-format - (get-text-property (point) 'gnus-line-format)) + (if (not details) + (gnus-message 5 "No details.") + (if gnus-mime-security-show-details-inline + (let ((gnus-mime-security-button-pressed + (not (get-text-property (point) 'gnus-mime-details))) + (gnus-mime-security-button-line-format + (get-text-property (point) 'gnus-line-format)) buffer-read-only) - (forward-char -1) - (while (eq (get-text-property (point) 'gnus-line-format) - gnus-mime-security-button-line-format) - (forward-char -1)) - (forward-char) - (save-restriction - (narrow-to-region (point) (point)) - (gnus-insert-mime-security-button handle)) - (delete-region (point) - (or (text-property-not-all - (point) (point-max) - 'gnus-line-format - gnus-mime-security-button-line-format) - (point-max)))) - (if (gnus-buffer-live-p gnus-mime-security-details-buffer) - (with-current-buffer gnus-mime-security-details-buffer - (erase-buffer) - t) - (setq gnus-mime-security-details-buffer - (gnus-get-buffer-create "*MIME Security Details*"))) - (with-current-buffer gnus-mime-security-details-buffer - (insert details) - (goto-char (point-min))) - (pop-to-buffer gnus-mime-security-details-buffer)) - (gnus-message 5 "No details.")))) + (forward-char -1) + (while (eq (get-text-property (point) 'gnus-line-format) + gnus-mime-security-button-line-format) + (forward-char -1)) + (forward-char) + (save-restriction + (narrow-to-region (point) (point)) + (gnus-insert-mime-security-button handle)) + (delete-region (point) + (or (text-property-not-all + (point) (point-max) + 'gnus-line-format + gnus-mime-security-button-line-format) + (point-max)))) + ;; Not inlined. + (if (gnus-buffer-live-p gnus-mime-security-details-buffer) + (with-current-buffer gnus-mime-security-details-buffer + (erase-buffer) + t) + (setq gnus-mime-security-details-buffer + (gnus-get-buffer-create "*MIME Security Details*"))) + (with-current-buffer gnus-mime-security-details-buffer + (insert details) + (goto-char (point-min))) + (pop-to-buffer gnus-mime-security-details-buffer))))) (defun gnus-mime-security-press-button (handle) - (if (mm-handle-multipart-ctl-parameter handle 'gnus-info) - (gnus-mime-security-show-details handle) - (gnus-mime-security-verify-or-decrypt handle))) + (save-excursion + (if (mm-handle-multipart-ctl-parameter handle 'gnus-info) + (gnus-mime-security-show-details handle) + (gnus-mime-security-verify-or-decrypt handle)))) (defun gnus-insert-mime-security-button (handle &optional displayed) (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) @@ -6507,7 +7063,8 @@ For example: b e) (setq gnus-tmp-details (if gnus-tmp-details - (concat "\n" gnus-tmp-details) "")) + (concat "\n" gnus-tmp-details) + "")) (setq gnus-tmp-pressed-details (if gnus-mime-security-button-pressed gnus-tmp-details "")) (unless (bolp) @@ -6519,9 +7076,13 @@ For example: `(,@(gnus-local-map-property gnus-mime-security-button-map) gnus-callback gnus-mime-security-press-button gnus-line-format ,gnus-mime-security-button-line-format + gnus-mime-details ,gnus-mime-security-button-pressed article-type annotation gnus-data ,handle)) - (setq e (point)) + (setq e (if (bolp) + ;; Exclude a newline. + (1- (point)) + (point))) (widget-convert-button 'link b e :mime-handle handle @@ -6531,8 +7092,8 @@ For example: (lambda (widget/window &optional overlay pos) ;; Needed to properly clear the message due to a bug in ;; wid-edit (XEmacs only). - (if (boundp 'help-echo-owns-message) - (setq help-echo-owns-message t)) + (when (boundp 'help-echo-owns-message) + (setq help-echo-owns-message t)) (format "%S: show detail" (aref gnus-mouse-2 0))))))