tm-view.el

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