+++ /dev/null
-;;;
-;;; tm-comp.el --- attachment for MIME composer
-;;;
-;;; Copyright (C) 1995 Free Software Foundation, Inc.
-;;; Copyright (C) 1994,1995 MORIOKA Tomohiko
-;;; Copyright (C) 1994,1995 OKABE Yasuo
-;;;
-;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>,
-;;; OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
-;;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
-;;; Kazushi (Jam) MARUKAWA <kazusi-m@is.aist-nara.ac.jp>,
-;;; KOBAYASHI Shuhei <shuhei@cmpt01.phys.tohoku.ac.jp>,
-;;; YAMAOKA Katsumi <yamaoka@ga.sony.co.jp>,
-;;; and Richard Stanton <stanton@haas.berkeley.edu>
-;;; Keywords: mail, news, MIME, multimedia
-;;;
-;;; This file is part of tm (Tools for MIME).
-;;;
-
-(require 'tm-view)
-(require 'tl-822)
-(require 'tl-list)
-(require 'mail-utils)
-
-
-;;; @ version
-;;;
-
-(defconst mime/composer-RCS-ID
- "$Id: tm-comp.el,v 7.2 1995/10/08 09:31:05 morioka Exp $")
-
-(defconst mime/composer-version (get-version-string mime/composer-RCS-ID))
-
-
-;;; @ variables
-;;;
-
-(defvar mime/message-default-max-length 1000)
-
-(defvar mime/message-max-length-alist
- '((news-reply-mode . 500)))
-
-(defconst mime/message-nuke-headers
- "\\(^Content-\\|^Subject:\\|^MIME-Version:\\)")
-(defvar mime/message-blind-headers "\\(^[BDFbdf]cc:\\|^cc:[ \t]*$\\)")
-
-(defvar mime/message-default-sender-alist
- '((mail-mode . mail-send-and-exit)
- (mh-letter-mode . mh-send-letter)
- (news-reply-mode . gnus-inews-news)))
-
-(defvar mime/message-sender-alist
- '((mail-mode . (lambda ()
- (interactive)
- (sendmail-send-it)
- ))
- (mh-letter-mode . (lambda (&optional arg)
- (interactive "P")
- (write-region (point-min) (point-max)
- mime/draft-file-name)
- (message
- (format "Sending %d/%d..." (+ i 1) total))
- (cond (arg
- (pop-to-buffer "MH mail delivery")
- (erase-buffer)
- (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush"
- "-nodraftfolder" mh-send-args mime/draft-file-name)
- (goto-char (point-max)) ; show the interesting part
- (recenter -1)
- (sit-for 1))
- (t
- (apply 'mh-exec-cmd-quiet t mh-send-prog
- (mh-list-to-string
- (list "-nopush" "-nodraftfolder" "-noverbose" "-nowatch" mh-send-args mime/draft-file-name)))))
- (message
- (format "Sending %d/%d... done" (+ i 1) total))
- ))
- ))
-
-
-(defvar mime/window-config-alist
- '((mail-mode . nil)
- (mh-letter-mode . mh-previous-window-config)
- (news-reply-mode . (cond ((boundp 'gnus-winconf-post-news)
- (prog1
- gnus-winconf-post-news
- (setq gnus-winconf-post-news nil)
- ))
- ((boundp 'gnus-prev-winconf)
- (prog1
- gnus-prev-winconf
- (setq gnus-prev-winconf nil)
- ))
- ))
- ))
-
-(defvar mime/news-reply-mode-server-running nil)
-
-
-(defvar mime/message-before-send-hook-alist
- '((mh-letter-mode . mh-before-send-letter-hook)))
-
-(defvar mime/message-after-send-hook-alist
- '((mh-letter-mode . (lambda ()
- (if mh-annotate-char
- (mh-annotate-msg mh-sent-from-msg
- mh-sent-from-folder
- mh-annotate-char
- "-component" mh-annotate-field
- "-text"
- (format "\"%s %s\""
- (mh-get-field "To:")
- (mh-get-field "Cc:"))))))
- ))
-
-(defvar tm-comp/message-inserter-alist nil)
-
-
-;;; @ edit
-;;;
-
-(defun tm-comp::mime-insert-file (file)
- "Insert a message from a file."
- (interactive "fInsert file as MIME message: ")
- (let* ((guess (mime-find-file-type file))
- (pritype (nth 0 guess))
- (subtype (nth 1 guess))
- (parameters (nth 2 guess))
- (default (nth 3 guess)) ;Guess encoding from its file name.
- (encoding
- (if (not (interactive-p))
- default
- (completing-read
- (concat "What transfer encoding"
- (if default
- (concat " (default "
- (if (string-equal default "") "\"\"" default)
- ")"
- ))
- ": ")
- mime-transfer-encoders nil t nil))))
- (if (string-equal encoding "")
- (setq encoding default))
- (if (consp parameters)
- (let ((rest parameters) cell attribute value)
- (setq parameters "")
- (while rest
- (setq cell (car rest))
- (setq attribute (car cell))
- (setq value (cdr cell))
- (if (eq value 'file)
- (setq value (file-name-nondirectory file))
- )
- (setq parameters (concat parameters "; " attribute "=" value))
- (setq rest (cdr rest))
- )))
- (mime-insert-tag pritype subtype parameters)
- (mime-insert-binary-file file encoding)
- ))
-
-;; Insert the binary content after MIME tag.
-;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
-;; for x-uue
-(defun tm-comp::mime-insert-binary-file (file &optional encoding)
- "Insert binary FILE at point.
-Optional argument ENCODING specifies an encoding method such as base64."
- (let ((tmpbuf (get-buffer-create " *MIME insert*")))
- (save-excursion
- (set-buffer tmpbuf)
- (erase-buffer)
- (let ((mc-flag nil) ;Mule
- (file-coding-system-for-read
- (if (featurep 'mule) *noconv*))
- (kanji-flag nil) ;NEmacs
- (emx-binary-mode t) ;Stop CRLF to LF conversion in OS/2
- )
- (let (jka-compr-compression-info-list
- jam-zcat-filename-list)
- (insert-file-contents file))))
- (prog1
- (if (and (stringp encoding)
- (string-equal (downcase encoding) "x-uue"))
- (let ((mime-transfer-encoders
- (copy-alist (cons (list "x-uue" "uuencode"
- (file-name-nondirectory file))
- mime-transfer-encoders))))
- (mime-insert-binary-buffer tmpbuf encoding))
- (mime-insert-binary-buffer tmpbuf encoding))
- (kill-buffer tmpbuf))))
-
-;; Insert the binary content after MIME tag.
-;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
-;; for x-uue
-(defun tm-comp::mime-insert-binary-buffer (buffer &optional encoding)
- "Insert binary BUFFER at point.
-Optional argument ENCODING specifies an encoding method such as base64."
- (let* ((tagend (1- (point))) ;End of the tag
- (hide-p (and mime-auto-hide-body
- (stringp encoding)
- (let ((en (downcase encoding)))
- (or (string-equal en "base64")
- (string-equal en "x-uue")
- ))))
- )
- (save-restriction
- (narrow-to-region (1- (point)) (point))
- (let ((start (point))
- (emx-binary-mode t)) ;Stop LF to CRLF conversion in OS/2
- (insert-buffer-substring buffer)
- ;; Encode binary message if necessary.
- (if encoding
- (mime-encode-region encoding start (point-max))))
- (if hide-p
- (progn
- (mime-flag-region (point-min) (1- (point-max)) ?\^M)
- (goto-char (point-max)))
- ))
- ;; Define encoding even if it is 7bit.
- (if (stringp encoding)
- (save-excursion
- (goto-char tagend) ;Make sure which line the tag is on.
- (mime-define-encoding encoding)))
- ))
-
-
-(defun tm-comp/insert-message (&optional message)
- (interactive)
- (let ((inserter (assoc-value major-mode tm-comp/message-inserter-alist)))
- (if (and inserter (fboundp inserter))
- (progn
- (mime-insert-tag "message" "rfc822")
- (funcall inserter message)
- )
- (message "Sorry, I don't have message inserter for your MUA.")
- )))
-
-
-;;; @ split
-;;;
-
-(defun mime/split-and-send (&optional cmd)
- (interactive)
- (let ((mime/message-max-length
- (or (cdr (assq major-mode mime/message-max-length-alist))
- mime/message-default-max-length))
- (lines (count-lines (point-min) (point-max)))
- )
- (if (<= lines mime/message-max-length)
- (call-interactively
- (or cmd (cdr (assq major-mode mime/message-default-sender-alist))))
- (let* ((mime/draft-file-name
- (or (buffer-file-name)
- (make-temp-name (expand-file-name "tm-draft" mime/tmp-dir))))
- (separator mail-header-separator)
- (config (eval (cdr (assq major-mode mime/window-config-alist))))
- (id (concat "\""
- (replace-space-with-underline (current-time-string))
- "@" (system-name) "\"")))
-
- (let ((hook (cdr (assq major-mode
- mime/message-before-send-hook-alist))))
- (run-hooks hook))
- (let* ((header (rfc822/get-header-string-except
- mime/message-nuke-headers separator))
- (orig-header (rfc822/get-header-string-except
- mime/message-blind-headers separator))
- (subject (mail-fetch-field "subject"))
- (total (+ (/ lines mime/message-max-length)
- (if (> (mod lines mime/message-max-length) 0)
- 1)))
- (i 0)
- (l mime/message-max-length)
- (the-buf (current-buffer))
- (buf (get-buffer "*tmp-send*"))
- (command
- (or cmd
- (cdr (assq major-mode mime/message-sender-alist))
- (cdr (assq major-mode mime/message-default-sender-alist))))
- data)
- (goto-char (point-min))
- (if (re-search-forward (concat "^" (regexp-quote separator) "$")
- nil t)
- (replace-match "")
- )
- (if buf
- (progn
- (switch-to-buffer buf)
- (erase-buffer)
- (switch-to-buffer the-buf)
- )
- (setq buf (get-buffer-create "*tmp-send*"))
- )
- (switch-to-buffer buf)
- (make-variable-buffer-local 'mail-header-separator)
- (setq mail-header-separator separator)
- (switch-to-buffer the-buf)
- (goto-char (point-min))
- (re-search-forward "^$" nil t)
- (while (< i total)
- (setq buf (get-buffer "*tmp-send*"))
- (setq data (buffer-substring
- (point)
- (progn
- (goto-line l)
- (point))
- ))
- (switch-to-buffer buf)
- (insert header)
- (insert
- (format "Subject: %s (%d/%d)\n" subject (+ i 1) total))
- (insert
- (format "Mime-Version: 1.0 (split by tm-comp %s)\n"
- mime/composer-version))
- (insert
- (format
- "Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n"
- id (+ i 1) total separator))
- (if (eq i 0)
- (insert orig-header))
- (insert data)
- (save-excursion
- (call-interactively command))
- (erase-buffer)
- (switch-to-buffer the-buf)
- (setq l (+ l mime/message-max-length))
- (setq i (+ i 1))
- )
- )
- (let ((hook
- (cdr (assq major-mode mime/message-after-send-hook-alist))))
- (run-hooks 'hook))
- (set-buffer-modified-p nil)
- (cond ((y-or-n-p "Kill draft buffer? ")
- (kill-buffer (current-buffer))
- (if config
- (set-window-configuration config))))
- (message "")
- ))))
-
-(defun tm-comp::mime-mode-exit-and-run ()
- (interactive)
- (mime-mode-exit)
- (call-interactively 'mime/split-and-send)
- )
-
-
-;;; @ set up
-;;;
-
-(add-hook 'mime-mode-hook
- (function
- (lambda ()
- (if (not (fboundp 'original::mime-insert-file))
- (progn
- (fset 'original::mime-insert-file
- (symbol-function 'mime-insert-file))
- (fset 'mime-insert-file 'tm-comp::mime-insert-file)
- ))
- (if (not (fboundp 'original::mime-insert-binary-file))
- (progn
- (fset 'original::mime-insert-binary-file
- (symbol-function 'mime-insert-binary-file))
- (fset 'mime-insert-binary-file
- 'tm-comp::mime-insert-binary-file)
- ))
- (if (not (fboundp 'original::mime-insert-binary-buffer))
- (progn
- (fset 'original::mime-insert-binary-buffer
- (symbol-function 'mime-insert-binary-buffer))
- (fset 'mime-insert-binary-buffer
- 'tm-comp::mime-insert-binary-buffer)
- ))
- (if (not (fboundp 'original::mime-mode-exit-and-run))
- (progn
- (fset 'original::mime-mode-exit-and-run
- (symbol-function 'mime-mode-exit-and-run))
- (fset 'mime-mode-exit-and-run
- 'tm-comp::mime-mode-exit-and-run)
- ))
- (define-key (lookup-key (current-local-map) mime-prefix)
- "m" 'tm-comp/insert-message)
- )))
-
-
-;;; @ draft preview
-;;;
-;; by "OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
-;; Mon, 10 Apr 1995 20:03:07 +0900
-
-(defvar mime/draft-header-separator-alist
- '((news-reply-mode . mail-header-separator)
- (mh-letter-mode . mail-header-separator)
- ))
-
-(defvar mime::article/draft-header-separator nil)
-
-(defun mime/draft-preview ()
- (interactive)
- (let ((sep (assoc-value major-mode mime/draft-header-separator-alist)))
- (or (stringp sep) (setq sep (eval sep)))
- (make-variable-buffer-local 'mime::article/draft-header-separator)
- (goto-char (point-min))
- (re-search-forward
- (concat "^\\(" (regexp-quote sep) "\\)?$"))
- (setq mime::article/draft-header-separator
- (buffer-substring (match-beginning 0) (match-end 0)))
- (replace-match "")
- (mime/viewer-mode (current-buffer))
- (pop-to-buffer (current-buffer))
- ))
-
-(defun mime-viewer::quitting-method/draft-preview ()
- (let ((mother mime/mother-buffer))
- (save-excursion
- (switch-to-buffer mother)
- (goto-char (point-min))
- (if (and
- (re-search-forward
- (concat "^\\("
- (regexp-quote mime::article/draft-header-separator)
- "\\)?$") nil t)
- (bolp))
- (progn
- (insert mime::article/draft-header-separator)
- (set-buffer-modified-p (buffer-modified-p))
- )))
- (mime-viewer/kill-buffer)
- (pop-to-buffer mother)
- ))
-
-(set-alist 'mime-viewer/quitting-method-alist
- 'mh-letter-mode
- (function mime-viewer::quitting-method/draft-preview)
- )
-
-(set-alist 'mime-viewer/quitting-method-alist
- 'news-reply-mode
- (function mime-viewer::quitting-method/draft-preview)
- )
-
-
-;;; @ etc
-;;;
-
-(defun rfc822/get-header-string-except (pat boundary)
- (let ((case-fold-search t))
- (save-excursion
- (save-restriction
- (narrow-to-region (goto-char (point-min))
- (progn
- (re-search-forward
- (concat "^\\(" (regexp-quote boundary) "\\)?$")
- nil t)
- (match-beginning 0)
- ))
- (goto-char (point-min))
- (let (field header)
- (while (re-search-forward rfc822/field-top-regexp nil t)
- (setq field (buffer-substring (match-beginning 0)
- (rfc822/field-end)
- ))
- (if (not (string-match pat field))
- (setq header (concat header field "\n"))
- ))
- header)
- ))))
-
-(defun replace-space-with-underline (str)
- (mapconcat (function
- (lambda (arg)
- (char-to-string
- (if (= arg 32)
- ?_
- arg)))) str "")
- )
-
-
-;;; @ end
-;;;
-
-(provide 'tm-comp)
-
-(run-hooks 'tm-comp-load-hook)
projects / elisp / tm.git / blobdiff