X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=2821f5f480697730a588bdc301cebe2b8fccb297;hp=1362f1dd46030ca5237af102eb5f249e04d41295;hb=2c102003004f4fa3dd5fe1f56c66936f386c4359;hpb=c98bf5f1ee6c9644e95db2b49d4c04a76398b863 diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 1362f1dd4..2821f5f48 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -51,6 +51,7 @@ (autoload 'ansi-color-apply-on-region "ansi-color") (autoload 'mm-url-insert-file-contents-external "mm-url") (autoload 'mm-extern-cache-contents "mm-extern") +(autoload 'url-expand-file-name "url-expand") (defgroup gnus-article nil "Article display." @@ -195,16 +196,16 @@ this list." "Headers that are only to be displayed if they have interesting data. Possible values in this list are: - 'empty Headers with no content. - 'newsgroups Newsgroup identical to Gnus group. - 'to-address To identical to To-address. - 'to-list To identical to To-list. - 'cc-list CC identical to To-list. - 'followup-to Followup-to identical to Newsgroups. - 'reply-to Reply-to identical to From. - 'date Date less than four days old. - 'long-to To and/or Cc longer than 1024 characters. - 'many-to Multiple To and/or Cc." + `empty' Headers with no content. + `newsgroups' Newsgroup identical to Gnus group. + `to-address' To identical to To-address. + `to-list' To identical to To-list. + `cc-list' CC identical to To-list. + `followup-to' Followup-to identical to Newsgroups. + `reply-to' Reply-to identical to From. + `date' Date less than four days old. + `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 identical to Gnus group." newsgroups) (const :tag "To identical to To-address." to-address) @@ -255,12 +256,10 @@ This can also be a list of the above values." :group 'gnus-article-signature) (defcustom gnus-hidden-properties - (if (featurep 'xemacs) - ;; `intangible' is evil, but I keep it here in case it's useful. - '(invisible t intangible t) - ;; Emacs's command loop moves point out of invisible text anyway, so - ;; `intangible' is clearly not needed there. - '(invisible t)) + ;; We use to have `intangible' here as well, but Emacs's command loop moves + ;; point out of invisible text anyway, so `intangible' is clearly not + ;; needed there. And XEmacs doesn't handle `intangible' anyway. + '(invisible t) "Property list to use for hiding text." :type 'sexp :group 'gnus-article-hiding) @@ -332,7 +331,7 @@ to match a mail address in the From: header, BANNER is one of a symbol If ADDRESS matches author's mail address, it will remove things like advertisements. For example: -\((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\")) +\((\"@yoo-hoo\\\\.co\\\\.jp\\\\\\='\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\")) " :type '(repeat (cons @@ -401,7 +400,7 @@ advertisements. For example: "*Alist that says how to fontify certain phrases. Each item looks like this: - (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) + (\"_\\\\(\\\\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 @@ -663,7 +662,7 @@ For instance, if you would like to save articles related to Gnus in the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", you could set this variable to something like: - '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\") + ((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\") (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\")) This variable is an alist where the key is the match and the @@ -888,12 +887,12 @@ Here are examples: ;; Specify the altitude of Face images in the From header. \(setq gnus-face-properties-alist - '((pbm . (:face gnus-x-face :ascent 80)) + \\='((pbm . (:face gnus-x-face :ascent 80)) (png . (:ascent 80)))) ;; Show Face images as pressed buttons. \(setq gnus-face-properties-alist - '((pbm . (:face gnus-x-face :relief -2)) + \\='((pbm . (:face gnus-x-face :relief -2)) (png . (:relief -2)))) See the manual for the valid properties for various image types. @@ -1258,7 +1257,7 @@ how to control what it hides." :type gnus-article-treat-custom) (defcustom gnus-treat-strip-list-identifiers 'head - "Strip list identifiers from `gnus-list-identifiers`. + "Strip list identifiers from `gnus-list-identifiers'. Valid values are nil, t, `head', `first', `last', an integer or a predicate. See Info node `(gnus)Customizing Articles'." :version "21.1" @@ -1629,8 +1628,11 @@ It is a string, such as \"PGP\". If nil, ask user." (defvar idna-program) -(defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error)) - (mm-coding-system-p 'utf-8) +(defcustom gnus-use-idna (and (mm-coding-system-p 'utf-8) + (condition-case nil + (require 'idna) + (file-error) + (invalid-operation)) idna-program (executable-find idna-program)) "Whether IDNA decoding of headers is used when viewing messages. @@ -1734,7 +1736,7 @@ regexp." (modify-syntax-entry ?` " " table) table) "Syntax table used in article mode buffers. -Initialized from `text-mode-syntax-table.") +Initialized from `text-mode-syntax-table'.") (defvar gnus-save-article-buffer nil) @@ -1772,19 +1774,12 @@ Initialized from `text-mode-syntax-table.") (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." - (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))))) + "Set text PROPS on the B to E region." + (gnus-add-text-properties-when 'article-type nil b e 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))) + (remove-text-properties b e gnus-hidden-properties)) (defun gnus-article-hide-text-type (b e type) "Hide text of TYPE between B and E." @@ -1796,10 +1791,7 @@ Initialized from `text-mode-syntax-table.") "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) - (put-text-property (max (1- b) (point-min)) - b 'intangible nil))) + b e (cons 'article-type (cons type gnus-hidden-properties)))) (defun gnus-article-delete-text-of-type (type) "Delete text of TYPE in the current buffer." @@ -2329,7 +2321,7 @@ long lines if and only if arg is positive." (goto-char (point-max)) (let ((start (point))) (insert "X-Boundary: ") - (gnus-add-text-properties start (point) '(invisible t intangible t)) + (gnus-add-text-properties start (point) gnus-hidden-properties) (insert (let (str (max (window-width))) (if (featurep 'xemacs) (setq max (1- max))) @@ -2437,7 +2429,7 @@ long lines if and only if arg is positive." (unless (setq from (gnus-article-goto-header "from")) (insert "From:") (setq from (point)) - (insert " [no `from' set]\n")) + (insert " [no 'from' set]\n")) (while faces (when (setq png (gnus-convert-face-to-png (pop faces))) (setq image @@ -2779,7 +2771,7 @@ summary buffer." (cond ((file-directory-p file) (when (or (not (eq how 'file)) (gnus-y-or-n-p - (format + (gnus-format-message "Delete temporary HTML file(s) in directory `%s'? " (file-name-as-directory file)))) (gnus-delete-directory file))) @@ -2793,10 +2785,9 @@ summary buffer." (setq gnus-article-browse-html-temp-list nil)) gnus-article-browse-html-temp-list) -(defun gnus-article-browse-html-save-cid-content (cid handles directory abs) +(defun gnus-article-browse-html-save-cid-content (cid handles directory) "Find CID content in HANDLES and save it in a file in DIRECTORY. -Return absolute file name if ABS is non-nil, otherwise relative to -the parent of DIRECTORY." +Return file name relative to the parent of DIRECTORY." (save-match-data (let (file afile) (catch 'found @@ -2808,7 +2799,7 @@ the parent of DIRECTORY." ((not (or (bufferp (car handle)) (stringp (car handle))))) ((equal (mm-handle-media-supertype handle) "multipart") (when (setq file (gnus-article-browse-html-save-cid-content - cid handle directory abs)) + cid handle directory)) (throw 'found file))) ((equal (concat "<" cid ">") (mm-handle-id handle)) (setq file (or (mm-handle-filename handle) @@ -2818,11 +2809,9 @@ the parent of DIRECTORY." mailcap-mime-extensions)))) afile (expand-file-name file directory)) (mm-save-part-to-file handle afile) - (throw 'found (if abs - afile - (concat (file-name-nondirectory - (directory-file-name directory)) - "/" file)))))))))) + (throw 'found (concat (file-name-nondirectory + (directory-file-name directory)) + "/" file))))))))) (defun gnus-article-browse-html-parts (list &optional header) "View all \"text/html\" parts from LIST. @@ -2858,13 +2847,32 @@ message header will be added to the bodies of the \"text/html\" parts." (insert content) ;; resolve cid contents (let ((case-fold-search t) - abs st cid-file) + st base regexp cid-file) (goto-char (point-min)) - (when (re-search-forward "]" nil t) - (setq st (match-end 0) - abs (or - (not (re-search-forward "]" nil t)) - (re-search-backward "]" st t)))) + (when (and (re-search-forward "]" nil t) + (progn + (setq st (match-end 0)) + (re-search-forward "]" nil t)) + (re-search-backward "]+\\)*[\t\n ]+href=\"\\([^\"]+\\)\"[^>]*>" st t)) + (setq base (match-string 1)) + (replace-match "") + (setq st (point)) + (dolist (tag '(("a" . "href") ("form" . "action") + ("img" . "src"))) + (setq regexp (concat "<" (car tag) + "\\(?:[\t\n ]+[^\t\n >]+\\)*[\t\n ]+" + (cdr tag) "=\"\\([^\"]+\\)")) + (while (re-search-forward regexp nil t) + (insert (prog1 + (condition-case nil + (save-match-data + (url-expand-file-name (match-string 1) + base)) + (error (match-string 1))) + (delete-region (match-beginning 1) + (match-end 1))))) + (goto-char st))) (while (re-search-forward "\ ]+[\t\n ]+\\)*src=\"\\(cid:\\([^\"]+\\)\\)\"" nil t) @@ -2878,18 +2886,7 @@ message header will be added to the bodies of the \"text/html\" parts." (match-string 2) (with-current-buffer gnus-article-buffer gnus-article-mime-handles) - cid-dir abs)) - (when abs - (setq cid-file - (if (eq system-type 'cygwin) - (concat "file:///" - (substring - (with-output-to-string - (call-process "cygpath" nil - standard-output - nil "-m" cid-file)) - 0 -1)) - (concat "file://" cid-file)))) + cid-dir)) (replace-match cid-file nil nil nil 1)))) (unless content (setq content (buffer-string)))) (when (or charset header (not file)) @@ -5407,9 +5404,9 @@ Compressed files like .gz and .bz2 are decompressed." 'gnus-undeletable t)))) ;; We're in the article header. (delete-char -1) - (dolist (ovl (gnus-overlays-in btn (point))) - (gnus-overlay-put ovl 'gnus-button-attachment-extra t) - (gnus-overlay-put ovl 'face nil)) + (dolist (ovl (overlays-in btn (point))) + (overlay-put ovl 'gnus-button-attachment-extra t) + (overlay-put ovl 'face nil)) (save-restriction (message-narrow-to-field) (let ((gnus-treatment-function-alist @@ -5802,9 +5799,9 @@ all parts." 'gnus-undeletable t)))) ;; We're in the article header. (delete-char -1) - (dolist (ovl (gnus-overlays-in point (point))) - (gnus-overlay-put ovl 'gnus-button-attachment-extra t) - (gnus-overlay-put ovl 'face nil)) + (dolist (ovl (overlays-in point (point))) + (overlay-put ovl 'gnus-button-attachment-extra t) + (overlay-put ovl 'face nil)) (save-restriction (message-narrow-to-field) (let ((gnus-treatment-function-alist @@ -5893,8 +5890,8 @@ all parts." (1- (point)) (point))) (when gnus-article-button-face - (gnus-overlay-put (gnus-make-overlay b e nil t) - 'face gnus-article-button-face)) + (overlay-put (make-overlay b e nil t) + 'face gnus-article-button-face)) (widget-convert-button 'link b e :mime-handle handle @@ -6456,9 +6453,9 @@ in the body. Use `gnus-header-face-alist' to highlight buttons." (insert "\n") (end-of-line))) (insert "\n") - (dolist (ovl (gnus-overlays-in (point-min) (point))) - (gnus-overlay-put ovl 'gnus-button-attachment-extra t) - (gnus-overlay-put ovl 'face nil)) + (dolist (ovl (overlays-in (point-min) (point))) + (overlay-put ovl 'gnus-button-attachment-extra t) + (overlay-put ovl 'face nil)) (let ((gnus-treatment-function-alist '((gnus-treat-highlight-headers gnus-article-highlight-headers)))) @@ -6875,11 +6872,13 @@ KEY is a string or a vector." (with-current-buffer gnus-article-current-summary (setq unread-command-events (if (featurep 'xemacs) - (append key nil) - (mapcar (lambda (x) (if (and (integerp x) (>= x 128)) - (list 'meta (- x 128)) - x)) - key))) + (append key unread-command-events) + (nconc + (mapcar (lambda (x) (if (and (integerp x) (>= x 128)) + (list 'meta (- x 128)) + x)) + key) + unread-command-events))) (let ((cursor-in-echo-area t) gnus-pick-mode) (describe-key (read-key-sequence nil t)))) @@ -6897,11 +6896,13 @@ KEY is a string or a vector." (with-current-buffer gnus-article-current-summary (setq unread-command-events (if (featurep 'xemacs) - (append key nil) - (mapcar (lambda (x) (if (and (integerp x) (>= x 128)) - (list 'meta (- x 128)) - x)) - key))) + (append key unread-command-events) + (nconc + (mapcar (lambda (x) (if (and (integerp x) (>= x 128)) + (list 'meta (- x 128)) + x)) + key) + unread-command-events))) (let ((cursor-in-echo-area t) gnus-pick-mode) (describe-key-briefly (read-key-sequence nil t) insert))) @@ -7031,8 +7032,7 @@ 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")) +(declare-function nneething-get-file-name "nneething" (id)) (defun gnus-request-article-this-buffer (article group) "Get an article and insert it into this buffer." @@ -7832,11 +7832,11 @@ positives are possible." ("/\\([a-z][-a-z0-9]+\\.el\\)\\>[^.?]" ;; Exclude [.?] for URLs in gmane.emacs.cvs 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) - ("`\\([a-z][-a-z0-9]+\\.el\\)'" + ("['`‘]\\([a-z][-a-z0-9]+\\.el\\)['’]" 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) - ("`\\([a-z][a-z0-9]+-[a-z0-9]+-[-a-z0-9]*[a-z]\\|\\(gnus\\|message\\)-[-a-z]+\\)'" + ("['`‘]\\([a-z][a-z0-9]+-[a-z0-9]+-[-a-z0-9]*[a-z]\\|\\(gnus\\|message\\)-[-a-z]+\\)['’]" 0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1) - ("`\\([a-z][a-z0-9]+-[a-z]+\\)'" + ("['`‘]\\([a-z][a-z0-9]+-[a-z]+\\)['’]" 0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1) ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)" 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1) @@ -7846,7 +7846,7 @@ positives are possible." 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2) ("\\b\\(C-h\\|?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2) - ("`\\(\\(C-h\\|?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'" + ("['`‘]\\(\\(C-h\\|?\\)[ \t\n]+k[ \t\n]+\\([^'’]+\\)\\)['’]" ;; Unlike the other regexps we really have to require quoting ;; here to determine where it ends. 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3) @@ -8038,8 +8038,8 @@ It does this by highlighting everything after (save-restriction (when (and gnus-signature-face (gnus-article-narrow-to-signature)) - (gnus-overlay-put (gnus-make-overlay (point-min) (point-max) nil t) - 'face gnus-signature-face) + (overlay-put (make-overlay (point-min) (point-max) nil t) + 'face gnus-signature-face) (widen) (gnus-article-search-signature) (let ((start (match-beginning 0)) @@ -8137,12 +8137,12 @@ url is put as the `gnus-button-url' overlay property on the button." 'gnus-button-push (list beg (assq 'gnus-button-url-regexp gnus-button-alist))))) - (let ((overlay (gnus-make-overlay start end))) - (gnus-overlay-put overlay 'evaporate t) - (gnus-overlay-put overlay 'gnus-button-url - (list (mapconcat 'identity (nreverse url) ""))) + (let ((overlay (make-overlay start end))) + (overlay-put overlay 'evaporate t) + (overlay-put overlay 'gnus-button-url + (list (mapconcat 'identity (nreverse url) ""))) (when gnus-article-mouse-face - (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face))) + (overlay-put overlay 'mouse-face gnus-article-mouse-face))) t) (goto-char opoint)))) @@ -8181,8 +8181,8 @@ url is put as the `gnus-button-url' overlay property on the button." (defun gnus-article-add-button (from to fun &optional data text) "Create a button between FROM and TO with callback FUN and data DATA." (when gnus-article-button-face - (gnus-overlay-put (gnus-make-overlay from to nil t) - 'face gnus-article-button-face)) + (overlay-put (make-overlay from to nil t) + 'face gnus-article-button-face)) (gnus-add-text-properties from to (nconc (and gnus-article-mouse-face @@ -8521,8 +8521,8 @@ url is put as the `gnus-button-url' overlay property on the button." (1- (point)) (point))) (when gnus-article-button-face - (gnus-overlay-put (gnus-make-overlay b e nil t) - 'face gnus-article-button-face)) + (overlay-put (make-overlay b e nil t) + 'face gnus-article-button-face)) (widget-convert-button 'link b e :action 'gnus-button-prev-page @@ -8557,8 +8557,8 @@ url is put as the `gnus-button-url' overlay property on the button." (1- (point)) (point))) (when gnus-article-button-face - (gnus-overlay-put (gnus-make-overlay b e nil t) - 'face gnus-article-button-face)) + (overlay-put (make-overlay b e nil t) + 'face gnus-article-button-face)) (widget-convert-button 'link b e :action 'gnus-button-next-page @@ -8953,8 +8953,8 @@ For example: (1- (point)) (point))) (when gnus-article-button-face - (gnus-overlay-put (gnus-make-overlay b e nil t) - 'face gnus-article-button-face)) + (overlay-put (make-overlay b e nil t) + 'face gnus-article-button-face)) (widget-convert-button 'link b e :mime-handle handle