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