X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=c893544b04cc97ace2cf955facde2d344e042a58;hb=851278bf56a0156a4dd5896e9959f63e33d07ee2;hp=aa041aab069096c0d585c669dba586480a597546;hpb=2b20527a87e8e056ed22892bd6e0d249424a0403;p=gnus diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index aa041aab0..c893544b0 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,6 +1,6 @@ ;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996-2014 Free Software Foundation, Inc. +;; Copyright (C) 1996-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -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." @@ -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) @@ -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 @@ -1140,7 +1139,7 @@ predicate. See Info node `(gnus)Customizing Articles'." :type gnus-article-treat-custom) (put 'gnus-treat-highlight-signature 'highlight t) -(defcustom gnus-treat-buttonize 100000 +(defcustom gnus-treat-buttonize '(and 100000 (typep "text/plain")) "Add buttons. Valid values are nil, t, `head', `first', `last', an integer or a predicate. See Info node `(gnus)Customizing Articles'." @@ -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))) @@ -2795,9 +2787,9 @@ summary buffer." (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 file name." +Return file name relative to the parent of DIRECTORY." (save-match-data - (let (file) + (let (file afile) (catch 'found (dolist (handle handles) (cond @@ -2810,16 +2802,16 @@ Return file name." cid handle directory)) (throw 'found file))) ((equal (concat "<" cid ">") (mm-handle-id handle)) - (setq file - (expand-file-name - (or (mm-handle-filename handle) - (concat - (make-temp-name "cid") - (car (rassoc (car (mm-handle-type handle)) - mailcap-mime-extensions)))) - directory)) - (mm-save-part-to-file handle file) - (throw 'found file)))))))) + (setq file (or (mm-handle-filename handle) + (concat + (make-temp-name "cid") + (car (rassoc (car (mm-handle-type handle)) + mailcap-mime-extensions)))) + afile (expand-file-name file directory)) + (mm-save-part-to-file handle afile) + (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. @@ -2855,8 +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) - cid-file) + st base regexp cid-file) (goto-char (point-min)) + (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) @@ -2871,16 +2887,7 @@ message header will be added to the bodies of the \"text/html\" parts." (with-current-buffer gnus-article-buffer gnus-article-mime-handles) cid-dir)) - (when (eq system-type 'cygwin) - (setq cid-file - (concat "/" (substring - (with-output-to-string - (call-process "cygpath" nil - standard-output - nil "-m" cid-file)) - 0 -1)))) - (replace-match (concat "file://" cid-file) - nil nil nil 1)))) + (replace-match cid-file nil nil nil 1)))) (unless content (setq content (buffer-string)))) (when (or charset header (not file)) (setq tmp-file (mm-make-temp-file @@ -5055,6 +5062,7 @@ and `gnus-mime-delete-part', and not provided at run-time normally." (let ((gnus-mime-buttonized-part-id current-id)) (gnus-article-edit-done)) (gnus-configure-windows 'article) + (sit-for 0) (when (and current-id (integerp gnus-auto-select-part)) (gnus-article-jump-to-part (min (max (+ current-id gnus-auto-select-part) 1) @@ -5350,7 +5358,10 @@ Compressed files like .gz and .bz2 are decompressed." 'gnus-data)))) (setq b btn)) (if (and (not arg) (mm-handle-undisplayer handle)) - (mm-remove-part handle) + (progn + (setq b (copy-marker b) + btn (copy-marker btn)) + (mm-remove-part handle)) (cond ((not arg) nil) ((numberp arg) @@ -5364,6 +5375,9 @@ Compressed files like .gz and .bz2 are decompressed." (forward-line 1)) (mm-display-inline handle)) ;; Toggle the button appearance between `[button]...' and `[button]'. + (when (markerp btn) + (setq btn (prog1 (marker-position btn) + (set-marker btn nil)))) (goto-char btn) (let ((displayed-p (mm-handle-displayed-p handle))) (gnus-insert-mime-button handle (get-text-property btn 'gnus-part) @@ -5390,15 +5404,18 @@ 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 '((gnus-treat-highlight-headers gnus-article-highlight-headers)))) (gnus-treat-article 'head))))) + (when (markerp b) + (setq b (prog1 (marker-position b) + (set-marker b nil)))) (goto-char b)))) (defun gnus-mime-set-charset-parameters (handle charset) @@ -5496,7 +5513,8 @@ If no internal viewer is available, use an external viewer." (gnus-mime-view-part-as-type nil (lambda (type) (mm-inlinable-p handle type))) (when handle - (gnus-bind-safe-url-regexp (mm-display-part handle)))))) + (gnus-bind-safe-url-regexp + (mm-display-part handle nil t)))))) (defun gnus-mime-action-on-part (&optional action) "Do something with the MIME attachment at \(point\)." @@ -5720,7 +5738,8 @@ all parts." point (previous-single-property-change start 'gnus-data)) (if (mm-handle-displayed-p handle) ;; This will remove the part. - (setq retval (mm-display-part handle)) + (setq point (copy-marker point) + retval (mm-display-part handle)) (let ((part (or (and (mm-inlinable-p handle) (mm-inlined-p handle) t) @@ -5751,6 +5770,9 @@ all parts." ,(point-max-marker))))))) (part (mm-display-inline handle)))))) + (when (markerp point) + (setq point (prog1 (marker-position point) + (set-marker point nil)))) (goto-char point) ;; Toggle the button appearance between `[button]...' and `[button]'. (let ((displayed-p (mm-handle-displayed-p handle))) @@ -5777,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 @@ -5868,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 @@ -6091,7 +6113,7 @@ If nil, don't show those extra buttons." (gnus-article-insert-newline) (if (prog1 (= (skip-chars-backward "\n") -1) - (forward-char 1)) + (unless (eobp) (forward-char 1))) (gnus-article-insert-newline) (put-text-property (point) (point-max) 'gnus-undeletable t)) (goto-char (point-max))) @@ -6422,8 +6444,7 @@ in the body. Use `gnus-header-face-alist' to highlight buttons." (dolist (button (nreverse buttons)) (setq st (point)) (insert " ") - (mm-handle-set-undisplayer - (setq handle (copy-sequence (cdr button))) nil) + (mm-handle-set-undisplayer (setq handle (cdr button)) nil) (gnus-insert-mime-button handle (car button)) (skip-chars-backward "\t\n ") (delete-region (point) (point-max)) @@ -6432,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)))) @@ -6851,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)))) @@ -6873,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))) @@ -7007,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." @@ -7187,6 +7211,8 @@ If given a prefix, show the hidden text instead." (set-buffer buf)))))) (defun gnus-block-private-groups (group) + "Allows images in newsgroups to be shown, blocks images in all +other groups." (if (or (gnus-news-group-p group) (gnus-member-of-valid 'global group)) ;; Block nothing in news groups. @@ -7806,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) @@ -7820,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) @@ -8012,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)) @@ -8111,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)))) @@ -8155,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 @@ -8495,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 @@ -8531,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 @@ -8927,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