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