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