tm-comp.el

   1 ;;;
   2 ;;; tm-comp.el: attachment for MIME composer
   3 ;;;
   4 ;;; by  MORIOKA Tomohiko <morioka@jaist.ac.jp>
   5 ;;; and   OKABE Yasuo    <okabe@kudpc.kyoto-u.ac.jp>
   6 ;;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
   7 ;;;         and MORIOKA Tomohiko
   8 ;;;
   9
  10 (provide 'tm-comp)
  11 (require 'tm-misc)
  12 (require 'tl-header)
  13 (require 'mail-utils)
  14
  15
  16 ;;; @ version
  17 ;;;
  18
  19 (defconst mime/composer-RCS-ID
  20   "$Id: tm-comp.el,v 3.3 1994/12/16 12:54:23 morioka Exp $")
  21
  22 (defconst mime/composer-version (get-version-string mime/composer-RCS-ID))
  23
  24
  25 ;;; @ variables
  26 ;;;
  27
  28 (defvar mime/message-default-max-length 1000)
  29
  30 (defvar mime/message-max-length-alist
  31   '((news-reply-mode . 500)))
  32
  33 (defconst mime/message-nuke-headers
  34   "\\(^[Cc]ontent-\\|^[Ss]ubject:\\|^[Mm][Ii][Mm][Ee]-[Vv]ersion:\\)")
  35 (defvar mime/message-blind-headers
  36   "\\(^[BDFbdf][Cc][Cc]:\\|^[Cc][Cc]:[ \t]*$\\)")
  37
  38 (defvar mime/message-default-sender-alist
  39   '((mail-mode . mail-send-and-exit)
  40     (mh-letter-mode . mh-send-letter)
  41     (news-reply-mode . gnus-inews-news)))
  42
  43 (defvar mime/message-sender-alist
  44   '((mail-mode  . (lambda ()
  45                     (interactive)
  46                     (sendmail-send-it)
  47                     ))
  48     (mh-letter-mode . (lambda (&optional arg)
  49                         (interactive "P")
  50                         (write-region (point-min) (point-max)
  51                                       mime/draft-file-name)
  52                         (message
  53                           (format "Sending %d/%d..." (+ i 1) total))
  54                         (cond (arg
  55                                (pop-to-buffer "MH mail delivery")
  56                                (erase-buffer)
  57                                (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush"
  58                                                    "-nodraftfolder" mh-send-args mime/draft-file-name)
  59                                (goto-char (point-max))  ; show the interesting part
  60                                (recenter -1)
  61                                (sit-for 1))
  62                               (t
  63                                (apply 'mh-exec-cmd-quiet t mh-send-prog
  64                                       (mh-list-to-string
  65                                        (list "-nopush" "-nodraftfolder" "-noverbose" "-nowatch" mh-send-args mime/draft-file-name)))))
  66                         (message
  67                           (format "Sending %d/%d... done" (+ i 1) total))
  68                               ))
  69     (news-reply-mode . (lambda ()
  70                          (interactive)
  71                          (widen)
  72                          (goto-char (point-min))
  73                          (save-restriction
  74                            (narrow-to-region
  75                             (point-min)
  76                             (progn
  77                               (goto-char (point-min))
  78                               (search-forward (concat "\n" mail-header-separator "\n"))
  79                               (point)))
  80                            ;; Mail the message too if To: or Cc: exists.
  81                            (if (or (mail-fetch-field "to" nil t)
  82                                    (mail-fetch-field "cc" nil t))
  83                                (if gnus-mail-send-method
  84                                    (progn
  85                                      (message
  86                                       (format "Sending (%d/%d) via mail..." (+ i 1) total))
  87                                      (widen)
  88                                      (funcall gnus-mail-send-method)
  89                                      (message
  90                                       (format "Sending (%d/%d) via mail... done" (+ i 1) total))
  91                                  (ding)
  92                                  (message "No mailer defined.  To: and/or Cc: fields ignored.")
  93                                  (sit-for 1)))))
  94                          (message
  95                           (format "Posting %d/%d to USENET..." (+ i 1) total))
  96                          (if (gnus-inews-article)
  97                              (message
  98                               (format "Posting %d/%d to USENET... done" (+ i 1) total))
  99                            ;; We cannot signal an error.
 100                            (ding)
 101                            (message
 102                             (format "Article %d/%d rejected: %s" (+ i 1) total (gnus-status-message)))
 103                            (sit-for 3))
 104                            ))
 105     ))
 106
 107
 108 (defvar mime/window-config-alist
 109   '((mail-mode       . nil)
 110     (mh-letter-mode  . mh-previous-window-config)
 111     (news-reply-mode . (prog1
 112                            gnus-winconf-post-news
 113                          (setq gnus-winconf-post-news nil)
 114                          ))
 115     ))
 116
 117 (defvar mime/news-reply-mode-server-running nil)
 118
 119 (defvar mime/message-before-send-hook-alist
 120   '((mh-letter-mode  . mh-before-send-letter-hook))
 121     (news-reply-mode . '(lambda ()
 122                           (let ((case-fold-search nil))
 123                             (or (boundp 'mime/news-reply-mode-server-running)
 124                                 (make-variable-buffer-local 'mime/news-reply-mode-server-running))
 125                             (setq mime/news-reply-mode-server-running (gnus-server-opened))
 126                             (save-excursion
 127                               (gnus-start-server-process)
 128                               (widen)
 129                               (goto-char (point-min))
 130                               (run-hooks 'news-inews-hook)
 131                               (save-restriction
 132                                 (narrow-to-region
 133                                  (point-min)
 134                                  (progn
 135                                    (goto-char (point-min))
 136                                    (search-forward (concat "\n" mail-header-separator "\n"))
 137                                    (point)))
 138
 139                                 (goto-char (point-min))
 140                                 (if (search-forward-regexp "^Newsgroups: +" nil t)
 141                                     (save-restriction
 142                                       (narrow-to-region
 143                                        (point)
 144                                        (if (re-search-forward "^[^ \t]" nil 'end)
 145                                            (match-beginning 0)
 146                                          (point-max)))
 147                                       (goto-char (point-min))
 148                                       (replace-regexp "\n[ \t]+" " ")
 149                                       (goto-char (point-min))
 150                                       (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",")
 151                                       ))
 152                                 ))))
 153                      ))
 154
 155 (defvar mime/message-after-send-hook-alist
 156   '((mh-letter-mode  . '(lambda ()
 157                          (if mh-annotate-char
 158                              (mh-annotate-msg mh-sent-from-msg
 159                                               mh-sent-from-folder
 160                                               mh-annotate-char
 161                                               "-component" mh-annotate-field
 162                                               "-text"
 163                                               (format "\"%s %s\""
 164                                                       (mh-get-field "To:")
 165                                                       (mh-get-field "Cc:"))))))
 166     (news-reply-mode . '(lambda ()
 167                           (or mime/news-reply-mode-server-running
 168                               (gnus-close-server))
 169                           (and (fboundp 'bury-buffer) (bury-buffer))))
 170     ))
 171
 172
 173 ;;; @ edit
 174 ;;;
 175
 176 ;; Insert the binary content after MIME tag.
 177 ;;      modified by MORITA Masahiro <hiro@isl.ntt.JP>
 178 ;;      for x-uue
 179 (defun tm-comp::mime-insert-binary-file (file &optional encoding)
 180   "Insert binary FILE at point.
 181 Optional argument ENCODING specifies an encoding method such as base64."
 182   (let ((tmpbuf (get-buffer-create " *MIME insert*")))
 183     (save-excursion
 184       (set-buffer tmpbuf)
 185       (erase-buffer)
 186       (let ((mc-flag nil)               ;Mule
 187             (file-coding-system-for-read
 188              (if (featurep 'mule) *noconv*))
 189             (kanji-flag nil))           ;NEmacs
 190         (insert-file-contents file)))
 191     (prog1
 192         (if (string-equal (downcase encoding) "x-uue")
 193             (let ((mime-transfer-encoders
 194                    (copy-alist (cons (list "x-uue" "uuencode"
 195                                            (file-name-nondirectory file))
 196                                      mime-transfer-encoders))))
 197               (mime-insert-binary-buffer tmpbuf encoding))
 198           (mime-insert-binary-buffer tmpbuf encoding))
 199       (kill-buffer tmpbuf))))
 200
 201 ;; Insert the binary content after MIME tag.
 202 ;;      modified by MORITA Masahiro <hiro@isl.ntt.JP>
 203 ;;      for x-uue
 204 (defun tm-comp::mime-insert-binary-buffer (buffer &optional encoding)
 205   "Insert binary BUFFER at point.
 206 Optional argument ENCODING specifies an encoding method such as base64."
 207   (let* ((tagend (1- (point)))          ;End of the tag
 208          (hide-p (and mime-auto-hide-body
 209                       (stringp encoding)
 210                       (let ((en (downcase encoding)))
 211                         (or (string-equal en "base64")
 212                             (string-equal en "x-uue")
 213                             ))))
 214          )
 215     (save-restriction
 216       (narrow-to-region (1- (point)) (point))
 217       (let ((start (point)))
 218         (insert-buffer-substring buffer)
 219         ;; Encode binary message if necessary.
 220         (if encoding
 221             (mime-encode-region encoding start (point-max))))
 222       (if hide-p
 223           (progn
 224             (mime-flag-region (point-min) (1- (point-max)) ?\^M)
 225             (goto-char (point-max)))
 226         ))
 227     ;; Define encoding even if it is 7bit.
 228     (if (stringp encoding)
 229         (save-excursion
 230           (goto-char tagend)            ;Make sure which line the tag is on.
 231           (mime-define-encoding encoding)))
 232     ))
 233
 234
 235 ;;; @ split
 236 ;;;
 237
 238 (defun mime/split-and-send (&optional cmd)
 239   (interactive)
 240   (let ((mime/message-max-length
 241          (or (cdr (assq major-mode mime/message-max-length-alist))
 242              mime/message-default-max-length))
 243         (lines (count-lines (point-min) (point-max)))
 244         )
 245     (if (<= lines mime/message-max-length)
 246         (call-interactively
 247          (or cmd (cdr (assq major-mode mime/message-default-sender-alist))))
 248       (let* ((mime/draft-file-name
 249               (or (buffer-file-name)
 250                   (make-temp-name (expand-file-name "tm-draft" mime/tmp-dir))))
 251              (separator mail-header-separator)
 252              (config (eval (cdr (assq major-mode mime/window-config-alist))))
 253              (id (concat "\""
 254                          (replace-space-with-underline (current-time-string))
 255                          "@" (system-name) "\"")))
 256
 257         (let ((hook (eval (cdr (assq major-mode mime/message-before-send-hook-alist)))))
 258           (run-hooks 'hook))
 259         (let* ((header (message/get-header-string-except
 260                       mime/message-nuke-headers separator))
 261                (orig-header (message/get-header-string-except
 262                              mime/message-blind-headers separator))
 263                (subject (mail-fetch-field "subject"))
 264                (total (+ (/ lines mime/message-max-length)
 265                          (if (> (mod lines mime/message-max-length) 0)
 266                              1)))
 267                (i 0)
 268                (l mime/message-max-length)
 269                (the-buf (current-buffer))
 270                (buf (get-buffer "*tmp-send*"))
 271                (command
 272                 (or cmd
 273                  (cdr (assq major-mode mime/message-sender-alist))
 274                  (cdr (assq major-mode mime/message-default-sender-alist))))
 275                data)
 276           (goto-char (point-min))
 277           (if (re-search-forward (concat "^" (regexp-quote separator) "$")
 278                                  nil t)
 279               (replace-match "")
 280             )
 281           (if buf
 282               (progn
 283                 (switch-to-buffer buf)
 284                 (erase-buffer)
 285                 (switch-to-buffer the-buf)
 286                 )
 287             (setq buf (get-buffer-create "*tmp-send*"))
 288             )
 289           (switch-to-buffer buf)
 290           (make-variable-buffer-local 'mail-header-separator)
 291           (setq mail-header-separator separator)
 292           (switch-to-buffer the-buf)
 293           (goto-char (point-min))
 294           (re-search-forward "^$" nil t)
 295           (while (< i total)
 296             (setq buf (get-buffer "*tmp-send*"))
 297             (setq data (buffer-substring
 298                         (point)
 299                         (progn
 300                           (goto-line l)
 301                           (point))
 302                         ))
 303             (switch-to-buffer buf)
 304             (insert header)
 305             (insert
 306              (format "Subject: %s (%d/%d)\n" subject (+ i 1) total))
 307             (insert
 308              (format "Mime-Version: 1.0\n"))
 309             (insert
 310              (format
 311               "Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n"
 312               id (+ i 1) total separator))
 313             (if (eq i 0)
 314                 (insert orig-header))
 315             (insert data)
 316             (save-excursion
 317               (call-interactively command))
 318             (erase-buffer)
 319             (switch-to-buffer the-buf)
 320             (setq l (+ l mime/message-max-length))
 321             (setq i (+ i 1))
 322             )
 323           )
 324         (let ((hook (eval (cdr (assq major-mode mime/message-after-send-hook-alist)))))
 325           (run-hooks 'hook))
 326         (set-buffer-modified-p nil)
 327         (cond ((y-or-n-p "Kill draft buffer? ")
 328                (kill-buffer (current-buffer))
 329                (if config
 330                    (set-window-configuration config))))
 331         (message "")
 332         ))))
 333
 334 (defun tm-comp::mime-mode-exit-and-run ()
 335   (interactive)
 336   (mime-mode-exit)
 337   (call-interactively 'mime/split-and-send)
 338   )
 339
 340
 341 ;;; @ set up
 342 ;;;
 343
 344 (add-hook 'mime-mode-hook
 345           (function
 346            (lambda ()
 347              (if (not (fboundp 'original::mime-insert-binary-file))
 348                  (progn
 349                    (fset 'original::mime-insert-binary-file
 350                          (symbol-function 'mime-insert-binary-file))
 351                    (fset 'mime-insert-binary-file
 352                          'tm-comp::mime-insert-binary-file)
 353                    ))
 354              (if (not (fboundp 'original::mime-insert-binary-buffer))
 355                  (progn
 356                    (fset 'original::mime-insert-binary-buffer
 357                          (symbol-function 'mime-insert-binary-buffer))
 358                    (fset 'mime-insert-binary-buffer
 359                          'tm-comp::mime-insert-binary-buffer)
 360                    ))
 361              (if (not (fboundp 'original::mime-mode-exit-and-run))
 362                  (progn
 363                    (fset 'original::mime-mode-exit-and-run
 364                          (symbol-function 'mime-mode-exit-and-run))
 365                    (fset 'mime-mode-exit-and-run
 366                          'tm-comp::mime-mode-exit-and-run)
 367                    ))
 368              )))
 369
 370 (autoload 'mime/viewer-mode "tm-view" nil t)
 371
 372 (defun mime/draft-preview ()
 373   (interactive)
 374   (goto-char (point-min))
 375   (mime/viewer-mode)
 376   (pop-to-buffer (current-buffer)))
 377
 378 (defun message/get-header-string-except (pat boundary)
 379   (save-excursion
 380     (save-restriction
 381       (narrow-to-region (goto-char (point-min))
 382                         (progn
 383                           (re-search-forward
 384                            (concat "^\\(" (regexp-quote boundary) "\\)?$")
 385                            nil t)
 386                           (match-beginning 0)
 387                           ))
 388       (goto-char (point-min))
 389       (let (field header)
 390         (while (re-search-forward message/field-regexp nil t)
 391           (setq field (buffer-substring (match-beginning 0)
 392                                         (match-end 0)
 393                                         ))
 394           (if (not (string-match pat field))
 395               (setq header (concat header field "\n"))
 396             ))
 397         header)
 398       )))
 399
 400 (defun replace-space-with-underline (str)
 401   (mapconcat (function
 402               (lambda (arg)
 403                 (char-to-string
 404                  (if (= arg 32)
 405                      ?_
 406                    arg)))) str "")
 407   )