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