Mercurial > hg > xemacs-beta

comparison lisp/utils/mail-extr.el @ 159:3bb7ccffb0c0 r20-3b6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b6
author cvs
date Mon, 13 Aug 2007 09:41:43 +0200
parents 8619ce7e4c50
children a2f645c6b9f8
comparison
equal deleted inserted replaced
158:558dfa75ffb3 159:3bb7ccffb0c0
1146 (car !-pos)) 1146 (car !-pos))
1147 (mail-extr-delete-char 1) 1147 (mail-extr-delete-char 1)
1148 (or (save-excursion 1148 (or (save-excursion
1149 (mail-extr-safe-move-sexp -1) 1149 (mail-extr-safe-move-sexp -1)
1150 (mail-extr-skip-whitespace-backward) 1150 (mail-extr-skip-whitespace-backward)
1151 (eq ?. (preceding-char))) 1151 (eq ?. (char-before)))
1152 (insert-before-markers 1152 (insert-before-markers
1153 (if (save-excursion 1153 (if (save-excursion
1154 (mail-extr-skip-whitespace-backward) 1154 (mail-extr-skip-whitespace-backward)
1155 (eq ?. (preceding-char))) 1155 (eq ?. (char-before)))
1156 "" 1156 ""
1157 ".") 1157 ".")
1158 "uucp")) 1158 "uucp"))
1159 (setq !-pos (cdr !-pos)))) 1159 (setq !-pos (cdr !-pos))))
1160 (and saved-%-pos 1160 (and saved-%-pos
1186 (mail-extr-skip-whitespace-backward) 1186 (mail-extr-skip-whitespace-backward)
1187 (save-excursion 1187 (save-excursion
1188 (mail-extr-safe-move-sexp -1) 1188 (mail-extr-safe-move-sexp -1)
1189 (setq domain-pos (point)) 1189 (setq domain-pos (point))
1190 (mail-extr-skip-whitespace-backward) 1190 (mail-extr-skip-whitespace-backward)
1191 (setq \.-pos (eq ?. (preceding-char)))) 1191 (setq \.-pos (eq ?. (char-before))))
1192 (cond ((and \.-pos 1192 (cond ((and \.-pos
1193 ;; #### string consing 1193 ;; #### string consing
1194 (let ((s (intern-soft 1194 (let ((s (intern-soft
1195 (buffer-substring domain-pos (point)) 1195 (buffer-substring domain-pos (point))
1196 all-top-level-domains))) 1196 all-top-level-domains)))
1528 ;; Stop after name suffix 1528 ;; Stop after name suffix
1529 ((and (>= word-count 2) 1529 ((and (>= word-count 2)
1530 (looking-at mail-extr-full-name-suffix-pattern)) 1530 (looking-at mail-extr-full-name-suffix-pattern))
1531 (mail-extr-skip-whitespace-backward) 1531 (mail-extr-skip-whitespace-backward)
1532 (setq suffix-flag (point)) 1532 (setq suffix-flag (point))
1533 (if (eq ?, (following-char)) 1533 (if (eq ?, (char-after))
1534 (forward-char 1) 1534 (forward-char 1)
1535 (insert ?,)) 1535 (insert ?,))
1536 ;; Enforce at least one space after comma 1536 ;; Enforce at least one space after comma
1537 (or (eq ?\ (following-char)) 1537 (or (eq ?\ (char-after))
1538 (insert ?\ )) 1538 (insert ?\ ))
1539 (mail-extr-skip-whitespace-forward) 1539 (mail-extr-skip-whitespace-forward)
1540 (cond ((memq (following-char) '(?j ?J ?s ?S)) 1540 (cond ((memq (char-after) '(?j ?J ?s ?S))
1541 (capitalize-word 1) 1541 (capitalize-word 1)
1542 (if (eq (following-char) ?.) 1542 (if (eq (char-after) ?.)
1543 (forward-char 1) 1543 (forward-char 1)
1544 (insert ?.))) 1544 (insert ?.)))
1545 (t 1545 (t
1546 (upcase-word 1))) 1546 (upcase-word 1)))
1547 (setq word-found-flag t) 1547 (setq word-found-flag t)
1552 (goto-char (match-beginning 1)) 1552 (goto-char (match-beginning 1))
1553 (narrow-to-region (point) (point-max)) 1553 (narrow-to-region (point) (point-max))
1554 (setq begin-again-flag t)) 1554 (setq begin-again-flag t))
1555 1555
1556 ;; Check for initial last name followed by comma 1556 ;; Check for initial last name followed by comma
1557 ((and (eq ?, (following-char)) 1557 ((and (eq ?, (char-after))
1558 (eq word-count 1)) 1558 (eq word-count 1))
1559 (forward-char 1) 1559 (forward-char 1)
1560 (setq last-name-comma-flag t) 1560 (setq last-name-comma-flag t)
1561 (or (eq ?\ (following-char)) 1561 (or (eq ?\ (char-after))
1562 (insert ?\ ))) 1562 (insert ?\ )))
1563 1563
1564 ;; Stop before trailing comma-separated comment 1564 ;; Stop before trailing comma-separated comment
1565 ;; THIS CASE MUST BE AFTER THE PRECEDING CASES. 1565 ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
1566 ;; *** This case is redundant??? 1566 ;; *** This case is redundant???
1567 ;;((eq ?, (following-char)) 1567 ;;((eq ?, (char-after))
1568 ;; (setq name-done-flag t)) 1568 ;; (setq name-done-flag t))
1569 1569
1570 ;; Delete parenthesized/quoted comment/nickname 1570 ;; Delete parenthesized/quoted comment/nickname
1571 ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`)) 1571 ((memq (char-after) '(?\( ?\{ ?\[ ?\" ?\' ?\`))
1572 (setq cbeg (point)) 1572 (setq cbeg (point))
1573 (set-syntax-table mail-extr-address-text-comment-syntax-table) 1573 (set-syntax-table mail-extr-address-text-comment-syntax-table)
1574 (cond ((memq (following-char) '(?\' ?\`)) 1574 (cond ((memq (char-after) '(?\' ?\`))
1575 (or (search-forward "'" nil t 1575 (or (search-forward "'" nil t
1576 (if (eq ?\' (following-char)) 2 1)) 1576 (if (eq ?\' (char-after)) 2 1))
1577 (mail-extr-delete-char 1))) 1577 (mail-extr-delete-char 1)))
1578 (t 1578 (t
1579 (or (mail-extr-safe-move-sexp 1) 1579 (or (mail-extr-safe-move-sexp 1)
1580 (goto-char (point-max))))) 1580 (goto-char (point-max)))))
1581 (set-syntax-table mail-extr-address-text-syntax-table) 1581 (set-syntax-table mail-extr-address-text-syntax-table)
1599 (if initial 1599 (if initial
1600 (insert initial ". "))))) 1600 (insert initial ". ")))))
1601 1601
1602 ;; Handle & substitution 1602 ;; Handle & substitution
1603 ((and (or (bobp) 1603 ((and (or (bobp)
1604 (eq ?\ (preceding-char))) 1604 (eq ?\ (char-before)))
1605 (looking-at "&\\( \\|\\'\\)")) 1605 (looking-at "&\\( \\|\\'\\)"))
1606 (mail-extr-delete-char 1) 1606 (mail-extr-delete-char 1)
1607 (capitalize-region 1607 (capitalize-region
1608 (point) 1608 (point)
1609 (progn 1609 (progn
1614 (setq word-found-flag t)) 1614 (setq word-found-flag t))
1615 1615
1616 ;; Handle *Stupid* VMS date stamps 1616 ;; Handle *Stupid* VMS date stamps
1617 ((looking-at mail-extr-stupid-vms-date-stamp-pattern) 1617 ((looking-at mail-extr-stupid-vms-date-stamp-pattern)
1618 (replace-match "" t)) 1618 (replace-match "" t))
1619 1619
1620 ;; Handle Chinese characters. 1620 ;; Handle Chinese characters.
1621 ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern) 1621 ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern)
1622 (goto-char (match-end 0)) 1622 (goto-char (match-end 0))
1623 (setq word-found-flag t)) 1623 (setq word-found-flag t))
1624 1624
1656 ((looking-at mail-extr-ham-call-sign-pattern) 1656 ((looking-at mail-extr-ham-call-sign-pattern)
1657 (delete-region (match-beginning 0) (match-end 0))) 1657 (delete-region (match-beginning 0) (match-end 0)))
1658 1658
1659 ;; Fixup initials 1659 ;; Fixup initials
1660 ((looking-at mail-extr-initial-pattern) 1660 ((looking-at mail-extr-initial-pattern)
1661 (or (eq (following-char) (upcase (following-char))) 1661 (or (eq (char-after) (upcase (char-after)))
1662 (setq lower-case-flag t)) 1662 (setq lower-case-flag t))
1663 (forward-char 1) 1663 (forward-char 1)
1664 (if (eq ?. (following-char)) 1664 (if (eq ?. (char-after))
1665 (forward-char 1) 1665 (forward-char 1)
1666 (insert ?.)) 1666 (insert ?.))
1667 (or (eq ?\ (following-char)) 1667 (or (eq ?\ (char-after))
1668 (insert ?\ )) 1668 (insert ?\ ))
1669 (setq word-found-flag t)) 1669 (setq word-found-flag t))
1670 1670
1671 ;; Handle BITNET LISTSERV list names. 1671 ;; Handle BITNET LISTSERV list names.
1672 ((and (eq word-count 0) 1672 ((and (eq word-count 0)
1673 (looking-at mail-extr-listserv-list-name-pattern)) 1673 (looking-at mail-extr-listserv-list-name-pattern))
1674 (narrow-to-region (match-beginning 1) (match-end 1)) 1674 (narrow-to-region (match-beginning 1) (match-end 1))
1675 (setq word-found-flag t) 1675 (setq word-found-flag t)
1676 (setq name-done-flag t)) 1676 (setq name-done-flag t))
1677 1677
1678 ;; Regular name words 1678 ;; Regular name words
1679 ((looking-at mail-extr-name-pattern) 1679 ((looking-at mail-extr-name-pattern)
1680 (setq name-beg (point)) 1680 (setq name-beg (point))
1681 (setq name-end (match-end 0)) 1681 (setq name-end (match-end 0))
1682 1682
1683 ;; Certain words will be dropped if they are at the end. 1683 ;; Certain words will be dropped if they are at the end.
1684 (and (>= word-count 2) 1684 (and (>= word-count 2)
1685 (not lower-case-flag) 1685 (not lower-case-flag)
1686 (or 1686 (or
1687 ;; A trailing 4-or-more letter lowercase words preceded by 1687 ;; A trailing 4-or-more letter lowercase words preceded by
1744 (cond (last-name-comma-flag 1744 (cond (last-name-comma-flag
1745 (goto-char (point-min)) 1745 (goto-char (point-min))
1746 (search-forward ",") 1746 (search-forward ",")
1747 (setq name-end (1- (point))) 1747 (setq name-end (1- (point)))
1748 (goto-char (or suffix-flag (point-max))) 1748 (goto-char (or suffix-flag (point-max)))
1749 (or (eq ?\ (preceding-char)) 1749 (or (eq ?\ (char-before))
1750 (insert ?\ )) 1750 (insert ?\ ))
1751 (insert-buffer-substring (current-buffer) (point-min) name-end) 1751 (insert-buffer-substring (current-buffer) (point-min) name-end)
1752 (goto-char name-end) 1752 (goto-char name-end)
1753 (skip-chars-forward "\t ,") 1753 (skip-chars-forward "\t ,")
1754 (narrow-to-region (point) (point-max)))) 1754 (narrow-to-region (point) (point-max))))
1755 1755
1756 ;; Delete leading and trailing junk characters. 1756 ;; Delete leading and trailing junk characters.
1757 ;; *** This is probably completly unneeded now. 1757 ;; *** This is probably completly unneeded now.
1758 ;;(goto-char (point-max)) 1758 ;;(goto-char (point-max))
1759 ;;(skip-chars-backward mail-extr-non-end-name-chars) 1759 ;;(skip-chars-backward mail-extr-non-end-name-chars)
1760 ;;(if (eq ?. (following-char)) 1760 ;;(if (eq ?. (char-after))
1761 ;; (forward-char 1)) 1761 ;; (forward-char 1))
1762 ;;(narrow-to-region (point) 1762 ;;(narrow-to-region (point)
1763 ;; (progn 1763 ;; (progn
1764 ;; (goto-char (point-min)) 1764 ;; (goto-char (point-min))
1765 ;; (skip-chars-forward mail-extr-non-begin-name-chars) 1765 ;; (skip-chars-forward mail-extr-non-begin-name-chars)