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