tm-comp.el

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