wl/wl-mime.el

   1 ;;; wl-mime.el -- SEMI implementations of MIME processing on Wanderlust.
   2
   3 ;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
   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 GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (require 'mime-view)
  33 (require 'mime-edit)
  34 (require 'mime-play)
  35 (require 'mmelmo)
  36
  37 (eval-when-compile
  38   (defun-maybe Meadow-version ())
  39   (mapcar
  40    (function
  41     (lambda (symbol)
  42       (unless (boundp symbol)
  43         (set (make-local-variable symbol) nil))))
  44    '(xemacs-betaname
  45      xemacs-codename
  46      enable-multibyte-characters
  47      mule-version)))
  48
  49 ;;; Draft
  50
  51 (defalias 'wl-draft-editor-mode 'mime-edit-mode)
  52
  53 (defalias 'wl-draft-decode-message-in-buffer
  54   'mime-edit-decode-message-in-buffer)
  55
  56 (defun wl-draft-yank-current-message-entity ()
  57   "Yank currently displayed message entity.
  58 By setting following-method as yank-content."
  59   (let ((wl-draft-buffer (current-buffer))
  60         (mime-view-following-method-alist
  61          (list (cons 'mmelmo-original-mode
  62                      (function wl-draft-yank-to-draft-buffer))))
  63         (mime-preview-following-method-alist
  64          (list (cons 'mmelmo-original-mode
  65                      (function wl-draft-yank-to-draft-buffer)))))
  66     (if (get-buffer (wl-current-message-buffer))
  67         (save-excursion
  68           (save-restriction
  69             (set-buffer (wl-current-message-buffer))
  70             (widen)
  71             (mime-preview-follow-current-entity))))))
  72
  73 (defalias 'wl-draft-enclose-digest-region 'mime-edit-enclose-digest-region)
  74
  75 ;; SEMI 1.13.5 or later.
  76 ;; (mime-display-message
  77 ;;  MESSAGE &optional
  78 ;;  PREVIEW-BUFFER MOTHER DEFAULT-KEYMAP-OR-FUNCTION ORIGINAL-MAJOR-MODE)
  79 ;; SEMI 1.13.4 or earlier.
  80 ;; (mime-display-message
  81 ;;  MESSAGE &optional
  82 ;;  PREVIEW-BUFFER MOTHER DEFAULT-KEYMAP-OR-FUNCTION)
  83 (static-if (or (and mime-user-interface-product
  84                     (eq (nth 0 (aref mime-user-interface-product 1)) 1)
  85                     (>= (nth 1 (aref mime-user-interface-product 1)) 14))
  86                (and mime-user-interface-product
  87                     (eq (nth 0 (aref mime-user-interface-product 1)) 1)
  88                     (eq (nth 1 (aref mime-user-interface-product 1)) 13)
  89                     (>= (nth 2 (aref mime-user-interface-product 1)) 5)))
  90     ;; Has original-major-mode optional argument.
  91     (defalias 'wl-mime-display-message 'mime-display-message)
  92   (defmacro wl-mime-display-message (message &optional
  93                                              preview-buffer mother
  94                                              default-keymap-or-function
  95                                              original-major-mode)
  96     (` (mime-display-message (, message) (, preview-buffer) (, mother)
  97                              (, default-keymap-or-function))))
  98   ;; User agent field of XEmacs has problem on SEMI 1.13.4 or earlier.
  99   (setq mime-edit-user-agent-value
 100         (concat
 101          (mime-product-name mime-user-interface-product) "/"
 102          (mapconcat
 103           #'number-to-string
 104           (mime-product-version mime-user-interface-product) ".")
 105          " (" (mime-product-code-name mime-user-interface-product)
 106          ") " (mime-product-name mime-library-product)
 107          "/" (mapconcat #'number-to-string
 108                         (mime-product-version mime-library-product) ".")
 109          " (" (mime-product-code-name mime-library-product) ") "
 110          (if (featurep 'xemacs)
 111              (concat
 112               (if (featurep 'mule) "MULE")
 113               " XEmacs"
 114               (if (string-match "\\s +\\((\\|\\\"\\)" emacs-version)
 115                   (concat "/" (substring emacs-version 0
 116                                          (match-beginning 0))
 117                           (if (and (boundp 'xemacs-betaname)
 118                                    ;; It does not exist in XEmacs
 119                                    ;; versions prior to 20.3.
 120                                    xemacs-betaname)
 121                               (concat " " xemacs-betaname)
 122                             "")
 123                           " (" xemacs-codename ") ("
 124                           system-configuration ")")
 125                 " (" emacs-version ")"))
 126            (let ((ver (if (string-match "\\.[0-9]+$" emacs-version)
 127                           (substring emacs-version 0 (match-beginning 0))
 128                         emacs-version)))
 129              (if (featurep 'mule)
 130                  (if (boundp 'enable-multibyte-characters)
 131                      (concat "Emacs/" ver
 132                              " (" system-configuration ")"
 133                              (if enable-multibyte-characters
 134                                  (concat " MULE/" mule-version)
 135                                " (with unibyte mode)")
 136                              (if (featurep 'meadow)
 137                                  (let ((mver (Meadow-version)))
 138                                    (if (string-match "^Meadow-" mver)
 139                                        (concat " Meadow/"
 140                                                (substring mver
 141                                                           (match-end 0)))))))
 142                    (concat "MULE/" mule-version
 143                            " (based on Emacs " ver ")"))
 144                (concat "Emacs/" ver " (" system-configuration ")")))))))
 145
 146 ;; FLIM 1.12.7
 147 ;; (mime-read-field FIELD-NAME &optional ENTITY)
 148 ;; FLIM 1.13.2 or later
 149 ;; (mime-entity-read-field ENTITY FIELD-NAME)
 150 (static-if (fboundp 'mime-entity-read-field)
 151     (defalias 'wl-mime-entity-read-field 'mime-entity-read-field)
 152   (defmacro wl-mime-entity-read-field (entity field-name)
 153     (` (mime-read-field (, field-name) (, entity)))))
 154
 155 (defun wl-draft-preview-message ()
 156   (interactive)
 157   (let ((mime-display-header-hook 'wl-highlight-headers)
 158         mime-view-ignored-field-list ; all header.
 159         (mime-edit-translate-buffer-hook (append
 160                                           (list 'wl-draft-config-exec)
 161                                           mime-edit-translate-buffer-hook)))
 162     (mime-edit-preview-message)
 163     (let ((buffer-read-only nil))
 164       (when wl-highlight-body-too
 165         (wl-highlight-body))
 166       (run-hooks 'wl-draft-preview-message-hook))))
 167
 168 (defalias 'wl-draft-caesar-region  'mule-caesar-region)
 169
 170 (defalias 'wl-draft-insert-message 'mime-edit-insert-message)
 171
 172 (defalias 'wl-draft-insert-mail 'mime-edit-insert-mail)
 173
 174 ;;; Message
 175
 176 (defun wl-message-decode-mode (outbuf inbuf)
 177   (let ((mime-view-content-header-filter-hook 'wl-highlight-headers)
 178         (mime-display-header-hook 'wl-highlight-headers))
 179     (mime-view-mode nil nil nil inbuf outbuf)))
 180
 181 (defun wl-message-decode-with-all-header (outbuf inbuf)
 182   (let ((mime-view-ignored-field-regexp "^:$")
 183         (mime-view-content-header-filter-hook 'wl-highlight-headers)
 184         (mime-display-header-hook 'wl-highlight-headers)
 185         mime-view-ignored-field-list)
 186     (mime-view-mode nil nil nil inbuf outbuf)))
 187
 188 (defun wl-message-delete-mime-out-buf ()
 189   (let (mime-out-buf mime-out-win)
 190     (if (setq mime-out-buf (get-buffer mime-echo-buffer-name))
 191         (if (setq mime-out-win (get-buffer-window mime-out-buf))
 192             (delete-window mime-out-win)))))
 193
 194 (defun wl-message-request-partial (folder number)
 195   (elmo-set-work-buf
 196    (elmo-read-msg-no-cache folder number (current-buffer))
 197    (mime-parse-buffer nil))); 'mime-buffer-entity)))
 198
 199 (defalias 'wl-message-read            'mime-preview-scroll-up-entity)
 200 (defalias 'wl-message-next-content    'mime-preview-move-to-next)
 201 (defalias 'wl-message-prev-content    'mime-preview-move-to-previous)
 202 (defalias 'wl-message-play-content    'mime-preview-play-current-entity)
 203 (defalias 'wl-message-extract-content 'mime-preview-extract-current-entity)
 204 (defalias 'wl-message-quit            'mime-preview-quit)
 205 (defalias 'wl-message-button-dispatcher 'mime-button-dispatcher)
 206
 207 ;;; Summary
 208 (defun wl-summary-burst-subr (children target number)
 209   ;; returns new number.
 210   (let (content-type message-entity granch)
 211     (while children
 212       (setq content-type (mime-entity-content-type (car children)))
 213       (if (eq (cdr (assq 'type content-type)) 'multipart)
 214           (setq number (wl-summary-burst-subr
 215                         (mime-entity-children (car children))
 216                         target
 217                         number))
 218         (when (and (eq (cdr (assq 'type content-type)) 'message)
 219                    (eq (cdr (assq 'subtype content-type)) 'rfc822))
 220           (message (format "Bursting...%s" (setq number (+ 1 number))))
 221           (setq message-entity
 222                 (car (mime-entity-children (car children))))
 223           (save-restriction
 224             (narrow-to-region (mime-entity-point-min message-entity)
 225                               (mime-entity-point-max message-entity))
 226             (elmo-append-msg target
 227                              ;;(mime-entity-content (car children))))
 228                              (buffer-substring (point-min) (point-max))
 229                              (std11-field-body "Message-ID")))))
 230       (setq children (cdr children)))
 231     number))
 232
 233 (defun wl-summary-burst ()
 234   (interactive)
 235   (let ((raw-buf (wl-message-get-original-buffer))
 236         children message-entity content-type target)
 237     (save-excursion
 238       (setq target wl-summary-buffer-folder-name)
 239       (while (not (elmo-folder-writable-p target))
 240         (setq target
 241               (wl-summary-read-folder wl-default-folder "to extract to")))
 242       (wl-summary-set-message-buffer-or-redisplay)
 243       (save-excursion
 244         (set-buffer (get-buffer wl-message-buf-name))
 245         (setq message-entity (get-text-property (point-min) 'mime-view-entity)))
 246       (set-buffer raw-buf)
 247       (setq children (mime-entity-children message-entity))
 248       (when children
 249         (message "Bursting...")
 250         (wl-summary-burst-subr children target 0)
 251         (message "Bursting...done."))
 252       (if (elmo-folder-plugged-p target)
 253           (elmo-commit target)))
 254     (wl-summary-sync-update3)))
 255
 256 ;; internal variable.
 257 (defvar wl-mime-save-dir nil "Last saved directory.")
 258 ;;; Yet another save method.
 259 (defun wl-mime-save-content (entity situation)
 260   (let ((filename (read-file-name "Save to file: "
 261                                   (expand-file-name
 262                                    (or (mime-entity-safe-filename entity)
 263                                        ".")
 264                                    (or wl-mime-save-dir
 265                                        wl-tmp-dir)))))
 266     (while (file-directory-p filename)
 267       (setq filename (read-file-name "Please set filename (not directory): "
 268                                      filename)))
 269     (if (file-exists-p filename)
 270         (or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
 271             (error "Not saved")))
 272     (setq wl-mime-save-dir (file-name-directory filename))
 273     (mime-write-entity-content entity filename)))
 274
 275 ;;; Yet another combine method.
 276 (defun wl-mime-combine-message/partial-pieces (entity situation)
 277   "Internal method for wl to combine message/partial messages
 278 automatically."
 279   (interactive)
 280   (let* ((msgdb (save-excursion
 281                   (set-buffer wl-message-buffer-cur-summary-buffer)
 282                   wl-summary-buffer-msgdb))
 283          (mime-display-header-hook 'wl-highlight-headers)
 284          (folder wl-message-buffer-cur-folder)
 285          (id (or (cdr (assoc "id" situation)) ""))
 286          (mother (current-buffer))
 287          subject-id overviews
 288          (root-dir (expand-file-name
 289                     (concat "m-prts-" (user-login-name))
 290                     temporary-file-directory))
 291          full-file)
 292     (setq root-dir (concat root-dir "/" (replace-as-filename id)))
 293     (setq full-file (concat root-dir "/FULL"))
 294     (if (or (file-exists-p full-file)
 295             (not (y-or-n-p "Merge partials?")))
 296         (with-current-buffer mother
 297           (mime-store-message/partial-piece entity situation))
 298       (setq subject-id
 299             (eword-decode-string
 300              (decode-mime-charset-string
 301               (wl-mime-entity-read-field entity 'Subject)
 302               wl-summary-buffer-mime-charset)))
 303       (if (string-match "[0-9\n]+" subject-id)
 304           (setq subject-id (substring subject-id 0 (match-beginning 0))))
 305       (setq overviews (elmo-msgdb-get-overview msgdb))
 306       (catch 'tag
 307         (while overviews
 308           (when (string-match
 309                  (regexp-quote subject-id)
 310                  (elmo-msgdb-overview-entity-get-subject (car overviews)))
 311             (let* ((message
 312                     ;; request message at the cursor in Subject buffer.
 313                     (wl-message-request-partial
 314                      folder
 315                      (elmo-msgdb-overview-entity-get-number (car overviews))))
 316                    (situation (mime-entity-situation message))
 317                    (the-id (or (cdr (assoc "id" situation)) "")))
 318               (when (string= (downcase the-id)
 319                              (downcase id))
 320                 (with-current-buffer mother
 321                   (mime-store-message/partial-piece message situation))
 322                 (if (file-exists-p full-file)
 323                     (throw 'tag nil)))))
 324           (setq overviews (cdr overviews)))
 325         (message "Not all partials found.")))))
 326
 327 ;;; Setup methods.
 328 (defun wl-mime-setup ()
 329   (set-alist 'mime-preview-quitting-method-alist
 330              'mmelmo-original-mode 'wl-message-exit)
 331   (set-alist 'mime-view-over-to-previous-method-alist
 332              'mmelmo-original-mode 'wl-message-exit)
 333   (set-alist 'mime-view-over-to-next-method-alist
 334              'mmelmo-original-mode 'wl-message-exit)
 335   (set-alist 'mime-preview-over-to-previous-method-alist
 336              'mmelmo-original-mode 'wl-message-exit)
 337   (set-alist 'mime-preview-over-to-next-method-alist
 338              'mmelmo-original-mode 'wl-message-exit)
 339   (add-hook 'wl-summary-redisplay-hook 'wl-message-delete-mime-out-buf)
 340   (add-hook 'wl-message-exit-hook 'wl-message-delete-mime-out-buf)
 341
 342   (ctree-set-calist-strictly
 343    'mime-acting-condition
 344    '((type . message) (subtype . partial)
 345      (method .  wl-mime-combine-message/partial-pieces)
 346      (request-partial-message-method . wl-message-request-partial)
 347      (major-mode . mmelmo-original-mode)))
 348   (ctree-set-calist-strictly
 349    'mime-acting-condition
 350    '((mode . "extract")
 351      (major-mode . mmelmo-original-mode)
 352      (method . wl-mime-save-content)))
 353   (set-alist 'mime-preview-following-method-alist
 354              'mmelmo-original-mode
 355              (function wl-message-follow-current-entity))
 356   (set-alist 'mime-view-following-method-alist
 357              'mmelmo-original-mode
 358              (function wl-message-follow-current-entity))
 359   (set-alist 'mime-edit-message-inserter-alist
 360              'wl-draft-mode (function wl-draft-insert-current-message))
 361   (set-alist 'mime-edit-mail-inserter-alist
 362              'wl-draft-mode (function wl-draft-insert-get-message))
 363   (set-alist 'mime-edit-split-message-sender-alist
 364              'wl-draft-mode
 365              (cdr (assq 'mail-mode mime-edit-split-message-sender-alist)))
 366   (set-alist 'mime-raw-representation-type-alist
 367              'mmelmo-original-mode 'binary)
 368   ;; Sort and highlight header fields.
 369   (setq mmelmo-sort-field-list wl-message-sort-field-list)
 370   (add-hook 'mmelmo-header-inserted-hook 'wl-highlight-headers)
 371   (add-hook 'mmelmo-entity-content-inserted-hook 'wl-highlight-body))
 372
 373
 374 (provide 'wl-mime)
 375
 376 ;;; wl-mime.el ends here