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.9 1995/12/10 20:33:48 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-name 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-name (param)
 184   (let ((str (mime-viewer/get-subject param)))
 185     (if (string-match " " str)
 186         (if (or (string-match mime-viewer/file-name-regexp-1 str)
 187                 (string-match mime-viewer/file-name-regexp-2 str))
 188             (substring str (match-beginning 0)(match-end 0))
 189           )
 190       (replace-as-filename str)
 191       )))
 192
 193
 194 ;;; @ mail/news message
 195 ;;;
 196
 197 (defun mime-viewer/quitting-method-for-mime/show-message-mode ()
 198   (let ((mother mime::preview/mother-buffer)
 199         (win-conf mime::preview/original-window-configuration)
 200         )
 201     (kill-buffer
 202      (mime::preview-content-info/buffer (car mime::preview/content-list)))
 203     (mime-viewer/kill-buffer)
 204     (set-window-configuration win-conf)
 205     (pop-to-buffer mother)
 206     ;;(goto-char (point-min))
 207     ;;(mime-viewer/up-content)
 208     ))
 209
 210 (defun mime-article/view-message/rfc822 (beg end cal)
 211   (let* ((cnum (mime-article/point-content-number beg))
 212          (cur-buf (current-buffer))
 213          (new-name (format "%s-%s" (buffer-name) cnum))
 214          (mother mime::article/preview-buffer)
 215          (code-converter
 216           (or (cdr (assq major-mode mime-viewer/code-converter-alist))
 217               'mime-viewer/default-code-convert-region))
 218          str)
 219     (setq str (buffer-substring beg end))
 220     (switch-to-buffer new-name)
 221     (erase-buffer)
 222     (insert str)
 223     (goto-char (point-min))
 224     (if (re-search-forward "^\n" nil t)
 225         (delete-region (point-min) (match-end 0))
 226       )
 227     (setq major-mode 'mime/show-message-mode)
 228     (setq mime::article/code-converter code-converter)
 229     (mime/viewer-mode mother)
 230     ))
 231
 232
 233 ;;; @ message/partial
 234 ;;;
 235
 236 (defvar mime-article/coding-system-alist
 237   (and (boundp 'MULE)
 238        '((mh-show-mode . *noconv*)
 239          (t            . *ctext*)
 240          )))
 241
 242 (defvar mime-article/kanji-code-alist
 243   (and (boundp 'NEMACS)
 244        '((mh-show-mode . nil)
 245          (t            . 2)
 246          )))
 247
 248 (defun mime-article/decode-message/partial (beg end cal)
 249   (goto-char beg)
 250   (let* ((root-dir (expand-file-name
 251                     (concat "m-prts-" (user-login-name)) mime/tmp-dir))
 252          (id (cdr (assoc "id" cal)))
 253          (number (cdr (assoc "number" cal)))
 254          (total (cdr (assoc "total" cal)))
 255          (the-buf (current-buffer))
 256          file
 257          (mother mime::article/preview-buffer)
 258          (win-conf (save-excursion
 259                      (set-buffer mother)
 260                      mime::preview/original-window-configuration))
 261          )
 262     (if (not (file-exists-p root-dir))
 263         (make-directory root-dir)
 264       )
 265     (setq id (replace-as-filename id))
 266     (setq root-dir (concat root-dir "/" id))
 267     (if (not (file-exists-p root-dir))
 268         (make-directory root-dir)
 269       )
 270     (setq file (concat root-dir "/FULL"))
 271     (if (not (file-exists-p file))
 272         (progn
 273           (re-search-forward "^$")
 274           (goto-char (1+ (match-end 0)))
 275           (setq file (concat root-dir "/" number))
 276           (let ((file-coding-system
 277                  (cdr
 278                   (or (assq major-mode mime-article/coding-system-alist)
 279                       (assq t mime-article/coding-system-alist)
 280                       )))
 281                 (kanji-fileio-code
 282                  (cdr
 283                   (or (assq major-mode mime-article/kanji-code-alist)
 284                       (assq t mime-article/kanji-code-alist)
 285                       )))
 286                 )
 287             (write-region (point) (point-max) file)
 288             )
 289           (if (get-buffer mime/temp-buffer-name)
 290               (kill-buffer mime/temp-buffer-name)
 291             )
 292           (switch-to-buffer mime/temp-buffer-name)
 293           (let ((i 1)
 294                 (max (string-to-int total))
 295                 (file-coding-system-for-read (if (boundp 'MULE)
 296                                                  *noconv*))
 297                 kanji-fileio-code)
 298             (catch 'tag
 299               (while (<= i max)
 300                 (setq file (concat root-dir "/" (int-to-string i)))
 301                 (if (not (file-exists-p file))
 302                     (progn
 303                       (switch-to-buffer the-buf)
 304                       (throw 'tag nil)
 305                       ))
 306                 (insert-file-contents file)
 307                 (goto-char (point-max))
 308                 (setq i (1+ i))
 309                 )
 310               ;;(delete-other-windows)
 311               (let ((buf (current-buffer)))
 312                 (write-file (concat root-dir "/FULL"))
 313                 (set-window-configuration win-conf)
 314                 (let ((win (get-buffer-window mother)))
 315                   (if win
 316                       (select-window win)
 317                     ))
 318                 (set-window-buffer (selected-window) buf)
 319                 ;;(set-window-buffer buf)
 320                 (setq major-mode 'mime/show-message-mode)
 321                 )
 322               (mime/viewer-mode mother)
 323               (pop-to-buffer (current-buffer))
 324               ))
 325           )
 326       (progn
 327         ;;(delete-other-windows)
 328         (set-window-configuration win-conf)
 329         (select-window (get-buffer-window mother))
 330         (let ((file-coding-system-for-read
 331                (if (boundp 'MULE) *noconv*))
 332               kanji-fileio-code)
 333           (set-buffer (get-buffer-create "FULL"))
 334           (insert-file-contents file)
 335           )
 336         (setq major-mode 'mime/show-message-mode)
 337         (mime/viewer-mode mother)
 338         ;;(pop-to-buffer (current-buffer))
 339         ))
 340     ))
 341
 342
 343 ;;; @ rot13-47
 344 ;;;
 345
 346 (defun mime-article/decode-caesar (beg end cal)
 347   (let* ((cnum (mime-article/point-content-number beg))
 348          (cur-buf (current-buffer))
 349          (new-name (format "%s-%s" (buffer-name) cnum))
 350          (mother mime::article/preview-buffer)
 351          (charset (cdr (assoc "charset" cal)))
 352          (encoding (cdr (assoc "encoding" cal)))
 353          (mode major-mode)
 354          str)
 355     (setq str (buffer-substring beg end))
 356     (switch-to-buffer new-name)
 357     (setq buffer-read-only nil)
 358     (erase-buffer)
 359     (insert str)
 360     (goto-char (point-min))
 361     (if (re-search-forward "^\n" nil t)
 362         (delete-region (point-min) (match-end 0))
 363       )
 364     (let ((m (assq mode mime-viewer/code-converter-alist)))
 365       (if (and m (fboundp (setq m (cdr m))))
 366           (funcall m (point-min) (point-max) charset encoding)
 367         (mime-viewer/default-code-convert-region (point-min) (point-max)
 368                                                  charset encoding)
 369         ))
 370     (save-excursion
 371       (set-mark (point-min))
 372       (goto-char (point-max))
 373       (tm:caesar-region)
 374       )
 375     (view-mode)
 376     ))
 377
 378
 379 ;;; @ end
 380 ;;;
 381
 382 (provide 'tm-play)