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