X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=7888afe915c28a6e8337f1dc1c279c77621f168e;hb=3a75505b36e914f05480b86020edd727c6abe2fb;hp=ee7c1549185bc919be1ed813061eae92f684d7d0;hpb=8cfa576451fc393ec8ad0de58a89a0afd4343fbf;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index ee7c154..7888afe 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,5 +1,6 @@ ;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -27,12 +28,11 @@ (eval-when-compile (require 'cl)) -(require 'custom) (require 'gnus) (require 'gnus-sum) (require 'gnus-spec) (require 'gnus-int) -(require 'browse-url) +(require 'gnus-win) (require 'mm-bodies) (require 'mail-parse) (require 'mm-decode) @@ -40,6 +40,10 @@ (require 'wid-edit) (require 'mm-uu) +(autoload 'gnus-msg-mail "gnus-msg" nil t) +(autoload 'gnus-button-mailto "gnus-msg") +(autoload 'gnus-button-reply "gnus-msg" nil t) + (defgroup gnus-article nil "Article display." :link '(custom-manual "(gnus)The Article Buffer") @@ -107,7 +111,7 @@ "^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-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.*:" @@ -116,11 +120,29 @@ "^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-Fingerprint:" "^X-Pgp-Key-Id:" - "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:" + "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:" "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:" - "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:" - "^Status:") + "^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:") "*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." @@ -130,7 +152,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." :group 'gnus-article-hiding) (defcustom gnus-visible-headers - "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" "*All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. If this variable is non-nil, `gnus-ignored-headers' will be ignored." @@ -154,15 +176,24 @@ this list." (defcustom gnus-boring-article-headers '(empty followup-to reply-to) "Headers that are only to be displayed if they have interesting data. -Possible values in this list are `empty', `newsgroups', `followup-to', -`reply-to', `date', `long-to', and `many-to'." +Possible values in this list are: + + 'empty Headers with no content. + 'newsgroups Newsgroup identical to Gnus group. + 'to-address To identical to To-address. + 'followup-to Followup-to identical to Newsgroups. + 'reply-to Reply-to identical to From. + 'date Date less than four days old. + 'long-to To and/or Cc longer than 1024 characters. + 'many-to Multiple To and/or Cc." :type '(set (const :tag "Headers with no content." empty) - (const :tag "Newsgroups with only one group." newsgroups) - (const :tag "Followup-to identical to newsgroups." followup-to) - (const :tag "Reply-to identical to from." reply-to) + (const :tag "Newsgroups identical to Gnus group." newsgroups) + (const :tag "To identical to To-address." to-address) + (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) - (const :tag "Very long To header." long-to) - (const :tag "Multiple To headers." many-to)) + (const :tag "To and/or Cc longer than 1024 characters." long-to) + (const :tag "Multiple To and/or Cc headers." many-to)) :group 'gnus-article-hiding) (defcustom gnus-signature-separator '("^-- $" "^-- *$") @@ -174,7 +205,7 @@ the end of the buffer." :group 'gnus-article-signature) (defcustom gnus-signature-limit nil - "Provide a limit to what is considered a signature. + "Provide a limit to what is considered a signature. If it is a number, no signature may not be longer (in characters) than that number. If it is a floating point number, no signature may be longer (in lines) than that number. If it is a function, the function @@ -192,12 +223,25 @@ 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. (defcustom gnus-article-x-face-command - "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" + (if (featurep 'xemacs) + (if (or (gnus-image-type-available-p 'xface) + (gnus-image-type-available-p 'pbm)) + 'gnus-display-x-face-in-from + "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -") + (if (gnus-image-type-available-p 'pbm) + 'gnus-display-x-face-in-from + "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \ +display -")) "*String or function to be executed to display an X-Face header. If it is a string, the command will be executed in a sub-shell asynchronously. The compressed face will be piped to this command." - :type 'string ;Leave function case to Lisp. + :type `(choice string + (function-item gnus-display-x-face-in-from) + function) + :version "21.1" :group 'gnus-article-washing) (defcustom gnus-article-x-face-too-ugly nil @@ -205,25 +249,54 @@ asynchronously. The compressed face will be piped to this command." :type '(choice regexp (const nil)) :group 'gnus-article-washing) +(defcustom gnus-article-banner-alist nil + "Banner alist for stripping. +For example, + ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))" + :version "21.1" + :type '(repeat (cons symbol regexp)) + :group 'gnus-article-washing) + +(gnus-define-group-parameter + banner + :variable-document + "Alist of regexps (to match group names) and banner." + :variable-group gnus-article-washing + :parameter-type + '(choice :tag "Banner" + :value nil + (const :tag "Remove signature" signature) + (symbol :tag "Item in `gnus-article-banner-alist'" none) + regexp + (const :tag "None" nil)) + :parameter-document + "If non-nil, specify how to remove `banners' from articles. + +Symbol `signature' means to remove signatures delimited by +`gnus-signature-separator'. Any other symbol is used to look up a +regular expression to match the banner in `gnus-article-banner-alist'. +A string is used as a regular expression to match the banner +directly.") + (defcustom gnus-emphasis-alist (let ((format - "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)") + "\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\([-,.;:\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)") (types - '(("_" "_" underline) + '(("\\*" "\\*" bold) + ("_" "_" underline) ("/" "/" italic) - ("\\*" "\\*" bold) ("_/" "/_" underline-italic) ("_\\*" "\\*_" underline-bold) ("\\*/" "/\\*" bold-italic) ("_\\*/" "/\\*_" underline-bold-italic)))) - `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" - 2 3 gnus-emphasis-underline) - ,@(mapcar + `(,@(mapcar (lambda (spec) (list (format format (car spec) (cadr spec)) 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) - types))) + types) + ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" + 2 3 gnus-emphasis-underline))) "*Alist that says how to fontify certain phrases. Each item looks like this: @@ -241,6 +314,15 @@ is the face used for highlighting." face)) :group 'gnus-article-emphasis) +(defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n" + "A regexp to describe whitespace which should not be emphasized. +Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\". +The former avoids underlining of leading and trailing whitespace, +and the latter avoids underlining any whitespace at all." + :version "21.1" + :group 'gnus-article-emphasis + :type 'regexp) + (defface gnus-emphasis-bold '((t (:bold t))) "Face used for displaying strong emphasized text (*word*)." :group 'gnus-article-emphasis) @@ -258,7 +340,7 @@ is the face used for highlighting." :group 'gnus-article-emphasis) (defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) - "Face used for displaying underlined italic emphasized text (_*word*_)." + "Face used for displaying underlined italic emphasized text (_/word/_)." :group 'gnus-article-emphasis) (defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) @@ -271,6 +353,11 @@ is the face used for highlighting." Esample: (_/*word*/_)." :group 'gnus-article-emphasis) +(defface gnus-emphasis-highlight-words + '((t (:background "black" :foreground "yellow"))) + "Face used for displaying highlighted words." + :group 'gnus-article-emphasis) + (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" "Format for display of Date headers in article bodies. See `format-time-string' for the possible values. @@ -322,6 +409,7 @@ Gnus provides the following functions: * gnus-summary-save-in-mail (Unix mail format) * gnus-summary-save-in-folder (MH folder) * gnus-summary-save-in-file (article format) +* gnus-summary-save-body-in-file (article body) * gnus-summary-save-in-vm (use VM's folder format) * gnus-summary-write-to-file (article format -- overwrite)." :group 'gnus-article-saving @@ -329,6 +417,7 @@ Gnus provides the following functions: (function-item gnus-summary-save-in-mail) (function-item gnus-summary-save-in-folder) (function-item gnus-summary-save-in-file) + (function-item gnus-summary-save-body-in-file) (function-item gnus-summary-save-in-vm) (function-item gnus-summary-write-to-file))) @@ -391,7 +480,7 @@ beginning of a line." :type 'regexp :group 'gnus-article-various) -(defcustom gnus-article-mode-line-format "Gnus: %g %S%m" +(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m" "*The format specification for the article mode line. See `gnus-summary-mode-line-format' for a closer description. @@ -407,14 +496,20 @@ The following additional specs are available: :type 'hook :group 'gnus-article-various) +(when (featurep 'xemacs) + ;; Extracted from gnus-xmas-define in order to preserve user settings + (when (fboundp 'turn-off-scroll-in-place) + (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place)) + ;; Extracted from gnus-xmas-redefine in order to preserve user settings + (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)) + (defcustom gnus-article-menu-hook nil "*Hook run after the creation of the article mode menu." :type 'hook :group 'gnus-article-various) (defcustom gnus-article-prepare-hook nil - "*A hook called after an article has been prepared in the article buffer. -If you want to run a special decoding program like nkf, use this hook." + "*A hook called after an article has been prepared in the article buffer." :type 'hook :group 'gnus-article-various) @@ -447,7 +542,7 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." :group 'gnus-article-signature) (defface gnus-signature-face - '((((type x)) + '((t (:italic t))) "Face used for highlighting a signature in the article buffer." :group 'gnus-article-highlight @@ -544,7 +639,8 @@ displayed by the first non-nil matching CONTENT face." (face :value default))))) (defcustom gnus-article-decode-hook - '(article-decode-charset article-decode-encoded-words) + '(article-decode-charset article-decode-encoded-words + article-decode-group-name) "*Hook run to decode charsets in articles." :group 'gnus-article-headers :type 'hook) @@ -558,7 +654,8 @@ displayed by the first non-nil matching CONTENT face." "Function used to decode headers.") (defvar gnus-article-dumbquotes-map - '(("\202" ",") + '(("\200" "EUR") + ("\202" ",") ("\203" "f") ("\204" ",,") ("\205" "...") @@ -567,10 +664,10 @@ displayed by the first non-nil matching CONTENT face." ("\221" "`") ("\222" "'") ("\223" "``") - ("\224" "''") + ("\224" "\"") ("\225" "*") ("\226" "-") - ("\227" "-") + ("\227" "--") ("\231" "(TM)") ("\233" ">") ("\234" "oe") @@ -579,14 +676,49 @@ displayed by the first non-nil matching CONTENT face." (defcustom gnus-ignored-mime-types nil "List of MIME types that should be ignored by Gnus." + :version "21.1" :group 'gnus-article-mime :type '(repeat regexp)) (defcustom gnus-unbuttonized-mime-types '(".*/.*") - "List of MIME types that should not be given buttons when rendered." + "List of MIME types that should not be given buttons when rendered inline. +See also `gnus-buttonized-mime-types' which may override this variable." + :version "21.1" :group 'gnus-article-mime :type '(repeat regexp)) +(defcustom gnus-buttonized-mime-types nil + "List of MIME types that should be given buttons when rendered inline. +If set, this variable overrides `gnus-unbuttonized-mime-types'. +To see e.g. security buttons you could set this to +`(\"multipart/signed\")'." + :version "21.1" + :group 'gnus-article-mime + :type '(repeat regexp)) + +(defcustom gnus-body-boundary-delimiter "_" + "String used to delimit header and body. +This variable is used by `gnus-article-treat-body-boundary' which can +be controlled by `gnus-treat-body-boundary'." + :group 'gnus-article-various + :type '(choice (item :tag "None" :value nil) + string)) + +(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces") + "*Defines the location of the faces database. +For information on obtaining this database of pretty pictures, please +see http://www.cs.indiana.edu/picons/ftp/index.html" + :type 'directory + :group 'gnus-picon) + +(defun gnus-picons-installed-p () + "Say whether picons are installed on your machine." + (let ((installed nil)) + (dolist (database gnus-picon-databases) + (when (file-exists-p database) + (setq installed t))) + installed)) + (defcustom gnus-article-mime-part-function nil "Function called with a MIME handle as the argument. This is meant for people who want to do something automatic based @@ -594,6 +726,69 @@ on parts -- for instance, adding Vcard info to a database." :group 'gnus-article-mime :type 'function) +(defcustom gnus-mime-multipart-functions nil + "An alist of MIME types to functions to display them." + :version "21.1" + :group 'gnus-article-mime + :type 'alist) + +(defcustom gnus-article-date-lapsed-new-header nil + "Whether the X-Sent and Date headers can coexist. +When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will +either replace the old \"Date:\" header (if this variable is nil), or +be added below it (otherwise)." + :version "21.1" + :group 'gnus-article-headers + :type 'boolean) + +(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative + "Function called with a MIME handle as the argument. +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 +used." + :version "21.1" + :group 'gnus-article-mime + :type '(choice + (item :tag "first" :value nil) + (item :tag "undisplayed" :value undisplayed) + (item :tag "undisplayed or alternative" + :value undisplayed-alternative) + (function))) + +(defcustom gnus-mime-action-alist + '(("save to file" . gnus-mime-save-part) + ("save and strip" . gnus-mime-save-part-and-strip) + ("display as text" . gnus-mime-inline-part) + ("view the part" . gnus-mime-view-part) + ("pipe to command" . gnus-mime-pipe-part) + ("toggle display" . gnus-article-press-button) + ("toggle display" . gnus-article-view-part-as-charset) + ("view as type" . gnus-mime-view-part-as-type) + ("internalize type" . gnus-mime-internalize-part) + ("externalize type" . gnus-mime-externalize-part)) + "An alist of actions that run on the MIME attachment." + :group 'gnus-article-mime + :type '(repeat (cons (string :tag "name") + (function)))) + +(defcustom gnus-mime-action-alist + '(("save to file" . gnus-mime-save-part) + ("display as text" . gnus-mime-inline-part) + ("view the part" . gnus-mime-view-part) + ("pipe to command" . gnus-mime-pipe-part) + ("toggle display" . gnus-article-press-button) + ("view as type" . gnus-mime-view-part-as-type) + ("internalize type" . gnus-mime-internalize-part) + ("externalize type" . gnus-mime-externalize-part)) + "An alist of actions that run on the MIME attachment." + :version "21.1" + :group 'gnus-article-mime + :type '(repeat (cons (string :tag "name") + (function)))) + ;;; ;;; The treatment variables ;;; @@ -607,183 +802,456 @@ on parts -- for instance, adding Vcard info to a database." (const :tag "Header" head) (const :tag "Last" last) (integer :tag "Less") + (repeat :tag "Groups" regexp) (sexp :tag "Predicate"))) +(defvar gnus-article-treat-head-custom + '(choice (const :tag "Off" nil) + (const :tag "Header" head))) + (defvar gnus-article-treat-types '("text/plain") "Parts to treat.") (defvar gnus-inhibit-treatment nil "Whether to inhibit treatment.") -(defcustom gnus-treat-highlight-signature 'last - "Highlight the signature." +(defcustom gnus-treat-highlight-signature '(or last (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'." :group 'gnus-article-treat :type gnus-article-treat-custom) +(put 'gnus-treat-highlight-signature 'highlight t) -(defcustom gnus-treat-buttonize t - "Add buttons." +(defcustom gnus-treat-buttonize 100000 + "Add buttons. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :type gnus-article-treat-custom) +(put 'gnus-treat-buttonize 'highlight t) (defcustom gnus-treat-buttonize-head 'head - "Add buttons to the head." + "Add buttons to the head. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) +(put 'gnus-treat-buttonize-head 'highlight t) + +(defcustom gnus-treat-emphasize + (and (or window-system + (featurep 'xemacs) + (>= (string-to-number emacs-version) 21)) + 50000) + "Emphasize text. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) +(put 'gnus-treat-emphasize 'highlight t) -(defcustom gnus-treat-emphasize t - "Emphasize text." +(defcustom gnus-treat-strip-cr nil + "Remove carriage returns. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) -(defcustom gnus-treat-strip-cr nil - "Remove carriage returns." +(defcustom gnus-treat-leading-whitespace nil + "Remove leading whitespace in headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) (defcustom gnus-treat-hide-headers 'head - "Hide headers." + "Hide headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat - :type gnus-article-treat-custom) + :type gnus-article-treat-head-custom) (defcustom gnus-treat-hide-boring-headers nil - "Hide boring headers." + "Hide boring headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat - :type gnus-article-treat-custom) + :type gnus-article-treat-head-custom) (defcustom gnus-treat-hide-signature nil - "Hide the signature." + "Hide the signature. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) (defcustom gnus-treat-fill-article nil - "Fill the article." + "Fill the article. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) (defcustom gnus-treat-hide-citation nil - "Hide cited text." + "Hide cited text. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-hide-citation-maybe nil + "Hide cited text. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-list-identifiers 'head + "Strip list identifiers from `gnus-list-identifiers`. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :version "21.1" :group 'gnus-article-treat :type gnus-article-treat-custom) (defcustom gnus-treat-strip-pgp t - "Strip PGP signatures." + "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 :type gnus-article-treat-custom) (defcustom gnus-treat-strip-pem nil - "Strip PEM signatures." + "Strip PEM 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 :type gnus-article-treat-custom) -(defcustom gnus-treat-highlight-headers 'head - "Highlight the headers." +(defcustom gnus-treat-strip-banner t + "Strip banners from articles. +The banner to be stripped is specified in the `banner' group parameter. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) +(defcustom gnus-treat-highlight-headers 'head + "Highlight the headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) +(put 'gnus-treat-highlight-headers 'highlight t) + (defcustom gnus-treat-highlight-citation t - "Highlight cited text." + "Highlight cited text. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) +(put 'gnus-treat-highlight-citation 'highlight t) (defcustom gnus-treat-date-ut nil - "Display the Date in UT (GMT)." + "Display the Date in UT (GMT). +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat - :type gnus-article-treat-custom) + :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-local nil - "Display the Date in the local timezone." + "Display the Date in the local timezone. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat - :type gnus-article-treat-custom) + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-date-english nil + "Display the Date in a format that can be read aloud in English. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-lapsed nil - "Display the Date header in a way that says how much time has elapsed." + "Display the Date header in a way that says how much time has elapsed. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat - :type gnus-article-treat-custom) + :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-original nil - "Display the date in the original timezone." + "Display the date in the original timezone. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-date-iso8601 nil + "Display the date in the ISO8601 format. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :version "21.1" + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-date-user-defined nil + "Display the date in a user-defined format. +The format is defined by the `gnus-article-time-format' variable. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-strip-headers-in-body t + "Strip the X-No-Archive header line from the beginning of the body. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :version "21.1" :group 'gnus-article-treat :type gnus-article-treat-custom) (defcustom gnus-treat-strip-trailing-blank-lines nil - "Strip trailing blank lines." + "Strip trailing blank lines. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) (defcustom gnus-treat-strip-leading-blank-lines nil - "Strip leading blank lines." + "Strip leading blank lines. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) (defcustom gnus-treat-strip-multiple-blank-lines nil - "Strip multiple blank lines." + "Strip multiple blank lines. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) -(defcustom gnus-treat-strip-blank-lines nil - "Strip all blank lines." +(defcustom gnus-treat-unfold-headers 'head + "Unfold folded header lines. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-fold-headers nil + "Fold headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-fold-newsgroups 'head + "Fold the Newsgroups and Followup-To headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) (defcustom gnus-treat-overstrike t - "Treat overstrike highlighting." + "Treat overstrike highlighting. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) +(put 'gnus-treat-overstrike 'highlight t) + +(defcustom gnus-treat-display-xface + (and (or (and (fboundp 'image-type-available-p) + (image-type-available-p 'xbm) + (string-match "^0x" (shell-command-to-string "uncompface"))) + (and (featurep 'xemacs) + (featurep 'xface))) + 'head) + "Display X-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.1" + :type gnus-article-treat-head-custom) +(put 'gnus-treat-display-xface 'highlight t) + +(defcustom gnus-treat-display-smileys + (if (or (and (featurep 'xemacs) + (featurep 'xpm)) + (and (fboundp 'image-type-available-p) + (image-type-available-p 'pbm))) + t nil) + "Display smileys. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' and Info node +`(gnus)Smileys' for details." + :group 'gnus-article-treat + :version "21.1" + :type gnus-article-treat-custom) +(put 'gnus-treat-display-smileys 'highlight t) + +(defcustom gnus-treat-from-picon + (if (and (gnus-image-type-available-p 'xpm) + (gnus-picons-installed-p)) + 'head nil) + "Display picons in the From header. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' and Info node +`(gnus)Picons' for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) +(put 'gnus-treat-from-picon 'highlight t) + +(defcustom gnus-treat-mail-picon + (if (and (gnus-image-type-available-p 'xpm) + (gnus-picons-installed-p)) + 'head nil) + "Display picons in To and Cc headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' and Info node +`(gnus)Picons' for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) +(put 'gnus-treat-mail-picon 'highlight t) + +(defcustom gnus-treat-newsgroups-picon + (if (and (gnus-image-type-available-p 'xpm) + (gnus-picons-installed-p)) + 'head nil) + "Display picons in the Newsgroups and Followup-To headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' and Info node +`(gnus)Picons' for details." + :group 'gnus-article-treat + :type gnus-article-treat-head-custom) +(put 'gnus-treat-newsgroups-picon 'highlight t) + +(defcustom gnus-treat-body-boundary + (if (or gnus-treat-newsgroups-picon + gnus-treat-mail-picon + 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. +See Info node `(gnus)Customizing Articles' for details." + :version "21.1" :group 'gnus-article-treat :type gnus-article-treat-custom) -(defcustom gnus-treat-display-xface (if (and gnus-xemacs (featurep 'xface)) - 'head nil) - "Display X-Face headers." +(defcustom gnus-treat-capitalize-sentences nil + "Capitalize sentence-starting words. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :version "21.1" :group 'gnus-article-treat :type gnus-article-treat-custom) -(defcustom gnus-treat-display-smileys (if (and gnus-xemacs - (featurep 'xpm)) - t nil) - "Display smileys." +(defcustom gnus-treat-fill-long-lines nil + "Fill long lines. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat :type gnus-article-treat-custom) -(defcustom gnus-treat-display-picons (if gnus-xemacs 'head nil) - "Display picons." +(defcustom gnus-treat-play-sounds nil + "Play sounds. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :version "21.1" :group 'gnus-article-treat :type gnus-article-treat-custom) +(defcustom gnus-treat-translate nil + "Translate articles from one language to another. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :version "21.1" + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-x-pgp-sig nil + "Verify X-PGP-Sig. +To automatically treat X-PGP-Sig, set it to head. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :group 'mime-security + :type gnus-article-treat-custom) + +(defvar gnus-article-encrypt-protocol-alist + '(("PGP" . mml2015-self-encrypt))) + +;; Set to nil if more than one protocol added to +;; gnus-article-encrypt-protocol-alist. +(defcustom gnus-article-encrypt-protocol "PGP" + "The protocol used for encrypt articles. +It is a string, such as \"PGP\". If nil, ask user." + :type 'string + :group 'mime-security) + ;;; Internal variables +(defvar gnus-english-month-names + '("January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December")) + (defvar article-goto-body-goes-to-point-min-p nil) +(defvar gnus-article-wash-types nil) +(defvar gnus-article-emphasis-alist nil) +(defvar gnus-article-image-alist nil) (defvar gnus-article-mime-handle-alist-1 nil) (defvar gnus-treatment-function-alist - '((gnus-treat-highlight-signature gnus-article-highlight-signature) + '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig) + (gnus-treat-strip-banner gnus-article-strip-banner) + (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body) + (gnus-treat-highlight-signature gnus-article-highlight-signature) (gnus-treat-buttonize gnus-article-add-buttons) - (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) - (gnus-treat-emphasize gnus-article-emphasize) (gnus-treat-fill-article gnus-article-fill-cited-article) + (gnus-treat-fill-long-lines gnus-article-fill-long-lines) (gnus-treat-strip-cr gnus-article-remove-cr) - (gnus-treat-hide-headers gnus-article-hide-headers) + (gnus-treat-date-ut gnus-article-date-ut) + (gnus-treat-date-local gnus-article-date-local) + (gnus-treat-date-english gnus-article-date-english) + (gnus-treat-date-lapsed gnus-article-date-lapsed) + (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-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-hide-citation gnus-article-hide-citation) + (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe) + (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) + (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon) (gnus-treat-highlight-headers gnus-article-highlight-headers) (gnus-treat-highlight-citation gnus-article-highlight-citation) (gnus-treat-highlight-signature gnus-article-highlight-signature) - (gnus-treat-date-ut gnus-article-date-ut) - (gnus-treat-date-local gnus-article-date-local) - (gnus-treat-date-lapsed gnus-article-date-lapsed) - (gnus-treat-date-original gnus-article-date-original) (gnus-treat-strip-trailing-blank-lines gnus-article-remove-trailing-blank-lines) (gnus-treat-strip-leading-blank-lines gnus-article-strip-leading-blank-lines) (gnus-treat-strip-multiple-blank-lines gnus-article-strip-multiple-blank-lines) - (gnus-treat-strip-blank-lines gnus-article-strip-blank-lines) (gnus-treat-overstrike gnus-article-treat-overstrike) - (gnus-treat-display-xface gnus-article-display-x-face) - (gnus-treat-display-smileys gnus-smiley-display) - (gnus-treat-display-picons gnus-article-display-picons))) + (gnus-treat-unfold-headers gnus-article-treat-unfold-headers) + (gnus-treat-fold-headers gnus-article-treat-fold-headers) + (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups) + (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) + (gnus-treat-display-smileys gnus-treat-smiley) + (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) + (gnus-treat-emphasize gnus-article-emphasize) + (gnus-treat-body-boundary gnus-article-treat-body-boundary) + (gnus-treat-play-sounds gnus-earcon-display))) (defvar gnus-article-mime-handle-alist nil) (defvar article-lapsed-timer nil) @@ -791,7 +1259,8 @@ on parts -- for instance, adding Vcard info to a database." (defvar gnus-article-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) - (modify-syntax-entry ?- "w" table) + ;; This causes the citation match run O(2^n). + ;; (modify-syntax-entry ?- "w" table) (modify-syntax-entry ?> ")" table) (modify-syntax-entry ?< "(" table) table) @@ -809,41 +1278,42 @@ Initialized from `text-mode-syntax-table.") (defvar gnus-inhibit-hiding nil) +;;; Macros for dealing with the article buffer. + +(defmacro gnus-with-article-headers (&rest forms) + `(save-excursion + (set-buffer gnus-article-buffer) + (save-restriction + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (case-fold-search t)) + (article-narrow-to-head) + ,@forms)))) + +(put 'gnus-with-article-headers 'lisp-indent-function 0) +(put 'gnus-with-article-headers 'edebug-form-spec '(body)) + +(defmacro gnus-with-article-buffer (&rest forms) + `(save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil)) + ,@forms))) + +(put 'gnus-with-article-buffer 'lisp-indent-function 0) +(put 'gnus-with-article-buffer 'edebug-form-spec '(body)) + +(defun gnus-article-goto-header (header) + "Go to HEADER, which is a regular expression." + (re-search-forward (concat "^\\(" header "\\):") nil t)) + (defsubst gnus-article-hide-text (b e props) "Set text PROPS on the B to E region, extending `intangible' 1 past B." - (add-text-properties b e props) + (gnus-add-text-properties-when 'article-type nil b e props) (when (memq 'intangible props) (put-text-property (max (1- b) (point-min)) b 'intangible (cddr (memq 'intangible props))))) -(defmacro gnus-with-article (article &rest forms) - "Select ARTICLE and perform FORMS in the original article buffer. -Then replace the article with the result." - `(progn - ;; We don't want the article to be marked as read. - (let (gnus-mark-article-hook) - (gnus-summary-select-article t t nil ,article)) - (set-buffer gnus-original-article-buffer) - ,@forms - (if (not (gnus-check-backend-function - 'request-replace-article (car gnus-article-current))) - (gnus-message 5 "Read-only group; not replacing") - (unless (gnus-request-replace-article - ,article (car gnus-article-current) - (current-buffer) t) - (error "Couldn't replace article"))) - ;; The cache and backlog have to be flushed somewhat. - (when gnus-keep-backlog - (gnus-backlog-remove-article - (car gnus-article-current) (cdr gnus-article-current))) - (when gnus-use-cache - (gnus-cache-update-article - (car gnus-article-current) (cdr gnus-article-current))))) - -(put 'gnus-with-article 'lisp-indent-function 1) -(put 'gnus-with-article 'edebug-form-spec '(form body)) - (defsubst gnus-article-unhide-text (b e) "Remove hidden text properties from region between B and E." (remove-text-properties b e gnus-hidden-properties) @@ -853,11 +1323,13 @@ Then replace the article with the result." (defun gnus-article-hide-text-type (b e type) "Hide text of TYPE between B and E." + (gnus-add-wash-type type) (gnus-article-hide-text b e (cons 'article-type (cons type gnus-hidden-properties)))) (defun gnus-article-unhide-text-type (b e type) "Unhide text of TYPE between B and E." + (gnus-delete-wash-type type) (remove-text-properties b e (cons 'article-type (cons type gnus-hidden-properties))) (when (memq 'intangible gnus-hidden-properties) @@ -906,79 +1378,60 @@ Then replace the article with the result." i)) (defun article-hide-headers (&optional arg delete) - "Toggle whether to hide unwanted headers and possibly sort them as well. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (gnus-article-hidden-arg)) - (current-buffer) - (if (gnus-article-check-hidden-text 'headers arg) - ;; Show boring headers as well. - (gnus-article-show-hidden-text 'boring-headers) - ;; This function might be inhibited. - (unless gnus-inhibit-hiding - (save-excursion - (save-restriction - (let ((buffer-read-only nil) - (case-fold-search t) - (props (nconc (list 'article-type 'headers) - gnus-hidden-properties)) - (max (1+ (length gnus-sorted-header-list))) - (ignored (when (not gnus-visible-headers) - (cond ((stringp gnus-ignored-headers) - gnus-ignored-headers) - ((listp gnus-ignored-headers) - (mapconcat 'identity gnus-ignored-headers - "\\|"))))) - (visible - (cond ((stringp gnus-visible-headers) - gnus-visible-headers) - ((and gnus-visible-headers - (listp gnus-visible-headers)) - (mapconcat 'identity gnus-visible-headers "\\|")))) - (inhibit-point-motion-hooks t) - beg) - ;; First we narrow to just the headers. - (widen) - (goto-char (point-min)) - ;; Hide any "From " lines at the beginning of (mail) articles. - (while (looking-at "From ") - (forward-line 1)) - (unless (bobp) - (if delete - (delete-region (point-min) (point)) - (gnus-article-hide-text (point-min) (point) props))) - ;; Then treat the rest of the header lines. - (narrow-to-region - (point) - (if (search-forward "\n\n" nil t) ; if there's a body - (progn (forward-line -1) (point)) - (point-max))) - ;; Then we use the two regular expressions - ;; `gnus-ignored-headers' and `gnus-visible-headers' to - ;; select which header lines is to remain visible in the - ;; article buffer. - (goto-char (point-min)) - (while (re-search-forward "^[^ \t]*:" nil t) - (beginning-of-line) - ;; Mark the rank of the header. - (put-text-property - (point) (1+ (point)) 'message-rank - (if (or (and visible (looking-at visible)) - (and ignored - (not (looking-at ignored)))) - (gnus-article-header-rank) - (+ 2 max))) - (forward-line 1)) - (message-sort-headers-1) - (when (setq beg (text-property-any - (point-min) (point-max) 'message-rank (+ 2 max))) - ;; We make the unwanted headers invisible. - (if delete - (delete-region beg (point-max)) - ;; Suggested by Sudish Joseph . - (gnus-article-hide-text-type beg (point-max) 'headers)) - ;; Work around XEmacs lossage. - (put-text-property (point-min) beg 'invisible nil)))))))) + "Hide unwanted headers and possibly sort them as well." + (interactive) + ;; This function might be inhibited. + (unless gnus-inhibit-hiding + (save-excursion + (save-restriction + (let ((buffer-read-only nil) + (case-fold-search t) + (max (1+ (length gnus-sorted-header-list))) + (ignored (when (not gnus-visible-headers) + (cond ((stringp gnus-ignored-headers) + gnus-ignored-headers) + ((listp gnus-ignored-headers) + (mapconcat 'identity gnus-ignored-headers + "\\|"))))) + (visible + (cond ((stringp gnus-visible-headers) + gnus-visible-headers) + ((and gnus-visible-headers + (listp gnus-visible-headers)) + (mapconcat 'identity gnus-visible-headers "\\|")))) + (inhibit-point-motion-hooks t) + beg) + ;; First we narrow to just the headers. + (article-narrow-to-head) + ;; Hide any "From " lines at the beginning of (mail) articles. + (while (looking-at "From ") + (forward-line 1)) + (unless (bobp) + (delete-region (point-min) (point))) + ;; Then treat the rest of the header lines. + ;; Then we use the two regular expressions + ;; `gnus-ignored-headers' and `gnus-visible-headers' to + ;; select which header lines is to remain visible in the + ;; article buffer. + (while (re-search-forward "^[^ \t:]*:" nil t) + (beginning-of-line) + ;; Mark the rank of the header. + (put-text-property + (point) (1+ (point)) 'message-rank + (if (or (and visible (looking-at visible)) + (and ignored + (not (looking-at ignored)))) + (gnus-article-header-rank) + (+ 2 max))) + (forward-line 1)) + (message-sort-headers-1) + (when (setq beg (text-property-any + (point-min) (point-max) 'message-rank (+ 2 max))) + ;; We delete the unwanted headers. + (gnus-add-wash-type 'headers) + (add-text-properties (point-min) (+ 5 (point-min)) + '(article-type headers dummy-invisible t)) + (delete-region beg (point-max)))))))) (defun article-hide-boring-headers (&optional arg) "Toggle hiding of headers that aren't very interesting. @@ -993,14 +1446,14 @@ always hide." (list gnus-boring-article-headers) (inhibit-point-motion-hooks t) elem) - (nnheader-narrow-to-headers) + (article-narrow-to-head) (while list (setq elem (pop list)) (goto-char (point-min)) (cond ;; Hide empty headers. ((eq elem 'empty) - (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t) + (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t) (forward-line -1) (gnus-article-hide-text-type (progn (beginning-of-line) (point)) @@ -1012,15 +1465,30 @@ always hide." 'boring-headers))) ;; Hide boring Newsgroups header. ((eq elem 'newsgroups) - (when (equal (gnus-fetch-field "newsgroups") - (gnus-group-real-name - (if (boundp 'gnus-newsgroup-name) - gnus-newsgroup-name - ""))) + (when (gnus-string-equal + (gnus-fetch-field "newsgroups") + (gnus-group-real-name + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name + ""))) (gnus-article-hide-header "newsgroups"))) + ((eq elem 'to-address) + (let ((to (message-fetch-field "to")) + (to-address + (gnus-parameter-to-address + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name "")))) + (when (and to to-address + (ignore-errors + (gnus-string-equal + ;; only one address in To + (nth 1 (mail-extract-address-components to)) + to-address))) + (gnus-article-hide-header "to")))) ((eq elem 'followup-to) - (when (equal (message-fetch-field "followup-to") - (message-fetch-field "newsgroups")) + (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")) @@ -1028,7 +1496,7 @@ always hide." (when (and from reply-to (ignore-errors - (equal + (gnus-string-equal (nth 1 (mail-extract-address-components from)) (nth 1 (mail-extract-address-components reply-to))))) (gnus-article-hide-header "reply-to")))) @@ -1039,11 +1507,15 @@ always hide." 4)) (gnus-article-hide-header "date")))) ((eq elem 'long-to) - (let ((to (message-fetch-field "to"))) + (let ((to (message-fetch-field "to")) + (cc (message-fetch-field "cc"))) (when (> (length to) 1024) - (gnus-article-hide-header "to")))) + (gnus-article-hide-header "to")) + (when (> (length cc) 1024) + (gnus-article-hide-header "cc")))) ((eq elem 'many-to) - (let ((to-count 0)) + (let ((to-count 0) + (cc-count 0)) (goto-char (point-min)) (while (re-search-forward "^to:" nil t) (setq to-count (1+ to-count))) @@ -1055,7 +1527,19 @@ always hide." (forward-line -1) (narrow-to-region (point) (point-max)) (gnus-article-hide-header "to")) - (setq to-count (1- to-count))))))))))))) + (setq to-count (1- to-count)))) + (goto-char (point-min)) + (while (re-search-forward "^cc:" nil t) + (setq cc-count (1+ cc-count))) + (when (> cc-count 1) + (while (> cc-count 0) + (goto-char (point-min)) + (save-restriction + (re-search-forward "^cc:" nil nil cc-count) + (forward-line -1) + (narrow-to-region (point) (point-max)) + (gnus-article-hide-header "cc")) + (setq cc-count (1- cc-count))))))))))))) (defun gnus-article-hide-header (header) (save-excursion @@ -1080,7 +1564,7 @@ always hide." column) (save-excursion (save-restriction - (message-narrow-to-head) + (article-narrow-to-head) (while (not (eobp)) (cond ((< (setq column (- (gnus-point-at-eol) (point))) @@ -1102,9 +1586,14 @@ always hide." (forward-line 1)))))) (defun article-treat-dumbquotes () - "Translate M******** sm*rtq**t*s into proper text. + "Translate M****s*** sm*rtq**t*s 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." +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." (interactive) (article-translate-strings gnus-article-dumbquotes-map)) @@ -1163,30 +1652,124 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (put-text-property (point) (1+ (point)) 'face 'underline))))))))) -(defun article-fill () - "Format too long lines." +(defun gnus-article-treat-unfold-headers () + "Unfold folded message headers. +Only the headers that fit into the current window width will be +unfolded." + (interactive) + (gnus-with-article-headers + (let (length) + (while (not (eobp)) + (save-restriction + (mail-header-narrow-to-field) + (let ((header (buffer-substring (point-min) (point-max)))) + (with-temp-buffer + (insert header) + (goto-char (point-min)) + (while (re-search-forward "[\t ]*\n[\t ]+" nil t) + (replace-match " " t t))) + (setq length (- (point-max) (point-min) 1))) + (when (< length (window-width)) + (while (re-search-forward "[\t ]*\n[\t ]+" nil t) + (replace-match " " t t))) + (goto-char (point-max))))))) + +(defun gnus-article-treat-fold-headers () + "Fold message headers." + (interactive) + (gnus-with-article-headers + (while (not (eobp)) + (save-restriction + (mail-header-narrow-to-field) + (mail-header-fold-field) + (goto-char (point-max)))))) + +(defun gnus-treat-smiley () + "Display textual emoticons (\"smileys\") as small graphical icons." + (interactive) + (gnus-with-article-buffer + (if (memq 'smiley gnus-article-wash-types) + (gnus-delete-images 'smiley) + (article-goto-body) + (let ((images (smiley-region (point) (point-max)))) + (when images + (gnus-add-wash-type 'smiley) + (dolist (image images) + (gnus-add-image 'smiley image))))))) + +(defun gnus-article-remove-images () + "Remove all images from the article buffer." + (interactive) + (gnus-with-article-buffer + (dolist (elem gnus-article-image-alist) + (gnus-delete-images (car elem))))) + +(defun gnus-article-treat-fold-newsgroups () + "Unfold folded message headers. +Only the headers that fit into the current window width will be +unfolded." + (interactive) + (gnus-with-article-headers + (while (gnus-article-goto-header "newsgroups\\|followup-to") + (save-restriction + (mail-header-narrow-to-field) + (while (re-search-forward ", *" nil t) + (replace-match ", " t t)) + (mail-header-fold-field) + (goto-char (point-max)))))) + +(defun gnus-article-treat-body-boundary () + "Place a boundary line at the end of the headers." + (interactive) + (when (and gnus-body-boundary-delimiter + (> (length gnus-body-boundary-delimiter) 0)) + (gnus-with-article-headers + (goto-char (point-max)) + (let ((start (point))) + (insert "X-Boundary: ") + (gnus-add-text-properties start (point) '(invisible t intangible t)) + (insert (let (str) + (while (>= (1- (window-width)) (length str)) + (setq str (concat str gnus-body-boundary-delimiter))) + (substring str 0 (1- (window-width)))) + "\n"))))) + +(defun article-fill-long-lines () + "Fill lines that are wider than the window width." (interactive) (save-excursion - (let ((buffer-read-only nil)) - (widen) + (let ((buffer-read-only nil) + (width (window-width (get-buffer-window (current-buffer))))) + (save-restriction + (article-goto-body) + (let ((adaptive-fill-mode nil)) ;Why? -sm + (while (not (eobp)) + (end-of-line) + (when (>= (current-column) (min fill-column width)) + (narrow-to-region (point) (gnus-point-at-bol)) + (fill-paragraph nil) + (goto-char (point-max)) + (widen)) + (forward-line 1))))))) + +(defun article-capitalize-sentences () + "Capitalize the first word in each sentence." + (interactive) + (save-excursion + (let ((buffer-read-only nil) + (paragraph-start "^[\n\^L]")) (article-goto-body) - (end-of-line 1) - (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$") - (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?") - (adaptive-fill-mode t)) - (while (not (eobp)) - (and (>= (current-column) (min fill-column (window-width))) - (/= (preceding-char) ?:) - (fill-paragraph nil)) - (end-of-line 2)))))) + (while (not (eobp)) + (capitalize-word 1) + (forward-sentence))))) (defun article-remove-cr () - "Translate CRLF pairs into LF, and then CR into LF.." + "Remove trailing CRs and then translate remaining CRs into LFs." (interactive) (save-excursion (let ((buffer-read-only nil)) (goto-char (point-min)) - (while (search-forward "\r$" nil t) + (while (re-search-forward "\r+$" nil t) (replace-match "" t t)) (goto-char (point-min)) (while (search-forward "\r" nil t) @@ -1212,42 +1795,64 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (defun article-display-x-face (&optional force) "Look for an X-Face header and display it if present." (interactive (list 'force)) - (save-excursion - ;; Delete the old process, if any. - (when (process-status "article-x-face") - (delete-process "article-x-face")) - (let ((inhibit-point-motion-hooks t) - (case-fold-search t) - from last) - (save-restriction - (nnheader-narrow-to-headers) - (setq from (message-fetch-field "from")) - (goto-char (point-min)) - (while (and gnus-article-x-face-command - (not last) - (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)))) - ;; Has to be present. - (re-search-forward "^X-Face: " nil t)) - ;; This used to try to do multiple faces (`while' instead of - ;; `when' above), but (a) sending multiple EOFs to xv doesn't - ;; work (b) it can crash some versions of Emacs (c) are - ;; multiple faces really something to encourage? - (when (stringp gnus-article-x-face-command) - (setq last t)) - ;; We now have the area of the buffer where the X-Face is stored. + (let ((wash-face-p buffer-read-only)) ;; When type `W f' + (gnus-with-article-headers + ;; Delete the old process, if any. + (when (process-status "article-x-face") + (delete-process "article-x-face")) + (if (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) (save-excursion - (let ((beg (point)) - (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))) + (when (and wash-face-p + (progn + (goto-char (point-min)) + (not (re-search-forward + "^X-Face\\(-[0-9]+\\)?:[\t ]*" nil t))) + (gnus-buffer-live-p gnus-original-article-buffer)) + ;; If type `W f', use gnus-original-article-buffer, + ;; otherwise use the current buffer because displaying + ;; RFC822 parts calls this function too. + (set-buffer gnus-original-article-buffer)) + (save-restriction + (mail-narrow-to-head) + (while (gnus-article-goto-header "x-face\\(-[0-9]+\\)?") + (when (match-beginning 2) + (setq grey t)) + (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 beg end) + (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. @@ -1256,7 +1861,10 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (start-process "article-x-face" nil shell-file-name shell-command-switch gnus-article-x-face-command)) - (process-send-region "article-x-face" beg end) + (with-temp-buffer + (insert face) + (process-send-region "article-x-face" + (point-min) (point-max))) (process-send-eof "article-x-face")))))))))) (defun article-decode-mime-words () @@ -1266,86 +1874,242 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (set-buffer gnus-article-buffer) (let ((inhibit-point-motion-hooks t) buffer-read-only - (mail-parse-charset gnus-newsgroup-charset)) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets))) (mail-decode-encoded-word-region (point-min) (point-max))))) (defun article-decode-charset (&optional prompt) "Decode charset-encoded text in the article. If PROMPT (the prefix), prompt for a coding system to use." (interactive "P") + (let ((inhibit-point-motion-hooks t) (case-fold-search t) + buffer-read-only + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (condition-case nil + (set-buffer gnus-summary-buffer) + (error)) + gnus-newsgroup-ignored-charsets)) + ct cte ctl charset format) (save-excursion (save-restriction - (message-narrow-to-head) - (let* ((inhibit-point-motion-hooks t) - (case-fold-search t) - (ct (message-fetch-field "Content-Type" t)) - (cte (message-fetch-field "Content-Transfer-Encoding" t)) - (ctl (and ct (condition-case () - (mail-header-parse-content-type ct) - (error nil)))) - (charset (cond - (prompt - (mm-read-coding-system "Charset to decode: ")) - (ctl - (mail-content-type-get ctl 'charset)))) - (mail-parse-charset gnus-newsgroup-charset) - buffer-read-only) - (goto-char (point-max)) - (widen) - (forward-line 1) - (narrow-to-region (point) (point-max)) - (when (and (or (not ctl) - (equal (car ctl) "text/plain")) - (not (mm-uu-test))) - (mm-decode-body - charset (and cte (intern (downcase - (gnus-strip-whitespace cte)))) - (car ctl))))))) + (article-narrow-to-head) + (setq ct (message-fetch-field "Content-Type" t) + cte (message-fetch-field "Content-Transfer-Encoding" t) + ctl (and ct (ignore-errors + (mail-header-parse-content-type ct))) + charset (cond + (prompt + (mm-read-coding-system "Charset to decode: ")) + (ctl + (mail-content-type-get ctl 'charset))) + format (and ctl (mail-content-type-get ctl 'format))) + (when cte + (setq cte (mail-header-strip cte))) + (if (and ctl (not (string-match "/" (car ctl)))) + (setq ctl nil)) + (goto-char (point-max))) + (forward-line 1) + (save-restriction + (narrow-to-region (point) (point-max)) + (when (and (eq mail-parse-charset 'gnus-decoded) + (eq (mm-body-7-or-8) '8bit)) + ;; The text code could have been decoded. + (setq charset mail-parse-charset)) + (when (and (or (not ctl) + (equal (car ctl) "text/plain")) + (not format)) ;; article with format will decode later. + (mm-decode-body + charset (and cte (intern (downcase + (gnus-strip-whitespace cte)))) + (car ctl))))))) (defun article-decode-encoded-words () "Remove encoded-word encoding from headers." (let ((inhibit-point-motion-hooks t) (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (condition-case nil + (set-buffer gnus-summary-buffer) + (error)) + gnus-newsgroup-ignored-charsets)) buffer-read-only) (save-restriction - (message-narrow-to-head) + (article-narrow-to-head) (funcall gnus-decode-header-function (point-min) (point-max))))) -(defun article-de-quoted-unreadable (&optional force) +(defun article-decode-group-name () + "Decode group names in `Newsgroups:'." + (let ((inhibit-point-motion-hooks t) + buffer-read-only + (method (gnus-find-method-for-group gnus-newsgroup-name))) + (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)))))) + +(defun article-de-quoted-unreadable (&optional force read-charset) "Translate a quoted-printable-encoded article. If FORCE, decode the article whether it is marked as quoted-printable -or not." - (interactive (list 'force)) +or not. +If READ-CHARSET, ask for a coding system." + (interactive (list 'force current-prefix-arg)) (save-excursion - (let ((buffer-read-only nil) - (type (gnus-fetch-field "content-transfer-encoding")) - (charset gnus-newsgroup-charset)) + (let ((buffer-read-only nil) type charset) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer + (setq type + (gnus-fetch-field "content-transfer-encoding")) + (let* ((ct (gnus-fetch-field "content-type")) + (ctl (and ct + (ignore-errors + (mail-header-parse-content-type ct))))) + (setq charset (and ctl + (mail-content-type-get ctl 'charset))) + (if (stringp charset) + (setq charset (intern (downcase charset))))))) + (if read-charset + (setq charset (mm-read-coding-system "Charset: " charset))) + (unless charset + (setq charset gnus-newsgroup-charset)) (when (or force - (and type (string-match "quoted-printable" (downcase type)))) + (and type (let ((case-fold-search t)) + (string-match "quoted-printable" type)))) + (article-goto-body) + (quoted-printable-decode-region + (point) (point-max) (mm-charset-to-coding-system charset)))))) + +(defun article-de-base64-unreadable (&optional force read-charset) + "Translate a base64 article. +If FORCE, decode the article whether it is marked as base64 not. +If READ-CHARSET, ask for a coding system." + (interactive (list 'force current-prefix-arg)) + (save-excursion + (let ((buffer-read-only nil) type charset) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer + (setq type + (gnus-fetch-field "content-transfer-encoding")) + (let* ((ct (gnus-fetch-field "content-type")) + (ctl (and ct + (ignore-errors + (mail-header-parse-content-type ct))))) + (setq charset (and ctl + (mail-content-type-get ctl 'charset))) + (if (stringp charset) + (setq charset (intern (downcase charset))))))) + (if read-charset + (setq charset (mm-read-coding-system "Charset: " charset))) + (unless charset + (setq charset gnus-newsgroup-charset)) + (when (or force + (and type (let ((case-fold-search t)) + (string-match "base64" type)))) (article-goto-body) (save-restriction (narrow-to-region (point) (point-max)) - (quoted-printable-decode-region (point-min) (point-max)) - (when charset - (mm-decode-body charset))))))) + (base64-decode-region (point-min) (point-max)) + (mm-decode-coding-region + (point-min) (point-max) (mm-charset-to-coding-system charset))))))) -(defun article-hide-pgp (&optional arg) - "Toggle hiding of any PGP headers and signatures in the current article. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (gnus-article-hidden-arg)) - (unless (gnus-article-check-hidden-text 'pgp arg) - (save-excursion +(eval-when-compile + (require 'rfc1843)) + +(defun article-decode-HZ () + "Translate a HZ-encoded article." + (interactive) + (require 'rfc1843) + (save-excursion + (let ((buffer-read-only nil)) + (rfc1843-decode-region (point-min) (point-max))))) + +(defun article-wash-html (&optional read-charset) + "Format an html article. +If READ-CHARSET, ask for a coding system." + (interactive "P") + (save-excursion + (let ((buffer-read-only nil) + charset) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer + (let* ((ct (gnus-fetch-field "content-type")) + (ctl (and ct + (ignore-errors + (mail-header-parse-content-type ct))))) + (setq charset (and ctl + (mail-content-type-get ctl 'charset))) + (if (stringp charset) + (setq charset (intern (downcase charset))))))) + (if read-charset + (setq charset (mm-read-coding-system "Charset: " charset))) + (unless charset + (setq charset gnus-newsgroup-charset)) + (article-goto-body) + (save-window-excursion + (save-restriction + (narrow-to-region (point) (point-max)) + (mm-setup-w3) + (let ((w3-strict-width (window-width)) + (url-standalone-mode t) + (w3-honor-stylesheets nil) + (w3-delay-image-loads t)) + (condition-case var + (w3-region (point-min) (point-max)) + (error)))))))) + +(defun article-hide-list-identifiers () + "Remove list identifies from the Subject header. +The `gnus-list-identifiers' variable specifies what to do." + (interactive) + (let ((inhibit-point-motion-hooks t) + (regexp (if (consp gnus-list-identifiers) + (mapconcat 'identity gnus-list-identifiers " *\\|") + gnus-list-identifiers)) + buffer-read-only) + (when regexp + (save-excursion + (save-restriction + (article-narrow-to-head) + (goto-char (point-min)) + (while (re-search-forward + (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)") + nil t) + (delete-region (match-beginning 2) (match-end 0)) + (beginning-of-line)) + (when (re-search-forward + "^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) - (widen) - (goto-char (point-min)) + (article-goto-body) ;; Hide the "header". - (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) - (delete-region (1+ (match-beginning 0)) (match-end 0)) - ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too - (when (looking-at "Hash:.*$") - (delete-region (point) (1+ (gnus-point-at-eol)))) + (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) @@ -1375,25 +2139,66 @@ always hide." (unless (gnus-article-check-hidden-text 'pem arg) (save-excursion (let (buffer-read-only end) - (widen) (goto-char (point-min)) - ;; hide the horrendously ugly "header". - (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" - nil - t) - (setq end (1+ (match-beginning 0))) - (gnus-article-hide-text-type - end - (if (search-forward "\n\n" nil t) - (match-end 0) - (point-max)) - 'pem)) - ;; hide the trailer as well - (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" - nil - t) - (gnus-article-hide-text-type - (match-beginning 0) (match-end 0) 'pem)))))) + ;; Hide the horrendously ugly "header". + (when (and (search-forward + "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" + nil t) + (setq end (1+ (match-beginning 0)))) + (gnus-add-wash-type 'pem) + (gnus-article-hide-text-type + end + (if (search-forward "\n\n" nil t) + (match-end 0) + (point-max)) + 'pem) + ;; Hide the trailer as well + (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" + nil t) + (gnus-article-hide-text-type + (match-beginning 0) (match-end 0) 'pem))))))) + +(defun article-strip-banner () + "Strip the banner specified by the `banner' group parameter." + (interactive) + (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 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)))))))))) + +(defun article-babel () + "Translate article using an online translation service." + (interactive) + (require 'babel) + (save-excursion + (set-buffer gnus-article-buffer) + (when (article-goto-body) + (let* ((buffer-read-only nil) + (start (point)) + (end (point-max)) + (orig (buffer-substring start end)) + (trans (babel-as-string orig))) + (save-restriction + (narrow-to-region start end) + (delete-region start end) + (insert trans)))))) (defun article-hide-signature (&optional arg) "Hide the signature in the current article. @@ -1406,7 +2211,17 @@ always hide." (let ((buffer-read-only nil)) (when (gnus-article-narrow-to-signature) (gnus-article-hide-text-type - (point-min) (point-max) 'signature))))))) + (point-min) (point-max) 'signature)))))) + (gnus-set-mode-line 'article)) + +(defun article-strip-headers-in-body () + "Strip offensive headers from bodies." + (interactive) + (save-excursion + (article-goto-body) + (let ((case-fold-search t)) + (when (looking-at "x-no-archive:") + (gnus-delete-line))))) (defun article-strip-leading-blank-lines () "Remove all blank lines from the beginning of the article." @@ -1419,10 +2234,22 @@ always hide." (looking-at "[ \t]*$")) (gnus-delete-line)))))) +(defun article-narrow-to-head () + "Narrow the buffer to the head of the message. +Point is left at the beginning of the narrowed-to region." + (narrow-to-region + (goto-char (point-min)) + (if (search-forward "\n\n" nil 1) + (1- (point)) + (point-max))) + (goto-char (point-min))) + (defun article-goto-body () "Place point at the start of the body." (goto-char (point-min)) (cond + ;; This variable is only bound when dealing with separate + ;; MIME body parts. (article-goto-body-goes-to-point-min-p t) ((search-forward "\n\n" nil t) @@ -1445,10 +2272,10 @@ always hide." (replace-match "" nil t))) ;; Then replace multiple empty lines with a single empty line. (article-goto-body) - (while (re-search-forward "\n\n\n+" nil t) + (while (re-search-forward "\n\n\\(\n+\\)" nil t) (unless (gnus-annotation-in-region-p (match-beginning 0) (match-end 0)) - (replace-match "\n\n" t t)))))) + (delete-region (match-beginning 1) (match-end 1))))))) (defun article-strip-leading-space () "Remove all white space from the beginning of the lines in the article." @@ -1489,7 +2316,6 @@ always hide." (defun gnus-article-narrow-to-signature () "Narrow to the signature; return t if a signature is found, else nil." - (widen) (let ((inhibit-point-motion-hooks t)) (when (gnus-article-search-signature) (forward-line 1) @@ -1530,38 +2356,6 @@ Put point at the beginning of the signature separator." (goto-char cur) nil))) -(eval-and-compile - (autoload 'w3-display "w3-parse") - (autoload 'w3-do-setup "w3" "" t) - (autoload 'w3-region "w3-display" "" t)) - -(defun gnus-article-treat-html () - "Render HTML." - (interactive) - (let ((cbuf (current-buffer))) - (set-buffer gnus-article-buffer) - (let (buf buffer-read-only b e) - (w3-do-setup) - (goto-char (point-min)) - (narrow-to-region - (if (search-forward "\n\n" nil t) - (setq b (point)) - (point-max)) - (setq e (point-max))) - (with-temp-buffer - (insert-buffer-substring gnus-article-buffer b e) - (require 'url) - (save-window-excursion - (w3-region (point-min) (point-max)) - (setq buf (buffer-substring-no-properties (point-min) (point-max))))) - (when buf - (delete-region (point-min) (point-max)) - (insert buf)) - (widen) - (goto-char (point-min)) - (set-window-start (get-buffer-window (current-buffer)) (point-min)) - (set-buffer cbuf)))) - (defun gnus-article-hidden-arg () "Return the current prefix arg as a number, or 0 if no prefix." (list (if current-prefix-arg @@ -1570,52 +2364,48 @@ Put point at the beginning of the signature separator." (defun gnus-article-check-hidden-text (type arg) "Return nil if hiding is necessary. -Arg can be nil or a number. Nil and positive means hide, negative +Arg can be nil or a number. nil and positive means hide, negative means show, 0 means toggle." (save-excursion (save-restriction - (widen) (let ((hide (gnus-article-hidden-text-p type))) (cond ((or (null arg) (> arg 0)) nil) ((< arg 0) - (gnus-article-show-hidden-text type)) + (gnus-article-show-hidden-text type) + t) (t (if (eq hide 'hidden) - (gnus-article-show-hidden-text type) + (progn + (gnus-article-show-hidden-text type) + t) nil))))))) (defun gnus-article-hidden-text-p (type) "Say whether the current buffer contains hidden text of type TYPE." (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) (while (and pos - (not (get-text-property pos 'invisible))) + (not (get-text-property pos 'invisible)) + (not (get-text-property pos 'dummy-invisible))) (setq pos (text-property-any (1+ pos) (point-max) 'article-type type))) (if pos 'hidden nil))) -(defun gnus-article-show-hidden-text (type &optional hide) +(defun gnus-article-show-hidden-text (type &optional dummy) "Show all hidden text of type TYPE. -If HIDE, hide the text instead." - (save-excursion - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (end (point-min)) - beg) - (while (setq beg (text-property-any end (point-max) 'article-type type)) - (goto-char beg) - (setq end (or - (text-property-not-all beg (point-max) 'article-type type) - (point-max))) - (if hide - (gnus-article-hide-text beg end gnus-hidden-properties) - (gnus-article-unhide-text beg end)) - (goto-char end)) - t))) +Originally it is hide instead of DUMMY." + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t)) + (gnus-remove-text-properties-when + 'article-type type + (point-min) (point-max) + (cons 'article-type (cons type + gnus-hidden-properties))) + (gnus-delete-wash-type type))) (defconst article-time-units `((year . ,(* 365.25 24 60 60)) @@ -1629,141 +2419,188 @@ If HIDE, hide the text instead." (defun article-date-ut (&optional type highlight header) "Convert DATE date to universal time in the current article. If TYPE is `local', convert to local time; if it is `lapsed', output -how much time has lapsed since DATE." +how much time has lapsed since DATE. For `lapsed', the value of +`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header +should replace the \"Date:\" one, or should be added below it." (interactive (list 'ut t)) (let* ((header (or header - (mail-header-date (save-excursion - (set-buffer gnus-summary-buffer) - gnus-current-headers)) (message-fetch-field "date") "")) + (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") + (date-regexp + (cond + ((not gnus-article-date-lapsed-new-header) + tdate-regexp) + ((eq type 'lapsed) + "^X-Sent:[ \t]") + (t + "^Date:[ \t]"))) (date (if (vectorp header) (mail-header-date header) header)) - (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") (inhibit-point-motion-hooks t) - bface eface newline) - (when (and date (not (string= date ""))) - (save-excursion - (save-restriction - (nnheader-narrow-to-headers) + pos + bface eface) + (save-excursion + (save-restriction + (article-narrow-to-head) + (when (re-search-forward tdate-regexp nil t) + (setq bface (get-text-property (gnus-point-at-bol) 'face) + date (or (get-text-property (gnus-point-at-bol) + 'original-date) + date) + eface (get-text-property (1- (gnus-point-at-eol)) 'face)) + (forward-line 1)) + (when (and date (not (string= date ""))) + (goto-char (point-min)) (let ((buffer-read-only nil)) ;; Delete any old Date headers. - (if (re-search-forward date-regexp nil t) - (progn - (setq bface (get-text-property (gnus-point-at-bol) 'face) - eface (get-text-property (1- (gnus-point-at-eol)) - 'face)) + (while (re-search-forward date-regexp nil t) + (if pos (delete-region (progn (beginning-of-line) (point)) - (progn (end-of-line) (point))) - (beginning-of-line)) - (goto-char (point-max)) - (setq newline t)) - (insert (article-make-date-line date type)) + (progn (forward-line 1) (point))) + (delete-region (progn (beginning-of-line) (point)) + (progn (end-of-line) (point))) + (setq pos (point)))) + (when (and (not pos) (re-search-forward tdate-regexp nil t)) + (forward-line 1)) + (if pos (goto-char pos)) + (insert (article-make-date-line date (or type 'ut))) + (when (not pos) + (insert "\n") + (forward-line -1)) ;; Do highlighting. (beginning-of-line) (when (looking-at "\\([^:]+\\): *\\(.*\\)$") (put-text-property (match-beginning 1) (1+ (match-end 1)) + 'original-date date) + (put-text-property (match-beginning 1) (1+ (match-end 1)) 'face bface) (put-text-property (match-beginning 2) (match-end 2) - 'face eface)) - (when newline - (end-of-line) - (insert "\n")))))))) + 'face eface)))))))) (defun article-make-date-line (date type) "Return a DATE line of TYPE." - (let ((time (condition-case () - (date-to-time date) - (error '(0 0))))) - (cond - ;; Convert to the local timezone. We have to slap a - ;; `condition-case' round the calls to the timezone - ;; functions since they aren't particularly resistant to - ;; buggy dates. - ((eq type 'local) - (let ((tz (car (current-time-zone)))) - (format "Date: %s %s%04d" (current-time-string time) - (if (> tz 0) "+" "-") (abs (/ tz 36))))) - ;; Convert to Universal Time. - ((eq type 'ut) - (concat "Date: " - (current-time-string - (let* ((e (parse-time-string date)) - (tm (apply 'encode-time e)) - (ms (car tm)) - (ls (- (cadr tm) (car (current-time-zone))))) - (cond ((< ls 0) (list (1- ms) (+ ls 65536))) - ((> ls 65535) (list (1+ ms) (- ls 65536))) - (t (list ms ls))))) - " UT")) - ;; Get the original date from the article. - ((eq type 'original) - (concat "Date: " (if (string-match "\n+$" date) - (substring date 0 (match-beginning 0)) - date))) - ;; Let the user define the format. - ((eq type 'user) - (if (gnus-functionp gnus-article-time-format) - (funcall gnus-article-time-format time) - (concat - "Date: " - (format-time-string gnus-article-time-format time)))) - ;; ISO 8601. - ((eq type 'iso8601) - (concat - "Date: " - (format-time-string "%Y%m%dT%H%M%S" time))) - ;; Do an X-Sent lapsed format. - ((eq type 'lapsed) - ;; If the date is seriously mangled, the timezone functions are - ;; liable to bug out, so we ignore all errors. - (let* ((now (current-time)) - (real-time (subtract-time now time)) - (real-sec (and real-time - (+ (* (float (car real-time)) 65536) - (cadr real-time)))) - (sec (and real-time (abs real-sec))) - num prev) + (unless (memq type '(local ut original user iso8601 lapsed english)) + (error "Unknown conversion type: %s" type)) + (condition-case () + (let ((time (date-to-time date))) (cond - ((null real-time) - "X-Sent: Unknown") - ((zerop sec) - "X-Sent: Now") - (t - (concat - "X-Sent: " - ;; This is a bit convoluted, but basically we go - ;; through the time units for years, weeks, etc, - ;; and divide things to see whether that results - ;; in positive answers. - (mapconcat - (lambda (unit) - (if (zerop (setq num (ffloor (/ sec (cdr unit))))) - ;; The (remaining) seconds are too few to - ;; be divided into this time unit. - "" - ;; It's big enough, so we output it. - (setq sec (- sec (* num (cdr unit)))) - (prog1 - (concat (if prev ", " "") (int-to-string - (floor num)) - " " (symbol-name (car unit)) - (if (> num 1) "s" "")) - (setq prev t)))) - article-time-units "") - ;; If dates are odd, then it might appear like the - ;; article was sent in the future. - (if (> real-sec 0) - " ago" - " in the future")))))) - (t - (error "Unknown conversion type: %s" type))))) + ;; Convert to the local timezone. + ((eq type 'local) + (let ((tz (car (current-time-zone time)))) + (format "Date: %s %s%02d%02d" (current-time-string time) + (if (> tz 0) "+" "-") (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60)))) + ;; Convert to Universal Time. + ((eq type 'ut) + (concat "Date: " + (current-time-string + (let* ((e (parse-time-string date)) + (tm (apply 'encode-time e)) + (ms (car tm)) + (ls (- (cadr tm) (car (current-time-zone time))))) + (cond ((< ls 0) (list (1- ms) (+ ls 65536))) + ((> ls 65535) (list (1+ ms) (- ls 65536))) + (t (list ms ls))))) + " UT")) + ;; Get the original date from the article. + ((eq type 'original) + (concat "Date: " (if (string-match "\n+$" date) + (substring date 0 (match-beginning 0)) + date))) + ;; Let the user define the format. + ((eq type 'user) + (if (gnus-functionp gnus-article-time-format) + (funcall gnus-article-time-format time) + (concat + "Date: " + (format-time-string gnus-article-time-format time)))) + ;; ISO 8601. + ((eq type 'iso8601) + (let ((tz (car (current-time-zone time)))) + (concat + "Date: " + (format-time-string "%Y%m%dT%H%M%S" time) + (format "%s%02d%02d" + (if (> tz 0) "+" "-") (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60))))) + ;; Do an X-Sent lapsed format. + ((eq type 'lapsed) + ;; If the date is seriously mangled, the timezone functions are + ;; liable to bug out, so we ignore all errors. + (let* ((now (current-time)) + (real-time (subtract-time now time)) + (real-sec (and real-time + (+ (* (float (car real-time)) 65536) + (cadr real-time)))) + (sec (and real-time (abs real-sec))) + num prev) + (cond + ((null real-time) + "X-Sent: Unknown") + ((zerop sec) + "X-Sent: Now") + (t + (concat + "X-Sent: " + ;; This is a bit convoluted, but basically we go + ;; through the time units for years, weeks, etc, + ;; and divide things to see whether that results + ;; in positive answers. + (mapconcat + (lambda (unit) + (if (zerop (setq num (ffloor (/ sec (cdr unit))))) + ;; The (remaining) seconds are too few to + ;; be divided into this time unit. + "" + ;; It's big enough, so we output it. + (setq sec (- sec (* num (cdr unit)))) + (prog1 + (concat (if prev ", " "") (int-to-string + (floor num)) + " " (symbol-name (car unit)) + (if (> num 1) "s" "")) + (setq prev t)))) + article-time-units "") + ;; If dates are odd, then it might appear like the + ;; article was sent in the future. + (if (> real-sec 0) + " ago" + " in the future")))))) + ;; Display the date in proper English + ((eq type 'english) + (let ((dtime (decode-time time))) + (concat + "Date: the " + (number-to-string (nth 3 dtime)) + (let ((digit (% (nth 3 dtime) 10))) + (cond + ((memq (nth 3 dtime) '(11 12 13)) "th") + ((= digit 1) "st") + ((= digit 2) "nd") + ((= digit 3) "rd") + (t "th"))) + " of " + (nth (1- (nth 4 dtime)) gnus-english-month-names) + " " + (number-to-string (nth 5 dtime)) + " at " + (format "%02d" (nth 2 dtime)) + ":" + (format "%02d" (nth 1 dtime))))))) + (error + (format "Date: %s (from Oort)" date)))) (defun article-date-local (&optional highlight) "Convert the current article date to the local timezone." (interactive (list t)) (article-date-ut 'local highlight)) +(defun article-date-english (&optional highlight) + "Convert the current article date to something that is proper English." + (interactive (list t)) + (article-date-ut 'english highlight)) + (defun article-date-original (&optional highlight) "Convert the current article date to what it was originally. This is only useful if you have used some other date conversion @@ -1819,19 +2656,35 @@ This format is defined by the `gnus-article-time-format' variable." (interactive (list t)) (article-date-ut 'iso8601 highlight)) -(defun article-show-all () - "Show all hidden text in the article buffer." +;; (defun article-show-all () +;; "Show all hidden text in the article buffer." +;; (interactive) +;; (save-excursion +;; (let ((buffer-read-only nil)) +;; (gnus-article-unhide-text (point-min) (point-max))))) + +(defun article-remove-leading-whitespace () + "Remove excessive whitespace from all headers." (interactive) (save-excursion - (let ((buffer-read-only nil)) - (gnus-article-unhide-text (point-min) (point-max))))) + (save-restriction + (let ((buffer-read-only nil)) + (article-narrow-to-head) + (goto-char (point-min)) + (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t) + (delete-region (match-beginning 1) (match-end 1))))))) (defun article-emphasize (&optional arg) "Emphasize text according to `gnus-emphasis-alist'." (interactive (gnus-article-hidden-arg)) (unless (gnus-article-check-hidden-text 'emphasis arg) (save-excursion - (let ((alist gnus-emphasis-alist) + (let ((alist (or + (condition-case nil + (with-current-buffer gnus-summary-buffer + gnus-article-emphasis-alist) + (error)) + gnus-emphasis-alist)) (buffer-read-only nil) (props (append '(article-type emphasis) gnus-hidden-properties)) @@ -1845,17 +2698,39 @@ This format is defined by the `gnus-article-time-format' variable." visible (nth 2 elem) face (nth 3 elem)) (while (re-search-forward regexp nil t) - (when (and (match-beginning visible) (match-beginning invisible)) - (gnus-article-hide-text - (match-beginning invisible) (match-end invisible) props) - (gnus-article-unhide-text-type - (match-beginning visible) (match-end visible) 'emphasis) - (gnus-put-text-property-excluding-newlines - (match-beginning visible) (match-end visible) 'face face) - (goto-char (match-end invisible))))))))) - -(defvar gnus-summary-article-menu) -(defvar gnus-summary-post-menu) + (when (and (match-beginning visible) (match-beginning invisible)) + (gnus-article-hide-text + (match-beginning invisible) (match-end invisible) props) + (gnus-article-unhide-text-type + (match-beginning visible) (match-end visible) 'emphasis) + (gnus-put-overlay-excluding-newlines + (match-beginning visible) (match-end visible) 'face face) + (gnus-add-wash-type 'emphasis) + (goto-char (match-end invisible))))))))) + +(defun gnus-article-setup-highlight-words (&optional highlight-words) + "Setup newsgroup emphasis alist." + (unless gnus-article-emphasis-alist + (let ((name (and gnus-newsgroup-name + (gnus-group-real-name gnus-newsgroup-name)))) + (make-local-variable 'gnus-article-emphasis-alist) + (setq gnus-article-emphasis-alist + (nconc + (let ((alist gnus-group-highlight-words-alist) elem highlight) + (while (setq elem (pop alist)) + (when (and name (string-match (car elem) name)) + (setq alist nil + highlight (copy-sequence (cdr elem))))) + highlight) + (copy-sequence highlight-words) + (if gnus-newsgroup-name + (copy-sequence (gnus-group-find-parameter + gnus-newsgroup-name 'highlight-words t))) + gnus-emphasis-alist))))) + +(eval-when-compile + (defvar gnus-summary-article-menu) + (defvar gnus-summary-post-menu)) ;;; Saving functions. @@ -1893,76 +2768,78 @@ This format is defined by the `gnus-article-time-format' variable." (let ((default-name (funcall function group headers (symbol-value variable))) result) - (setq - result - (cond - ((eq filename 'default) - default-name) - ((eq filename t) - default-name) - (filename filename) - (t - (let* ((split-name (gnus-get-split-value gnus-split-methods)) - (prompt - (format prompt - (if (and gnus-number-of-articles-to-be-saved - (> gnus-number-of-articles-to-be-saved 1)) - (format "these %d articles" - gnus-number-of-articles-to-be-saved) - "this article"))) - (file - ;; Let the split methods have their say. - (cond - ;; No split name was found. - ((null split-name) - (read-file-name - (concat prompt " (default " - (file-name-nondirectory default-name) ") ") - (file-name-directory default-name) - default-name)) - ;; A single group name is returned. - ((stringp split-name) - (setq default-name - (funcall function split-name headers - (symbol-value variable))) - (read-file-name - (concat prompt " (default " - (file-name-nondirectory default-name) ") ") - (file-name-directory default-name) - default-name)) - ;; A single split name was found - ((= 1 (length split-name)) - (let* ((name (expand-file-name - (car split-name) gnus-article-save-directory)) - (dir (cond ((file-directory-p name) - (file-name-as-directory name)) - ((file-exists-p name) name) - (t gnus-article-save-directory)))) - (read-file-name - (concat prompt " (default " name ") ") - dir name))) - ;; A list of splits was found. - (t - (setq split-name (nreverse split-name)) - (let (result) - (let ((file-name-history - (nconc split-name file-name-history))) - (setq result - (expand-file-name - (read-file-name - (concat prompt " (`M-p' for defaults) ") - gnus-article-save-directory - (car split-name)) - gnus-article-save-directory))) - (car (push result file-name-history))))))) - ;; Create the directory. - (gnus-make-directory (file-name-directory file)) - ;; If we have read a directory, we append the default file name. - (when (file-directory-p file) - (setq file (concat (file-name-as-directory file) - (file-name-nondirectory default-name)))) - ;; Possibly translate some characters. - (nnheader-translate-file-chars file))))) + (setq result + (expand-file-name + (cond + ((eq filename 'default) + default-name) + ((eq filename t) + default-name) + (filename filename) + (t + (let* ((split-name (gnus-get-split-value gnus-split-methods)) + (prompt + (format prompt + (if (and gnus-number-of-articles-to-be-saved + (> gnus-number-of-articles-to-be-saved 1)) + (format "these %d articles" + gnus-number-of-articles-to-be-saved) + "this article"))) + (file + ;; Let the split methods have their say. + (cond + ;; No split name was found. + ((null split-name) + (read-file-name + (concat prompt " (default " + (file-name-nondirectory default-name) ") ") + (file-name-directory default-name) + default-name)) + ;; A single group name is returned. + ((stringp split-name) + (setq default-name + (funcall function split-name headers + (symbol-value variable))) + (read-file-name + (concat prompt " (default " + (file-name-nondirectory default-name) ") ") + (file-name-directory default-name) + default-name)) + ;; A single split name was found + ((= 1 (length split-name)) + (let* ((name (expand-file-name + (car split-name) + gnus-article-save-directory)) + (dir (cond ((file-directory-p name) + (file-name-as-directory name)) + ((file-exists-p name) name) + (t gnus-article-save-directory)))) + (read-file-name + (concat prompt " (default " name ") ") + dir name))) + ;; A list of splits was found. + (t + (setq split-name (nreverse split-name)) + (let (result) + (let ((file-name-history + (nconc split-name file-name-history))) + (setq result + (expand-file-name + (read-file-name + (concat prompt " (`M-p' for defaults) ") + gnus-article-save-directory + (car split-name)) + gnus-article-save-directory))) + (car (push result file-name-history))))))) + ;; Create the directory. + (gnus-make-directory (file-name-directory file)) + ;; If we have read a directory, we append the default file name. + (when (file-directory-p file) + (setq file (expand-file-name (file-name-nondirectory + default-name) + (file-name-as-directory file)))) + ;; Possibly translate some characters. + (nnheader-translate-file-chars file)))))) (gnus-make-directory (file-name-directory result)) (set variable result))) @@ -2030,7 +2907,7 @@ Directory to save to is default to `gnus-article-save-directory'." filename) (defun gnus-summary-write-to-file (&optional filename) - "Write this article to a file. + "Write this article to a file, overwriting it if the file exists. Optional argument FILENAME specifies file name. The directory to save in defaults to `gnus-article-save-directory'." (gnus-summary-save-in-file nil t)) @@ -2058,7 +2935,8 @@ The directory to save in defaults to `gnus-article-save-directory'." (cond ((and (eq command 'default) gnus-last-shell-command) gnus-last-shell-command) - (command command) + ((stringp command) + command) (t (read-string (format "Shell command on %s: " @@ -2069,13 +2947,22 @@ The directory to save in defaults to `gnus-article-save-directory'." "this article")) gnus-last-shell-command)))) (when (string-equal command "") - (setq command gnus-last-shell-command)) + (if gnus-last-shell-command + (setq command gnus-last-shell-command) + (error "A command is required"))) (gnus-eval-in-buffer-window gnus-article-buffer (save-restriction (widen) (shell-command-on-region (point-min) (point-max) command nil))) (setq gnus-last-shell-command command)) +(defun gnus-summary-pipe-to-muttprint (&optional command) + "Pipe this article to muttprint." + (setq command (read-string + "Print using command: " gnus-summary-muttprint-program + nil gnus-summary-muttprint-program)) + (gnus-summary-save-in-pipe command)) + ;;; Article file names when saving. (defun gnus-capitalize-newsgroup (newsgroup) @@ -2120,17 +3007,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is default (or last-file default)))) -(defun gnus-Plain-save-name (newsgroup headers &optional last-file) - "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. -If variable `gnus-use-long-file-name' is non-nil, it is -~/News/News.group. Otherwise, it is like ~/News/news/group/news." - (or last-file - (expand-file-name - (if (gnus-use-long-file-name 'not-save) - (gnus-capitalize-newsgroup newsgroup) - (concat (gnus-newsgroup-directory-form newsgroup) "/news")) - gnus-article-save-directory))) - (defun gnus-plain-save-name (newsgroup headers &optional last-file) "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. If variable `gnus-use-long-file-name' is non-nil, it is @@ -2139,9 +3015,99 @@ If variable `gnus-use-long-file-name' is non-nil, it is (expand-file-name (if (gnus-use-long-file-name 'not-save) newsgroup - (concat (gnus-newsgroup-directory-form newsgroup) "/news")) + (file-relative-name + (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup)) + default-directory)) gnus-article-save-directory))) +(defun gnus-sender-save-name (newsgroup headers &optional last-file) + "Generate file name from sender." + (let ((from (mail-header-from headers))) + (expand-file-name + (if (and from (string-match "\\([^ <]+\\)@" from)) + (match-string 1 from) + "nobody") + gnus-article-save-directory))) + +(defun article-verify-x-pgp-sig () + "Verify X-PGP-Sig." + (interactive) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (let ((sig (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field "X-PGP-Sig"))) + items info headers) + (when (and sig + mml2015-use + (mml2015-clear-verify-function)) + (with-temp-buffer + (insert-buffer gnus-original-article-buffer) + (setq items (split-string sig)) + (message-narrow-to-head) + (let ((inhibit-point-motion-hooks t) + (case-fold-search t)) + ;; Don't verify multiple headers. + (setq headers (mapconcat (lambda (header) + (concat header ": " + (mail-fetch-field header) "\n")) + (split-string (nth 1 items) ",") ""))) + (delete-region (point-min) (point-max)) + (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n") + (insert "X-Signed-Headers: " (nth 1 items) "\n") + (insert headers) + (widen) + (forward-line) + (while (not (eobp)) + (if (looking-at "^-") + (insert "- ")) + (forward-line)) + (insert "\n-----BEGIN PGP SIGNATURE-----\n") + (insert "Version: " (car items) "\n\n") + (insert (mapconcat 'identity (cddr items) "\n")) + (insert "\n-----END PGP SIGNATURE-----\n") + (let ((mm-security-handle (list (format "multipart/signed")))) + (mml2015-clean-buffer) + (let ((coding-system-for-write (or gnus-newsgroup-charset + 'iso-8859-1))) + (funcall (mml2015-clear-verify-function))) + (setq info + (or (mm-handle-multipart-ctl-parameter + mm-security-handle 'gnus-details) + (mm-handle-multipart-ctl-parameter + mm-security-handle 'gnus-info))))) + (when info + (let (buffer-read-only bface eface) + (save-restriction + (message-narrow-to-head) + (goto-char (point-max)) + (forward-line -1) + (setq bface (get-text-property (gnus-point-at-bol) 'face) + eface (get-text-property (1- (gnus-point-at-eol)) 'face)) + (message-remove-header "X-Gnus-PGP-Verify") + (if (re-search-forward "^X-PGP-Sig:" nil t) + (forward-line) + (goto-char (point-max))) + (narrow-to-region (point) (point)) + (insert "X-Gnus-PGP-Verify: " info "\n") + (goto-char (point-min)) + (forward-line) + (while (not (eobp)) + (if (not (looking-at "^[ \t]")) + (insert " ")) + (forward-line)) + ;; Do highlighting. + (goto-char (point-min)) + (when (looking-at "\\([^:]+\\): *") + (put-text-property (match-beginning 1) (1+ (match-end 1)) + 'face bface) + (put-text-property (match-end 0) (point-max) + 'face eface))))))))) + +(defun article-verify-cancel-lock () + "Verify Cancel-Lock header." + (interactive) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (canlock-verify gnus-original-article-buffer))) + (eval-and-compile (mapcar (lambda (func) @@ -2151,28 +3117,37 @@ If variable `gnus-use-long-file-name' is non-nil, it is gfunc (cdr func)) (setq afunc func gfunc (intern (format "gnus-%s" func)))) - (fset gfunc - (if (not (fboundp afunc)) - nil - `(lambda (&optional interactive &rest args) - ,(documentation afunc t) - (interactive (list t)) - (save-excursion - (set-buffer gnus-article-buffer) - (if interactive - (call-interactively ',afunc) - (apply ',afunc args)))))))) + (defalias gfunc + (when (fboundp afunc) + `(lambda (&optional interactive &rest args) + ,(documentation afunc t) + (interactive (list t)) + (save-excursion + (set-buffer gnus-article-buffer) + (if interactive + (call-interactively ',afunc) + (apply ',afunc args)))))))) '(article-hide-headers + article-verify-x-pgp-sig + article-verify-cancel-lock article-hide-boring-headers article-treat-overstrike - (article-fill . gnus-article-word-wrap) + article-fill-long-lines + article-capitalize-sentences article-remove-cr + article-remove-leading-whitespace article-display-x-face article-de-quoted-unreadable - article-mime-decode-quoted-printable + article-de-base64-unreadable + article-decode-HZ + article-wash-html + article-hide-list-identifiers article-hide-pgp + article-strip-banner + article-babel article-hide-pem article-hide-signature + article-strip-headers-in-body article-remove-trailing-blank-lines article-strip-leading-blank-lines article-strip-multiple-blank-lines @@ -2180,7 +3155,9 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-strip-trailing-space article-strip-blank-lines article-strip-all-blank-lines + article-replace-with-quoted-text article-date-local + article-date-english article-date-iso8601 article-date-original article-date-ut @@ -2192,7 +3169,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-emphasize article-treat-dumbquotes article-normalize-headers - (article-show-all . gnus-article-show-all-headers)))) +;; (article-show-all . gnus-article-show-all-headers) + ))) ;;; ;;; Gnus article mode @@ -2212,11 +3190,15 @@ If variable `gnus-use-long-file-name' is non-nil, it is "s" gnus-article-show-summary "\C-c\C-m" gnus-article-mail "?" gnus-article-describe-briefly - "e" gnus-article-edit + "e" gnus-summary-edit-article "<" beginning-of-buffer ">" end-of-buffer "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug + "R" gnus-article-reply-with-original + "F" gnus-article-followup-with-original + "\C-hk" gnus-article-describe-key + "\C-hc" gnus-article-describe-key-briefly "\C-d" gnus-article-read-summary-keys "\M-*" gnus-article-read-summary-keys @@ -2228,6 +3210,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map) (defun gnus-article-make-menu-bar () + (unless (boundp 'gnus-article-commands-menu) + (gnus-summary-make-menu-bar)) (gnus-turn-off-edit-menu 'article) (unless (boundp 'gnus-article-article-menu) (easy-menu-define @@ -2242,22 +3226,28 @@ If variable `gnus-use-long-file-name' is non-nil, it is (easy-menu-define gnus-article-treatment-menu gnus-article-mode-map "" + ;; Fixme: this should use :active (and maybe :visible). '("Treatment" ["Hide headers" gnus-article-hide-headers t] ["Hide signature" gnus-article-hide-signature t] ["Hide citation" gnus-article-hide-citation t] ["Treat overstrike" gnus-article-treat-overstrike t] ["Remove carriage return" gnus-article-remove-cr t] - ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) + ["Remove leading whitespace" gnus-article-remove-leading-whitespace t] + ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] + ["Remove base64" gnus-article-de-base64-unreadable t] + ["Treat html" gnus-article-wash-html t] + ["Decode HZ" gnus-article-decode-HZ t])) ;; Note "Commands" menu is defined in gnus-sum.el for consistency - (when (boundp 'gnus-summary-post-menu) - (define-key gnus-article-mode-map [menu-bar post] - (cons "Post" gnus-summary-post-menu))) + ;; Note "Post" menu is defined in gnus-sum.el for consistency (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. @@ -2274,13 +3264,13 @@ commands: \\[gnus-article-describe-briefly]\t Describe the current mode briefly \\[gnus-info-find-node]\t Go to the Gnus info node" (interactive) - (when (gnus-visual-p 'article-menu 'menu) - (gnus-article-make-menu-bar)) (gnus-simplify-mode-line) (setq mode-name "Article") (setq major-mode 'gnus-article-mode) (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-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) (make-local-variable 'gnus-page-broken) @@ -2289,6 +3279,10 @@ commands: (make-local-variable 'gnus-article-mime-handles) (make-local-variable 'gnus-article-decoded-p) (make-local-variable 'gnus-article-mime-handle-alist) + (make-local-variable 'gnus-article-wash-types) + (make-local-variable 'gnus-article-image-alist) + (make-local-variable 'gnus-article-charset) + (make-local-variable 'gnus-article-ignored-charsets) (gnus-set-default-directory) (buffer-disable-undo) (setq buffer-read-only t) @@ -2314,6 +3308,7 @@ commands: (setq gnus-article-buffer name) (setq gnus-original-article-buffer original) (gnus-set-global-variables))) + (gnus-article-setup-highlight-words) ;; Init original article buffer. (save-excursion (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) @@ -2323,6 +3318,11 @@ commands: (if (get-buffer name) (save-excursion (set-buffer name) + (when gnus-article-mime-handles + (mm-destroy-parts gnus-article-mime-handles) + (setq gnus-article-mime-handles nil)) + ;; Set it to nil in article-buffer! + (setq gnus-article-mime-handle-alist nil) (buffer-disable-undo) (setq buffer-read-only t) (unless (eq major-mode 'gnus-article-mode) @@ -2339,7 +3339,7 @@ commands: ;; from the head of the article. (defun gnus-article-set-window-start (&optional line) (set-window-start - (get-buffer-window gnus-article-buffer t) + (gnus-get-buffer-window gnus-article-buffer t) (save-excursion (set-buffer gnus-article-buffer) (goto-char (point-min)) @@ -2389,8 +3389,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (message "Message marked for downloading")) (gnus-summary-mark-article article gnus-canceled-mark) (unless (memq article gnus-newsgroup-sparse) - (gnus-error 1 - "No such article (may have expired or been canceled)"))))) + (gnus-error 1 "No such article (may have expired or been canceled)"))))) (if (or (eq result 'pseudo) (eq result 'nneething)) (progn @@ -2438,11 +3437,11 @@ If ALL-HEADERS is non-nil, no headers are hidden." (when (gnus-visual-p 'article-highlight 'highlight) (gnus-run-hooks 'gnus-visual-mark-article-hook)) ;; Set the global newsgroup variables here. - ;; Suggested by Jim Sisolak - ;; . (gnus-set-global-variables) (setq gnus-have-all-headers (or all-headers gnus-show-all-headers)))) + (save-excursion + (gnus-configure-windows 'article)) (when (or (numberp article) (stringp article)) (gnus-article-prepare-display) @@ -2455,9 +3454,9 @@ If ALL-HEADERS is non-nil, no headers are hidden." (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) (gnus-set-mode-line 'article)) - (gnus-configure-windows 'article) (article-goto-body) (set-window-point (get-buffer-window (current-buffer)) (point)) + (gnus-configure-windows 'article) t)))))) ;;;###autoload @@ -2469,25 +3468,32 @@ If ALL-HEADERS is non-nil, no headers are hidden." buffer-read-only) (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) - (setq buffer-read-only nil) + (setq buffer-read-only nil + gnus-article-wash-types nil + gnus-article-image-alist nil) (gnus-run-hooks 'gnus-tmp-internal-hook) - (gnus-run-hooks 'gnus-article-prepare-hook) (when gnus-display-mime-function - (funcall gnus-display-mime-function)))) + (funcall gnus-display-mime-function)) + (gnus-run-hooks 'gnus-article-prepare-hook))) ;;; ;;; Gnus MIME viewing functions ;;; (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n" - "The following specs can be used: + "Format of the MIME buttons. + +Valid specifiers include: %t The MIME type %T MIME type, along with additional info %n The `name' parameter %d The description, if any %l The length of the encoded part %p The part identifier number -%e Dots if the part isn't displayed") +%e Dots if the part isn't displayed + +General format specifiers can also be used. See +(gnus)Formatting Variables.") (defvar gnus-mime-button-line-format-alist '((?t gnus-tmp-type ?s) @@ -2499,36 +3505,44 @@ If ALL-HEADERS is non-nil, no headers are hidden." (?e gnus-tmp-dots ?s))) (defvar gnus-mime-button-commands - '((gnus-article-press-button "\r" "Toggle Display") - (gnus-mime-view-part "v" "View Interactively...") - (gnus-mime-save-part "o" "Save...") - (gnus-mime-copy-part "c" "View As Text, In Other Buffer") - (gnus-mime-inline-part "i" "View As Text, In This Buffer") - (gnus-mime-internalize-part "E" "View Internally") - (gnus-mime-externalize-part "e" "View Externally") - (gnus-mime-pipe-part "|" "Pipe To Command..."))) + '((gnus-article-press-button "\r" "Toggle Display") + (gnus-mime-view-part "v" "View Interactively...") + (gnus-mime-view-part-as-type "t" "View As Type...") + (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-copy-part "c" "View As Text, In Other Buffer") + (gnus-mime-inline-part "i" "View As Text, In This Buffer") + (gnus-mime-internalize-part "E" "View Internally") + (gnus-mime-externalize-part "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"))) (defun gnus-article-mime-part-status () (if gnus-article-mime-handle-alist-1 - (format " (%d parts)" (length gnus-article-mime-handle-alist-1)) + (if (eq 1 (length gnus-article-mime-handle-alist-1)) + " (1 part)" + (format " (%d parts)" (length gnus-article-mime-handle-alist-1))) "")) -(defvar gnus-mime-button-map nil) -(unless gnus-mime-button-map - (setq gnus-mime-button-map (make-sparse-keymap)) - (set-keymap-parent gnus-mime-button-map gnus-article-mode-map) - (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button) - (define-key gnus-mime-button-map gnus-down-mouse-3 'gnus-mime-button-menu) - (mapcar (lambda (c) - (define-key gnus-mime-button-map (cadr c) (car c))) - gnus-mime-button-commands)) +(defvar gnus-mime-button-map + (let ((map (make-sparse-keymap))) + (unless (>= (string-to-number emacs-version) 21) + ;; XEmacs doesn't care. + (set-keymap-parent map gnus-article-mode-map)) + (define-key map gnus-mouse-2 'gnus-article-push-button) + (define-key map gnus-down-mouse-3 'gnus-mime-button-menu) + (dolist (c gnus-mime-button-commands) + (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-excursion + (save-window-excursion (let ((pos (event-start event))) - (set-buffer (window-buffer (posn-window pos))) + (select-window (posn-window pos)) (goto-char (posn-point pos)) (gnus-article-check-buffer) (let ((response (x-popup-menu @@ -2537,7 +3551,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (cons (caddr c) (car c))) gnus-mime-button-commands)))))) (if response - (funcall response)))))) + (call-interactively response)))))) (defun gnus-mime-view-all-parts (&optional handles) "View all the MIME parts." @@ -2545,73 +3559,244 @@ If ALL-HEADERS is non-nil, no headers are hidden." (save-current-buffer (set-buffer gnus-article-buffer) (let ((handles (or handles gnus-article-mime-handles)) - (mail-parse-charset gnus-newsgroup-charset)) - (if (stringp (car handles)) - (gnus-mime-view-all-parts (cdr handles)) - (mapcar 'mm-display-part handles))))) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets))) + (when handles + (mm-remove-parts handles) + (goto-char (point-min)) + (or (search-forward "\n\n") (goto-char (point-max))) + (let (buffer-read-only) + (delete-region (point) (point-max)) + (mm-display-parts handles)))))) + +(defun gnus-mime-save-part-and-strip () + "Save the MIME part under point then replace it with an external body." + (interactive) + (gnus-article-check-buffer) + (let* ((data (get-text-property (point) 'gnus-data)) + file param + (handles gnus-article-mime-handles)) + (if (mm-multiple-handles gnus-article-mime-handles) + (error "This function is not implemented")) + (setq file (and data (mm-save-part data))) + (when file + (with-current-buffer (mm-handle-buffer data) + (erase-buffer) + (insert "Content-Type: " (mm-handle-media-type data)) + (mml-insert-parameter-string (cdr (mm-handle-type data)) + '(charset)) + (insert "\n") + (insert "Content-ID: " (message-make-message-id) "\n") + (insert "Content-Transfer-Encoding: binary\n") + (insert "\n")) + (setcdr data + (cdr (mm-make-handle nil + `("message/external-body" + (access-type . "LOCAL-FILE") + (name . ,file))))) + (set-buffer gnus-summary-buffer) + (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)) + ;; 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) + (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)))))) (defun gnus-mime-save-part () "Save the MIME part under point." (interactive) (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) - (mm-save-part data))) + (when data + (mm-save-part data)))) (defun gnus-mime-pipe-part () "Pipe the MIME part under point to a process." (interactive) (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) - (mm-pipe-part data))) + (when data + (mm-pipe-part data)))) (defun gnus-mime-view-part () - "Interactively choose a view method for the MIME part under point." + "Interactively choose a viewing method for the MIME part under point." (interactive) (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) - (mm-interactively-view-part data))) + (when data + (setq gnus-article-mime-handles + (mm-merge-handles + gnus-article-mime-handles (setq data (copy-sequence data)))) + (mm-interactively-view-part data)))) + +(defun gnus-mime-view-part-as-type-internal () + (gnus-article-check-buffer) + (let* ((name (mail-content-type-get + (mm-handle-type (get-text-property (point) 'gnus-data)) + 'name)) + (def-type (and name (mm-default-file-encoding name)))) + (and def-type (cons def-type 0)))) + +(defun gnus-mime-view-part-as-type (&optional mime-type) + "Choose a MIME media type, and view the part as such." + (interactive) + (unless mime-type + (setq mime-type (completing-read + "View as MIME type: " + (mapcar #'list (mailcap-mime-types)) + nil nil + (gnus-mime-view-part-as-type-internal)))) + (gnus-article-check-buffer) + (let ((handle (get-text-property (point) 'gnus-data))) + (when handle + (setq handle + (mm-make-handle (mm-handle-buffer handle) + (cons mime-type (cdr (mm-handle-type handle))) + (mm-handle-encoding handle) + (mm-handle-undisplayer handle) + (mm-handle-disposition handle) + (mm-handle-description handle) + nil + (mm-handle-id handle))) + (setq gnus-article-mime-handles + (mm-merge-handles gnus-article-mime-handles handle)) + (gnus-mm-display-part handle)))) (defun gnus-mime-copy-part (&optional handle) - "Put the the MIME part under point into a new buffer." + "Put the MIME part under point into a new buffer." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) - (contents (mm-get-part handle))| - (base (file-name-nondirectory - (or - (mail-content-type-get (mm-handle-type handle) 'name) - (mail-content-type-get (mm-handle-type handle) - 'filename) - "*decoded*"))) - (buffer (generate-new-buffer base))) - (switch-to-buffer buffer) - (insert contents) - ;; We do it this way to make `normal-mode' set the appropriate mode. - (unwind-protect - (progn - (setq buffer-file-name (expand-file-name base)) - (normal-mode)) - (setq buffer-file-name nil)) - (goto-char (point-min)))) - -(defun gnus-mime-inline-part (&optional charset) + (contents (and handle (mm-get-part handle))) + (base (and handle + (file-name-nondirectory + (or + (mail-content-type-get (mm-handle-type handle) 'name) + (mail-content-type-get (mm-handle-type handle) + 'filename) + "*decoded*")))) + (buffer (and base (generate-new-buffer base)))) + (when contents + (switch-to-buffer buffer) + (insert contents) + ;; We do it this way to make `normal-mode' set the appropriate mode. + (unwind-protect + (progn + (setq buffer-file-name (expand-file-name base)) + (normal-mode)) + (setq buffer-file-name nil)) + (goto-char (point-min))))) + +(defun gnus-mime-print-part (&optional handle) + "Print the MIME part under point." + (interactive) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + (contents (and handle (mm-get-part handle))) + (file (make-temp-name (expand-file-name "mm." mm-tmp-directory))) + (printer (mailcap-mime-info (mm-handle-type handle) "print"))) + (when contents + (if printer + (unwind-protect + (progn + (with-temp-file file + (insert contents)) + (call-process shell-file-name nil + (generate-new-buffer " *mm*") + nil + shell-command-switch + (mm-mailcap-command + printer file (mm-handle-type handle)))) + (delete-file file)) + (with-temp-buffer + (insert contents) + (gnus-print-buffer)))))) + +(defun gnus-mime-inline-part (&optional handle arg) "Insert the MIME part under point into the current buffer." - (interactive "P") ; For compatibility reasons we are not using "z". + (interactive (list nil current-prefix-arg)) (gnus-article-check-buffer) - (let* ((data (get-text-property (point) 'gnus-data)) - contents + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + contents charset (b (point)) buffer-read-only) - (if (mm-handle-undisplayer data) - (mm-remove-part data) - (setq contents (mm-get-part data)) - (forward-line 2) - (when charset - (unless (symbolp charset) - (setq charset (mm-read-coding-system "Charset: "))) - (setq contents (mm-decode-coding-string contents charset))) - (mm-insert-inline data contents) - (goto-char b)))) + (when handle + (if (and (not arg) (mm-handle-undisplayer handle)) + (mm-remove-part handle) + (setq contents (mm-get-part handle)) + (cond + ((not arg) + (setq charset (or (mail-content-type-get + (mm-handle-type handle) 'charset) + gnus-newsgroup-charset))) + ((numberp arg) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle)) + (setq charset + (or (cdr (assq arg + gnus-summary-show-article-charset-alist)) + (mm-read-coding-system "Charset: "))))) + (forward-line 2) + (mm-insert-inline handle + (if (and charset + (setq charset (mm-charset-to-coding-system + charset)) + (not (eq charset 'ascii))) + (mm-decode-coding-string contents charset) + contents)) + (goto-char b))))) + +(defun gnus-mime-view-part-as-charset (&optional handle arg) + "Insert the MIME part under point into the current buffer using the +specified charset." + (interactive (list nil current-prefix-arg)) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + contents charset + (b (point)) + buffer-read-only) + (when handle + (if (mm-handle-undisplayer handle) + (mm-remove-part handle)) + (let ((gnus-newsgroup-charset + (or (cdr (assq arg + gnus-summary-show-article-charset-alist)) + (mm-read-coding-system "Charset: "))) + (gnus-newsgroup-ignored-charsets 'gnus-all)) + (gnus-article-press-button))))) (defun gnus-mime-externalize-part (&optional handle) "View the MIME part under point with an external viewer." @@ -2619,29 +3804,48 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) (mm-user-display-methods nil) - (mm-all-images-fit t) - (mail-parse-charset gnus-newsgroup-charset)) - (if (mm-handle-undisplayer handle) - (mm-remove-part handle) - (mm-display-part handle)))) + (mm-inlined-types nil) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets))) + (when handle + (if (mm-handle-undisplayer handle) + (mm-remove-part handle) + (mm-display-part handle))))) (defun gnus-mime-internalize-part (&optional handle) - "View the MIME part under point with an internal viewer." + "View the MIME part under point with an internal viewer. +If no internal viewer is available, use an external viewer." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) - (mm-user-display-methods '((".*" . inline))) - (mm-all-images-fit t) - (mail-parse-charset gnus-newsgroup-charset)) - (if (mm-handle-undisplayer handle) - (mm-remove-part handle) - (mm-display-part handle)))) + (mm-inlined-types '(".*")) + (mm-inline-large-images t) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets))) + (when handle + (if (mm-handle-undisplayer handle) + (mm-remove-part handle) + (mm-display-part handle))))) + +(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))) + (gnus-article-check-buffer) + (let ((action-pair (assoc action gnus-mime-action-alist))) + (if action-pair + (funcall (cdr action-pair))))) (defun gnus-article-part-wrapper (n function) (save-current-buffer (set-buffer gnus-article-buffer) (when (> n (length gnus-article-mime-handle-alist)) (error "No such part")) + (gnus-article-goto-part n) (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) (funcall function handle)))) @@ -2656,25 +3860,57 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-article-part-wrapper n 'mm-save-part)) (defun gnus-article-interactively-view-part (n) - "Pipe MIME part N, which is the numerical prefix." + "View MIME part N interactively, which is the numerical prefix." (interactive "p") (gnus-article-part-wrapper n 'mm-interactively-view-part)) (defun gnus-article-copy-part (n) - "Pipe MIME part N, which is the numerical prefix." + "Copy MIME part N, which is the numerical prefix." (interactive "p") (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." + (interactive "p") + (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset)) + (defun gnus-article-externalize-part (n) - "Pipe MIME part N, which is the numerical prefix." + "View MIME part N externally, which is the numerical prefix." (interactive "p") (gnus-article-part-wrapper n 'gnus-mime-externalize-part)) -(defun gnus-article-view-part (n) - "View MIME part N, which is the numerical prefix." +(defun gnus-article-inline-part (n) + "Inline MIME part N, which is the numerical prefix." (interactive "p") + (gnus-article-part-wrapper n 'gnus-mime-inline-part)) + +(defun gnus-article-mime-match-handle-first (condition) + (if condition + (let ((alist gnus-article-mime-handle-alist) ihandle n) + (while (setq ihandle (pop alist)) + (if (and (cond + ((functionp condition) + (funcall condition (cdr ihandle))) + ((eq condition 'undisplayed) + (not (or (mm-handle-undisplayer (cdr ihandle)) + (equal (mm-handle-media-type (cdr ihandle)) + "multipart/alternative")))) + ((eq condition 'undisplayed-alternative) + (not (mm-handle-undisplayer (cdr ihandle)))) + (t t)) + (gnus-article-goto-part (car ihandle)) + (or (not n) (< (car ihandle) n))) + (setq n (car ihandle)))) + (or n 1)) + 1)) + +(defun gnus-article-view-part (&optional n) + "View MIME part N, which is the numerical prefix." + (interactive "P") (save-current-buffer (set-buffer gnus-article-buffer) + (or (numberp n) (setq n (gnus-article-mime-match-handle-first + gnus-article-mime-match-handle-function))) (when (> n (length gnus-article-mime-handle-alist)) (error "No such part")) (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) @@ -2684,6 +3920,11 @@ If ALL-HEADERS is non-nil, no headers are hidden." (when (eq (gnus-mm-display-part handle) 'internal) (gnus-set-window-start))))))) +(defsubst gnus-article-mime-total-parts () + (if (bufferp (car gnus-article-mime-handles)) + 1 ;; single part + (1- (length gnus-article-mime-handles)))) + (defun gnus-mm-display-part (handle) "Display HANDLE and fix MIME button." (let ((id (get-text-property (point) 'gnus-part)) @@ -2692,10 +3933,13 @@ If ALL-HEADERS is non-nil, no headers are hidden." (forward-line 1) (prog1 (let ((window (selected-window)) - (mail-parse-charset gnus-newsgroup-charset)) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets))) (save-excursion (unwind-protect - (let ((win (get-buffer-window (current-buffer) t)) + (let ((win (gnus-get-buffer-window (current-buffer) t)) (beg (point))) (when win (select-window win)) @@ -2705,13 +3949,20 @@ If ALL-HEADERS is non-nil, no headers are hidden." ;; This will remove the part. (mm-display-part handle) (save-restriction - (narrow-to-region (point) (1+ (point))) + (narrow-to-region (point) + (if (eobp) (point) (1+ (point)))) (mm-display-part handle) + ;; We narrow to the part itself and + ;; then call the treatment functions. + (goto-char (point-min)) + (forward-line 1) + (narrow-to-region (point) (point-max)) (gnus-treat-article nil id - (1- (length gnus-article-mime-handles)) - (car (mm-handle-type handle)))))) - (select-window window)))) + (gnus-article-mime-total-parts) + (mm-handle-media-type handle))))) + (if (window-live-p window) + (select-window window))))) (goto-char point) (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point))) (gnus-insert-mime-button @@ -2726,12 +3977,11 @@ If ALL-HEADERS is non-nil, no headers are hidden." (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) (let ((gnus-tmp-name - (or (mail-content-type-get (mm-handle-type handle) - 'name) - (mail-content-type-get (mm-handle-disposition handle) - 'filename) + (or (mail-content-type-get (mm-handle-type handle) 'name) + (mail-content-type-get (mm-handle-disposition handle) 'filename) + (mail-content-type-get (mm-handle-type handle) 'url) "")) - (gnus-tmp-type (car (mm-handle-type handle))) + (gnus-tmp-type (mm-handle-media-type handle)) (gnus-tmp-description (mail-decode-encoded-word-string (or (mm-handle-description handle) ""))) @@ -2747,40 +3997,50 @@ If ALL-HEADERS is non-nil, no headers are hidden." (setq gnus-tmp-type-long (concat gnus-tmp-type (and (not (equal gnus-tmp-name "")) (concat "; " gnus-tmp-name)))) - (or (equal gnus-tmp-description "") - (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) + (unless (equal gnus-tmp-description "") + (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) (unless (bolp) (insert "\n")) (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist - `(local-map ,gnus-mime-button-map - keymap ,gnus-mime-button-map - gnus-callback gnus-mm-display-part - gnus-part ,gnus-tmp-id - article-type annotation - gnus-data ,handle)) + `(,@(gnus-local-map-property gnus-mime-button-map) + gnus-callback gnus-mm-display-part + gnus-part ,gnus-tmp-id + article-type annotation + gnus-data ,handle)) (setq e (point)) - (widget-convert-button 'link b e - :mime-handle handle - :action 'gnus-widget-press-button - :button-keymap gnus-mime-button-map - :help-echo - (lambda (widget) - ;; Needed to properly clear the message - ;; due to a bug in wid-edit - (setq help-echo-owns-message t) - (format - "Click to %s the MIME part; %s for more options" - (if (mm-handle-displayed-p - (widget-get widget :mime-handle)) - "hide" "show") - (if gnus-xemacs "button3" "mouse-3")))))) + (widget-convert-button + 'link b e + :mime-handle handle + :action 'gnus-widget-press-button + :button-keymap gnus-mime-button-map + :help-echo + (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)) + (format + "%S: %s the MIME part; %S: more options" + (aref gnus-mouse-2 0) + ;; XEmacs will get a single widget arg; Emacs 21 will get + ;; window, overlay, position. + (if (mm-handle-displayed-p + (if overlay + (with-current-buffer (gnus-overlay-buffer overlay) + (widget-get (widget-at (gnus-overlay-start overlay)) + :mime-handle)) + (widget-get widget/window :mime-handle))) + "hide" "show") + (aref gnus-down-mouse-3 0)))))) (defun gnus-widget-press-button (elems el) (goto-char (widget-get elems :from)) (gnus-article-press-button)) +(defvar gnus-displaying-mime nil) + (defun gnus-display-mime (&optional ihandles) "Display the MIME parts." (save-excursion @@ -2793,12 +4053,14 @@ If ALL-HEADERS is non-nil, no headers are hidden." ;; may change the point. So we set the window point. (set-window-point window point))) (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect))) - handle name type b e display) - (unless ihandles + buffer-read-only handle name type b e display) + (when (and (not ihandles) + (not gnus-displaying-mime)) ;; Top-level call; we clean up. - (mm-destroy-parts gnus-article-mime-handles) - (setq gnus-article-mime-handles handles - gnus-article-mime-handle-alist nil) + (when gnus-article-mime-handles + (mm-destroy-parts gnus-article-mime-handles) + (setq gnus-article-mime-handle-alist nil));; A trick. + (setq gnus-article-mime-handles handles) ;; We allow users to glean info from the handles. (when gnus-article-mime-part-function (gnus-mime-part-function handles))) @@ -2806,41 +4068,65 @@ If ALL-HEADERS is non-nil, no headers are hidden." (or (not (stringp (car handles))) (cdr handles))) (progn - (unless ihandles + (when (and (not ihandles) + (not gnus-displaying-mime)) ;; Clean up for mime parts. (article-goto-body) (delete-region (point) (point-max))) - (gnus-mime-display-part handles)) + (let ((gnus-displaying-mime t)) + (gnus-mime-display-part handles))) (save-restriction (article-goto-body) (narrow-to-region (point) (point-max)) - (gnus-treat-article nil 1 1))) - ;; Highlight the headers. - (save-excursion - (save-restriction - (article-goto-body) - (narrow-to-region (point-min) (point)) - (gnus-treat-article 'head))))))) + (gnus-treat-article nil 1 1) + (widen))) + (unless ihandles + ;; Highlight the headers. + (save-excursion + (save-restriction + (article-goto-body) + (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) (defun gnus-mime-display-part (handle) (cond ;; Single part. ((not (stringp (car handle))) (gnus-mime-display-single handle)) + ;; User-defined multipart + ((cdr (assoc (car handle) gnus-mime-multipart-functions)) + (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions)) + handle)) ;; multipart/alternative ((and (equal (car handle) "multipart/alternative") - (not gnus-mime-display-multipart-as-mixed)) + (not (or gnus-mime-display-multipart-as-mixed + gnus-mime-display-multipart-alternative-as-mixed))) (let ((id (1+ (length gnus-article-mime-handle-alist)))) (push (cons id handle) gnus-article-mime-handle-alist) (gnus-mime-display-alternative (cdr handle) nil nil id))) ;; multipart/related ((and (equal (car handle) "multipart/related") - (not gnus-mime-display-multipart-as-mixed)) + (not (or gnus-mime-display-multipart-as-mixed + gnus-mime-display-multipart-related-as-mixed))) ;;;!!!We should find the start part, but we just default ;;;!!!to the first part. + ;;(gnus-mime-display-part (cadr handle)) + ;;;!!! Most multipart/related is an HTML message plus images. + ;;;!!! Unfortunately we are unable to let W3 display those + ;;;!!! included images, so we just display it as a mixed multipart. + ;;(gnus-mime-display-mixed (cdr handle)) + ;;;!!! No, w3 can display everything just fine. (gnus-mime-display-part (cadr handle))) + ((equal (car handle) "multipart/signed") + (gnus-add-wash-type 'signed) + (gnus-mime-display-security handle)) + ((equal (car handle) "multipart/encrypted") + (gnus-add-wash-type 'encrypted) + (gnus-mime-display-security handle)) ;; Other multiparts are handled like multipart/mixed. (t (gnus-mime-display-mixed (cdr handle))))) @@ -2854,7 +4140,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (mapcar 'gnus-mime-display-part handles)) (defun gnus-mime-display-single (handle) - (let ((type (car (mm-handle-type handle))) + (let ((type (mm-handle-media-type handle)) (ignored gnus-ignored-mime-types) (not-attachment t) (move nil) @@ -2865,37 +4151,49 @@ If ALL-HEADERS is non-nil, no headers are hidden." (when (string-match (pop ignored) type) (throw 'ignored nil))) (if (and (setq not-attachment - (or (not (mm-handle-disposition handle)) - (equal (car (mm-handle-disposition handle)) - "inline"))) - (mm-automatic-display-p type) - (or (mm-inlinable-part-p type) + (and (not (mm-inline-override-p handle)) + (or (not (mm-handle-disposition handle)) + (equal (car (mm-handle-disposition handle)) + "inline") + (mm-attachment-override-p handle)))) + (mm-automatic-display-p handle) + (or (and + (mm-inlinable-p handle) + (mm-inlined-p handle)) (mm-automatic-external-display-p type))) (setq display t) - (when (equal (car (split-string type "/")) - "text") + (when (equal (mm-handle-media-supertype handle) "text") (setq text t))) - (let ((id (1+ (length gnus-article-mime-handle-alist)))) + (let ((id (1+ (length gnus-article-mime-handle-alist))) + beg) (push (cons id handle) gnus-article-mime-handle-alist) (when (or (not display) (not (gnus-unbuttonized-mime-type-p type))) - (gnus-article-insert-newline) + ;(gnus-article-insert-newline) (gnus-insert-mime-button handle id (list (or display (and not-attachment text)))) (gnus-article-insert-newline) - (gnus-article-insert-newline) - (setq move t))) - (let ((beg (point))) + ;(gnus-article-insert-newline) + ;; Remember modify the number of forward lines. + (setq move t)) + (setq beg (point)) (cond (display (when move - (forward-line -2)) - (let ((mail-parse-charset gnus-newsgroup-charset)) + (forward-line -1) + (setq beg (point))) + (let ((mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (condition-case () + (set-buffer gnus-summary-buffer) + (error)) + gnus-newsgroup-ignored-charsets))) (mm-display-part handle t)) (goto-char (point-max))) ((and text not-attachment) (when move - (forward-line -2)) + (forward-line -1) + (setq beg (point))) (gnus-article-insert-newline) (mm-insert-inline handle (mm-get-part handle)) (goto-char (point-max)))) @@ -2904,18 +4202,23 @@ If ALL-HEADERS is non-nil, no headers are hidden." (save-restriction (narrow-to-region beg (point)) (gnus-treat-article - nil (length gnus-article-mime-handle-alist) - (1- (length gnus-article-mime-handles)) - (car (mm-handle-type handle)))))))))) + nil id + (gnus-article-mime-total-parts) + (mm-handle-media-type handle))))))))) (defun gnus-unbuttonized-mime-type-p (type) "Say whether TYPE is to be unbuttonized." (unless gnus-inhibit-mime-unbuttonizing - (catch 'found - (let ((types gnus-unbuttonized-mime-types)) - (while types - (when (string-match (pop types) type) - (throw 'found t))))))) + (when (catch 'found + (let ((types gnus-unbuttonized-mime-types)) + (while types + (when (string-match (pop types) type) + (throw 'found t))))) + (not (catch 'found + (let ((types gnus-buttonized-mime-types)) + (while types + (when (string-match (pop types) type) + (throw 'found t))))))))) (defun gnus-article-insert-newline () "Insert a newline, but mark it as undeletable." @@ -2943,6 +4246,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (unless (setq not-pref (cadr (member preferred ihandles))) (setq not-pref (car ihandles))) (when (or ibegend + (not preferred) (not (gnus-unbuttonized-mime-type-p "multipart/alternative"))) (gnus-add-text-properties @@ -2957,10 +4261,9 @@ If ALL-HEADERS is non-nil, no headers are hidden." ',gnus-article-mime-handle-alist)) (gnus-mime-display-alternative ',ihandles ',not-pref ',begend ,id)) - local-map ,gnus-mime-button-map + ,@(gnus-local-map-property gnus-mime-button-map) ,gnus-mouse-face-prop ,gnus-article-mouse-face face ,gnus-article-button-face - keymap ,gnus-mime-button-map gnus-part ,id gnus-data ,handle)) (widget-convert-button 'link from (point) @@ -2973,9 +4276,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (progn (insert (format "(%c) %-18s" (if (equal handle preferred) ?* ? ) - (if (stringp (car handle)) - (car handle) - (car (mm-handle-type handle))))) + (mm-handle-media-type handle))) (point)) `(gnus-callback (lambda (handles) @@ -2984,10 +4285,9 @@ If ALL-HEADERS is non-nil, no headers are hidden." ',gnus-article-mime-handle-alist)) (gnus-mime-display-alternative ',ihandles ',handle ',begend ,id)) - local-map ,gnus-mime-button-map + ,@(gnus-local-map-property gnus-mime-button-map) ,gnus-mouse-face-prop ,gnus-article-mouse-face face ,gnus-article-button-face - keymap ,gnus-mime-button-map gnus-part ,id gnus-data ,handle)) (widget-convert-button 'link from (point) @@ -2998,34 +4298,104 @@ If ALL-HEADERS is non-nil, no headers are hidden." (when preferred (if (stringp (car preferred)) (gnus-display-mime preferred) - (let ((mail-parse-charset gnus-newsgroup-charset)) - (mm-display-part preferred))) + (let ((mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets))) + (mm-display-part preferred) + ;; Do highlighting. + (save-excursion + (save-restriction + (narrow-to-region (car begend) (point-max)) + (gnus-treat-article + nil (length gnus-article-mime-handle-alist) + (gnus-article-mime-total-parts) + (mm-handle-media-type handle)))))) (goto-char (point-max)) (setcdr begend (point-marker))))) (when ibegend (goto-char point)))) +(defconst gnus-article-wash-status-strings + (let ((alist '((cite "c" "Possible hidden citation text" + " " "All citation text visible") + (headers "h" "Hidden headers" + " " "All headers visible.") + (pgp "p" "Encrypted or signed message status hidden" + " " "No hidden encryption nor digital signature status") + (signature "s" "Signature has been hidden" + " " "Signature is visible") + (overstrike "o" "Overstrike (^H) characters applied" + " " "No overstrike characters applied") + (emphasis "e" "/*_Emphasis_*/ characters applied" + " " "No /*_emphasis_*/ characters applied"))) + result) + (dolist (entry alist result) + (let ((key (nth 0 entry)) + (on (copy-sequence (nth 1 entry))) + (on-help (nth 2 entry)) + (off (copy-sequence (nth 3 entry))) + (off-help (nth 4 entry))) + (put-text-property 0 1 'help-echo on-help on) + (put-text-property 0 1 'help-echo off-help off) + (push (list key on off) result)))) + "Alist of strings describing wash status in the mode line. +Each entry has the form (KEY ON OF), where the KEY is a symbol +representing the particular washing function, ON is the string to use +in the article mode line when the washing function is active, and OFF +is the string to use when it is inactive.") + +(defun gnus-article-wash-status-entry (key value) + (let ((entry (assoc key gnus-article-wash-status-strings))) + (if value (nth 1 entry) (nth 2 entry)))) + (defun gnus-article-wash-status () "Return a string which display status of article washing." (save-excursion (set-buffer gnus-article-buffer) - (let ((cite (gnus-article-hidden-text-p 'cite)) - (headers (gnus-article-hidden-text-p 'headers)) - (boring (gnus-article-hidden-text-p 'boring-headers)) - (pgp (gnus-article-hidden-text-p 'pgp)) - (pem (gnus-article-hidden-text-p 'pem)) - (signature (gnus-article-hidden-text-p 'signature)) - (overstrike (gnus-article-hidden-text-p 'overstrike)) - (emphasis (gnus-article-hidden-text-p 'emphasis))) - (format "%c%c%c%c%c%c" - (if cite ?c ? ) - (if (or headers boring) ?h ? ) - (if (or pgp pem) ?p ? ) - (if signature ?s ? ) - (if overstrike ?o ? ) - (if emphasis ?e ? ))))) - -(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) + (let ((cite (memq 'cite gnus-article-wash-types)) + (headers (memq 'headers gnus-article-wash-types)) + (boring (memq 'boring-headers gnus-article-wash-types)) + (pgp (memq 'pgp gnus-article-wash-types)) + (pem (memq 'pem gnus-article-wash-types)) + (signed (memq 'signed gnus-article-wash-types)) + (encrypted (memq 'encrypted gnus-article-wash-types)) + (signature (memq 'signature gnus-article-wash-types)) + (overstrike (memq 'overstrike gnus-article-wash-types)) + (emphasis (memq 'emphasis gnus-article-wash-types))) + (concat + (gnus-article-wash-status-entry 'cite cite) + (gnus-article-wash-status-entry 'headers (or headers boring)) + (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted)) + (gnus-article-wash-status-entry 'signature signature) + (gnus-article-wash-status-entry 'overstrike overstrike) + (gnus-article-wash-status-entry 'emphasis emphasis))))) + +(defun gnus-add-wash-type (type) + "Add a washing of TYPE to the current status." + (add-to-list 'gnus-article-wash-types type)) + +(defun gnus-delete-wash-type (type) + "Add a washing of TYPE to the current status." + (setq gnus-article-wash-types (delq type gnus-article-wash-types))) + +(defun gnus-add-image (category image) + "Add IMAGE of CATEGORY to the list of displayed images." + (let ((entry (assq category gnus-article-image-alist))) + (unless entry + (setq entry (list category)) + (push entry gnus-article-image-alist)) + (nconc entry (list image)))) + +(defun gnus-delete-images (category) + "Delete all images in CATEGORY." + (let ((entry (assq category gnus-article-image-alist))) + (dolist (image (cdr entry)) + (gnus-remove-image image)) + (setq gnus-article-image-alist (delq entry gnus-article-image-alist)) + (gnus-delete-wash-type category))) + +(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) (defun gnus-article-maybe-hide-headers () "Hide unwanted headers if `gnus-have-all-headers' is nil. @@ -3047,7 +4417,8 @@ Provided for backwards compatibility." ;; save it to file. (goto-char (point-max)) (insert "\n") - (append-to-file (point-min) (point-max) file-name) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (mm-append-to-file (point-min) (point-max) file-name)) t))) (defun gnus-narrow-to-page (&optional arg) @@ -3208,68 +4579,152 @@ Argument LINES specifies lines to be scrolled down." (interactive "P") (gnus-article-check-buffer) (let ((nosaves - '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" - "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" - "=" "^" "\M-^" "|")) - (nosave-but-article - '("A\r")) - (nosave-in-article - '("\C-d")) - (up-to-top - '("n" "Gn" "p" "Gp")) - keys new-sum-point) + '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f" + "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" + "=" "^" "\M-^" "|")) + (nosave-but-article + '("A\r")) + (nosave-in-article + '("\C-d")) + (up-to-top + '("n" "Gn" "p" "Gp")) + keys new-sum-point) (save-excursion (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) - (push (or key last-command-event) unread-command-events) - (setq keys (read-key-sequence nil)))) + (push (or key last-command-event) unread-command-events) + (setq keys (if (featurep 'xemacs) + (events-to-keys (read-key-sequence nil)) + (read-key-sequence nil))))) + (message "") (if (or (member keys nosaves) - (member keys nosave-but-article) - (member keys nosave-in-article)) - (let (func) - (save-window-excursion - (pop-to-buffer gnus-article-current-summary 'norecord) - ;; We disable the pick minor mode commands. - (let (gnus-pick-mode) - (setq func (lookup-key (current-local-map) keys)))) - (if (not func) - (ding) - (unless (member keys nosave-in-article) - (set-buffer gnus-article-current-summary)) - (call-interactively func) - (setq new-sum-point (point))) - (when (member keys nosave-but-article) - (pop-to-buffer gnus-article-buffer 'norecord))) + (member keys nosave-but-article) + (member keys nosave-in-article)) + (let (func) + (save-window-excursion + (pop-to-buffer gnus-article-current-summary 'norecord) + ;; We disable the pick minor mode commands. + (let (gnus-pick-mode) + (setq func (lookup-key (current-local-map) keys)))) + (if (or (not func) + (numberp func)) + (ding) + (unless (member keys nosave-in-article) + (set-buffer gnus-article-current-summary)) + (call-interactively func) + (setq new-sum-point (point))) + (when (member keys nosave-but-article) + (pop-to-buffer gnus-article-buffer 'norecord))) ;; These commands should restore window configuration. (let ((obuf (current-buffer)) - (owin (current-window-configuration)) - (opoint (point)) - (summary gnus-article-current-summary) - func in-buffer selected) - (if not-restore-window - (pop-to-buffer summary 'norecord) - (switch-to-buffer summary 'norecord)) - (setq in-buffer (current-buffer)) - ;; We disable the pick minor mode commands. - (if (setq func (let (gnus-pick-mode) - (lookup-key (current-local-map) keys))) - (progn - (call-interactively func) - (setq new-sum-point (point))) - (ding)) - (when (eq in-buffer (current-buffer)) - (setq selected (gnus-summary-select-article)) - (set-buffer obuf) - (unless not-restore-window - (set-window-configuration owin)) - (unless (or (not (eq selected 'old)) (member keys up-to-top)) - (set-window-point (get-buffer-window (current-buffer)) - opoint)) - (let ((win (get-buffer-window gnus-article-current-summary))) - (when win - (set-window-point win new-sum-point)))))))) + (owin (current-window-configuration)) + (opoint (point)) + (summary gnus-article-current-summary) + func in-buffer selected) + (if not-restore-window + (pop-to-buffer summary 'norecord) + (switch-to-buffer summary 'norecord)) + (setq in-buffer (current-buffer)) + ;; We disable the pick minor mode commands. + (if (and (setq func (let (gnus-pick-mode) + (lookup-key (current-local-map) keys))) + (functionp func)) + (progn + (call-interactively func) + (setq new-sum-point (point)) + (when (eq in-buffer (current-buffer)) + (setq selected (gnus-summary-select-article)) + (set-buffer obuf) + (unless not-restore-window + (set-window-configuration owin)) + (when (eq selected 'old) + (article-goto-body) + (set-window-start (get-buffer-window (current-buffer)) + 1) + (set-window-point (get-buffer-window (current-buffer)) + (point))) + (let ((win (get-buffer-window gnus-article-current-summary))) + (when win + (set-window-point win new-sum-point)))) ) + (switch-to-buffer gnus-article-buffer) + (ding)))))) + +(defun gnus-article-describe-key (key) + "Display documentation of the function invoked by KEY. KEY is a string." + (interactive "kDescribe key: ") + (gnus-article-check-buffer) + (if (eq (key-binding key) 'gnus-article-read-summary-keys) + (save-excursion + (set-buffer gnus-article-current-summary) + (let (gnus-pick-mode) + (if (featurep 'xemacs) + (progn + (push (elt key 0) unread-command-events) + (setq key (events-to-keys + (read-key-sequence "Describe key: ")))) + (setq unread-command-events + (mapcar + (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) + (string-to-list key))) + (setq key (read-key-sequence "Describe key: ")))) + (describe-key key)) + (describe-key key))) + +(defun gnus-article-describe-key-briefly (key &optional insert) + "Display documentation of the function invoked by KEY. KEY is a string." + (interactive "kDescribe key: \nP") + (gnus-article-check-buffer) + (if (eq (key-binding key) 'gnus-article-read-summary-keys) + (save-excursion + (set-buffer gnus-article-current-summary) + (let (gnus-pick-mode) + (if (featurep 'xemacs) + (progn + (push (elt key 0) unread-command-events) + (setq key (events-to-keys + (read-key-sequence "Describe key: ")))) + (setq unread-command-events + (mapcar + (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) + (string-to-list key))) + (setq key (read-key-sequence "Describe key: ")))) + (describe-key-briefly key insert)) + (describe-key-briefly key insert))) + +(defun gnus-article-reply-with-original (&optional wide) + "Start composing a reply mail to the current message. +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)) + (gnus-summary-reply (list (list article)) wide) + (setq cont (buffer-substring (point) (mark))) + ;; Deactivate active regions. + (when (and (boundp 'transient-mark-mode) + transient-mark-mode) + (setq mark-active nil)) + (gnus-summary-reply + (list (list article cont)) 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 (gnus-region-active-p)) + (gnus-summary-followup (list (list article))) + (setq cont (buffer-substring (point) (mark))) + ;; Deactivate active regions. + (when (and (boundp 'transient-mark-mode) + transient-mark-mode) + (setq mark-active nil)) + (gnus-summary-followup + (list (list article cont)))))) (defun gnus-article-hide (&optional arg force) "Hide all the gruft in the current article. @@ -3278,6 +4733,7 @@ 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)) @@ -3294,6 +4750,9 @@ If given a prefix, show the hidden text instead." (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) (gnus-request-group gnus-newsgroup-name t))) +(eval-when-compile + (autoload 'nneething-get-file-name "nneething")) + (defun gnus-request-article-this-buffer (article group) "Get an article and insert it into this buffer." (let (do-update-line sparse-header) @@ -3310,8 +4769,7 @@ If given a prefix, show the hidden text instead." ;; We only request an article by message-id when we do not have the ;; headers for it, so we'll have to get those. (when (stringp article) - (let ((gnus-override-method gnus-refer-article-method)) - (gnus-read-header article))) + (gnus-read-header article)) ;; If the article number is negative, that means that this article ;; doesn't belong in this newsgroup (possibly), so we find its @@ -3329,8 +4787,7 @@ If given a prefix, show the hidden text instead." ;; This is a sparse gap article. (setq do-update-line article) (setq article (mail-header-id header)) - (let ((gnus-override-method gnus-refer-article-method)) - (setq sparse-header (gnus-read-header article))) + (setq sparse-header (gnus-read-header article)) (setq gnus-newsgroup-sparse (delq article gnus-newsgroup-sparse))) ((vectorp header) @@ -3345,12 +4802,10 @@ If given a prefix, show the hidden text instead." gnus-newsgroup-name))) (when (and (eq (car method) 'nneething) (vectorp header)) - (let ((dir (concat - (file-name-as-directory - (or (cadr (assq 'nneething-address method)) - (nth 1 method))) - (mail-header-subject header)))) - (when (file-directory-p dir) + (let ((dir (nneething-get-file-name + (mail-header-id header)))) + (when (and (stringp dir) + (file-directory-p dir)) (setq article 'nneething) (gnus-group-enter-directory dir)))))))) @@ -3389,21 +4844,48 @@ If given a prefix, show the hidden text instead." (numberp article) (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)) + 'article) ;; Get the article and put into the article buffer. - ((or (stringp article) (numberp article)) - (let ((gnus-override-method - (and (stringp article) gnus-refer-article-method)) + ((or (stringp article) + (numberp article)) + (let ((gnus-override-method gnus-override-method) + (methods (and (stringp article) + gnus-refer-article-method)) + result (buffer-read-only nil)) - (erase-buffer) - (gnus-kill-all-overlays) - (gnus-check-group-server) - (when (gnus-request-article article group (current-buffer)) - (when (numberp article) - (gnus-async-prefetch-next group article gnus-summary-buffer) - (when gnus-keep-backlog - (gnus-backlog-enter-article - group article (current-buffer)))) - 'article))) + (if (or (not (listp methods)) + (and (symbolp (car methods)) + (assq (car methods) nnoo-definition-alist))) + (setq methods (list methods))) + (when (and (null gnus-override-method) + methods) + (setq gnus-override-method (pop methods))) + (while (not result) + (when (eq gnus-override-method 'current) + (setq gnus-override-method + (with-current-buffer gnus-summary-buffer + gnus-current-select-method))) + (erase-buffer) + (gnus-kill-all-overlays) + (let ((gnus-newsgroup-name group)) + (gnus-check-group-server)) + (when (gnus-request-article article group (current-buffer)) + (when (numberp article) + (gnus-async-prefetch-next group article + gnus-summary-buffer) + (when gnus-keep-backlog + (gnus-backlog-enter-article + group article (current-buffer)))) + (setq result 'article)) + (if (not result) + (if methods + (setq gnus-override-method (pop methods)) + (setq result 'done)))) + (and (eq result 'article) 'article))) ;; It was a pseudo. (t article))) @@ -3440,7 +4922,7 @@ If given a prefix, show the hidden text instead." (set-buffer gnus-summary-buffer) (gnus-summary-update-article do-update-line sparse-header) (gnus-summary-goto-subject do-update-line nil t) - (set-window-point (get-buffer-window (current-buffer) t) + (set-window-point (gnus-get-buffer-window (current-buffer) t) (point)) (set-buffer buf)))))) @@ -3470,21 +4952,18 @@ If given a prefix, show the hidden text instead." "\C-c\C-w" gnus-article-edit-mode-map) "f" gnus-article-edit-full-stops)) -(defun gnus-article-edit-mode () +(define-derived-mode gnus-article-edit-mode text-mode "Article Edit" "Major mode for editing articles. This is an extended text-mode. \\{gnus-article-edit-mode-map}" - (interactive) - (setq major-mode 'gnus-article-edit-mode) - (setq mode-name "Article Edit") - (use-local-map gnus-article-edit-mode-map) (make-local-variable 'gnus-article-edit-done-function) (make-local-variable 'gnus-prev-winconf) + (set (make-local-variable 'font-lock-defaults) + '(message-font-lock-keywords t)) (setq buffer-read-only nil) (buffer-enable-undo) - (widen) - (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook)) + (widen)) (defun gnus-article-edit (&optional force) "Edit the current article. @@ -3497,18 +4976,20 @@ groups." (error "The current newsgroup does not support article editing")) (gnus-article-date-original) (gnus-article-edit-article + 'ignore `(lambda (no-highlight) + 'ignore (gnus-summary-edit-article-done ,(or (mail-header-references gnus-current-headers) "") ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)))) -(defun gnus-article-edit-article (exit-func) +(defun gnus-article-edit-article (start-func exit-func) "Start editing the contents of the current article buffer." (let ((winconf (current-window-configuration))) (set-buffer gnus-article-buffer) (gnus-article-edit-mode) - (gnus-article-delete-text-of-type 'annotation) - (gnus-set-text-properties (point-min) (point-max) nil) + (funcall start-func) + (set-buffer-modified-p nil) (gnus-configure-windows 'edit-article) (setq gnus-article-edit-done-function exit-func) (setq gnus-prev-winconf winconf) @@ -3517,31 +4998,23 @@ groups." (defun gnus-article-edit-done (&optional arg) "Update the article edits and exit." (interactive "P") - (save-excursion - (save-restriction - (widen) - (when (article-goto-body) - (let ((lines (count-lines (point) (point-max))) - (length (- (point-max) (point))) - (case-fold-search t) - (body (copy-marker (point)))) - (goto-char (point-min)) - (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string length))) - (goto-char (point-min)) - (when (re-search-forward - "^x-content-length:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string length))) - (goto-char (point-min)) - (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string lines))))))) (let ((func gnus-article-edit-done-function) (buf (current-buffer)) (start (window-start))) - (gnus-article-edit-exit) + ;; We remove all text props from the article buffer. + (let ((content + (buffer-substring-no-properties (point-min) (point-max))) + (p (point))) + (erase-buffer) + (insert content) + (let ((winconf gnus-prev-winconf)) + (gnus-article-mode) + (set-window-configuration winconf) + ;; Tippy-toe some to make sure that point remains where it was. + (save-current-buffer + (set-buffer buf) + (set-window-start (get-buffer-window (current-buffer)) start) + (goto-char p)))) (save-excursion (set-buffer buf) (let ((buffer-read-only nil)) @@ -3565,21 +5038,22 @@ groups." (defun gnus-article-edit-exit () "Exit the article editing without updating." (interactive) - ;; We remove all text props from the article buffer. - (let ((buf (format "%s" (buffer-string))) - (curbuf (current-buffer)) - (p (point)) - (window-start (window-start))) - (erase-buffer) - (insert buf) - (let ((winconf gnus-prev-winconf)) - (gnus-article-mode) - (set-window-configuration winconf) - ;; Tippy-toe some to make sure that point remains where it was. - (save-current-buffer - (set-buffer curbuf) - (set-window-start (get-buffer-window (current-buffer)) window-start) - (goto-char p))))) + (when (or (not (buffer-modified-p)) + (yes-or-no-p "Article modified; kill anyway? ")) + (let ((curbuf (current-buffer)) + (p (point)) + (window-start (window-start))) + (erase-buffer) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (insert-buffer gnus-original-article-buffer)) + (let ((winconf gnus-prev-winconf)) + (gnus-article-mode) + (set-window-configuration winconf) + ;; Tippy-toe some to make sure that point remains where it was. + (save-current-buffer + (set-buffer curbuf) + (set-window-start (get-buffer-window (current-buffer)) window-start) + (goto-char p)))))) (defun gnus-article-edit-full-stops () "Interactively repair spacing at end of sentences." @@ -3598,15 +5072,16 @@ groups." ;;; Internal Variables: -(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)" +(defcustom gnus-button-url-regexp "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)" "Regular expression that matches URLs." :group 'gnus-article-buttons :type 'regexp) (defcustom gnus-button-alist - `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" - 0 t gnus-button-message-id 2) - ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1) + `(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" + 0 t 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) @@ -3614,12 +5089,15 @@ groups." ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 t gnus-button-message-id 3) ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 2) - ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1) + ("mailto:\\([-a-zA-Z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) + ;; This is info + ("\\binfo:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t + gnus-button-handle-info 2) ;; This is how URLs _should_ be embedded in text... - ("]*\\)>" 0 t gnus-button-embedded-url 1) + ("]*\\)>" 1 t gnus-button-embedded-url 1) ;; Raw URLs. - (,gnus-button-url-regexp 0 t gnus-button-url 0)) + (,gnus-button-url-regexp 0 t browse-url 0)) "*Alist of regexps matching buttons in article bodies. Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where @@ -3642,14 +5120,15 @@ variable it the real callback function." (integer :tag "Regexp group"))))) (defcustom gnus-header-button-alist - `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>" + `(("^\\(References\\|Message-I[Dd]\\):" "<[^<>]+>" 0 t gnus-button-message-id 0) ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t 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 gnus-button-url 0) - ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0) - ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 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-zA-Z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1) ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t gnus-button-message-id 3)) "*Alist of headers and regexps to match buttons in article heads. @@ -3688,7 +5167,7 @@ call it with the value of the `gnus-data' text property." (interactive "e") (set-buffer (window-buffer (posn-window (event-start event)))) (let* ((pos (posn-point (event-start event))) - (data (get-text-property pos 'gnus-data)) + (data (get-text-property pos 'gnus-data)) (fun (get-text-property pos 'gnus-callback))) (goto-char pos) (when fun @@ -3738,7 +5217,7 @@ do the highlighting. See the documentation for those functions." (case-fold-search t) (inhibit-point-motion-hooks t) entry regexp header-face field-face from hpoints fpoints) - (message-narrow-to-head) + (article-narrow-to-head) (while (setq entry (pop alist)) (goto-char (point-min)) (setq regexp (concat "^\\(" @@ -3804,14 +5283,17 @@ specified by `gnus-button-alist'." (alist gnus-button-alist) beg entry regexp) ;; Remove all old markers. - (let (marker entry) + (let (marker entry new-list) (while (setq marker (pop gnus-button-marker-list)) - (goto-char marker) - (when (setq entry (gnus-button-entry)) - (put-text-property (match-beginning (nth 1 entry)) - (match-end (nth 1 entry)) - 'gnus-callback nil)) - (set-marker marker nil))) + (if (or (< marker (point-min)) (>= marker (point-max))) + (push marker new-list) + (goto-char marker) + (when (setq entry (gnus-button-entry)) + (put-text-property (match-beginning (nth 1 entry)) + (match-end (nth 1 entry)) + 'gnus-callback nil)) + (set-marker marker nil))) + (setq gnus-button-marker-list new-list)) ;; We skip the headers. (article-goto-body) (setq beg (point)) @@ -3839,38 +5321,38 @@ specified by `gnus-button-alist'." (interactive) (save-excursion (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (case-fold-search t) - (alist gnus-header-button-alist) - entry beg end) - (nnheader-narrow-to-headers) - (while alist - ;; Each alist entry. - (setq entry (car alist) - alist (cdr alist)) - (goto-char (point-min)) - (while (re-search-forward (car entry) nil t) - ;; Each header matching the entry. - (setq beg (match-beginning 0)) - (setq end (or (and (re-search-forward "^[^ \t]" nil t) - (match-beginning 0)) - (point-max))) - (goto-char beg) - (while (re-search-forward (nth 1 entry) end t) - ;; Each match within a header. - (let* ((entry (cdr entry)) - (start (match-beginning (nth 1 entry))) - (end (match-end (nth 1 entry))) - (form (nth 2 entry))) - (goto-char (match-end 0)) - (when (eval form) - (gnus-article-add-button - start end (nth 3 entry) - (buffer-substring (match-beginning (nth 4 entry)) - (match-end (nth 4 entry))))))) - (goto-char end)))) - (widen))) + (save-restriction + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (case-fold-search t) + (alist gnus-header-button-alist) + entry beg end) + (article-narrow-to-head) + (while alist + ;; Each alist entry. + (setq entry (car alist) + alist (cdr alist)) + (goto-char (point-min)) + (while (re-search-forward (car entry) nil t) + ;; Each header matching the entry. + (setq beg (match-beginning 0)) + (setq end (or (and (re-search-forward "^[^ \t]" nil t) + (match-beginning 0)) + (point-max))) + (goto-char beg) + (while (re-search-forward (nth 1 entry) end t) + ;; Each match within a header. + (let* ((entry (cdr entry)) + (start (match-beginning (nth 1 entry))) + (end (match-end (nth 1 entry))) + (form (nth 2 entry))) + (goto-char (match-end 0)) + (when (eval form) + (gnus-article-add-button + start end (nth 3 entry) + (buffer-substring (match-beginning (nth 4 entry)) + (match-end (nth 4 entry))))))) + (goto-char end))))))) ;;; External functions: @@ -3900,9 +5382,20 @@ specified by `gnus-button-alist'." (set-buffer gnus-article-buffer) (let ((buffer-read-only nil) (inhibit-point-motion-hooks t)) - (if (get-text-property end 'invisible) - (gnus-article-unhide-text end (point-max)) - (gnus-article-hide-text end (point-max) gnus-hidden-properties))))) + (if (text-property-any end (point-max) 'article-type 'signature) + (progn + (gnus-delete-wash-type 'signature) + (gnus-remove-text-properties-when + 'article-type 'signature end (point-max) + (cons 'article-type (cons 'signature + gnus-hidden-properties)))) + (gnus-add-wash-type 'signature) + (gnus-add-text-properties-when + 'article-type nil end (point-max) + (cons 'article-type (cons 'signature + gnus-hidden-properties))))) + (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) + (gnus-set-mode-line 'article)))) (defun gnus-button-entry () ;; Return the first entry in `gnus-button-alist' matching this place. @@ -3938,6 +5431,57 @@ specified by `gnus-button-alist'." (gnus-message 1 "You must define `%S' to use this button" (cons fun args))))))) +(defun gnus-parse-news-url (url) + (let (scheme server group message-id articles) + (with-temp-buffer + (insert url) + (goto-char (point-min)) + (when (looking-at "\\([A-Za-z]+\\):") + (setq scheme (match-string 1)) + (goto-char (match-end 0))) + (when (looking-at "//\\([^/]+\\)/") + (setq server (match-string 1)) + (goto-char (match-end 0))) + + (cond + ((looking-at "\\(.*@.*\\)") + (setq message-id (match-string 1))) + ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)") + (setq group (match-string 1) + articles (split-string (match-string 2) "-"))) + ((looking-at "\\([^/]+\\)/?") + (setq group (match-string 1))) + (t + (error "Unknown news URL syntax")))) + (list scheme server group message-id articles))) + +(defun gnus-button-handle-news (url) + "Fetch a news URL." + (destructuring-bind (scheme server group message-id articles) + (gnus-parse-news-url url) + (cond + (message-id + (save-excursion + (set-buffer gnus-summary-buffer) + (if server + (let ((gnus-refer-article-method (list (list 'nntp server)))) + (gnus-summary-refer-article message-id)) + (gnus-summary-refer-article message-id)))) + (group + (gnus-button-fetch-group url))))) + +(defun gnus-button-handle-info (url) + "Fetch an info URL." + (if (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)))) + (error "Can't parse %s" url))) + (defun gnus-button-message-id (message-id) "Fetch MESSAGE-ID." (save-excursion @@ -3949,8 +5493,10 @@ specified by `gnus-button-alist'." (if (not (string-match "[:/]" address)) ;; This is just a simple group url. (gnus-group-read-ephemeral-group address gnus-select-method) - (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$" - address)) + (if (not + (string-match + "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?" + address)) (error "Can't parse %s" address) (gnus-group-read-ephemeral-group (match-string 4 address) @@ -3958,160 +5504,136 @@ specified by `gnus-button-alist'." (nntp-address ,(match-string 1 address)) (nntp-port-number ,(if (match-end 3) (match-string 3 address) - "nntp"))))))) + "nntp"))) + nil nil nil + (and (match-end 6) (list (string-to-int (match-string 6 address)))))))) (defun gnus-url-parse-query-string (query &optional downcase) (let (retval pairs cur key val) (setq pairs (split-string query "&")) (while pairs (setq cur (car pairs) - pairs (cdr pairs)) + pairs (cdr pairs)) (if (not (string-match "=" cur)) - nil ; Grace - (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0))) - val (gnus-url-unhex-string (substring cur (match-end 0) nil))) - (if downcase - (setq key (downcase key))) - (setq cur (assoc key retval)) - (if cur - (setcdr cur (cons val (cdr cur))) - (setq retval (cons (list key val) retval))))) + nil ; Grace + (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0))) + val (gnus-url-unhex-string (substring cur (match-end 0) nil) t)) + (if downcase + (setq key (downcase key))) + (setq cur (assoc key retval)) + (if cur + (setcdr cur (cons val (cdr cur))) + (setq retval (cons (list key val) retval))))) retval)) -(defun gnus-url-unhex (x) - (if (> x ?9) - (if (>= x ?a) - (+ 10 (- x ?a)) - (+ 10 (- x ?A))) - (- x ?0))) - -(defun gnus-url-unhex-string (str &optional allow-newlines) - "Remove %XXX embedded spaces, etc in a url. -If optional second argument ALLOW-NEWLINES is non-nil, then allow the -decoding of carriage returns and line feeds in the string, which is normally -forbidden in URL encoding." - (setq str (or str "")) - (let ((tmp "") - (case-fold-search t)) - (while (string-match "%[0-9a-f][0-9a-f]" str) - (let* ((start (match-beginning 0)) - (ch1 (gnus-url-unhex (elt str (+ start 1)))) - (code (+ (* 16 ch1) - (gnus-url-unhex (elt str (+ start 2)))))) - (setq tmp (concat - tmp (substring str 0 start) - (cond - (allow-newlines - (char-to-string code)) - ((or (= code ?\n) (= code ?\r)) - " ") - (t (char-to-string code)))) - str (substring str (match-end 0))))) - (setq tmp (concat tmp str)) - tmp)) - (defun gnus-url-mailto (url) ;; Send mail to someone (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 (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) - subject (cdr-safe (assoc "subject" args))) - (message-mail) + subject (cdr-safe (assoc "subject" args))) + (gnus-msg-mail) (while args (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) (if (fboundp func) - (funcall func) - (message-position-on-field (caar args))) + (funcall func) + (message-position-on-field (caar args))) (insert (mapconcat 'identity (cdar args) ", ")) (setq args (cdr args))) (if subject - (message-goto-body) + (message-goto-body) (message-goto-subject)))) -(defun gnus-button-mailto (address) - ;; Mail to ADDRESS. - (set-buffer (gnus-copy-article-buffer)) - (message-reply address)) - -(defun gnus-button-reply (address) - ;; Reply to ADDRESS. - (message-reply address)) - -(defun gnus-button-url (address) - "Browse ADDRESS." - ;; In Emacs 20, `browse-url-browser-function' may be an alist. - (if (listp browse-url-browser-function) - (browse-url address) - (funcall browse-url-browser-function address))) - (defun gnus-button-embedded-url (address) - "Browse ADDRESS." - ;; In Emacs 20, `browse-url-browser-function' may be an alist. - (if (listp browse-url-browser-function) - (browse-url (gnus-strip-whitespace address)) - (funcall browse-url-browser-function (gnus-strip-whitespace address)))) + "Activate ADDRESS with `browse-url'." + (browse-url (gnus-strip-whitespace address))) ;;; Next/prev buttons in the article buffer. (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n") -(defvar gnus-prev-page-map nil) -(unless gnus-prev-page-map - (setq gnus-prev-page-map (make-sparse-keymap)) - (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page) - (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page)) +(defvar gnus-prev-page-map + (let ((map (make-sparse-keymap))) + (unless (>= emacs-major-version 21) + ;; XEmacs doesn't care. + (set-keymap-parent map gnus-article-mode-map)) + (define-key map gnus-mouse-2 'gnus-button-prev-page) + (define-key map "\r" 'gnus-button-prev-page) + map)) (defun gnus-insert-prev-page-button () - (let ((buffer-read-only nil)) + (let ((b (point)) + (buffer-read-only nil)) (gnus-eval-format gnus-prev-page-line-format nil - `(gnus-prev t local-map ,gnus-prev-page-map - gnus-callback gnus-article-button-prev-page - article-type annotation)))) - -(defvar gnus-next-page-map nil) -(unless gnus-next-page-map - (setq gnus-next-page-map (make-keymap)) - (suppress-keymap gnus-prev-page-map) - (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page) - (define-key gnus-next-page-map "\r" 'gnus-button-next-page)) - -(defun gnus-button-next-page () + `(,@(gnus-local-map-property gnus-prev-page-map) + gnus-prev t + gnus-callback gnus-article-button-prev-page + article-type annotation)) + (widget-convert-button + 'link b (point) + :action 'gnus-button-prev-page + :button-keymap gnus-prev-page-map))) + +(defvar gnus-prev-page-map + (let ((map (make-sparse-keymap))) + (unless (>= emacs-major-version 21) + ;; XEmacs doesn't care. + (set-keymap-parent map gnus-article-mode-map)) + (define-key map gnus-mouse-2 'gnus-button-prev-page) + (define-key map "\r" 'gnus-button-prev-page) + map)) + +(defvar gnus-next-page-map + (let ((map (make-sparse-keymap))) + (unless (>= emacs-major-version 21) + ;; XEmacs doesn't care. + (set-keymap-parent map gnus-article-mode-map)) + (define-key map gnus-mouse-2 'gnus-button-next-page) + (define-key map "\r" 'gnus-button-next-page) + map)) + +(defun gnus-button-next-page (&optional args more-args) "Go to the next page." (interactive) (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) + (select-window (gnus-get-buffer-window gnus-article-buffer t)) (gnus-article-next-page) (select-window win))) -(defun gnus-button-prev-page () +(defun gnus-button-prev-page (&optional args more-args) "Go to the prev page." (interactive) (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) + (select-window (gnus-get-buffer-window gnus-article-buffer t)) (gnus-article-prev-page) (select-window win))) (defun gnus-insert-next-page-button () - (let ((buffer-read-only nil)) + (let ((b (point)) + (buffer-read-only nil)) (gnus-eval-format gnus-next-page-line-format nil - `(gnus-next - t local-map ,gnus-next-page-map - gnus-callback gnus-article-button-next-page - article-type annotation)))) + `(,@(gnus-local-map-property gnus-next-page-map) + gnus-next t + gnus-callback gnus-article-button-next-page + article-type annotation)) + (widget-convert-button + 'link b (point) + :action 'gnus-button-next-page + :button-keymap gnus-next-page-map))) (defun gnus-article-button-next-page (arg) "Go to the next page." (interactive "P") (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) + (select-window (gnus-get-buffer-window gnus-article-buffer t)) (gnus-article-next-page) (select-window win))) @@ -4119,7 +5641,7 @@ forbidden in URL encoding." "Go to the prev page." (interactive "P") (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) + (select-window (gnus-get-buffer-window gnus-article-buffer t)) (gnus-article-prev-page) (select-window win))) @@ -4127,8 +5649,8 @@ forbidden in URL encoding." '(mail-decode-encoded-word-region) "List of methods used to decode headers. -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 +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 whose names match REGEXP. @@ -4146,13 +5668,13 @@ For example: (eq gnus-newsgroup-name (car gnus-decode-header-methods-cache))) (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name)) - (mapc '(lambda (x) - (if (symbolp x) - (nconc gnus-decode-header-methods-cache (list x)) - (if (and gnus-newsgroup-name - (string-match (car x) gnus-newsgroup-name)) - (nconc gnus-decode-header-methods-cache - (list (cdr x)))))) + (mapcar (lambda (x) + (if (symbolp x) + (nconc gnus-decode-header-methods-cache (list x)) + (if (and gnus-newsgroup-name + (string-match (car x) gnus-newsgroup-name)) + (nconc gnus-decode-header-methods-cache + (list (cdr x)))))) gnus-decode-header-methods)) (let ((xlist gnus-decode-header-methods-cache)) (pop xlist) @@ -4169,34 +5691,309 @@ For example: (let ((length (- (point-max) (point-min))) (alist gnus-treatment-function-alist) (article-goto-body-goes-to-point-min-p t) + (treated-type + (or (not type) + (catch 'found + (let ((list gnus-article-treat-types)) + (while list + (when (string-match (pop list) type) + (throw 'found t))))))) + (highlightp (gnus-visual-p 'article-highlight 'highlight)) val elem) - (when (and (gnus-visual-p 'article-highlight 'highlight) - (or (not type) - (catch 'found - (let ((list gnus-article-treat-types)) - (while list - (when (string-match (pop list) type) - (throw 'found t))))))) - (gnus-run-hooks 'gnus-part-display-hook) - (while (setq elem (pop alist)) - (setq val (symbol-value (car elem))) - (when (cond - (condition - (eq condition val)) - ((null val) - nil) - ((eq val t) - t) - ((eq val 'head) - nil) - ((eq val 'last) - (eq part-number total-parts)) - ((numberp val) - (< length val)) - (t - (eval val))) + (gnus-run-hooks 'gnus-part-display-hook) + (while (setq elem (pop alist)) + (setq val + (save-excursion + (if (gnus-buffer-live-p gnus-summary-buffer) + (set-buffer gnus-summary-buffer)) + (symbol-value (car elem)))) + (when (and (or (consp val) + treated-type) + (gnus-treat-predicate val) + (or (not (get (car elem) 'highlight)) + highlightp)) + (save-restriction (funcall (cadr elem))))))) +;; Dynamic variables. +(eval-when-compile + (defvar part-number) + (defvar total-parts) + (defvar type) + (defvar condition) + (defvar length)) + +(defun gnus-treat-predicate (val) + (cond + ((null val) + nil) + ((and (listp val) + (stringp (car val))) + (apply 'gnus-or (mapcar `(lambda (s) + (string-match s ,(or gnus-newsgroup-name ""))) + val))) + ((listp val) + (let ((pred (pop val))) + (cond + ((eq pred 'or) + (apply 'gnus-or (mapcar 'gnus-treat-predicate val))) + ((eq pred 'and) + (apply 'gnus-and (mapcar 'gnus-treat-predicate val))) + ((eq pred 'not) + (not (gnus-treat-predicate (car val)))) + ((eq pred 'typep) + (equal (car val) type)) + (t + (error "%S is not a valid predicate" pred))))) + (condition + (eq condition val)) + ((eq val t) + t) + ((eq val 'head) + nil) + ((eq val 'last) + (eq part-number total-parts)) + ((numberp val) + (< length val)) + (t + (error "%S is not a valid value" val)))) + +(defun gnus-article-encrypt-body (protocol &optional n) + "Encrypt the article body." + (interactive + (list + (or gnus-article-encrypt-protocol + (completing-read "Encrypt protocol: " + gnus-article-encrypt-protocol-alist + nil t)) + current-prefix-arg)) + (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist)))) + (unless func + (error (format "Can't find the encrypt protocol %s" protocol))) + (if (equal gnus-newsgroup-name "nndraft:drafts") + (error "Can't encrypt the article in group nndraft:drafts")) + (if (equal gnus-newsgroup-name "nndraft:queue") + (error "Don't encrypt the article in group nndraft:queue")) + (gnus-summary-iterate n + (save-excursion + (set-buffer gnus-summary-buffer) + (let ((mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) + (summary-buffer gnus-summary-buffer) + references point) + (gnus-set-global-variables) + (when (gnus-group-read-only-p) + (error "The current newsgroup does not support article encrypt")) + (gnus-summary-show-article t) + (setq references + (or (mail-header-references gnus-current-headers) "")) + (set-buffer gnus-article-buffer) + (let* ((buffer-read-only nil) + (headers + (mapcar (lambda (field) + (and (save-restriction + (message-narrow-to-head) + (goto-char (point-min)) + (search-forward field nil t)) + (prog2 + (message-narrow-to-field) + (buffer-substring (point-min) (point-max)) + (delete-region (point-min) (point-max)) + (widen)))) + '("Content-Type:" "Content-Transfer-Encoding:" + "Content-Disposition:")))) + (message-narrow-to-head) + (message-remove-header "MIME-Version") + (goto-char (point-max)) + (setq point (point)) + (insert (apply 'concat headers)) + (widen) + (narrow-to-region point (point-max)) + (let ((message-options message-options)) + (message-options-set 'message-sender user-mail-address) + (message-options-set 'message-recipients user-mail-address) + (message-options-set 'message-sign-encrypt 'not) + (funcall func)) + (goto-char (point-min)) + (insert "MIME-Version: 1.0\n") + (widen) + (gnus-summary-edit-article-done + references nil summary-buffer t)) + (when gnus-keep-backlog + (gnus-backlog-remove-article + (car gnus-article-current) (cdr gnus-article-current))) + (save-excursion + (when (get-buffer gnus-original-article-buffer) + (set-buffer gnus-original-article-buffer) + (setq gnus-original-article nil))) + (when gnus-use-cache + (gnus-cache-update-article + (car gnus-article-current) (cdr gnus-article-current)))))))) + +(defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n" + "The following specs can be used: +%t The security MIME type +%i Additional info +%d Details +%D Details if button is pressed") + +(defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n" + "The following specs can be used: +%t The security MIME type +%i Additional info +%d Details +%D Details if button is pressed") + +(defvar gnus-mime-security-button-line-format-alist + '((?t gnus-tmp-type ?s) + (?i gnus-tmp-info ?s) + (?d gnus-tmp-details ?s) + (?D gnus-tmp-pressed-details ?s))) + +(defvar gnus-mime-security-button-map + (let ((map (make-sparse-keymap))) + (unless (>= (string-to-number emacs-version) 21) + (set-keymap-parent map gnus-article-mode-map)) + (define-key map gnus-mouse-2 'gnus-article-push-button) + (define-key map "\r" 'gnus-article-press-button) + map)) + +(defvar gnus-mime-security-details-buffer nil) + +(defvar gnus-mime-security-button-pressed nil) + +(defvar gnus-mime-security-show-details-inline t + "If non-nil, show details in the article buffer.") + +(defun gnus-mime-security-verify-or-decrypt (handle) + (mm-remove-parts (cdr handle)) + (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region)) + point buffer-read-only) + (if region + (goto-char (car region))) + (save-restriction + (narrow-to-region (point) (point)) + (with-current-buffer (mm-handle-multipart-original-buffer handle) + (let* ((mm-verify-option 'known) + (mm-decrypt-option 'known) + (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle))) + (unless (eq nparts (cdr handle)) + (mm-destroy-parts (cdr handle)) + (setcdr handle nparts)))) + (setq point (point)) + (gnus-mime-display-security handle) + (goto-char (point-max))) + (when region + (delete-region (point) (cdr region)) + (set-marker (car region) nil) + (set-marker (cdr region) nil)) + (goto-char point))) + +(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)) + 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.")))) + +(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))) + +(defun gnus-insert-mime-security-button (handle &optional displayed) + (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) + (gnus-tmp-type + (concat + (or (nth 2 (assoc protocol mm-verify-function-alist)) + (nth 2 (assoc protocol mm-decrypt-function-alist)) + "Unknown") + (if (equal (car handle) "multipart/signed") + " Signed" " Encrypted") + " Part")) + (gnus-tmp-info + (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) + "Undecided")) + (gnus-tmp-details + (mm-handle-multipart-ctl-parameter handle 'gnus-details)) + gnus-tmp-pressed-details + b e) + (setq gnus-tmp-details + (if gnus-tmp-details + (concat "\n" gnus-tmp-details) "")) + (setq gnus-tmp-pressed-details + (if gnus-mime-security-button-pressed gnus-tmp-details "")) + (unless (bolp) + (insert "\n")) + (setq b (point)) + (gnus-eval-format + gnus-mime-security-button-line-format + gnus-mime-security-button-line-format-alist + `(,@(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 + article-type annotation + gnus-data ,handle)) + (setq e (point)) + (widget-convert-button + 'link b e + :mime-handle handle + :action 'gnus-widget-press-button + :button-keymap gnus-mime-security-button-map + :help-echo + (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)) + (format + "%S: show detail" + (aref gnus-mouse-2 0)))))) + +(defun gnus-mime-display-security (handle) + (save-restriction + (narrow-to-region (point) (point)) + (unless (gnus-unbuttonized-mime-type-p (car handle)) + (gnus-insert-mime-security-button handle)) + (gnus-mime-display-mixed (cdr handle)) + (unless (bolp) + (insert "\n")) + (unless (gnus-unbuttonized-mime-type-p (car handle)) + (let ((gnus-mime-security-button-line-format + gnus-mime-security-button-end-line-format)) + (gnus-insert-mime-security-button handle))) + (mm-set-handle-multipart-parameter + handle 'gnus-region + (cons (set-marker (make-marker) (point-min)) + (set-marker (make-marker) (point-max)))))) + (gnus-ems-redefine) (provide 'gnus-art)