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 ;;; Version:
   9 ;;;     $Id: tm-play.el,v 7.2 1995/11/16 15:12:43 morioka Exp $
  10 ;;; Keywords: mail, news, MIME, multimedia
  11 ;;;
  12 ;;; This file is part of tm (Tools for MIME).
  13 ;;;
  14
  15 (require 'tm-view)
  16
  17
  18 ;;; @ content decoder
  19 ;;;
  20
  21 (defvar mime-preview/after-decoded-position nil)
  22
  23 (defun mime-preview/decode-content ()
  24   (interactive)
  25   (let ((pc (mime::point-preview-content (point))))
  26     (if pc
  27         (let ((the-buf (current-buffer)))
  28           (setq mime-preview/after-decoded-position (point))
  29           (set-buffer (mime::preview-content-info/buffer pc))
  30           (mime-article/decode-content
  31            (mime::preview-content-info/content-info pc))
  32           (if (eq (current-buffer)
  33                   (mime::preview-content-info/buffer pc))
  34               (progn
  35                 (set-buffer the-buf)
  36                 (goto-char mime-preview/after-decoded-position)
  37                 ))
  38           ))))
  39
  40
  41 (defun mime-article/decode-content (cinfo)
  42   (let ((beg (mime::content-info/point-min cinfo))
  43         (end (mime::content-info/point-max cinfo))
  44         (ctype (mime::content-info/type cinfo))
  45         (params (mime::content-info/parameters cinfo))
  46         (encoding (mime::content-info/encoding cinfo))
  47         )
  48     (if ctype
  49         (let (method cal ret)
  50           (setq cal (append (list (cons 'type ctype)
  51                                   (cons 'encoding encoding)
  52                                   (cons 'major-mode major-mode)
  53                                   )
  54                             params))
  55           (if mime-viewer/decoding-mode
  56               (setq cal (cons
  57                          (cons 'mode mime-viewer/decoding-mode)
  58                          cal))
  59             )
  60           (setq ret (mime/get-content-decoding-alist cal))
  61           (setq method (cdr (assoc 'method ret)))
  62           (cond ((and (symbolp method)
  63                       (fboundp method))
  64                  (funcall method beg end ret)
  65                  )
  66                 ((and (listp method)(stringp (car method)))
  67                  (mime-article/start-external-method-region beg end ret)
  68                  )
  69                 (t
  70                  (mime-article/show-output-buffer
  71                   "No method are specified for %s\n" ctype)
  72                  ))
  73           ))
  74     ))
  75
  76 (defun mime/get-content-decoding-alist (al)
  77   (get-unified-alist mime/content-decoding-condition al)
  78   )
  79
  80
  81 ;;; @ external decoder
  82 ;;;
  83
  84 (defun mime-article/start-external-method-region (beg end cal)
  85   (save-excursion
  86     (save-restriction
  87       (narrow-to-region beg end)
  88       (goto-char beg)
  89       (let ((method (cdr (assoc 'method cal)))
  90             (name (mime-article/get-name cal))
  91             )
  92         (if method
  93             (let ((file (make-temp-name
  94                          (expand-file-name "TM" mime/tmp-dir)))
  95                   b args)
  96               (if (nth 1 method)
  97                   (setq b beg)
  98                 (setq b
  99                       (if (re-search-forward "^$" nil t)
 100                           (1+ (match-end 0))
 101                         (point-min)
 102                         ))
 103                 )
 104               (goto-char b)
 105               (write-region b end file)
 106               (setq cal (put-alist
 107                          'name (replace-as-filename name) cal))
 108               (setq cal (put-alist 'file file cal))
 109               (setq args (nconc
 110                           (list (car method)
 111                                 mime/output-buffer-name (car method)
 112                                 )
 113                           (mime-article/make-method-args cal
 114                                                          (cdr (cdr method)))
 115                           ))
 116               (apply (function start-process) args)
 117               (mime-article/show-output-buffer)
 118               ))
 119         ))))
 120
 121 (defun mime-article/make-method-args (cal format)
 122   (mapcar (function
 123            (lambda (arg)
 124              (if (stringp arg)
 125                  arg
 126                (let ((ret (cdr (assoc (eval arg) cal))))
 127                  (if ret
 128                      ret
 129                    "")
 130                  ))
 131              ))
 132           format))
 133
 134 (defun mime-article/show-output-buffer (&rest forms)
 135   (let ((the-win (selected-window))
 136         (win (get-buffer-window mime/output-buffer-name))
 137         )
 138     (if (null win)
 139         (progn
 140           (setq win (split-window-vertically (/ (* (window-height) 3) 4)))
 141           (set-window-buffer win mime/output-buffer-name)
 142           ))
 143     (select-window win)
 144     (goto-char (point-max))
 145     (if forms
 146         (insert (apply (function format) forms))
 147       )
 148     (select-window the-win)
 149     ))
 150
 151
 152 ;;; @ file name
 153 ;;;
 154
 155 (defvar mime-viewer/file-name-char-regexp "[A-Za-z0-9+_-]")
 156
 157 (defvar mime-viewer/file-name-regexp-1
 158   (concat mime-viewer/file-name-char-regexp "+\\."
 159           mime-viewer/file-name-char-regexp "+"))
 160
 161 (defvar mime-viewer/file-name-regexp-2
 162   (concat (regexp-* mime-viewer/file-name-char-regexp)
 163           "\\(\\." mime-viewer/file-name-char-regexp "+\\)*"))
 164
 165 (defun mime-article/get-name (param)
 166   (let ((str (mime-viewer/get-subject param)))
 167     (if (string-match " " str)
 168         (if (or (string-match mime-viewer/file-name-regexp-1 str)
 169                 (string-match mime-viewer/file-name-regexp-2 str))
 170             (substring str (match-beginning 0)(match-end 0))
 171           )
 172       (replace-as-filename str)
 173       )))
 174
 175
 176 ;;; @ mail/news message
 177 ;;;
 178
 179 (defun mime-viewer/quitting-method-for-mime/show-message-mode ()
 180   (set-window-configuration mime/show-mode-old-window-configuration)
 181   (let ((mother mime::preview/mother-buffer))
 182     (kill-buffer
 183      (mime::preview-content-info/buffer (car mime::preview/content-list)))
 184     (mime-viewer/kill-buffer)
 185     (pop-to-buffer mother)
 186     ;;(goto-char (point-min))
 187     ;;(mime-viewer/up-content)
 188     ))
 189
 190 (defun mime-article/view-message/rfc822 (beg end cal)
 191   (let* ((cnum (mime-article/point-content-number beg))
 192          (cur-buf (current-buffer))
 193          (new-name (format "%s-%s" (buffer-name) cnum))
 194          (mother mime::article/preview-buffer)
 195          str)
 196     (setq str (buffer-substring beg end))
 197     (switch-to-buffer new-name)
 198     (erase-buffer)
 199     (insert str)
 200     (goto-char (point-min))
 201     (if (re-search-forward "^\n" nil t)
 202         (delete-region (point-min) (match-end 0))
 203       )
 204     (setq major-mode 'mime/show-message-mode)
 205     (mime/viewer-mode mother)
 206     ))
 207
 208
 209 ;;; @ message/partial
 210 ;;;
 211
 212 (defvar mime-article/coding-system-alist
 213   (and (boundp 'MULE)
 214        '((mh-show-mode . *noconv*)
 215          (t            . *ctext*)
 216          )))
 217
 218 (defvar mime-article/kanji-code-alist
 219   (and (boundp 'NEMACS)
 220        '((mh-show-mode . nil)
 221          (t            . 2)
 222          )))
 223
 224 (defun mime-article/decode-message/partial (beg end cal)
 225   (goto-char beg)
 226   (let* ((root-dir (expand-file-name
 227                     (concat "m-prts-" (user-login-name)) mime/tmp-dir))
 228          (id (cdr (assoc "id" cal)))
 229          (number (cdr (assoc "number" cal)))
 230          (total (cdr (assoc "total" cal)))
 231          (the-buf (current-buffer))
 232          file
 233          (mother mime::article/preview-buffer))
 234     (if (not (file-exists-p root-dir))
 235         (make-directory root-dir)
 236       )
 237     (setq id (replace-as-filename id))
 238     (setq root-dir (concat root-dir "/" id))
 239     (if (not (file-exists-p root-dir))
 240         (make-directory root-dir)
 241       )
 242     (setq file (concat root-dir "/FULL"))
 243     (if (not (file-exists-p file))
 244         (progn
 245           (re-search-forward "^$")
 246           (goto-char (1+ (match-end 0)))
 247           (setq file (concat root-dir "/" number))
 248           (let ((file-coding-system
 249                  (cdr
 250                   (or (assq major-mode mime-article/coding-system-alist)
 251                       (assq t mime-article/coding-system-alist)
 252                       )))
 253                 (kanji-fileio-code
 254                  (cdr
 255                   (or (assq major-mode mime-article/kanji-code-alist)
 256                       (assq t mime-article/kanji-code-alist)
 257                       )))
 258                 )
 259             (write-region (point) (point-max) file)
 260             )
 261           (if (get-buffer "*MIME-temp*")
 262               (kill-buffer "*MIME-temp*")
 263             )
 264           (switch-to-buffer "*MIME-temp*")
 265           (let ((i 1)
 266                 (max (string-to-int total))
 267                 (file-coding-system-for-read (if (boundp 'MULE)
 268                                                  *noconv*))
 269                 kanji-fileio-code)
 270             (catch 'tag
 271               (while (<= i max)
 272                 (setq file (concat root-dir "/" (int-to-string i)))
 273                 (if (not (file-exists-p file))
 274                     (progn
 275                       (switch-to-buffer the-buf)
 276                       (throw 'tag nil)
 277                       ))
 278                 (insert-file-contents file)
 279                 (goto-char (point-max))
 280                 (setq i (1+ i))
 281                 )
 282               (delete-other-windows)
 283               (write-file (concat root-dir "/FULL"))
 284               (setq major-mode 'mime/show-message-mode)
 285               (mime/viewer-mode mother)
 286               (pop-to-buffer (current-buffer))
 287               ))
 288           )
 289       (progn
 290         (delete-other-windows)
 291         (let ((file-coding-system-for-read
 292                (if (boundp 'MULE) *noconv*))
 293               kanji-fileio-code)
 294           (find-file file)
 295           )
 296         (setq major-mode 'mime/show-message-mode)
 297         (mime/viewer-mode mother)
 298         (pop-to-buffer (current-buffer))
 299         ))
 300     ))
 301
 302
 303 ;;; @ rot13-47
 304 ;;;
 305
 306 (defun mime-article/decode-caesar (beg end cal)
 307   (let* ((cnum (mime-article/point-content-number beg))
 308          (cur-buf (current-buffer))
 309          (new-name (format "%s-%s" (buffer-name) cnum))
 310          (mother mime::article/preview-buffer)
 311          (charset (cdr (assoc "charset" cal)))
 312          (encoding (cdr (assoc "encoding" cal)))
 313          (mode major-mode)
 314          str)
 315     (setq str (buffer-substring beg end))
 316     (switch-to-buffer new-name)
 317     (erase-buffer)
 318     (insert str)
 319     (goto-char (point-min))
 320     (if (re-search-forward "^\n" nil t)
 321         (delete-region (point-min) (match-end 0))
 322       )
 323     (let ((m (assq mode mime-viewer/code-converter-alist)))
 324       (if (and m (fboundp (setq m (cdr m))))
 325           (funcall m (point-min) (point-max) charset encoding)
 326         (mime-viewer/default-code-convert-region (point-min) (point-max)
 327                                                  charset encoding)
 328         ))
 329     (save-excursion
 330       (set-mark (point-min))
 331       (goto-char (point-max))
 332       (tm:caesar-region)
 333       )
 334     (view-mode)
 335     ))
 336
 337
 338 ;;; @ end
 339 ;;;
 340
 341 (provide 'tm-play)