Mercurial > emacs
comparison lisp/mail/mail-extr.el @ 1186:24f248525608
(mail-undo-backslash-quoting): Renamed from undo-...
(mail-safe-move-sexp): Renamed from safe-...
(mail-variant-method): Renamed from variant-method.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Mon, 21 Sep 1992 14:52:30 +0000 |
parents | 9f3cc03dae67 |
children | 58d613f69b39 |
comparison
equal
deleted
inserted
replaced
1185:4ec50a934e54 | 1186:24f248525608 |
---|---|
100 ;; * arrange to have syntax tables byte-compiled. | 100 ;; * arrange to have syntax tables byte-compiled. |
101 ;; * speed hacks. | 101 ;; * speed hacks. |
102 ;; * delete unused variables. | 102 ;; * delete unused variables. |
103 ;; * arrange for testing with different relative precedences of ! vs. @ | 103 ;; * arrange for testing with different relative precedences of ! vs. @ |
104 ;; and %. | 104 ;; and %. |
105 ;; * put variant-method back into mail-extract-address-components. | 105 ;; * put mail-variant-method back into mail-extract-address-components. |
106 ;; * insert documentation strings! | 106 ;; * insert documentation strings! |
107 ;; * handle X.400-gatewayed addresses according to RFC 1148. | 107 ;; * handle X.400-gatewayed addresses according to RFC 1148. |
108 | 108 |
109 ;;; Change Log: | 109 ;;; Change Log: |
110 ;; | 110 ;; |
335 )) | 335 )) |
336 | 336 |
337 | 337 |
338 ;; Utility functions and macros. | 338 ;; Utility functions and macros. |
339 | 339 |
340 (defmacro undo-backslash-quoting (beg end) | 340 (defmacro mail-undo-backslash-quoting (beg end) |
341 (`(save-excursion | 341 (`(save-excursion |
342 (save-restriction | 342 (save-restriction |
343 (narrow-to-region (, beg) (, end)) | 343 (narrow-to-region (, beg) (, end)) |
344 (goto-char (point-min)) | 344 (goto-char (point-min)) |
345 ;; undo \ quoting | 345 ;; undo \ quoting |
386 (` (let ((list (, list))) | 386 (` (let ((list (, list))) |
387 (while (not (null (cdr list))) | 387 (while (not (null (cdr list))) |
388 (setq list (cdr list))) | 388 (setq list (cdr list))) |
389 (car list)))) | 389 (car list)))) |
390 | 390 |
391 (defmacro safe-move-sexp (arg) | 391 (defmacro mail-safe-move-sexp (arg) |
392 "Safely skip over one balanced sexp, if there is one. Return t if success." | 392 "Safely skip over one balanced sexp, if there is one. Return t if success." |
393 (` (condition-case error | 393 (` (condition-case error |
394 (progn | 394 (progn |
395 (goto-char (scan-sexps (point) (, arg))) | 395 (goto-char (scan-sexps (point) (, arg))) |
396 t) | 396 t) |
465 (forward-char 1) | 465 (forward-char 1) |
466 (skip-chars-forward mail-whitespace) | 466 (skip-chars-forward mail-whitespace) |
467 (not (eq ?\) (char-after (point)))))) | 467 (not (eq ?\) (char-after (point)))))) |
468 (setq comment-beg (point))) | 468 (setq comment-beg (point))) |
469 ;; TODO: don't record if unbalanced | 469 ;; TODO: don't record if unbalanced |
470 (or (safe-move-sexp 1) | 470 (or (mail-safe-move-sexp 1) |
471 (forward-char 1)) | 471 (forward-char 1)) |
472 (set-syntax-table address-syntax-table) | 472 (set-syntax-table address-syntax-table) |
473 (if (and comment-beg | 473 (if (and comment-beg |
474 (not comment-end)) | 474 (not comment-end)) |
475 (setq comment-end (point)))) | 475 (setq comment-end (point)))) |
481 (forward-char 1) | 481 (forward-char 1) |
482 (skip-chars-forward mail-whitespace) | 482 (skip-chars-forward mail-whitespace) |
483 (not (eq ?\" (char-after (point)))))) | 483 (not (eq ?\" (char-after (point)))))) |
484 (setq quote-beg (point))) | 484 (setq quote-beg (point))) |
485 ;; TODO: don't record if unbalanced | 485 ;; TODO: don't record if unbalanced |
486 (or (safe-move-sexp 1) | 486 (or (mail-safe-move-sexp 1) |
487 (forward-char 1)) | 487 (forward-char 1)) |
488 (if (and quote-beg | 488 (if (and quote-beg |
489 (not quote-end)) | 489 (not quote-end)) |
490 (setq quote-end (point)))) | 490 (setq quote-end (point)))) |
491 ;; domain literals | 491 ;; domain literals |
492 ((eq char ?\[) | 492 ((eq char ?\[) |
493 (set-syntax-table address-domain-literal-syntax-table) | 493 (set-syntax-table address-domain-literal-syntax-table) |
494 (or (safe-move-sexp 1) | 494 (or (mail-safe-move-sexp 1) |
495 (forward-char 1)) | 495 (forward-char 1)) |
496 (set-syntax-table address-syntax-table)) | 496 (set-syntax-table address-syntax-table)) |
497 ;; commas delimit addresses when outside < > pairs. | 497 ;; commas delimit addresses when outside < > pairs. |
498 ((and (eq char ?,) | 498 ((and (eq char ?,) |
499 (or (null <-pos) | 499 (or (null <-pos) |
765 (1+ (nth 1 !-pos)) | 765 (1+ (nth 1 !-pos)) |
766 (point-min)) | 766 (point-min)) |
767 (car !-pos)) | 767 (car !-pos)) |
768 (delete-char 1) | 768 (delete-char 1) |
769 (or (save-excursion | 769 (or (save-excursion |
770 (safe-move-sexp -1) | 770 (mail-safe-move-sexp -1) |
771 (skip-chars-backward mail-whitespace) | 771 (skip-chars-backward mail-whitespace) |
772 (eq ?. (preceding-char))) | 772 (eq ?. (preceding-char))) |
773 (insert-before-markers | 773 (insert-before-markers |
774 (if (save-excursion | 774 (if (save-excursion |
775 (skip-chars-backward mail-whitespace) | 775 (skip-chars-backward mail-whitespace) |
799 (while temp | 799 (while temp |
800 (goto-char (or (nth 1 temp) | 800 (goto-char (or (nth 1 temp) |
801 @-pos)) | 801 @-pos)) |
802 (skip-chars-backward mail-whitespace) | 802 (skip-chars-backward mail-whitespace) |
803 (save-excursion | 803 (save-excursion |
804 (safe-move-sexp -1) | 804 (mail-safe-move-sexp -1) |
805 (setq domain-pos (point)) | 805 (setq domain-pos (point)) |
806 (skip-chars-backward mail-whitespace) | 806 (skip-chars-backward mail-whitespace) |
807 (setq \.-pos (eq ?. (preceding-char)))) | 807 (setq \.-pos (eq ?. (preceding-char)))) |
808 (cond ((and \.-pos | 808 (cond ((and \.-pos |
809 (get | 809 (get |
832 | 832 |
833 (cond ((and phrase-beg | 833 (cond ((and phrase-beg |
834 (eq quote-beg phrase-beg) | 834 (eq quote-beg phrase-beg) |
835 (<= quote-end phrase-end)) | 835 (<= quote-end phrase-end)) |
836 (narrow-to-region (1+ quote-beg) (1- quote-end)) | 836 (narrow-to-region (1+ quote-beg) (1- quote-end)) |
837 (undo-backslash-quoting (point-min) (point-max))) | 837 (mail-undo-backslash-quoting (point-min) (point-max))) |
838 (phrase-beg | 838 (phrase-beg |
839 (narrow-to-region phrase-beg phrase-end)) | 839 (narrow-to-region phrase-beg phrase-end)) |
840 (comment-beg | 840 (comment-beg |
841 (narrow-to-region (1+ comment-beg) (1- comment-end)) | 841 (narrow-to-region (1+ comment-beg) (1- comment-end)) |
842 (undo-backslash-quoting (point-min) (point-max))) | 842 (mail-undo-backslash-quoting (point-min) (point-max))) |
843 (t | 843 (t |
844 ;; *** Work in canon buffer instead? No, can't. Hmm. | 844 ;; *** Work in canon buffer instead? No, can't. Hmm. |
845 (delete-region (point-min) (point-max)) | 845 (delete-region (point-min) (point-max)) |
846 (insert-buffer-substring canonicalization-buffer | 846 (insert-buffer-substring canonicalization-buffer |
847 mbox-beg mbox-end) | 847 mbox-beg mbox-end) |
853 (not (eobp))) | 853 (not (eobp))) |
854 (setq char (char-after (point))) | 854 (setq char (char-after (point))) |
855 (cond | 855 (cond |
856 ((eq char ?\") | 856 ((eq char ?\") |
857 (setq quote-beg (point)) | 857 (setq quote-beg (point)) |
858 (or (safe-move-sexp 1) | 858 (or (mail-safe-move-sexp 1) |
859 ;; TODO: handle this error condition!!!!! | 859 ;; TODO: handle this error condition!!!!! |
860 (forward-char 1)) | 860 (forward-char 1)) |
861 ;; take into account deletions | 861 ;; take into account deletions |
862 (setq quote-end (- (point) 2)) | 862 (setq quote-end (- (point) 2)) |
863 (save-excursion | 863 (save-excursion |
864 (backward-char 1) | 864 (backward-char 1) |
865 (delete-char 1) | 865 (delete-char 1) |
866 (goto-char quote-beg) | 866 (goto-char quote-beg) |
867 (delete-char 1)) | 867 (delete-char 1)) |
868 (undo-backslash-quoting quote-beg quote-end) | 868 (mail-undo-backslash-quoting quote-beg quote-end) |
869 (or (eq mail-space-char (char-after (point))) | 869 (or (eq mail-space-char (char-after (point))) |
870 (insert " ")) | 870 (insert " ")) |
871 (setq \.-ends-name t)) | 871 (setq \.-ends-name t)) |
872 ((eq char ?.) | 872 ((eq char ?.) |
873 (if (eq (char-after (1+ (point))) ?_) | 873 (if (eq (char-after (1+ (point))) ?_) |
893 (replace-match "\\1 ")) | 893 (replace-match "\\1 ")) |
894 (goto-char (point-max)))))))) | 894 (goto-char (point-max)))))))) |
895 | 895 |
896 (set-syntax-table address-text-syntax-table) | 896 (set-syntax-table address-text-syntax-table) |
897 | 897 |
898 (setq xxx (variant-method (buffer-string))) | 898 (setq xxx (mail-variant-method (buffer-string))) |
899 (delete-region (point-min) (point-max)) | 899 (delete-region (point-min) (point-max)) |
900 (insert xxx) | 900 (insert xxx) |
901 (goto-char (point-min)) | 901 (goto-char (point-min)) |
902 | 902 |
903 ;; ;; Compress whitespace | 903 ;; ;; Compress whitespace |
914 ;; (goto-char (point-max)) | 914 ;; (goto-char (point-max)) |
915 ;; (skip-chars-backward mail-whitespace) | 915 ;; (skip-chars-backward mail-whitespace) |
916 ;; (cond ((memq (char-after (1- (point))) '(?\) ?\} ?\])) | 916 ;; (cond ((memq (char-after (1- (point))) '(?\) ?\} ?\])) |
917 ;; (setq comment-end (point)) | 917 ;; (setq comment-end (point)) |
918 ;; (set-syntax-table address-text-comment-syntax-table) | 918 ;; (set-syntax-table address-text-comment-syntax-table) |
919 ;; (or (safe-move-sexp -1) | 919 ;; (or (mail-safe-move-sexp -1) |
920 ;; (backward-char 1)) | 920 ;; (backward-char 1)) |
921 ;; (set-syntax-table address-text-syntax-table) | 921 ;; (set-syntax-table address-text-syntax-table) |
922 ;; (setq comment-beg (point)) | 922 ;; (setq comment-beg (point)) |
923 ;; (skip-chars-backward mail-whitespace) | 923 ;; (skip-chars-backward mail-whitespace) |
924 ;; (if (bobp) | 924 ;; (if (bobp) |
1070 (set-buffer canonicalization-buffer) | 1070 (set-buffer canonicalization-buffer) |
1071 (buffer-string))) | 1071 (buffer-string))) |
1072 ))) | 1072 ))) |
1073 | 1073 |
1074 ;; TODO: put this back in the above function now that it's proven: | 1074 ;; TODO: put this back in the above function now that it's proven: |
1075 (defun variant-method (string) | 1075 (defun mail-variant-method (string) |
1076 (let ((variant-buffer (get-buffer-create "*variant method buffer*")) | 1076 (let ((variant-buffer (get-buffer-create "*variant method buffer*")) |
1077 (word-count 0) | 1077 (word-count 0) |
1078 mixed-case-flag lower-case-flag upper-case-flag | 1078 mixed-case-flag lower-case-flag upper-case-flag |
1079 suffix-flag last-name-comma-flag | 1079 suffix-flag last-name-comma-flag |
1080 comment-beg comment-end initial beg end | 1080 comment-beg comment-end initial beg end |
1181 (if (eq ?\' (following-char)) | 1181 (if (eq ?\' (following-char)) |
1182 (forward-char 1)) | 1182 (forward-char 1)) |
1183 (or (search-forward "'" nil t) | 1183 (or (search-forward "'" nil t) |
1184 (delete-char 1))) | 1184 (delete-char 1))) |
1185 (t | 1185 (t |
1186 (or (safe-move-sexp 1) | 1186 (or (mail-safe-move-sexp 1) |
1187 (goto-char (point-max))))) | 1187 (goto-char (point-max))))) |
1188 (set-syntax-table address-text-syntax-table) | 1188 (set-syntax-table address-text-syntax-table) |
1189 (setq comment-end (point)) | 1189 (setq comment-end (point)) |
1190 (cond | 1190 (cond |
1191 ;; Handle case of entire name being quoted | 1191 ;; Handle case of entire name being quoted |