tm-view.el

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