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