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