tm-view.el

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