mime-view.el

   1 ;;; mime-view.el --- interactive MIME viewer for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Created: 1994/7/13
   7 ;;      Renamed: 1994/8/31 from tm-body.el
   8 ;;      Renamed: 1997/02/19 from tm-view.el
   9 ;; Keywords: MIME, multimedia, mail, news
  10
  11 ;; This file is part of SEMI (Sophisticated Emacs MIME Interfaces).
  12
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Code:
  29
  30 (require 'std11)
  31 (require 'mel)
  32 (require 'eword-decode)
  33 (require 'mime-parse)
  34 (require 'mime-text)
  35 (require 'calist)
  36
  37
  38 ;;; @ version
  39 ;;;
  40
  41 (defconst mime-view-version-string
  42   `,(concat "SEMI MIME-View "
  43             (mapconcat #'number-to-string (cdr semi-version) ".")
  44             " (" (car semi-version) ")"))
  45
  46
  47 ;;; @ buffer local variables
  48 ;;;
  49
  50 ;;; @@ in raw-buffer
  51 ;;;
  52
  53 (defvar mime-raw-message-info
  54   "Information about structure of message.
  55 Please use reference function `mime-entity-SLOT' to get value of SLOT.
  56
  57 Following is a list of slots of the structure:
  58
  59 node-id         reversed entity-number (list of integers)
  60 point-min       beginning point of region in raw-buffer
  61 point-max       end point of region in raw-buffer
  62 type            media-type (symbol)
  63 subtype         media-subtype (symbol)
  64 type/subtype    media-type/subtype (string or nil)
  65 parameters      parameter of Content-Type field (association list)
  66 encoding        Content-Transfer-Encoding (string or nil)
  67 children        entities included in this entity (list of content-infos)
  68
  69 If an entity includes other entities in its body, such as multipart or
  70 message/rfc822, `mime-entity' structures of them are included in
  71 `children', so the `mime-entity' structure become a tree.")
  72 (make-variable-buffer-local 'mime-raw-message-info)
  73
  74 (defvar mime-preview-buffer nil
  75   "MIME-preview buffer corresponding with the (raw) buffer.")
  76 (make-variable-buffer-local 'mime-preview-buffer)
  77
  78
  79 ;;; @@ in preview-buffer
  80 ;;;
  81
  82 (defvar mime-mother-buffer nil
  83   "Mother buffer corresponding with the (MIME-preview) buffer.
  84 If current MIME-preview buffer is generated by other buffer, such as
  85 message/partial, it is called `mother-buffer'.")
  86 (make-variable-buffer-local 'mime-mother-buffer)
  87
  88 (defvar mime-raw-buffer nil
  89   "Raw buffer corresponding with the (MIME-preview) buffer.")
  90 (make-variable-buffer-local 'mime-raw-buffer)
  91
  92 (defvar mime-preview-original-major-mode nil
  93   "Major-mode of mime-raw-buffer.")
  94 (make-variable-buffer-local 'mime-preview-original-major-mode)
  95
  96 (make-variable-buffer-local 'mime-preview-original-window-configuration)
  97
  98
  99 ;;; @ entity-button
 100 ;;;
 101
 102 (defvar mime-view-content-button-visible-ctype-list
 103   '("application/pgp"))
 104
 105 (defun mime-view-insert-entity-button (entity message-info subj)
 106   "Insert entity-button of ENTITY."
 107   (let ((entity-node-id (mime-entity-node-id entity))
 108         (params (mime-entity-parameters entity)))
 109     (mime-insert-button
 110      (let ((access-type (assoc "access-type" params))
 111            (num (or (cdr (assoc "x-part-number" params))
 112                     (if (consp entity-node-id)
 113                         (mapconcat (function
 114                                     (lambda (num)
 115                                       (format "%s" (1+ num))
 116                                       ))
 117                                    (reverse entity-node-id) ".")
 118                       "0"))
 119                 ))
 120        (cond (access-type
 121               (let ((server (assoc "server" params)))
 122                 (setq access-type (cdr access-type))
 123                 (if server
 124                     (format "%s %s ([%s] %s)"
 125                             num subj access-type (cdr server))
 126                 (let ((site (cdr (assoc "site" params)))
 127                       (dir (cdr (assoc "directory" params)))
 128                       )
 129                   (format "%s %s ([%s] %s:%s)"
 130                           num subj access-type site dir)
 131                   )))
 132             )
 133            (t
 134             (let ((media-type (mime-entity-media-type entity))
 135                   (media-subtype (mime-entity-media-subtype entity))
 136                   (charset (cdr (assoc "charset" params)))
 137                   (encoding (mime-entity-encoding entity)))
 138               (concat
 139                num " " subj
 140                (let ((rest
 141                       (format " <%s/%s%s%s>"
 142                               media-type media-subtype
 143                               (if charset
 144                                   (concat "; " charset)
 145                                 "")
 146                               (if encoding
 147                                   (concat " (" encoding ")")
 148                                 ""))))
 149                  (if (>= (+ (current-column)(length rest))(window-width))
 150                      "\n\t")
 151                  rest)))
 152             )))
 153      (function mime-preview-play-current-entity))
 154     ))
 155
 156 (defun mime-view-entity-button-function (entity message-info subj)
 157   "Insert entity-button of ENTITY conditionally.
 158 Please redefine this function if you want to change default setting."
 159   (let ((entity-node-id (mime-entity-node-id entity))
 160         (media-type (mime-entity-media-type entity))
 161         (media-subtype (mime-entity-media-subtype entity)))
 162     (or (null entity-node-id)
 163         (and (eq media-type 'application)
 164              (or (eq media-subtype 'x-selection)
 165                  (and (eq media-subtype 'octet-stream)
 166                       (let ((mother-entity
 167                              (mime-raw-find-entity-from-node-id
 168                               (cdr entity-node-id) message-info)))
 169                         (and (eq (mime-entity-media-type mother-entity)
 170                                  'multipart)
 171                              (eq (mime-entity-media-subtype mother-entity)
 172                                  'encrypted)
 173                              )))))
 174         (mime-view-insert-entity-button entity message-info subj)
 175         )))
 176
 177
 178 ;;; @ entity-header
 179 ;;;
 180
 181 ;;; @@ predicate function
 182 ;;;
 183
 184 (defvar mime-view-childrens-header-showing-Content-Type-list
 185   '("message/rfc822" "message/news"))
 186
 187 (defun mime-view-header-visible-p (entity message-info)
 188   "Return non-nil if header of ENTITY is visible."
 189   (let ((entity-node-id (mime-entity-node-id entity)))
 190     (or (null entity-node-id)
 191         (member (mime-entity-type/subtype
 192                  (mime-raw-find-entity-from-node-id
 193                   (cdr entity-node-id) message-info))
 194                 mime-view-childrens-header-showing-Content-Type-list)
 195         )))
 196
 197 ;;; @@ entity header filter
 198 ;;;
 199
 200 (defvar mime-view-content-header-filter-alist nil)
 201
 202 (defun mime-view-default-content-header-filter ()
 203   (mime-view-cut-header)
 204   (eword-decode-header)
 205   )
 206
 207 (defun mime-view-display-header (beg end)
 208   (save-restriction
 209     (narrow-to-region (point)(point))
 210     (insert-buffer-substring mime-raw-buffer beg end)
 211     (let ((f (cdr (assq mime-preview-original-major-mode
 212                         mime-view-content-header-filter-alist))))
 213       (if (functionp f)
 214           (funcall f)
 215         (mime-view-default-content-header-filter)
 216         ))
 217     (run-hooks 'mime-view-content-header-filter-hook)
 218     ))
 219
 220 ;;; @@ entity field cutter
 221 ;;;
 222
 223 (defvar mime-view-ignored-field-list
 224   '(".*Received" ".*Path" ".*Id" "References"
 225     "Replied" "Errors-To"
 226     "Lines" "Sender" ".*Host" "Xref"
 227     "Content-Type" "Precedence"
 228     "Status" "X-VM-.*")
 229   "All fields that match this list will be hidden in MIME preview buffer.
 230 Each elements are regexp of field-name.")
 231
 232 (defvar mime-view-ignored-field-regexp
 233   (concat "^"
 234           (apply (function regexp-or) mime-view-ignored-field-list)
 235           ":"))
 236
 237 (defvar mime-view-visible-field-list '("Dnas.*" "Message-Id")
 238   "All fields that match this list will be displayed in MIME preview buffer.
 239 Each elements are regexp of field-name.")
 240
 241 (defun mime-view-cut-header ()
 242   (goto-char (point-min))
 243   (while (re-search-forward mime-view-ignored-field-regexp nil t)
 244     (let* ((beg (match-beginning 0))
 245            (end (match-end 0))
 246            (name (buffer-substring beg end))
 247            )
 248       (catch 'visible
 249         (let ((rest mime-view-visible-field-list))
 250           (while rest
 251             (if (string-match (car rest) name)
 252                 (throw 'visible nil)
 253               )
 254             (setq rest (cdr rest))))
 255         (delete-region beg
 256                        (save-excursion
 257                          (if (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
 258                              (match-beginning 0)
 259                            (point-max))))
 260         ))))
 261
 262
 263 ;;; @ entity-body
 264 ;;;
 265
 266 ;;; @@ predicate function
 267 ;;;
 268
 269 (defvar mime-view-body-visible-condition
 270   '(type
 271     (nil)
 272     (text subtype
 273           (plain)
 274           (enriched)
 275           (rfc822-headers)
 276           (richtext)
 277           (x-latex)
 278           (x-pgp))
 279     (application subtype
 280                  (octet-stream encoding
 281                                (nil)
 282                                ("7bit")
 283                                ("8bit"))
 284                  (pgp)
 285                  (x-latex)
 286                  (x-selection)
 287                  (x-comment))
 288     (message subtype
 289              (delivery-status)))
 290   "Condition-tree to be able to display body of entity.")
 291
 292 (defun mime-view-body-visible-p (entity message-info)
 293   "Return non-nil if body of ENTITY is visible."
 294   (ctree-match-calist
 295    mime-view-body-visible-condition
 296    (list* (cons 'type (mime-entity-media-type entity))
 297           (cons 'subtype (mime-entity-media-subtype entity))
 298           (cons 'encoding (mime-entity-encoding entity))
 299           (cons 'major-mode major-mode)
 300           (mime-entity-parameters entity))))
 301
 302 ;; (defvar mime-view-visible-media-type-list
 303 ;;   '("text/plain" nil "text/richtext" "text/enriched"
 304 ;;     "text/rfc822-headers"
 305 ;;     "text/x-latex" "application/x-latex"
 306 ;;     "message/delivery-status"
 307 ;;     "application/pgp" "text/x-pgp"
 308 ;;     "application/octet-stream"
 309 ;;     "application/x-selection" "application/x-comment")
 310 ;;   "*List of media-types to be able to display in MIME-preview buffer.
 311 ;; Each elements are string of TYPE/SUBTYPE, e.g. \"text/plain\".")
 312
 313 ;; (defun mime-view-body-visible-p (entity message-info)
 314 ;;   "Return non-nil if body of ENTITY is visible."
 315 ;;   (let ((media-type (mime-entity-media-type entity))
 316 ;;         (media-subtype (mime-entity-media-subtype entity))
 317 ;;         (ctype (mime-entity-type/subtype entity)))
 318 ;;     (and (member ctype mime-view-visible-media-type-list)
 319 ;;          (if (and (eq media-type 'application)
 320 ;;                   (eq media-subtype 'octet-stream))
 321 ;;              (member (mime-entity-encoding entity) '(nil "7bit" "8bit"))
 322 ;;            t))))
 323
 324
 325 ;;; @@ entity filter
 326 ;;;
 327
 328 (defvar mime-view-content-filter-alist
 329   '(("text/enriched" . mime-view-filter-for-text/enriched)
 330     ("text/richtext" . mime-view-filter-for-text/richtext)
 331     (t . mime-view-filter-for-text/plain)
 332     )
 333   "Alist of media-types vs. corresponding MIME-preview filter functions.
 334 Each element looks like (TYPE/SUBTYPE . FUNCTION) or (t . FUNCTION).
 335 TYPE/SUBTYPE is a string of media-type and FUNCTION is a filter
 336 function.  t means default media-type.")
 337
 338 (defun mime-view-display-body (start end entity message-info subj)
 339   (save-restriction
 340     (narrow-to-region (point-max)(point-max))
 341     (insert-buffer-substring mime-raw-buffer start end)
 342     (let* ((ctype (mime-entity-type/subtype entity))
 343            (params (mime-entity-parameters entity))
 344            (encoding (mime-entity-encoding entity))
 345            (f (cdr (or (assoc ctype mime-view-content-filter-alist)
 346                        (assq t mime-view-content-filter-alist)))))
 347       (and (functionp f)
 348            (funcall f ctype params encoding))
 349       )))
 350
 351 (defvar mime-view-announcement-for-message/partial
 352   (if (and (>= emacs-major-version 19) window-system)
 353       "\
 354 \[[ This is message/partial style split message. ]]
 355 \[[ Please press `v' key in this buffer          ]]
 356 \[[ or click here by mouse button-2.             ]]"
 357     "\
 358 \[[ This is message/partial style split message. ]]
 359 \[[ Please press `v' key in this buffer.         ]]"
 360     ))
 361
 362 (defun mime-view-insert-message/partial-button ()
 363   (save-restriction
 364     (goto-char (point-max))
 365     (if (not (search-backward "\n\n" nil t))
 366         (insert "\n")
 367       )
 368     (goto-char (point-max))
 369     (narrow-to-region (point-max)(point-max))
 370     (insert mime-view-announcement-for-message/partial)
 371     (mime-add-button (point-min)(point-max)
 372                      #'mime-preview-play-current-entity)
 373     ))
 374
 375
 376 ;;; @ entity separator
 377 ;;;
 378
 379 (defun mime-view-entity-separator-function (entity message-info)
 380   "Insert entity-separator of ENTITY conditionally.
 381 Please redefine this function if you want to change default setting."
 382   (or (mime-view-header-visible-p entity message-info)
 383       (mime-view-body-visible-p entity message-info)
 384       (progn
 385         (goto-char (point-max))
 386         (insert "\n")
 387         )))
 388
 389
 390 ;;; @ acting-condition
 391 ;;;
 392
 393 (defvar mime-acting-condition
 394   '(((type . text)(subtype . plain)
 395      (method "tm-plain" nil 'file "" 'encoding 'mode 'name)
 396      (mode "play" "print")
 397      )
 398     ((type . text)(subtype . html)
 399      (method "tm-html" nil 'file "" 'encoding 'mode 'name)
 400      (mode . "play")
 401      )
 402     ((type . text)(subtype . x-rot13-47)
 403      (method . mime-method-to-display-caesar)
 404      (mode . "play")
 405      )
 406     ((type . text)(subtype . x-rot13-47-48)
 407      (method . mime-method-to-display-caesar)
 408      (mode . "play")
 409      )
 410
 411     ((type . audio)(subtype . basic)
 412      (method "tm-au"    nil 'file "" 'encoding 'mode 'name)
 413      (mode . "play")
 414      )
 415
 416     ((type . image)
 417      (method "tm-image" nil 'file "" 'encoding 'mode 'name)
 418      (mode "play" "print")
 419      )
 420
 421     ((type . video)(subtype . mpeg)
 422      (method "tm-mpeg"  nil 'file "" 'encoding 'mode 'name)
 423      (mode . "play")
 424      )
 425
 426     ((type . application)(subtype . postscript)
 427      (method "tm-ps" nil 'file "" 'encoding 'mode 'name)
 428      (mode "play" "print")
 429      )
 430     ((type . application)(subtype . octet-stream)
 431      (method . mime-method-to-save)(mode "play" "print")
 432      )
 433
 434     ((type . message)(subtype . external-body)
 435      ("access-type" . "anon-ftp")
 436      (method . mime-method-to-display-message/external-ftp)
 437      )
 438     ((type . message)(subtype . rfc822)
 439      (method . mime-method-to-display-message/rfc822)
 440      (mode . "play")
 441      )
 442     ((type . message)(subtype . partial)
 443      (method . mime-method-to-store-message/partial)
 444      (mode . "play")
 445      )
 446
 447     ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file)
 448      (mode . "play")
 449      )
 450     ((method . mime-method-to-save)(mode . "extract"))
 451     ))
 452
 453
 454 ;;; @ quitting method
 455 ;;;
 456
 457 (defvar mime-preview-quitting-method-alist
 458   '((mime-show-message-mode
 459      . mime-preview-quitting-method-for-mime-show-message-mode))
 460   "Alist of major-mode vs. quitting-method of mime-view.")
 461
 462 (defvar mime-view-over-to-previous-method-alist nil)
 463 (defvar mime-view-over-to-next-method-alist nil)
 464
 465 (defvar mime-view-show-summary-method nil
 466   "Alist of major-mode vs. show-summary-method.")
 467
 468
 469 ;;; @ following method
 470 ;;;
 471
 472 (defvar mime-view-following-method-alist nil
 473   "Alist of major-mode vs. following-method of mime-view.")
 474
 475 (defvar mime-view-following-required-fields-list
 476   '("From"))
 477
 478
 479 ;;; @ X-Face
 480 ;;;
 481
 482 ;; hack from Gnus 5.0.4.
 483
 484 (defvar mime-view-x-face-to-pbm-command
 485   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
 486
 487 (defvar mime-view-x-face-command
 488   (concat mime-view-x-face-to-pbm-command
 489           " | xv -quit -")
 490   "String to be executed to display an X-Face field.
 491 The command will be executed in a sub-shell asynchronously.
 492 The compressed face will be piped to this command.")
 493
 494 (defun mime-view-x-face-function ()
 495   "Function to display X-Face field. You can redefine to customize."
 496   ;; 1995/10/12 (c.f. tm-eng:130)
 497   ;;    fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
 498   (save-restriction
 499     (narrow-to-region (point-min) (re-search-forward "^$" nil t))
 500     ;; end
 501     (goto-char (point-min))
 502     (if (re-search-forward "^X-Face:[ \t]*" nil t)
 503         (let ((beg (match-end 0))
 504               (end (std11-field-end))
 505               )
 506           (call-process-region beg end "sh" nil 0 nil
 507                                "-c" mime-view-x-face-command)
 508           ))))
 509
 510
 511 ;;; @ miscellaneous
 512 ;;;
 513
 514 (defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
 515
 516 (defvar mime-raw-buffer-coding-system-alist
 517   `((t . ,(mime-charset-to-coding-system default-mime-charset)))
 518   "Alist of major-mode vs. corresponding coding-system of `mime-raw-buffer'.")
 519
 520
 521 ;;; @ buffer setup
 522 ;;;
 523
 524 (defvar mime-view-redisplay nil)
 525
 526 (defun mime-view-setup-buffers (&optional ctl encoding ibuf obuf)
 527   (if ibuf
 528       (progn
 529         (get-buffer ibuf)
 530         (set-buffer ibuf)
 531         ))
 532   (or mime-view-redisplay
 533       (setq mime-raw-message-info (mime-parse-message ctl encoding))
 534       )
 535   (let* ((message-info mime-raw-message-info)
 536          (pcl (mime-raw-flatten-message-info message-info))
 537          (the-buf (current-buffer))
 538          (mode major-mode)
 539          )
 540     (or obuf
 541         (setq obuf (concat "*Preview-" (buffer-name the-buf) "*")))
 542     (set-buffer (get-buffer-create obuf))
 543     (let ((inhibit-read-only t))
 544       ;;(setq buffer-read-only nil)
 545       (widen)
 546       (erase-buffer)
 547       (setq mime-raw-buffer the-buf)
 548       (setq mime-preview-original-major-mode mode)
 549       (setq major-mode 'mime-view-mode)
 550       (setq mode-name "MIME-View")
 551       (while pcl
 552         (mime-view-display-entity (car pcl) message-info the-buf obuf)
 553         (setq pcl (cdr pcl))
 554         )
 555       (set-buffer-modified-p nil)
 556       )
 557     (setq buffer-read-only t)
 558     (set-buffer the-buf)
 559     )
 560   (setq mime-preview-buffer obuf)
 561   )
 562
 563 (defun mime-view-display-entity (entity message-info ibuf obuf)
 564   "Display ENTITY."
 565   (let* ((beg (mime-entity-point-min entity))
 566          (end (mime-entity-point-max entity))
 567          (media-type (mime-entity-media-type entity))
 568          (media-subtype (mime-entity-media-subtype entity))
 569          (ctype (if media-type
 570                     (if media-subtype
 571                         (format "%s/%s" media-type media-subtype)
 572                       (symbol-name media-type)
 573                       )))
 574          (params (mime-entity-parameters entity))
 575          (encoding (mime-entity-encoding entity))
 576          (entity-node-id (mime-entity-node-id entity))
 577          he e nb ne subj)
 578     (set-buffer ibuf)
 579     (goto-char beg)
 580     (setq he (if (re-search-forward "^$" nil t)
 581                  (1+ (match-end 0))
 582                end))
 583     (if (> he end)
 584         (setq he end)
 585       )
 586     (save-restriction
 587       (narrow-to-region beg end)
 588       (setq subj
 589             (eword-decode-string
 590              (mime-raw-get-subject params encoding)))
 591       )
 592     (set-buffer obuf)
 593     (setq nb (point))
 594     (narrow-to-region nb nb)
 595     (mime-view-entity-button-function entity message-info subj)
 596     (if (mime-view-header-visible-p entity message-info)
 597         (mime-view-display-header beg he)
 598       )
 599     (if (and (null entity-node-id)
 600              (member
 601               ctype mime-view-content-button-visible-ctype-list))
 602         (save-excursion
 603           (goto-char (point-max))
 604           (mime-view-insert-entity-button entity message-info subj)
 605           ))
 606     (cond ((mime-view-body-visible-p entity message-info)
 607            (mime-view-display-body he end entity message-info subj)
 608            )
 609           ((and (eq media-type 'message)(eq media-subtype 'partial))
 610            (mime-view-insert-message/partial-button)
 611            )
 612           ((and (null entity-node-id)
 613                 (null (mime-entity-children message-info))
 614                 )
 615            (goto-char (point-max))
 616            (mime-view-insert-entity-button entity message-info subj)
 617            ))
 618     (mime-view-entity-separator-function entity message-info)
 619     (setq ne (point-max))
 620     (widen)
 621     (put-text-property nb ne 'mime-view-raw-buffer ibuf)
 622     (put-text-property nb ne 'mime-view-entity entity)
 623     (goto-char ne)
 624     ))
 625
 626 (defun mime-raw-get-uu-filename (param &optional encoding)
 627   (if (member (or encoding
 628                   (cdr (assq 'encoding param))
 629                   )
 630               mime-view-uuencode-encoding-name-list)
 631       (save-excursion
 632         (or (if (re-search-forward "^begin [0-9]+ " nil t)
 633                 (if (looking-at ".+$")
 634                     (buffer-substring (match-beginning 0)(match-end 0))
 635                   ))
 636             ""))
 637     ))
 638
 639 (defun mime-raw-get-subject (param &optional encoding)
 640   (or (std11-find-field-body '("Content-Description" "Subject"))
 641       (let (ret)
 642         (if (or (and (setq ret (mime/Content-Disposition))
 643                      (setq ret (assoc "filename" (cdr ret)))
 644                      )
 645                 (setq ret (assoc "name" param))
 646                 (setq ret (assoc "x-name" param))
 647                 )
 648             (std11-strip-quoted-string (cdr ret))
 649           ))
 650       (mime-raw-get-uu-filename param encoding)
 651       ""))
 652
 653
 654 ;;; @ entity information
 655 ;;;
 656
 657 (defsubst mime-raw-find-entity-from-node-id (entity-node-id
 658                                              &optional message-info)
 659   "Return entity from ENTITY-NODE-ID in mime-raw-buffer.
 660 If optional argument MESSAGE-INFO is not specified,
 661 `mime-raw-message-info' is used."
 662   (mime-raw-find-entity-from-number (reverse entity-node-id) message-info))
 663
 664 (defun mime-raw-find-entity-from-number (entity-number &optional message-info)
 665   "Return entity from ENTITY-NUMBER in mime-raw-buffer.
 666 If optional argument MESSAGE-INFO is not specified,
 667 `mime-raw-message-info' is used."
 668   (or message-info
 669       (setq message-info mime-raw-message-info))
 670   (if (eq entity-number t)
 671       message-info
 672     (let ((sn (car entity-number)))
 673       (if (null sn)
 674           message-info
 675         (let ((rc (nth sn (mime-entity-children message-info))))
 676           (if rc
 677               (mime-raw-find-entity-from-number (cdr entity-number) rc)
 678             ))
 679         ))))
 680
 681 (defun mime-raw-find-entity-from-point (point &optional message-info)
 682   "Return entity from POINT in mime-raw-buffer.
 683 If optional argument MESSAGE-INFO is not specified,
 684 `mime-raw-message-info' is used."
 685   (or message-info
 686       (setq message-info mime-raw-message-info))
 687   (if (and (<= (mime-entity-point-min message-info) point)
 688            (<= point (mime-entity-point-max message-info)))
 689       (let ((children (mime-entity-children message-info)))
 690         (catch 'tag
 691           (while children
 692             (let ((ret
 693                    (mime-raw-find-entity-from-point point (car children))))
 694               (if ret
 695                   (throw 'tag ret)
 696                 ))
 697             (setq children (cdr children)))
 698           message-info))))
 699
 700 (defsubst mime-raw-point-to-entity-node-id (point &optional message-info)
 701   "Return entity-node-id from POINT in mime-raw-buffer.
 702 If optional argument MESSAGE-INFO is not specified,
 703 `mime-raw-message-info' is used."
 704   (mime-entity-node-id (mime-raw-find-entity-from-point point message-info)))
 705
 706 (defsubst mime-raw-point-to-entity-number (point &optional message-info)
 707   "Return entity-number from POINT in mime-raw-buffer.
 708 If optional argument MESSAGE-INFO is not specified,
 709 `mime-raw-message-info' is used."
 710   (reverse (mime-raw-point-to-entity-node-id point message-id)))
 711
 712 (defun mime-raw-flatten-message-info (&optional message-info)
 713   "Return list of entity in mime-raw-buffer.
 714 If optional argument MESSAGE-INFO is not specified,
 715 `mime-raw-message-info' is used."
 716   (or message-info
 717       (setq message-info mime-raw-message-info))
 718   (let ((dest (list message-info))
 719         (rcl (mime-entity-children message-info)))
 720     (while rcl
 721       (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
 722       (setq rcl (cdr rcl)))
 723     dest))
 724
 725
 726 ;;; @ MIME viewer mode
 727 ;;;
 728
 729 (defconst mime-view-menu-title "MIME-View")
 730 (defconst mime-view-menu-list
 731   '((up          "Move to upper entity"    mime-preview-move-to-upper)
 732     (previous    "Move to previous entity" mime-preview-move-to-previous)
 733     (next        "Move to next entity"     mime-preview-move-to-next)
 734     (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
 735     (scroll-up   "Scroll-up"               mime-preview-scroll-up-entity)
 736     (play        "Play current entity"     mime-preview-play-current-entity)
 737     (extract     "Extract current entity"  mime-preview-extract-current-entity)
 738     (print       "Print current entity"    mime-preview-print-current-entity)
 739     (x-face      "Show X Face"             mime-preview-display-x-face)
 740     )
 741   "Menu for MIME Viewer")
 742
 743 (cond (running-xemacs
 744        (defvar mime-view-xemacs-popup-menu
 745          (cons mime-view-menu-title
 746                (mapcar (function
 747                         (lambda (item)
 748                           (vector (nth 1 item)(nth 2 item) t)
 749                           ))
 750                        mime-view-menu-list)))
 751        (defun mime-view-xemacs-popup-menu (event)
 752          "Popup the menu in the MIME Viewer buffer"
 753          (interactive "e")
 754          (select-window (event-window event))
 755          (set-buffer (event-buffer event))
 756          (popup-menu 'mime-view-xemacs-popup-menu))
 757        (defvar mouse-button-2 'button2)
 758        )
 759       (t
 760        (defvar mouse-button-2 [mouse-2])
 761        ))
 762
 763 (defun mime-view-define-keymap (&optional default)
 764   (let ((mime-view-mode-map (if (keymapp default)
 765                                 (copy-keymap default)
 766                               (make-sparse-keymap)
 767                               )))
 768     (define-key mime-view-mode-map
 769       "u"        (function mime-preview-move-to-upper))
 770     (define-key mime-view-mode-map
 771       "p"        (function mime-preview-move-to-previous))
 772     (define-key mime-view-mode-map
 773       "n"        (function mime-preview-move-to-next))
 774     (define-key mime-view-mode-map
 775       "\e\t"     (function mime-preview-move-to-previous))
 776     (define-key mime-view-mode-map
 777       "\t"       (function mime-preview-move-to-next))
 778     (define-key mime-view-mode-map
 779       " "        (function mime-preview-scroll-up-entity))
 780     (define-key mime-view-mode-map
 781       "\M- "     (function mime-preview-scroll-down-entity))
 782     (define-key mime-view-mode-map
 783       "\177"     (function mime-preview-scroll-down-entity))
 784     (define-key mime-view-mode-map
 785       "\C-m"     (function mime-preview-next-line-entity))
 786     (define-key mime-view-mode-map
 787       "\C-\M-m"  (function mime-preview-previous-line-entity))
 788     (define-key mime-view-mode-map
 789       "v"        (function mime-preview-play-current-entity))
 790     (define-key mime-view-mode-map
 791       "e"        (function mime-preview-extract-current-entity))
 792     (define-key mime-view-mode-map
 793       "\C-c\C-p" (function mime-preview-print-current-entity))
 794     (define-key mime-view-mode-map
 795       "a"        (function mime-preview-follow-current-entity))
 796     (define-key mime-view-mode-map
 797       "q"        (function mime-preview-quit))
 798     (define-key mime-view-mode-map
 799       "h"        (function mime-preview-show-summary))
 800     (define-key mime-view-mode-map
 801       "\C-c\C-x" (function mime-preview-kill-buffer))
 802     ;; (define-key mime-view-mode-map
 803     ;;   "<"        (function beginning-of-buffer))
 804     ;; (define-key mime-view-mode-map
 805     ;;   ">"        (function end-of-buffer))
 806     (define-key mime-view-mode-map
 807       "?"        (function describe-mode))
 808     (define-key mime-view-mode-map
 809       [tab] (function mime-preview-move-to-next))
 810     (define-key mime-view-mode-map
 811       [delete] (function mime-preview-scroll-down-entity))
 812     (define-key mime-view-mode-map
 813       [backspace] (function mime-preview-scroll-down-entity))
 814     (if (functionp default)
 815         (cond (running-xemacs
 816                (set-keymap-default-binding mime-view-mode-map default)
 817                )
 818               (t
 819                (setq mime-view-mode-map
 820                      (append mime-view-mode-map (list (cons t default))))
 821                )))
 822     (if mouse-button-2
 823         (define-key mime-view-mode-map
 824           mouse-button-2 (function mime-button-dispatcher))
 825       )
 826     (cond (running-xemacs
 827            (define-key mime-view-mode-map
 828              mouse-button-3 (function mime-view-xemacs-popup-menu))
 829            )
 830           ((>= emacs-major-version 19)
 831            (define-key mime-view-mode-map [menu-bar mime-view]
 832              (cons mime-view-menu-title
 833                    (make-sparse-keymap mime-view-menu-title)))
 834            (mapcar (function
 835                     (lambda (item)
 836                       (define-key mime-view-mode-map
 837                         (vector 'menu-bar 'mime-view (car item))
 838                         (cons (nth 1 item)(nth 2 item))
 839                         )
 840                       ))
 841                    (reverse mime-view-menu-list)
 842                    )
 843            ))
 844     (use-local-map mime-view-mode-map)
 845     (run-hooks 'mime-view-define-keymap-hook)
 846     ))
 847
 848 (defsubst mime-maybe-hide-echo-buffer ()
 849   "Clear mime-echo buffer and delete window for it."
 850   (let ((buf (get-buffer mime-echo-buffer-name)))
 851     (if buf
 852         (save-excursion
 853           (set-buffer buf)
 854           (erase-buffer)
 855           (let ((win (get-buffer-window buf)))
 856             (if win
 857                 (delete-window win)
 858               ))
 859           (bury-buffer buf)
 860           ))))
 861
 862 (defun mime-view-mode (&optional mother ctl encoding ibuf obuf
 863                                  default-keymap-or-function)
 864   "Major mode for viewing MIME message.
 865
 866 Here is a list of the standard keys for mime-view-mode.
 867
 868 key             feature
 869 ---             -------
 870
 871 u               Move to upper content
 872 p or M-TAB      Move to previous content
 873 n or TAB        Move to next content
 874 SPC             Scroll up or move to next content
 875 M-SPC or DEL    Scroll down or move to previous content
 876 RET             Move to next line
 877 M-RET           Move to previous line
 878 v               Decode current content as `play mode'
 879 e               Decode current content as `extract mode'
 880 C-c C-p         Decode current content as `print mode'
 881 a               Followup to current content.
 882 x               Display X-Face
 883 q               Quit
 884 button-2        Move to point under the mouse cursor
 885                 and decode current content as `play mode'
 886 "
 887   (interactive)
 888   (mime-maybe-hide-echo-buffer)
 889   (let ((ret (mime-view-setup-buffers ctl encoding ibuf obuf))
 890         (win-conf (current-window-configuration))
 891         )
 892     (prog1
 893         (switch-to-buffer ret)
 894       (setq mime-preview-original-window-configuration win-conf)
 895       (if mother
 896           (progn
 897             (setq mime-mother-buffer mother)
 898             ))
 899       (mime-view-define-keymap default-keymap-or-function)
 900       (let ((point
 901              (next-single-property-change (point-min) 'mime-view-entity)))
 902         (if point
 903             (goto-char point)
 904           (goto-char (point-min))
 905           (search-forward "\n\n" nil t)
 906           ))
 907       (run-hooks 'mime-view-mode-hook)
 908       )))
 909
 910
 911 ;;; @@ playing
 912 ;;;
 913
 914 (autoload 'mime-preview-play-current-entity "mime-play"
 915   "Play current entity." t)
 916
 917 (defun mime-preview-extract-current-entity ()
 918   "Extract current entity into file (maybe).
 919 It decodes current entity to call internal or external method as
 920 \"extract\" mode.  The method is selected from variable
 921 `mime-acting-condition'."
 922   (interactive)
 923   (mime-preview-play-current-entity "extract")
 924   )
 925
 926 (defun mime-preview-print-current-entity ()
 927   "Print current entity (maybe).
 928 It decodes current entity to call internal or external method as
 929 \"print\" mode.  The method is selected from variable
 930 `mime-acting-condition'."
 931   (interactive)
 932   (mime-preview-play-current-entity "print")
 933   )
 934
 935
 936 ;;; @@ following
 937 ;;;
 938
 939 (defun mime-preview-original-major-mode ()
 940   "Return major-mode of original buffer.
 941 If a current buffer has mime-mother-buffer, return original major-mode
 942 of the mother-buffer."
 943   (if mime-mother-buffer
 944       (save-excursion
 945         (set-buffer mime-mother-buffer)
 946         (mime-preview-original-major-mode)
 947         )
 948     mime-preview-original-major-mode))
 949
 950 (defun mime-preview-follow-current-entity ()
 951   "Write follow message to current entity.
 952 It calls following-method selected from variable
 953 `mime-view-following-method-alist'."
 954   (interactive)
 955   (let ((message-info (get-text-property (point-min) 'mime-view-entity))
 956         entity)
 957     (while (null (setq entity
 958                        (get-text-property (point) 'mime-view-entity)))
 959       (backward-char)
 960       )
 961     (let* ((p-beg
 962             (previous-single-property-change (point) 'mime-view-entity))
 963            p-end
 964            (entity-node-id (mime-entity-node-id entity))
 965            (len (length entity-node-id))
 966            )
 967       (cond ((null p-beg)
 968              (setq p-beg
 969                    (if (eq (next-single-property-change (point-min)
 970                                                         'mime-view-entity)
 971                            (point))
 972                        (point)
 973                      (point-min)))
 974              )
 975             ((eq (next-single-property-change p-beg 'mime-view-entity)
 976                  (point))
 977              (setq p-beg (point))
 978              ))
 979       (setq p-end (next-single-property-change p-beg 'mime-view-entity))
 980       (cond ((null p-end)
 981              (setq p-end (point-max))
 982              )
 983             ((null entity-node-id)
 984              (setq p-end (point-max))
 985              )
 986             (t
 987              (save-excursion
 988                (goto-char p-end)
 989                (catch 'tag
 990                  (let (e)
 991                    (while (setq e
 992                                 (next-single-property-change
 993                                  (point) 'mime-view-entity))
 994                      (goto-char e)
 995                      (let ((rc (mime-entity-node-id
 996                                 (get-text-property (point)
 997                                                    'mime-view-entity))))
 998                        (or (equal entity-node-id
 999                                   (nthcdr (- (length rc) len) rc))
1000                            (throw 'tag nil)
1001                            ))
1002                      (setq p-end e)
1003                      ))
1004                  (setq p-end (point-max))
1005                  ))
1006              ))
1007       (let* ((mode (mime-preview-original-major-mode))
1008              (new-name
1009               (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1010              new-buf
1011              (the-buf (current-buffer))
1012              (a-buf mime-raw-buffer)
1013              fields)
1014         (save-excursion
1015           (set-buffer (setq new-buf (get-buffer-create new-name)))
1016           (erase-buffer)
1017           (insert-buffer-substring the-buf p-beg p-end)
1018           (goto-char (point-min))
1019           (if (mime-view-header-visible-p entity message-info)
1020               (delete-region (goto-char (point-min))
1021                              (if (re-search-forward "^$" nil t)
1022                                  (match-end 0)
1023                                (point-min)))
1024             )
1025           (goto-char (point-min))
1026           (insert "\n")
1027           (goto-char (point-min))
1028           (let ((entity-node-id (mime-entity-node-id entity)) ci str)
1029             (while (progn
1030                      (setq
1031                       str
1032                       (save-excursion
1033                         (set-buffer a-buf)
1034                         (setq
1035                          ci
1036                          (mime-raw-find-entity-from-node-id entity-node-id))
1037                         (save-restriction
1038                           (narrow-to-region
1039                            (mime-entity-point-min ci)
1040                            (mime-entity-point-max ci)
1041                            )
1042                           (std11-header-string-except
1043                            (concat "^"
1044                                    (apply (function regexp-or) fields)
1045                                    ":") ""))))
1046                      (if (and
1047                           (eq (mime-entity-media-type ci) 'message)
1048                           (eq (mime-entity-media-subtype ci) 'rfc822))
1049                          nil
1050                        (if str
1051                            (insert str)
1052                          )
1053                        entity-node-id))
1054               (setq fields (std11-collect-field-names)
1055                     entity-node-id (cdr entity-node-id))
1056               )
1057             )
1058           (let ((rest mime-view-following-required-fields-list))
1059             (while rest
1060               (let ((field-name (car rest)))
1061                 (or (std11-field-body field-name)
1062                     (insert
1063                      (format
1064                       (concat field-name
1065                               ": "
1066                               (save-excursion
1067                                 (set-buffer the-buf)
1068                                 (set-buffer mime-mother-buffer)
1069                                 (set-buffer mime-raw-buffer)
1070                                 (std11-field-body field-name)
1071                                 )
1072                               "\n")))
1073                     ))
1074               (setq rest (cdr rest))
1075               ))
1076           (eword-decode-header)
1077           )
1078         (let ((f (cdr (assq mode mime-view-following-method-alist))))
1079           (if (functionp f)
1080               (funcall f new-buf)
1081             (message
1082              (format
1083               "Sorry, following method for %s is not implemented yet."
1084               mode))
1085             ))
1086         ))))
1087
1088
1089 ;;; @@ X-Face
1090 ;;;
1091
1092 (defun mime-preview-display-x-face ()
1093   (interactive)
1094   (save-window-excursion
1095     (set-buffer mime-raw-buffer)
1096     (mime-view-x-face-function)
1097     ))
1098
1099
1100 ;;; @@ moving
1101 ;;;
1102
1103 (defun mime-preview-move-to-upper ()
1104   "Move to upper entity.
1105 If there is no upper entity, call function `mime-preview-quit'."
1106   (interactive)
1107   (let (cinfo)
1108     (while (null (setq cinfo
1109                        (get-text-property (point) 'mime-view-entity)))
1110       (backward-char)
1111       )
1112     (let ((r (mime-raw-find-entity-from-node-id
1113               (cdr (mime-entity-node-id cinfo))
1114               (get-text-property 1 'mime-view-entity)))
1115           point)
1116       (catch 'tag
1117         (while (setq point (previous-single-property-change
1118                             (point) 'mime-view-entity))
1119           (goto-char point)
1120           (if (eq r (get-text-property (point) 'mime-view-entity))
1121               (throw 'tag t)
1122             )
1123           )
1124         (mime-preview-quit)
1125         ))))
1126
1127 (defun mime-preview-move-to-previous ()
1128   "Move to previous entity.
1129 If there is no previous entity, it calls function registered in
1130 variable `mime-view-over-to-previous-method-alist'."
1131   (interactive)
1132   (while (null (get-text-property (point) 'mime-view-entity))
1133     (backward-char)
1134     )
1135   (let ((point
1136          (previous-single-property-change (point) 'mime-view-entity)))
1137     (if point
1138         (goto-char point)
1139       (let ((f (assq mime-preview-original-major-mode
1140                      mime-view-over-to-previous-method-alist)))
1141         (if f
1142             (funcall (cdr f))
1143           ))
1144       )))
1145
1146 (defun mime-preview-move-to-next ()
1147   "Move to next entity.
1148 If there is no previous entity, it calls function registered in
1149 variable `mime-view-over-to-next-method-alist'."
1150   (interactive)
1151   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1152     (if point
1153         (goto-char point)
1154       (let ((f (assq mime-preview-original-major-mode
1155                      mime-view-over-to-next-method-alist)))
1156         (if f
1157             (funcall (cdr f))
1158           ))
1159       )))
1160
1161 (defun mime-preview-scroll-up-entity (&optional h)
1162   "Scroll up current entity.
1163 If reached to (point-max), it calls function registered in variable
1164 `mime-view-over-to-next-method-alist'."
1165   (interactive)
1166   (or h
1167       (setq h (1- (window-height)))
1168       )
1169   (if (= (point) (point-max))
1170       (let ((f (assq mime-preview-original-major-mode
1171                      mime-view-over-to-next-method-alist)))
1172         (if f
1173             (funcall (cdr f))
1174           ))
1175     (let ((point
1176            (or (next-single-property-change (point) 'mime-view-entity)
1177                (point-max))))
1178       (forward-line h)
1179       (if (> (point) point)
1180           (goto-char point)
1181         )
1182       )))
1183
1184 (defun mime-preview-scroll-down-entity (&optional h)
1185   "Scroll down current entity.
1186 If reached to (point-min), it calls function registered in variable
1187 `mime-view-over-to-previous-method-alist'."
1188   (interactive)
1189   (or h
1190       (setq h (1- (window-height)))
1191       )
1192   (if (= (point) (point-min))
1193       (let ((f (assq mime-preview-original-major-mode
1194                      mime-view-over-to-previous-method-alist)))
1195         (if f
1196             (funcall (cdr f))
1197           ))
1198     (let (point)
1199       (save-excursion
1200         (catch 'tag
1201           (while (> (point) 1)
1202             (if (setq point
1203                       (previous-single-property-change (point)
1204                                                        'mime-view-entity))
1205                 (throw 'tag t)
1206               )
1207             (backward-char)
1208             )
1209           (setq point (point-min))
1210           ))
1211       (forward-line (- h))
1212       (if (< (point) point)
1213           (goto-char point)
1214         ))))
1215
1216 (defun mime-preview-next-line-entity ()
1217   (interactive)
1218   (mime-preview-scroll-up-entity 1)
1219   )
1220
1221 (defun mime-preview-previous-line-entity ()
1222   (interactive)
1223   (mime-preview-scroll-down-entity 1)
1224   )
1225
1226
1227 ;;; @@ quitting
1228 ;;;
1229
1230 (defun mime-preview-quit ()
1231   "Quit from MIME-preview buffer.
1232 It calls function registered in variable
1233 `mime-preview-quitting-method-alist'."
1234   (interactive)
1235   (let ((r (assq mime-preview-original-major-mode
1236                  mime-preview-quitting-method-alist)))
1237     (if r
1238         (funcall (cdr r))
1239       )))
1240
1241 (defun mime-preview-show-summary ()
1242   "Show summary.
1243 It calls function registered in variable
1244 `mime-view-show-summary-method'."
1245   (interactive)
1246   (let ((r (assq mime-preview-original-major-mode
1247                  mime-view-show-summary-method)))
1248     (if r
1249         (funcall (cdr r))
1250       )))
1251
1252 (defun mime-preview-kill-buffer ()
1253   (interactive)
1254   (kill-buffer (current-buffer))
1255   )
1256
1257
1258 ;;; @ end
1259 ;;;
1260
1261 (provide 'mime-view)
1262
1263 (run-hooks 'mime-view-load-hook)
1264
1265 ;;; mime-view.el ends here