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