X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=tm-comp.el;h=8ff815cf0edd9873a16fceedee8e0fd9c085624a;hb=a7110eca79a127b0b627934466375dbf9d49d9a0;hp=a1157cb21b21e0ad16dac4747e0ac02dd47c96d0;hpb=512f3ae410a64c797aee755730d693750b232e6c;p=elisp%2Ftm.git diff --git a/tm-comp.el b/tm-comp.el index a1157cb..8ff815c 100644 --- a/tm-comp.el +++ b/tm-comp.el @@ -1,19 +1,24 @@ ;;; -;;; tm-comp.el: attachment for MIME composer +;;; tm-comp.el --- attachment for MIME composer ;;; -;;; by MORIOKA Tomohiko -;;; and OKABE Yasuo -;;; modified by MORITA Masahiro -;;; MORIOKA Tomohiko, -;;; Kazushi (Jam) MARUKAWA , -;;; OKABE Yasuo, -;;; KOBAYASHI Shuhei , -;;; and YAMAOKA Katsumi +;;; 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). ;;; -(require 'tm-misc) (require 'tm-view) -(require 'tl-header) +(require 'tl-822) (require 'tl-list) (require 'mail-utils) @@ -22,7 +27,7 @@ ;;; (defconst mime/composer-RCS-ID - "$Id: tm-comp.el,v 6.7 1995/06/12 05:33:22 morioka Exp $") + "$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)) @@ -36,9 +41,8 @@ '((news-reply-mode . 500))) (defconst mime/message-nuke-headers - "\\(^[Cc]ontent-\\|^[Ss]ubject:\\|^[Mm][Ii][Mm][Ee]-[Vv]ersion:\\)") -(defvar mime/message-blind-headers - "\\(^[BDFbdf][Cc][Cc]:\\|^[Cc][Cc]:[ \t]*$\\)") + "\\(^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) @@ -71,44 +75,8 @@ (message (format "Sending %d/%d... done" (+ i 1) total)) )) - (news-reply-mode . (lambda () - (interactive) - (widen) - (goto-char (point-min)) - (save-restriction - (narrow-to-region - (point-min) - (progn - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n")) - (point))) - ;; Mail the message too if To: or Cc: exists. - (if (or (mail-fetch-field "to" nil t) - (mail-fetch-field "cc" nil t)) - (if gnus-mail-send-method - (progn - (message - (format "Sending (%d/%d) via mail..." (+ i 1) total)) - (widen) - (funcall gnus-mail-send-method) - (message - (format "Sending (%d/%d) via mail... done" (+ i 1) total)) - (ding) - (message "No mailer defined. To: and/or Cc: fields ignored.") - (sit-for 1))))) - (message - (format "Posting %d/%d to USENET..." (+ i 1) total)) - (if (gnus-inews-article) - (message - (format "Posting %d/%d to USENET... done" (+ i 1) total)) - ;; We cannot signal an error. - (ding) - (message - (format "Article %d/%d rejected: %s" (+ i 1) total (gnus-status-message))) - (sit-for 3)) - )) )) - + (defvar mime/window-config-alist '((mail-mode . nil) @@ -128,46 +96,12 @@ (defvar mime/news-reply-mode-server-running nil) -(defun tm-gnus4/message-before-send () - (let ((case-fold-search nil)) - (or (boundp 'mime/news-reply-mode-server-running) - (make-variable-buffer-local 'mime/news-reply-mode-server-running)) - (setq mime/news-reply-mode-server-running (gnus-server-opened)) - (save-excursion - (gnus-start-news-server) - (widen) - (goto-char (point-min)) - (run-hooks 'news-inews-hook) - (save-restriction - (narrow-to-region - (point-min) - (progn - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n")) - (point))) - - (goto-char (point-min)) - (if (search-forward-regexp "^Newsgroups: +" nil t) - (save-restriction - (narrow-to-region - (point) - (if (re-search-forward "^[^ \t]" nil 'end) - (match-beginning 0) - (point-max))) - (goto-char (point-min)) - (replace-regexp "\n[ \t]+" " ") - (goto-char (point-min)) - (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",") - )) - )))) (defvar mime/message-before-send-hook-alist - '((mh-letter-mode . mh-before-send-letter-hook) - (news-reply-mode . tm-gnus4/message-before-send) - )) + '((mh-letter-mode . mh-before-send-letter-hook))) (defvar mime/message-after-send-hook-alist - '((mh-letter-mode . '(lambda () + '((mh-letter-mode . (lambda () (if mh-annotate-char (mh-annotate-msg mh-sent-from-msg mh-sent-from-folder @@ -177,10 +111,6 @@ (format "\"%s %s\"" (mh-get-field "To:") (mh-get-field "Cc:")))))) - (news-reply-mode . '(lambda () - (or mime/news-reply-mode-server-running - (gnus-close-server)) - (and (fboundp 'bury-buffer) (bury-buffer)))) )) (defvar tm-comp/message-inserter-alist nil) @@ -189,6 +119,45 @@ ;;; @ 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 @@ -202,7 +171,9 @@ Optional argument ENCODING specifies an encoding method such as base64." (let ((mc-flag nil) ;Mule (file-coding-system-for-read (if (featurep 'mule) *noconv*)) - (kanji-flag nil)) ;NEmacs + (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)))) @@ -233,7 +204,8 @@ Optional argument ENCODING specifies an encoding method such as base64." ) (save-restriction (narrow-to-region (1- (point)) (point)) - (let ((start (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 @@ -288,9 +260,9 @@ Optional argument ENCODING specifies an encoding method such as base64." (let ((hook (cdr (assq major-mode mime/message-before-send-hook-alist)))) (run-hooks hook)) - (let* ((header (message/get-header-string-except - mime/message-nuke-headers separator)) - (orig-header (message/get-header-string-except + (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) @@ -337,7 +309,8 @@ Optional argument ENCODING specifies an encoding method such as base64." (insert (format "Subject: %s (%d/%d)\n" subject (+ i 1) total)) (insert - (format "Mime-Version: 1.0\n")) + (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" @@ -353,7 +326,8 @@ Optional argument ENCODING specifies an encoding method such as base64." (setq i (+ i 1)) ) ) - (let ((hook (eval (cdr (assq major-mode mime/message-after-send-hook-alist))))) + (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? ") @@ -376,6 +350,12 @@ Optional argument ENCODING specifies an encoding method such as base64." (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 @@ -462,27 +442,28 @@ Optional argument ENCODING specifies an encoding method such as base64." ;;; @ etc ;;; -(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) - )) - (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) - ))) +(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 @@ -494,6 +475,9 @@ Optional argument ENCODING specifies an encoding method such as base64." ) -(run-hooks 'tm-comp-load-hook) +;;; @ end +;;; (provide 'tm-comp) + +(run-hooks 'tm-comp-load-hook)