home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / NeXT / GnuSource / emacs-15.0.3 / lisp / sendmail.el < prev    next >
Lisp/Scheme  |  1990-07-19  |  16KB  |  453 lines
  1. ;; Mail sending commands for Emacs.
  2. ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is distributed in the hope that it will be useful,
  7. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  8. ;; accepts responsibility to anyone for the consequences of using it
  9. ;; or for whether it serves any particular purpose or works at all,
  10. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  11. ;; License for full details.
  12.  
  13. ;; Everyone is granted permission to copy, modify and redistribute
  14. ;; GNU Emacs, but only under the conditions described in the
  15. ;; GNU Emacs General Public License.   A copy of this license is
  16. ;; supposed to have been given to you along with GNU Emacs so you
  17. ;; can know your rights and responsibilities.  It should be in a
  18. ;; file named COPYING.  Among other things, the copyright notice
  19. ;; and this notice must be preserved on all copies.
  20.  
  21.  
  22. (provide 'sendmail)
  23.  
  24. ;(defconst mail-self-blind nil
  25. ;  "Non-nil means insert BCC to self in messages to be sent.
  26. ;This is done when the message is initialized,
  27. ;so you can remove or alter the BCC field to override the default.")
  28.  
  29. ;(defconst mail-interactive nil
  30. ;  "Non-nil means when sending a message wait for and display errors.
  31. ;nil means let mailer mail back a message to report errors.")
  32.  
  33. ;(defconst mail-yank-ignored-headers
  34. ;   "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^remailed\\|^received:\\|^message-id:\\|^summary-line:\\|^to:\\|^subject:\\|^in-reply-to:\\|^return-path:"
  35. ;   "Delete these headers from old message when it's inserted in a reply.")
  36. ;(defvar send-mail-function 'sendmail-send-it
  37. ;  "Function to call to send the current buffer as mail.
  38. ;The headers are be delimited by a line which is mail-header-separator"")
  39.  
  40. ; really defined in loaddefs for emacs 17.17+
  41. ;(defvar mail-header-separator "--text follows this line--"
  42. ;  "*Line used to separate headers from text in messages being composed.")
  43. ; really defined in loaddefs for emacs 17.17+
  44. ;(defvar mail-archive-file-name nil
  45. ;  "*Name of file to write all outgoing messages in, or nil for none.")
  46. ; really defined in loaddefs for emacs 17.17+
  47. (defvar mail-aliases t
  48.   "Alias of mail address aliases,
  49. or t meaning should be initialized from .mailrc.")
  50.  
  51. (defvar mail-default-reply-to nil
  52.   "*Address to insert as default Reply-to field of outgoing messages.")
  53.  
  54. (defvar mail-abbrevs-loaded nil)
  55. (defvar mail-mode-map nil)
  56.  
  57. (autoload 'build-mail-aliases "mailalias"
  58.   "Read mail aliases from ~/.mailrc and set mail-aliases."
  59.   nil)
  60.  
  61. (autoload 'expand-mail-aliases "mailalias"
  62.   "Expand all mail aliases in suitable header fields found between BEG and END.
  63. Suitable header fields are To, CC and BCC."
  64.   nil)
  65.  
  66. (defun mail-setup (to subject in-reply-to cc replybuffer)
  67.   (if (eq mail-aliases t)
  68.       (progn
  69.     (setq mail-aliases nil)
  70.     (if (file-exists-p "~/.mailrc")
  71.         (build-mail-aliases))))
  72.   (setq mail-reply-buffer replybuffer)
  73.   (goto-char (point-min))
  74.   (insert "To: ")
  75.   (save-excursion
  76.     (if to
  77.     (progn
  78.       (insert to "\n")
  79.       ;;; Here removed code to extract names from within <...>
  80.       ;;; on the assumption that mail-strip-quoted-names
  81.       ;;; has been called and has done so.
  82.       (let ((fill-prefix "\t"))
  83.         (fill-region (point-min) (point-max))))
  84.       (newline))
  85.     (if cc
  86.     (let ((opos (point))
  87.           (fill-prefix "\t"))
  88.       (insert "CC: " cc "\n")
  89.       (fill-region-as-paragraph opos (point-max))))
  90.     (if in-reply-to
  91.     (insert "In-reply-to: " in-reply-to "\n"))
  92.     (insert "Subject: " (or subject "") "\n")
  93.     (if mail-default-reply-to
  94.     (insert "Reply-to: " mail-default-reply-to "\n"))
  95.     (if mail-self-blind
  96.     (insert "BCC: " (user-login-name) "\n"))
  97.     (if mail-archive-file-name
  98.     (insert "FCC: " mail-archive-file-name "\n"))
  99.     (insert mail-header-separator "\n"))
  100.   (if to (goto-char (point-max)))
  101.   (or to subject in-reply-to
  102.       (set-buffer-modified-p nil))
  103.   (run-hooks 'mail-setup-hook))
  104.  
  105. (defun mail-mode ()
  106.   "Major mode for editing mail to be sent.
  107. Like Text Mode but with these additional commands:
  108. C-c C-s  mail-send (send the message)    C-c C-c  mail-send-and-exit
  109. C-c C-f  move to a header field (and create it if there isn't):
  110.      C-c C-f C-t  move to To:    C-c C-f C-s  move to Subj:
  111.      C-c C-f C-b  move to BCC:    C-c C-f C-c  move to CC:
  112. C-c C-w  mail-signature (insert ~/.signature at end).
  113. C-c C-y  mail-yank-original (insert current message, in Rmail).
  114. C-c C-q  mail-fill-yanked-message (fill what was yanked)."
  115.   (interactive)
  116.   (kill-all-local-variables)
  117.   (make-local-variable 'mail-reply-buffer)
  118.   (setq mail-reply-buffer nil)
  119.   (set-syntax-table text-mode-syntax-table)
  120.   (use-local-map mail-mode-map)
  121.   (setq local-abbrev-table text-mode-abbrev-table)
  122.   (setq major-mode 'mail-mode)
  123.   (setq mode-name "Mail")
  124.   (setq buffer-offer-save t)
  125.   (make-local-variable 'paragraph-separate)
  126.   (make-local-variable 'paragraph-start)
  127.   (setq paragraph-start (concat "^" mail-header-separator
  128.                 "$\\|^[ \t]*[-_][-_][-_]+$\\|"
  129.                 paragraph-start))
  130.   (setq paragraph-separate (concat "^" mail-header-separator
  131.                    "$\\|^[ \t]*[-_][-_][-_]+$\\|"
  132.                    paragraph-separate))
  133.   (run-hooks 'text-mode-hook 'mail-mode-hook))
  134.  
  135. (if mail-mode-map
  136.     nil
  137.   (setq mail-mode-map (make-sparse-keymap))
  138.   (define-key mail-mode-map "\C-c?" 'describe-mode)
  139.   (define-key mail-mode-map "\C-c\C-f\C-t" 'mail-to)
  140.   (define-key mail-mode-map "\C-c\C-f\C-b" 'mail-bcc)
  141.   (define-key mail-mode-map "\C-c\C-f\C-c" 'mail-cc)
  142.   (define-key mail-mode-map "\C-c\C-f\C-s" 'mail-subject)
  143.   (define-key mail-mode-map "\C-c\C-w" 'mail-signature)        ; who
  144.   (define-key mail-mode-map "\C-c\C-y" 'mail-yank-original)
  145.   (define-key mail-mode-map "\C-c\C-q" 'mail-fill-yanked-message)
  146.   (define-key mail-mode-map "\C-c\C-c" 'mail-send-and-exit)
  147.   (define-key mail-mode-map "\C-c\C-s" 'mail-send))
  148.  
  149. (defun mail-send-and-exit (arg)
  150.   "Send message like mail-send, then, if no errors, exit from mail buffer.
  151. Prefix arg means don't delete this window."
  152.   (interactive "P")
  153.   (mail-send)
  154.   (bury-buffer (current-buffer))
  155.   (if (and (not arg)
  156.        (not (one-window-p))
  157.        (save-excursion
  158.          (set-buffer (window-buffer (next-window (selected-window) 'not)))
  159.          (eq major-mode 'rmail-mode)))
  160.       (delete-window)
  161.     (switch-to-buffer (other-buffer (current-buffer)))))
  162.  
  163. (defun mail-send ()
  164.   "Send the message in the current buffer.
  165. If  mail-interactive  is non-nil, wait for success indication
  166. or error messages, and inform user.
  167. Otherwise any failure is reported in a message back to
  168. the user from the mailer."
  169.   (interactive)
  170.   (message "Sending...")
  171.   (funcall send-mail-function)
  172.   (set-buffer-modified-p nil)
  173.   (delete-auto-save-file-if-necessary)
  174.   (message "Sending...done"))
  175.  
  176. (defun sendmail-send-it ()
  177.   (let ((errbuf (if mail-interactive
  178.             (generate-new-buffer " sendmail errors")
  179.           0))
  180.     (tembuf (generate-new-buffer " sendmail temp"))
  181.     (case-fold-search nil)
  182.     delimline
  183.     (mailbuf (current-buffer)))
  184.     (unwind-protect
  185.     (save-excursion
  186.       (set-buffer tembuf)
  187.       (erase-buffer)
  188.       (insert-buffer-substring mailbuf)
  189.       (goto-char (point-max))
  190.       ;; require one newline at the end.
  191.       (or (= (preceding-char) ?\n)
  192.           (insert ?\n))
  193.       ;; Change header-delimiter to be what sendmail expects.
  194.       (goto-char (point-min))
  195.       (re-search-forward
  196.         (concat "^" (regexp-quote mail-header-separator) "\n"))
  197.       (replace-match "\n")
  198.       (backward-char 1)
  199.       (setq delimline (point-marker))
  200.       (if mail-aliases
  201.           (expand-mail-aliases (point-min) delimline))
  202.       (goto-char (point-min))
  203.       ;; ignore any blank lines in the header
  204.       (while (and (re-search-forward "\n\n\n*" delimline t)
  205.               (< (point) delimline))
  206.         (replace-match "\n"))
  207.       (let ((case-fold-search t))
  208.         ;; Find and handle any FCC fields.
  209.         (goto-char (point-min))
  210.         (if (re-search-forward "^FCC:" delimline t)
  211.         (mail-do-fcc delimline))
  212.         ;; If there is a From and no Sender, put it a Sender.
  213.         (goto-char (point-min))
  214.         (and (re-search-forward "^From:"  delimline t)
  215.          (not (save-excursion
  216.             (goto-char (point-min))
  217.             (re-search-forward "^Sender:" delimline t)))
  218.          (progn
  219.            (forward-line 1)
  220.            (insert "Sender: " (user-login-name) "\n")))
  221.         ;; don't send out a blank subject line
  222.         (goto-char (point-min))
  223.         (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
  224.         (replace-match ""))
  225.         (if mail-interactive
  226.         (save-excursion
  227.           (set-buffer errbuf)
  228.           (erase-buffer))))
  229.       (apply 'call-process-region
  230.          (append (list (point-min) (point-max)
  231.                    (if (boundp 'sendmail-program)
  232.                    sendmail-program
  233.                  "/usr/lib/sendmail")
  234.                    nil errbuf nil
  235.                    "-oi" "-t")
  236.              ;; Always specify who from,
  237.              ;; since some systems have broken sendmails.
  238.              (list "-f" (user-login-name))
  239. ;;;             ;; Don't say "from root" if running under su.
  240. ;;;             (and (equal (user-real-login-name) "root")
  241. ;;;                  (list "-f" (user-login-name)))
  242.              ;; These mean "report errors by mail"
  243.              ;; and "deliver in background".
  244.              (if (null mail-interactive) '("-oem" "-odb"))))
  245.       (if mail-interactive
  246.           (save-excursion
  247.         (set-buffer errbuf)
  248.         (goto-char (point-min))
  249.         (while (re-search-forward "\n\n* *" nil t)
  250.           (replace-match "; "))
  251.         (if (not (zerop (buffer-size)))
  252.             (error "Sending...failed to %s"
  253.                (buffer-substring (point-min) (point-max)))))))
  254.       (kill-buffer tembuf)
  255.       (if (bufferp errbuf)
  256.       (kill-buffer errbuf)))))
  257.  
  258. (defun mail-do-fcc (header-end)
  259.   (let (fcc-list
  260.     (rmailbuf (current-buffer))
  261.     (tembuf (generate-new-buffer " rmail output"))
  262.     (case-fold-search t))
  263.     (save-excursion
  264.       (goto-char (point-min))
  265.       (while (re-search-forward "^FCC:[ \t]*" header-end t)
  266.     (setq fcc-list (cons (buffer-substring (point)
  267.                            (progn
  268.                          (end-of-line)
  269.                          (skip-chars-backward " \t")
  270.                          (point)))
  271.                  fcc-list))
  272.     (delete-region (match-beginning 0)
  273.                (progn (forward-line 1) (point))))
  274.       (set-buffer tembuf)
  275.       (erase-buffer)
  276.       (insert "\nFrom " (user-login-name) " "
  277.           (current-time-string) "\n")
  278.       (insert-buffer-substring rmailbuf)
  279.       ;; Make sure messages are separated.
  280.       (goto-char (point-max))
  281.       (insert ?\n)
  282.       (goto-char 2)
  283.       ;; ``Quote'' "^From " as ">From "
  284.       ;;  (note that this isn't really quoting, as there is no requirement
  285.       ;;   that "^[>]+From " be quoted in the same transparent way.)
  286.       (let ((case-fold-search nil))
  287.     (while (search-forward "\nFrom " nil t)
  288.       (forward-char -5)
  289.       (insert ?>)))
  290.       (while fcc-list
  291.     (let ((buffer (get-file-buffer (car fcc-list))))
  292.       (if buffer
  293.           ;; File is present in a buffer => append to that buffer.
  294.           (let ((curbuf (current-buffer))
  295.             (beg (point-min)) (end (point-max)))
  296.         (save-excursion
  297.           (set-buffer buffer)
  298.           (goto-char (point-max))
  299.           (insert-buffer-substring curbuf beg end)))
  300.         ;; Else append to the file directly.
  301.         (write-region (point-min) (point-max) (car fcc-list) t)))
  302.     (setq fcc-list (cdr fcc-list))))
  303.     (kill-buffer tembuf)))
  304.  
  305. (defun mail-to ()
  306.   "Move point to end of To-field."
  307.   (interactive)
  308.   (expand-abbrev)
  309.   (mail-position-on-field "To"))
  310.  
  311. (defun mail-subject ()
  312.   "Move point to end of Subject-field."
  313.   (interactive)
  314.   (expand-abbrev)
  315.   (mail-position-on-field "Subject"))
  316.  
  317. (defun mail-cc ()
  318.   "Move point to end of CC-field.  Create a CC field if none."
  319.   (interactive)
  320.   (expand-abbrev)
  321.   (or (mail-position-on-field "cc" t)
  322.       (progn (mail-position-on-field "to")
  323.          (insert "\nCC: "))))
  324.  
  325. (defun mail-bcc ()
  326.   "Move point to end of BCC-field.  Create a BCC field if none."
  327.   (interactive)
  328.   (expand-abbrev)
  329.   (or (mail-position-on-field "bcc" t)
  330.       (progn (mail-position-on-field "to")
  331.          (insert "\nBCC: "))))
  332.  
  333. (defun mail-position-on-field (field &optional soft)
  334.   (let (end
  335.     (case-fold-search t))
  336.     (goto-char (point-min))
  337.     (search-forward (concat "\n" mail-header-separator "\n"))
  338.     (setq end (match-beginning 0))
  339.     (goto-char (point-min))
  340.     (if (re-search-forward (concat "^" (regexp-quote field) ":") end t)
  341.     (progn
  342.       (re-search-forward "^[^ \t]" nil 'move)
  343.       (beginning-of-line)
  344.       (skip-chars-backward "\n")
  345.       t)
  346.       (or soft
  347.       (progn (goto-char end)
  348.          (skip-chars-backward "\n")
  349.          (insert "\n" field ": ")))
  350.       nil)))
  351.  
  352. (defun mail-signature ()
  353.   "Sign letter with contents of ~/.signature file."
  354.   (interactive)
  355.   (save-excursion
  356.     (goto-char (point-max))
  357.     (insert-file-contents (expand-file-name "~/.signature"))))
  358.  
  359. (defun mail-fill-yanked-message (&optional justifyp)
  360.   "Fill the paragraphs of a message yanked into this one.
  361. Numeric argument means justify as well."
  362.   (interactive "P")
  363.   (save-excursion
  364.     (goto-char (point-min))
  365.     (search-forward (concat "\n" mail-header-separator "\n") nil t)
  366.     (fill-individual-paragraphs (point)
  367.                 (point-max)
  368.                 justifyp
  369.                 t)))
  370. (defun mail-yank-original (arg)
  371.   "Insert the message being replied to, if any (in rmail).
  372. Puts point before the text and mark after.
  373. Indents each nonblank line ARG spaces (default 3).
  374. Just \\[universal-argument] as argument means don't indent
  375. and don't delete any header fields."
  376.   (interactive "P")
  377.   (if mail-reply-buffer
  378.       (let ((start (point)))
  379.     (delete-windows-on mail-reply-buffer)
  380.     (insert-buffer mail-reply-buffer)
  381.     (if (consp arg)
  382.         nil
  383.       (mail-yank-clear-headers start (mark))
  384.       (indent-rigidly start (mark)
  385.               (if arg (prefix-numeric-value arg) 3)))
  386.     (exchange-point-and-mark)
  387.     (if (not (eolp)) (insert ?\n)))))
  388.  
  389. (defun mail-yank-clear-headers (start end)
  390.   (save-excursion
  391.     (goto-char start)
  392.     (if (search-forward "\n\n" end t)
  393.     (save-restriction
  394.       (narrow-to-region start (point))
  395.       (goto-char start)
  396.       (while (let ((case-fold-search t))
  397.            (re-search-forward mail-yank-ignored-headers nil t))
  398.         (beginning-of-line)
  399.         (delete-region (point)
  400.                (progn (re-search-forward "\n[^ \t]")
  401.                   (forward-char -1)
  402.                   (point))))))))
  403.  
  404. ;; Put these last, to reduce chance of lossage from quitting in middle of loading the file.
  405.  
  406. (defun mail (&optional noerase to subject in-reply-to cc replybuffer)
  407.   "Edit a message to be sent.  Argument means resume editing (don't erase).
  408. Returns with message buffer selected; value t if message freshly initialized.
  409. While editing message, type C-c C-c to send the message and exit.
  410.  
  411. Various special commands starting with C-c are available in sendmail mode
  412. to move to message header fields:
  413. \\{mail-mode-map}
  414.  
  415. If mail-self-blind is non-nil, a BCC to yourself is inserted
  416. when the message is initialized.
  417.  
  418. If mail-default-reply-to is non-nil, it should be an address (a string);
  419. a Reply-to: field with that address is inserted.
  420.  
  421. If mail-archive-file-name is non-nil, an FCC field with that file name
  422. is inserted.
  423.  
  424. If mail-setup-hook is bound, its value is called with no arguments
  425. after the message is initialized.  It can add more default fields.
  426.  
  427. When calling from a program, the second through fifth arguments
  428.  TO, SUBJECT, IN-REPLY-TO and CC specify if non-nil
  429.  the initial contents of those header fields.
  430.  These arguments should not have final newlines.
  431. The sixth argument REPLYBUFFER is a buffer whose contents
  432.  should be yanked if the user types C-c C-y."
  433.   (interactive "P")
  434.   (switch-to-buffer "*mail*")
  435.   (setq default-directory (expand-file-name "~/"))
  436.   (auto-save-mode auto-save-default)
  437.   (mail-mode)
  438.   (and (not noerase)
  439.        (or (not (buffer-modified-p))
  440.        (y-or-n-p "Unsent message being composed; erase it? "))
  441.        (progn (erase-buffer)
  442.           (mail-setup to subject in-reply-to cc replybuffer)
  443.           t)))
  444.  
  445. (defun mail-other-window (&optional noerase to subject in-reply-to cc replybuffer)
  446.   "Like `mail' command, but display mail buffer in another window."
  447.   (interactive "P")
  448.   (let ((pop-up-windows t))
  449.     (pop-to-buffer "*mail*"))
  450.   (mail noerase to subject in-reply-to cc replybuffer))
  451.  
  452. ;;; Do not add anything but external entries on this page.
  453.