code.delx.au - gnu-emacs/blob - share/emacs/site-lisp/w3m/mew-w3m.el

   1 ;; mew-w3m.el --- View Text/Html content with w3m in Mew
   2
   3 ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2008, 2009, 2010
   4 ;; TSUCHIYA Masatoshi <tsuchiya@namazu.org>
   5
   6 ;; Author: Shun-ichi GOTO  <gotoh@taiyo.co.jp>,
   7 ;;         Hideyuki SHIRAI <shirai@meadowy.org>
   8 ;; Created: Wed Feb 28 03:31:00 2001
   9 ;; Version: $Revision: 1.69 $
  10 ;; Keywords: Mew, mail, w3m, WWW, hypermedia
  11
  12 ;; This file is a part of emacs-w3m.
  13
  14 ;; This program is free software; you can redistribute it and/or
  15 ;; modify it under the terms of the GNU General Public License as
  16 ;; published by the Free Software Foundation; either version 2, or (at
  17 ;; your option) any later version.
  18
  19 ;; This program is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with this program; see the file COPYING.  If not, write to
  26 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; This package is for viewing formatted (rendered) Text/Html content
  32 ;; in Mew's message buffer.
  33
  34 ;;; Installation:
  35
  36 ;; (1) Simply load this file and add followings in your ~/.mew file.
  37 ;;
  38 ;; (require 'mew-w3m)
  39 ;;
  40 ;; (2) And you can use keymap of w3m-mode as mew-w3m-minor-mode.
  41 ;; To activate this feaeture, add followings also:
  42 ;;
  43 ;; (setq mew-use-w3m-minor-mode t)
  44 ;; (add-hook 'mew-message-hook 'mew-w3m-minor-mode-setter)
  45 ;;
  46 ;; (3) If you use mew-1.95b118 or later on which Emacs 21, 22 or XEmacs,
  47 ;; can display the images in the Text/Html message.
  48 ;; To activate this feaeture, add following in your ~/.mew file.
  49 ;;
  50 ;; (define-key mew-summary-mode-map "T" 'mew-w3m-view-inline-image)
  51 ;;
  52 ;; Press "T":    Toggle the visibility of the images included its message only.
  53 ;; Press "C-uT": Display the all images included its Text/Html part."
  54 ;;
  55 ;; (4) You can use emacs-w3m to fetch and/or browse
  56 ;; `external-body with URL access'. To activate this feaeture,
  57 ;; add followings also:
  58 ;;
  59 ;; (setq mew-ext-url-alist
  60 ;;      '(("^application/" "Fetch by emacs-w3m" mew-w3m-ext-url-fetch nil)
  61 ;;        (t "Browse by emacs-w3m" mew-w3m-ext-url-show nil)))
  62 ;;  or
  63 ;; (setq mew-ext-url-alist
  64 ;;      '((t "Browse by emacs-w3m" mew-w3m-ext-url-show nil)))
  65 ;;
  66
  67 ;;; Usage:
  68
  69 ;; There's nothing special. Browse messages in usual way.
  70 ;; On viewing Text/Html file, rendered text is appeared in message
  71 ;; buffer instead of usual "HTML" banner.
  72 ;; C-c C-e operation is also allowed to view with external browser.
  73 ;;
  74 ;; If mew-use-w3m-minor-mode is t, key operations of w3m-mode is
  75 ;; allowed (as minor-mode-map) and jump links in message buffer.
  76 ;; NOTE: This feature is not complete. You may confuse.
  77 ;;
  78 ;;
  79
  80 ;;; Code:
  81
  82 (require 'mew)
  83 (require 'w3m)
  84 (eval-when-compile (require 'cl))
  85
  86 ;;; initializer for mew
  87 (defgroup mew-w3m nil
  88   "mew-w3m - Inline HTML rendering extension of Mew"
  89   :group 'w3m)
  90
  91 (defcustom mew-use-w3m-minor-mode nil
  92   "*Use w3m minor mode in message buffer.
  93 Non-nil means that the minor mode whose keymap contains keys binded to
  94 some emacs-w3m commands are activated in message buffer, when viewing
  95 Text/Html contents."
  96   :group 'mew-w3m
  97   :type 'boolean)
  98
  99 (defcustom mew-w3m-auto-insert-image nil
 100   "*If non-nil, images are inserted automatically in Multipart/Related message.
 101 This variable is effective only in XEmacs, Emacs 21 and Emacs 22."
 102   :group 'mew-w3m
 103   :type 'boolean)
 104
 105 (defcustom mew-w3m-cid-retrieve-hook nil
 106   "*Hook run after cid retrieved"
 107   :group 'mew-w3m
 108   :type 'hook)
 109
 110 (defcustom mew-w3m-region-cite-mark "&gt;&nbsp;"
 111   "*Method of converting `blockquote'."
 112   :group 'mew-w3m
 113   :type '(choice (const :tag "Use Indent" nil)
 114                  (const :tag "Use Cite Mark \"> \"" "&gt;&nbsp;")
 115                  (string :tag "Use Other Mark")))
 116
 117 (defconst mew-w3m-safe-url-regexp "\\`cid:")
 118
 119 ;; Avoid bytecompile error and warnings.
 120 (eval-when-compile
 121   (defvar mew-use-text/html)
 122   (unless (fboundp 'mew-current-get-fld)
 123     (autoload 'mew-coding-system-p "mew")
 124     (autoload 'mew-current-get-fld "mew")
 125     (autoload 'mew-current-get-msg "mew")
 126     (autoload 'mew-syntax-get-entry-by-cid "mew")
 127     (defun mew-cache-hit (&rest args) ())))
 128
 129 (defmacro mew-w3m-add-text-properties (props)
 130   `(add-text-properties (point-min)
 131                         (min (1+ (point-min)) (point-max))
 132                         ,props))
 133
 134 (defun mew-w3m-minor-mode-setter ()
 135   "Check message buffer and activate w3m-minor-mode."
 136   (w3m-minor-mode (or (and (get-text-property (point-min) 'w3m)
 137                            mew-use-w3m-minor-mode)
 138                       0)))
 139
 140 (defvar mew-w3m-use-safe-url-regexp t)
 141
 142 (defun mew-w3m-view-inline-image (&optional allimage)
 143   "Display the images of Text/Html part.
 144 \\<mew-summary-mode-map>
 145 '\\[mew-w3m-view-inline-image]' Toggle display the images included its message only.
 146 '\\[universal-argument]\\[mew-w3m-view-inline-image]'   Display the all images included its Text/Html part."
 147   (interactive "P")
 148   (mew-summary-msg-or-part
 149    (if allimage
 150        (let ((mew-use-text/html t)
 151              (mew-w3m-auto-insert-image t)
 152              (mew-w3m-use-safe-url-regexp nil))
 153          (mew-summary-display 'force))
 154      (with-current-buffer (mew-buffer-message)
 155        (let* ((image (get-text-property (point-min) 'w3m-images))
 156               (w3m-display-inline-images image)
 157               (w3m-safe-url-regexp (when mew-w3m-use-safe-url-regexp
 158                                      mew-w3m-safe-url-regexp)))
 159          (w3m-toggle-inline-images)
 160          (mew-elet
 161           (mew-w3m-add-text-properties `(w3m-images ,(not image)))
 162           (set-buffer-modified-p nil)))))))
 163
 164 (defun mew-w3m-region (start end &optional url charset)
 165   "w3m-region with inserting the cite mark."
 166   (if (null mew-w3m-region-cite-mark)
 167       (w3m-region start end url charset)
 168     (save-restriction
 169       (narrow-to-region start end)
 170       (let ((case-fold-search t)
 171             pos lines tagbeg0 tagend0 tagbeg1 tagend1)
 172         (goto-char (point-min))
 173         (while (w3m-search-tag "blockquote")
 174           (setq tagbeg0 (match-beginning 0))
 175           (setq tagend0 (match-end 0))
 176           (when (w3m-search-tag "/blockquote")
 177             (setq tagbeg1 (match-beginning 0))
 178             (setq tagend1 (match-end 0))
 179             (setq lines (buffer-substring tagend0 tagbeg1))
 180             (delete-region tagbeg0 tagend1)
 181             (insert (with-temp-buffer
 182                       (insert lines)
 183                       (goto-char (point-min))
 184                       (if (and (w3m-search-tag "pre")
 185                                (setq tagbeg0 (match-beginning 0))
 186                                (setq tagend0 (match-end 0))
 187                                (w3m-search-tag "/pre")
 188                                (setq tagbeg1 (match-beginning 0))
 189                                (setq tagend1 (match-end 0)))
 190                           (progn
 191                             (delete-region tagbeg1 tagend1)
 192                             (delete-region tagbeg0 tagend0))
 193                         ;; delete <br>
 194                         (goto-char (point-min))
 195                         (while (w3m-search-tag "br")
 196                           (delete-region (match-beginning 0) (match-end 0))
 197                           (unless (looking-at "[\n\r]") (insert "\n"))))
 198                       (goto-char (point-max))
 199                       (skip-chars-backward " \t\n\f\r")
 200                       (delete-region (point) (point-max))
 201                       (goto-char (point-min))
 202                       (skip-chars-forward " \t\n\f\r")
 203                       (delete-region (point-min) (point))
 204                       (goto-char (point-min))
 205                       (while (not (eobp))
 206                         (insert mew-w3m-region-cite-mark)
 207                         (forward-line 1))
 208                       (goto-char (point-min))
 209                       (insert "<pre>\n")
 210                       (goto-char (point-max))
 211                       (insert "\n</pre>\n")
 212                       (buffer-substring (point-min) (point-max)))))))
 213       (w3m-region (point-min) (point-max) url charset))))
 214
 215 ;; processing Text/Html contents with w3m.
 216 (defun mew-mime-text/html-w3m (&rest args)
 217   "View Text/Html contents with w3m rendering output."
 218   (let ((w3m-display-inline-images mew-w3m-auto-insert-image)
 219         (w3m-safe-url-regexp (when mew-w3m-use-safe-url-regexp
 220                                mew-w3m-safe-url-regexp))
 221         w3m-force-redisplay     ;; don't redraw
 222         charset wcs xref
 223         cache begin end params execute)
 224     (if (= (length args) 2)
 225         ;; Mew-2
 226         (setq begin (nth 0 args) end (nth 1 args))
 227       ;; Old Mew
 228       (setq cache (nth 0 args))
 229       (setq begin (nth 1 args))
 230       (setq end (nth 2 args))
 231       (setq params (nth 3 args))
 232       (setq execute (nth 4 args)))
 233     (if (and cache (or execute (<= end begin)))
 234         ;; 'C-cC-e' + Old Mew
 235         (apply 'mew-mime-text/html (list cache begin end params execute))
 236       (save-excursion
 237         ;; search Xref: Header in SHIMBUN article
 238         (when cache (set-buffer cache))
 239         (goto-char (point-min))
 240         (when (re-search-forward mew-eoh nil t)
 241           (let ((eoh (point))
 242                 (case-fold-search t))
 243             (goto-char (point-min))
 244             (when (and (re-search-forward "^X-Shimbun-Id: " eoh t)
 245                        (goto-char (point-min))
 246                        (re-search-forward "^Xref: \\(.+\\)\n" eoh t))
 247               (setq xref (match-string 1))
 248               (w3m-static-if (fboundp 'match-string-no-properties)
 249                   (setq xref (match-string-no-properties 1))
 250                 (setq xref (match-string 1))
 251                 (set-text-properties 0 (length xref) nil xref))))))
 252       (mew-elet
 253        (cond
 254         ((and (null cache) (eq w3m-type 'w3m-m17n))
 255          ;; Mew-2 + w3m-m17n.
 256          ;; Coding-system and charset are decided by Mew.
 257          (let ((w3m-input-coding-system w3m-input-coding-system)
 258                (w3m-output-coding-system w3m-output-coding-system)
 259                (w3m-halfdump-command-arguments w3m-halfdump-command-arguments))
 260            (when (setq charset (mew-charset-guess-region begin end))
 261              (setq wcs (mew-charset-to-cs charset)))
 262            (when (and charset wcs (mew-coding-system-p wcs))
 263              ;; guess correctly and not us-ascii
 264              (setq w3m-input-coding-system wcs)
 265              (setq w3m-output-coding-system wcs)
 266              (setq w3m-halfdump-command-arguments
 267                    (list "-halfdump"
 268                          "-I" charset "-O" charset
 269                          "-o" "ext_halfdump=1"
 270                          "-o" "pre_conv=1"
 271                          "-o" "strict_iso2022=0")))
 272            (mew-w3m-region begin end xref)))
 273         ((null cache)   ;; Mew-2 + w3m, w3mmee
 274          (mew-w3m-region begin end xref (mew-charset-guess-region begin end)))
 275         (t              ;; Old Mew
 276          (setq charset (or (mew-syntax-get-param params "charset")
 277                            (with-current-buffer cache
 278                              (mew-charset-guess-region begin end))))
 279          (if charset
 280              (setq wcs (mew-charset-to-cs charset))
 281            (setq wcs mew-cs-text-for-write))
 282          (mew-frwlet
 283              mew-cs-dummy wcs
 284            (mew-w3m-region (point)
 285                            (progn (insert-buffer-substring cache begin end)
 286                                   (point))
 287                            xref))))
 288        (mew-w3m-add-text-properties `(w3m t w3m-images ,mew-w3m-auto-insert-image))))))
 289
 290 (defvar w3m-mew-support-cid (and (boundp 'mew-version-number)
 291                                  (fboundp 'mew-syntax-get-entry-by-cid)))
 292
 293 (defun mew-w3m-cid-retrieve (url &rest args)
 294   (let ((output-buffer (current-buffer)))
 295     (with-current-buffer w3m-current-buffer
 296       (when (and w3m-mew-support-cid
 297                  (string-match "^cid:\\(.+\\)" url))
 298         (setq url (match-string 1 url))
 299         (let* ((fld (mew-current-get-fld (mew-frame-id)))
 300                (msg (mew-current-get-msg (mew-frame-id)))
 301                (cache (mew-cache-hit fld msg 'must-hit))
 302                (syntax (mew-cache-decode-syntax cache))
 303                cidstx beg end)
 304           (if (string< "4.0.53" mew-version-number)
 305               (setq cidstx (mew-syntax-get-entry-by-cid syntax (concat "<" url ">")))
 306             (setq cidstx (mew-syntax-get-entry-by-cid syntax url)))
 307           (when cidstx
 308             (setq beg (mew-syntax-get-begin cidstx))
 309             (setq end (mew-syntax-get-end cidstx))
 310             (prog1
 311                 (with-current-buffer output-buffer
 312                   (set-buffer-multibyte t)
 313                   (insert-buffer-substring cache beg end)
 314                   (set-buffer-multibyte nil)
 315                   (downcase (car (mew-syntax-get-ct cidstx))))
 316               (run-hooks 'mew-w3m-cid-retrieve-hook))))))))
 317
 318 (when w3m-mew-support-cid
 319   (push (cons 'mew-message-mode 'mew-w3m-cid-retrieve)
 320         w3m-cid-retrieve-function-alist))
 321
 322 (defun mew-w3m-ext-url-show (dummy url)
 323   (pop-to-buffer (mew-buffer-message))
 324   (w3m url))
 325
 326 (defun mew-w3m-ext-url-fetch (dummy url)
 327   (lexical-let ((url url)
 328                 (name (file-name-nondirectory url))
 329                 handler)
 330     (w3m-process-do
 331         (success (prog1
 332                      (w3m-download url nil nil handler)
 333                    (message "Download: %s..." name)))
 334       (if success
 335           (message "Download: %s...done" name)
 336         (message "Download: %s...failed" name))
 337       (sit-for 1))))
 338
 339 (defun w3m-mail-compose-with-mew (source url charset content-type
 340                                          to subject other-headers)
 341   "Compose a mail using Mew."
 342   (when (one-window-p)
 343     (split-window))
 344   (select-window (next-window))
 345   (condition-case nil
 346       (unless (and (boundp 'mew-init-p) mew-init-p
 347                    (progn
 348                      (mew-summary-jump-to-draft-buffer)
 349                      (and (eq major-mode 'mew-draft-mode)
 350                           (y-or-n-p "Attatch this draft? "))))
 351         (mew-user-agent-compose to subject other-headers))
 352     (quit
 353      (if (y-or-n-p "Create new draft? ")
 354          (mew-user-agent-compose to subject other-headers)
 355        (delete-window)
 356        (error "Abort mail composing"))))
 357   (let* ((basename (file-name-nondirectory (w3m-url-strip-query url)))
 358          (ct (downcase  content-type))
 359          (mew-attach-move-next-after-copy nil)
 360          (i 1)
 361          (pos -1)
 362          (csorig (mew-charset-to-cs (symbol-name charset)))
 363          last filename cs)
 364     (unless (mew-attach-p)
 365       (mew-draft-prepare-attachments))
 366     ;; goto last attachment
 367     (setq last (catch 'last
 368                  (while (not (= pos (point)))
 369                    (setq i (1+ i))
 370                    (mew-attach-goto-number 'here `(,i))
 371                    (when (mew-attach-line-lastp)
 372                      (throw 'last t)))))
 373     (when (eq csorig mew-cs-unknown)
 374       (setq csorig nil))
 375     (if (or (not last) (not (mew-attach-not-line012-1)))
 376         (message "Can not attach from emacs-w3m here!")
 377       ;; Application/.*xml is not inline view with Mew.
 378       (cond
 379        ((string= "application/xhtml+xml" ct)
 380         (setq ct "text/html"))
 381        ((string-match "^application/.*xml$" ct)
 382         (setq ct "text/xml")))
 383       (setq filename (expand-file-name (cond
 384                                         ((and (string-match "^[\t ]*$" basename)
 385                                               (string= ct "text/html"))
 386                                          "index.html")
 387                                         ((and (string-match "^[\t ]*$" basename)
 388                                               (string= ct "text/xml"))
 389                                          "index.xml")
 390                                         ((string-match "^[\t ]*$" basename)
 391                                          "dummy")
 392                                         (t
 393                                          basename))
 394                                        mew-temp-dir))
 395       (with-temp-buffer
 396         (cond
 397          ((string= "text/html" ct)
 398           (insert source)
 399           (setq cs (w3m-static-if (fboundp 'mew-text/html-detect-cs)
 400                        (mew-text/html-detect-cs (point-min) (point-max))))
 401           (when (or (eq cs mew-cs-unknown) (not cs))
 402             (cond
 403              (csorig
 404               (setq cs csorig))
 405              (t
 406               (setq cs mew-cs-autoconv)))))
 407          ((string= "text/xml" ct)
 408           (insert source)
 409           (setq cs (w3m-static-if (fboundp 'mew-text/html-detect-cs)
 410                        (mew-text/html-detect-cs (point-min) (point-max))))
 411           (when (or (eq cs mew-cs-unknown) (not cs))
 412             (cond
 413              (csorig
 414               (setq cs csorig))
 415              ((mew-coding-system-p 'utf-8)
 416               (setq cs 'utf-8))
 417              (t
 418               (setq cs mew-cs-autoconv)))))
 419          ((string-match "^text/" ct)
 420           (insert source)
 421           (setq cs mew-cs-autoconv))
 422          (t
 423           (mew-set-buffer-multibyte nil)
 424           (insert source)
 425           (setq cs mew-cs-binary)))
 426         (setq charset (cond
 427                        ((eq cs mew-cs-autoconv)
 428                         (mew-charset-guess-region (point-min) (point-max)))
 429                        ((eq cs mew-cs-binary)
 430                         nil)
 431                        (t
 432                         (mew-cs-to-charset cs))))
 433         (mew-frwlet
 434             mew-cs-text-for-read cs
 435           (write-region (point-min) (point-max) filename nil 'nomsg)))
 436       (when ct
 437         (setq ct (mew-capitalize ct)))
 438       (mew-attach-copy filename (file-name-nondirectory filename))
 439       ;; content-type check & set
 440       (let* ((nums (mew-syntax-nums))
 441              (syntax (mew-syntax-get-entry mew-encode-syntax nums))
 442              (file (mew-syntax-get-file syntax))
 443              (ctl (mew-syntax-get-ct syntax))
 444              (ct-orig (mew-syntax-get-value ctl 'cap))
 445              cte)
 446         (unless (string= ct ct-orig)
 447           (setq ctl (list ct))
 448           (mew-syntax-set-ct syntax ctl)
 449           (setq cte (mew-ctdb-cte (mew-ctdb-by-ct ct)))
 450           (mew-syntax-set-cte syntax cte)
 451           (mew-syntax-set-cdp syntax (mew-syntax-cdp-format ct file))
 452           (mew-encode-syntax-print mew-encode-syntax)))
 453       ;; charset set
 454       (let* ((nums (mew-syntax-nums))
 455              (syntax (mew-syntax-get-entry mew-encode-syntax nums))
 456              (file (mew-syntax-get-file syntax))
 457              (ctl (mew-syntax-get-ct syntax))
 458              (ct (mew-syntax-get-value ctl 'cap))
 459              (params (mew-syntax-get-params ctl))
 460              (ocharset "charset"))
 461         (when (and (string-match "^Text" ct) charset)
 462           (setq params (mew-delete ocharset params))
 463           (setq ctl (cons ct (cons (list ocharset charset) params)))
 464           (mew-syntax-set-ct syntax ctl))
 465         (mew-syntax-set-cd syntax url)
 466         (mew-encode-syntax-print mew-encode-syntax))
 467       (message "Compose a mail using Mew with %s...done" url)
 468       (when (and (file-exists-p filename) (file-writable-p filename))
 469         (delete-file filename)))))
 470
 471 ;;;
 472 (provide 'mew-w3m)
 473
 474 ;; mew-w3m.el ends here