tm-view.el

   1 ;;;
   2 ;;; A MIME viewer for GNU Emacs
   3 ;;;
   4 ;;; by Morioka Tomohiko, 1994/07/13
   5
   6 (provide 'tm-view)
   7
   8
   9 ;;; @ require modules
  10 ;;;
  11
  12 (require 'tl-str)
  13 (require 'tl-list)
  14 (require 'tl-header)
  15 (require 'tiny-mime)
  16 (require 'tm-misc)
  17
  18
  19 ;;; @ version
  20 ;;;
  21
  22 (defconst mime/viewer-RCS-ID
  23   "$Id: tm-view.el,v 5.21 1994/11/21 18:38:48 morioka Exp morioka $")
  24
  25 (defconst mime/viewer-version (get-version-string mime/viewer-RCS-ID))
  26
  27
  28 ;;; @ constants
  29 ;;;
  30
  31 (defconst mime/tspecials "\000-\040()<>@,;:\\\"/[\093?.=")
  32 (defconst mime/token-regexp
  33   (concat "[^" mime/tspecials "]*"))
  34 (defconst mime/content-type-subtype-regexp
  35   (concat mime/token-regexp "/" mime/token-regexp))
  36 (defconst mime/content-parameter-value-regexp
  37   (concat "\\("
  38           message/quoted-string-regexp
  39           "\\|[^; \t\n]*\\)"))
  40
  41 (defconst mime/output-buffer-name "*MIME-out*")
  42 (defconst mime/decoding-buffer-name "*MIME-decoding*")
  43
  44
  45 ;;; @ variables
  46 ;;;
  47
  48 (defvar mime/content-decoding-condition
  49 ;;(setq mime/content-decoding-condition
  50   '(((type . "text/plain")
  51      (method "tm-plain" nil 'file 'type 'encoding 'mode 'name))
  52     ;;((type . "text/x-latex")
  53     ;; (method "tm-latex" nil 'file 'type 'encoding 'mode 'name))
  54     ((type . "audio/basic")
  55      (method "tm-au"    nil 'file 'type 'encoding 'mode 'name))
  56     ((type . "image/gif")
  57      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  58     ((type . "image/jpeg")
  59      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  60     ((type . "image/tiff")
  61      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  62     ((type . "image/x-tiff")
  63      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  64     ((type . "image/x-xbm")
  65      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  66     ((type . "image/x-pic")
  67      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  68     ((type . "video/mpeg")
  69      (method "tm-mpeg"  nil 'file 'type 'encoding 'mode 'name))
  70     ((type . "application/octet-stream")
  71      (method "tm-file"  nil 'file 'type 'encoding 'mode 'name))
  72     ;;((type . "message/external-body")
  73     ;; (method "xterm" nil
  74     ;;         "-e" "showexternal"
  75     ;;         'file '"access-type" '"name" '"site" '"directory"))
  76     ((type . "message/partial")
  77      (method . mime/decode-message/partial-region))
  78     ((method "metamail" t
  79              "-m" "tm" "-x" "-d" "-z" "-e" 'file)(mode . "play"))
  80     ))
  81
  82 (defvar mime/content-filter-alist
  83   '(("text/plain" . mime/decode-text/plain)))
  84
  85 (defvar mime/make-content-subject-function
  86   (function
  87    (lambda (cid subj ctype)
  88      (insert
  89       (format "[%s %s (%s)]\n"
  90               (if (listp cid)
  91                   (mapconcat (function
  92                               (lambda (num)
  93                                 (format "%s" (+ num 1))
  94                                 ))
  95                              cid ".")
  96                 "0")
  97               subj (car ctype)))
  98      )))
  99
 100 (defvar mime/make-content-header-filter
 101 ;;(setq mime/make-content-header-filter
 102   (function
 103    (lambda (cid)
 104      (if (listp cid)
 105          (delete-region (goto-char (point-min))
 106                         (or (and (re-search-forward "^$" nil t)
 107                                  (match-end 0))
 108                             (point-max))
 109                         )
 110        )
 111      )))
 112
 113 (defvar mime/default-showing-Content-Type-list
 114 ;;(setq mime/default-showing-Content-Type-list
 115   '("text/plain" "text/richtext" "text/enriched"
 116     "text/x-latex" "application/x-latex"
 117     "application/octet-stream" nil))
 118
 119 (defvar mime/go-to-top-node-method-alist
 120 ;;(setq mime/go-to-top-node-method-alist
 121   '((gnus-article-mode . (lambda ()
 122                            (mime/exit-view-mode)
 123                            (delete-other-windows)
 124                            (gnus-article-show-summary)
 125                            ))
 126     (rmail-mode . (lambda ()
 127                     (mime/exit-view-mode)
 128                     (rmail-summary)
 129                     (delete-other-windows)
 130                     ))
 131     (mh-show-mode . (lambda ()
 132                       (let ((win (get-buffer-window
 133                                   mime/output-buffer-name))
 134                             (buf
 135                              (nth 2 (car mime/preview-flat-content-list)))
 136                             )
 137                         (if win
 138                             (delete-window win)
 139                           )
 140                         (mime/exit-view-mode)
 141                         (pop-to-buffer
 142                          (let ((name (buffer-name buf)))
 143                            (string-match "show-" name)
 144                            (substring name (match-end 0))
 145                            ))
 146                         )))
 147     (mime/show-message-mode . (lambda ()
 148                                 (set-window-configuration
 149                                  mime/show-mode-old-window-configuration)
 150                                 (let ((mother mime/mother-buffer))
 151                                   (kill-buffer
 152                                    (nth 2 (car
 153                                            mime/preview-flat-content-list)))
 154                                   (mime/exit-view-mode)
 155                                   (pop-to-buffer mother)
 156                                   (goto-char (point-min))
 157                                   (mime/up-content)
 158                                   )))
 159     ))
 160
 161 (defvar mime/use-internal-decoder nil)
 162
 163 (defvar mime/body-decoding-mode "play" "MIME body decoding mode")
 164
 165
 166 ;;; @ parser
 167 ;;;
 168
 169 (defun mime/parse-contents ()
 170   (save-excursion
 171     (save-restriction
 172       (goto-char (point-min))
 173       (let* ((ctl (mime/Content-Type))
 174              (ctype (car ctl))
 175              (boundary (assoc "boundary" (cdr ctl)))
 176              beg end dest)
 177         (if (stringp ctype)
 178             (setq ctype (downcase ctype))
 179           )
 180         (search-forward "\n\n" nil t)
 181         (cond (boundary
 182                (let ((sep (concat "\n--"
 183                                   (setq boundary
 184                                         (message/strip-quoted-string
 185                                          (cdr boundary)))
 186                                   "\n"))
 187                      cb ce ct ret ncb)
 188                  (setq beg (match-end 0))
 189                  (search-forward (concat "\n--" boundary "--\n") nil t)
 190                  (setq end (match-beginning 0))
 191                  (save-excursion
 192                    (save-restriction
 193                      (narrow-to-region beg end)
 194                      (goto-char (point-min))
 195                      (search-forward (concat "--" boundary "\n") nil t)
 196                      (setq cb (match-end 0))
 197                      (while (search-forward sep nil t)
 198                        (setq ce (match-beginning 0))
 199                        (setq ncb (match-end 0))
 200                        (save-excursion
 201                          (save-restriction
 202                            (narrow-to-region cb ce)
 203                            (setq ret (mime/parse-contents))
 204                            ))
 205                        (setq dest (nconc dest (list ret)))
 206                        (goto-char (nth 1 ret))
 207                        (search-forward (concat "--" boundary "\n") nil t)
 208                        (goto-char (setq cb (match-end 0)))
 209                        )
 210                      (setq ce (point-max))
 211                      (save-excursion
 212                        (save-restriction
 213                          (narrow-to-region cb ce)
 214                          (setq ret (mime/parse-contents))
 215                          ))
 216                      (setq dest (append dest (list ret)))
 217                      ))
 218                  (setq beg (point-min))
 219                  (goto-char beg)
 220                  (search-forward (concat "\n--" boundary "--\n") nil t)
 221                  (setq end (match-beginning 0))
 222                  ))
 223               ((string= ctype "message/rfc822")
 224                (save-excursion
 225                  (save-restriction
 226                    (narrow-to-region (match-end 0) (point-max))
 227                    (setq dest (list (mime/parse-contents)))
 228                    ))
 229                (setq beg (point-min))
 230                (setq end (point-max))
 231                )
 232               (t (setq beg (point-min))
 233                  (setq end (point-max))
 234                  ))
 235         (list beg end dest)
 236         ))))
 237
 238 (defun mime/Content-Type ()
 239   (save-excursion
 240     (save-restriction
 241       (if (and (re-search-forward "^Content-Type:[ \t]*" nil t)
 242                  (progn
 243                    (narrow-to-region
 244                     (point)
 245                     (and (re-search-forward ".*\\(\n[ \t].*\\)*" nil t)
 246                          (match-end 0))
 247                     )
 248                    (goto-char (point-min))
 249                    (re-search-forward mime/content-type-subtype-regexp nil t)
 250                    ))
 251             (let ((ctype
 252                    (downcase
 253                     (buffer-substring (match-beginning 0) (match-end 0))
 254                     ))
 255                   dest attribute value)
 256               (while (and (re-search-forward "[ \t\n]*;[ \t\n]*" nil t)
 257                           (re-search-forward mime/token-regexp nil t)
 258                           )
 259                 (setq attribute
 260                       (downcase
 261                        (buffer-substring (match-beginning 0) (match-end 0))
 262                        ))
 263                 (if (and (re-search-forward "=[ \t\n]*" nil t)
 264                          (re-search-forward mime/content-parameter-value-regexp
 265                                             nil t)
 266                          )
 267                     (setq dest
 268                           (put-alist attribute
 269                                      (message/strip-quoted-string
 270                                       (buffer-substring (match-beginning 0)
 271                                                         (match-end 0)))
 272                                      dest))
 273                   )
 274                 )
 275               (cons ctype dest)
 276               )))))
 277
 278 (defun mime/Content-Transfer-Encoding (&optional default-encoding)
 279   (save-excursion
 280     (save-restriction
 281       (if (and (re-search-forward "^Content-Transfer-Encoding:[ \t]*" nil t)
 282                (re-search-forward mime/token-regexp nil t)
 283                )
 284           (downcase (buffer-substring (match-beginning 0) (match-end 0)))
 285         default-encoding)
 286       )))
 287
 288 (defun mime/get-subject (param)
 289   (save-excursion
 290     (save-restriction
 291       (let (ret)
 292         (or (and (setq ret (assoc "name" param))
 293                  (message/strip-quoted-string (cdr ret))
 294                  )
 295             (and (setq ret (assoc "x-name" param))
 296                  (message/strip-quoted-string (cdr ret))
 297                  )
 298             (progn
 299               (narrow-to-region (point-min)
 300                                 (or (and (search-forward "\n\n" nil t)
 301                                          (match-beginning 0)
 302                                          )
 303                                     (point-max)))
 304               (or
 305                (message/get-field-body "Content-Description")
 306                (message/get-field-body "Subject")
 307                ))
 308             ""))
 309       )))
 310
 311 (defun mime/get-name (param)
 312   (replace-as-filename (mime/get-subject param))
 313   )
 314
 315 (defun mime/make-preview-buffer (&optional buf cl obuf)
 316   (let ((the-buf (current-buffer)) fcl)
 317     (if (null buf)
 318         (setq buf (current-buffer))
 319       (setq buf (get-buffer buf))
 320       )
 321     (if (null cl)
 322         (progn
 323           (switch-to-buffer buf)
 324           (setq cl mime/content-list)
 325           ))
 326     (if (null obuf)
 327         (setq obuf (concat "*Preview-" (buffer-name buf) "*"))
 328       )
 329     (setq fcl (mime/make-flat-content-list cl))
 330     (if (get-buffer obuf)
 331         (kill-buffer obuf)
 332       )
 333     (let ((r fcl) cell cid ctype beg end e nb ne subj dest str)
 334       (while r
 335         (setq cell (car r))
 336         (setq beg (car cell))
 337         (setq end (nth 1 cell))
 338         (setq cid (mime/get-point-content-number beg cl))
 339         (switch-to-buffer buf)
 340         (save-excursion
 341           (save-restriction
 342             (narrow-to-region beg end)
 343             (goto-char beg)
 344             (setq ctype (mime/Content-Type))
 345             (setq e
 346                   (if (not (member (car ctype)
 347                                    mime/default-showing-Content-Type-list))
 348                       (progn
 349                         (goto-char beg)
 350                         (search-forward "\n\n" nil t)
 351                         (match-end 0)
 352                         )
 353                     (+ end 1)
 354                     ))
 355             ))
 356         (if (> e (point-max))
 357             (setq e (point-max))
 358           )
 359         (setq str (buffer-substring beg e))
 360         (switch-to-buffer obuf)
 361         (setq nb (point))
 362         (insert str)
 363         (setq ne (point))
 364         (save-excursion
 365           (save-restriction
 366             (narrow-to-region nb ne)
 367             (mime/decode-message-header)
 368             (setq subj (mime/get-subject (cdr ctype)))
 369             (let ((f (cdr (assoc (car ctype) mime/content-filter-alist))))
 370               (if (and f (fboundp f))
 371                   (funcall f ctype)
 372                 ))
 373             (funcall mime/make-content-header-filter cid)
 374             (goto-char nb)
 375             (funcall mime/make-content-subject-function cid subj ctype)
 376             (setq ne (point-max))
 377             (setq dest (nconc dest (list (list nb (- ne 1) buf beg end))))
 378             ))
 379         (goto-char ne)
 380         (setq r (cdr r))
 381         )
 382       (set-buffer-modified-p nil)
 383       (setq buffer-read-only t)
 384       (switch-to-buffer the-buf)
 385       (list obuf dest)
 386       )))
 387
 388 (defun mime/parse-message ()
 389   (interactive)
 390   (make-variable-buffer-local 'mime/content-list)
 391   (setq mime/content-list (mime/parse-contents))
 392   (let ((ret (mime/make-preview-buffer)))
 393     (make-variable-buffer-local 'mime/preview-buffer)
 394     (setq mime/preview-buffer (car ret))
 395     ret))
 396
 397 ;;; @ content information
 398 ;;;
 399
 400 (defun mime/get-point-content-number (p &optional cl)
 401   (if (null cl)
 402       (setq cl mime/content-list)
 403     )
 404   (let ((b (car cl))
 405         (e (nth 1 cl))
 406         (c (nth 2 cl))
 407         )
 408     (if (and (<= b p)(<= p e))
 409         (or (let (co ret (sn 0))
 410               (catch 'tag
 411                 (while c
 412                   (setq co (car c))
 413                   (setq ret (mime/get-point-content-number p co))
 414                   (cond ((eq ret t) (throw 'tag (list sn)))
 415                         (ret (throw 'tag (cons sn ret)))
 416                         )
 417                   (setq c (cdr c))
 418                   (setq sn (+ sn 1))
 419                   )))
 420             t))))
 421
 422 (defun mime/get-content-region (cn &optional cl)
 423   (if (null cl)
 424       (setq cl mime/content-list)
 425     )
 426   (if (eq cn t)
 427       cl
 428     (let ((sn (car cn)))
 429       (if (null sn)
 430           cl
 431         (let ((rcl (nth sn (nth 2 cl))))
 432           (if rcl
 433               (mime/get-content-region (cdr cn) rcl)
 434             ))
 435         ))))
 436
 437 (defun mime/make-flat-content-list (&optional cl)
 438   (if (null cl)
 439       (setq cl mime/content-list)
 440     )
 441   (let ((dest (list cl))
 442         (rcl (nth 2 cl))
 443         )
 444     (while rcl
 445       (setq dest (append dest (mime/make-flat-content-list (car rcl))))
 446       (setq rcl (cdr rcl))
 447       )
 448     dest))
 449
 450 (defun mime/get-point-preview-content (p &optional fcl)
 451   (if (null fcl)
 452       (setq fcl mime/preview-flat-content-list)
 453     )
 454   (catch 'tag
 455     (let ((r fcl) cell)
 456       (while r
 457         (setq cell (car r))
 458         (if (and (<= (car cell) p)(<= p (nth 1 cell)))
 459             (throw 'tag cell)
 460           )
 461         (setq r (cdr r))
 462         ))
 463     (car (last fcl))
 464     ))
 465
 466
 467 ;;; @ decoder
 468 ;;;
 469
 470 (defun mime/Quoted-Printable-decode-region (beg end)
 471   (interactive "*r")
 472   (save-excursion
 473     (save-restriction
 474       (narrow-to-region beg end)
 475       (goto-char (point-min))
 476       (while (re-search-forward "=\n" nil t)
 477         (replace-match "")
 478         )
 479       (goto-char (point-min))
 480       (let (b e str)
 481         (while (re-search-forward mime/Quoted-Printable-octet-regexp nil t)
 482           (setq b (match-beginning 0))
 483           (setq e (match-end 0))
 484           (setq str (buffer-substring b e))
 485           (delete-region b e)
 486           (insert (mime/Quoted-Printable-decode-string str))
 487           ))
 488       )))
 489
 490 (defun mime/Base64-decode-region (beg end)
 491   (interactive "*r")
 492   (save-excursion
 493     (save-restriction
 494       (narrow-to-region beg end)
 495       (goto-char (point-min))
 496       (while (search-forward "\n" nil t)
 497         (replace-match "")
 498         )
 499       (let ((str (buffer-substring (point-min)(point-max))))
 500         (delete-region (point-min)(point-max))
 501         (insert (mime/base64-decode-string str))
 502         ))))
 503
 504 (defun mime/make-method-args (cal format)
 505   (mapcar (function
 506            (lambda (arg)
 507              (if (stringp arg)
 508                  arg
 509                (let ((ret (cdr (assoc (eval arg) cal))))
 510                  (if ret
 511                      ret
 512                    "")
 513                  ))
 514              ))
 515           format))
 516
 517 (defun mime/start-external-method-region (beg end cal)
 518   (let ((e end))
 519     (if (< end (point-max))
 520         (setq e (+ end 1))
 521       )
 522     (save-excursion
 523       (save-restriction
 524         (narrow-to-region beg e)
 525         (goto-char beg)
 526         (let ((method (cdr (assoc 'method cal)))
 527               (name (mime/get-name cal))
 528               )
 529           (if method
 530               (let ((file (make-temp-name
 531                            (expand-file-name "TM" mime/tmp-dir)))
 532                     b args)
 533                 (if (nth 1 method)
 534                     (setq b beg)
 535                   (search-forward "\n\n" nil t)
 536                   (setq b (match-end 0))
 537                   )
 538                 (goto-char b)
 539                 (write-region b e file)
 540                 (setq cal (put-alist
 541                            'name (replace-as-filename name) cal))
 542                 (setq cal (put-alist 'file file cal))
 543                 (setq args (nconc
 544                             (list (car method)
 545                                   mime/output-buffer-name (car method)
 546                                   )
 547                             (mime/make-method-args cal (cdr (cdr method)))
 548                             ))
 549                 (apply (function start-process) args)
 550                 (mime/show-output-buffer)
 551                 ))))))
 552   )
 553
 554 (defun mime/decode-message/partial-region (beg end cal)
 555   (goto-char beg)
 556   (let* ((root-dir (expand-file-name
 557                     (concat "m-prts-" (user-login-name)) mime/tmp-dir))
 558          (id (cdr (assoc "id" cal)))
 559          (number (cdr (assoc "number" cal)))
 560          (total (cdr (assoc "total" cal)))
 561          (the-buf (current-buffer))
 562          file
 563          (mother mime/preview-buffer))
 564     (if (not (file-exists-p root-dir))
 565         (shell-command (concat "mkdir " root-dir))
 566       )
 567     (setq id (replace-as-filename id))
 568     (setq root-dir (concat root-dir "/" id))
 569     (if (not (file-exists-p root-dir))
 570         (shell-command (concat "mkdir " root-dir))
 571       )
 572     (setq file (concat root-dir "/FULL"))
 573     (if (not (file-exists-p file))
 574         (progn
 575           (re-search-forward "^$")
 576           (goto-char (+ (match-end 0) 1))
 577           (setq file (concat root-dir "/" number))
 578           (write-region (point) (point-max) file)
 579           (if (get-buffer "*MIME-temp*")
 580               (kill-buffer "*MIME-temp*")
 581             )
 582           (switch-to-buffer "*MIME-temp*")
 583           (let ((i 1)
 584                 (max (string-to-int total))
 585                 )
 586             (catch 'tag
 587               (while (<= i max)
 588                 (setq file (concat root-dir "/" (int-to-string i)))
 589                 (if (not (file-exists-p file))
 590                     (progn
 591                       (switch-to-buffer the-buf)
 592                       (throw 'tag nil)
 593                       ))
 594                 (insert-file-contents file)
 595                 (goto-char (point-max))
 596                 (setq i (+ i 1))
 597                 )
 598               (delete-other-windows)
 599               (write-file (concat root-dir "/FULL"))
 600               (setq major-mode 'mime/show-message-mode)
 601               (mime/viewer-mode mother)
 602               (pop-to-buffer (current-buffer))
 603               ))
 604           )
 605       (progn
 606         (delete-other-windows)
 607         (find-file file)
 608         (setq major-mode 'mime/show-message-mode)
 609         (mime/viewer-mode mother)
 610         (pop-to-buffer (current-buffer))
 611         ))
 612     ))
 613
 614 (defun mime/get-content-decoding-alist (al)
 615   (get-unified-alist mime/content-decoding-condition al)
 616   )
 617
 618 (defun mime/decode-content-region (beg end)
 619   (interactive "*r")
 620   (let (ctl encoding)
 621     (save-excursion
 622       (save-restriction
 623         (narrow-to-region beg end)
 624         (and (goto-char beg)
 625              (setq ctl (mime/Content-Type))
 626              (goto-char beg)
 627              (setq encoding (mime/Content-Transfer-Encoding "7bit"))
 628              )))
 629     (if ctl
 630         (let ((ctype (downcase (car ctl))) method cal ret)
 631           (setq ctl (cdr ctl))
 632           (setq cal (nconc (list (cons 'type ctype)
 633                                  (cons 'encoding encoding)
 634                                  (cons 'major-mode major-mode)
 635                                  )
 636                            ctl))
 637           (if mime/body-decoding-mode
 638               (setq cal (cons
 639                          (cons 'mode mime/body-decoding-mode)
 640                          cal))
 641             )
 642           (setq ret (mime/get-content-decoding-alist cal))
 643           (setq method (cdr (assoc 'method ret)))
 644           (cond ((and (symbolp method)
 645                       (fboundp method))
 646                  (funcall method beg end ret)
 647                  )
 648                 ((and (listp method)(stringp (car method)))
 649                  (mime/start-external-method-region beg end ret)
 650                  )
 651                 (t (mime/show-output-buffer
 652                     "No method are specified for %s\n" ctype)
 653                    ))
 654           ))
 655     ))
 656
 657 (defun mime/show-output-buffer (&rest forms)
 658   (let ((the-buf (current-buffer)))
 659     (if (null (get-buffer-window mime/output-buffer-name))
 660         (split-window-vertically (/ (* (window-height) 3) 4))
 661       )
 662     (pop-to-buffer mime/output-buffer-name)
 663     (goto-char (point-max))
 664     (if forms
 665         (insert (apply (function format) forms))
 666       )
 667     (pop-to-buffer the-buf)
 668     ))
 669
 670
 671 ;;; @ content filter
 672 ;;;
 673
 674 (defun mime/decode-text/plain (ctl)
 675   (interactive)
 676   (save-excursion
 677     (save-restriction
 678       (let ((charset (cdr (assoc "charset" (cdr ctl))))
 679             (encoding
 680              (save-excursion
 681                (save-restriction
 682                  (goto-char (point-min))
 683                  (narrow-to-region (point-min)
 684                                    (or (and (search-forward "\n\n" nil t)
 685                                             (match-beginning 0))
 686                                        (point-max)))
 687                  (goto-char (point-min))
 688                  (mime/Content-Transfer-Encoding "7bit")
 689                  )))
 690             (beg (point-min)) (end (point-max))
 691             )
 692         (goto-char (point-min))
 693         (if (search-forward "\n\n" nil t)
 694             (setq beg (match-end 0))
 695           )
 696         (if (cond ((string= encoding "quoted-printable")
 697                    (mime/Quoted-Printable-decode-region beg end)
 698                    t)
 699                   ((string= encoding "base64")
 700                    (mime/Base64-decode-region beg end)
 701                    t))
 702             (mime/code-convert-region-to-emacs beg (point-max) charset)
 703           )
 704         ))))
 705
 706
 707 ;;; @ MIME viewer mode
 708 ;;;
 709
 710 (defvar mime/viewer-mode-map nil)
 711 (if (null mime/viewer-mode-map)
 712     (progn
 713       (setq mime/viewer-mode-map (make-keymap))
 714       (suppress-keymap mime/viewer-mode-map)
 715       (define-key mime/viewer-mode-map "u" 'mime/up-content)
 716       (define-key mime/viewer-mode-map "p" 'mime/previous-content)
 717       (define-key mime/viewer-mode-map "n" 'mime/next-content)
 718       (define-key mime/viewer-mode-map " " 'mime/scroll-up-content)
 719       (define-key mime/viewer-mode-map "\M- " 'mime/scroll-down-content)
 720       (define-key mime/viewer-mode-map "\177" 'mime/scroll-down-content)
 721       (define-key mime/viewer-mode-map "\C-m" 'mime/next-line-content)
 722       (define-key mime/viewer-mode-map "\C-\M-m" 'mime/previous-line-content)
 723       (define-key mime/viewer-mode-map "v" 'mime/play-content)
 724       (define-key mime/viewer-mode-map "e" 'mime/extract-content)
 725       (define-key mime/viewer-mode-map "\C-c\C-p" 'mime/print-content)
 726       (define-key mime/viewer-mode-map "q" 'mime/quit-view-mode)
 727       (define-key mime/viewer-mode-map "\C-c\C-x" 'mime/exit-view-mode)
 728       ))
 729
 730 (defun mime/viewer-mode (&optional mother)
 731   "Major mode for viewing MIME message.
 732
 733 u       Move to upper content
 734 p       Move to previous content
 735 n       Move to next content
 736 SPC     Scroll up
 737 M-SPC   Scroll down
 738 DEL     Scroll down
 739 RET     Move to next line
 740 M-RET   Move to previous line
 741 v       Decode the content as `play mode'
 742 e       Decode the content as `extract mode'
 743 C-c C-p Decode the content as `print mode'
 744 q       Quit
 745 "
 746   (interactive)
 747   (let ((buf (get-buffer mime/output-buffer-name))
 748         (the-buf (current-buffer))
 749         )
 750     (if buf
 751         (progn
 752           (switch-to-buffer buf)
 753           (erase-buffer)
 754           (switch-to-buffer the-buf)
 755           )))
 756   (let ((ret (mime/parse-message))
 757         (mode major-mode))
 758     (switch-to-buffer (car ret))
 759     (setq major-mode 'mime/viewer-mode)
 760     (setq mode-name "MIME-View")
 761     (make-variable-buffer-local 'mime/viewer-original-major-mode)
 762     (setq mime/viewer-original-major-mode
 763           (if mother
 764               (progn
 765                 (make-variable-buffer-local
 766                  'mime/show-mode-old-window-configuration)
 767                 (setq mime/show-mode-old-window-configuration
 768                       (current-window-configuration))
 769                 (make-variable-buffer-local 'mime/mother-buffer)
 770                 (setq mime/mother-buffer mother)
 771                 'mime/show-message-mode)
 772             mode))
 773     (use-local-map mime/viewer-mode-map)
 774     (make-variable-buffer-local 'mime/preview-flat-content-list)
 775     (setq mime/preview-flat-content-list (nth 1 ret))
 776     (goto-char
 777      (let ((ce (nth 1 (car mime/preview-flat-content-list)))
 778            e)
 779        (goto-char (point-min))
 780        (search-forward "\n\n" nil t)
 781        (setq e (match-end 0))
 782        (if (<= e ce)
 783            e
 784          ce)))
 785     (run-hooks 'mime/viewer-mode-hook)
 786     ))
 787
 788 (defun mime/decode-content ()
 789   (interactive)
 790   (let ((pc (mime/get-point-preview-content (point))))
 791     (if pc
 792         (let ((the-buf (current-buffer)))
 793           (switch-to-buffer (nth 2 pc))
 794           (mime/decode-content-region (nth 3 pc)(nth 4 pc))
 795           (if (eq (current-buffer) (nth 2 pc))
 796               (switch-to-buffer the-buf)
 797             )
 798           ))))
 799
 800 (defun mime/play-content ()
 801   (interactive)
 802   (let ((mime/body-decoding-mode "play"))
 803     (mime/decode-content)
 804     ))
 805
 806 (defun mime/extract-content ()
 807   (interactive)
 808   (let ((mime/body-decoding-mode "extract"))
 809     (mime/decode-content)
 810     ))
 811
 812 (defun mime/print-content ()
 813   (interactive)
 814   (let ((mime/body-decoding-mode "print"))
 815     (mime/decode-content)
 816     ))
 817
 818 (defun mime/up-content ()
 819   (interactive)
 820   (let ((pc (mime/get-point-preview-content (point)))
 821         (the-buf (current-buffer))
 822         cn r)
 823     (switch-to-buffer (nth 2 pc))
 824     (setq cn (mime/get-point-content-number (nth 3 pc)))
 825     (if (eq cn t)
 826         (mime/quit-view-mode the-buf (nth 2 pc))
 827       (setq r (mime/get-content-region (butlast cn)))
 828       (switch-to-buffer the-buf)
 829       (catch 'tag
 830         (let ((rfcl mime/preview-flat-content-list) cell)
 831           (while rfcl
 832             (setq cell (car rfcl))
 833             (if (and (= (car r)(nth 3 cell))
 834                      (= (nth 1 r)(nth 4 cell))
 835                      )
 836                 (progn
 837                   (goto-char (nth 0 cell))
 838                   (throw 'tag nil)
 839                   ))
 840             (setq rfcl (cdr rfcl))
 841             )))
 842       )))
 843
 844 (defun mime/previous-content ()
 845   (interactive)
 846   (let* ((fcl mime/preview-flat-content-list)
 847          (p (point))
 848          (i (- (length fcl) 1))
 849          )
 850     (catch 'tag
 851       (while (>= i 0)
 852         (if (> p (car (nth i fcl)))
 853             (throw 'tag (goto-char (car (nth i fcl))))
 854           )
 855         (setq i (- i 1))
 856         ))
 857     ))
 858
 859 (defun mime/next-content ()
 860   (interactive)
 861   (let ((fcl mime/preview-flat-content-list)
 862         (p (point))
 863         )
 864     (catch 'tag
 865       (while fcl
 866         (if (< p (car (car fcl)))
 867             (throw 'tag (goto-char (car (car fcl))))
 868           )
 869         (setq fcl (cdr fcl))
 870         ))
 871     ))
 872
 873 (defun mime/scroll-up-content (&optional h)
 874   (interactive)
 875   (if (null h)
 876       (setq h (- (window-height) 1))
 877     )
 878   (let ((fcl mime/preview-flat-content-list)
 879         (p (point))
 880         np)
 881     (setq np (or (catch 'tag
 882                    (while fcl
 883                      (if (< p (car (car fcl)))
 884                          (throw 'tag (car (car fcl)))
 885                        )
 886                      (setq fcl (cdr fcl))
 887                      ))
 888                  (point-max)))
 889     (forward-line h)
 890     (if (> (point) np)
 891         (goto-char np)
 892       )))
 893
 894 (defun mime/scroll-down-content (&optional h)
 895   (interactive)
 896   (if (null h)
 897       (setq h (- (window-height) 1))
 898     )
 899   (let ((fcl mime/preview-flat-content-list)
 900         (p (point))
 901         pp)
 902     (setq pp (or (let ((i (- (length fcl) 1)))
 903                    (catch 'tag
 904                      (while (> i 0)
 905                        (if (> p (nth 1 (nth i fcl)))
 906                            (throw 'tag (nth 1 (nth i fcl)))
 907                          )
 908                        (setq i (- i 1))
 909                        )))
 910                  (point-min)))
 911     (forward-line (- h))
 912     (if (< (point) pp)
 913         (goto-char pp)
 914       )))
 915
 916 (defun mime/next-line-content ()
 917   (interactive)
 918   (mime/scroll-up-content 1)
 919   )
 920
 921 (defun mime/previous-line-content ()
 922   (interactive)
 923   (mime/scroll-down-content 1)
 924   )
 925
 926 (defun mime/quit-view-mode (&optional the-buf buf)
 927   (interactive)
 928   (if (null the-buf)
 929       (setq the-buf (current-buffer))
 930     )
 931   (if (null buf)
 932       (setq buf (nth 2 (mime/get-point-preview-content (point))))
 933     )
 934   (let ((r (progn
 935              (switch-to-buffer buf)
 936              (assoc major-mode mime/go-to-top-node-method-alist)
 937              )))
 938     (if r
 939         (progn
 940           (switch-to-buffer the-buf)
 941           (funcall (cdr r))
 942           ))
 943     ))
 944
 945 (defun mime/exit-view-mode ()
 946   (interactive)
 947   (kill-buffer (current-buffer))
 948   )
 949
 950 (fset 'mime/view-mode 'mime/viewer-mode)
 951
 952 (run-hooks 'tm-view-load-hook)