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.3 1995/04/18 16:38:42 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 . (prog1
 117                            gnus-winconf-post-news
 118                          (setq gnus-winconf-post-news nil)
 119                          ))
 120     ))
 121
 122 (defvar mime/news-reply-mode-server-running nil)
 123
 124 (defvar mime/message-before-send-hook-alist
 125   '((mh-letter-mode  . mh-before-send-letter-hook))
 126     (news-reply-mode . '(lambda ()
 127                           (let ((case-fold-search nil))
 128                             (or (boundp 'mime/news-reply-mode-server-running)
 129                                 (make-variable-buffer-local 'mime/news-reply-mode-server-running))
 130                             (setq mime/news-reply-mode-server-running (gnus-server-opened))
 131                             (save-excursion
 132                               (gnus-start-server-process)
 133                               (widen)
 134                               (goto-char (point-min))
 135                               (run-hooks 'news-inews-hook)
 136                               (save-restriction
 137                                 (narrow-to-region
 138                                  (point-min)
 139                                  (progn
 140                                    (goto-char (point-min))
 141                                    (search-forward (concat "\n" mail-header-separator "\n"))
 142                                    (point)))
 143
 144                                 (goto-char (point-min))
 145                                 (if (search-forward-regexp "^Newsgroups: +" nil t)
 146                                     (save-restriction
 147                                       (narrow-to-region
 148                                        (point)
 149                                        (if (re-search-forward "^[^ \t]" nil 'end)
 150                                            (match-beginning 0)
 151                                          (point-max)))
 152                                       (goto-char (point-min))
 153                                       (replace-regexp "\n[ \t]+" " ")
 154                                       (goto-char (point-min))
 155                                       (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",")
 156                                       ))
 157                                 ))))
 158                      ))
 159
 160 (defvar mime/message-after-send-hook-alist
 161   '((mh-letter-mode  . '(lambda ()
 162                          (if mh-annotate-char
 163                              (mh-annotate-msg mh-sent-from-msg
 164                                               mh-sent-from-folder
 165                                               mh-annotate-char
 166                                               "-component" mh-annotate-field
 167                                               "-text"
 168                                               (format "\"%s %s\""
 169                                                       (mh-get-field "To:")
 170                                                       (mh-get-field "Cc:"))))))
 171     (news-reply-mode . '(lambda ()
 172                           (or mime/news-reply-mode-server-running
 173                               (gnus-close-server))
 174                           (and (fboundp 'bury-buffer) (bury-buffer))))
 175     ))
 176
 177 (defvar tm-comp/message-inserter-alist nil)
 178
 179
 180 ;;; @ edit
 181 ;;;
 182
 183 ;; Insert the binary content after MIME tag.
 184 ;;      modified by MORITA Masahiro <hiro@isl.ntt.JP>
 185 ;;      for x-uue
 186 (defun tm-comp::mime-insert-binary-file (file &optional encoding)
 187   "Insert binary FILE at point.
 188 Optional argument ENCODING specifies an encoding method such as base64."
 189   (let ((tmpbuf (get-buffer-create " *MIME insert*")))
 190     (save-excursion
 191       (set-buffer tmpbuf)
 192       (erase-buffer)
 193       (let ((mc-flag nil)               ;Mule
 194             (file-coding-system-for-read
 195              (if (featurep 'mule) *noconv*))
 196             (kanji-flag nil))           ;NEmacs
 197         (let (jka-compr-compression-info-list
 198               jam-zcat-filename-list)
 199           (insert-file-contents file))))
 200     (prog1
 201         (if (and (stringp encoding)
 202                  (string-equal (downcase encoding) "x-uue"))
 203             (let ((mime-transfer-encoders
 204                    (copy-alist (cons (list "x-uue" "uuencode"
 205                                            (file-name-nondirectory file))
 206                                      mime-transfer-encoders))))
 207               (mime-insert-binary-buffer tmpbuf encoding))
 208           (mime-insert-binary-buffer tmpbuf encoding))
 209       (kill-buffer tmpbuf))))
 210
 211 ;; Insert the binary content after MIME tag.
 212 ;;      modified by MORITA Masahiro <hiro@isl.ntt.JP>
 213 ;;      for x-uue
 214 (defun tm-comp::mime-insert-binary-buffer (buffer &optional encoding)
 215   "Insert binary BUFFER at point.
 216 Optional argument ENCODING specifies an encoding method such as base64."
 217   (let* ((tagend (1- (point)))          ;End of the tag
 218          (hide-p (and mime-auto-hide-body
 219                       (stringp encoding)
 220                       (let ((en (downcase encoding)))
 221                         (or (string-equal en "base64")
 222                             (string-equal en "x-uue")
 223                             ))))
 224          )
 225     (save-restriction
 226       (narrow-to-region (1- (point)) (point))
 227       (let ((start (point)))
 228         (insert-buffer-substring buffer)
 229         ;; Encode binary message if necessary.
 230         (if encoding
 231             (mime-encode-region encoding start (point-max))))
 232       (if hide-p
 233           (progn
 234             (mime-flag-region (point-min) (1- (point-max)) ?\^M)
 235             (goto-char (point-max)))
 236         ))
 237     ;; Define encoding even if it is 7bit.
 238     (if (stringp encoding)
 239         (save-excursion
 240           (goto-char tagend)            ;Make sure which line the tag is on.
 241           (mime-define-encoding encoding)))
 242     ))
 243
 244
 245 (defun tm-comp/insert-message (&optional message)
 246   (interactive)
 247   (let ((inserter (assoc-value major-mode tm-comp/message-inserter-alist)))
 248     (if (and inserter (fboundp inserter))
 249         (progn
 250           (mime-insert-tag "message" "rfc822")
 251           (funcall inserter message)
 252           )
 253       (message "Sorry, I don't have message inserter for your MUA.")
 254       )))
 255
 256
 257 ;;; @ split
 258 ;;;
 259
 260 (defun mime/split-and-send (&optional cmd)
 261   (interactive)
 262   (let ((mime/message-max-length
 263          (or (cdr (assq major-mode mime/message-max-length-alist))
 264              mime/message-default-max-length))
 265         (lines (count-lines (point-min) (point-max)))
 266         )
 267     (if (<= lines mime/message-max-length)
 268         (call-interactively
 269          (or cmd (cdr (assq major-mode mime/message-default-sender-alist))))
 270       (let* ((mime/draft-file-name
 271               (or (buffer-file-name)
 272                   (make-temp-name (expand-file-name "tm-draft" mime/tmp-dir))))
 273              (separator mail-header-separator)
 274              (config (eval (cdr (assq major-mode mime/window-config-alist))))
 275              (id (concat "\""
 276                          (replace-space-with-underline (current-time-string))
 277                          "@" (system-name) "\"")))
 278
 279         (let ((hook (eval (cdr (assq major-mode mime/message-before-send-hook-alist)))))
 280           (run-hooks 'hook))
 281         (let* ((header (message/get-header-string-except
 282                       mime/message-nuke-headers separator))
 283                (orig-header (message/get-header-string-except
 284                              mime/message-blind-headers separator))
 285                (subject (mail-fetch-field "subject"))
 286                (total (+ (/ lines mime/message-max-length)
 287                          (if (> (mod lines mime/message-max-length) 0)
 288                              1)))
 289                (i 0)
 290                (l mime/message-max-length)
 291                (the-buf (current-buffer))
 292                (buf (get-buffer "*tmp-send*"))
 293                (command
 294                 (or cmd
 295                  (cdr (assq major-mode mime/message-sender-alist))
 296                  (cdr (assq major-mode mime/message-default-sender-alist))))
 297                data)
 298           (goto-char (point-min))
 299           (if (re-search-forward (concat "^" (regexp-quote separator) "$")
 300                                  nil t)
 301               (replace-match "")
 302             )
 303           (if buf
 304               (progn
 305                 (switch-to-buffer buf)
 306                 (erase-buffer)
 307                 (switch-to-buffer the-buf)
 308                 )
 309             (setq buf (get-buffer-create "*tmp-send*"))
 310             )
 311           (switch-to-buffer buf)
 312           (make-variable-buffer-local 'mail-header-separator)
 313           (setq mail-header-separator separator)
 314           (switch-to-buffer the-buf)
 315           (goto-char (point-min))
 316           (re-search-forward "^$" nil t)
 317           (while (< i total)
 318             (setq buf (get-buffer "*tmp-send*"))
 319             (setq data (buffer-substring
 320                         (point)
 321                         (progn
 322                           (goto-line l)
 323                           (point))
 324                         ))
 325             (switch-to-buffer buf)
 326             (insert header)
 327             (insert
 328              (format "Subject: %s (%d/%d)\n" subject (+ i 1) total))
 329             (insert
 330              (format "Mime-Version: 1.0\n"))
 331             (insert
 332              (format
 333               "Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n"
 334               id (+ i 1) total separator))
 335             (if (eq i 0)
 336                 (insert orig-header))
 337             (insert data)
 338             (save-excursion
 339               (call-interactively command))
 340             (erase-buffer)
 341             (switch-to-buffer the-buf)
 342             (setq l (+ l mime/message-max-length))
 343             (setq i (+ i 1))
 344             )
 345           )
 346         (let ((hook (eval (cdr (assq major-mode mime/message-after-send-hook-alist)))))
 347           (run-hooks 'hook))
 348         (set-buffer-modified-p nil)
 349         (cond ((y-or-n-p "Kill draft buffer? ")
 350                (kill-buffer (current-buffer))
 351                (if config
 352                    (set-window-configuration config))))
 353         (message "")
 354         ))))
 355
 356 (defun tm-comp::mime-mode-exit-and-run ()
 357   (interactive)
 358   (mime-mode-exit)
 359   (call-interactively 'mime/split-and-send)
 360   )
 361
 362
 363 ;;; @ set up
 364 ;;;
 365
 366 (add-hook 'mime-mode-hook
 367           (function
 368            (lambda ()
 369              (if (not (fboundp 'original::mime-insert-binary-file))
 370                  (progn
 371                    (fset 'original::mime-insert-binary-file
 372                          (symbol-function 'mime-insert-binary-file))
 373                    (fset 'mime-insert-binary-file
 374                          'tm-comp::mime-insert-binary-file)
 375                    ))
 376              (if (not (fboundp 'original::mime-insert-binary-buffer))
 377                  (progn
 378                    (fset 'original::mime-insert-binary-buffer
 379                          (symbol-function 'mime-insert-binary-buffer))
 380                    (fset 'mime-insert-binary-buffer
 381                          'tm-comp::mime-insert-binary-buffer)
 382                    ))
 383              (if (not (fboundp 'original::mime-mode-exit-and-run))
 384                  (progn
 385                    (fset 'original::mime-mode-exit-and-run
 386                          (symbol-function 'mime-mode-exit-and-run))
 387                    (fset 'mime-mode-exit-and-run
 388                          'tm-comp::mime-mode-exit-and-run)
 389                    ))
 390              (define-key (lookup-key (current-local-map) mime-prefix)
 391                "m" 'tm-comp/insert-message)
 392              )))
 393
 394
 395 ;;; @ draft preview
 396 ;;;
 397 ;; by "OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
 398 ;;       Mon, 10 Apr 1995 20:03:07 +0900
 399
 400 (defvar mime/draft-header-separator-alist
 401   '((news-reply-mode . mail-header-separator)
 402     (mh-letter-mode . mail-header-separator)
 403     ))
 404
 405 (defvar mime::article/draft-header-separator nil)
 406
 407 (defun mime/draft-preview ()
 408   (interactive)
 409   (let ((sep (assoc-value major-mode mime/draft-header-separator-alist)))
 410     (or (stringp sep) (setq sep (eval sep)))
 411     (make-variable-buffer-local 'mime::article/draft-header-separator)
 412     (goto-char (point-min))
 413     (re-search-forward
 414      (concat "^\\(" (regexp-quote sep) "\\)?$"))
 415     (setq mime::article/draft-header-separator
 416           (buffer-substring (match-beginning 0) (match-end 0)))
 417     (replace-match "")
 418     (mime/viewer-mode (current-buffer))
 419     (pop-to-buffer (current-buffer))
 420     ))
 421
 422 (defun mime-viewer::quitting-method/draft-preview ()
 423   (let ((mother mime/mother-buffer))
 424     (save-excursion
 425       (switch-to-buffer mother)
 426       (goto-char (point-min))
 427       (if (and
 428            (re-search-forward
 429             (concat "^\\("
 430                     (regexp-quote mime::article/draft-header-separator)
 431                     "\\)?$") nil t)
 432            (bolp))
 433           (progn
 434             (insert mime::article/draft-header-separator)
 435             (set-buffer-modified-p (buffer-modified-p))
 436             )))
 437     (mime-viewer/kill-buffer)
 438     (pop-to-buffer mother)
 439     ))
 440
 441 (set-alist 'mime-viewer/quitting-method-alist
 442            'mh-letter-mode
 443            (function mime-viewer::quitting-method/draft-preview)
 444            )
 445
 446 (set-alist 'mime-viewer/quitting-method-alist
 447            'news-reply-mode
 448            (function mime-viewer::quitting-method/draft-preview)
 449            )
 450
 451
 452 ;;; @ etc
 453 ;;;
 454
 455 (defun message/get-header-string-except (pat boundary)
 456   (save-excursion
 457     (save-restriction
 458       (narrow-to-region (goto-char (point-min))
 459                         (progn
 460                           (re-search-forward
 461                            (concat "^\\(" (regexp-quote boundary) "\\)?$")
 462                            nil t)
 463                           (match-beginning 0)
 464                           ))
 465       (goto-char (point-min))
 466       (let (field header)
 467         (while (re-search-forward message/field-regexp nil t)
 468           (setq field (buffer-substring (match-beginning 0)
 469                                         (match-end 0)
 470                                         ))
 471           (if (not (string-match pat field))
 472               (setq header (concat header field "\n"))
 473             ))
 474         header)
 475       )))
 476
 477 (defun replace-space-with-underline (str)
 478   (mapconcat (function
 479               (lambda (arg)
 480                 (char-to-string
 481                  (if (= arg 32)
 482                      ?_
 483                    arg)))) str "")
 484   )
 485
 486
 487 (run-hooks 'tm-comp-load-hook)
 488
 489 (provide 'tm-comp)