tm-view.el

   1 ;;;
   2 ;;; tm-view.el --- interactive MIME viewer for GNU Emacs
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1994,1995 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author:   MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Keywords: mail, news, MIME, multimedia
   9 ;;;
  10 ;;; This file is part of tm (Tools for MIME).
  11 ;;;
  12
  13 ;;; @ require modules
  14 ;;;
  15
  16 (require 'tl-str)
  17 (require 'tl-list)
  18 (require 'tl-atype)
  19 (require 'tl-misc)
  20 (require 'tl-header)
  21 (require 'mel)
  22 (require 'tiny-mime)
  23 (require 'tm-def)
  24
  25
  26 ;;; @ version
  27 ;;;
  28
  29 (defconst mime-viewer/RCS-ID
  30   "$Id: tm-view.el,v 6.88 1995/09/21 02:33:28 morioka Exp $")
  31
  32 (defconst mime-viewer/version (get-version-string mime-viewer/RCS-ID))
  33 (defconst mime/viewer-version mime-viewer/version)
  34
  35
  36 ;;; @ constants
  37 ;;;
  38
  39 (defconst mime/content-type-subtype-regexp
  40   (concat mime/token-regexp "/" mime/token-regexp))
  41 (defconst mime/content-parameter-value-regexp
  42   (concat "\\("
  43           message/quoted-string-regexp
  44           "\\|[^; \t\n]*\\)"))
  45
  46 (defconst mime/output-buffer-name "*MIME-out*")
  47 (defconst mime/decoding-buffer-name "*MIME-decoding*")
  48
  49
  50 ;;; @ variables
  51 ;;;
  52
  53 (defvar mime/content-decoding-condition
  54   '(((type . "text/plain")
  55      (method "tm-plain" nil 'file 'type 'encoding 'mode 'name))
  56     ;;((type . "text/x-latex")
  57     ;; (method "tm-latex" nil 'file 'type 'encoding 'mode 'name))
  58     ((type . "audio/basic")
  59      (method "tm-au"    nil 'file 'type 'encoding 'mode 'name))
  60     ((type . "image/gif")
  61      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  62     ((type . "image/jpeg")
  63      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  64     ((type . "image/tiff")
  65      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  66     ((type . "image/x-tiff")
  67      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  68     ((type . "image/x-xbm")
  69      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  70     ((type . "image/x-pic")
  71      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  72     ((type . "video/mpeg")
  73      (method "tm-mpeg"  nil 'file 'type 'encoding 'mode 'name))
  74     ((type . "application/octet-stream")
  75      (method "tm-file"  nil 'file 'type 'encoding 'mode 'name))
  76     ;;((type . "message/external-body")
  77     ;; (method "xterm" nil
  78     ;;         "-e" "showexternal"
  79     ;;         'file '"access-type" '"name" '"site" '"directory"))
  80     ((type . "message/partial")
  81      (method . mime/decode-message/partial-region))
  82     ((method "metamail" t
  83              "-m" "tm" "-x" "-d" "-z" "-e" 'file)(mode . "play"))
  84     ((method "tm-file"  nil 'file 'type 'encoding 'mode 'name)
  85      (mode . "extract"))
  86     ))
  87
  88 (defvar mime-viewer/childrens-header-showing-Content-Type-list
  89   '("message/rfc822" "message/news"))
  90
  91 (defvar mime-viewer/default-showing-Content-Type-list
  92   '("text/plain" "text/richtext" "text/enriched"
  93     "text/x-latex" "application/x-latex"
  94     "application/octet-stream" nil
  95     "application/x-selection" "application/x-comment"))
  96
  97 (defvar mime-viewer/content-subject-omitting-Content-Type-list
  98   '("application/x-selection"))
  99
 100 (defvar mime-viewer/uuencode-encoding-name-list '("x-uue" "x-uuencode"))
 101
 102 (defvar mime-viewer/ignored-field-list
 103   '("Received" "Return-Path" "Replied" "Errors-To"
 104     "Lines" "Sender" "Path" "Nntp-Posting-Host"
 105     "Content-Type" "Precedence" "X-Face"))
 106
 107 (defvar mime-viewer/ignored-field-regexp)
 108
 109 (defvar mime-viewer/decoding-mode "play" "MIME body decoding mode")
 110
 111 (defvar mime-viewer/file-name-char-regexp "[A-Za-z0-9+_-]")
 112
 113 (defvar mime-viewer/file-name-regexp-1
 114   (concat mime-viewer/file-name-char-regexp "+\\."
 115           mime-viewer/file-name-char-regexp "+"))
 116
 117 (defvar mime-viewer/file-name-regexp-2
 118   (concat (regexp-* mime-viewer/file-name-char-regexp)
 119           "\\(\\." mime-viewer/file-name-char-regexp "+\\)*"))
 120
 121 (defvar mime-viewer/announcement-for-message/partial
 122   (if (and (>= emacs-major-version 19) window-system)
 123       "\
 124 \[[ This is message/partial style split message. ]]
 125 \[[ Please press `v' key in this buffer          ]]
 126 \[[ or click here by mouse button-2.             ]]"
 127     "\
 128 \[[ This is message/partial style split message. ]]
 129 \[[ Please press `v' key in this buffer.         ]]"
 130     ))
 131
 132
 133 ;;; @@ predicate functions
 134 ;;;
 135
 136 (defun mime-viewer/header-visible-p (cnum cinfo &optional ctype)
 137   (or (eq cnum t)
 138       (progn
 139         (setq ctype
 140               (mime::content-info/type
 141                (mime-article/cnum-to-cinfo (butlast cnum) cinfo)
 142                ))
 143         (member ctype mime-viewer/childrens-header-showing-Content-Type-list)
 144         )))
 145
 146 (defun mime-viewer/body-visible-p (cnum cinfo &optional ctype)
 147   (let (ccinfo)
 148     (or ctype
 149         (setq ctype
 150               (mime::content-info/type
 151                (setq ccinfo (mime-article/cnum-to-cinfo cnum cinfo))
 152                ))
 153         )
 154     (and (member ctype mime-viewer/default-showing-Content-Type-list)
 155          (if (string-equal ctype "application/octet-stream")
 156              (progn
 157                (or ccinfo
 158                    (setq ccinfo (mime-article/cnum-to-cinfo cnum cinfo))
 159                    )
 160                (member (mime::content-info/encoding ccinfo)
 161                        '(nil "7bit" "8bit"))
 162                )
 163            t))
 164     ))
 165
 166
 167 ;;; @@ content subject
 168 ;;;
 169
 170 (defun mime-viewer/insert-content-subject
 171   (cnum cinfo ctype params subj)
 172   (save-restriction
 173     (narrow-to-region (point)(point))
 174     (insert
 175      (let ((access-type (assoc "access-type" params))
 176            (num (or (assoc-value "x-part-number" params)
 177                     (if (listp cnum)
 178                         (mapconcat (function
 179                                     (lambda (num)
 180                                       (format "%s" (+ num 1))
 181                                       ))
 182                                    cnum ".")
 183                       "0"))
 184                 ))
 185        (if access-type
 186            (let ((server (assoc "server" params)))
 187              (setq access-type (cdr access-type))
 188              (if server
 189                  (format "[%s %s ([%s] %s)]\n" num subj
 190                          access-type (cdr server))
 191                (let ((site (assoc-value "site" params))
 192                      (dir (assoc-value "directory" params))
 193                      )
 194                  (format "[%s %s ([%s] %s:%s)]\n" num subj
 195                          access-type site dir)
 196                  )))
 197          (format "[%s %s (%s)]\n" num subj ctype)
 198          )))
 199     (tm:add-button (point-min)(1- (point-max))
 200                    (function mime-viewer/play-content))
 201     ))
 202
 203 (defun mime-viewer/default-content-subject-function
 204   (cnum cinfo ctype params subj)
 205   (if (and (listp cnum)
 206            (not (member
 207                  ctype
 208                  mime-viewer/content-subject-omitting-Content-Type-list))
 209            )
 210       (mime-viewer/insert-content-subject
 211        cnum cinfo ctype params subj)
 212     ))
 213
 214 (defvar mime-viewer/content-subject-function
 215   (function mime-viewer/default-content-subject-function))
 216
 217
 218 ;;; @@ content header filter
 219 ;;;
 220
 221 ;;; @@@ X-Face
 222 ;;;
 223
 224 ;; hack from Gnus 5.0.4.
 225
 226 (defvar mime-viewer/x-face-command
 227   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
 228   "String to be executed to display an X-Face field.
 229 The command will be executed in a sub-shell asynchronously.
 230 The compressed face will be piped to this command.")
 231
 232 (defun mime-viewer/x-face-function ()
 233   "Function to display X-Face field. You can redefine to customize."
 234   (goto-char (point-min))
 235   (if (re-search-forward "^X-Face:[ \t]*" nil t)
 236       (let ((beg (match-end 0))
 237             (end (message/field-end))
 238             )
 239         (call-process-region beg end "sh" nil 0 nil
 240                              "-c" mime-viewer/x-face-command)
 241         )))
 242
 243 (defun mime-viewer/default-content-header-filter ()
 244   (mime-viewer/x-face-function)
 245   (goto-char (point-min))
 246   (while (and (re-search-forward
 247                (concat "^" mime-viewer/ignored-field-regexp ":")
 248                nil t)
 249               (progn
 250                 (delete-region
 251                  (match-beginning 0)
 252                  (save-excursion
 253                    (and
 254                     (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
 255                     (match-beginning 0)
 256                     )))
 257                 t)))
 258   (mime/decode-message-header)
 259   )
 260
 261 (defvar mime-viewer/content-header-filter-alist nil)
 262
 263
 264 ;;; @@ content filter
 265 ;;;
 266
 267 (defvar mime-viewer/content-filter-alist
 268   '(("text/plain" . mime-viewer/filter-text/plain)
 269     (nil . mime-viewer/filter-text/plain)))
 270
 271 (defun mime-viewer/default-content-filter (cnum cinfo ctype params subj)
 272   )
 273
 274
 275 ;;; @@ content separator
 276 ;;;
 277
 278 (defun mime-viewer/default-content-separator (cnum cinfo ctype params subj)
 279   (if (and (not (mime-viewer/header-visible-p cnum cinfo ctype))
 280            (not (mime-viewer/body-visible-p cnum cinfo ctype))
 281            )
 282       (progn
 283         (goto-char (point-max))
 284         (insert "\n")
 285         )))
 286
 287
 288 ;;; @@ buffer local variables
 289 ;;;
 290
 291 (defvar mime::article/content-info nil)
 292 (defvar mime::article/preview-buffer nil)
 293
 294 (defvar mime::preview/article-buffer nil)
 295 (defvar mime::preview/content-list nil)
 296 (defvar mime::preview/original-major-mode nil)
 297
 298
 299 ;;; @@ quitting method
 300 ;;;
 301
 302 (defvar mime-viewer/quitting-method-alist
 303   '((mime/show-message-mode
 304      . (lambda ()
 305          (set-window-configuration
 306           mime/show-mode-old-window-configuration)
 307          (let ((mother mime/mother-buffer))
 308            (kill-buffer
 309             (mime::preview-content-info/buffer
 310              (car mime::preview/content-list)))
 311            (mime-viewer/kill-buffer)
 312            (pop-to-buffer mother)
 313            (goto-char (point-min))
 314            (mime-viewer/up-content)
 315            )))
 316     ))
 317
 318
 319 ;;; @ data structures
 320 ;;;
 321
 322 ;;; @@ content-info
 323 ;;;
 324 (define-structure mime::content-info
 325   point-min point-max type parameters encoding children)
 326
 327 ;;; @@ preview-content-info
 328 ;;;
 329 (define-structure mime::preview-content-info
 330   point-min point-max buffer content-info)
 331
 332
 333 ;;; @ parser
 334 ;;;
 335
 336 (defun mime-viewer/parse-message (&optional ctl encoding)
 337   (make-variable-buffer-local 'mime::article/content-info)
 338   (setq mime::article/content-info (mime-viewer/parse ctl encoding))
 339   (let ((ret (mime-viewer/make-preview-buffer)))
 340     (make-variable-buffer-local 'mime::article/preview-buffer)
 341     (setq mime::article/preview-buffer (car ret))
 342     ret))
 343
 344 (defun mime-viewer/parse (&optional ctl encoding)
 345   (save-excursion
 346     (save-restriction
 347       (setq ctl (or (mime/Content-Type)
 348                     ctl))
 349       (setq encoding (or (mime/Content-Transfer-Encoding)
 350                          encoding))
 351       (let ((ctype (car ctl))
 352             (params (cdr ctl))
 353             )
 354         (let ((boundary (assoc "boundary" params)))
 355           (goto-char (point-min))
 356           (search-forward "\n\n" nil t)
 357           (cond (boundary
 358                  (save-excursion
 359                    (save-restriction
 360                      (setq boundary
 361                            (message/strip-quoted-string (cdr boundary)))
 362                      (narrow-to-region
 363                       (point-min)
 364                       (if (re-search-forward
 365                            (concat "^--" (regexp-quote boundary) "--$") nil t)
 366                           (match-beginning 0)
 367                         (point-max)
 368                         ))
 369                      (mime-viewer/parse-multipart
 370                       (point-min)
 371                       (point-max)
 372                       boundary ctype params encoding)
 373                      )))
 374                 ((string= ctype "message/rfc822")
 375                  (mime::content-info/create
 376                   (point-min) (point-max)
 377                   ctype params encoding
 378                   (save-excursion
 379                     (save-restriction
 380                       (narrow-to-region (progn
 381                                           (goto-char (point-min))
 382                                           (if (re-search-forward "^$" nil t)
 383                                               (+ (match-end 0) 1)
 384                                             (point-min)
 385                                             ))
 386                                         (point-max))
 387                       (list (mime-viewer/parse))
 388                       ))
 389                   )
 390                  )
 391                 (t
 392                  (mime::content-info/create (point-min) (point-max)
 393                                           ctype params encoding nil)
 394                  ))
 395           )))))
 396
 397 (defun mime-viewer/parse-multipart (beg end boundary ctype params encoding)
 398   (let ((sep (concat "^--" (regexp-quote boundary) "$"))
 399         cb ce ct ret ncb children)
 400     (save-excursion
 401       (save-restriction
 402         (narrow-to-region beg end)
 403         (goto-char (point-min))
 404         (search-forward (concat "--" boundary "\n") nil t)
 405         (setq cb (match-end 0))
 406         (while (re-search-forward sep nil t)
 407           (setq ce (match-beginning 0))
 408           (setq ncb (match-end 0))
 409           (save-excursion
 410             (save-restriction
 411               (narrow-to-region cb ce)
 412               (setq ret (apply (function mime-viewer/parse)
 413                                (cond ((string= ctype "multipart/digest")
 414                                       '(("message/rfc822") "7bit")
 415                                       )
 416                                      (t '(("text/plain") "7bit"))
 417                                      )
 418                                ))
 419               ))
 420           (setq children (nconc children (list ret)))
 421           (goto-char (mime::content-info/point-max ret))
 422           (search-forward (concat "--" boundary "\n") nil t)
 423           (goto-char (setq cb (match-end 0)))
 424           )
 425         (setq ce (point-max))
 426         (save-excursion
 427           (save-restriction
 428             (narrow-to-region cb ce)
 429             (setq ret (apply (function mime-viewer/parse)
 430                              (cond ((string= ctype "multipart/mixed")
 431                                     '(("text/plain") "7bit")
 432                                     )
 433                                    ((string= ctype "multipart/digest")
 434                                     '(("message/rfc822") "7bit")
 435                                     ))
 436                              ))
 437             ))
 438         (setq children (nconc children (list ret)))
 439         ))
 440     (setq beg (point-min))
 441     (goto-char beg)
 442     (mime::content-info/create beg end ctype params encoding children)
 443     ))
 444
 445 (defun mime::parse-parameter (str)
 446   (let ((ret (message::parse "\;" str)))
 447     (if ret
 448         (if (setq ret
 449                   (message::parse mime/token-regexp
 450                                   (message::parsed/rest ret)))
 451             (let ((parameter (downcase (message::parsed/matched ret))))
 452               (if (setq ret (message::parse "=" (message::parsed/rest ret)))
 453                   (if (setq ret
 454                             (message::parse
 455                              mime/content-parameter-value-regexp
 456                              (message::parsed/rest ret)))
 457                       (message::make-parsed
 458                        (cons parameter
 459                              (message/strip-quoted-string
 460                               (message::parsed/matched ret))
 461                              )
 462                        (message::parsed/rest ret)
 463                        )
 464                     )))))))
 465
 466 (defun mime::parse-field-body/Content-Type (str)
 467   (let ((ret (message::parse mime/content-type-subtype-regexp str)))
 468     (if ret
 469         (let ((ctype (downcase (message::parsed/matched ret)))
 470               dest)
 471           (while (progn
 472                    (setq str (message::parsed/rest ret))
 473                    (setq ret (mime::parse-parameter str))
 474                    )
 475             (setq dest (cons (message::parsed/matched ret) dest))
 476             )
 477           (if (string-match "^[ \t]*$" str)
 478               (cons ctype (reverse dest))
 479             )))))
 480
 481 (defun mime/Content-Type (&optional port)
 482   "Read field-body of Content-Type field from PORT and parse it.
 483 PORT must be buffer or string. If PORT is omitted,
 484 it is regarded as current-buffer. [tm-view]"
 485   (or port
 486       (setq port (current-buffer))
 487       )
 488   (let ((str (if (get-buffer port)
 489                  (save-window-excursion
 490                    (switch-to-buffer port)
 491                    (message/get-field-body "Content-Type")
 492                    )
 493                port)
 494              ))
 495     (if str
 496         (mime::parse-field-body/Content-Type
 497          (message/unfolding-string str))
 498       )))
 499
 500 (defun mime/Content-Transfer-Encoding (&optional default-encoding)
 501   (let ((str (message/get-field-body "Content-Transfer-Encoding")))
 502     (if str
 503         (downcase str)
 504       default-encoding)
 505       ))
 506
 507 (defun mime-viewer/get-subject (param)
 508   (if (member (cdr (assq 'encoding param))
 509               mime-viewer/uuencode-encoding-name-list)
 510       (save-excursion
 511         (or (if (re-search-forward "^begin [0-9]+ " nil t)
 512                 (if (looking-at ".+$")
 513                     (buffer-substring (match-beginning 0)(match-end 0))
 514                   ))
 515             ""))
 516     (let (ret)
 517       (or (and (setq ret (assoc "name" param))
 518                (message/strip-quoted-string (cdr ret))
 519                )
 520           (and (setq ret (assoc "x-name" param))
 521                (message/strip-quoted-string (cdr ret))
 522                )
 523
 524           (save-excursion
 525             (save-restriction
 526               (narrow-to-region (point-min)
 527                                 (or (and (search-forward "\n\n" nil t)
 528                                          (match-beginning 0)
 529                                          )
 530                                     (point-max)))
 531               (or
 532                (message/get-field-body "Content-Description")
 533                (message/get-field-body "Subject")
 534                )))
 535           ""))
 536     ))
 537
 538 (defun mime-viewer/get-name (param)
 539   (let ((str (mime-viewer/get-subject param)))
 540     (if (string-match " " str)
 541         (if (or (string-match mime-viewer/file-name-regexp-1 str)
 542                 (string-match mime-viewer/file-name-regexp-2 str))
 543             (substring str (match-beginning 0)(match-end 0))
 544           )
 545       (replace-as-filename str)
 546       )))
 547
 548 (defun mime-viewer/make-preview-buffer (&optional buf cinfo obuf)
 549   (let ((the-buf (current-buffer))
 550         (mode major-mode)
 551         pcl dest)
 552     (setq buf
 553           (if (null buf)
 554               (current-buffer)
 555             (prog1
 556                 (get-buffer buf)
 557               (switch-to-buffer buf)
 558               )))
 559     (or cinfo
 560         (setq cinfo mime::article/content-info)
 561         )
 562     (or obuf
 563         (setq obuf (concat "*Preview-" (buffer-name buf) "*"))
 564         )
 565     (setq pcl (mime::make-flat-content-list cinfo))
 566     (let ((bf (get-buffer obuf)))
 567       (switch-to-buffer obuf)
 568       (setq buffer-read-only nil)
 569       (if bf
 570           (erase-buffer)
 571         ))
 572     (make-variable-buffer-local 'mime::preview/article-buffer)
 573     (setq mime::preview/article-buffer the-buf)
 574     (make-variable-buffer-local 'mime::preview/original-major-mode)
 575     (setq mime::preview/original-major-mode mode)
 576     (setq major-mode 'mime/viewer-mode)
 577     (setq mode-name "MIME-View")
 578     (setq dest
 579           (mapcar
 580            (function
 581             (lambda (cell)
 582               (let ((beg (mime::content-info/point-min cell))
 583                     (end (mime::content-info/point-max cell))
 584                     (ctype (mime::content-info/type cell))
 585                     (params (mime::content-info/parameters cell))
 586                     (encoding (mime::content-info/encoding cell))
 587                     he cnum e nb ne subj str)
 588                 (setq cnum (mime::get-point-content-number beg cinfo))
 589                 (switch-to-buffer the-buf)
 590                 (setq he (save-excursion
 591                            (goto-char beg)
 592                            (re-search-forward "^$" nil t)
 593                            (+ (match-end 0) 1)
 594                            ))
 595                 (if (> he (point-max))
 596                     (setq he (point-max))
 597                   )
 598                 (save-excursion
 599                   (save-restriction
 600                     (narrow-to-region beg he)
 601                     (setq subj (mime-viewer/get-subject params))
 602                     ))
 603                 (switch-to-buffer obuf)
 604                 (setq nb (point))
 605                 (narrow-to-region nb nb)
 606                 (switch-to-buffer the-buf)
 607                 (if (mime-viewer/header-visible-p cnum cinfo ctype)
 608                     (progn
 609                       (setq str (buffer-substring beg he))
 610                       (switch-to-buffer obuf)
 611                       (insert str)
 612                       (let ((f (assq
 613                                 mode
 614                                 mime-viewer/content-header-filter-alist))
 615                             )
 616                         (if (and f (setq f (cdr f)))
 617                             (funcall f)
 618                           (mime-viewer/default-content-header-filter)
 619                           ))
 620                       (run-hooks 'mime-viewer/content-header-filter-hook)
 621                       (switch-to-buffer the-buf)
 622                       ))
 623                 (cond ((mime-viewer/body-visible-p cnum cinfo ctype)
 624                        (let (be)
 625                          (setq str (buffer-substring he end))
 626                          (switch-to-buffer obuf)
 627                          (save-restriction
 628                            (setq be (point-max))
 629                            (narrow-to-region be be)
 630                            (insert str)
 631                            (setq ne (point-max))
 632                            (let ((f (or (assoc-value
 633                                          ctype
 634                                          mime-viewer/content-filter-alist)
 635                                         )))
 636                              (if (and f (fboundp f))
 637                                  (funcall f ctype params encoding)
 638                                (mime-viewer/default-content-filter
 639                                 cnum cinfo ctype params subj)
 640                                ))
 641                            (setq ne (point-max))
 642                            )
 643                          (switch-to-buffer the-buf)
 644                          ))
 645                       ((equal ctype "message/partial")
 646                        (let (be)
 647                          (switch-to-buffer obuf)
 648                          (save-restriction
 649                            (goto-char (point-max))
 650                            (if (not (search-backward "\n\n" nil t))
 651                                (insert "\n")
 652                              )
 653                            (setq be (point-max))
 654                            (narrow-to-region be be)
 655                            (insert
 656                             mime-viewer/announcement-for-message/partial)
 657                            (tm:add-button (point-min)(point-max)
 658                                           (function mime-viewer/play-content))
 659                            (setq ne (point-max))
 660                            )
 661                          (switch-to-buffer the-buf)
 662                          ))
 663                       ((and (eq cnum t)
 664                             (null (mime::content-info/children cinfo))
 665                             )
 666                        (let (be)
 667                          (switch-to-buffer obuf)
 668                          (save-restriction
 669                            (setq be (point-max))
 670                            (narrow-to-region be be)
 671                            (mime-viewer/insert-content-subject
 672                             cnum cinfo ctype params subj)
 673                            (setq ne (point-max))
 674                            )
 675                          (switch-to-buffer the-buf)
 676                          ))
 677                       )
 678                 (switch-to-buffer obuf)
 679                 (mime-viewer/default-content-separator
 680                  cnum cinfo ctype params subj)
 681                 (prog1
 682                     (progn
 683                       (goto-char nb)
 684                       (funcall mime-viewer/content-subject-function
 685                                cnum cinfo ctype params subj)
 686                       (setq ne (point-max))
 687                       (widen)
 688                       (mime::preview-content-info/create nb (- ne 1)
 689                                                          buf cell)
 690                       )
 691                   (goto-char ne)
 692                   ))))
 693            pcl))
 694     (set-buffer-modified-p nil)
 695     (setq buffer-read-only t)
 696     (switch-to-buffer the-buf)
 697     (list obuf dest)
 698     ))
 699
 700
 701 ;;; @ content information
 702 ;;;
 703
 704 (defun mime::get-point-content-number (p &optional cinfo)
 705   (or cinfo
 706       (setq cinfo mime::article/content-info)
 707       )
 708   (let ((b (mime::content-info/point-min cinfo))
 709         (e (mime::content-info/point-max cinfo))
 710         (c (mime::content-info/children cinfo))
 711         )
 712     (if (and (<= b p)(<= p e))
 713         (or (let (co ret (sn 0))
 714               (catch 'tag
 715                 (while c
 716                   (setq co (car c))
 717                   (setq ret (mime::get-point-content-number p co))
 718                   (cond ((eq ret t) (throw 'tag (list sn)))
 719                         (ret (throw 'tag (cons sn ret)))
 720                         )
 721                   (setq c (cdr c))
 722                   (setq sn (+ sn 1))
 723                   )))
 724             t))))
 725
 726 (defun mime-article/cnum-to-cinfo (cn &optional cinfo)
 727   (or cinfo
 728       (setq cinfo mime::article/content-info)
 729       )
 730   (if (eq cn t)
 731       cinfo
 732     (let ((sn (car cn)))
 733       (if (null sn)
 734           cinfo
 735         (let ((rc (nth sn (mime::content-info/children cinfo))))
 736           (if rc
 737               (mime-article/cnum-to-cinfo (cdr cn) rc)
 738             ))
 739         ))))
 740
 741 (defun mime::make-flat-content-list (&optional cinfo)
 742   (or cinfo
 743       (setq cinfo mime::article/content-info)
 744       )
 745   (let ((dest (list cinfo))
 746         (rcl (mime::content-info/children cinfo))
 747         )
 748     (while rcl
 749       (setq dest (nconc dest (mime::make-flat-content-list (car rcl))))
 750       (setq rcl (cdr rcl))
 751       )
 752     dest))
 753
 754 (defun mime::point-preview-content (p &optional pcl)
 755   (or pcl
 756       (setq pcl mime::preview/content-list)
 757       )
 758   (catch 'tag
 759     (let ((r pcl) cell)
 760       (while r
 761         (setq cell (car r))
 762         (if (and (<= (mime::preview-content-info/point-min cell) p)
 763                  (<= p (mime::preview-content-info/point-max cell))
 764                  )
 765             (throw 'tag cell)
 766           )
 767         (setq r (cdr r))
 768         ))
 769     (car (last pcl))
 770     ))
 771
 772
 773 ;;; @ decoder
 774 ;;;
 775
 776 (defun mime/make-method-args (cal format)
 777   (mapcar (function
 778            (lambda (arg)
 779              (if (stringp arg)
 780                  arg
 781                (let ((ret (cdr (assoc (eval arg) cal))))
 782                  (if ret
 783                      ret
 784                    "")
 785                  ))
 786              ))
 787           format))
 788
 789 (defun mime/start-external-method-region (beg end cal)
 790   (save-excursion
 791     (save-restriction
 792       (narrow-to-region beg end)
 793       (goto-char beg)
 794       (let ((method (cdr (assoc 'method cal)))
 795             (name (mime-viewer/get-name cal))
 796             )
 797         (if method
 798             (let ((file (make-temp-name
 799                          (expand-file-name "TM" mime/tmp-dir)))
 800                   b args)
 801               (if (nth 1 method)
 802                   (setq b beg)
 803                 (setq b
 804                       (if (re-search-forward "^$" nil t)
 805                           (+ (match-end 0) 1)
 806                         (point-min)
 807                         ))
 808                 )
 809               (goto-char b)
 810               (write-region b end file)
 811               (setq cal (put-alist
 812                          'name (replace-as-filename name) cal))
 813               (setq cal (put-alist 'file file cal))
 814               (setq args (nconc
 815                           (list (car method)
 816                                 mime/output-buffer-name (car method)
 817                                 )
 818                           (mime/make-method-args cal (cdr (cdr method)))
 819                           ))
 820               (apply (function start-process) args)
 821               (mime/show-output-buffer)
 822               ))
 823         ))))
 824
 825 (defun mime/decode-message/partial-region (beg end cal)
 826   (goto-char beg)
 827   (let* ((root-dir (expand-file-name
 828                     (concat "m-prts-" (user-login-name)) mime/tmp-dir))
 829          (id (cdr (assoc "id" cal)))
 830          (number (cdr (assoc "number" cal)))
 831          (total (cdr (assoc "total" cal)))
 832          (the-buf (current-buffer))
 833          file
 834          (mother mime::article/preview-buffer))
 835     (if (not (file-exists-p root-dir))
 836         (make-directory root-dir)
 837       )
 838     (setq id (replace-as-filename id))
 839     (setq root-dir (concat root-dir "/" id))
 840     (if (not (file-exists-p root-dir))
 841         (make-directory root-dir)
 842       )
 843     (setq file (concat root-dir "/FULL"))
 844     (if (not (file-exists-p file))
 845         (progn
 846           (re-search-forward "^$")
 847           (goto-char (+ (match-end 0) 1))
 848           (setq file (concat root-dir "/" number))
 849           (write-region (point) (point-max) file)
 850           (if (get-buffer "*MIME-temp*")
 851               (kill-buffer "*MIME-temp*")
 852             )
 853           (switch-to-buffer "*MIME-temp*")
 854           (let ((i 1)
 855                 (max (string-to-int total))
 856                 )
 857             (catch 'tag
 858               (while (<= i max)
 859                 (setq file (concat root-dir "/" (int-to-string i)))
 860                 (if (not (file-exists-p file))
 861                     (progn
 862                       (switch-to-buffer the-buf)
 863                       (throw 'tag nil)
 864                       ))
 865                 (insert-file-contents file)
 866                 (goto-char (point-max))
 867                 (setq i (+ i 1))
 868                 )
 869               (delete-other-windows)
 870               (write-file (concat root-dir "/FULL"))
 871               (setq major-mode 'mime/show-message-mode)
 872               (mime/viewer-mode mother)
 873               (pop-to-buffer (current-buffer))
 874               ))
 875           )
 876       (progn
 877         (delete-other-windows)
 878         (find-file file)
 879         (setq major-mode 'mime/show-message-mode)
 880         (mime/viewer-mode mother)
 881         (pop-to-buffer (current-buffer))
 882         ))
 883     ))
 884
 885 (defun mime/get-content-decoding-alist (al)
 886   (get-unified-alist mime/content-decoding-condition al)
 887   )
 888
 889 (defun mime::article/decode-content-region (cinfo)
 890   (let ((beg (mime::content-info/point-min cinfo))
 891         (end (mime::content-info/point-max cinfo))
 892         (ctype (mime::content-info/type cinfo))
 893         (params (mime::content-info/parameters cinfo))
 894         (encoding (mime::content-info/encoding cinfo))
 895         )
 896     (if ctype
 897         (let (method cal ret)
 898           (setq cal (append (list (cons 'type ctype)
 899                                   (cons 'encoding encoding)
 900                                   (cons 'major-mode major-mode)
 901                                   )
 902                             params))
 903           (if mime-viewer/decoding-mode
 904               (setq cal (cons
 905                          (cons 'mode mime-viewer/decoding-mode)
 906                          cal))
 907             )
 908           (setq ret (mime/get-content-decoding-alist cal))
 909           (setq method (cdr (assoc 'method ret)))
 910           (cond ((and (symbolp method)
 911                       (fboundp method))
 912                  (funcall method beg end ret)
 913                  )
 914                 ((and (listp method)(stringp (car method)))
 915                  (mime/start-external-method-region beg end ret)
 916                  )
 917                 (t (mime/show-output-buffer
 918                     "No method are specified for %s\n" ctype)
 919                    ))
 920           ))
 921     ))
 922
 923 (defun mime/show-output-buffer (&rest forms)
 924   (let ((the-buf (current-buffer)))
 925     (if (null (get-buffer-window mime/output-buffer-name))
 926         (split-window-vertically (/ (* (window-height) 3) 4))
 927       )
 928     (pop-to-buffer mime/output-buffer-name)
 929     (goto-char (point-max))
 930     (if forms
 931         (insert (apply (function format) forms))
 932       )
 933     (pop-to-buffer the-buf)
 934     ))
 935
 936
 937 ;;; @ content filter
 938 ;;;
 939
 940 (defvar mime-viewer/code-converter-alist nil)
 941
 942 (defun mime-viewer/default-code-convert-region
 943   (beg end charset &optional encoding)
 944   (if (member encoding '("quoted-printable" "base64"))
 945       (mime/code-convert-region-to-emacs beg (point-max) charset)
 946     ))
 947
 948 (defun mime-viewer/filter-text/plain (ctype params encoding)
 949   (let ((charset (cdr (assoc "charset" params)))
 950         (beg (point-min)) (end (point-max))
 951         )
 952     (goto-char (point-min))
 953     (cond ((string= encoding "quoted-printable")
 954            (quoted-printable-decode-region beg end)
 955            )
 956           ((string= encoding "base64")
 957            (base64-decode-region beg end)
 958            ))
 959     (let* ((mode mime::preview/original-major-mode)
 960            (m (assq mode mime-viewer/code-converter-alist))
 961            )
 962       (if (and m (fboundp (setq m (cdr m))))
 963           (funcall m beg (point-max) charset encoding)
 964         (mime-viewer/default-code-convert-region beg (point-max)
 965                                                  charset encoding)
 966         )))
 967   (goto-char (point-max))
 968   (if (not (eq (char-after (1- (point))) ?\n))
 969       (insert "\n")
 970     )
 971   ;;(hide-sublevels 1)
 972   (run-hooks 'mime-viewer/plain-text-preview-hook)
 973   )
 974
 975
 976 ;;; @ MIME viewer mode
 977 ;;;
 978
 979 (defvar mime/viewer-mode-map nil)
 980 (if (null mime/viewer-mode-map)
 981     (progn
 982       (setq mime/viewer-mode-map (make-keymap))
 983       (suppress-keymap mime/viewer-mode-map)
 984       (define-key mime/viewer-mode-map
 985         "u"        (function mime-viewer/up-content))
 986       (define-key mime/viewer-mode-map
 987         "p"        (function mime-viewer/previous-content))
 988       (define-key mime/viewer-mode-map
 989         "n"        (function mime-viewer/next-content))
 990       (define-key mime/viewer-mode-map
 991         " "        (function mime-viewer/scroll-up-content))
 992       (define-key mime/viewer-mode-map
 993         "\M- "     (function mime-viewer/scroll-down-content))
 994       (define-key mime/viewer-mode-map
 995         "\177"     (function mime-viewer/scroll-down-content))
 996       (define-key mime/viewer-mode-map
 997         "\C-m"     (function mime-viewer/next-line-content))
 998       (define-key mime/viewer-mode-map
 999         "\C-\M-m"  (function mime-viewer/previous-line-content))
1000       (define-key mime/viewer-mode-map
1001         "v"        (function mime-viewer/play-content))
1002       (define-key mime/viewer-mode-map
1003         "e"        (function mime-viewer/extract-content))
1004       (define-key mime/viewer-mode-map
1005         "\C-c\C-p" (function mime-viewer/print-content))
1006       (define-key mime/viewer-mode-map
1007         "q"        (function mime-viewer/quit))
1008       (define-key mime/viewer-mode-map
1009         "\C-c\C-x" (function mime-viewer/kill-buffer))
1010       (if mouse-button-2
1011           (define-key mime/viewer-mode-map
1012             mouse-button-2 (function tm:button-dispatcher))
1013         )
1014       ))
1015
1016 (defun mime/viewer-mode (&optional mother ctl encoding)
1017   "Major mode for viewing MIME message.
1018
1019 Here is a list of the standard keys for mime/viewer-mode.
1020
1021 key             feature
1022 ---             -------
1023
1024 u               Move to upper content
1025 p               Move to previous content
1026 n               Move to next content
1027 SPC             Scroll up or move to next content
1028 M-SPC           Scroll down or move to previous content
1029 DEL             Scroll down or move to previous content
1030 RET             Move to next line
1031 M-RET           Move to previous line
1032 v               Decode current content as `play mode'
1033 e               Decode current content as `extract mode'
1034 C-c C-p         Decode current content as `print mode'
1035 q               Quit
1036 button-2        Move to point under the mouse cursor
1037                 and decode current content as `play mode'
1038
1039
1040 Here are all the commands with their current binding,
1041 listed in key order:
1042
1043 \\{mime/viewer-mode-map}
1044 "
1045   (interactive)
1046   (setq mime-viewer/ignored-field-regexp
1047         (concat "\\("
1048                 (mapconcat (function regexp-quote)
1049                            mime-viewer/ignored-field-list "\\|")
1050                 "\\)"))
1051   (let ((buf (get-buffer mime/output-buffer-name))
1052         (the-buf (current-buffer))
1053         )
1054     (if buf
1055         (progn
1056           (switch-to-buffer buf)
1057           (erase-buffer)
1058           (switch-to-buffer the-buf)
1059           )))
1060   (let ((ret (mime-viewer/parse-message ctl encoding)))
1061     (prog1
1062         (switch-to-buffer (car ret))
1063       (if mother
1064           (progn
1065             (make-variable-buffer-local
1066              'mime/show-mode-old-window-configuration)
1067             (setq mime/show-mode-old-window-configuration
1068                   (current-window-configuration))
1069             (make-variable-buffer-local 'mime/mother-buffer)
1070             (setq mime/mother-buffer mother)
1071             ))
1072       (use-local-map mime/viewer-mode-map)
1073       (make-variable-buffer-local 'mime::preview/content-list)
1074       (setq mime::preview/content-list (nth 1 ret))
1075       (goto-char
1076        (let ((ce (mime::preview-content-info/point-max
1077                   (car mime::preview/content-list)
1078                   ))
1079              e)
1080          (goto-char (point-min))
1081          (search-forward "\n\n" nil t)
1082          (setq e (match-end 0))
1083          (if (<= e ce)
1084              e
1085            ce)))
1086       (run-hooks 'mime/viewer-mode-hook)
1087       )))
1088
1089 (defun mime-preview/point-content-number (point)
1090   (save-window-excursion
1091     (let ((pc (mime::point-preview-content (point)))
1092           cinfo)
1093       (switch-to-buffer (mime::preview-content-info/buffer pc))
1094       (setq cinfo (mime::preview-content-info/content-info pc))
1095       (mime::get-point-content-number (mime::content-info/point-min cinfo))
1096       )))
1097
1098 (defun mime-preview/cinfo-to-pcinfo (cinfo)
1099   (let ((rpcl mime::preview/content-list) cell)
1100     (catch 'tag
1101       (while rpcl
1102         (setq cell (car rpcl))
1103         (if (eq cinfo (mime::preview-content-info/content-info cell))
1104             (throw 'tag cell)
1105           )
1106         (setq rpcl (cdr rpcl))
1107         ))))
1108
1109 (defvar mime-preview/after-decoded-position nil)
1110
1111 (defun mime-preview/decode-content ()
1112   (interactive)
1113   (let ((pc (mime::point-preview-content (point))))
1114     (if pc
1115         (let ((the-buf (current-buffer)))
1116           (setq mime-preview/after-decoded-position (point))
1117           (switch-to-buffer (mime::preview-content-info/buffer pc))
1118           (mime::article/decode-content-region
1119            (mime::preview-content-info/content-info pc))
1120           (if (eq (current-buffer)
1121                   (mime::preview-content-info/buffer pc))
1122               (progn
1123                 (switch-to-buffer the-buf)
1124                 (goto-char mime-preview/after-decoded-position)
1125                 ))
1126           ))))
1127
1128 (defun mime-viewer/play-content ()
1129   (interactive)
1130   (let ((mime-viewer/decoding-mode "play"))
1131     (mime-preview/decode-content)
1132     ))
1133
1134 (defun mime-viewer/play-content-mouse (e)
1135   (interactive "e")
1136   (mouse-set-point e)
1137   (mime-viewer/play-content)
1138   )
1139
1140 (defun mime-viewer/extract-content ()
1141   (interactive)
1142   (let ((mime-viewer/decoding-mode "extract"))
1143     (mime-preview/decode-content)
1144     ))
1145
1146 (defun mime-viewer/print-content ()
1147   (interactive)
1148   (let ((mime-viewer/decoding-mode "print"))
1149     (mime-preview/decode-content)
1150     ))
1151
1152 (defun mime-viewer/up-content ()
1153   (interactive)
1154   (let ((pc (mime::point-preview-content (point))) cinfo
1155         (the-buf (current-buffer))
1156         cn r)
1157     (switch-to-buffer (mime::preview-content-info/buffer pc))
1158     (setq cinfo (mime::preview-content-info/content-info pc))
1159     (setq cn (mime::get-point-content-number
1160               (mime::content-info/point-min cinfo)))
1161     (if (eq cn t)
1162         (mime-viewer/quit the-buf
1163                           (mime::preview-content-info/buffer pc)
1164                           )
1165       (setq r (mime-article/cnum-to-cinfo (butlast cn)))
1166       (switch-to-buffer the-buf)
1167       (catch 'tag
1168         (let ((rpcl mime::preview/content-list) cell)
1169           (while rpcl
1170             (setq cell (car rpcl))
1171             (if (eq r (mime::preview-content-info/content-info cell))
1172                 (progn
1173                   (goto-char (mime::preview-content-info/point-min cell))
1174                   (throw 'tag nil)
1175                   ))
1176             (setq rpcl (cdr rpcl))
1177             )))
1178       )))
1179
1180 (defun mime-viewer/previous-content ()
1181   (interactive)
1182   (let* ((pcl mime::preview/content-list)
1183          (p (point))
1184          (i (- (length pcl) 1))
1185          beg)
1186     (catch 'tag
1187       (while (>= i 0)
1188         (setq beg (mime::preview-content-info/point-min (nth i pcl)))
1189         (if (> p beg)
1190             (throw 'tag (goto-char beg))
1191           )
1192         (setq i (- i 1))
1193         ))
1194     ))
1195
1196 (defun mime-viewer/next-content ()
1197   (interactive)
1198   (let ((pcl mime::preview/content-list)
1199         (p (point))
1200         beg)
1201     (catch 'tag
1202       (while pcl
1203         (setq beg (mime::preview-content-info/point-min (car pcl)))
1204         (if (< p beg)
1205             (throw 'tag (goto-char beg))
1206           )
1207         (setq pcl (cdr pcl))
1208         ))
1209     ))
1210
1211 (defun mime-viewer/scroll-up-content (&optional h)
1212   (interactive)
1213   (or h
1214       (setq h (- (window-height) 1))
1215       )
1216   (let ((pcl mime::preview/content-list)
1217         (p (point))
1218         np beg)
1219     (setq np
1220           (or (catch 'tag
1221                 (while pcl
1222                   (setq beg (mime::preview-content-info/point-min (car pcl)))
1223                   (if (< p beg)
1224                       (throw 'tag beg)
1225                     )
1226                   (setq pcl (cdr pcl))
1227                   ))
1228               (point-max)))
1229     (forward-line h)
1230     (if (> (point) np)
1231         (goto-char np)
1232       )
1233     ;;(show-subtree)
1234     ))
1235
1236 (defun mime-viewer/scroll-down-content (&optional h)
1237   (interactive)
1238   (or h
1239       (setq h (- (window-height) 1))
1240       )
1241   (let ((pcl mime::preview/content-list)
1242         (p (point))
1243         pp beg)
1244     (setq pp
1245           (or (let ((i (- (length pcl) 1)))
1246                 (catch 'tag
1247                   (while (> i 0)
1248                     (setq beg (mime::preview-content-info/point-min
1249                                (nth i pcl)))
1250                     (if (> p beg)
1251                         (throw 'tag beg)
1252                       )
1253                     (setq i (- i 1))
1254                     )))
1255               (point-min)))
1256     (forward-line (- h))
1257     (if (< (point) pp)
1258         (goto-char pp)
1259       )))
1260
1261 (defun mime-viewer/next-line-content ()
1262   (interactive)
1263   (mime-viewer/scroll-up-content 1)
1264   )
1265
1266 (defun mime-viewer/previous-line-content ()
1267   (interactive)
1268   (mime-viewer/scroll-down-content 1)
1269   )
1270
1271 (defun mime-viewer/quit (&optional the-buf buf)
1272   (interactive)
1273   (or the-buf
1274       (setq the-buf (current-buffer))
1275       )
1276   (or buf
1277       (setq buf (mime::preview-content-info/buffer
1278                  (mime::point-preview-content (point))))
1279       )
1280   (let ((r (progn
1281              (switch-to-buffer buf)
1282              (assoc major-mode mime-viewer/quitting-method-alist)
1283              )))
1284     (if r
1285         (progn
1286           (switch-to-buffer the-buf)
1287           (funcall (cdr r))
1288           ))
1289     ))
1290
1291 (defun mime-viewer/kill-buffer ()
1292   (interactive)
1293   (kill-buffer (current-buffer))
1294   )
1295
1296
1297 ;;; @ end
1298 ;;;
1299
1300 (provide 'tm-view)
1301
1302 (run-hooks 'tm-view-load-hook)