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.18 1995/04/23 15:51:19 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/mixed")
 370                                       '(("text/plain") "7bit")
 371                                       )
 372                                      ((string= ctype "multipart/digest")
 373                                       '(("message/rfc822") "7bit")
 374                                       ))
 375                                ))
 376               ))
 377           (setq children (nconc children (list ret)))
 378           (goto-char (mime::content-info/point-max ret))
 379           (search-forward (concat "--" boundary "\n") nil t)
 380           (goto-char (setq cb (match-end 0)))
 381           )
 382         (setq ce (point-max))
 383         (save-excursion
 384           (save-restriction
 385             (narrow-to-region cb ce)
 386             (setq ret (apply (function mime-viewer/parse)
 387                              (cond ((string= ctype "multipart/mixed")
 388                                     '(("text/plain") "7bit")
 389                                     )
 390                                    ((string= ctype "multipart/digest")
 391                                     '(("message/rfc822") "7bit")
 392                                     ))
 393                              ))
 394             ))
 395         (setq children (nconc children (list ret)))
 396         ))
 397     (setq beg (point-min))
 398     (goto-char beg)
 399     (mime::make-content-info beg end ctype params encoding children)
 400     ))
 401
 402 (defun mime::parse-parameter (str)
 403   (let ((ret (message::parse "\;" str)))
 404     (if ret
 405         (if (setq ret
 406                   (message::parse mime/token-regexp
 407                                   (message::parsed/rest ret)))
 408             (let ((parameter (downcase (message::parsed/matched ret))))
 409               (if (setq ret (message::parse "=" (message::parsed/rest ret)))
 410                   (if (setq ret
 411                             (message::parse
 412                              mime/content-parameter-value-regexp
 413                              (message::parsed/rest ret)))
 414                       (message::make-parsed
 415                        (cons parameter
 416                              (message/strip-quoted-string
 417                               (message::parsed/matched ret))
 418                              )
 419                        (message::parsed/rest ret)
 420                        )
 421                     )))))))
 422
 423 (defun mime::parse-field-body/Content-Type (str)
 424   (let ((ret (message::parse mime/content-type-subtype-regexp str)))
 425     (if ret
 426         (let ((ctype (downcase (message::parsed/matched ret)))
 427               dest)
 428           (while (progn
 429                    (setq str (message::parsed/rest ret))
 430                    (setq ret (mime::parse-parameter str))
 431                    )
 432             (setq dest (cons (message::parsed/matched ret) dest))
 433             )
 434           (if (string-match "^[ \t]*$" str)
 435               (cons ctype (reverse dest))
 436             )))))
 437
 438 (defun mime/Content-Type ()
 439   (let ((str (message/get-field-body "Content-Type")))
 440     (if str
 441         (mime::parse-field-body/Content-Type
 442          (message/unfolding-string str))
 443       )))
 444
 445 (defun mime/Content-Transfer-Encoding (&optional default-encoding)
 446   (let ((str (message/get-field-body "Content-Transfer-Encoding")))
 447     (if str
 448         (downcase str)
 449       default-encoding)
 450       ))
 451
 452 (defun mime/get-subject (param)
 453   (save-excursion
 454     (save-restriction
 455       (let (ret)
 456         (or (and (setq ret (assoc "name" param))
 457                  (message/strip-quoted-string (cdr ret))
 458                  )
 459             (and (setq ret (assoc "x-name" param))
 460                  (message/strip-quoted-string (cdr ret))
 461                  )
 462             (progn
 463               (narrow-to-region (point-min)
 464                                 (or (and (search-forward "\n\n" nil t)
 465                                          (match-beginning 0)
 466                                          )
 467                                     (point-max)))
 468               (or
 469                (message/get-field-body "Content-Description")
 470                (message/get-field-body "Subject")
 471                ))
 472             ""))
 473       )))
 474
 475 (defun mime/get-name (param)
 476   (replace-as-filename (mime/get-subject param))
 477   )
 478
 479 (defun mime-viewer/make-preview-buffer (&optional buf cinfo obuf)
 480   (let ((the-buf (current-buffer)) pcl dest)
 481     (setq buf
 482           (if (null buf)
 483               (current-buffer)
 484             (get-buffer buf)
 485             ))
 486     (if (null cinfo)
 487         (progn
 488           (switch-to-buffer buf)
 489           (setq cinfo mime::article/content-info)
 490           ))
 491     (if (null obuf)
 492         (setq obuf (concat "*Preview-" (buffer-name buf) "*"))
 493       )
 494     (setq pcl (mime::make-flat-content-list cinfo))
 495     (if (get-buffer obuf)
 496         (kill-buffer obuf)
 497       )
 498     (setq dest
 499           (mapcar
 500            (function
 501             (lambda (cell)
 502               (let ((beg (mime::content-info/point-min cell))
 503                     (end (mime::content-info/point-max cell))
 504                     (ctype (mime::content-info/type cell))
 505                     (params (mime::content-info/parameters cell))
 506                     cnum e nb ne subj str)
 507                 (setq cnum (mime::get-point-content-number beg cinfo))
 508                 (switch-to-buffer buf)
 509                 (setq e
 510                       (if (not
 511                            (member
 512                             ctype
 513                             mime-viewer/default-showing-Content-Type-list))
 514                           (save-excursion
 515                             (save-restriction
 516                               (goto-char beg)
 517                               (re-search-forward "^$" nil t)
 518                               (+ (match-end 0) 1)
 519                               ))
 520                         end))
 521                 (if (> e (point-max))
 522                     (setq e (point-max))
 523                   )
 524                 (setq str (buffer-substring beg e))
 525                 (switch-to-buffer obuf)
 526                 (setq nb (point))
 527                 (insert str)
 528                 (setq ne (point))
 529                 (prog1
 530                     (save-excursion
 531                       (save-restriction
 532                         (narrow-to-region nb ne)
 533                         (mime/decode-message-header)
 534                         (setq subj (mime/get-subject params))
 535                         (let ((f
 536                                (cdr
 537                                 (assoc ctype
 538                                        mime-viewer/content-filter-alist))))
 539                           (if (and f (fboundp f))
 540                               (funcall f ctype params)
 541                             ))
 542                         (funcall mime-viewer/content-header-filter-function
 543                                  cnum cinfo)
 544                         (goto-char nb)
 545                         (funcall mime-viewer/content-subject-function
 546                                  cnum subj ctype params)
 547                         (setq ne (point-max))
 548                         (mime::make-preview-content-info nb (- ne 1)
 549                                                          buf cell)
 550                         ))
 551                   (goto-char ne)
 552                   )
 553                 ))) pcl))
 554     (set-buffer-modified-p nil)
 555     (setq buffer-read-only t)
 556     (switch-to-buffer the-buf)
 557     (list obuf dest)
 558     ))
 559
 560
 561 ;;; @ content information
 562 ;;;
 563
 564 (defun mime::get-point-content-number (p &optional cinfo)
 565   (if (null cinfo)
 566       (setq cinfo mime::article/content-info)
 567     )
 568   (let ((b (mime::content-info/point-min cinfo))
 569         (e (mime::content-info/point-max cinfo))
 570         (c (mime::content-info/children cinfo))
 571         )
 572     (if (and (<= b p)(<= p e))
 573         (or (let (co ret (sn 0))
 574               (catch 'tag
 575                 (while c
 576                   (setq co (car c))
 577                   (setq ret (mime::get-point-content-number p co))
 578                   (cond ((eq ret t) (throw 'tag (list sn)))
 579                         (ret (throw 'tag (cons sn ret)))
 580                         )
 581                   (setq c (cdr c))
 582                   (setq sn (+ sn 1))
 583                   )))
 584             t))))
 585
 586 (defun mime::article/get-content-region (cn &optional cinfo)
 587   (if (null cinfo)
 588       (setq cinfo mime::article/content-info)
 589     )
 590   (if (eq cn t)
 591       cinfo
 592     (let ((sn (car cn)))
 593       (if (null sn)
 594           cinfo
 595         (let ((rc (nth sn (mime::content-info/children cinfo))))
 596           (if rc
 597               (mime::article/get-content-region (cdr cn) rc)
 598             ))
 599         ))))
 600
 601 (defun mime::make-flat-content-list (&optional cinfo)
 602   (if (null cinfo)
 603       (setq cinfo mime::article/content-info)
 604     )
 605   (let ((dest (list cinfo))
 606         (rcl (mime::content-info/children cinfo))
 607         )
 608     (while rcl
 609       (setq dest (nconc dest (mime::make-flat-content-list (car rcl))))
 610       (setq rcl (cdr rcl))
 611       )
 612     dest))
 613
 614 (defun mime::point-preview-content (p &optional pcl)
 615   (if (null pcl)
 616       (setq pcl mime::preview/content-list)
 617     )
 618   (catch 'tag
 619     (let ((r pcl) cell)
 620       (while r
 621         (setq cell (car r))
 622         (if (and (<= (mime::preview-content-info/point-min cell) p)
 623                  (<= p (mime::preview-content-info/point-max cell))
 624                  )
 625             (throw 'tag cell)
 626           )
 627         (setq r (cdr r))
 628         ))
 629     (car (last pcl))
 630     ))
 631
 632
 633 ;;; @ decoder
 634 ;;;
 635
 636 (defun mime/Quoted-Printable-decode-region (beg end)
 637   (interactive "*r")
 638   (save-excursion
 639     (save-restriction
 640       (narrow-to-region beg end)
 641       (goto-char (point-min))
 642       (while (re-search-forward "=\n" nil t)
 643         (replace-match "")
 644         )
 645       (goto-char (point-min))
 646       (let (b e str)
 647         (while (re-search-forward mime/Quoted-Printable-octet-regexp nil t)
 648           (setq b (match-beginning 0))
 649           (setq e (match-end 0))
 650           (setq str (buffer-substring b e))
 651           (delete-region b e)
 652           (insert (mime/Quoted-Printable-decode-string str))
 653           ))
 654       )))
 655
 656 (defun mime/Base64-decode-region (beg end)
 657   (interactive "*r")
 658   (save-excursion
 659     (save-restriction
 660       (narrow-to-region beg end)
 661       (goto-char (point-min))
 662       (while (search-forward "\n" nil t)
 663         (replace-match "")
 664         )
 665       (let ((str (buffer-substring (point-min)(point-max))))
 666         (delete-region (point-min)(point-max))
 667         (insert (mime/base64-decode-string str))
 668         ))))
 669
 670 (defun mime/make-method-args (cal format)
 671   (mapcar (function
 672            (lambda (arg)
 673              (if (stringp arg)
 674                  arg
 675                (let ((ret (cdr (assoc (eval arg) cal))))
 676                  (if ret
 677                      ret
 678                    "")
 679                  ))
 680              ))
 681           format))
 682
 683 (defun mime/start-external-method-region (beg end cal)
 684   (save-excursion
 685     (save-restriction
 686       (narrow-to-region beg end)
 687       (goto-char beg)
 688       (let ((method (cdr (assoc 'method cal)))
 689             (name (mime/get-name cal))
 690             )
 691         (if method
 692             (let ((file (make-temp-name
 693                          (expand-file-name "TM" mime/tmp-dir)))
 694                   b args)
 695               (if (nth 1 method)
 696                   (setq b beg)
 697                 (setq b
 698                       (if (re-search-forward "^$" nil t)
 699                           (+ (match-end 0) 1)
 700                         (point-min)
 701                         ))
 702                 )
 703               (goto-char b)
 704               (write-region b end file)
 705               (setq cal (put-alist
 706                          'name (replace-as-filename name) cal))
 707               (setq cal (put-alist 'file file cal))
 708               (setq args (nconc
 709                           (list (car method)
 710                                 mime/output-buffer-name (car method)
 711                                 )
 712                           (mime/make-method-args cal (cdr (cdr method)))
 713                           ))
 714               (apply (function start-process) args)
 715               (mime/show-output-buffer)
 716               ))
 717         ))))
 718
 719 (defun mime/decode-message/partial-region (beg end cal)
 720   (goto-char beg)
 721   (let* ((root-dir (expand-file-name
 722                     (concat "m-prts-" (user-login-name)) mime/tmp-dir))
 723          (id (cdr (assoc "id" cal)))
 724          (number (cdr (assoc "number" cal)))
 725          (total (cdr (assoc "total" cal)))
 726          (the-buf (current-buffer))
 727          file
 728          (mother mime::article/preview-buffer))
 729     (if (not (file-exists-p root-dir))
 730         (make-directory root-dir)
 731       )
 732     (setq id (replace-as-filename id))
 733     (setq root-dir (concat root-dir "/" id))
 734     (if (not (file-exists-p root-dir))
 735         (make-directory root-dir)
 736       )
 737     (setq file (concat root-dir "/FULL"))
 738     (if (not (file-exists-p file))
 739         (progn
 740           (re-search-forward "^$")
 741           (goto-char (+ (match-end 0) 1))
 742           (setq file (concat root-dir "/" number))
 743           (write-region (point) (point-max) file)
 744           (if (get-buffer "*MIME-temp*")
 745               (kill-buffer "*MIME-temp*")
 746             )
 747           (switch-to-buffer "*MIME-temp*")
 748           (let ((i 1)
 749                 (max (string-to-int total))
 750                 )
 751             (catch 'tag
 752               (while (<= i max)
 753                 (setq file (concat root-dir "/" (int-to-string i)))
 754                 (if (not (file-exists-p file))
 755                     (progn
 756                       (switch-to-buffer the-buf)
 757                       (throw 'tag nil)
 758                       ))
 759                 (insert-file-contents file)
 760                 (goto-char (point-max))
 761                 (setq i (+ i 1))
 762                 )
 763               (delete-other-windows)
 764               (write-file (concat root-dir "/FULL"))
 765               (setq major-mode 'mime/show-message-mode)
 766               (mime/viewer-mode mother)
 767               (pop-to-buffer (current-buffer))
 768               ))
 769           )
 770       (progn
 771         (delete-other-windows)
 772         (find-file file)
 773         (setq major-mode 'mime/show-message-mode)
 774         (mime/viewer-mode mother)
 775         (pop-to-buffer (current-buffer))
 776         ))
 777     ))
 778
 779 (defun mime/get-content-decoding-alist (al)
 780   (get-unified-alist mime/content-decoding-condition al)
 781   )
 782
 783 (defun mime::article/decode-content-region (cinfo)
 784   (let ((beg (mime::content-info/point-min cinfo))
 785         (end (mime::content-info/point-max cinfo))
 786         (ctype (mime::content-info/type cinfo))
 787         (params (mime::content-info/parameters cinfo))
 788         (encoding (mime::content-info/encoding cinfo))
 789         )
 790     (if ctype
 791         (let (method cal ret)
 792           (setq cal (append (list (cons 'type ctype)
 793                                   (cons 'encoding encoding)
 794                                   (cons 'major-mode major-mode)
 795                                   )
 796                             params))
 797           (if mime-viewer/decoding-mode
 798               (setq cal (cons
 799                          (cons 'mode mime-viewer/decoding-mode)
 800                          cal))
 801             )
 802           (setq ret (mime/get-content-decoding-alist cal))
 803           (setq method (cdr (assoc 'method ret)))
 804           (cond ((and (symbolp method)
 805                       (fboundp method))
 806                  (funcall method beg end ret)
 807                  )
 808                 ((and (listp method)(stringp (car method)))
 809                  (mime/start-external-method-region beg end ret)
 810                  )
 811                 (t (mime/show-output-buffer
 812                     "No method are specified for %s\n" ctype)
 813                    ))
 814           ))
 815     ))
 816
 817 (defun mime/show-output-buffer (&rest forms)
 818   (let ((the-buf (current-buffer)))
 819     (if (null (get-buffer-window mime/output-buffer-name))
 820         (split-window-vertically (/ (* (window-height) 3) 4))
 821       )
 822     (pop-to-buffer mime/output-buffer-name)
 823     (goto-char (point-max))
 824     (if forms
 825         (insert (apply (function format) forms))
 826       )
 827     (pop-to-buffer the-buf)
 828     ))
 829
 830
 831 ;;; @ content filter
 832 ;;;
 833
 834 (defun mime-viewer/filter-text/plain (ctype params)
 835   (save-excursion
 836     (save-restriction
 837       (let ((charset (cdr (assoc "charset" params)))
 838             (encoding
 839              (save-excursion
 840                (save-restriction
 841                  (goto-char (point-min))
 842                  (narrow-to-region (point-min)
 843                                    (or (and (search-forward "\n\n" nil t)
 844                                             (match-beginning 0))
 845                                        (point-max)))
 846                  (goto-char (point-min))
 847                  (mime/Content-Transfer-Encoding "7bit")
 848                  )))
 849             (beg (point-min)) (end (point-max))
 850             )
 851         (goto-char (point-min))
 852         (if (search-forward "\n\n" nil t)
 853             (setq beg (match-end 0))
 854           )
 855         (if (cond ((string= encoding "quoted-printable")
 856                    (mime/Quoted-Printable-decode-region beg end)
 857                    t)
 858                   ((string= encoding "base64")
 859                    (mime/Base64-decode-region beg end)
 860                    t))
 861             (mime/code-convert-region-to-emacs beg (point-max) charset)
 862           )
 863         ))))
 864
 865
 866 ;;; @ MIME viewer mode
 867 ;;;
 868
 869 (defvar mime/viewer-mode-map nil)
 870 (if (null mime/viewer-mode-map)
 871     (progn
 872       (setq mime/viewer-mode-map (make-keymap))
 873       (suppress-keymap mime/viewer-mode-map)
 874       (define-key mime/viewer-mode-map
 875         "u"        (function mime-viewer/up-content))
 876       (define-key mime/viewer-mode-map
 877         "p"        (function mime-viewer/previous-content))
 878       (define-key mime/viewer-mode-map
 879         "n"        (function mime-viewer/next-content))
 880       (define-key mime/viewer-mode-map
 881         " "        (function mime-viewer/scroll-up-content))
 882       (define-key mime/viewer-mode-map
 883         "\M- "     (function mime-viewer/scroll-down-content))
 884       (define-key mime/viewer-mode-map
 885         "\177"     (function mime-viewer/scroll-down-content))
 886       (define-key mime/viewer-mode-map
 887         "\C-m"     (function mime-viewer/next-line-content))
 888       (define-key mime/viewer-mode-map
 889         "\C-\M-m"  (function mime-viewer/previous-line-content))
 890       (define-key mime/viewer-mode-map
 891         "v"        (function mime-viewer/play-content))
 892       (define-key mime/viewer-mode-map
 893         "e"        (function mime-viewer/extract-content))
 894       (define-key mime/viewer-mode-map
 895         "\C-c\C-p" (function mime-viewer/print-content))
 896       (define-key mime/viewer-mode-map
 897         "q"        (function mime-viewer/quit))
 898       (define-key mime/viewer-mode-map
 899         "\C-c\C-x" (function mime-viewer/kill-buffer))
 900       ))
 901
 902 (defun mime/viewer-mode (&optional mother ctl encoding)
 903   "Major mode for viewing MIME message.
 904
 905 u       Move to upper content
 906 p       Move to previous content
 907 n       Move to next content
 908 SPC     Scroll up
 909 M-SPC   Scroll down
 910 DEL     Scroll down
 911 RET     Move to next line
 912 M-RET   Move to previous line
 913 v       Decode the content as `play mode'
 914 e       Decode the content as `extract mode'
 915 C-c C-p Decode the content as `print mode'
 916 q       Quit
 917 "
 918   (interactive)
 919   (let ((buf (get-buffer mime/output-buffer-name))
 920         (the-buf (current-buffer))
 921         )
 922     (if buf
 923         (progn
 924           (switch-to-buffer buf)
 925           (erase-buffer)
 926           (switch-to-buffer the-buf)
 927           )))
 928   (let ((ret (mime-viewer/parse-message ctl encoding))
 929         (mode major-mode))
 930     (switch-to-buffer (car ret))
 931     (setq major-mode 'mime/viewer-mode)
 932     (setq mode-name "MIME-View")
 933     (make-variable-buffer-local 'mime::preview/original-major-mode)
 934     (setq mime::preview/original-major-mode
 935           (if mother
 936               (progn
 937                 (make-variable-buffer-local
 938                  'mime/show-mode-old-window-configuration)
 939                 (setq mime/show-mode-old-window-configuration
 940                       (current-window-configuration))
 941                 (make-variable-buffer-local 'mime/mother-buffer)
 942                 (setq mime/mother-buffer mother)
 943                 'mime/show-message-mode)
 944             mode))
 945     (use-local-map mime/viewer-mode-map)
 946     (make-variable-buffer-local 'mime::preview/content-list)
 947     (setq mime::preview/content-list (nth 1 ret))
 948     (goto-char
 949      (let ((ce (mime::preview-content-info/point-max
 950                 (car mime::preview/content-list)
 951                 ))
 952            e)
 953        (goto-char (point-min))
 954        (search-forward "\n\n" nil t)
 955        (setq e (match-end 0))
 956        (if (<= e ce)
 957            e
 958          ce)))
 959     (run-hooks 'mime/viewer-mode-hook)
 960     ))
 961
 962 (defun mime::preview/decode-content ()
 963   (interactive)
 964   (let ((pc (mime::point-preview-content (point))))
 965     (if pc
 966         (let ((the-buf (current-buffer)))
 967           (switch-to-buffer (mime::preview-content-info/buffer pc))
 968           (mime::article/decode-content-region
 969            (mime::preview-content-info/content-info pc))
 970           (if (eq (current-buffer)
 971                   (mime::preview-content-info/buffer pc))
 972               (switch-to-buffer the-buf)
 973             )
 974           ))))
 975
 976 (defun mime-viewer/play-content ()
 977   (interactive)
 978   (let ((mime-viewer/decoding-mode "play"))
 979     (mime::preview/decode-content)
 980     ))
 981
 982 (defun mime-viewer/extract-content ()
 983   (interactive)
 984   (let ((mime-viewer/decoding-mode "extract"))
 985     (mime::preview/decode-content)
 986     ))
 987
 988 (defun mime-viewer/print-content ()
 989   (interactive)
 990   (let ((mime-viewer/decoding-mode "print"))
 991     (mime::preview/decode-content)
 992     ))
 993
 994 (defun mime-viewer/up-content ()
 995   (interactive)
 996   (let ((pc (mime::point-preview-content (point))) cinfo
 997         (the-buf (current-buffer))
 998         cn r)
 999     (switch-to-buffer (mime::preview-content-info/buffer pc))
1000     (setq cinfo (mime::preview-content-info/content-info pc))
1001     (setq cn (mime::get-point-content-number
1002               (mime::content-info/point-min cinfo)))
1003     (if (eq cn t)
1004         (mime-viewer/quit the-buf
1005                           (mime::preview-content-info/buffer pc)
1006                           )
1007       (setq r (mime::article/get-content-region (butlast cn)))
1008       (switch-to-buffer the-buf)
1009       (catch 'tag
1010         (let ((rpcl mime::preview/content-list) cell)
1011           (while rpcl
1012             (setq cell (car rpcl))
1013             (if (eq r (mime::preview-content-info/content-info cell))
1014                 (progn
1015                   (goto-char (mime::preview-content-info/point-min cell))
1016                   (throw 'tag nil)
1017                   ))
1018             (setq rpcl (cdr rpcl))
1019             )))
1020       )))
1021
1022 (defun mime-viewer/previous-content ()
1023   (interactive)
1024   (let* ((pcl mime::preview/content-list)
1025          (p (point))
1026          (i (- (length pcl) 1))
1027          beg)
1028     (catch 'tag
1029       (while (>= i 0)
1030         (setq beg (mime::preview-content-info/point-min (nth i pcl)))
1031         (if (> p beg)
1032             (throw 'tag (goto-char beg))
1033           )
1034         (setq i (- i 1))
1035         ))
1036     ))
1037
1038 (defun mime-viewer/next-content ()
1039   (interactive)
1040   (let ((pcl mime::preview/content-list)
1041         (p (point))
1042         beg)
1043     (catch 'tag
1044       (while pcl
1045         (setq beg (mime::preview-content-info/point-min (car pcl)))
1046         (if (< p beg)
1047             (throw 'tag (goto-char beg))
1048           )
1049         (setq pcl (cdr pcl))
1050         ))
1051     ))
1052
1053 (defun mime-viewer/scroll-up-content (&optional h)
1054   (interactive)
1055   (if (null h)
1056       (setq h (- (window-height) 1))
1057     )
1058   (let ((pcl mime::preview/content-list)
1059         (p (point))
1060         np beg)
1061     (setq np
1062           (or (catch 'tag
1063                 (while pcl
1064                   (setq beg (mime::preview-content-info/point-min (car pcl)))
1065                   (if (< p beg)
1066                       (throw 'tag beg)
1067                     )
1068                   (setq pcl (cdr pcl))
1069                   ))
1070               (point-max)))
1071     (forward-line h)
1072     (if (> (point) np)
1073         (goto-char np)
1074       )))
1075
1076 (defun mime-viewer/scroll-down-content (&optional h)
1077   (interactive)
1078   (if (null h)
1079       (setq h (- (window-height) 1))
1080     )
1081   (let ((pcl mime::preview/content-list)
1082         (p (point))
1083         pp beg)
1084     (setq pp
1085           (or (let ((i (- (length pcl) 1)))
1086                 (catch 'tag
1087                   (while (> i 0)
1088                     (setq beg (mime::preview-content-info/point-min
1089                                (nth i pcl)))
1090                     (if (> p beg)
1091                         (throw 'tag beg)
1092                       )
1093                     (setq i (- i 1))
1094                     )))
1095               (point-min)))
1096     (forward-line (- h))
1097     (if (< (point) pp)
1098         (goto-char pp)
1099       )))
1100
1101 (defun mime-viewer/next-line-content ()
1102   (interactive)
1103   (mime-viewer/scroll-up-content 1)
1104   )
1105
1106 (defun mime-viewer/previous-line-content ()
1107   (interactive)
1108   (mime-viewer/scroll-down-content 1)
1109   )
1110
1111 (defun mime-viewer/quit (&optional the-buf buf)
1112   (interactive)
1113   (if (null the-buf)
1114       (setq the-buf (current-buffer))
1115     )
1116   (if (null buf)
1117       (setq buf (mime::preview-content-info/buffer
1118                  (mime::point-preview-content (point))))
1119     )
1120   (let ((r (progn
1121              (switch-to-buffer buf)
1122              (assoc major-mode mime-viewer/quitting-method-alist)
1123              )))
1124     (if r
1125         (progn
1126           (switch-to-buffer the-buf)
1127           (funcall (cdr r))
1128           ))
1129     ))
1130
1131 (defun mime-viewer/kill-buffer ()
1132   (interactive)
1133   (kill-buffer (current-buffer))
1134   )
1135
1136 (fset 'mime/view-mode 'mime/viewer-mode)
1137
1138 (run-hooks 'tm-view-load-hook)