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