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-def)
  18
  19
  20 ;;; @ version
  21 ;;;
  22
  23 (defconst mime-viewer/RCS-ID
  24   "$Id: tm-view.el,v 6.79 1995/09/08 14:50:03 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/content-type-subtype-regexp
  34   (concat mime/token-regexp "/" mime/token-regexp))
  35 (defconst mime/content-parameter-value-regexp
  36   (concat "\\("
  37           message/quoted-string-regexp
  38           "\\|[^; \t\n]*\\)"))
  39
  40 (defconst mime/output-buffer-name "*MIME-out*")
  41 (defconst mime/decoding-buffer-name "*MIME-decoding*")
  42
  43
  44 ;;; @ variables
  45 ;;;
  46
  47 (defvar mime/content-decoding-condition
  48   '(((type . "text/plain")
  49      (method "tm-plain" nil 'file 'type 'encoding 'mode 'name))
  50     ;;((type . "text/x-latex")
  51     ;; (method "tm-latex" nil 'file 'type 'encoding 'mode 'name))
  52     ((type . "audio/basic")
  53      (method "tm-au"    nil 'file 'type 'encoding 'mode 'name))
  54     ((type . "image/gif")
  55      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  56     ((type . "image/jpeg")
  57      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  58     ((type . "image/tiff")
  59      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  60     ((type . "image/x-tiff")
  61      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  62     ((type . "image/x-xbm")
  63      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  64     ((type . "image/x-pic")
  65      (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
  66     ((type . "video/mpeg")
  67      (method "tm-mpeg"  nil 'file 'type 'encoding 'mode 'name))
  68     ((type . "application/octet-stream")
  69      (method "tm-file"  nil 'file 'type 'encoding 'mode 'name))
  70     ;;((type . "message/external-body")
  71     ;; (method "xterm" nil
  72     ;;         "-e" "showexternal"
  73     ;;         'file '"access-type" '"name" '"site" '"directory"))
  74     ((type . "message/partial")
  75      (method . mime/decode-message/partial-region))
  76     ((type . "message/rfc822")
  77      (method "tm-file"  nil 'file 'type 'encoding 'mode 'name))
  78     ((method "metamail" t
  79              "-m" "tm" "-x" "-d" "-z" "-e" 'file)(mode . "play"))
  80     ))
  81
  82 (defvar mime-viewer/childrens-header-showing-Content-Type-list
  83   '("message/rfc822"))
  84
  85 (defvar mime-viewer/default-showing-Content-Type-list
  86   '("text/plain" "text/richtext" "text/enriched"
  87     "text/x-latex" "application/x-latex"
  88     "application/octet-stream" nil
  89     "application/x-selection" "application/x-comment"))
  90
  91 (defvar mime-viewer/content-subject-omitting-Content-Type-list
  92   '("application/x-selection"))
  93
  94 (defvar mime-viewer/uuencode-encoding-name-list '("x-uue" "x-uuencode"))
  95
  96 (defvar mime-viewer/ignored-field-list
  97   '("Received" "Return-Path" "Replied" "Errors-To"
  98     "Lines" "Sender" "Path" "Nntp-Posting-Host"
  99     "Content-Type" "Precedence"))
 100
 101 (defvar mime-viewer/ignored-field-regexp)
 102
 103 (defvar mime-viewer/decoding-mode "play" "MIME body decoding mode")
 104
 105 (defvar mime-viewer/file-name-char-regexp "[A-Za-z0-9+_-]")
 106
 107 (defvar mime-viewer/file-name-regexp-1
 108   (concat mime-viewer/file-name-char-regexp "+\\."
 109           mime-viewer/file-name-char-regexp "+"))
 110
 111 (defvar mime-viewer/file-name-regexp-2
 112   (concat (regexp-* mime-viewer/file-name-char-regexp)
 113           "\\(\\." mime-viewer/file-name-char-regexp "+\\)*"))
 114
 115 (defvar mime-viewer/announcement-for-message/partial
 116   "[[ This is message/partial style split message. ]]
 117 [[ Please press `v' key in this buffer.         ]]")
 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/insert-content-subject
 158   (cnum cinfo ctype params subj)
 159   (insert
 160    (let ((access-type (assoc "access-type" params))
 161          (num (or (assoc-value "x-part-number" params)
 162                   (if (listp cnum)
 163                       (mapconcat (function
 164                                   (lambda (num)
 165                                     (format "%s" (+ num 1))
 166                                     ))
 167                                  cnum ".")
 168                     "0"))
 169               ))
 170      (if access-type
 171          (let ((server (assoc "server" params)))
 172            (setq access-type (cdr access-type))
 173            (if server
 174                (format "[%s %s ([%s] %s)]\n" num subj
 175                        access-type (cdr server))
 176              (let ((site (assoc-value "site" params))
 177                    (dir (assoc-value "directory" params))
 178                    )
 179                (format "[%s %s ([%s] %s:%s)]\n" num subj
 180                        access-type site dir)
 181                )))
 182        (format "[%s %s (%s)]\n" num subj ctype)
 183        ))))
 184
 185 (defun mime-viewer/default-content-subject-function
 186   (cnum cinfo ctype params subj)
 187   (if (and (listp cnum)
 188            (not (member
 189                  ctype
 190                  mime-viewer/content-subject-omitting-Content-Type-list))
 191            )
 192       (mime-viewer/insert-content-subject
 193        cnum cinfo ctype params subj)
 194     ))
 195
 196 (defvar mime-viewer/content-subject-function
 197   (function mime-viewer/default-content-subject-function))
 198
 199
 200 ;;; @ content header filter
 201 ;;;
 202
 203 (defun mime-viewer/default-content-header-filter ()
 204   (goto-char (point-min))
 205   (while (and (re-search-forward
 206                (concat "^" mime-viewer/ignored-field-regexp ":")
 207                nil t)
 208               (progn
 209                 (delete-region
 210                  (match-beginning 0)
 211                  (save-excursion
 212                    (and
 213                     (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
 214                     (match-beginning 0)
 215                     )))
 216                 t)))
 217   (mime/decode-message-header)
 218   )
 219
 220 (defvar mime-viewer/content-header-filter-alist nil)
 221
 222
 223 ;;; @@ content filter
 224 ;;;
 225
 226 (defvar mime-viewer/content-filter-alist
 227   '(("text/plain" . mime-viewer/filter-text/plain)
 228     (nil . mime-viewer/filter-text/plain)))
 229
 230 (defun mime-viewer/default-content-filter (cnum cinfo ctype params subj)
 231   )
 232
 233
 234 ;;; @@ content separator
 235 ;;;
 236
 237 (defun mime-viewer/default-content-separator (cnum cinfo ctype params subj)
 238   (if (and (not (mime-viewer/header-visible-p cnum cinfo ctype))
 239            (not (mime-viewer/body-visible-p cnum cinfo ctype))
 240            )
 241       (progn
 242         (goto-char (point-max))
 243         (insert "\n")
 244         )))
 245
 246
 247 ;;; @@ buffer local variables
 248 ;;;
 249
 250 (defvar mime::article/content-info nil)
 251 (defvar mime::article/preview-buffer nil)
 252
 253 (defvar mime::preview/article-buffer nil)
 254 (defvar mime::preview/content-list nil)
 255 (defvar mime::preview/original-major-mode nil)
 256
 257
 258 ;;; @@ quitting method
 259 ;;;
 260
 261 (defvar mime-viewer/quitting-method-alist
 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     (setq dest
 538           (mapcar
 539            (function
 540             (lambda (cell)
 541               (let ((beg (mime::content-info/point-min cell))
 542                     (end (mime::content-info/point-max cell))
 543                     (ctype (mime::content-info/type cell))
 544                     (params (mime::content-info/parameters cell))
 545                     (encoding (mime::content-info/encoding cell))
 546                     he cnum e nb ne subj str)
 547                 (setq cnum (mime::get-point-content-number beg cinfo))
 548                 (switch-to-buffer the-buf)
 549                 (setq he (save-excursion
 550                            (goto-char beg)
 551                            (re-search-forward "^$" nil t)
 552                            (+ (match-end 0) 1)
 553                            ))
 554                 (if (> he (point-max))
 555                     (setq he (point-max))
 556                   )
 557                 (save-excursion
 558                   (save-restriction
 559                     (narrow-to-region beg he)
 560                     (setq subj (mime-viewer/get-subject params))
 561                     ))
 562                 (switch-to-buffer obuf)
 563                 (setq nb (point))
 564                 (narrow-to-region nb nb)
 565                 (switch-to-buffer the-buf)
 566                 (if (mime-viewer/header-visible-p cnum cinfo ctype)
 567                     (progn
 568                       (setq str (buffer-substring beg he))
 569                       (switch-to-buffer obuf)
 570                       (insert str)
 571                       (let ((f (assq
 572                                 mode
 573                                 mime-viewer/content-header-filter-alist))
 574                             )
 575                         (if (and f (setq f (cdr f)))
 576                             (funcall f)
 577                           (mime-viewer/default-content-header-filter)
 578                           ))
 579                       (run-hooks 'mime-viewer/content-header-filter-hook)
 580                       (switch-to-buffer the-buf)
 581                       ))
 582                 (cond ((mime-viewer/body-visible-p cnum cinfo ctype)
 583                        (let (be)
 584                          (setq str (buffer-substring he end))
 585                          (switch-to-buffer obuf)
 586                          (save-restriction
 587                            (setq be (point-max))
 588                            (narrow-to-region be be)
 589                            (insert str)
 590                            (setq ne (point-max))
 591                            (let ((f (or (assoc-value
 592                                          ctype
 593                                          mime-viewer/content-filter-alist)
 594                                         )))
 595                              (if (and f (fboundp f))
 596                                  (funcall f ctype params encoding)
 597                                (mime-viewer/default-content-filter
 598                                 cnum cinfo ctype params subj)
 599                                ))
 600                            (setq ne (point-max))
 601                            )
 602                          (switch-to-buffer the-buf)
 603                          ))
 604                       ((equal ctype "message/partial")
 605                        (let (be)
 606                          (switch-to-buffer obuf)
 607                          (save-restriction
 608                            (setq be (point-max))
 609                            (narrow-to-region be be)
 610                            (insert
 611                             mime-viewer/announcement-for-message/partial)
 612                            (setq ne (point-max))
 613                            )
 614                          (switch-to-buffer the-buf)
 615                          ))
 616                       ((and (eq cnum t)
 617                             (null (mime::content-info/children cinfo))
 618                             )
 619                        (let (be)
 620                          (switch-to-buffer obuf)
 621                          (save-restriction
 622                            (setq be (point-max))
 623                            (narrow-to-region be be)
 624                            (mime-viewer/insert-content-subject
 625                             cnum cinfo ctype params subj)
 626                            (setq ne (point-max))
 627                            )
 628                          (switch-to-buffer the-buf)
 629                          ))
 630                       )
 631                 (switch-to-buffer obuf)
 632                 (mime-viewer/default-content-separator
 633                  cnum cinfo ctype params subj)
 634                 (prog1
 635                     (progn
 636                       (goto-char nb)
 637                       (funcall mime-viewer/content-subject-function
 638                                cnum cinfo ctype params subj)
 639                       (setq ne (point-max))
 640                       (widen)
 641                       (mime::preview-content-info/create nb (- ne 1)
 642                                                          buf cell)
 643                       )
 644                   (goto-char ne)
 645                   ))))
 646            pcl))
 647     (set-buffer-modified-p nil)
 648     (setq buffer-read-only t)
 649     (switch-to-buffer the-buf)
 650     (list obuf dest)
 651     ))
 652
 653
 654 ;;; @ content information
 655 ;;;
 656
 657 (defun mime::get-point-content-number (p &optional cinfo)
 658   (or cinfo
 659       (setq cinfo mime::article/content-info)
 660       )
 661   (let ((b (mime::content-info/point-min cinfo))
 662         (e (mime::content-info/point-max cinfo))
 663         (c (mime::content-info/children cinfo))
 664         )
 665     (if (and (<= b p)(<= p e))
 666         (or (let (co ret (sn 0))
 667               (catch 'tag
 668                 (while c
 669                   (setq co (car c))
 670                   (setq ret (mime::get-point-content-number p co))
 671                   (cond ((eq ret t) (throw 'tag (list sn)))
 672                         (ret (throw 'tag (cons sn ret)))
 673                         )
 674                   (setq c (cdr c))
 675                   (setq sn (+ sn 1))
 676                   )))
 677             t))))
 678
 679 (defun mime-article/cnum-to-cinfo (cn &optional cinfo)
 680   (or cinfo
 681       (setq cinfo mime::article/content-info)
 682       )
 683   (if (eq cn t)
 684       cinfo
 685     (let ((sn (car cn)))
 686       (if (null sn)
 687           cinfo
 688         (let ((rc (nth sn (mime::content-info/children cinfo))))
 689           (if rc
 690               (mime-article/cnum-to-cinfo (cdr cn) rc)
 691             ))
 692         ))))
 693
 694 (defun mime::make-flat-content-list (&optional cinfo)
 695   (or cinfo
 696       (setq cinfo mime::article/content-info)
 697       )
 698   (let ((dest (list cinfo))
 699         (rcl (mime::content-info/children cinfo))
 700         )
 701     (while rcl
 702       (setq dest (nconc dest (mime::make-flat-content-list (car rcl))))
 703       (setq rcl (cdr rcl))
 704       )
 705     dest))
 706
 707 (defun mime::point-preview-content (p &optional pcl)
 708   (or pcl
 709       (setq pcl mime::preview/content-list)
 710       )
 711   (catch 'tag
 712     (let ((r pcl) cell)
 713       (while r
 714         (setq cell (car r))
 715         (if (and (<= (mime::preview-content-info/point-min cell) p)
 716                  (<= p (mime::preview-content-info/point-max cell))
 717                  )
 718             (throw 'tag cell)
 719           )
 720         (setq r (cdr r))
 721         ))
 722     (car (last pcl))
 723     ))
 724
 725
 726 ;;; @ decoder
 727 ;;;
 728
 729 (defun mime/make-method-args (cal format)
 730   (mapcar (function
 731            (lambda (arg)
 732              (if (stringp arg)
 733                  arg
 734                (let ((ret (cdr (assoc (eval arg) cal))))
 735                  (if ret
 736                      ret
 737                    "")
 738                  ))
 739              ))
 740           format))
 741
 742 (defun mime/start-external-method-region (beg end cal)
 743   (save-excursion
 744     (save-restriction
 745       (narrow-to-region beg end)
 746       (goto-char beg)
 747       (let ((method (cdr (assoc 'method cal)))
 748             (name (mime-viewer/get-name cal))
 749             )
 750         (if method
 751             (let ((file (make-temp-name
 752                          (expand-file-name "TM" mime/tmp-dir)))
 753                   b args)
 754               (if (nth 1 method)
 755                   (setq b beg)
 756                 (setq b
 757                       (if (re-search-forward "^$" nil t)
 758                           (+ (match-end 0) 1)
 759                         (point-min)
 760                         ))
 761                 )
 762               (goto-char b)
 763               (write-region b end file)
 764               (setq cal (put-alist
 765                          'name (replace-as-filename name) cal))
 766               (setq cal (put-alist 'file file cal))
 767               (setq args (nconc
 768                           (list (car method)
 769                                 mime/output-buffer-name (car method)
 770                                 )
 771                           (mime/make-method-args cal (cdr (cdr method)))
 772                           ))
 773               (apply (function start-process) args)
 774               (mime/show-output-buffer)
 775               ))
 776         ))))
 777
 778 (defun mime/decode-message/partial-region (beg end cal)
 779   (goto-char beg)
 780   (let* ((root-dir (expand-file-name
 781                     (concat "m-prts-" (user-login-name)) mime/tmp-dir))
 782          (id (cdr (assoc "id" cal)))
 783          (number (cdr (assoc "number" cal)))
 784          (total (cdr (assoc "total" cal)))
 785          (the-buf (current-buffer))
 786          file
 787          (mother mime::article/preview-buffer))
 788     (if (not (file-exists-p root-dir))
 789         (make-directory root-dir)
 790       )
 791     (setq id (replace-as-filename id))
 792     (setq root-dir (concat root-dir "/" id))
 793     (if (not (file-exists-p root-dir))
 794         (make-directory root-dir)
 795       )
 796     (setq file (concat root-dir "/FULL"))
 797     (if (not (file-exists-p file))
 798         (progn
 799           (re-search-forward "^$")
 800           (goto-char (+ (match-end 0) 1))
 801           (setq file (concat root-dir "/" number))
 802           (write-region (point) (point-max) file)
 803           (if (get-buffer "*MIME-temp*")
 804               (kill-buffer "*MIME-temp*")
 805             )
 806           (switch-to-buffer "*MIME-temp*")
 807           (let ((i 1)
 808                 (max (string-to-int total))
 809                 )
 810             (catch 'tag
 811               (while (<= i max)
 812                 (setq file (concat root-dir "/" (int-to-string i)))
 813                 (if (not (file-exists-p file))
 814                     (progn
 815                       (switch-to-buffer the-buf)
 816                       (throw 'tag nil)
 817                       ))
 818                 (insert-file-contents file)
 819                 (goto-char (point-max))
 820                 (setq i (+ i 1))
 821                 )
 822               (delete-other-windows)
 823               (write-file (concat root-dir "/FULL"))
 824               (setq major-mode 'mime/show-message-mode)
 825               (mime/viewer-mode mother)
 826               (pop-to-buffer (current-buffer))
 827               ))
 828           )
 829       (progn
 830         (delete-other-windows)
 831         (find-file file)
 832         (setq major-mode 'mime/show-message-mode)
 833         (mime/viewer-mode mother)
 834         (pop-to-buffer (current-buffer))
 835         ))
 836     ))
 837
 838 (defun mime/get-content-decoding-alist (al)
 839   (get-unified-alist mime/content-decoding-condition al)
 840   )
 841
 842 (defun mime::article/decode-content-region (cinfo)
 843   (let ((beg (mime::content-info/point-min cinfo))
 844         (end (mime::content-info/point-max cinfo))
 845         (ctype (mime::content-info/type cinfo))
 846         (params (mime::content-info/parameters cinfo))
 847         (encoding (mime::content-info/encoding cinfo))
 848         )
 849     (if ctype
 850         (let (method cal ret)
 851           (setq cal (append (list (cons 'type ctype)
 852                                   (cons 'encoding encoding)
 853                                   (cons 'major-mode major-mode)
 854                                   )
 855                             params))
 856           (if mime-viewer/decoding-mode
 857               (setq cal (cons
 858                          (cons 'mode mime-viewer/decoding-mode)
 859                          cal))
 860             )
 861           (setq ret (mime/get-content-decoding-alist cal))
 862           (setq method (cdr (assoc 'method ret)))
 863           (cond ((and (symbolp method)
 864                       (fboundp method))
 865                  (funcall method beg end ret)
 866                  )
 867                 ((and (listp method)(stringp (car method)))
 868                  (mime/start-external-method-region beg end ret)
 869                  )
 870                 (t (mime/show-output-buffer
 871                     "No method are specified for %s\n" ctype)
 872                    ))
 873           ))
 874     ))
 875
 876 (defun mime/show-output-buffer (&rest forms)
 877   (let ((the-buf (current-buffer)))
 878     (if (null (get-buffer-window mime/output-buffer-name))
 879         (split-window-vertically (/ (* (window-height) 3) 4))
 880       )
 881     (pop-to-buffer mime/output-buffer-name)
 882     (goto-char (point-max))
 883     (if forms
 884         (insert (apply (function format) forms))
 885       )
 886     (pop-to-buffer the-buf)
 887     ))
 888
 889
 890 ;;; @ content filter
 891 ;;;
 892
 893 (defvar mime-viewer/code-converter-alist nil)
 894
 895 (defun mime-viewer/default-code-convert-region
 896   (beg end charset &optional encoding)
 897   (if (member encoding '("quoted-printable" "base64"))
 898       (mime/code-convert-region-to-emacs beg (point-max) charset)
 899     ))
 900
 901 (defun mime-viewer/filter-text/plain (ctype params encoding)
 902   (let ((charset (cdr (assoc "charset" params)))
 903         (beg (point-min)) (end (point-max))
 904         )
 905     (goto-char (point-min))
 906     (cond ((string= encoding "quoted-printable")
 907            (quoted-printable-decode-region beg end)
 908            )
 909           ((string= encoding "base64")
 910            (base64-decode-region beg end)
 911            ))
 912     (let* ((mode mime::preview/original-major-mode)
 913            (m (assq mode mime-viewer/code-converter-alist))
 914            )
 915       (if (and m (fboundp (setq m (cdr m))))
 916           (funcall m beg (point-max) charset encoding)
 917         (mime-viewer/default-code-convert-region beg (point-max)
 918                                                  charset encoding)
 919         )))
 920   (goto-char (point-max))
 921   (if (not (eq (char-after (1- (point))) ?\n))
 922       (insert "\n")
 923     )
 924   ;;(hide-sublevels 1)
 925   (run-hooks 'mime-viewer/plain-text-preview-hook)
 926   )
 927
 928
 929 ;;; @ MIME viewer mode
 930 ;;;
 931
 932 (defvar mime/viewer-mode-map nil)
 933 (if (null mime/viewer-mode-map)
 934     (progn
 935       (setq mime/viewer-mode-map (make-keymap))
 936       (suppress-keymap mime/viewer-mode-map)
 937       (define-key mime/viewer-mode-map
 938         "u"        (function mime-viewer/up-content))
 939       (define-key mime/viewer-mode-map
 940         "p"        (function mime-viewer/previous-content))
 941       (define-key mime/viewer-mode-map
 942         "n"        (function mime-viewer/next-content))
 943       (define-key mime/viewer-mode-map
 944         " "        (function mime-viewer/scroll-up-content))
 945       (define-key mime/viewer-mode-map
 946         "\M- "     (function mime-viewer/scroll-down-content))
 947       (define-key mime/viewer-mode-map
 948         "\177"     (function mime-viewer/scroll-down-content))
 949       (define-key mime/viewer-mode-map
 950         "\C-m"     (function mime-viewer/next-line-content))
 951       (define-key mime/viewer-mode-map
 952         "\C-\M-m"  (function mime-viewer/previous-line-content))
 953       (define-key mime/viewer-mode-map
 954         "v"        (function mime-viewer/play-content))
 955       (define-key mime/viewer-mode-map
 956         "e"        (function mime-viewer/extract-content))
 957       (define-key mime/viewer-mode-map
 958         "\C-c\C-p" (function mime-viewer/print-content))
 959       (define-key mime/viewer-mode-map
 960         "q"        (function mime-viewer/quit))
 961       (define-key mime/viewer-mode-map
 962         "\C-c\C-x" (function mime-viewer/kill-buffer))
 963       (cond ((string-match "XEmacs\\|Lucid" emacs-version)
 964              (define-key mime/viewer-mode-map
 965                'button2 (function mime-viewer/play-content-mouse))
 966              )
 967             ((>= emacs-major-version 19)
 968              (define-key mime/viewer-mode-map
 969                [mouse-2] (function mime-viewer/play-content-mouse))
 970              ))
 971       ))
 972
 973 (defun mime/viewer-mode (&optional mother ctl encoding)
 974   "Major mode for viewing MIME message.
 975
 976 u       Move to upper content
 977 p       Move to previous content
 978 n       Move to next content
 979 SPC     Scroll up
 980 M-SPC   Scroll down
 981 DEL     Scroll down
 982 RET     Move to next line
 983 M-RET   Move to previous line
 984 v       Decode the content as `play mode'
 985 e       Decode the content as `extract mode'
 986 C-c C-p Decode the content as `print mode'
 987 q       Quit
 988 "
 989   (interactive)
 990   (setq mime-viewer/ignored-field-regexp
 991         (concat "\\("
 992                 (mapconcat (function regexp-quote)
 993                            mime-viewer/ignored-field-list "\\|")
 994                 "\\)"))
 995   (let ((buf (get-buffer mime/output-buffer-name))
 996         (the-buf (current-buffer))
 997         )
 998     (if buf
 999         (progn
1000           (switch-to-buffer buf)
1001           (erase-buffer)
1002           (switch-to-buffer the-buf)
1003           )))
1004   (let ((ret (mime-viewer/parse-message ctl encoding)))
1005     (prog1
1006         (switch-to-buffer (car ret))
1007       (if mother
1008           (progn
1009             (make-variable-buffer-local
1010              'mime/show-mode-old-window-configuration)
1011             (setq mime/show-mode-old-window-configuration
1012                   (current-window-configuration))
1013             (make-variable-buffer-local 'mime/mother-buffer)
1014             (setq mime/mother-buffer mother)
1015             ))
1016       (use-local-map mime/viewer-mode-map)
1017       (make-variable-buffer-local 'mime::preview/content-list)
1018       (setq mime::preview/content-list (nth 1 ret))
1019       (goto-char
1020        (let ((ce (mime::preview-content-info/point-max
1021                   (car mime::preview/content-list)
1022                   ))
1023              e)
1024          (goto-char (point-min))
1025          (search-forward "\n\n" nil t)
1026          (setq e (match-end 0))
1027          (if (<= e ce)
1028              e
1029            ce)))
1030       (run-hooks 'mime/viewer-mode-hook)
1031       )))
1032
1033 (defun mime-preview/point-content-number (point)
1034   (save-window-excursion
1035     (let ((pc (mime::point-preview-content (point)))
1036           cinfo)
1037       (switch-to-buffer (mime::preview-content-info/buffer pc))
1038       (setq cinfo (mime::preview-content-info/content-info pc))
1039       (mime::get-point-content-number (mime::content-info/point-min cinfo))
1040       )))
1041
1042 (defun mime-preview/cinfo-to-pcinfo (cinfo)
1043   (let ((rpcl mime::preview/content-list) cell)
1044     (catch 'tag
1045       (while rpcl
1046         (setq cell (car rpcl))
1047         (if (eq cinfo (mime::preview-content-info/content-info cell))
1048             (throw 'tag cell)
1049           )
1050         (setq rpcl (cdr rpcl))
1051         ))))
1052
1053 (defvar mime-preview/after-decoded-position nil)
1054
1055 (defun mime-preview/decode-content ()
1056   (interactive)
1057   (let ((pc (mime::point-preview-content (point))))
1058     (if pc
1059         (let ((the-buf (current-buffer)))
1060           (setq mime-preview/after-decoded-position (point))
1061           (switch-to-buffer (mime::preview-content-info/buffer pc))
1062           (mime::article/decode-content-region
1063            (mime::preview-content-info/content-info pc))
1064           (if (eq (current-buffer)
1065                   (mime::preview-content-info/buffer pc))
1066               (progn
1067                 (switch-to-buffer the-buf)
1068                 (goto-char mime-preview/after-decoded-position)
1069                 ))
1070           ))))
1071
1072 (defun mime-viewer/play-content ()
1073   (interactive)
1074   (let ((mime-viewer/decoding-mode "play"))
1075     (mime-preview/decode-content)
1076     ))
1077
1078 (defun mime-viewer/play-content-mouse (e)
1079   (interactive "e")
1080   (mouse-set-point e)
1081   (mime-viewer/play-content)
1082   )
1083
1084 (defun mime-viewer/extract-content ()
1085   (interactive)
1086   (let ((mime-viewer/decoding-mode "extract"))
1087     (mime-preview/decode-content)
1088     ))
1089
1090 (defun mime-viewer/print-content ()
1091   (interactive)
1092   (let ((mime-viewer/decoding-mode "print"))
1093     (mime-preview/decode-content)
1094     ))
1095
1096 (defun mime-viewer/up-content ()
1097   (interactive)
1098   (let ((pc (mime::point-preview-content (point))) cinfo
1099         (the-buf (current-buffer))
1100         cn r)
1101     (switch-to-buffer (mime::preview-content-info/buffer pc))
1102     (setq cinfo (mime::preview-content-info/content-info pc))
1103     (setq cn (mime::get-point-content-number
1104               (mime::content-info/point-min cinfo)))
1105     (if (eq cn t)
1106         (mime-viewer/quit the-buf
1107                           (mime::preview-content-info/buffer pc)
1108                           )
1109       (setq r (mime-article/cnum-to-cinfo (butlast cn)))
1110       (switch-to-buffer the-buf)
1111       (catch 'tag
1112         (let ((rpcl mime::preview/content-list) cell)
1113           (while rpcl
1114             (setq cell (car rpcl))
1115             (if (eq r (mime::preview-content-info/content-info cell))
1116                 (progn
1117                   (goto-char (mime::preview-content-info/point-min cell))
1118                   (throw 'tag nil)
1119                   ))
1120             (setq rpcl (cdr rpcl))
1121             )))
1122       )))
1123
1124 (defun mime-viewer/previous-content ()
1125   (interactive)
1126   (let* ((pcl mime::preview/content-list)
1127          (p (point))
1128          (i (- (length pcl) 1))
1129          beg)
1130     (catch 'tag
1131       (while (>= i 0)
1132         (setq beg (mime::preview-content-info/point-min (nth i pcl)))
1133         (if (> p beg)
1134             (throw 'tag (goto-char beg))
1135           )
1136         (setq i (- i 1))
1137         ))
1138     ))
1139
1140 (defun mime-viewer/next-content ()
1141   (interactive)
1142   (let ((pcl mime::preview/content-list)
1143         (p (point))
1144         beg)
1145     (catch 'tag
1146       (while pcl
1147         (setq beg (mime::preview-content-info/point-min (car pcl)))
1148         (if (< p beg)
1149             (throw 'tag (goto-char beg))
1150           )
1151         (setq pcl (cdr pcl))
1152         ))
1153     ))
1154
1155 (defun mime-viewer/scroll-up-content (&optional h)
1156   (interactive)
1157   (or h
1158       (setq h (- (window-height) 1))
1159       )
1160   (let ((pcl mime::preview/content-list)
1161         (p (point))
1162         np beg)
1163     (setq np
1164           (or (catch 'tag
1165                 (while pcl
1166                   (setq beg (mime::preview-content-info/point-min (car pcl)))
1167                   (if (< p beg)
1168                       (throw 'tag beg)
1169                     )
1170                   (setq pcl (cdr pcl))
1171                   ))
1172               (point-max)))
1173     (forward-line h)
1174     (if (> (point) np)
1175         (goto-char np)
1176       )
1177     ;;(show-subtree)
1178     ))
1179
1180 (defun mime-viewer/scroll-down-content (&optional h)
1181   (interactive)
1182   (or h
1183       (setq h (- (window-height) 1))
1184       )
1185   (let ((pcl mime::preview/content-list)
1186         (p (point))
1187         pp beg)
1188     (setq pp
1189           (or (let ((i (- (length pcl) 1)))
1190                 (catch 'tag
1191                   (while (> i 0)
1192                     (setq beg (mime::preview-content-info/point-min
1193                                (nth i pcl)))
1194                     (if (> p beg)
1195                         (throw 'tag beg)
1196                       )
1197                     (setq i (- i 1))
1198                     )))
1199               (point-min)))
1200     (forward-line (- h))
1201     (if (< (point) pp)
1202         (goto-char pp)
1203       )))
1204
1205 (defun mime-viewer/next-line-content ()
1206   (interactive)
1207   (mime-viewer/scroll-up-content 1)
1208   )
1209
1210 (defun mime-viewer/previous-line-content ()
1211   (interactive)
1212   (mime-viewer/scroll-down-content 1)
1213   )
1214
1215 (defun mime-viewer/quit (&optional the-buf buf)
1216   (interactive)
1217   (or the-buf
1218       (setq the-buf (current-buffer))
1219       )
1220   (or buf
1221       (setq buf (mime::preview-content-info/buffer
1222                  (mime::point-preview-content (point))))
1223       )
1224   (let ((r (progn
1225              (switch-to-buffer buf)
1226              (assoc major-mode mime-viewer/quitting-method-alist)
1227              )))
1228     (if r
1229         (progn
1230           (switch-to-buffer the-buf)
1231           (funcall (cdr r))
1232           ))
1233     ))
1234
1235 (defun mime-viewer/kill-buffer ()
1236   (interactive)
1237   (kill-buffer (current-buffer))
1238   )
1239
1240
1241 ;;; @ end
1242 ;;;
1243
1244 (provide 'tm-view)
1245
1246 (run-hooks 'tm-view-load-hook)