tm-comp.el

   1 ;;;
   2 ;;; $Id: tm-comp.el,v 1.1 1994/08/21 22:00:44 morioka Exp morioka $
   3 ;;;
   4
   5 (provide 'tm-comp)
   6
   7 (defvar mime/message-max-length 1000)
   8 (defvar mime/message-sender-alist
   9   '((mail-mode . sendmail-send-it)
  10     (mh-letter-mode . (lambda ()
  11                         (write-region (point-min) (point-max)
  12                                       mime/draft-file-name)
  13                         (call-process
  14                          (expand-file-name mh-send-prog mh-progs)
  15                          nil nil nil mime/draft-file-name)
  16                         ))
  17     (news-reply-mode . gnus-inews-article)
  18     ))
  19 (defvar mime/window-config-alist
  20   '((mail-mode       . nil)
  21     (mh-letter-mode  . mh-previous-window-config)
  22     (news-reply-mode . (prog1
  23                            gnus-winconf-post-news
  24                          (setq gnus-winconf-post-news nil)
  25                          ))
  26     ))
  27
  28 (defun mime/split-and-send (&optional cmd)
  29   (interactive)
  30   (if (null cmd)
  31       (setq cmd (cdr (assq major-mode mime/message-sender-alist)))
  32     )
  33   (let ((mime/draft-file-name (buffer-file-name))
  34         (lines (count-lines (point-min)(point-max)))
  35         (separator mail-header-separator)
  36         (config (eval (cdr (assq major-mode mime/window-config-alist))))
  37         )
  38     (if (null mime/draft-file-name)
  39         (setq mime/draft-file-name "/tmp/tm-draft")
  40       )
  41     (mime-mode-exit)
  42     (if (<= lines mime/message-max-length)
  43         (funcall cmd)
  44       (let ((header (message/get-header-string-except
  45                      "^Content-" separator))
  46             (id (concat "\""
  47                         (replace-space-with-underline (current-time-string))
  48                         "@" (system-name) "\""))
  49             )
  50         (goto-char (point-min))
  51         (if (re-search-forward (concat "^" (regexp-quote separator) "$")
  52                                nil t)
  53             (replace-match "")
  54           )
  55         (let* ((total (+ (/ lines mime/message-max-length)
  56                          (if (> (mod lines mime/message-max-length) 0)
  57                              1)))
  58                (i 0)(l mime/message-max-length)
  59                (the-buf (current-buffer))
  60                (buf (get-buffer "*tmp-send*"))
  61                data)
  62           (if buf
  63               (progn
  64                 (switch-to-buffer buf)
  65                 (erase-buffer)
  66                 (switch-to-buffer the-buf)
  67                 )
  68             (setq buf (get-buffer-create "*tmp-send*"))
  69             )
  70           (switch-to-buffer buf)
  71           (make-variable-buffer-local 'mail-header-separator)
  72           (setq mail-header-separator separator)
  73           (switch-to-buffer the-buf)
  74           (goto-char (point-min))
  75           (while (< i total)
  76             (setq buf (get-buffer "*tmp-send*"))
  77
  78             (setq data (buffer-substring
  79                         (point)
  80                         (progn
  81                           (goto-line l)
  82                           (point))
  83                         ))
  84             (switch-to-buffer buf)
  85             (insert header)
  86             (insert
  87              (format
  88               "Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n"
  89               id (+ i 1) total separator))
  90             (insert data)
  91             (funcall cmd)
  92             (erase-buffer)
  93             (switch-to-buffer the-buf)
  94             (setq l (+ l mime/message-max-length))
  95             (setq i (+ i 1))
  96             )
  97           )))
  98     (set-buffer-modified-p nil)
  99     (kill-buffer (current-buffer))
 100     (if config
 101         (set-window-configuration config)
 102       )
 103     ))
 104
 105 (add-hook 'mime-mode-hook
 106           (function
 107            (lambda ()
 108              (if (not (fboundp 'default-mime-mode-exit-and-run))
 109                  (progn
 110                    (make-variable-buffer-local 'mime/send-message-method)
 111                    (fset 'default-mime-mode-exit-and-run
 112                          'mime-mode-exit-and-run)
 113                    (fset 'mime-mode-exit-and-run
 114                          'mime/split-and-send)
 115                    )))))
 116
 117 (defun message/get-header-string-except (pat boundary)
 118   (save-excursion
 119     (save-restriction
 120       (narrow-to-region (goto-char (point-min))
 121                         (progn
 122                           (re-search-forward boundary nil t)
 123                           (match-beginning 0)
 124                           ))
 125       (goto-char (point-min))
 126       (let (field header)
 127         (while (re-search-forward message/field-regexp nil t)
 128           (setq field (buffer-substring (match-beginning 0)
 129                                         (match-end 0)
 130                                         ))
 131           (if (not (string-match pat field))
 132               (setq header (concat header field "\n"))
 133             ))
 134         header)
 135       )))
 136
 137 (defun replace-space-with-underline (str)
 138   (mapconcat (function
 139               (lambda (arg)
 140                 (char-to-string
 141                  (if (= arg 32)
 142                      ?_
 143                    arg)))) str "")
 144   )