Mercurial > emacs

comparison lisp/mail/sendmail.el @ 66965:1bca10e9d192

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
* simple.el (hard-newline): New variable. * mail/sendmail.el (mail-setup, mail-send, mail-insert-from-field) (sendmail-send-it, mail-do-fcc, mail-cc, mail-bcc, mail-fcc) (mail-mail-reply-to, mail-mail-followup-to) (mail-position-on-field, mail-signature, mail-yank-original) (mail-attach-file): Use it. * mail/mailheader.el (mail-header-format) (mail-header-format-function): Likewise. * add-log.el (add-change-log-entry, change-log-merge): Likewise.
author Chong Yidong <cyd@stupidchicken.com>
date Thu, 17 Nov 2005 16:30:52 +0000
parents 69f47ed7d25d
children 818361523ce8
comparison
equal deleted inserted replaced
66964:99b6d306113f 66965:1bca10e9d192
444 ;; Here removed code to extract names from within <...> 444 ;; Here removed code to extract names from within <...>
445 ;; on the assumption that mail-strip-quoted-names 445 ;; on the assumption that mail-strip-quoted-names
446 ;; has been called and has done so. 446 ;; has been called and has done so.
447 (let ((fill-prefix "\t") 447 (let ((fill-prefix "\t")
448 (address-start (point))) 448 (address-start (point)))
449 (insert to "\n") 449 (insert to hard-newline)
450 (fill-region-as-paragraph address-start (point-max)) 450 (fill-region-as-paragraph address-start (point-max))
451 (goto-char (point-max)) 451 (goto-char (point-max))
452 (unless (bolp) 452 (unless (bolp)
453 (newline))) 453 (newline)))
454 (newline)) 454 (newline))
455 (if cc 455 (if cc
456 (let ((fill-prefix "\t") 456 (let ((fill-prefix "\t")
457 (address-start (progn (insert "CC: ") (point)))) 457 (address-start (progn (insert "CC: ") (point))))
458 (insert cc "\n") 458 (insert cc hard-newline)
459 (fill-region-as-paragraph address-start (point-max)) 459 (fill-region-as-paragraph address-start (point-max))
460 (goto-char (point-max)) 460 (goto-char (point-max))
461 (unless (bolp) 461 (unless (bolp)
462 (newline)))) 462 (newline))))
463 (if in-reply-to 463 (if in-reply-to
464 (let ((fill-prefix "\t") 464 (let ((fill-prefix "\t")
465 (fill-column 78) 465 (fill-column 78)
466 (address-start (point))) 466 (address-start (point)))
467 (insert "In-reply-to: " in-reply-to "\n") 467 (insert "In-reply-to: " in-reply-to hard-newline)
468 (fill-region-as-paragraph address-start (point-max)) 468 (fill-region-as-paragraph address-start (point-max))
469 (goto-char (point-max)) 469 (goto-char (point-max))
470 (unless (bolp) 470 (unless (bolp)
471 (newline)))) 471 (newline))))
472 (insert "Subject: " (or subject "") "\n") 472 (insert "Subject: " (or subject "") hard-newline)
473 (if mail-default-headers 473 (if mail-default-headers
474 (insert mail-default-headers)) 474 (insert mail-default-headers))
475 (if mail-default-reply-to 475 (if mail-default-reply-to
476 (insert "Reply-to: " mail-default-reply-to "\n")) 476 (insert "Reply-to: " mail-default-reply-to hard-newline))
477 (if mail-self-blind 477 (if mail-self-blind
478 (insert "BCC: " user-mail-address "\n")) 478 (insert "BCC: " user-mail-address hard-newline))
479 (if mail-archive-file-name 479 (if mail-archive-file-name
480 (insert "FCC: " mail-archive-file-name "\n")) 480 (insert "FCC: " mail-archive-file-name hard-newline))
481 (put-text-property (point) 481 (put-text-property (point)
482 (progn 482 (progn
483 (insert mail-header-separator "\n") 483 (insert mail-header-separator hard-newline)
484 (1- (point))) 484 (1- (point)))
485 'category 'mail-header-separator) 485 'category 'mail-header-separator)
486 ;; Insert the signature. But remember the beginning of the message. 486 ;; Insert the signature. But remember the beginning of the message.
487 (if to (setq to (point))) 487 (if to (setq to (point)))
488 (cond ((eq mail-signature t) 488 (cond ((eq mail-signature t)
489 (if (file-exists-p mail-signature-file) 489 (if (file-exists-p mail-signature-file)
490 (progn 490 (progn
491 (insert "\n\n-- \n") 491 (insert hard-newline hard-newline "-- " hard-newline)
492 (insert-file-contents mail-signature-file)))) 492 (insert-file-contents mail-signature-file))))
493 ((stringp mail-signature) 493 ((stringp mail-signature)
494 (insert mail-signature)) 494 (insert mail-signature))
495 (t 495 (t
496 (eval mail-signature))) 496 (eval mail-signature)))
833 (unless (member e l) 833 (unless (member e l)
834 (push e l))) 834 (push e l)))
835 (split-string new-header-values 835 (split-string new-header-values
836 ",[[:space:]]+" t)) 836 ",[[:space:]]+" t))
837 (mapconcat 'identity l ", ")) 837 (mapconcat 'identity l ", "))
838 "\n")) 838 hard-newline))
839 ;; Add Mail-Reply-To if none yet 839 ;; Add Mail-Reply-To if none yet
840 (unless (mail-fetch-field "mail-reply-to") 840 (unless (mail-fetch-field "mail-reply-to")
841 (goto-char (mail-header-end)) 841 (goto-char (mail-header-end))
842 (insert "Mail-Reply-To: " 842 (insert "Mail-Reply-To: "
843 (or (mail-fetch-field "reply-to") 843 (or (mail-fetch-field "reply-to")
844 user-mail-address) 844 user-mail-address)
845 "\n")))))) 845 hard-newline))))))
846 (unless (memq mail-send-nonascii '(t mime)) 846 (unless (memq mail-send-nonascii '(t mime))
847 (goto-char (point-min)) 847 (goto-char (point-min))
848 (skip-chars-forward "\0-\177") 848 (skip-chars-forward "\0-\177")
849 (or (= (point) (point-max)) 849 (or (= (point) (point-max))
850 (if (eq mail-send-nonascii 'query) 850 (if (eq mail-send-nonascii 'query)
929 (insert "\"") 929 (insert "\"")
930 (while (re-search-forward "[\"\\]" 930 (while (re-search-forward "[\"\\]"
931 fullname-end 1) 931 fullname-end 1)
932 (replace-match "\\\\\\&" t)) 932 (replace-match "\\\\\\&" t))
933 (insert "\"")))) 933 (insert "\""))))
934 (insert " <" login ">\n")) 934 (insert " <" login ">" hard-newline))
935 ((eq mail-from-style 'parens) 935 ((eq mail-from-style 'parens)
936 (insert "From: " login " (") 936 (insert "From: " login " (")
937 (let ((fullname-start (point))) 937 (let ((fullname-start (point)))
938 (if quote-fullname 938 (if quote-fullname
939 (insert "\"")) 939 (insert "\""))
953 (while (re-search-forward 953 (while (re-search-forward
954 "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" 954 "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
955 fullname-end 1) 955 fullname-end 1)
956 (replace-match "\\1(\\3)" t) 956 (replace-match "\\1(\\3)" t)
957 (goto-char fullname-start)))) 957 (goto-char fullname-start))))
958 (insert ")\n")) 958 (insert ")" hard-newline))
959 ((null mail-from-style) 959 ((null mail-from-style)
960 (insert "From: " login "\n")) 960 (insert "From: " login hard-newline))
961 ((eq mail-from-style 'system-default) 961 ((eq mail-from-style 'system-default)
962 nil) 962 nil)
963 (t (error "Invalid value for `mail-from-style'"))))) 963 (t (error "Invalid value for `mail-from-style'")))))
964 964
965 (defun sendmail-send-it () 965 (defun sendmail-send-it ()
994 (set-buffer-multibyte nil)) 994 (set-buffer-multibyte nil))
995 (insert-buffer-substring mailbuf) 995 (insert-buffer-substring mailbuf)
996 (goto-char (point-max)) 996 (goto-char (point-max))
997 ;; require one newline at the end. 997 ;; require one newline at the end.
998 (or (= (preceding-char) ?\n) 998 (or (= (preceding-char) ?\n)
999 (insert ?\n)) 999 (insert hard-newline))
1000 ;; Change header-delimiter to be what sendmail expects. 1000 ;; Change header-delimiter to be what sendmail expects.
1001 (goto-char (mail-header-end)) 1001 (goto-char (mail-header-end))
1002 (delete-region (point) (progn (end-of-line) (point))) 1002 (delete-region (point) (progn (end-of-line) (point)))
1003 (setq delimline (point-marker)) 1003 (setq delimline (point-marker))
1004 (sendmail-sync-aliases) 1004 (sendmail-sync-aliases)
1006 (expand-mail-aliases (point-min) delimline)) 1006 (expand-mail-aliases (point-min) delimline))
1007 (goto-char (point-min)) 1007 (goto-char (point-min))
1008 ;; Ignore any blank lines in the header 1008 ;; Ignore any blank lines in the header
1009 (while (and (re-search-forward "\n\n\n*" delimline t) 1009 (while (and (re-search-forward "\n\n\n*" delimline t)
1010 (< (point) delimline)) 1010 (< (point) delimline))
1011 (replace-match "\n")) 1011 (replace-match hard-newline))
1012 (goto-char (point-min)) 1012 (goto-char (point-min))
1013 ;; Look for Resent- headers. They require sending 1013 ;; Look for Resent- headers. They require sending
1014 ;; the message specially. 1014 ;; the message specially.
1015 (let ((case-fold-search t)) 1015 (let ((case-fold-search t))
1016 (goto-char (point-min)) 1016 (goto-char (point-min))
1068 (/= (point) (point-max))) 1068 (/= (point) (point-max)))
1069 selected-coding 1069 selected-coding
1070 (setq charset 1070 (setq charset
1071 (coding-system-get selected-coding 'mime-charset)) 1071 (coding-system-get selected-coding 'mime-charset))
1072 (goto-char delimline) 1072 (goto-char delimline)
1073 (insert "MIME-version: 1.0\n" 1073 (insert "MIME-version: 1.0" hard-newline
1074 "Content-type: text/plain; charset=" 1074 "Content-type: text/plain; charset="
1075 (symbol-name charset) "\n" 1075 (symbol-name charset) hard-newline
1076 "Content-Transfer-Encoding: 8bit\n"))) 1076 "Content-Transfer-Encoding: 8bit" hard-newline)))
1077 ;; Insert an extra newline if we need it to work around 1077 ;; Insert an extra newline if we need it to work around
1078 ;; Sun's bug that swallows newlines. 1078 ;; Sun's bug that swallows newlines.
1079 (goto-char (1+ delimline)) 1079 (goto-char (1+ delimline))
1080 (if (eval mail-mailer-swallows-blank-line) 1080 (if (eval mail-mailer-swallows-blank-line)
1081 (newline)) 1081 (newline))
1165 (delete-region (match-beginning 0) 1165 (delete-region (match-beginning 0)
1166 (progn (forward-line 1) (point)))) 1166 (progn (forward-line 1) (point))))
1167 (set-buffer tembuf) 1167 (set-buffer tembuf)
1168 (erase-buffer) 1168 (erase-buffer)
1169 ;; This initial newline is written out if the fcc file already exists. 1169 ;; This initial newline is written out if the fcc file already exists.
1170 (insert "\nFrom " (user-login-name) " " 1170 (insert hard-newline "From " (user-login-name) " "
1171 (current-time-string time) "\n") 1171 (current-time-string time) hard-newline)
1172 ;; Insert the time zone before the year. 1172 ;; Insert the time zone before the year.
1173 (forward-char -1) 1173 (forward-char -1)
1174 (forward-word -1) 1174 (forward-word -1)
1175 (require 'mail-utils) 1175 (require 'mail-utils)
1176 (insert (mail-rfc822-time-zone time) " ") 1176 (insert (mail-rfc822-time-zone time) " ")
1177 (goto-char (point-max)) 1177 (goto-char (point-max))
1178 (insert-buffer-substring rmailbuf) 1178 (insert-buffer-substring rmailbuf)
1179 ;; Make sure messages are separated. 1179 ;; Make sure messages are separated.
1180 (goto-char (point-max)) 1180 (goto-char (point-max))
1181 (insert ?\n) 1181 (insert hard-newline)
1182 (goto-char 2) 1182 (goto-char 2)
1183 ;; ``Quote'' "^From " as ">From " 1183 ;; ``Quote'' "^From " as ">From "
1184 ;; (note that this isn't really quoting, as there is no requirement 1184 ;; (note that this isn't really quoting, as there is no requirement
1185 ;; that "^[>]+From " be quoted in the same transparent way.) 1185 ;; that "^[>]+From " be quoted in the same transparent way.)
1186 (let ((case-fold-search nil)) 1186 (let ((case-fold-search nil))
1218 ;; Append to an ordinary buffer as a 1218 ;; Append to an ordinary buffer as a
1219 ;; Unix mail message. 1219 ;; Unix mail message.
1220 (rmail-maybe-set-message-counters) 1220 (rmail-maybe-set-message-counters)
1221 (widen) 1221 (widen)
1222 (narrow-to-region (point-max) (point-max)) 1222 (narrow-to-region (point-max) (point-max))
1223 (insert "\C-l\n0, unseen,,\n*** EOOH ***\n" 1223 (insert "\C-l" hard-newline "0, unseen,,"
1224 "Date: " (mail-rfc822-date) "\n") 1224 hard-newline "*** EOOH ***" hard-newline
1225 "Date: " (mail-rfc822-date) hard-newline)
1225 (insert-buffer-substring curbuf beg2 end) 1226 (insert-buffer-substring curbuf beg2 end)
1226 (insert "\n\C-_") 1227 (insert hard-newline "\C-_")
1227 (goto-char (point-min)) 1228 (goto-char (point-min))
1228 (widen) 1229 (widen)
1229 (search-backward "\n\^_") 1230 (search-backward "\n\^_")
1230 (narrow-to-region (point) (point-max)) 1231 (narrow-to-region (point) (point-max))
1231 (rmail-count-new-messages t) 1232 (rmail-count-new-messages t)
1259 'emacs-mule))) 1260 'emacs-mule)))
1260 (save-excursion 1261 (save-excursion
1261 (set-buffer (get-buffer-create " mail-temp")) 1262 (set-buffer (get-buffer-create " mail-temp"))
1262 (setq buffer-read-only nil) 1263 (setq buffer-read-only nil)
1263 (erase-buffer) 1264 (erase-buffer)
1264 (insert "\C-l\n0, unseen,,\n*** EOOH ***\n" 1265 (insert "\C-l" hard-newline "0, unseen,," hard-newline
1265 "Date: " (mail-rfc822-date) "\n") 1266 "*** EOOH ***" hard-newline "Date: "
1267 (mail-rfc822-date) hard-newline)
1266 (insert-buffer-substring curbuf beg2 end) 1268 (insert-buffer-substring curbuf beg2 end)
1267 (insert "\n\C-_") 1269 (insert hard-newline "\C-_")
1268 (write-region (point-min) (point-max) (car fcc-list) t) 1270 (write-region (point-min) (point-max) (car fcc-list) t)
1269 (erase-buffer))) 1271 (erase-buffer)))
1270 (write-region 1272 (write-region
1271 (1+ (point-min)) (point-max) (car fcc-list) t))) 1273 (1+ (point-min)) (point-max) (car fcc-list) t)))
1272 (and buffer (not dont-write-the-file) 1274 (and buffer (not dont-write-the-file)
1314 "Move point to end of CC-field. Create a CC field if none." 1316 "Move point to end of CC-field. Create a CC field if none."
1315 (interactive) 1317 (interactive)
1316 (expand-abbrev) 1318 (expand-abbrev)
1317 (or (mail-position-on-field "cc" t) 1319 (or (mail-position-on-field "cc" t)
1318 (progn (mail-position-on-field "to") 1320 (progn (mail-position-on-field "to")
1319 (insert "\nCC: ")))) 1321 (insert hard-newline "CC: "))))
1320 1322
1321 (defun mail-bcc () 1323 (defun mail-bcc ()
1322 "Move point to end of BCC-field. Create a BCC field if none." 1324 "Move point to end of BCC-field. Create a BCC field if none."
1323 (interactive) 1325 (interactive)
1324 (expand-abbrev) 1326 (expand-abbrev)
1325 (or (mail-position-on-field "bcc" t) 1327 (or (mail-position-on-field "bcc" t)
1326 (progn (mail-position-on-field "to") 1328 (progn (mail-position-on-field "to")
1327 (insert "\nBCC: ")))) 1329 (insert hard-newline "BCC: "))))
1328 1330
1329 (defun mail-fcc (folder) 1331 (defun mail-fcc (folder)
1330 "Add a new FCC field, with file name completion." 1332 "Add a new FCC field, with file name completion."
1331 (interactive "FFolder carbon copy: ") 1333 (interactive "FFolder carbon copy: ")
1332 (expand-abbrev) 1334 (expand-abbrev)
1333 (or (mail-position-on-field "fcc" t) ;Put new field after exiting FCC. 1335 (or (mail-position-on-field "fcc" t) ;Put new field after exiting FCC.
1334 (mail-position-on-field "to")) 1336 (mail-position-on-field "to"))
1335 (insert "\nFCC: " folder)) 1337 (insert hard-newline "FCC: " folder))
1336 1338
1337 (defun mail-reply-to () 1339 (defun mail-reply-to ()
1338 "Move point to end of Reply-To-field. Create a Reply-To field if none." 1340 "Move point to end of Reply-To-field. Create a Reply-To field if none."
1339 (interactive) 1341 (interactive)
1340 (expand-abbrev) 1342 (expand-abbrev)
1345 Create a Mail-Reply-To field if none." 1347 Create a Mail-Reply-To field if none."
1346 (interactive) 1348 (interactive)
1347 (expand-abbrev) 1349 (expand-abbrev)
1348 (or (mail-position-on-field "mail-reply-to" t) 1350 (or (mail-position-on-field "mail-reply-to" t)
1349 (progn (mail-position-on-field "to") 1351 (progn (mail-position-on-field "to")
1350 (insert "\nMail-Reply-To: ")))) 1352 (insert hard-newline "Mail-Reply-To: "))))
1351 1353
1352 (defun mail-mail-followup-to () 1354 (defun mail-mail-followup-to ()
1353 "Move point to end of Mail-Followup-To field. 1355 "Move point to end of Mail-Followup-To field.
1354 Create a Mail-Followup-To field if none." 1356 Create a Mail-Followup-To field if none."
1355 (interactive) 1357 (interactive)
1356 (expand-abbrev) 1358 (expand-abbrev)
1357 (or (mail-position-on-field "mail-followup-to" t) 1359 (or (mail-position-on-field "mail-followup-to" t)
1358 (progn (mail-position-on-field "to") 1360 (progn (mail-position-on-field "to")
1359 (insert "\nMail-Followup-To: ")))) 1361 (insert hard-newline "Mail-Followup-To: "))))
1360 1362
1361 (defun mail-position-on-field (field &optional soft) 1363 (defun mail-position-on-field (field &optional soft)
1362 (let (end 1364 (let (end
1363 (case-fold-search t)) 1365 (case-fold-search t))
1364 (setq end (mail-header-end)) 1366 (setq end (mail-header-end))
1369 (beginning-of-line) 1371 (beginning-of-line)
1370 (skip-chars-backward "\n") 1372 (skip-chars-backward "\n")
1371 t) 1373 t)
1372 (or soft 1374 (or soft
1373 (progn (goto-char end) 1375 (progn (goto-char end)
1374 (insert field ": \n") 1376 (insert field ": " hard-newline)
1375 (skip-chars-backward "\n"))) 1377 (skip-chars-backward "\n")))
1376 nil))) 1378 nil)))
1377 1379
1378 (defun mail-text () 1380 (defun mail-text ()
1379 "Move point to beginning of message text." 1381 "Move point to beginning of message text."
1392 (end-of-line) 1394 (end-of-line)
1393 (or atpoint 1395 (or atpoint
1394 (delete-region (point) (point-max))) 1396 (delete-region (point) (point-max)))
1395 (if (stringp mail-signature) 1397 (if (stringp mail-signature)
1396 (insert mail-signature) 1398 (insert mail-signature)
1397 (insert "\n\n-- \n") 1399 (insert hard-newline hard-newline "-- " hard-newline)
1398 (insert-file-contents (expand-file-name mail-signature-file))))) 1400 (insert-file-contents (expand-file-name mail-signature-file)))))
1399 1401
1400 (defun mail-fill-yanked-message (&optional justifyp) 1402 (defun mail-fill-yanked-message (&optional justifyp)
1401 "Fill the paragraphs of a message yanked into this one. 1403 "Fill the paragraphs of a message yanked into this one.
1402 Numeric argument means justify as well." 1404 Numeric argument means justify as well."
1478 ;; This is like exchange-point-and-mark, but doesn't activate the mark. 1480 ;; This is like exchange-point-and-mark, but doesn't activate the mark.
1479 ;; It is cleaner to avoid activation, even though the command 1481 ;; It is cleaner to avoid activation, even though the command
1480 ;; loop would deactivate the mark because we inserted text. 1482 ;; loop would deactivate the mark because we inserted text.
1481 (goto-char (prog1 (mark t) 1483 (goto-char (prog1 (mark t)
1482 (set-marker (mark-marker) (point) (current-buffer)))) 1484 (set-marker (mark-marker) (point) (current-buffer))))
1483 (if (not (eolp)) (insert ?\n))))) 1485 (if (not (eolp)) (insert hard-newline)))))
1484 1486
1485 (defun mail-yank-clear-headers (start end) 1487 (defun mail-yank-clear-headers (start end)
1486 (if (< end start) 1488 (if (< end start)
1487 (let (temp) 1489 (let (temp)
1488 (setq temp start start end end temp))) 1490 (setq temp start start end end temp)))
1562 middle) 1564 middle)
1563 (insert (format "===File %s===" file)) 1565 (insert (format "===File %s===" file))
1564 (insert-char ?= (max 0 (- 60 (current-column)))) 1566 (insert-char ?= (max 0 (- 60 (current-column))))
1565 (newline) 1567 (newline)
1566 (setq middle (point)) 1568 (setq middle (point))
1567 (insert "============================================================\n") 1569 (insert "============================================================"
1570 hard-newline)
1568 (push-mark) 1571 (push-mark)
1569 (goto-char middle) 1572 (goto-char middle)
1570 (insert-file-contents file) 1573 (insert-file-contents file)
1571 (or (bolp) (newline)) 1574 (or (bolp) (newline))
1572 (goto-char start)))) 1575 (goto-char start))))