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

   1 ;;; w3m-mail.el --- an interface to mail-user-agent for sending web pages
   2
   3 ;; Copyright (C) 2006, 2009 TSUCHIYA Masatoshi
   4
   5 ;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
   6 ;; Keywords: w3m, WWW, hypermedia
   7
   8 ;; This file is a part of emacs-w3m.
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This module provides the `w3m-mail' command which enables you to
  28 ;; send web pages as mails respecting those content types (typically
  29 ;; text/html).  Currently this program works if and only if you set
  30 ;; the `mail-user-agent' variable to one of the following agents:
  31 ;;      `gnus-user-agent'
  32 ;;      `message-user-agent'
  33 ;;      `mew-user-agent'
  34 ;;      `vm-user-agent'
  35 ;;      `wl-user-agent'
  36 ;; To send the page you are looking at, type `M-x w3m-mail' or click
  37 ;; the menu button, fill message headers properly, and type `C-c C-c'.
  38
  39 ;;; Code:
  40
  41 (require 'w3m)
  42
  43 (defcustom w3m-mail-subject '("Emailing:" url)
  44   "A list of strings and symbols used to generate the subject header.
  45 Valid symbols include `url' which is replaced with the url of the page
  46 and `title' which is replaced with the page title.  You can also use
  47 just a string for this variable."
  48   :group 'w3m
  49   :type '(radio (editable-list :format "\n%v%i\n"
  50                                (radio-button-choice
  51                                 (const :format "%v " url)
  52                                 (const :format "%v " title)
  53                                 string))
  54                 string
  55                 (const :format "no subject" nil)))
  56
  57 (defvar w3m-mail-user-agent-compose-function-alist
  58   (let ((alist '((gnus-user-agent . w3m-mail-compose-with-mml)
  59                  (message-user-agent . w3m-mail-compose-with-mml)
  60                  (mew-user-agent . w3m-mail-compose-with-mew)
  61                  (vm-user-agent . w3m-mail-compose-with-vm)
  62                  (wl-user-agent . w3m-mail-compose-with-semi)))
  63         composer)
  64     (delq nil (mapcar (lambda (agent)
  65                         (if (setq composer (cdr (assq agent alist)))
  66                             (cons agent composer)))
  67                       w3m-mail-user-agents)))
  68   "Alist of mail user agents and functions to compose a mail.
  69 The function will be called with the arguments `source', `url',
  70 `charset', `content-type', `to', `subject', and `other-headers'; where
  71 `source' is a string containing the page source, `url' is the url of
  72 the page, `charset' is a charset that the page uses, `content-type' is
  73 the one such as \"text/html\", and the rest are the same as those of
  74 `compose-mail'.")
  75
  76 (eval-when-compile
  77   (autoload 'message-add-action "message")
  78   (autoload 'mml-insert-empty-tag "mml")
  79   (autoload 'vm-mime-attach-buffer "vm-mime")
  80   (condition-case nil
  81       (require 'mime-edit)
  82     (error
  83      (dolist (symbol '(encode-mime-charset-region
  84                        detect-mime-charset-region
  85                        std11-wrap-as-quoted-string
  86                        mime-find-file-type
  87                        mime-edit-insert-tag
  88                        mime-edit-define-encoding
  89                        mime-encode-region))
  90        (defalias symbol 'ignore)))))
  91
  92 (eval-and-compile
  93   (autoload 'mm-find-mime-charset-region "mm-util")
  94   (autoload 'w3m-mail-compose-with-mew "mew-w3m"
  95     "Compose a mail using Mew." t))
  96
  97 (defun w3m-mail-make-subject ()
  98   "Return a string used for the Subject header."
  99   (cond ((consp w3m-mail-subject)
 100          (w3m-replace-in-string
 101           (w3m-replace-in-string
 102            (mapconcat (lambda (elem)
 103                         (cond ((eq elem 'url) w3m-current-url)
 104                               ((eq elem 'title) w3m-current-title)
 105                               ((stringp elem) elem)
 106                               (t (format "%s" elem))))
 107                       w3m-mail-subject
 108                       " ")
 109            "[\t\n ]+" " ")
 110           "\\(?:\\` \\| \\'\\)" ""))
 111         ((stringp w3m-mail-subject) w3m-mail-subject)
 112         (t "(no subject)")))
 113
 114 (defun w3m-mail-compute-base-url ()
 115   "Compute a base url of the page if it is not provided."
 116   (let ((url (substring w3m-current-url 15)))
 117     (unless (string-match "\\`about:" url)
 118       (save-excursion
 119         (goto-char (point-min))
 120         (let ((case-fold-search t)
 121               start end)
 122           (unless (and (setq start (search-forward "<head>" nil t))
 123                        (setq end (search-forward "</head>" nil t))
 124                        (progn
 125                          (goto-char start)
 126                          (re-search-forward "<base[\t\n\r ]+" end t))
 127                        (w3m-parse-attributes (href) (> (length href) 0)))
 128             (substring (w3m-expand-url "x" url) 0 -1)))))))
 129
 130 (defun w3m-mail-embed-base-url (source base-url)
 131   "Embed BASE-URL in SOURCE."
 132   (with-temp-buffer
 133     (w3m-static-unless (featurep 'xemacs)
 134       (set-buffer-multibyte t))
 135     (setq case-fold-search t)
 136     (insert source)
 137     (goto-char (point-min))
 138     (while (search-forward "\r\n" nil t)
 139       (replace-match "\n"))
 140     (goto-char (point-min))
 141     (let ((nohead t)
 142           (points (list (point-min) (point-min)))
 143           (margin 0))
 144       (when (re-search-forward "\\(<html>\\)[\t\n ]*" nil t)
 145         (setq points (list (match-end 1) (match-end 0))
 146               margin (current-column)))
 147       (when (re-search-forward "\\(<head>\\)[\t\n ]*" nil t)
 148         (setq nohead nil
 149               points (list (match-end 1) (match-end 0))
 150               margin (current-column)))
 151       (setq margin (make-string margin ? ))
 152       (goto-char (car points))
 153       (apply 'delete-region points)
 154       (if nohead
 155           (insert "\n" margin "<head><base href=\"" base-url "\"></head>\n"
 156                   margin)
 157         (insert "\n" margin "<base href=\"" base-url "\">\n" margin)))
 158     (buffer-string)))
 159
 160 (defun w3m-mail-goto-body-and-clear-body ()
 161   "Go to the beginning of the body and clear the body."
 162   (goto-char (point-min))
 163   (if (re-search-forward (concat "^\\(?:"
 164                                  (regexp-quote mail-header-separator)
 165                                  "\\)?\n")
 166                          nil 'move)
 167       (delete-region (point) (point-max))
 168     (insert (if (bolp) "\n" "\n\n"))))
 169
 170 (defun w3m-mail-position-point (bob)
 171   "Go to empty or bogus header, otherwise the beginning of the body BOB."
 172   (goto-char (point-min))
 173   (when (re-search-forward "^\\(Subject: \\)(no subject)\\|\
 174 ^\\([0-9A-Za-z-]+: ?\\)[\t ]*\n\\(?:[\t ]+\n\\)*[^\t ]"
 175                            bob 'move)
 176     (goto-char (or (match-end 1) (match-end 2)))))
 177
 178 (defun w3m-mail-compose-with-mml (source url charset content-type
 179                                          to subject other-headers)
 180   "Compose a mail using MML."
 181   (let ((buffer (generate-new-buffer " *w3m-mail*")))
 182     (with-current-buffer buffer
 183       (w3m-static-unless (featurep 'xemacs)
 184         (set-buffer-multibyte (not (string-match "\\`image/" content-type))))
 185       (insert source))
 186     (if (eq mail-user-agent 'gnus-user-agent)
 187         (progn
 188           (require 'gnus)
 189           (let (gnus-newsgroup-name)
 190             (compose-mail to subject other-headers)))
 191       (compose-mail to subject other-headers))
 192     (message-add-action `(kill-buffer ,buffer) 'exit 'kill 'postpone 'send)
 193     (w3m-mail-goto-body-and-clear-body)
 194     (w3m-mail-position-point
 195      (prog1
 196          (point)
 197        (mml-insert-empty-tag
 198         'part
 199         'type content-type
 200         'buffer (buffer-name buffer)
 201         ;; Use the base64 encoding if the body contains non-ASCII text
 202         ;; or very long lines which might be broken by MTAs.
 203         'encoding "base64"
 204         'charset (when charset (symbol-name charset))
 205         'disposition "inline"
 206         'description url)))))
 207
 208 ;; This function is implemented in mew-w3m.el.
 209 ;; (defun w3m-mail-compose-with-mew (source url charset content-type
 210 ;;                                         to subject other-headers)
 211 ;;   "Compose a mail using Mew.")
 212
 213 (defun w3m-mail-compose-with-vm (source url charset content-type
 214                                         to subject other-headers)
 215   "Compose a mail using VM."
 216   (let* ((coding (and charset (w3m-charset-to-coding-system charset)))
 217          (multibytep (and (not coding)
 218                           (or charset
 219                               (and (not (string-match "\\`image/"
 220                                                       content-type))
 221                                    (w3m-static-if (featurep 'xemacs)
 222                                        (string-match "[^\000-\177]" source)
 223                                      (multibyte-string-p source))))))
 224          (buffer (generate-new-buffer " *w3m-mail*")))
 225     (with-current-buffer buffer
 226       (w3m-static-unless (featurep 'xemacs)
 227         (set-buffer-multibyte (and (not coding) multibytep)))
 228       (cond (coding
 229              (insert (encode-coding-string source coding)))
 230             (multibytep
 231              (insert source)
 232              (when (and (setq charset (car (mm-find-mime-charset-region
 233                                             (point-min) (point-max))))
 234                         (setq coding (w3m-charset-to-coding-system charset)))
 235                (w3m-static-if (featurep 'xemacs)
 236                    (encode-coding-region (point-min) (point-max) coding)
 237                  (insert (prog1
 238                              (encode-coding-string (buffer-string) coding)
 239                            (erase-buffer)
 240                            (set-buffer-multibyte nil))))))
 241             (t
 242              (insert source))))
 243     (require 'vm-startup)
 244     (compose-mail to subject other-headers)
 245     (add-to-list 'mail-send-actions `(kill-buffer ,buffer))
 246     (w3m-add-local-hook 'kill-buffer-hook `(lambda nil (kill-buffer ,buffer)))
 247     (w3m-mail-goto-body-and-clear-body)
 248     (w3m-mail-position-point
 249      (prog1
 250          (point)
 251        (vm-mime-attach-buffer buffer content-type
 252                               (when charset (symbol-name charset))
 253                               url)))))
 254
 255 (defun w3m-mail-compose-with-semi (source url charset content-type
 256                                           to subject other-headers)
 257   "Compose a mail using SEMI."
 258   (require 'mime-edit)
 259   (let* ((content-type (and content-type
 260                             (split-string (downcase content-type) "/")))
 261          (basename (file-name-nondirectory (w3m-url-strip-query url)))
 262          (filename (cond
 263                     ((and (string-match "^[\t ]*$" basename)
 264                           (equal content-type '("text" "html")))
 265                      "index.html")
 266                     ((string-match "^[\t ]*$" basename)
 267                      "dummy")
 268                     (t
 269                      basename)))
 270          (type (or (nth 0 content-type) "text"))
 271          (subtype (or (nth 1 content-type) "html"))
 272          parameters
 273          (encoding "base64")
 274          (disposition-type "inline")
 275          disposition-params
 276          (guess (mime-find-file-type filename))
 277          (textp (string= type "text")))
 278     (when (and guess
 279                (string= (nth 0 guess) type)
 280                (string= (nth 1 guess) subtype))
 281       (setq parameters (nth 2 guess)
 282             encoding (or (nth 3 guess) encoding)
 283             disposition-type (or (nth 4 guess) disposition-type)
 284             disposition-params (nth 5 guess)))
 285     (compose-mail to subject other-headers)
 286     (w3m-mail-goto-body-and-clear-body)
 287     (let ((parameters-to-string
 288            (lambda (parameters)
 289              (when parameters
 290                (mapconcat
 291                 (lambda (parameter)
 292                   (concat "; " (car parameter)
 293                           "=" (if (eq (cdr parameter) 'file)
 294                                   (std11-wrap-as-quoted-string filename)
 295                                 (cdr parameter))))
 296                 parameters
 297                 ""))))
 298           (body (point))
 299           (edit-buffer (current-buffer))
 300           work-buffer)
 301       (with-temp-buffer
 302         (if textp
 303             (progn
 304               (insert source)
 305               (unless charset
 306                 (setq charset (detect-mime-charset-region (point-min)
 307                                                           (point-max))))
 308               (when charset
 309                 (setq parameters (cons (cons "charset" (symbol-name charset))
 310                                        parameters))
 311                 (encode-mime-charset-region (point-min) (point-max) charset)))
 312           (set-buffer-multibyte nil)
 313           (insert source))
 314         (mime-encode-region (point-min) (point-max) encoding)
 315         (setq work-buffer (current-buffer))
 316         (set-buffer edit-buffer)
 317         (mime-edit-insert-tag
 318          type subtype
 319          (concat (funcall parameters-to-string parameters)
 320                  "\nContent-Disposition: " disposition-type
 321                  (funcall parameters-to-string disposition-params)
 322                  "\nContent-Description: " url))
 323         (mime-edit-define-encoding encoding)
 324         (save-restriction
 325           (narrow-to-region (point) (point))
 326           (insert-buffer-substring work-buffer)
 327           (unless (bolp)
 328             (insert "\n"))
 329           (when (or (string= disposition-type "attachment")
 330                     (not (member encoding '("7bit" "8bit" "binary"))))
 331             (add-text-properties
 332              (point-min) (point-max) '(invisible t mime-edit-invisible t)))))
 333       (w3m-mail-position-point body))))
 334
 335 (defun w3m-mail (&optional headers)
 336   "Send a web page as a mail.
 337 By default the subject is generated according to `w3m-mail-subject'.
 338 The optional HEADERS is a list in which each element is a cons of the
 339 symbol of a header name and a string.  Here is an example to use this
 340 function:
 341
 342 \(w3m-mail '((To . \"foo@bar\") (Subject . \"The emacs-w3m home page\")))"
 343   (interactive (unless (eq major-mode 'w3m-mode)
 344                  (error "`%s' must be invoked from an emacs-w3m buffer"
 345                         this-command)))
 346   (let ((composer (cdr (assq mail-user-agent
 347                              w3m-mail-user-agent-compose-function-alist)))
 348         ;; Don't move the history position.
 349         (w3m-history-reuse-history-elements t)
 350         source base url charset content-type to subject)
 351     (cond
 352      ((not composer)
 353       (error "`%s' is not supported (yet) by `w3m-mail'" mail-user-agent))
 354      ((not w3m-current-url)
 355       (error "The source for this page is not available"))
 356      ((string-match "\\`about://source/" w3m-current-url)
 357       (setq source (buffer-string)
 358             base (w3m-mail-compute-base-url))
 359       (w3m-view-source)
 360       (setq url w3m-current-url
 361             charset (w3m-coding-system-to-charset w3m-current-coding-system)
 362             content-type (or (w3m-arrived-content-type w3m-current-url)
 363                              (w3m-content-type w3m-current-url)))
 364       (w3m-view-source))
 365      ((string-match "\\`about://header/" w3m-current-url)
 366       (w3m-view-source)
 367       (setq source (buffer-string)
 368             base (w3m-mail-compute-base-url))
 369       (w3m-view-source)
 370       (setq url w3m-current-url
 371             charset (w3m-coding-system-to-charset w3m-current-coding-system)
 372             content-type (or (w3m-arrived-content-type w3m-current-url)
 373                              (w3m-content-type w3m-current-url)))
 374       (w3m-view-header))
 375      (t
 376       (setq url w3m-current-url
 377             charset (w3m-coding-system-to-charset w3m-current-coding-system)
 378             content-type (or (w3m-arrived-content-type w3m-current-url)
 379                              (w3m-content-type w3m-current-url)))
 380       (w3m-view-source)
 381       (setq source (buffer-string)
 382             base (w3m-mail-compute-base-url))
 383       (w3m-view-source)))
 384     (when (and base (string= "text/html" content-type))
 385       (setq source (w3m-mail-embed-base-url source base)))
 386     (setq to (or (assq 'To headers) (assq 'to headers))
 387           subject (or (assq 'Subject headers) (assq 'subject headers)))
 388     (when (or to subject)
 389       (setq headers (delq to (delq subject (copy-sequence headers)))
 390             to (cdr to)
 391             subject (cdr subject)))
 392     (unless subject
 393       (setq subject (let ((w3m-current-url url)) (w3m-mail-make-subject))))
 394     (funcall composer source url charset content-type to subject headers)))
 395
 396 ;;; w3m-mail.el ends here