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