mime-play.el

   1 ;;; mime-play.el --- decoder for mime-view.el
   2
   3 ;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Created: 1995/9/26 (separated from tm-view.el)
   7 ;;      Renamed: 1997/2/21 from tm-play.el
   8 ;; Version: $Id: mime-play.el,v 0.5 1997-02-28 02:16:31 tmorioka Exp $
   9 ;; Keywords: MIME, multimedia, mail, news
  10
  11 ;; This file is part of SEMI (SEMI is 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 'mime-view)
  31
  32
  33 ;;; @ content decoder
  34 ;;;
  35
  36 (defvar mime-preview/after-decoded-position nil)
  37
  38 (defun mime-preview/decode-content ()
  39   (interactive)
  40   (let ((pc (mime-preview/point-pcinfo (point))))
  41     (if pc
  42         (let ((the-buf (current-buffer)))
  43           (setq mime-preview/after-decoded-position (point))
  44           (set-buffer (mime::preview-content-info/buffer pc))
  45           (mime-article/decode-content
  46            (mime::preview-content-info/content-info pc))
  47           (if (eq (current-buffer)
  48                   (mime::preview-content-info/buffer pc))
  49               (progn
  50                 (set-buffer the-buf)
  51                 (goto-char mime-preview/after-decoded-position)
  52                 ))
  53           ))))
  54
  55 (defun mime-article/decode-content (cinfo)
  56   (let ((beg (mime::content-info/point-min cinfo))
  57         (end (mime::content-info/point-max cinfo))
  58         (ctype (or (mime::content-info/type cinfo) "text/plain"))
  59         (params (mime::content-info/parameters cinfo))
  60         (encoding (mime::content-info/encoding cinfo))
  61         )
  62     ;; Check for VM
  63     (if (< beg (point-min))
  64         (setq beg (point-min))
  65       )
  66     (if (< (point-max) end)
  67         (setq end (point-max))
  68       )
  69     (let (method cal ret)
  70       (setq cal (list* (cons 'type ctype)
  71                        (cons 'encoding encoding)
  72                        (cons 'major-mode major-mode)
  73                        params))
  74       (if mime-view-decoding-mode
  75           (setq cal (cons
  76                      (cons 'mode mime-view-decoding-mode)
  77                      cal))
  78         )
  79       (setq ret (mime/get-content-decoding-alist cal))
  80       (setq method (cdr (assq 'method ret)))
  81       (cond ((and (symbolp method)
  82                   (fboundp method))
  83              (funcall method beg end ret)
  84              )
  85             ((and (listp method)(stringp (car method)))
  86              (mime-article/start-external-method-region beg end ret)
  87              )
  88             (t
  89              (mime-article/show-output-buffer
  90               "No method are specified for %s\n" ctype)
  91              ))
  92       )
  93     ))
  94
  95
  96 ;;; @ method selector
  97 ;;;
  98
  99 ;;; @@ alist
 100 ;;;
 101
 102 (defun put-alist (item value alist)
 103   "Modify ALIST to set VALUE to ITEM.
 104 If there is a pair whose car is ITEM, replace its cdr by VALUE.
 105 If there is not such pair, create new pair (ITEM . VALUE) and
 106 return new alist whose car is the new pair and cdr is ALIST.
 107 \[tomo's ELIS like function]"
 108   (let ((pair (assoc item alist)))
 109     (if pair
 110         (progn
 111           (setcdr pair value)
 112           alist)
 113       (cons (cons item value) alist)
 114       )))
 115
 116 (defun del-alist (item alist)
 117   "If there is a pair whose key is ITEM, delete it from ALIST.
 118 \[tomo's ELIS emulating function]"
 119   (if (equal item (car (car alist)))
 120       (cdr alist)
 121     (let ((pr alist)
 122           (r (cdr alist))
 123           )
 124       (catch 'tag
 125         (while (not (null r))
 126           (if (equal item (car (car r)))
 127               (progn
 128                 (rplacd pr (cdr r))
 129                 (throw 'tag alist)))
 130           (setq pr r)
 131           (setq r (cdr r))
 132           )
 133         alist))))
 134
 135
 136 ;;; @@ field
 137 ;;;
 138
 139 (defun put-fields (tp c)
 140   (catch 'tag
 141     (let ((r tp) f ret)
 142       (while r
 143         (setq f (car r))
 144         (if (not (if (setq ret (assoc (car f) c))
 145                      (equal (cdr ret)(cdr f))
 146                    (setq c (cons f c))
 147                    ))
 148             (throw 'tag 'error))
 149         (setq r (cdr r))
 150         ))
 151     c))
 152
 153
 154 ;;; @@ field unifier
 155 ;;;
 156
 157 (defun field-unifier-for-default (a b)
 158   (let ((ret
 159          (cond ((equal a b)    a)
 160                ((null (cdr b)) a)
 161                ((null (cdr a)) b)
 162                )))
 163     (if ret
 164         (list nil ret nil)
 165       )))
 166
 167 (defun field-unifier-for-mode (a b)
 168   (let ((va (cdr a)))
 169     (if (if (consp va)
 170             (member (cdr b) va)
 171           (equal va (cdr b))
 172           )
 173         (list nil b nil)
 174       )))
 175
 176 (defun field-unify (a b)
 177   (let ((sym (intern (concat "field-unifier-for-" (intern (car a))))))
 178     (if (not (fboundp sym))
 179         (setq sym (function field-unifier-for-default))
 180       )
 181     (funcall sym a b)
 182     ))
 183
 184
 185 ;;; @@ type unifier
 186 ;;;
 187
 188 (defun assoc-unify (class instance)
 189   (catch 'tag
 190     (let ((cla (copy-alist class))
 191           (ins (copy-alist instance))
 192           (r class)
 193           cell aret ret prev rest)
 194       (while r
 195         (setq cell (car r))
 196         (setq aret (assoc (car cell) ins))
 197         (if aret
 198             (if (setq ret (field-unify cell aret))
 199                 (progn
 200                   (if (car ret)
 201                       (setq prev (put-alist (car (car ret))
 202                                             (cdr (car ret))
 203                                             prev))
 204                     )
 205                   (if (nth 2 ret)
 206                       (setq rest (put-alist (car (nth 2 ret))
 207                                             (cdr (nth 2 ret))
 208                                             rest))
 209                     )
 210                   (setq cla (put-alist (car cell)(cdr (nth 1 ret)) cla))
 211                   (setq ins (del-alist (car cell) ins))
 212                   )
 213               (throw 'tag nil)
 214               ))
 215         (setq r (cdr r))
 216         )
 217       (setq r (copy-alist ins))
 218       (while r
 219         (setq cell (car r))
 220         (setq aret (assoc (car cell) cla))
 221         (if aret
 222             (if (setq ret (field-unify cell aret))
 223                 (progn
 224                   (if (car ret)
 225                       (setq prev (put-alist (car (car ret))
 226                                             (cdr (car ret))
 227                                             prev))
 228                     )
 229                   (if (nth 2 ret)
 230                       (setq rest (put-alist (car (nth 2 ret))
 231                                             (cdr (nth 2 ret))
 232                                             rest))
 233                     )
 234                   (setq cla (del-alist (car cell) cla))
 235                   (setq ins (put-alist (car cell)(cdr (nth 1 ret)) ins))
 236                   )
 237               (throw 'tag nil)
 238               ))
 239         (setq r (cdr r))
 240         )
 241       (list prev (append cla ins) rest)
 242       )))
 243
 244 (defun get-unified-alist (db al)
 245   (let ((r db) ret)
 246     (catch 'tag
 247       (while r
 248         (if (setq ret (nth 1 (assoc-unify (car r) al)))
 249             (throw 'tag ret)
 250           )
 251         (setq r (cdr r))
 252         ))))
 253
 254 (defun delete-atype (atl al)
 255   (let* ((r atl) ret oal)
 256     (setq oal
 257           (catch 'tag
 258             (while r
 259               (if (setq ret (nth 1 (assoc-unify (car r) al)))
 260                   (throw 'tag (car r))
 261                 )
 262               (setq r (cdr r))
 263               )))
 264     (delete oal atl)
 265     ))
 266
 267 (defun remove-atype (sym al)
 268   (and (boundp sym)
 269        (set sym (delete-atype (eval sym) al))
 270        ))
 271
 272 (defun replace-atype (atl old-al new-al)
 273   (let* ((r atl) ret oal)
 274     (if (catch 'tag
 275           (while r
 276             (if (setq ret (nth 1 (assoc-unify (car r) old-al)))
 277                 (throw 'tag (rplaca r new-al))
 278               )
 279             (setq r (cdr r))
 280             ))
 281         atl)))
 282
 283 (defun set-atype (sym al &rest options)
 284   (if (null (boundp sym))
 285       (set sym al)
 286     (let* ((replacement (memq 'replacement options))
 287            (ignore-fields (car (cdr (memq 'ignore options))))
 288            (remove (or (car (cdr (memq 'remove options)))
 289                        (let ((ral (copy-alist al)))
 290                          (mapcar (function
 291                                   (lambda (type)
 292                                     (setq ral (del-alist type ral))
 293                                     ))
 294                                  ignore-fields)
 295                          ral)))
 296            )
 297       (set sym
 298            (or (if replacement
 299                    (replace-atype (eval sym) remove al)
 300                  )
 301                (cons al
 302                      (delete-atype (eval sym) remove)
 303                      )
 304                )))))
 305
 306
 307 ;;; @@ main selector
 308 ;;;
 309
 310 (defun mime/get-content-decoding-alist (al)
 311   (get-unified-alist mime/content-decoding-condition al)
 312   )
 313
 314
 315 ;;; @ external decoder
 316 ;;;
 317
 318 (defun mime-article/start-external-method-region (beg end cal)
 319   (save-excursion
 320     (save-restriction
 321       (narrow-to-region beg end)
 322       (goto-char beg)
 323       (let ((method (cdr (assoc 'method cal)))
 324             (name (mime-article/get-filename cal))
 325             )
 326         (if method
 327             (let ((file (make-temp-name
 328                          (expand-file-name "TM" mime/tmp-dir)))
 329                   b args)
 330               (if (nth 1 method)
 331                   (setq b beg)
 332                 (setq b
 333                       (if (re-search-forward "^$" nil t)
 334                           (1+ (match-end 0))
 335                         (point-min)
 336                         ))
 337                 )
 338               (goto-char b)
 339               (write-region b end file)
 340               (message "External method is starting...")
 341               (setq cal (put-alist
 342                          'name (replace-as-filename name) cal))
 343               (setq cal (put-alist 'file file cal))
 344               (setq args (nconc
 345                           (list (car method)
 346                                 mime/output-buffer-name (car method)
 347                                 )
 348                           (mime-article/make-method-args cal
 349                                                          (cdr (cdr method)))
 350                           ))
 351               (apply (function start-process) args)
 352               (mime-article/show-output-buffer)
 353               ))
 354         ))))
 355
 356 (defun mime-article/make-method-args (cal format)
 357   (mapcar (function
 358            (lambda (arg)
 359              (if (stringp arg)
 360                  arg
 361                (let* ((item (eval arg))
 362                       (ret (cdr (assoc item cal)))
 363                       )
 364                  (if ret
 365                      ret
 366                    (if (eq item 'encoding)
 367                        "7bit"
 368                      ""))
 369                  ))
 370              ))
 371           format))
 372
 373 (defun mime-article/show-output-buffer (&rest forms)
 374   (get-buffer-create mime/output-buffer-name)
 375   (let ((the-win (selected-window))
 376         (win (get-buffer-window mime/output-buffer-name))
 377         )
 378     (or win
 379         (if (and mime/output-buffer-window-is-shared-with-bbdb
 380                  (boundp 'bbdb-buffer-name)
 381                  (setq win (get-buffer-window bbdb-buffer-name))
 382                  )
 383             (set-window-buffer win mime/output-buffer-name)
 384           (select-window (get-buffer-window mime::article/preview-buffer))
 385           (setq win (split-window-vertically (/ (* (window-height) 3) 4)))
 386           (set-window-buffer win mime/output-buffer-name)
 387           ))
 388     (select-window win)
 389     (goto-char (point-max))
 390     (if forms
 391         (insert (apply (function format) forms))
 392       )
 393     (select-window the-win)
 394     ))
 395
 396
 397 ;;; @ file name
 398 ;;;
 399
 400 (defvar mime-view-file-name-char-regexp "[A-Za-z0-9+_-]")
 401
 402 (defvar mime-view-file-name-regexp-1
 403   (concat mime-view-file-name-char-regexp "+\\."
 404           mime-view-file-name-char-regexp "+"))
 405
 406 (defvar mime-view-file-name-regexp-2
 407   (concat (regexp-* mime-view-file-name-char-regexp)
 408           "\\(\\." mime-view-file-name-char-regexp "+\\)*"))
 409
 410 (defun mime-article/get-original-filename (param &optional encoding)
 411   (or (mime-article/get-uu-filename param encoding)
 412       (let (ret)
 413         (or (if (or (and (setq ret (mime/Content-Disposition))
 414                          (setq ret (assoc "filename" (cdr ret)))
 415                          )
 416                     (setq ret (assoc "name" param))
 417                     (setq ret (assoc "x-name" param))
 418                     )
 419                 (std11-strip-quoted-string (cdr ret))
 420               )
 421             (if (setq ret
 422                       (std11-find-field-body '("Content-Description"
 423                                                "Subject")))
 424                 (if (or (string-match mime-view-file-name-regexp-1 ret)
 425                         (string-match mime-view-file-name-regexp-2 ret))
 426                     (substring ret (match-beginning 0)(match-end 0))
 427                   ))
 428             ))
 429       ))
 430
 431 (defun mime-article/get-filename (param)
 432   (replace-as-filename (mime-article/get-original-filename param))
 433   )
 434
 435
 436 ;;; @ mail/news message
 437 ;;;
 438
 439 (defun mime-view-quitting-method-for-mime/show-message-mode ()
 440   (let ((mother mime::preview/mother-buffer)
 441         (win-conf mime::preview/original-window-configuration)
 442         )
 443     (kill-buffer
 444      (mime::preview-content-info/buffer (car mime::preview/content-list)))
 445     (mime-view-kill-buffer)
 446     (set-window-configuration win-conf)
 447     (pop-to-buffer mother)
 448     ;;(goto-char (point-min))
 449     ;;(mime-view-up-content)
 450     ))
 451
 452 (defun mime-article/view-message/rfc822 (beg end cal)
 453   (let* ((cnum (mime-article/point-content-number beg))
 454          (cur-buf (current-buffer))
 455          (new-name (format "%s-%s" (buffer-name) cnum))
 456          (mother mime::article/preview-buffer)
 457          (code-converter
 458           (or (cdr (assq major-mode mime-text-decoder-alist))
 459               'mime-view-default-code-convert-region))
 460          str)
 461     (setq str (buffer-substring beg end))
 462     (switch-to-buffer new-name)
 463     (erase-buffer)
 464     (insert str)
 465     (goto-char (point-min))
 466     (if (re-search-forward "^\n" nil t)
 467         (delete-region (point-min) (match-end 0))
 468       )
 469     (setq major-mode 'mime/show-message-mode)
 470     (setq mime::article/code-converter code-converter)
 471     (mime-view-mode mother)
 472     ))
 473
 474
 475 ;;; @ message/partial
 476 ;;;
 477
 478 (defvar mime-article/coding-system-alist
 479   (list '(mh-show-mode . no-conversion)
 480         (cons t (mime-charset-to-coding-system default-mime-charset))
 481         ))
 482
 483 (cond (running-mule-merged-emacs
 484        (defun mime-article::write-region (start end file)
 485          (let ((coding-system-for-write
 486                 (cdr
 487                  (or (assq major-mode mime-article/coding-system-alist)
 488                      (assq t mime-article/coding-system-alist)
 489                      ))))
 490            (write-region start end file)
 491            ))
 492        )
 493       ((or (boundp 'MULE)
 494            running-xemacs-with-mule)
 495        (defun mime-article::write-region (start end file)
 496          (let ((file-coding-system
 497                 (cdr
 498                  (or (assq major-mode mime-article/coding-system-alist)
 499                      (assq t mime-article/coding-system-alist)
 500                      ))))
 501            (write-region start end file)
 502            ))
 503        )
 504       ((boundp 'NEMACS)
 505        (defun mime-article::write-region (start end file)
 506          (let ((kanji-fileio-code
 507                 (cdr
 508                  (or (assq major-mode mime-article/kanji-code-alist)
 509                      (assq t mime-article/kanji-code-alist)
 510                      ))))
 511            (write-region start end file)
 512            ))
 513        )
 514       (t
 515        (defalias 'mime-article::write-region 'write-region)
 516        ))
 517
 518 (defun mime-article/decode-message/partial (beg end cal)
 519   (goto-char beg)
 520   (let* ((root-dir (expand-file-name
 521                     (concat "m-prts-" (user-login-name)) mime/tmp-dir))
 522          (id (cdr (assoc "id" cal)))
 523          (number (cdr (assoc "number" cal)))
 524          (total (cdr (assoc "total" cal)))
 525          file
 526          (mother mime::article/preview-buffer)
 527          )
 528     (or (file-exists-p root-dir)
 529         (make-directory root-dir)
 530         )
 531     (setq id (replace-as-filename id))
 532     (setq root-dir (concat root-dir "/" id))
 533     (or (file-exists-p root-dir)
 534         (make-directory root-dir)
 535         )
 536     (setq file (concat root-dir "/FULL"))
 537     (if (file-exists-p file)
 538         (let ((full-buf (get-buffer-create "FULL"))
 539               (pwin (or (get-buffer-window mother)
 540                         (get-largest-window)))
 541               )
 542           (save-window-excursion
 543             (set-buffer full-buf)
 544             (erase-buffer)
 545             (as-binary-input-file (insert-file-contents file))
 546             (setq major-mode 'mime/show-message-mode)
 547             (mime-view-mode mother)
 548             )
 549           (set-window-buffer pwin
 550                              (save-excursion
 551                                (set-buffer full-buf)
 552                                mime::article/preview-buffer))
 553           (select-window pwin)
 554           )
 555       (re-search-forward "^$")
 556       (goto-char (1+ (match-end 0)))
 557       (setq file (concat root-dir "/" number))
 558       (mime-article::write-region (point) (point-max) file)
 559       (let ((total-file (concat root-dir "/CT")))
 560         (setq total
 561               (if total
 562                   (progn
 563                     (or (file-exists-p total-file)
 564                         (save-excursion
 565                           (set-buffer
 566                            (get-buffer-create mime/temp-buffer-name))
 567                           (erase-buffer)
 568                           (insert total)
 569                           (write-file total-file)
 570                           (kill-buffer (current-buffer))
 571                           ))
 572                     (string-to-number total)
 573                     )
 574                 (and (file-exists-p total-file)
 575                      (save-excursion
 576                        (set-buffer (find-file-noselect total-file))
 577                        (prog1
 578                            (and (re-search-forward "[0-9]+" nil t)
 579                                 (string-to-number
 580                                  (buffer-substring (match-beginning 0)
 581                                                    (match-end 0)))
 582                                 )
 583                          (kill-buffer (current-buffer))
 584                          )))
 585                 )))
 586       (if (and total (> total 0))
 587           (catch 'tag
 588             (save-excursion
 589               (set-buffer (get-buffer-create mime/temp-buffer-name))
 590               (let ((full-buf (current-buffer)))
 591                 (erase-buffer)
 592                 (let ((i 1))
 593                   (while (<= i total)
 594                     (setq file (concat root-dir "/" (int-to-string i)))
 595                     (or (file-exists-p file)
 596                         (throw 'tag nil)
 597                         )
 598                     (as-binary-input-file (insert-file-contents file))
 599                     (goto-char (point-max))
 600                     (setq i (1+ i))
 601                     ))
 602                 (as-binary-output-file (write-file (concat root-dir "/FULL")))
 603                 (let ((i 1))
 604                   (while (<= i total)
 605                     (let ((file (format "%s/%d" root-dir i)))
 606                       (and (file-exists-p file)
 607                            (delete-file file)
 608                            ))
 609                     (setq i (1+ i))
 610                     ))
 611                 (let ((file (expand-file-name "CT" root-dir)))
 612                   (and (file-exists-p file)
 613                        (delete-file file)
 614                        ))
 615                 (save-window-excursion
 616                   (setq major-mode 'mime/show-message-mode)
 617                   (mime-view-mode mother)
 618                   )
 619                 (let ((pwin (or (get-buffer-window mother)
 620                                 (get-largest-window)
 621                                 ))
 622                       (pbuf (save-excursion
 623                               (set-buffer full-buf)
 624                               mime::article/preview-buffer)))
 625                   (set-window-buffer pwin pbuf)
 626                   (select-window pwin)
 627                   )))))
 628       )))
 629
 630
 631 ;;; @ rot13-47
 632 ;;;
 633
 634 (require 'view)
 635
 636 (defconst mime-view-text/plain-mode-map (copy-keymap view-mode-map))
 637 (define-key mime-view-text/plain-mode-map
 638   "q" (function mime-view-text/plain-exit))
 639
 640 (defun mime-view-text/plain-mode ()
 641   "\\{mime-view-text/plain-mode-map}"
 642   (setq buffer-read-only t)
 643   (setq major-mode 'mime-view-text/plain-mode)
 644   (setq mode-name "MIME-View text/plain")
 645   (use-local-map mime-view-text/plain-mode-map)
 646   )
 647
 648 (defun mime-view-text/plain-exit ()
 649   (interactive)
 650   (kill-buffer (current-buffer))
 651   )
 652
 653 (defun mime-article/decode-caesar (beg end cal)
 654   (let* ((cnum (mime-article/point-content-number beg))
 655          (cur-buf (current-buffer))
 656          (new-name (format "%s-%s" (buffer-name) cnum))
 657          (mother mime::article/preview-buffer)
 658          (charset (cdr (assoc "charset" cal)))
 659          (encoding (cdr (assq 'encoding cal)))
 660          (mode major-mode)
 661          str)
 662     (setq str (buffer-substring beg end))
 663     (let ((pwin (or (get-buffer-window mother)
 664                     (get-largest-window)))
 665           (buf (get-buffer-create new-name))
 666           )
 667       (set-window-buffer pwin buf)
 668       (set-buffer buf)
 669       (select-window pwin)
 670       )
 671     (setq buffer-read-only nil)
 672     (erase-buffer)
 673     (insert str)
 674     (goto-char (point-min))
 675     (if (re-search-forward "^\n" nil t)
 676         (delete-region (point-min) (match-end 0))
 677       )
 678     (let ((m (cdr (or (assq mode mime-text-decoder-alist)
 679                       (assq t mime-text-decoder-alist)))))
 680       (and (functionp m)
 681            (funcall m charset encoding)
 682            ))
 683     (save-excursion
 684       (set-mark (point-min))
 685       (goto-char (point-max))
 686       (tm:caesar-region)
 687       )
 688     (set-buffer-modified-p nil)
 689     (mime-view-text/plain-mode)
 690     ))
 691
 692
 693 ;;; @ end
 694 ;;;
 695
 696 (provide 'mime-play)
 697
 698 ;;; mime-play.el ends here