Mercurial > emacs

comparison lisp/gnus/gnus-art.el @ 91239:2fcaae6177a5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge from emacs--devo--0 Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-300
author Miles Bader <miles@gnu.org>
date Sun, 16 Dec 2007 05:08:49 +0000
parents 53108e6cea98 b968c7f9a8b4
children 56a72e2bd635
comparison
equal deleted inserted replaced
91238:5cf14a2107b5 91239:2fcaae6177a5
25 25
26 ;;; Commentary: 26 ;;; Commentary:
27 27
28 ;;; Code: 28 ;;; Code:
29 29
30 ;; For Emacs < 22.2.
31 (eval-and-compile
32 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
30 (eval-when-compile 33 (eval-when-compile
31 (require 'cl)) 34 (require 'cl))
32 (defvar tool-bar-map) 35 (defvar tool-bar-map)
33 (defvar w3m-minor-mode-map) 36 (defvar w3m-minor-mode-map)
34 37
2703 ((functionp func) 2706 ((functionp func)
2704 (funcall func)) 2707 (funcall func))
2705 (t 2708 (t
2706 (apply (car func) (cdr func)))))))))) 2709 (apply (car func) (cdr func))))))))))
2707 2710
2711 ;; External.
2712 (declare-function w3-region "ext:w3-display" (st nd))
2713
2708 (defun gnus-article-wash-html-with-w3 () 2714 (defun gnus-article-wash-html-with-w3 ()
2709 "Wash the current buffer with w3." 2715 "Wash the current buffer with w3."
2710 (mm-setup-w3) 2716 (mm-setup-w3)
2711 (let ((w3-strict-width (window-width)) 2717 (let ((w3-strict-width (window-width))
2712 (url-standalone-mode t) 2718 (url-standalone-mode t)
2713 (url-gateway-unplugged t) 2719 (url-gateway-unplugged t)
2714 (w3-honor-stylesheets nil)) 2720 (w3-honor-stylesheets nil))
2715 (condition-case () 2721 (condition-case ()
2716 (w3-region (point-min) (point-max)) 2722 (w3-region (point-min) (point-max))
2717 (error)))) 2723 (error))))
2724
2725 ;; External.
2726 (declare-function w3m-region "ext:w3m" (start end &optional url charset))
2718 2727
2719 (defun gnus-article-wash-html-with-w3m () 2728 (defun gnus-article-wash-html-with-w3m ()
2720 "Wash the current buffer with emacs-w3m." 2729 "Wash the current buffer with emacs-w3m."
2721 (mm-setup-w3m) 2730 (mm-setup-w3m)
2722 (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) 2731 (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
2771 "Delete temp-files created by `gnus-article-browse-html-parts'." 2780 "Delete temp-files created by `gnus-article-browse-html-parts'."
2772 (when (and gnus-article-browse-html-temp-list 2781 (when (and gnus-article-browse-html-temp-list
2773 (or how 2782 (or how
2774 (setq how gnus-article-browse-delete-temp))) 2783 (setq how gnus-article-browse-delete-temp)))
2775 (when (and (eq how 'ask) 2784 (when (and (eq how 'ask)
2776 (y-or-n-p (format 2785 (gnus-y-or-n-p (format
2777 "Delete all %s temporary HTML file(s)? " 2786 "Delete all %s temporary HTML file(s)? "
2778 (length gnus-article-browse-html-temp-list))) 2787 (length gnus-article-browse-html-temp-list)))
2779 (setq how t))) 2788 (setq how t)))
2780 (dolist (file gnus-article-browse-html-temp-list) 2789 (dolist (file gnus-article-browse-html-temp-list)
2781 (when (and (file-exists-p file) 2790 (when (and (file-exists-p file)
2782 (or (eq how t) 2791 (or (eq how t)
2783 ;; `how' is neither `nil', `ask' nor `t' (i.e. `file'): 2792 ;; `how' is neither `nil', `ask' nor `t' (i.e. `file'):
2791 2800
2792 (defun gnus-article-browse-html-parts (list) 2801 (defun gnus-article-browse-html-parts (list)
2793 "View all \"text/html\" parts from LIST. 2802 "View all \"text/html\" parts from LIST.
2794 Recurse into multiparts." 2803 Recurse into multiparts."
2795 ;; Internal function used by `gnus-article-browse-html-article'. 2804 ;; Internal function used by `gnus-article-browse-html-article'.
2796 (let ((showed)) 2805 (let (type file charset tmp-file showed)
2797 ;; Find and show the html-parts. 2806 ;; Find and show the html-parts.
2798 (dolist (handle list) 2807 (dolist (handle list)
2799 ;; If HTML, show it: 2808 ;; If HTML, show it:
2800 (when (listp handle) 2809 (cond ((not (listp handle)))
2801 (cond ((and (bufferp (car handle)) 2810 ((or (equal (car (setq type (mm-handle-type handle))) "text/html")
2802 (string-match "text/html" (car (mm-handle-type handle)))) 2811 (and (equal (car type) "message/external-body")
2803 (let ((tmp-file (mm-make-temp-file 2812 (setq file (or (mail-content-type-get type 'name)
2804 ;; Do we need to care for 8.3 filenames? 2813 (mail-content-type-get
2805 "mm-" nil ".html")) 2814 (mm-handle-disposition handle)
2806 (charset (mail-content-type-get (mm-handle-type handle) 2815 'filename)))
2807 'charset))) 2816 (or (mm-handle-cache handle)
2808 (if charset 2817 (condition-case code
2809 ;; Add a meta html tag to specify charset. 2818 (progn (mm-extern-cache-contents handle) t)
2810 (mm-with-unibyte-buffer 2819 (error
2811 (insert (with-current-buffer (mm-handle-buffer handle) 2820 (gnus-message 3 "%s" (error-message-string code))
2812 (if (eq charset 'gnus-decoded) 2821 (when (>= gnus-verbose 3) (sit-for 2))
2813 (mm-encode-coding-string 2822 nil)))
2814 (buffer-string) 2823 (progn
2815 (setq charset 'utf-8)) 2824 (setq handle (mm-handle-cache handle)
2816 (buffer-string)))) 2825 type (mm-handle-type handle))
2817 (setq charset (format "\ 2826 (equal (car type) "text/html"))))
2818 <meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\">" 2827 (when (or (setq charset (mail-content-type-get type 'charset))
2819 charset)) 2828 (not file))
2820 (goto-char (point-min)) 2829 (setq tmp-file (mm-make-temp-file
2821 (let ((case-fold-search t)) 2830 ;; Do we need to care for 8.3 filenames?
2822 (cond (;; Don't modify existing meta tag. 2831 "mm-" nil ".html")))
2823 (re-search-forward "\ 2832 (if charset
2824 <meta[\t\n\r ]+http-equiv=\"content-type\"[^>]+>" 2833 ;; Add a meta html tag to specify charset.
2825 nil t)) 2834 (mm-with-unibyte-buffer
2826 ((re-search-forward "<head>[\t\n\r ]*" nil t) 2835 (insert (if (eq charset 'gnus-decoded)
2827 (insert charset "\n")) 2836 (mm-encode-coding-string (mm-get-part handle)
2828 (t 2837 (setq charset 'utf-8))
2829 (re-search-forward "\ 2838 (mm-get-part handle)))
2830 <html\\(?:[\t\n\r ]+[^>]+\\|[\t\n\r ]*\\)>[\t\n\r ]*" 2839 (if (or (mm-add-meta-html-tag handle charset)
2831 nil t) 2840 (not file))
2832 (insert "<head>\n" charset "\n</head>\n"))))
2833 (mm-write-region (point-min) (point-max) 2841 (mm-write-region (point-min) (point-max)
2834 tmp-file nil nil nil 'binary t)) 2842 tmp-file nil nil nil 'binary t)
2835 (mm-save-part-to-file handle tmp-file)) 2843 (setq tmp-file nil)))
2836 (add-to-list 'gnus-article-browse-html-temp-list tmp-file) 2844 (when tmp-file
2837 (add-hook 'gnus-summary-prepare-exit-hook 2845 (mm-save-part-to-file handle tmp-file)))
2838 'gnus-article-browse-delete-temp-files) 2846 (when tmp-file
2839 (add-hook 'gnus-exit-gnus-hook 2847 (add-to-list 'gnus-article-browse-html-temp-list tmp-file))
2840 (lambda () 2848 (add-hook 'gnus-summary-prepare-exit-hook
2841 (gnus-article-browse-delete-temp-files t))) 2849 'gnus-article-browse-delete-temp-files)
2842 ;; FIXME: Warn if there's an <img> tag? 2850 (add-hook 'gnus-exit-gnus-hook
2843 (browse-url-of-file tmp-file) 2851 (lambda ()
2844 (setq showed t))) 2852 (gnus-article-browse-delete-temp-files t)))
2845 ;; If multipart, recurse 2853 ;; FIXME: Warn if there's an <img> tag?
2846 ((and (stringp (car handle)) 2854 (browse-url-of-file (or tmp-file (expand-file-name file)))
2847 (string-match "^multipart/" (car handle)) 2855 (setq showed t))
2848 (setq showed 2856 ;; If multipart, recurse
2849 (or showed 2857 ((and (stringp (car handle))
2850 (gnus-article-browse-html-parts handle)))))))) 2858 (string-match "^multipart/" (car handle))
2859 (setq showed
2860 (or showed
2861 (gnus-article-browse-html-parts handle)))))))
2851 showed)) 2862 showed))
2852 2863
2853 ;; FIXME: Documentation in texi/gnus.texi missing. 2864 ;; FIXME: Documentation in texi/gnus.texi missing.
2854 (defun gnus-article-browse-html-article () 2865 (defun gnus-article-browse-html-article ()
2855 "View \"text/html\" parts of the current article with a WWW browser. 2866 "View \"text/html\" parts of the current article with a WWW browser.
3905 "nobody") 3916 "nobody")
3906 gnus-article-save-directory))) 3917 gnus-article-save-directory)))
3907 3918
3908 (defun article-verify-x-pgp-sig () 3919 (defun article-verify-x-pgp-sig ()
3909 "Verify X-PGP-Sig." 3920 "Verify X-PGP-Sig."
3921 ;; <ftp://ftp.isc.org/pub/pgpcontrol/FORMAT>
3910 (interactive) 3922 (interactive)
3911 (if (gnus-buffer-live-p gnus-original-article-buffer) 3923 (if (gnus-buffer-live-p gnus-original-article-buffer)
3912 (let ((sig (with-current-buffer gnus-original-article-buffer 3924 (let ((sig (with-current-buffer gnus-original-article-buffer
3913 (gnus-fetch-field "X-PGP-Sig"))) 3925 (gnus-fetch-field "X-PGP-Sig")))
3914 items info headers) 3926 items info headers)
4713 (let* ((data (get-text-property (point) 'gnus-data)) 4725 (let* ((data (get-text-property (point) 'gnus-data))
4714 (id (get-text-property (point) 'gnus-part)) 4726 (id (get-text-property (point) 'gnus-part))
4715 (handles gnus-article-mime-handles) 4727 (handles gnus-article-mime-handles)
4716 (none "(none)") 4728 (none "(none)")
4717 (description 4729 (description
4718 (mail-decode-encoded-word-string (or (mm-handle-description data) 4730 (let ((desc (mm-handle-description data)))
4719 none))) 4731 (when desc
4732 (mail-decode-encoded-word-string desc))))
4720 (filename 4733 (filename
4721 (or (mail-content-type-get (mm-handle-disposition data) 'filename) 4734 (or (mail-content-type-get (mm-handle-disposition data) 'filename)
4722 none)) 4735 none))
4723 (type (mm-handle-media-type data))) 4736 (type (mm-handle-media-type data)))
4724 (unless data 4737 (unless data
4732 "| The following attachment has been deleted:\n" 4745 "| The following attachment has been deleted:\n"
4733 "|\n" 4746 "|\n"
4734 "| Type: " type "\n" 4747 "| Type: " type "\n"
4735 "| Filename: " filename "\n" 4748 "| Filename: " filename "\n"
4736 "| Size (encoded): " bsize " Byte\n" 4749 "| Size (encoded): " bsize " Byte\n"
4737 "| Description: " description "\n" 4750 (when description
4751 (concat "| Description: " description "\n"))
4738 "`----\n")) 4752 "`----\n"))
4739 (setcdr data 4753 (setcdr data
4740 (cdr (mm-make-handle 4754 (cdr (mm-make-handle
4741 nil `("text/plain") nil nil 4755 nil `("text/plain") nil nil
4742 (list "attachment") 4756 (list "attachment")
7680 7694
7681 (defun gnus-button-handle-info-url-kde (url) 7695 (defun gnus-button-handle-info-url-kde (url)
7682 "Fetch KDE style info URL." 7696 "Fetch KDE style info URL."
7683 (gnus-info-find-node (gnus-url-unhex-string url))) 7697 (gnus-info-find-node (gnus-url-unhex-string url)))
7684 7698
7699 ;; (info) will autoload info.el
7700 (declare-function Info-menu "info" (menu-item &optional fork))
7701
7685 (defun gnus-button-handle-info-keystrokes (url) 7702 (defun gnus-button-handle-info-keystrokes (url)
7686 "Call `info' when pushing the corresponding URL button." 7703 "Call `info' when pushing the corresponding URL button."
7687 ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'. 7704 ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'.
7688 (info) 7705 (info)
7689 (Info-directory) 7706 (Info-directory)
7989 (or gnus-article-encrypt-protocol 8006 (or gnus-article-encrypt-protocol
7990 (completing-read "Encrypt protocol: " 8007 (completing-read "Encrypt protocol: "
7991 gnus-article-encrypt-protocol-alist 8008 gnus-article-encrypt-protocol-alist
7992 nil t)) 8009 nil t))
7993 current-prefix-arg)) 8010 current-prefix-arg))
8011 ;; User might hit `K E' instead of `K e', so prompt once.
8012 (when (and gnus-article-encrypt-protocol
8013 gnus-novice-user)
8014 (unless (gnus-y-or-n-p "Really encrypt article(s)? ")
8015 (error "Encrypt aborted.")))
7994 (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist)))) 8016 (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
7995 (unless func 8017 (unless func
7996 (error "Can't find the encrypt protocol %s" protocol)) 8018 (error "Can't find the encrypt protocol %s" protocol))
7997 (if (member gnus-newsgroup-name '("nndraft:delayed" 8019 (if (member gnus-newsgroup-name '("nndraft:delayed"
7998 "nndraft:drafts" 8020 "nndraft:drafts"