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