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