cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/mew-mime.el

   1 ;;; mew-mime.el --- MIME launcher for Mew
   2
   3 ;; Author:  Kazu Yamamoto <Kazu@Mew.org>
   4 ;; Created: Mar 23, 1997
   5 ;; Revised: Aug 31, 1999
   6
   7 ;;; Code:
   8
   9 (defconst mew-mime-version "mew-mime.el version 0.13")
  10
  11 (require 'mew)
  12
  13 ;;
  14 ;;
  15 ;;
  16
  17 (defmacro mew-attr-by-ct (ct)
  18   (` (mew-assoc-match2 (, ct) mew-mime-content-type 0)))
  19
  20 (defmacro mew-attr-by-file (ct)
  21   (` (mew-assoc-match2 (, ct) mew-mime-content-type 1)))
  22
  23 (defmacro mew-attr-get-ct (attr)
  24   (` (nth 0 (, attr))))
  25
  26 (defmacro mew-attr-get-cte (attr)
  27   (` (symbol-value (nth 2 (, attr)))))
  28
  29 (defun mew-attr-get-prog (attr)
  30   (let ((val (symbol-value (nth 3 attr))))
  31     (if (and (listp val) (equal 'if (car val)))
  32         (setq val (eval val)))
  33     (nth 0 val)))
  34
  35 (defun mew-attr-get-opt (attr)
  36   (let ((val (symbol-value (nth 3 attr))))
  37     (if (and (listp val) (equal 'if (car val)))
  38         (setq val (eval val)))
  39     (nth 1 val)))
  40
  41 (defun mew-attr-get-async (attr)
  42   (let ((val (symbol-value (nth 3 attr))))
  43     (if (and (listp val) (equal 'if (car val)))
  44         (setq val (eval val)))
  45     (nth 2 val)))
  46
  47 (defmacro mew-attr-get-icon (attr)
  48   (` (symbol-value (nth 4 (, attr)))))
  49
  50 (defvar mew-process-file-alist nil)
  51
  52 ;;
  53 ;;
  54 ;;
  55
  56 (defun mew-mime-start-process (program options file)
  57   (let ((process-connection-type mew-connection-type1) pro)
  58     (message "Starting %s ..." program)
  59     (setq pro (apply (function start-process)
  60                      (format "*mew %s*" program)
  61                      mew-buffer-tmp
  62                      program
  63                      (append options (list file))))
  64     (set-process-sentinel pro 'mew-mime-start-process-sentinel)
  65     (message "Starting %s ... done" program)
  66     (setq mew-process-file-alist (cons (cons pro file) mew-process-file-alist))
  67     )
  68   t ;; to next part
  69   )
  70
  71 (defun mew-mime-start-process-sentinel (process event)
  72   (let* ((al (assoc process mew-process-file-alist))
  73          (file (cdr al)))
  74     (if (and mew-delete-temp-file file) (delete-file file))
  75     (setq mew-process-file-alist (delete al mew-process-file-alist))))
  76
  77 (defun mew-mime-call-process (program options file)
  78   (message "Calling %s ..." program)
  79   (apply (function call-process) program file nil nil options)
  80   (message "Calling %s ... done" program)
  81   t ;; to next part
  82   )
  83
  84 ;;
  85 ;;
  86 ;;
  87
  88 (defun mew-mime-part (fullpart nums &optional execute)
  89   ;; called in message buffer
  90   ;; if nums is nil, it means singlepart.
  91   (let* ((syntax  (mew-syntax-get-entry fullpart nums))
  92          (begin   (mew-syntax-get-begin syntax))
  93          (end     (mew-syntax-get-end   syntax))
  94          (ctl     (mew-syntax-get-ct    syntax))
  95          (cte     (mew-syntax-get-cte   syntax))
  96          (ct      (mew-syntax-get-value  ctl))
  97          (cdpl    (mew-syntax-get-cdp syntax))
  98          (fname   (and cdpl (mew-syntax-get-param cdpl "filename")))
  99          (cd      (mew-syntax-get-cd syntax))
 100          (params  (mew-syntax-get-params ctl))
 101          (attr    (mew-attr-by-ct ct))
 102          (program (mew-attr-get-prog attr))
 103          (options (mew-attr-get-opt attr))
 104          (async   (mew-attr-get-async attr)))
 105     (if (symbolp program)
 106         (if (fboundp program)
 107             (cond
 108              ((eq program 'mew-mime-message/rfc822)
 109               (funcall program syntax)) ;; for recursive MIME
 110              ((eq program 'mew-mime-application/octet-stream)
 111               (funcall program begin end params ct cte fname))
 112              (t
 113               (funcall program begin end params execute))))
 114       (insert " ######  ######  #######  #####  ######     #    #     #\n"
 115               " #     # #     # #     # #     # #     #   # #   ##   ##\n"
 116               " #     # #     # #     # #       #     #  #   #  # # # #\n"
 117               " ######  ######  #     # #  #### ######  #     # #  #  #\n"
 118               " #       #   #   #     # #     # #   #   ####### #     #\n"
 119               " #       #    #  #     # #     # #    #  #     # #     #\n"
 120               " #       #     # #######  #####  #     # #     # #     #\n"
 121               "\n\n")
 122       (mew-insert "Content-Type:\t%s\n" ct)
 123       (mew-insert "Encoding: \t%s\n" cte)
 124       (mew-insert "Size:\t\t%d bytes\n"
 125                   (mew-region-bytes begin end (mew-current-get 'cache)))
 126       (mew-insert "Filename:\t%s\n" fname)
 127       (mew-insert "Description: \t%s\n" cd)
 128       (mew-insert "Program:\t%s\n" program)
 129       (if (not execute)
 130           (insert "\nTo execute this external command, type "
 131                   (substitute-command-keys
 132                    "'\\<mew-summary-mode-map>\\[mew-summary-execute-external]'.")
 133                   "\nTo save this part, type "
 134                   (substitute-command-keys
 135                    "'\\<mew-summary-mode-map>\\[mew-summary-save]'.")
 136                   "\nTo display this part in Message mode, type "
 137                   (substitute-command-keys
 138                    "'\\<mew-summary-mode-map>\\[mew-summary-insert]'."))
 139         (if (mew-which program exec-path)
 140             (let ((file (mew-make-temp-name fname)))
 141               (save-excursion
 142                 (set-buffer (mew-current-get 'cache))
 143                 ;; NEVER use call-process-region for privacy reasons
 144                 (mew-frwlet
 145                  mew-cs-dummy
 146                  (if (mew-ct-linebasep ct) mew-cs-outfile mew-cs-binary)
 147                  (write-region begin end file nil 'no-msg))
 148                 (if async
 149                     (mew-mime-start-process program options file)
 150                   (mew-mime-call-process program options file))))
 151           (message "Program %s is not found" program))))))
 152 ;;
 153 ;;
 154 ;;
 155
 156 (defun mew-mime-image (begin end format)
 157   (message "Loading image...")
 158   (cond
 159    ((eq format 'xbm) ;; use temporary file.
 160     (let ((temp-file-name (mew-make-temp-name))
 161           glyph)
 162       (save-excursion
 163         (set-buffer (mew-current-get 'cache))
 164         (write-region begin end temp-file-name nil 'no-msg)
 165         (set-buffer (mew-buffer-message))
 166         (mew-elet
 167          (setq glyph (make-glyph (vector
 168                                   'xbm
 169                                   :file
 170                                   temp-file-name)))
 171          (set-glyph-property glyph 'face 'x-face)
 172          (set-extent-end-glyph
 173           (mew-overlay-make (point-min) (point-min)) glyph)
 174          (if (file-exists-p temp-file-name)
 175              (delete-file temp-file-name))))))
 176    (t
 177     (set-buffer (mew-buffer-message))
 178     (mew-elet
 179      (set-extent-end-glyph (mew-overlay-make (point-min) (point-min))
 180                            (make-glyph (vector
 181                                         format
 182                                         :data
 183                                         (buffer-substring
 184                                          begin end
 185                                          (mew-current-get 'cache))))))))
 186   (message "Loading image...done"))
 187
 188 (defun mew-mime-image/jpeg (begin end &optional params execute)
 189   (mew-mime-image begin end 'jpeg))
 190
 191 (defun mew-mime-image/gif (begin end &optional params execute)
 192   (mew-mime-image begin end 'gif))
 193
 194 (defun mew-mime-image/xbm (begin end &optional params execute)
 195   (mew-mime-image begin end 'xbm))
 196
 197 (defun mew-mime-image/xpm (begin end &optional params execute)
 198   (mew-mime-image begin end 'xpm))
 199
 200 (defun mew-mime-image/png (begin end &optional params execute)
 201   (mew-mime-image begin end 'png))
 202
 203 (defun mew-mime-text/plain (begin end &optional params execute)
 204   (if (> end begin)
 205       (save-excursion
 206         (set-buffer (mew-buffer-message))
 207         (mew-elet
 208          (insert-buffer-substring (mew-current-get 'cache) begin end)
 209          ;; Highlight
 210          (mew-highlight-url)
 211          (mew-highlight-body))
 212         ;; Page breaks
 213         (if mew-break-pages
 214             (progn
 215               (goto-char (point-min))
 216               (mew-message-narrow-to-page))))))
 217
 218 (defun mew-mime-text/enriched (begin end &optional params execute)
 219   (if (> end begin)
 220       (save-excursion
 221         (set-buffer (mew-buffer-message))
 222         (mew-elet
 223          (insert-buffer-substring (mew-current-get 'cache) begin end)
 224          ;; Highlight
 225          (if mew-use-text/enriched
 226              (progn
 227                (format-decode-buffer 'text/enriched)
 228                (enriched-mode nil)))
 229          (mew-highlight-url)
 230          (mew-highlight-body))
 231         ;; Page breaks
 232         (if mew-break-pages
 233             (progn
 234               (goto-char (point-min))
 235               (mew-message-narrow-to-page))))))
 236
 237 (defun mew-prog-text/html-netscape-remote ()
 238   (list "-remote" (format mew-prog-text/html-netscape-remote-format file)))
 239
 240 (defun mew-mime-text/html (begin end &optional params execute)
 241   (mew-elet
 242    (insert " #     # ####### #     # #\n"
 243            " #     #    #    ##   ## #\n"
 244            " #     #    #    # # # # #\n"
 245            " #######    #    #  #  # #\n"
 246            " #     #    #    #     # #\n"
 247            " #     #    #    #     # #\n"
 248            " #     #    #    #     # #######\n"
 249            "\n\n")
 250    (mew-insert "Size:\t\t%d bytes\n"
 251                (mew-region-bytes begin end (mew-current-get 'cache)))
 252    (insert (format "Browser:\t%s\n"
 253                    (cond ((and (symbolp mew-prog-text/html)
 254                                (fboundp mew-prog-text/html))
 255                           (symbol-name mew-prog-text/html))
 256                          ((stringp mew-prog-text/html) mew-prog-text/html)
 257                          (t "none")))
 258            "\nTo save this part, type "
 259            (substitute-command-keys
 260             "'\\<mew-summary-mode-map>\\[mew-summary-save]'.")
 261            "\nTo display this part in Message mode, type "
 262            (substitute-command-keys
 263             "'\\<mew-summary-mode-map>\\[mew-summary-insert]'."))
 264    (if (null execute)
 265        (insert "\nTo display this text/html contents with browser, type "
 266                (substitute-command-keys
 267                 "'\\<mew-summary-mode-map>\\[mew-summary-execute-external]'."))
 268      (cond
 269       ((and (symbolp mew-prog-text/html) (fboundp mew-prog-text/html))
 270        (let (source)
 271          (set-buffer (mew-current-get 'cache))
 272          (setq source (buffer-substring begin end))
 273          (set-buffer (mew-buffer-message))
 274          (mew-erase-buffer)
 275          (insert source)
 276          (funcall mew-prog-text/html (point-min) (point-max))))
 277       ((stringp mew-prog-text/html)
 278        (if (> end begin)
 279            (let ((file (format "%s.html" (mew-make-temp-name))) arg)
 280              (save-excursion
 281                (set-buffer (mew-current-get 'cache))
 282                (if mew-prog-text/html-arg-hack
 283                    (setq arg (funcall mew-prog-text/html-arg-hack))
 284                  (setq arg (append mew-prog-text/html-arg (list file))))
 285                (mew-frwlet
 286                 mew-cs-dummy mew-cs-outfile
 287                 (write-region begin end file nil 'no-msg)
 288                 (apply (function start-process)
 289                        mew-prog-text/html mew-buffer-tmp mew-prog-text/html
 290                        arg))))))))))
 291
 292 (defun mew-mime-message/rfc822 (part)
 293   (mew-elet
 294    (let* ((hbeg (mew-syntax-get-begin part))
 295           (hend (mew-syntax-get-end   part))
 296           (cache (mew-current-get 'cache))
 297           (body (mew-syntax-get-part part)))
 298      (insert-buffer-substring cache hbeg hend)
 299      (mew-header-arrange (point-min) (point-max))
 300      (cond
 301       ;; Displaying the text/plain body or the first part of
 302       ;; top level multipart if it is text/plain.
 303       ;; see also mew-syntax-singlepart
 304       ((mew-syntax-singlepart-p body)
 305        (mew-mime-part body nil)) ;; nil is single
 306       ((mew-syntax-multipart-p body)
 307        (let* ((first (mew-syntax-get-part body))
 308               (ct (mew-syntax-get-value (mew-syntax-get-ct first) 'cap)))
 309          (if (mew-case-equal ct mew-ct-txt)
 310              (let* ((syntax (mew-syntax-get-entry body '(1)))
 311                     (begin   (mew-syntax-get-begin syntax))
 312                     (end     (mew-syntax-get-end   syntax)))
 313                (mew-mime-text/plain begin end)))))))))
 314
 315 (defun mew-mime-application/octet-stream (begin end &optional params ct cte fl)
 316   (mew-elet
 317    (insert " ######    ###   #     #    #    ######  #     #\n"
 318            " #     #    #    ##    #   # #   #     #  #   #\n"
 319            " #     #    #    # #   #  #   #  #     #   # #\n"
 320            " ######     #    #  #  # #     # ######     #\n"
 321            " #     #    #    #   # # ####### #   #      #\n"
 322            " #     #    #    #    ## #     # #    #     #\n"
 323            " ######    ###   #     # #     # #     #    #\n"
 324            "\n\n")
 325    (mew-insert "Content-Type:\t%s\n" ct)
 326    (mew-insert "Encoding: \t%s\n" cte)
 327    (and params
 328         (insert
 329          (format
 330           "Parameters:\t%s\n"
 331           (mapconcat
 332            (function mew-header-sanity-check-string)
 333            (mapcar (function (lambda (x) (concat (nth 0 x) "=" (nth 1 x))))
 334                    params)
 335            ", "))))
 336    (mew-insert "Size:\t\t%d bytes\n"
 337                (mew-region-bytes begin end (mew-current-get 'cache)))
 338    (mew-insert "Filename:\t%s\n" fl)
 339    (insert "\nTo save this part, type "
 340            (substitute-command-keys
 341             "'\\<mew-summary-mode-map>\\[mew-summary-save]'.")
 342            "\nTo display this part in Message mode, type "
 343            (substitute-command-keys
 344             "'\\<mew-summary-mode-map>\\[mew-summary-insert]'."))))
 345
 346 (defun mew-summary-insert ()
 347   "Insert row message or part into Message mode."
 348   (interactive)
 349   (let* ((ofld-msg (mew-current-get 'message))
 350          (msg (mew-summary-message-number))
 351          (part (mew-syntax-nums))
 352          (buf (buffer-name)))
 353     (if (or msg (not part))
 354         (mew-summary-display 'force)
 355       (unwind-protect
 356           (progn
 357             (mew-summary-toggle-disp-msg 'on)
 358             (mew-window-configure buf 'message)
 359             (set-buffer (mew-buffer-message))
 360             (mew-elet
 361              (let* ((syntax (mew-cache-decode-syntax (mew-cache-hit ofld-msg)))
 362                     (stx (mew-syntax-get-entry syntax part))
 363                     (begin (mew-syntax-get-begin stx))
 364                     (end (mew-syntax-get-end stx)))
 365                (mew-erase-buffer)
 366                (insert-buffer-substring (mew-current-get 'cache) begin end)
 367                (run-hooks 'mew-message-hook)
 368                (mew-message-set-end-of)
 369                (goto-char (point-min))))
 370             (mew-pop-to-buffer buf))))))
 371
 372 (provide 'mew-mime)
 373
 374 ;;; Copyright Notice:
 375
 376 ;; Copyright (C) 1997, 1998, 1999 Mew developing team.
 377 ;; All rights reserved.
 378
 379 ;; Redistribution and use in source and binary forms, with or without
 380 ;; modification, are permitted provided that the following conditions
 381 ;; are met:
 382 ;;
 383 ;; 1. Redistributions of source code must retain the above copyright
 384 ;;    notice, this list of conditions and the following disclaimer.
 385 ;; 2. Redistributions in binary form must reproduce the above copyright
 386 ;;    notice, this list of conditions and the following disclaimer in the
 387 ;;    documentation and/or other materials provided with the distribution.
 388 ;; 3. Neither the name of the team nor the names of its contributors
 389 ;;    may be used to endorse or promote products derived from this software
 390 ;;    without specific prior written permission.
 391 ;;
 392 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 393 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 394 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 395 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 396 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 397 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 398 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 399 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 400 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 401 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 402 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 403
 404 ;;; mew-mime.el ends here