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