X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=5b54196a518a034b3aba3180d8237283294bee6a;hb=507b285173baa14c25dc095f5c65d05a5474a8fe;hp=0168a62a6d4d7f32a178b27aac0ca476db4cbe57;hpb=926bcf02432a9bed8ce9f17224e91c514b2a5093;p=gnus diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 0168a62a6..5b54196a5 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,5 +1,5 @@ ;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -25,21 +25,234 @@ ;;; Code: +(require 'custom) (require 'gnus) (require 'gnus-sum) -(require 'article) (require 'gnus-spec) (require 'gnus-int) (require 'browse-url) -(defcustom gnus-article-save-directory gnus-directory - "*Name of the directory articles will be saved in (default \"~/News\")." - :group 'article - :type 'directory) +(defgroup gnus-article nil + "Article display." + :link '(custom-manual "(gnus)The Article Buffer") + :group 'gnus) + +(defgroup gnus-article-hiding nil + "Hiding article parts." + :link '(custom-manual "(gnus)Article Hiding") + :group 'gnus-article) + +(defgroup gnus-article-highlight nil + "Article highlighting." + :link '(custom-manual "(gnus)Article Highlighting") + :group 'gnus-article + :group 'gnus-visual) + +(defgroup gnus-article-signature nil + "Article signatures." + :link '(custom-manual "(gnus)Article Signature") + :group 'gnus-article) + +(defgroup gnus-article-headers nil + "Article headers." + :link '(custom-manual "(gnus)Hiding Headers") + :group 'gnus-article) + +(defgroup gnus-article-washing nil + "Special commands on articles." + :link '(custom-manual "(gnus)Article Washing") + :group 'gnus-article) + +(defgroup gnus-article-emphasis nil + "Fontisizing articles." + :link '(custom-manual "(gnus)Article Fontisizing") + :group 'gnus-article) + +(defgroup gnus-article-saving nil + "Saving articles." + :link '(custom-manual "(gnus)Saving Articles") + :group 'gnus-article) + +(defgroup gnus-article-mime nil + "Worshiping the MIME wonder." + :link '(custom-manual "(gnus)Using MIME") + :group 'gnus-article) + +(defgroup gnus-article-buttons nil + "Pushable buttons in the article buffer." + :link '(custom-manual "(gnus)Article Buttons") + :group 'gnus-article) + +(defgroup gnus-article-various nil + "Other article options." + :link '(custom-manual "(gnus)Misc Article") + :group 'gnus-article) + +(defcustom gnus-ignored-headers + '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:" + "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:" + "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:" + "^Approved:" "^Sender:" "^Received:" "^Mail-from:") + "All headers that match 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." + :type '(choice :custom-show nil + regexp + (repeat regexp)) + :group 'gnus-article-hiding) + +(defcustom gnus-visible-headers + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From" + "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." + :type '(repeat :value-to-internal (lambda (widget value) + (custom-split-regexp-maybe value)) + :match (lambda (widget value) + (or (stringp value) + (widget-editable-list-match widget value))) + regexp) + :group 'gnus-article-hiding) + +(defcustom gnus-sorted-header-list + '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^To:" + "^Cc:" "^Date:" "^Organization:") + "This variable is a list of regular expressions. +If it is non-nil, headers that match the regular expressions will +be placed first in the article buffer in the sequence specified by +this list." + :type '(repeat regexp) + :group 'gnus-article-hiding) + +(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', and `date'." + :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 "Date less than four days old." date)) + :group 'gnus-article-hiding) + +(defcustom gnus-signature-separator '("^-- $" "^-- *$") + "Regexp matching signature separator. +This can also be a list of regexps. In that case, it will be checked +from head to tail looking for a separator. Searches will be done from +the end of the buffer." + :type '(repeat string) + :group 'gnus-article-signature) + +(defcustom gnus-signature-limit nil + "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 +will be called without any parameters, and if it returns nil, there is +no signature in the buffer. If it is a string, it will be used as a +regexp. If it matches, the text in question is not a signature." + :type '(choice integer number function regexp) + :group 'gnus-article-signature) + +(defcustom gnus-hidden-properties '(invisible t intangible t) + "Property list to use for hiding text." + :type 'sexp + :group 'gnus-article-hiding) + +(defcustom gnus-article-x-face-command + "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" + "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. + :group 'gnus-article-washing) + +(defcustom gnus-article-x-face-too-ugly nil + "Regexp matching posters whose face shouldn't be shown automatically." + :type 'regexp + :group 'gnus-article-washing) + +(defcustom gnus-emphasis-alist + (let ((format + "\\(\\s-\\|^\\|[-\"\(]\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"\)]\\)") + (types + '(("_" "_" underline) + ("/" "/" italic) + ("\\*" "\\*" bold) + ("_/" "/_" underline-italic) + ("_\\*" "\\*_" underline-bold) + ("\\*/" "/\\*" bold-italic) + ("_\\*/" "/\\*_" underline-bold-italic)))) + `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" + 2 3 gnus-emphasis-underline) + ,@(mapcar + (lambda (spec) + (list + (format format (car spec) (cadr spec)) + 2 3 (intern (format "gnus-emphasis-%s" (caddr spec))))) + types))) + "Alist that says how to fontify certain phrases. +Each item looks like this: + + (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) + +The first element is a regular expression to be matched. The second +is a number that says what regular expression grouping used to find +the entire emphasized word. The third is a number that says what +regexp grouping should be displayed and highlighted. The fourth +is the face used for highlighting." + :type '(repeat (list :value ("" 0 0 default) + regexp + (integer :tag "Match group") + (integer :tag "Emphasize group") + face)) + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-bold '((t (:bold t))) + "Face used for displaying strong emphasized text (*word*)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-italic '((t (:italic t))) + "Face used for displaying italic emphasized text (/word/)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline '((t (:underline t))) + "Face used for displaying underlined emphasized text (_word_)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline-bold '((t (:bold t :underline t))) + "Face used for displaying underlined bold emphasized text (_*word*_)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) + "Face used for displaying underlined italic emphasized text (_*word*_)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) + "Face used for displaying bold italic emphasized text (/*word*/)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline-bold-italic + '((t (:bold t :italic t :underline t))) + "Face used for displaying underlined bold italic emphasized text. +Esample: (_/*word*/_)." + :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-zone' for the possible values." + :type 'string + :link '(custom-manual "(gnus)Article Date") + :group 'gnus-article-washing) + +(eval-and-compile + (autoload 'hexl-hex-string-to-integer "hexl") + (autoload 'timezone-make-date-arpa-standard "timezone") + (autoload 'mail-extract-address-components "mail-extr")) (defcustom gnus-save-all-headers t "*If non-nil, don't remove any headers before saving." - :group 'article + :group 'gnus-article-saving :type 'boolean) (defcustom gnus-prompt-before-saving 'always @@ -50,7 +263,7 @@ every article that is saved will be preceded by a prompt, even when saving large batches of articles. If this variable is neither nil not `always', there the user will be prompted once for a file name for each invocation of the saving commands." - :group 'article + :group 'gnus-article-saving :type '(choice (item always) (item :tag "never" nil) (sexp :tag "once" :format "%t"))) @@ -60,7 +273,7 @@ each invocation of the saving commands." If `gnus-save-all-headers' is non-nil, this variable will be ignored. If that variable is nil, however, all headers that match this regexp will be kept while the rest will be deleted before saving." - :group 'article + :group 'gnus-article-saving :type '(repeat string)) (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail @@ -76,7 +289,7 @@ Gnus provides the following functions: * gnus-summary-save-in-file (article format) * gnus-summary-save-in-vm (use VM's folder format) * gnus-summary-write-to-file (article format -- overwrite)." - :group 'article + :group 'gnus-article-saving :type '(radio (function-item gnus-summary-save-in-rmail) (function-item gnus-summary-save-in-mail) (function-item gnus-summary-save-in-folder) @@ -87,26 +300,26 @@ Gnus provides the following functions: (defcustom gnus-rmail-save-name 'gnus-plain-save-name "A function generating a file name to save articles in Rmail format. The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE." - :group 'article + :group 'gnus-article-saving :type 'function) (defcustom gnus-mail-save-name 'gnus-plain-save-name "A function generating a file name to save articles in Unix mail format. The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE." - :group 'article + :group 'gnus-article-saving :type 'function) (defcustom gnus-folder-save-name 'gnus-folder-save-name "A function generating a file name to save articles in MH folder. The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER." - :group 'article + :group 'gnus-article-saving :type 'function) (defcustom gnus-file-save-name 'gnus-numeric-save-name "A function generating a file name to save articles in article format. The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE." - :group 'article + :group 'gnus-article-saving :type 'function) (defcustom gnus-split-methods @@ -130,26 +343,26 @@ parameter. If it is a list, it will be evaled in the same buffer. If this form or function returns a string, this string will be used as a possible file name; and if it returns a non-nil list, that list will be used as possible file names." - :group 'article + :group 'gnus-article-saving :type '(repeat (choice (list function) (cons regexp (repeat string)) sexp))) (defcustom gnus-strict-mime t "*If nil, MIME-decode even if there is no Mime-Version header." - :group 'article + :group 'gnus-article-mime :type 'boolean) (defcustom gnus-show-mime-method 'metamail-buffer "Function to process a MIME message. The function is called from the article buffer." - :group 'article + :group 'gnus-article-mime :type 'function) (defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable "*Function to decode MIME encoded words. The function is called from the article buffer." - :group 'article + :group 'gnus-article-mime :type 'function) (defcustom gnus-page-delimiter "^\^L" @@ -157,29 +370,29 @@ The function is called from the article buffer." The default value is \"^\^L\", which is a form linefeed at the beginning of a line." :type 'regexp - :group 'article) + :group 'gnus-article-various) (defcustom gnus-article-mode-line-format "Gnus: %%b %S" "*The format specification for the article mode line. See `gnus-summary-mode-line-format' for a closer description." :type 'string - :group 'article) + :group 'gnus-article-various) (defcustom gnus-article-mode-hook nil "*A hook for Gnus article mode." :type 'hook - :group 'article) + :group 'gnus-article-various) (defcustom gnus-article-menu-hook nil "*Hook run after the creation of the article mode menu." :type 'hook - :group 'article) + :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." :type 'hook - :group 'article) + :group 'gnus-article-various) (defcustom gnus-article-button-face 'bold "Face used for highlighting buttons in the article buffer. @@ -187,7 +400,7 @@ If you want to run a special decoding program like nkf, use this hook." An article button is a piece of text that you can activate by pressing `RET' or `mouse-2' above it." :type 'face - :group 'article) + :group 'gnus-article-buttons) (defcustom gnus-article-mouse-face 'highlight "Face used for mouse highlighting in the article buffer. @@ -195,60 +408,65 @@ An article button is a piece of text that you can activate by pressing Article buttons will be displayed in this face when the cursor is above them." :type 'face - :group 'article) + :group 'gnus-article-buttons) (defcustom gnus-signature-face 'italic "Face used for highlighting a signature in the article buffer." :type 'face - :group 'article) + :group 'gnus-article-highlight + :group 'gnus-article-signature) -(defface gnus-header-from-face +(defface gnus-header-from-face '((((class color) (background dark)) - (:foreground "light blue" :bold t :italic t)) + (:foreground "spring green" :bold t)) (((class color) (background light)) - (:foreground "MidnightBlue" :bold t :italic t)) - (t + (:foreground "red3" :bold t)) + (t (:bold t :italic t))) "Face used for displaying from headers." - :group 'article) + :group 'gnus-article-headers + :group 'gnus-article-highlight) -(defface gnus-header-subject-face +(defface gnus-header-subject-face '((((class color) (background dark)) - (:foreground "pink" :bold t :italic t)) + (:foreground "SeaGreen3" :bold t)) (((class color) (background light)) - (:foreground "firebrick" :bold t :italic t)) - (t + (:foreground "red4" :bold t)) + (t (:bold t :italic t))) "Face used for displaying subject headers." - :group 'article) + :group 'gnus-article-headers + :group 'gnus-article-highlight) -(defface gnus-header-newsgroups-face +(defface gnus-header-newsgroups-face '((((class color) (background dark)) (:foreground "yellow" :bold t :italic t)) (((class color) (background light)) - (:foreground "indianred" :bold t :italic t)) - (t + (:foreground "MidnightBlue" :bold t :italic t)) + (t (:bold t :italic t))) "Face used for displaying newsgroups headers." - :group 'article) + :group 'gnus-article-headers + :group 'gnus-article-highlight) -(defface gnus-header-name-face +(defface gnus-header-name-face '((((class color) (background dark)) - (:foreground "cyan" :bold t)) + (:foreground "SeaGreen")) (((class color) (background light)) - (:foreground "DarkGreen" :bold t)) - (t + (:foreground "maroon")) + (t (:bold t))) "Face used for displaying header names." - :group 'article) + :group 'gnus-article-headers + :group 'gnus-article-highlight) (defface gnus-header-content-face '((((class color) @@ -256,10 +474,11 @@ above them." (:foreground "forest green" :italic t)) (((class color) (background light)) - (:foreground "DarkGreen" :italic t)) - (t + (:foreground "indianred4" :italic t)) + (t (:italic t))) "Face used for displaying header content." - :group 'article) + :group 'gnus-article-headers + :group 'gnus-article-highlight) (defcustom gnus-header-face-alist '(("From" nil gnus-header-from-face) @@ -268,7 +487,7 @@ above them." ("" gnus-header-name-face gnus-header-content-face)) "Controls highlighting of article header. -An alist of the form (HEADER NAME CONTENT). +An alist of the form (HEADER NAME CONTENT). HEADER is a regular expression which should match the name of an header header and NAME and CONTENT are either face names or nil. @@ -277,7 +496,8 @@ The name of each header field will be displayed using the face specified by the first element in the list where HEADER match the header name and NAME is non-nil. Similarly, the content will be displayed by the first non-nil matching CONTENT face." - :group 'article + :group 'gnus-article-headers + :group 'gnus-article-highlight :type '(repeat (list (regexp :tag "Header") (choice :tag "Name" (item :tag "skip" nil) @@ -290,7 +510,7 @@ displayed by the first non-nil matching CONTENT face." (defvar gnus-article-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) - ;;(modify-syntax-entry ?_ "w" table) + (modify-syntax-entry ?- "w" table) table) "Syntax table used in article mode buffers. Initialized from `text-mode-syntax-table.") @@ -303,48 +523,843 @@ Initialized from `text-mode-syntax-table.") (defvar gnus-number-of-articles-to-be-saved nil) -;;; Provide a mapping from `gnus-*' commands to Article commands. +(defvar gnus-inhibit-hiding nil) +(defvar gnus-newsgroup-name) + +(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) + (when (memq 'intangible props) + (put-text-property + (max (1- b) (point-min)) + b 'intangible (cddr (memq 'intangible props))))) + +(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) + (when (memq 'intangible gnus-hidden-properties) + (put-text-property (max (1- b) (point-min)) + b 'intangible nil))) + +(defun gnus-article-hide-text-type (b e type) + "Hide text of TYPE between B and E." + (gnus-article-hide-text + b e (cons 'article-type (cons type gnus-hidden-properties)))) + +(defun gnus-article-unhide-text-type (b e type) + "Hide text of TYPE between B and E." + (remove-text-properties + b e (cons 'article-type (cons type gnus-hidden-properties))) + (when (memq 'intangible gnus-hidden-properties) + (put-text-property (max (1- b) (point-min)) + b 'intangible nil))) + +(defun gnus-article-hide-text-of-type (type) + "Hide text of TYPE in the current buffer." + (save-excursion + (let ((b (point-min)) + (e (point-max))) + (while (setq b (text-property-any b e 'article-type type)) + (add-text-properties b (incf b) gnus-hidden-properties))))) -(eval-and-compile - (mapcar - (lambda (func) - (let (afunc gfunc) - (if (consp func) - (setq afunc (car func) - gfunc (cdr func)) - (setq afunc func - gfunc (intern (format "gnus-%s" func)))) - (fset gfunc - `(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-hide-boring-headers - article-treat-overstrike - (article-fill . gnus-article-word-wrap) - article-remove-cr - article-display-x-face - article-de-quoted-unreadable - article-mime-decode-quoted-printable - article-hide-pgp - article-hide-pem - article-hide-signature - article-remove-trailing-blank-lines - article-strip-leading-blank-lines - article-strip-multiple-blank-lines - article-strip-blank-lines - article-date-local - article-date-original - article-date-lapsed - article-emphasize - (article-show-all . gnus-article-show-all-headers)))) +(defun gnus-article-delete-text-of-type (type) + "Delete text of TYPE in the current buffer." + (save-excursion + (let ((b (point-min))) + (while (setq b (text-property-any b (point-max) 'article-type type)) + (delete-region b (incf b)))))) + +(defun gnus-article-delete-invisible-text () + "Delete all invisible text in the current buffer." + (save-excursion + (let ((b (point-min))) + (while (setq b (text-property-any b (point-max) 'invisible t)) + (delete-region b (incf b)))))) + +(defun gnus-article-text-type-exists-p (type) + "Say whether any text of type TYPE exists in the buffer." + (text-property-any (point-min) (point-max) 'article-type type)) + +(defsubst gnus-article-header-rank () + "Give the rank of the string HEADER as given by `gnus-sorted-header-list'." + (let ((list gnus-sorted-header-list) + (i 0)) + (while list + (when (looking-at (car list)) + (setq list nil)) + (setq list (cdr list)) + (incf i)) + 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)) + (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) + (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) + want-list 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)))))))) + +(defun article-hide-boring-headers (&optional arg) + "Toggle hiding of headers that aren't very interesting. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (when (and (not (gnus-article-check-hidden-text 'boring-headers arg)) + (not gnus-show-all-headers)) + (save-excursion + (save-restriction + (let ((buffer-read-only nil) + (list gnus-boring-article-headers) + (inhibit-point-motion-hooks t) + elem) + (nnheader-narrow-to-headers) + (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) + (forward-line -1) + (gnus-article-hide-text-type + (progn (beginning-of-line) (point)) + (progn + (end-of-line) + (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (point-max))) + '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 + ""))) + (gnus-article-hide-header "newsgroups"))) + ((eq elem 'followup-to) + (when (equal (message-fetch-field "followup-to") + (message-fetch-field "newsgroups")) + (gnus-article-hide-header "followup-to"))) + ((eq elem 'reply-to) + (let ((from (message-fetch-field "from")) + (reply-to (message-fetch-field "reply-to"))) + (when (and + from reply-to + (ignore-errors + (equal + (nth 1 (mail-extract-address-components from)) + (nth 1 (mail-extract-address-components reply-to))))) + (gnus-article-hide-header "reply-to")))) + ((eq elem 'date) + (let ((date (message-fetch-field "date"))) + (when (and date + (< (gnus-days-between (current-time-string) date) + 4)) + (gnus-article-hide-header "date"))))))))))) + +(defun gnus-article-hide-header (header) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward (concat "^" header ":") nil t) + (gnus-article-hide-text-type + (progn (beginning-of-line) (point)) + (progn + (end-of-line) + (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (point-max))) + 'boring-headers)))) + +;; Written by Per Abrahamsen . +(defun article-treat-overstrike () + "Translate overstrikes into bold text." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (while (search-forward "\b" nil t) + (let ((next (following-char)) + (previous (char-after (- (point) 2)))) + ;; We do the boldification/underlining by hiding the + ;; overstrikes and putting the proper text property + ;; on the letters. + (cond + ((eq next previous) + (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) + (put-text-property (point) (1+ (point)) 'face 'bold)) + ((eq next ?_) + (gnus-article-hide-text-type (1- (point)) (1+ (point)) 'overstrike) + (put-text-property + (- (point) 2) (1- (point)) 'face 'underline)) + ((eq previous ?_) + (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) + (put-text-property + (point) (1+ (point)) 'face 'underline)))))))) + +(defun article-fill () + "Format too long lines." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (widen) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (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)))))) + +(defun article-remove-cr () + "Remove carriage returns from an article." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (replace-match "" t t))))) + +(defun article-remove-trailing-blank-lines () + "Remove all trailing blank lines from the article." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-max)) + (delete-region + (point) + (progn + (while (and (not (bobp)) + (looking-at "^[ \t]*$")) + (forward-line -1)) + (forward-line 1) + (point)))))) + +(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 nil) + from) + (save-restriction + (nnheader-narrow-to-headers) + (setq from (message-fetch-field "from")) + (goto-char (point-min)) + (when (and 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)))) + ;; Has to be present. + (re-search-forward "^X-Face: " nil t)) + ;; We now have the area of the buffer where the X-Face is stored. + (let ((beg (point)) + (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))) + ;; 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) + (error "%s is not a function" gnus-article-x-face-command)) + ;; The command is a string, so we interpret the command + ;; as a, well, command, and fork it off. + (let ((process-connection-type nil)) + (process-kill-without-query + (start-process + "article-x-face" nil shell-file-name shell-command-switch + gnus-article-x-face-command)) + (process-send-region "article-x-face" beg end) + (process-send-eof "article-x-face"))))))))) (defalias 'gnus-decode-rfc1522 'article-decode-rfc1522) +(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522) +(defun article-decode-rfc1522 () + "Hack to remove QP encoding from headers." + (let ((case-fold-search t) + (inhibit-point-motion-hooks t) + (buffer-read-only nil) + string) + (save-restriction + (narrow-to-region + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (point-max))) + (goto-char (point-min)) + (while (re-search-forward + "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) + (setq string (match-string 1)) + (save-restriction + (narrow-to-region (match-beginning 0) (match-end 0)) + (delete-region (point-min) (point-max)) + (insert string) + (article-mime-decode-quoted-printable + (goto-char (point-min)) (point-max)) + (subst-char-in-region (point-min) (point-max) ?_ ? ) + (goto-char (point-max))) + (goto-char (point-min)))))) + +(defun article-de-quoted-unreadable (&optional force) + "Do a naive translation of a quoted-printable-encoded article. +This is in no way, shape or form meant as a replacement for real MIME +processing, but is simply a stop-gap measure until MIME support is +written. +If FORCE, decode the article whether it is marked as quoted-printable +or not." + (interactive (list 'force)) + (save-excursion + (let ((case-fold-search t) + (buffer-read-only nil) + (type (gnus-fetch-field "content-transfer-encoding"))) + (gnus-article-decode-rfc1522) + (when (or force + (and type (string-match "quoted-printable" (downcase type)))) + (goto-char (point-min)) + (search-forward "\n\n" nil 'move) + (article-mime-decode-quoted-printable (point) (point-max)))))) + +(defun article-mime-decode-quoted-printable-buffer () + "Decode Quoted-Printable in the current buffer." + (article-mime-decode-quoted-printable (point-min) (point-max))) + +(defun article-mime-decode-quoted-printable (from to) + "Decode Quoted-Printable in the region between FROM and TO." + (interactive "r") + (goto-char from) + (while (search-forward "=" to t) + (cond ((eq (following-char) ?\n) + (delete-char -1) + (delete-char 1)) + ((looking-at "[0-9A-F][0-9A-F]") + (subst-char-in-region + (1- (point)) (point) ?= + (hexl-hex-string-to-integer + (buffer-substring (point) (+ 2 (point))))) + (delete-char 2)) + ((looking-at "=") + (delete-char 1)) + ((gnus-message 3 "Malformed MIME quoted-printable message"))))) + +(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 + (let ((inhibit-point-motion-hooks t) + buffer-read-only beg end) + (widen) + (goto-char (point-min)) + ;; Hide the "header". + (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) + (gnus-article-hide-text-type (1+ (match-beginning 0)) + (match-end 0) 'pgp)) + (setq beg (point)) + ;; Hide the actual signature. + (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) + (setq end (1+ (match-beginning 0))) + (gnus-article-hide-text-type + end + (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) + (match-end 0) + ;; Perhaps we shouldn't hide to the end of the buffer + ;; if there is no end to the signature? + (point-max)) + 'pgp)) + ;; Hide "- " PGP quotation markers. + (when (and beg end) + (narrow-to-region beg end) + (goto-char (point-min)) + (while (re-search-forward "^- " nil t) + (gnus-article-hide-text-type + (match-beginning 0) (match-end 0) 'pgp)) + (widen)))))) + +(defun article-hide-pem (&optional arg) + "Toggle hiding of any PEM headers and signatures in the current article. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (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)))))) + +(defun article-hide-signature (&optional arg) + "Hide the signature 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 'signature arg) + (save-excursion + (save-restriction + (let ((buffer-read-only nil)) + (when (gnus-article-narrow-to-signature) + (gnus-article-hide-text-type + (point-min) (point-max) 'signature))))))) + +(defun article-strip-leading-blank-lines () + "Remove all blank lines from the beginning of the article." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (while (and (not (eobp)) + (looking-at "[ \t]*$")) + (gnus-delete-line)))))) + +(defun article-strip-multiple-blank-lines () + "Replace consecutive blank lines with one empty line." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + ;; First make all blank lines empty. + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (while (re-search-forward "^[ \t]+$" nil t) + (replace-match "" nil t)) + ;; Then replace multiple empty lines with a single empty line. + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (while (re-search-forward "\n\n\n+" nil t) + (replace-match "\n\n" t t))))) + +(defun article-strip-leading-space () + "Remove all white space from the beginning of the lines in the article." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (while (re-search-forward "^[ \t]+" nil t) + (replace-match "" t t))))) + +(defun article-strip-blank-lines () + "Strip leading, trailing and multiple blank lines." + (interactive) + (article-strip-leading-blank-lines) + (article-remove-trailing-blank-lines) + (article-strip-multiple-blank-lines)) + +(defvar mime::preview/content-list) +(defvar mime::preview-content-info/point-min) +(defun gnus-article-narrow-to-signature () + "Narrow to the signature; return t if a signature is found, else nil." + (widen) + (when (and (boundp 'mime::preview/content-list) + mime::preview/content-list) + ;; We have a MIMEish article, so we use the MIME data to narrow. + (let ((pcinfo (car (last mime::preview/content-list)))) + (ignore-errors + (narrow-to-region + (funcall (intern "mime::preview-content-info/point-min") pcinfo) + (point-max))))) + + (when (gnus-article-search-signature) + (forward-line 1) + ;; Check whether we have some limits to what we consider + ;; to be a signature. + (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit + (list gnus-signature-limit))) + limit limited) + (while (setq limit (pop limits)) + (if (or (and (integerp limit) + (< (- (point-max) (point)) limit)) + (and (floatp limit) + (< (count-lines (point) (point-max)) limit)) + (and (gnus-functionp limit) + (funcall limit)) + (and (stringp limit) + (not (re-search-forward limit nil t)))) + () ; This limit did not succeed. + (setq limited t + limits nil))) + (unless limited + (narrow-to-region (point) (point-max)) + t)))) + +(defun gnus-article-search-signature () + "Search the current buffer for the signature separator. +Put point at the beginning of the signature separator." + (let ((cur (point))) + (goto-char (point-max)) + (if (if (stringp gnus-signature-separator) + (re-search-backward gnus-signature-separator nil t) + (let ((seps gnus-signature-separator)) + (while (and seps + (not (re-search-backward (car seps) nil t))) + (pop seps)) + seps)) + t + (goto-char cur) + nil))) + +(eval-and-compile + (autoload 'w3-parse-buffer "w3-parse")) + +(defun gnus-article-treat-html () + "Render HTML." + (interactive) + (let ((cbuf (current-buffer))) + (set-buffer gnus-article-buffer) + (let (buf buffer-read-only b e) + (goto-char (point-min)) + (narrow-to-region + (if (search-forward "\n\n" nil t) + (setq b (point)) + (point-max)) + (setq e (point-max))) + (nnheader-temp-write nil + (insert-buffer-substring gnus-article-buffer b e) + (save-window-excursion + (setq buf (car (w3-parse-buffer (current-buffer)))))) + (when buf + (delete-region (point-min) (point-max)) + (insert-buffer-substring buf) + (kill-buffer 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 + (prefix-numeric-value current-prefix-arg) + 0))) + +(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 +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)) + (t + (if (eq hide 'hidden) + (gnus-article-show-hidden-text type) + 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))) + (when pos + (if (get-text-property pos 'invisible) + 'hidden + 'shown)))) + +(defun gnus-article-show-hidden-text (type &optional hide) + "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))) + +(defconst article-time-units + `((year . ,(* 365.25 24 60 60)) + (week . ,(* 7 24 60 60)) + (day . ,(* 24 60 60)) + (hour . ,(* 60 60)) + (minute . 60) + (second . 1)) + "Mapping from time units to seconds.") + +(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." + (interactive (list 'ut t)) + (let* ((header (or header + (mail-header-date gnus-current-headers) + (message-fetch-field "date") + "")) + (date (if (vectorp header) (mail-header-date header) + header)) + (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") + (inhibit-point-motion-hooks t) + bface eface) + (when (and date (not (string= date ""))) + (save-excursion + (save-restriction + (nnheader-narrow-to-headers) + (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)) + (message-remove-header date-regexp t) + (beginning-of-line)) + (goto-char (point-max))) + (insert (article-make-date-line date type)) + ;; Do highlighting. + (forward-line -1) + (when (looking-at "\\([^:]+\\): *\\(.*\\)$") + (put-text-property (match-beginning 1) (match-end 1) + 'face bface) + (put-text-property (match-beginning 2) (match-end 2) + 'face eface)))))))) + +(defun article-make-date-line (date type) + "Return a DATE line of TYPE." + (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) + (concat "Date: " (condition-case () + (timezone-make-date-arpa-standard date) + (error date)) + "\n")) + ;; Convert to Universal Time. + ((eq type 'ut) + (concat "Date: " + (condition-case () + (timezone-make-date-arpa-standard date nil "UT") + (error date)) + "\n")) + ;; Get the original date from the article. + ((eq type 'original) + (concat "Date: " date "\n")) + ;; Let the user define the format. + ((eq type 'user) + (concat + "Date: " + (format-time-string gnus-article-time-format + (ignore-errors + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT")))) + "\n")) + ;; 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 + (ignore-errors + (gnus-time-minus + (gnus-encode-date + (timezone-make-date-arpa-standard + (current-time-string now) + (current-time-zone now) "UT")) + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT"))))) + (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\n") + ((zerop sec) + "X-Sent: Now\n") + (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\n" + " in the future\n")))))) + (t + (error "Unknown conversion type: %s" type)))) + +(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-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 +function and want to see what the date was before converting." + (interactive (list t)) + (article-date-ut 'original highlight)) + +(defun article-date-lapsed (&optional highlight) + "Convert the current article date to time lapsed since it was sent." + (interactive (list t)) + (article-date-ut 'lapsed highlight)) + +(defun article-date-user (&optional highlight) + "Convert the current article date to the user-defined format. +This format is defined by the `gnus-article-time-format' variable." + (interactive (list t)) + (article-date-ut 'user highlight)) + +(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-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) + (buffer-read-only nil) + (props (append '(article-type emphasis) + gnus-hidden-properties)) + regexp elem beg invisible visible face) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (setq beg (point)) + (while (setq elem (pop alist)) + (goto-char beg) + (setq regexp (car elem) + invisible (nth 1 elem) + 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) @@ -376,7 +1391,7 @@ Initialized from `text-mode-syntax-table.") (when (eq gnus-prompt-before-saving t) num))) ; Magic (set-buffer gnus-summary-buffer) - (funcall gnus-default-article-saver filename))))) + (funcall gnus-default-article-saver filename))))) (defun gnus-read-save-file-name (prompt default-name &optional filename) (cond @@ -417,10 +1432,12 @@ Initialized from `text-mode-syntax-table.") (let (result) (let ((file-name-history (nconc split-name file-name-history))) (setq result - (read-file-name - (concat prompt " (`M-p' for defaults) ") - gnus-article-save-directory - (car split-name)))) + (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)) @@ -478,10 +1495,10 @@ Directory to save to is default to `gnus-article-save-directory'." (save-excursion (save-restriction (widen) - (if (and (file-readable-p filename) (mail-file-babyl-p filename)) - (gnus-output-to-rmail filename) - (let ((mail-use-rfc822 t)) - (rmail-output filename 1 t t)))))) + (if (and (file-readable-p filename) + (mail-file-babyl-p filename)) + (gnus-output-to-rmail filename t) + (gnus-output-to-mail filename))))) ;; Remember the directory name to save articles. (setq gnus-newsgroup-last-mail filename))) @@ -546,8 +1563,15 @@ The directory to save in defaults to `gnus-article-save-directory'." (cond ((eq command 'default) gnus-last-shell-command) (command command) - (t (read-string "Shell command on article: " - gnus-last-shell-command)))) + (t (read-string + (format + "Shell command on %s: " + (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")) + gnus-last-shell-command)))) (when (string-equal command "") (setq command gnus-last-shell-command)) (gnus-eval-in-buffer-window gnus-article-buffer @@ -566,7 +1590,7 @@ The directory to save in defaults to `gnus-article-save-directory'." (defun gnus-Numeric-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 nil, it is ~/News/News.group/num. +If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num. Otherwise, it is like ~/News/news/group/num." (let ((default (expand-file-name @@ -622,6 +1646,49 @@ If variable `gnus-use-long-file-name' is non-nil, it is (concat (gnus-newsgroup-directory-form newsgroup) "/news")) gnus-article-save-directory))) +(eval-and-compile + (mapcar + (lambda (func) + (let (afunc gfunc) + (if (consp func) + (setq afunc (car func) + 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)))))))) + '(article-hide-headers + article-hide-boring-headers + article-treat-overstrike + (article-fill . gnus-article-word-wrap) + article-remove-cr + article-display-x-face + article-de-quoted-unreadable + article-mime-decode-quoted-printable + article-hide-pgp + article-hide-pem + article-hide-signature + article-remove-trailing-blank-lines + article-strip-leading-blank-lines + article-strip-multiple-blank-lines + article-strip-leading-space + article-strip-blank-lines + article-date-local + article-date-original + article-date-ut + article-date-user + article-date-lapsed + article-emphasize + (article-show-all . gnus-article-show-all-headers)))) ;;; ;;; Gnus article mode @@ -651,6 +1718,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is "\C-d" gnus-article-read-summary-keys "\M-*" gnus-article-read-summary-keys + "\M-#" gnus-article-read-summary-keys + "\M-^" gnus-article-read-summary-keys "\M-g" gnus-article-read-summary-keys) (substitute-key-definition @@ -678,9 +1747,10 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["Remove carriage return" gnus-article-remove-cr t] ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) - (when (boundp 'gnus-summary-article-menu) - (define-key gnus-article-mode-map [menu-bar commands] - (cons "Commands" gnus-summary-article-menu))) + (when nil + (when (boundp 'gnus-summary-article-menu) + (define-key gnus-article-mode-map [menu-bar commands] + (cons "Commands" gnus-summary-article-menu)))) (when (boundp 'gnus-summary-post-menu) (define-key gnus-article-mode-map [menu-bar post] @@ -716,6 +1786,7 @@ commands: (use-local-map gnus-article-mode-map) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) + (set (make-local-variable 'gnus-button-marker-list) nil) (gnus-set-default-directory) (buffer-disable-undo (current-buffer)) (setq buffer-read-only t) @@ -792,7 +1863,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-find-method-for-group gnus-newsgroup-name)) (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) (gnus-request-group gnus-newsgroup-name t)) - (let* ((article (if header (mail-header-number header) article)) + (let* ((gnus-article (if header (mail-header-number header) article)) (summary-buffer (current-buffer)) (internal-hook gnus-article-internal-prepare-hook) (group gnus-newsgroup-name) @@ -900,14 +1971,14 @@ If ALL-HEADERS is non-nil, no headers are hidden." "Return a string which display status of article washing." (save-excursion (set-buffer gnus-article-buffer) - (let ((cite (article-hidden-text-p 'cite)) - (headers (article-hidden-text-p 'headers)) - (boring (article-hidden-text-p 'boring-headers)) - (pgp (article-hidden-text-p 'pgp)) - (pem (article-hidden-text-p 'pem)) - (signature (article-hidden-text-p 'signature)) - (overstrike (article-hidden-text-p 'overstrike)) - (emphasis (article-hidden-text-p 'emphasis)) + (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)) (mime gnus-show-mime)) (format "%c%c%c%c%c%c%c" (if cite ?c ? ) @@ -927,56 +1998,6 @@ Provided for backwards compatibility." ;;; Article savers. -(defun gnus-output-to-rmail (file-name) - "Append the current article to an Rmail file named FILE-NAME." - (require 'rmail) - ;; Most of these codes are borrowed from rmailout.el. - (setq file-name (expand-file-name file-name)) - (setq rmail-default-rmail-file file-name) - (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *Gnus-output*"))) - (save-excursion - (or (get-file-buffer file-name) - (file-exists-p file-name) - (if (gnus-yes-or-no-p - (concat "\"" file-name "\" does not exist, create it? ")) - (let ((file-buffer (create-file-buffer file-name))) - (save-excursion - (set-buffer file-buffer) - (rmail-insert-rmail-file-header) - (let ((require-final-newline nil)) - (gnus-write-buffer file-name))) - (kill-buffer file-buffer)) - (error "Output file does not exist"))) - (set-buffer tmpbuf) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert-buffer-substring artbuf) - (gnus-convert-article-to-rmail) - ;; Decide whether to append to a file or to an Emacs buffer. - (let ((outbuf (get-file-buffer file-name))) - (if (not outbuf) - (append-to-file (point-min) (point-max) file-name) - ;; File has been visited, in buffer OUTBUF. - (set-buffer outbuf) - (let ((buffer-read-only nil) - (msg (and (boundp 'rmail-current-message) - (symbol-value 'rmail-current-message)))) - ;; If MSG is non-nil, buffer is in RMAIL mode. - (when msg - (widen) - (narrow-to-region (point-max) (point-max))) - (insert-buffer-substring tmpbuf) - (when msg - (goto-char (point-min)) - (widen) - (search-backward "\^_") - (narrow-to-region (point) (point-max)) - (goto-char (1+ (point-min))) - (rmail-count-new-messages t) - (rmail-show-message msg)))))) - (kill-buffer tmpbuf))) - (defun gnus-output-to-file (file-name) "Append the current article to a file named FILE-NAME." (let ((artbuf (current-buffer))) @@ -988,18 +2009,6 @@ Provided for backwards compatibility." (insert "\n") (append-to-file (point-min) (point-max) file-name)))) -(defun gnus-convert-article-to-rmail () - "Convert article in current buffer to Rmail message format." - (let ((buffer-read-only nil)) - ;; Convert article directly into Babyl format. - ;; Suggested by Rob Austein - (goto-char (point-min)) - (insert "\^L\n0, unseen,,\n*** EOOH ***\n") - (while (search-forward "\n\^_" nil t) ;single char - (replace-match "\n^_" t t)) ;2 chars: "^" and "_" - (goto-char (point-max)) - (insert "\^_"))) - (defun gnus-narrow-to-page (&optional arg) "Narrow the article buffer to a page. If given a numerical ARG, move forward ARG pages." @@ -1042,12 +2051,13 @@ If given a numerical ARG, move forward ARG pages." "Show the next page of the article." (interactive) (when (gnus-article-next-page) + (goto-char (point-min)) (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) (defun gnus-article-goto-prev-page () "Show the next page of the article." (interactive) - (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)) + (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) (gnus-article-prev-page nil))) (defun gnus-article-next-page (&optional lines) @@ -1092,8 +2102,10 @@ Argument LINES specifies lines to be scrolled down." (recenter -1)) (let ((scroll-in-place nil)) (prog1 - (ignore-errors - (scroll-down lines)) + (condition-case () + (scroll-down lines) + (beginning-of-buffer + (goto-char (point-min)))) (move-to-window-line 0))))) (defun gnus-article-refer-article () @@ -1156,8 +2168,9 @@ Argument LINES specifies lines to be scrolled down." keys) (save-excursion (set-buffer gnus-summary-buffer) - (push (or key last-command-event) unread-command-events) - (setq keys (read-key-sequence nil))) + (let (gnus-pick-mode) + (push (or key last-command-event) unread-command-events) + (setq keys (read-key-sequence nil)))) (message "") (if (or (member keys nosaves) @@ -1166,7 +2179,9 @@ Argument LINES specifies lines to be scrolled down." (let (func) (save-window-excursion (pop-to-buffer gnus-summary-buffer 'norecord) - (setq func (lookup-key (current-local-map) keys))) + ;; 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) @@ -1183,7 +2198,9 @@ Argument LINES specifies lines to be scrolled down." (pop-to-buffer gnus-summary-buffer 'norecord) (switch-to-buffer gnus-summary-buffer 'norecord)) (setq in-buffer (current-buffer)) - (if (setq func (lookup-key (current-local-map) keys)) + ;; We disable the pick minor mode commands. + (if (setq func (let (gnus-pick-mode) + (lookup-key (current-local-map) keys))) (call-interactively func) (ding)) (when (eq in-buffer (current-buffer)) @@ -1241,7 +2258,7 @@ If given a prefix, show the hidden text instead." (set-buffer gnus-summary-buffer) (let ((header (gnus-summary-article-header article))) (when (< article 0) - (cond + (cond ((memq article gnus-newsgroup-sparse) ;; This is a sparse gap article. (setq do-update-line article) @@ -1257,8 +2274,8 @@ If given a prefix, show the hidden text instead." ;; It is an extracted pseudo-article. (setq article 'pseudo) (gnus-request-pseudo-article header)))) - - (let ((method (gnus-find-method-for-group + + (let ((method (gnus-find-method-for-group gnus-newsgroup-name))) (if (not (eq (car method) 'nneething)) () @@ -1312,7 +2329,7 @@ If given a prefix, show the hidden text instead." (when (numberp article) (gnus-async-prefetch-next group article gnus-summary-buffer) (when gnus-keep-backlog - (gnus-backlog-enter-article + (gnus-backlog-enter-article group article (current-buffer)))) 'article))) ;; It was a pseudo. @@ -1336,7 +2353,7 @@ If given a prefix, show the hidden text instead." (erase-buffer) (insert-buffer-substring gnus-article-buffer)) (setq gnus-original-article (cons group article)))) - + ;; Update sparse articles. (when (and do-update-line (or (numberp article) @@ -1349,30 +2366,20 @@ If given a prefix, show the hidden text instead." (point)) (set-buffer buf)))))) -(defun gnus-article-date-ut (&optional type highlight) - "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." - (interactive (list 'ut t)) - (let ((headers (or gnus-current-headers (gnus-summary-article-header)))) - (save-excursion - (set-buffer gnus-article-buffer) - (article-date-ut type highlight headers)))) - ;;; ;;; Article editing ;;; (defcustom gnus-article-edit-mode-hook nil "Hook run in article edit mode buffers." - :group 'article + :group 'gnus-article-various :type 'hook) (defvar gnus-article-edit-done-function nil) (defvar gnus-article-edit-mode-map nil) -(unless gnus-article-edit-mode-map +(unless gnus-article-edit-mode-map (setq gnus-article-edit-mode-map (copy-keymap text-mode-map)) (gnus-define-keys gnus-article-edit-mode-map @@ -1455,10 +2462,10 @@ groups." (gnus-article-mode) ;; The cache and backlog have to be flushed somewhat. (when gnus-use-cache - (gnus-cache-update-article + (gnus-cache-update-article (car gnus-article-current) (cdr gnus-article-current))) (when gnus-keep-backlog - (gnus-backlog-remove-article + (gnus-backlog-remove-article (car gnus-article-current) (cdr gnus-article-current))) ;; Flush original article as well. (save-excursion @@ -1472,7 +2479,7 @@ groups." (set-window-start (get-buffer-window (current-buffer)) window-start) (goto-char p) (set-buffer buf))))) - + (defun gnus-article-edit-full-stops () "Interactively repair spacing at end of sentences." (interactive) @@ -1482,7 +2489,7 @@ groups." (let ((case-fold-search nil)) (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2")))) -;;; +;;; ;;; Article highlights ;;; @@ -1490,23 +2497,25 @@ groups." ;;; Internal Variables: -(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-\\wa-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]*[-\\wa-zA-Z0-9_=#$@~`%&*+|\\/]" +(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\\)" "Regular expression that matches URLs." - :group 'article + :group 'gnus-article-buttons :type 'regexp) -(defcustom gnus-button-alist - `(("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 +(defcustom gnus-button-alist + `(("<\\(url: ?\\)?news:\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t + gnus-button-message-id 2) + ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*+\\)" 0 t gnus-button-message-id 1) + ("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t + gnus-button-fetch-group 4) + ("\\bnews:\\(//\\)?\\([^>\n\t ]+\\)" 0 t gnus-button-fetch-group 2) + ("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 t gnus-button-message-id 3) - ("\\(\n\t ]*\\)>?\\)" 1 t - gnus-button-fetch-group 3) - ("\\(\n\t ]*\\)>?\\)" 1 t - gnus-button-message-id 3) - ("\\( \n\t]+\\)>?" 0 t gnus-url-mailto 2) + ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 1) + ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 2) ;; This is how URLs _should_ be embedded in text... - ("]*\\)>" 0 t gnus-button-url 1) - ;; Next regexp stolen from highlight-headers.el. - ;; Modified by Vladimir Alexiev. + ("]*\\)>" 0 t gnus-button-embedded-url 1) + ;; Raw URLs. (,gnus-button-url-regexp 0 t gnus-button-url 0)) "Alist of regexps matching buttons in article bodies. @@ -1514,14 +2523,14 @@ Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where REGEXP: is the string matching text around the button, BUTTON: is the number of the regexp grouping actually matching the button, FORM: is a lisp expression which must eval to true for the button to -be added, +be added, CALLBACK: is the function to call when the user push this button, and each PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. CALLBACK can also be a variable, in that case the value of that variable it the real callback function." - :group 'article - :type '(repeat (list regexp + :group 'gnus-article-buttons + :type '(repeat (list regexp (integer :tag "Button") (sexp :tag "Form") (function :tag "Callback") @@ -1529,11 +2538,11 @@ variable it the real callback function." :inline t (integer :tag "Regexp group"))))) -(defcustom gnus-header-button-alist +(defcustom gnus-header-button-alist `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>" 0 t gnus-button-message-id 0) ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) - ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" + ("^\\(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) ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) @@ -1548,9 +2557,10 @@ alist has an additional HEADER element first in each entry: HEADER is a regexp to match a header. For a fuller explanation, see `gnus-button-alist'." - :group 'article + :group 'gnus-article-buttons + :group 'gnus-article-headers :type '(repeat (list (regexp :tag "Header") - regexp + regexp (integer :tag "Button") (sexp :tag "Form") (function :tag "Callback") @@ -1626,7 +2636,7 @@ If N is negative, move backward instead." (defun gnus-article-highlight (&optional force) "Highlight current article. This function calls `gnus-article-highlight-headers', -`gnus-article-highlight-citation', +`gnus-article-highlight-citation', `gnus-article-highlight-signature', and `gnus-article-add-buttons' to do the highlighting. See the documentation for those functions." (interactive (list 'force)) @@ -1657,40 +2667,38 @@ 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) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (narrow-to-region (1- (point)) (point-min)) - (while (setq entry (pop alist)) - (goto-char (point-min)) - (setq regexp (concat "^\\(" - (if (string-equal "" (nth 0 entry)) - "[^\t ]" - (nth 0 entry)) - "\\)") - header-face (nth 1 entry) - field-face (nth 2 entry)) - (while (and (re-search-forward regexp nil t) - (not (eobp))) - (beginning-of-line) - (setq from (point)) - (unless (search-forward ":" nil t) - (forward-char 1)) - (when (and header-face - (not (memq (point) hpoints))) - (push (point) hpoints) - (gnus-put-text-property from (point) 'face header-face)) - (when (and field-face - (not (memq (setq from (point)) fpoints))) - (push from fpoints) - (if (re-search-forward "^[^ \t]" nil t) - (forward-char -2) - (goto-char (point-max))) - (gnus-put-text-property from (point) 'face field-face))))))))) + (message-narrow-to-head) + (while (setq entry (pop alist)) + (goto-char (point-min)) + (setq regexp (concat "^\\(" + (if (string-equal "" (nth 0 entry)) + "[^\t ]" + (nth 0 entry)) + "\\)") + header-face (nth 1 entry) + field-face (nth 2 entry)) + (while (and (re-search-forward regexp nil t) + (not (eobp))) + (beginning-of-line) + (setq from (point)) + (unless (search-forward ":" nil t) + (forward-char 1)) + (when (and header-face + (not (memq (point) hpoints))) + (push (point) hpoints) + (gnus-put-text-property from (point) 'face header-face)) + (when (and field-face + (not (memq (setq from (point)) fpoints))) + (push from fpoints) + (if (re-search-forward "^[^ \t]" nil t) + (forward-char -2) + (goto-char (point-max))) + (gnus-put-text-property from (point) 'face field-face)))))))) (defun gnus-article-highlight-signature () "Highlight the signature in an article. It does this by highlighting everything after -`gnus-signature-separator' using `gnus-signature-face'." +`gnus-signature-separator' using `gnus-signature-face'." (interactive) (save-excursion (set-buffer gnus-article-buffer) @@ -1698,16 +2706,20 @@ It does this by highlighting everything after (inhibit-point-motion-hooks t)) (save-restriction (when (and gnus-signature-face - (article-narrow-to-signature)) + (gnus-article-narrow-to-signature)) (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) 'face gnus-signature-face) (widen) - (article-search-signature) + (gnus-article-search-signature) (let ((start (match-beginning 0)) (end (set-marker (make-marker) (1+ (match-end 0))))) (gnus-article-add-button start (1- end) 'gnus-signature-toggle end))))))) +(defun gnus-button-in-region-p (b e prop) + "Say whether PROP exists in the region." + (text-property-not-all b e prop nil)) + (defun gnus-article-add-buttons (&optional force) "Find external references in the article and make buttons of them. \"External references\" are things like Message-IDs and URLs, as @@ -1715,16 +2727,22 @@ specified by `gnus-button-alist'." (interactive (list 'force)) (save-excursion (set-buffer gnus-article-buffer) - ;; Remove all old markers. - (while gnus-button-marker-list - (set-marker (pop gnus-button-marker-list) nil)) (let ((buffer-read-only nil) (inhibit-point-motion-hooks t) (case-fold-search t) (alist gnus-button-alist) beg entry regexp) - (goto-char (point-min)) + ;; Remove all old markers. + (let (marker entry) + (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))) ;; We skip the headers. + (goto-char (point-min)) (unless (search-forward "\n\n" nil t) (goto-char (point-max))) (setq beg (point)) @@ -1735,12 +2753,14 @@ specified by `gnus-button-alist'." (let* ((start (and entry (match-beginning (nth 1 entry)))) (end (and entry (match-end (nth 1 entry)))) (from (match-beginning 0))) - (when (or (eq t (nth 1 entry)) - (eval (nth 1 entry))) + (when (and (or (eq t (nth 1 entry)) + (eval (nth 1 entry))) + (not (gnus-button-in-region-p + start end 'gnus-callback))) ;; That optional form returned non-nil, so we add the - ;; button. - (gnus-article-add-button - start end 'gnus-button-push + ;; button. + (gnus-article-add-button + start end 'gnus-button-push (car (push (set-marker (make-marker) from) gnus-button-marker-list)))))))))) @@ -1776,7 +2796,7 @@ specified by `gnus-button-alist'." (form (nth 2 entry))) (goto-char (match-end 0)) (when (eval form) - (gnus-article-add-button + (gnus-article-add-button start end (nth 3 entry) (buffer-substring (match-beginning (nth 4 entry)) (match-end (nth 4 entry))))))) @@ -1790,7 +2810,7 @@ specified by `gnus-button-alist'." (when gnus-article-button-face (gnus-overlay-put (gnus-make-overlay from to) 'face gnus-article-button-face)) - (gnus-add-text-properties + (gnus-add-text-properties from to (nconc (and gnus-article-mouse-face (list gnus-mouse-face-prop gnus-article-mouse-face)) @@ -1805,8 +2825,8 @@ specified by `gnus-button-alist'." (let ((buffer-read-only nil) (inhibit-point-motion-hooks t)) (if (get-text-property end 'invisible) - (article-unhide-text end (point-max)) - (article-hide-text end (point-max) gnus-hidden-properties))))) + (gnus-article-unhide-text end (point-max)) + (gnus-article-hide-text end (point-max) gnus-hidden-properties))))) (defun gnus-button-entry () ;; Return the first entry in `gnus-button-alist' matching this place. @@ -1828,9 +2848,7 @@ specified by `gnus-button-alist'." (inhibit-point-motion-hooks t) (fun (nth 3 entry)) (args (mapcar (lambda (group) - (let ((string (buffer-substring - (match-beginning group) - (match-end group)))) + (let ((string (match-string group))) (gnus-set-text-properties 0 (length string) nil string) string)) @@ -1853,14 +2871,19 @@ specified by `gnus-button-alist'." (defun gnus-button-fetch-group (address) "Fetch GROUP specified by ADDRESS." - (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\(.*\\)$" address)) - (error "Can't parse %s" address) - (gnus-group-read-ephemeral-group - (match-string 4 address) - `(nntp ,(match-string 1 address) (nntp-address ,(match-string 1 address)) - (nntp-port-number ,(if (match-end 3) - (match-string 3 address) - "nntp")))))) + (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)) + (error "Can't parse %s" address) + (gnus-group-read-ephemeral-group + (match-string 4 address) + `(nntp ,(match-string 1 address) + (nntp-address ,(match-string 1 address)) + (nntp-port-number ,(if (match-end 3) + (match-string 3 address) + "nntp"))))))) (defun gnus-split-string (string pattern) "Return a list of substrings of STRING which are separated by PATTERN." @@ -1869,7 +2892,7 @@ specified by `gnus-button-alist'." (setq parts (cons (substring string start (match-beginning 0)) parts) start (match-end 0))) (nreverse (cons (substring string start) parts)))) - + (defun gnus-url-parse-query-string (query &optional downcase) (let (retval pairs cur key val) (setq pairs (gnus-split-string query "&")) @@ -1887,14 +2910,14 @@ specified by `gnus-button-alist'." (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 @@ -1908,7 +2931,7 @@ forbidden in URL encoding." (ch1 (gnus-url-unhex (elt str (+ start 1)))) (code (+ (* 16 ch1) (gnus-url-unhex (elt str (+ start 2)))))) - (setq tmp (concat + (setq tmp (concat tmp (substring str 0 start) (cond (allow-newlines @@ -1919,12 +2942,11 @@ forbidden in URL encoding." str (substring str (match-end 0))))) (setq tmp (concat tmp str)) tmp)) - + (defun gnus-url-mailto (url) ;; Send mail to someone - (if (not (string-match "mailto:/*\\(.*\\)" url)) - (error "Malformed mailto link: %s" url)) - (setq url (substring url (match-beginning 1) nil)) + (when (string-match "mailto:/*\\(.*\\)" url) + (setq url (substring url (match-beginning 1) nil))) (let (to args source-url subject func) (if (string-match (regexp-quote "?") url) (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) @@ -1958,6 +2980,10 @@ forbidden in URL encoding." "Browse ADDRESS." (funcall browse-url-browser-function address)) +(defun gnus-button-embedded-url (address) + "Browse ADDRESS." + (funcall browse-url-browser-function (gnus-strip-whitespace address))) + ;;; Next/prev buttons in the article buffer. (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") @@ -1971,7 +2997,7 @@ forbidden in URL encoding." (defun gnus-insert-prev-page-button () (let ((buffer-read-only nil)) - (gnus-eval-format + (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)))) @@ -2003,7 +3029,7 @@ forbidden in URL encoding." (let ((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-callback gnus-article-button-next-page)))) (defun gnus-article-button-next-page (arg) @@ -2020,7 +3046,9 @@ forbidden in URL encoding." (let ((win (selected-window))) (select-window (get-buffer-window gnus-article-buffer t)) (gnus-article-prev-page) - (select-window win))) + (select-window win))) + +(gnus-ems-redefine) (provide 'gnus-art)