X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=tm-comp.el;h=8ff815cf0edd9873a16fceedee8e0fd9c085624a;hb=c6b287dbd7789726678fcdc1ec497bdda703e8a6;hp=9749f8a9cdd116c0a58428dbf11a6ef543ae4928;hpb=137966958dfb743089532a2cd91ed113f56b5f8f;p=elisp%2Ftm.git diff --git a/tm-comp.el b/tm-comp.el index 9749f8a..8ff815c 100644 --- a/tm-comp.el +++ b/tm-comp.el @@ -1,71 +1,287 @@ ;;; -;;; $Id: tm-comp.el,v 1.2 1994/09/26 12:37:03 morioka Exp $ +;;; 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 , +;;; OKABE Yasuo +;;; modified by MORITA Masahiro +;;; Kazushi (Jam) MARUKAWA , +;;; KOBAYASHI Shuhei , +;;; YAMAOKA Katsumi , +;;; and Richard Stanton +;;; Keywords: mail, news, MIME, multimedia +;;; +;;; This file is part of tm (Tools for MIME). ;;; -(provide 'tm-comp) -(require 'tl-header) +(require 'tm-view) +(require 'tl-822) +(require 'tl-list) (require 'mail-utils) -(defvar mime/tmp-dir (or (getenv "TM_TMPDIR") "/tmp/")) -(defvar mime/message-max-length 1000) +;;; @ 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 . sendmail-send-it) - (mh-letter-mode . (lambda () - (write-region (point-min) (point-max) + '((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) - (call-process - (expand-file-name mh-send-prog mh-progs) - nil nil nil mime/draft-file-name) - )) - (news-reply-mode . gnus-inews-article) + (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 . (prog1 - gnus-winconf-post-news - (setq gnus-winconf-post-news nil) - )) + (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 +;; 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 +;; 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) - (if (null cmd) - (setq cmd (cdr (assq major-mode mime/message-sender-alist))) - ) - (let ((mime/draft-file-name (buffer-file-name)) - (lines (count-lines (point-min)(point-max))) - (separator mail-header-separator) - (config (eval (cdr (assq major-mode mime/window-config-alist)))) + (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 (null mime/draft-file-name) - (setq mime/draft-file-name - (make-temp-name (expand-file-name "tm-draft" mime/tmp-dir))) - ) - (if (and (boundp 'mime-mode-flag) mime-mode-flag) - (mime-mode-exit)) (if (<= lines mime/message-max-length) - (funcall cmd) - (let ((header (message/get-header-string-except - "\\(^[Cc]ontent-\\|^[Ss]ubject:\\)" separator)) - (subject (mail-fetch-field "subject")) - (id (concat "\"" - (replace-space-with-underline (current-time-string)) - "@" (system-name) "\"")) - ) - (goto-char (point-min)) - (if (re-search-forward (concat "^" (regexp-quote separator) "$") - nil t) - (replace-match "") - ) - (let* ((total (+ (/ 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) + (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) @@ -79,9 +295,9 @@ (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 @@ -93,57 +309,161 @@ (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) - (funcall cmd) + (save-excursion + (call-interactively command)) (erase-buffer) (switch-to-buffer the-buf) (setq l (+ l mime/message-max-length)) (setq i (+ i 1)) ) - ))) - (set-buffer-modified-p nil) - (kill-buffer (current-buffer)) - (if config - (set-window-configuration config) - ) - )) + ) + (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 'default-mime-mode-exit-and-run)) + (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 - (make-variable-buffer-local 'mime/send-message-method) - (fset 'default-mime-mode-exit-and-run - 'mime-mode-exit-and-run) + (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 - 'mime/split-and-send) - ))))) + 'tm-comp::mime-mode-exit-and-run) + )) + (define-key (lookup-key (current-local-map) mime-prefix) + "m" 'tm-comp/insert-message) + ))) -(defun message/get-header-string-except (pat boundary) - (save-excursion - (save-restriction - (narrow-to-region (goto-char (point-min)) - (progn - (re-search-forward - (concat "^\\(" (regexp-quote boundary) "\\)?$") - nil t) - (match-beginning 0) - )) + +;;; @ draft preview +;;; +;; by "OKABE Yasuo +;; 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)) - (let (field header) - (while (re-search-forward message/field-regexp nil t) - (setq field (buffer-substring (match-beginning 0) - (match-end 0) - )) - (if (not (string-match pat field)) - (setq header (concat header field "\n")) - )) - header) - ))) + (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 @@ -153,3 +473,11 @@ ?_ arg)))) str "") ) + + +;;; @ end +;;; + +(provide 'tm-comp) + +(run-hooks 'tm-comp-load-hook)