tm-play.el

   1 ;;;
   2 ;;; tm-play.el --- decoder for tm-view.el
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1994,1995 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;;; Created: 1995/9/26 (separated from tm-view.el)
  10 ;;; Version:
  11 ;;;     $Id: tm-play.el,v 7.11 1995/12/21 18:11:03 morioka Exp $
  12 ;;; Keywords: mail, news, MIME, multimedia
  13 ;;;
  14 ;;; This file is part of tm (Tools for MIME).
  15 ;;;
  16 ;;; This program is free software; you can redistribute it and/or
  17 ;;; modify it under the terms of the GNU General Public License as
  18 ;;; published by the Free Software Foundation; either version 2, or
  19 ;;; (at your option) any later version.
  20 ;;;
  21 ;;; This program is distributed in the hope that it will be useful,
  22 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  24 ;;; General Public License for more details.
  25 ;;;
  26 ;;; You should have received a copy of the GNU General Public License
  27 ;;; along with This program.  If not, write to the Free Software
  28 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  29 ;;;
  30 ;;; Code:
  31
  32 (require 'tm-view)
  33
  34
  35 ;;; @ content decoder
  36 ;;;
  37
  38 (defvar mime-preview/after-decoded-position nil)
  39
  40 (defun mime-preview/decode-content ()
  41   (interactive)
  42   (let ((pc (mime-preview/point-pcinfo (point))))
  43     (if pc
  44         (let ((the-buf (current-buffer)))
  45           (setq mime-preview/after-decoded-position (point))
  46           (set-buffer (mime::preview-content-info/buffer pc))
  47           (mime-article/decode-content
  48            (mime::preview-content-info/content-info pc))
  49           (if (eq (current-buffer)
  50                   (mime::preview-content-info/buffer pc))
  51               (progn
  52                 (set-buffer the-buf)
  53                 (goto-char mime-preview/after-decoded-position)
  54                 ))
  55           ))))
  56
  57
  58 (defun mime-article/decode-content (cinfo)
  59   (let ((beg (mime::content-info/point-min cinfo))
  60         (end (mime::content-info/point-max cinfo))
  61         (ctype (mime::content-info/type cinfo))
  62         (params (mime::content-info/parameters cinfo))
  63         (encoding (mime::content-info/encoding cinfo))
  64         )
  65     (if ctype
  66         (let (method cal ret)
  67           (setq cal (append (list (cons 'type ctype)
  68                                   (cons 'encoding encoding)
  69                                   (cons 'major-mode major-mode)
  70                                   )
  71                             params))
  72           (if mime-viewer/decoding-mode
  73               (setq cal (cons
  74                          (cons 'mode mime-viewer/decoding-mode)
  75                          cal))
  76             )
  77           (setq ret (mime/get-content-decoding-alist cal))
  78           (setq method (cdr (assoc 'method ret)))
  79           (cond ((and (symbolp method)
  80                       (fboundp method))
  81                  (funcall method beg end ret)
  82                  )
  83                 ((and (listp method)(stringp (car method)))
  84                  (mime-article/start-external-method-region beg end ret)
  85                  )
  86                 (t
  87                  (mime-article/show-output-buffer
  88                   "No method are specified for %s\n" ctype)
  89                  ))
  90           ))
  91     ))
  92
  93 (defun mime/get-content-decoding-alist (al)
  94   (get-unified-alist mime/content-decoding-condition al)
  95   )
  96
  97
  98 ;;; @ external decoder
  99 ;;;
 100
 101 (defun mime-article/start-external-method-region (beg end cal)
 102   (save-excursion
 103     (save-restriction
 104       (narrow-to-region beg end)
 105       (goto-char beg)
 106       (let ((method (cdr (assoc 'method cal)))
 107             (name (mime-article/get-filename cal))
 108             )
 109         (if method
 110             (let ((file (make-temp-name
 111                          (expand-file-name "TM" mime/tmp-dir)))
 112                   b args)
 113               (if (nth 1 method)
 114                   (setq b beg)
 115                 (setq b
 116                       (if (re-search-forward "^$" nil t)
 117                           (1+ (match-end 0))
 118                         (point-min)
 119                         ))
 120                 )
 121               (goto-char b)
 122               (write-region b end file)
 123               (setq cal (put-alist
 124                          'name (replace-as-filename name) cal))
 125               (setq cal (put-alist 'file file cal))
 126               (setq args (nconc
 127                           (list (car method)
 128                                 mime/output-buffer-name (car method)
 129                                 )
 130                           (mime-article/make-method-args cal
 131                                                          (cdr (cdr method)))
 132                           ))
 133               (apply (function start-process) args)
 134               (mime-article/show-output-buffer)
 135               ))
 136         ))))
 137
 138 (defun mime-article/make-method-args (cal format)
 139   (mapcar (function
 140            (lambda (arg)
 141              (if (stringp arg)
 142                  arg
 143                (let ((ret (cdr (assoc (eval arg) cal))))
 144                  (if ret
 145                      ret
 146                    "")
 147                  ))
 148              ))
 149           format))
 150
 151 (defun mime-article/show-output-buffer (&rest forms)
 152   (get-buffer-create mime/output-buffer-name)
 153   (let ((the-win (selected-window))
 154         (win (get-buffer-window mime/output-buffer-name))
 155         )
 156     (if (null win)
 157         (progn
 158           (setq win (split-window-vertically (/ (* (window-height) 3) 4)))
 159           (set-window-buffer win mime/output-buffer-name)
 160           ))
 161     (select-window win)
 162     (goto-char (point-max))
 163     (if forms
 164         (insert (apply (function format) forms))
 165       )
 166     (select-window the-win)
 167     ))
 168
 169
 170 ;;; @ file name
 171 ;;;
 172
 173 (defvar mime-viewer/file-name-char-regexp "[A-Za-z0-9+_-]")
 174
 175 (defvar mime-viewer/file-name-regexp-1
 176   (concat mime-viewer/file-name-char-regexp "+\\."
 177           mime-viewer/file-name-char-regexp "+"))
 178
 179 (defvar mime-viewer/file-name-regexp-2
 180   (concat (regexp-* mime-viewer/file-name-char-regexp)
 181           "\\(\\." mime-viewer/file-name-char-regexp "+\\)*"))
 182
 183 (defun mime-article/get-original-filename (param &optional encoding)
 184   (or (mime-article/get-uu-filename param encoding)
 185       (let (ret)
 186         (or (if (or (and (setq ret (mime/Content-Disposition))
 187                          (setq ret (assoc "filename" (cdr ret)))
 188                          )
 189                     (setq ret (assoc "name" param))
 190                     (setq ret (assoc "x-name" param))
 191                     )
 192                 (rfc822/strip-quoted-string (cdr ret))
 193               )
 194             (if (setq ret
 195                       (or (rfc822/get-field-body "Content-Description")
 196                           (rfc822/get-field-body "Subject")
 197                           ))
 198                 (if (or (string-match mime-viewer/file-name-regexp-1 ret)
 199                         (string-match mime-viewer/file-name-regexp-2 ret))
 200                     (substring ret (match-beginning 0)(match-end 0))
 201                   ))
 202             ))
 203       ""))
 204
 205 (defun mime-article/get-filename (param)
 206   (replace-as-filename (mime-article/get-original-filename param))
 207   )
 208
 209
 210 ;;; @ mail/news message
 211 ;;;
 212
 213 (defun mime-viewer/quitting-method-for-mime/show-message-mode ()
 214   (let ((mother mime::preview/mother-buffer)
 215         (win-conf mime::preview/original-window-configuration)
 216         )
 217     (kill-buffer
 218      (mime::preview-content-info/buffer (car mime::preview/content-list)))
 219     (mime-viewer/kill-buffer)
 220     (set-window-configuration win-conf)
 221     (pop-to-buffer mother)
 222     ;;(goto-char (point-min))
 223     ;;(mime-viewer/up-content)
 224     ))
 225
 226 (defun mime-article/view-message/rfc822 (beg end cal)
 227   (let* ((cnum (mime-article/point-content-number beg))
 228          (cur-buf (current-buffer))
 229          (new-name (format "%s-%s" (buffer-name) cnum))
 230          (mother mime::article/preview-buffer)
 231          (code-converter
 232           (or (cdr (assq major-mode mime-viewer/code-converter-alist))
 233               'mime-viewer/default-code-convert-region))
 234          str)
 235     (setq str (buffer-substring beg end))
 236     (switch-to-buffer new-name)
 237     (erase-buffer)
 238     (insert str)
 239     (goto-char (point-min))
 240     (if (re-search-forward "^\n" nil t)
 241         (delete-region (point-min) (match-end 0))
 242       )
 243     (setq major-mode 'mime/show-message-mode)
 244     (setq mime::article/code-converter code-converter)
 245     (mime/viewer-mode mother)
 246     ))
 247
 248
 249 ;;; @ message/partial
 250 ;;;
 251
 252 (defvar mime-article/coding-system-alist
 253   (and (boundp 'MULE)
 254        '((mh-show-mode . *noconv*)
 255          (t            . *ctext*)
 256          )))
 257
 258 (defvar mime-article/kanji-code-alist
 259   (and (boundp 'NEMACS)
 260        '((mh-show-mode . nil)
 261          (t            . 2)
 262          )))
 263
 264 (defun mime-article/decode-message/partial (beg end cal)
 265   (goto-char beg)
 266   (let* ((root-dir (expand-file-name
 267                     (concat "m-prts-" (user-login-name)) mime/tmp-dir))
 268          (id (cdr (assoc "id" cal)))
 269          (number (cdr (assoc "number" cal)))
 270          (total (cdr (assoc "total" cal)))
 271          (the-buf (current-buffer))
 272          file
 273          (mother mime::article/preview-buffer)
 274          (win-conf (save-excursion
 275                      (set-buffer mother)
 276                      mime::preview/original-window-configuration))
 277          )
 278     (if (not (file-exists-p root-dir))
 279         (make-directory root-dir)
 280       )
 281     (setq id (replace-as-filename id))
 282     (setq root-dir (concat root-dir "/" id))
 283     (if (not (file-exists-p root-dir))
 284         (make-directory root-dir)
 285       )
 286     (setq file (concat root-dir "/FULL"))
 287     (if (not (file-exists-p file))
 288         (progn
 289           (re-search-forward "^$")
 290           (goto-char (1+ (match-end 0)))
 291           (setq file (concat root-dir "/" number))
 292           (let ((file-coding-system
 293                  (cdr
 294                   (or (assq major-mode mime-article/coding-system-alist)
 295                       (assq t mime-article/coding-system-alist)
 296                       )))
 297                 (kanji-fileio-code
 298                  (cdr
 299                   (or (assq major-mode mime-article/kanji-code-alist)
 300                       (assq t mime-article/kanji-code-alist)
 301                       )))
 302                 )
 303             (write-region (point) (point-max) file)
 304             )
 305           (if (get-buffer mime/temp-buffer-name)
 306               (kill-buffer mime/temp-buffer-name)
 307             )
 308           (switch-to-buffer mime/temp-buffer-name)
 309           (let ((i 1)
 310                 (max (string-to-int total))
 311                 (file-coding-system-for-read (if (boundp 'MULE)
 312                                                  *noconv*))
 313                 kanji-fileio-code)
 314             (catch 'tag
 315               (while (<= i max)
 316                 (setq file (concat root-dir "/" (int-to-string i)))
 317                 (if (not (file-exists-p file))
 318                     (progn
 319                       (switch-to-buffer the-buf)
 320                       (throw 'tag nil)
 321                       ))
 322                 (insert-file-contents file)
 323                 (goto-char (point-max))
 324                 (setq i (1+ i))
 325                 )
 326               ;;(delete-other-windows)
 327               (let ((buf (current-buffer)))
 328                 (write-file (concat root-dir "/FULL"))
 329                 (set-window-configuration win-conf)
 330                 (let ((win (get-buffer-window mother)))
 331                   (if win
 332                       (select-window win)
 333                     ))
 334                 (set-window-buffer (selected-window) buf)
 335                 ;;(set-window-buffer buf)
 336                 (setq major-mode 'mime/show-message-mode)
 337                 )
 338               (mime/viewer-mode mother)
 339               (pop-to-buffer (current-buffer))
 340               ))
 341           )
 342       (progn
 343         ;;(delete-other-windows)
 344         (set-window-configuration win-conf)
 345         (select-window (get-buffer-window mother))
 346         (let ((file-coding-system-for-read
 347                (if (boundp 'MULE) *noconv*))
 348               kanji-fileio-code)
 349           (set-buffer (get-buffer-create "FULL"))
 350           (insert-file-contents file)
 351           )
 352         (setq major-mode 'mime/show-message-mode)
 353         (mime/viewer-mode mother)
 354         ;;(pop-to-buffer (current-buffer))
 355         ))
 356     ))
 357
 358
 359 ;;; @ rot13-47
 360 ;;;
 361
 362 (defun mime-article/decode-caesar (beg end cal)
 363   (let* ((cnum (mime-article/point-content-number beg))
 364          (cur-buf (current-buffer))
 365          (new-name (format "%s-%s" (buffer-name) cnum))
 366          (mother mime::article/preview-buffer)
 367          (charset (cdr (assoc "charset" cal)))
 368          (encoding (cdr (assq 'encoding cal)))
 369          (mode major-mode)
 370          str)
 371     (setq str (buffer-substring beg end))
 372     (switch-to-buffer new-name)
 373     (setq buffer-read-only nil)
 374     (erase-buffer)
 375     (insert str)
 376     (goto-char (point-min))
 377     (if (re-search-forward "^\n" nil t)
 378         (delete-region (point-min) (match-end 0))
 379       )
 380     (let ((m (assq mode mime-viewer/code-converter-alist)))
 381       (if (and m (fboundp (setq m (cdr m))))
 382           (funcall m (point-min) (point-max) charset encoding)
 383         (mime-viewer/default-code-convert-region (point-min) (point-max)
 384                                                  charset encoding)
 385         ))
 386     (save-excursion
 387       (set-mark (point-min))
 388       (goto-char (point-max))
 389       (tm:caesar-region)
 390       )
 391     (view-mode)
 392     ))
 393
 394
 395 ;;; @ end
 396 ;;;
 397
 398 (provide 'tm-play)