1434 |
(if all (nreverse value-list) (car value-list)) |
(if all (nreverse value-list) (car value-list)) |
1435 |
)) |
)) |
1436 |
|
|
1437 |
|
(defcustom mail-extr-disable-voodoo "\\cj" |
1438 |
|
"*If it is a regexp, names matching it will never be modified. |
1439 |
|
If it is neither nil nor a string, modifying of names will never take |
1440 |
|
place. It affects how `mail-extract-address-components' works." |
1441 |
|
:type '(choice (regexp :size 0) |
1442 |
|
(const :tag "Always enabled" nil) |
1443 |
|
(const :tag "Always disabled" t)) |
1444 |
|
:group 'mail-extr) |
1445 |
|
|
1446 |
(defun mail-extr-voodoo (mbox-beg mbox-end canonicalization-buffer) |
(defun mail-extr-voodoo (mbox-beg mbox-end canonicalization-buffer) |
1447 |
(let ((word-count 0) |
(unless (and mail-extr-disable-voodoo |
1448 |
(case-fold-search nil) |
(or (not (stringp mail-extr-disable-voodoo)) |
1449 |
mixed-case-flag lower-case-flag ;;upper-case-flag |
(progn |
1450 |
suffix-flag last-name-comma-flag |
(goto-char (point-min)) |
1451 |
;;cbeg cend |
(re-search-forward mail-extr-disable-voodoo nil t)))) |
1452 |
initial |
(let ((word-count 0) |
1453 |
begin-again-flag |
(case-fold-search nil) |
1454 |
drop-this-word-if-trailing-flag |
mixed-case-flag lower-case-flag ;;upper-case-flag |
1455 |
drop-last-word-if-trailing-flag |
suffix-flag last-name-comma-flag |
1456 |
word-found-flag |
;;cbeg cend |
1457 |
this-word-beg last-word-beg |
initial |
1458 |
name-beg name-end |
begin-again-flag |
1459 |
name-done-flag |
drop-this-word-if-trailing-flag |
1460 |
) |
drop-last-word-if-trailing-flag |
1461 |
(save-excursion |
word-found-flag |
1462 |
(set-syntax-table mail-extr-address-text-syntax-table) |
this-word-beg last-word-beg |
1463 |
|
name-beg name-end |
1464 |
;; Get rid of comments. |
name-done-flag |
1465 |
(goto-char (point-min)) |
) |
1466 |
(while (not (eobp)) |
(save-excursion |
1467 |
;; Initialize for this iteration of the loop. |
(set-syntax-table mail-extr-address-text-syntax-table) |
|
(skip-chars-forward "^({[\"'`") |
|
|
(let ((cbeg (point))) |
|
|
(set-syntax-table mail-extr-address-text-comment-syntax-table) |
|
|
(if (memq (following-char) '(?\' ?\`)) |
|
|
(search-forward "'" nil 'move |
|
|
(if (eq ?\' (following-char)) 2 1)) |
|
|
(or (mail-extr-safe-move-sexp 1) |
|
|
(goto-char (point-max)))) |
|
|
(set-syntax-table mail-extr-address-text-syntax-table) |
|
|
(when (eq (char-after cbeg) ?\() |
|
|
;; Delete the comment itself. |
|
|
(delete-region cbeg (point)) |
|
|
;; Canonicalize whitespace where the comment was. |
|
|
(skip-chars-backward " \t") |
|
|
(if (looking-at "\\([ \t]+$\\|[ \t]+,\\)") |
|
|
(replace-match "") |
|
|
(setq cbeg (point)) |
|
|
(skip-chars-forward " \t") |
|
|
(if (bobp) |
|
|
(delete-region (point) cbeg) |
|
|
(just-one-space)))))) |
|
|
|
|
|
;; This was moved above. |
|
|
;; Fix . used as space |
|
|
;; But it belongs here because it occurs not only as |
|
|
;; rypens@reks.uia.ac.be (Piet.Rypens) |
|
|
;; but also as |
|
|
;; "Piet.Rypens" <rypens@reks.uia.ac.be> |
|
|
;;(goto-char (point-min)) |
|
|
;;(while (re-search-forward mail-extr-bad-dot-pattern nil t) |
|
|
;; (replace-match "\\1 \\2" t)) |
|
1468 |
|
|
1469 |
(unless (search-forward " " nil t) |
;; Get rid of comments. |
1470 |
(goto-char (point-min)) |
(goto-char (point-min)) |
1471 |
(cond ((search-forward "_" nil t) |
(while (not (eobp)) |
1472 |
;; Handle the *idiotic* use of underlines as spaces. |
;; Initialize for this iteration of the loop. |
1473 |
;; Example: fml@foo.bar.dom (First_M._Last) |
(skip-chars-forward "^({[\"'`") |
1474 |
(goto-char (point-min)) |
(let ((cbeg (point))) |
1475 |
(while (search-forward "_" nil t) |
(set-syntax-table mail-extr-address-text-comment-syntax-table) |
1476 |
(replace-match " " t))) |
(if (memq (following-char) '(?\' ?\`)) |
1477 |
((search-forward "." nil t) |
(search-forward "'" nil 'move |
1478 |
;; Fix . used as space |
(if (eq ?\' (following-char)) 2 1)) |
1479 |
;; Example: danj1@cb.att.com (daniel.jacobson) |
(or (mail-extr-safe-move-sexp 1) |
1480 |
(goto-char (point-min)) |
(goto-char (point-max)))) |
1481 |
(while (re-search-forward mail-extr-bad-dot-pattern nil t) |
(set-syntax-table mail-extr-address-text-syntax-table) |
1482 |
(replace-match "\\1 \\2" t))))) |
(when (eq (char-after cbeg) ?\() |
1483 |
|
;; Delete the comment itself. |
1484 |
;; Loop over the words (and other junk) in the name. |
(delete-region cbeg (point)) |
1485 |
(goto-char (point-min)) |
;; Canonicalize whitespace where the comment was. |
1486 |
(while (not name-done-flag) |
(skip-chars-backward " \t") |
1487 |
|
(if (looking-at "\\([ \t]+$\\|[ \t]+,\\)") |
1488 |
(when word-found-flag |
(replace-match "") |
1489 |
;; Last time through this loop we skipped over a word. |
(setq cbeg (point)) |
1490 |
(setq last-word-beg this-word-beg) |
(skip-chars-forward " \t") |
1491 |
(setq drop-last-word-if-trailing-flag |
(if (bobp) |
1492 |
drop-this-word-if-trailing-flag) |
(delete-region (point) cbeg) |
1493 |
(setq word-found-flag nil)) |
(just-one-space)))))) |
1494 |
|
|
1495 |
(when begin-again-flag |
;; This was moved above. |
1496 |
;; Last time through the loop we found something that |
;; Fix . used as space |
1497 |
;; indicates we should pretend we are beginning again from |
;; But it belongs here because it occurs not only as |
1498 |
;; the start. |
;; rypens@reks.uia.ac.be (Piet.Rypens) |
1499 |
(setq word-count 0) |
;; but also as |
1500 |
(setq last-word-beg nil) |
;; "Piet.Rypens" <rypens@reks.uia.ac.be> |
1501 |
(setq drop-last-word-if-trailing-flag nil) |
;;(goto-char (point-min)) |
1502 |
(setq mixed-case-flag nil) |
;;(while (re-search-forward mail-extr-bad-dot-pattern nil t) |
1503 |
(setq lower-case-flag nil) |
;; (replace-match "\\1 \\2" t)) |
1504 |
;; (setq upper-case-flag nil) |
|
1505 |
(setq begin-again-flag nil)) |
(unless (search-forward " " nil t) |
1506 |
|
(goto-char (point-min)) |
1507 |
;; Initialize for this iteration of the loop. |
(cond ((search-forward "_" nil t) |
1508 |
(mail-extr-skip-whitespace-forward) |
;; Handle the *idiotic* use of underlines as spaces. |
1509 |
(if (eq word-count 0) (narrow-to-region (point) (point-max))) |
;; Example: fml@foo.bar.dom (First_M._Last) |
1510 |
(setq this-word-beg (point)) |
(goto-char (point-min)) |
1511 |
(setq drop-this-word-if-trailing-flag nil) |
(while (search-forward "_" nil t) |
1512 |
|
(replace-match " " t))) |
1513 |
;; Decide what to do based on what we are looking at. |
((search-forward "." nil t) |
1514 |
(cond |
;; Fix . used as space |
1515 |
|
;; Example: danj1@cb.att.com (daniel.jacobson) |
1516 |
;; Delete title |
(goto-char (point-min)) |
1517 |
((and (eq word-count 0) |
(while (re-search-forward mail-extr-bad-dot-pattern nil t) |
1518 |
(looking-at mail-extr-full-name-prefixes)) |
(replace-match "\\1 \\2" t))))) |
|
(goto-char (match-end 0)) |
|
|
(narrow-to-region (point) (point-max))) |
|
1519 |
|
|
1520 |
;; Stop after name suffix |
;; Loop over the words (and other junk) in the name. |
1521 |
((and (>= word-count 2) |
(goto-char (point-min)) |
1522 |
(looking-at mail-extr-full-name-suffix-pattern)) |
(while (not name-done-flag) |
1523 |
(mail-extr-skip-whitespace-backward) |
|
1524 |
(setq suffix-flag (point)) |
(when word-found-flag |
1525 |
(if (eq ?, (following-char)) |
;; Last time through this loop we skipped over a word. |
1526 |
(forward-char 1) |
(setq last-word-beg this-word-beg) |
1527 |
(insert ?,)) |
(setq drop-last-word-if-trailing-flag |
1528 |
;; Enforce at least one space after comma |
drop-this-word-if-trailing-flag) |
1529 |
(or (eq ?\ (following-char)) |
(setq word-found-flag nil)) |
1530 |
(insert ?\ )) |
|
1531 |
|
(when begin-again-flag |
1532 |
|
;; Last time through the loop we found something that |
1533 |
|
;; indicates we should pretend we are beginning again from |
1534 |
|
;; the start. |
1535 |
|
(setq word-count 0) |
1536 |
|
(setq last-word-beg nil) |
1537 |
|
(setq drop-last-word-if-trailing-flag nil) |
1538 |
|
(setq mixed-case-flag nil) |
1539 |
|
(setq lower-case-flag nil) |
1540 |
|
;; (setq upper-case-flag nil) |
1541 |
|
(setq begin-again-flag nil)) |
1542 |
|
|
1543 |
|
;; Initialize for this iteration of the loop. |
1544 |
(mail-extr-skip-whitespace-forward) |
(mail-extr-skip-whitespace-forward) |
1545 |
(cond ((memq (following-char) '(?j ?J ?s ?S)) |
(if (eq word-count 0) (narrow-to-region (point) (point-max))) |
1546 |
(capitalize-word 1) |
(setq this-word-beg (point)) |
1547 |
(if (eq (following-char) ?.) |
(setq drop-this-word-if-trailing-flag nil) |
|
(forward-char 1) |
|
|
(insert ?.))) |
|
|
(t |
|
|
(upcase-word 1))) |
|
|
(setq word-found-flag t) |
|
|
(setq name-done-flag t)) |
|
|
|
|
|
;; Handle SCA names |
|
|
((looking-at "MKA \\(.+\\)") ; "Mundanely Known As" |
|
|
(goto-char (match-beginning 1)) |
|
|
(narrow-to-region (point) (point-max)) |
|
|
(setq begin-again-flag t)) |
|
|
|
|
|
;; Check for initial last name followed by comma |
|
|
((and (eq ?, (following-char)) |
|
|
(eq word-count 1)) |
|
|
(forward-char 1) |
|
|
(setq last-name-comma-flag t) |
|
|
(or (eq ?\ (following-char)) |
|
|
(insert ?\ ))) |
|
|
|
|
|
;; Stop before trailing comma-separated comment |
|
|
;; THIS CASE MUST BE AFTER THE PRECEDING CASES. |
|
|
;; *** This case is redundant??? |
|
|
;;((eq ?, (following-char)) |
|
|
;; (setq name-done-flag t)) |
|
|
|
|
|
;; Delete parenthesized/quoted comment/nickname |
|
|
((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`)) |
|
|
(setq cbeg (point)) |
|
|
(set-syntax-table mail-extr-address-text-comment-syntax-table) |
|
|
(cond ((memq (following-char) '(?\' ?\`)) |
|
|
(or (search-forward "'" nil t |
|
|
(if (eq ?\' (following-char)) 2 1)) |
|
|
(delete-char 1))) |
|
|
(t |
|
|
(or (mail-extr-safe-move-sexp 1) |
|
|
(goto-char (point-max))))) |
|
|
(set-syntax-table mail-extr-address-text-syntax-table) |
|
|
(setq cend (point)) |
|
|
(cond |
|
|
;; Handle case of entire name being quoted |
|
|
((and (eq word-count 0) |
|
|
(looking-at " *\\'") |
|
|
(>= (- cend cbeg) 2)) |
|
|
(narrow-to-region (1+ cbeg) (1- cend)) |
|
|
(goto-char (point-min))) |
|
|
(t |
|
|
;; Handle case of quoted initial |
|
|
(if (and (or (= 3 (- cend cbeg)) |
|
|
(and (= 4 (- cend cbeg)) |
|
|
(eq ?. (char-after (+ 2 cbeg))))) |
|
|
(not (looking-at " *\\'"))) |
|
|
(setq initial (char-after (1+ cbeg))) |
|
|
(setq initial nil)) |
|
|
(delete-region cbeg cend) |
|
|
(if initial |
|
|
(insert initial ". "))))) |
|
|
|
|
|
;; Handle *Stupid* VMS date stamps |
|
|
((looking-at mail-extr-stupid-vms-date-stamp-pattern) |
|
|
(replace-match "" t)) |
|
|
|
|
|
;; Handle Chinese characters. |
|
|
((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern) |
|
|
(goto-char (match-end 0)) |
|
|
(setq word-found-flag t)) |
|
|
|
|
|
;; Skip initial garbage characters. |
|
|
;; THIS CASE MUST BE AFTER THE PRECEDING CASES. |
|
|
((and (eq word-count 0) |
|
|
(looking-at mail-extr-leading-garbage)) |
|
|
(goto-char (match-end 0)) |
|
|
;; *** Skip backward over these??? |
|
|
;; (skip-chars-backward "& \"") |
|
|
(narrow-to-region (point) (point-max))) |
|
1548 |
|
|
1549 |
;; Various stopping points |
;; Decide what to do based on what we are looking at. |
1550 |
((or |
(cond |
1551 |
|
|
1552 |
;; Stop before ALL CAPS acronyms, if preceded by mixed-case |
;; Delete title |
1553 |
;; words. Example: XT-DEM. |
((and (eq word-count 0) |
1554 |
(and (>= word-count 2) |
(looking-at mail-extr-full-name-prefixes)) |
1555 |
mixed-case-flag |
(goto-char (match-end 0)) |
1556 |
(looking-at mail-extr-weird-acronym-pattern) |
(narrow-to-region (point) (point-max))) |
1557 |
(not (looking-at mail-extr-roman-numeral-pattern))) |
|
1558 |
|
;; Stop after name suffix |
1559 |
;; Stop before trailing alternative address |
((and (>= word-count 2) |
1560 |
(looking-at mail-extr-alternative-address-pattern) |
(looking-at mail-extr-full-name-suffix-pattern)) |
1561 |
|
(mail-extr-skip-whitespace-backward) |
1562 |
;; Stop before trailing comment not introduced by comma |
(setq suffix-flag (point)) |
1563 |
;; THIS CASE MUST BE AFTER AN EARLIER CASE. |
(if (eq ?, (following-char)) |
1564 |
(looking-at mail-extr-trailing-comment-start-pattern) |
(forward-char 1) |
1565 |
|
(insert ?,)) |
1566 |
;; Stop before telephone numbers |
;; Enforce at least one space after comma |
1567 |
(and (>= word-count 1) |
(or (eq ?\ (following-char)) |
1568 |
(looking-at mail-extr-telephone-extension-pattern))) |
(insert ?\ )) |
1569 |
(setq name-done-flag t)) |
(mail-extr-skip-whitespace-forward) |
1570 |
|
(cond ((memq (following-char) '(?j ?J ?s ?S)) |
1571 |
;; Delete ham radio call signs |
(capitalize-word 1) |
1572 |
((looking-at mail-extr-ham-call-sign-pattern) |
(if (eq (following-char) ?.) |
1573 |
(delete-region (match-beginning 0) (match-end 0))) |
(forward-char 1) |
1574 |
|
(insert ?.))) |
1575 |
;; Fixup initials |
(t |
1576 |
((looking-at mail-extr-initial-pattern) |
(upcase-word 1))) |
1577 |
(or (eq (following-char) (upcase (following-char))) |
(setq word-found-flag t) |
1578 |
(setq lower-case-flag t)) |
(setq name-done-flag t)) |
1579 |
(forward-char 1) |
|
1580 |
(if (eq ?. (following-char)) |
;; Handle SCA names |
1581 |
(forward-char 1) |
((looking-at "MKA \\(.+\\)") ; "Mundanely Known As" |
1582 |
(insert ?.)) |
(goto-char (match-beginning 1)) |
1583 |
(or (eq ?\ (following-char)) |
(narrow-to-region (point) (point-max)) |
1584 |
(insert ?\ )) |
(setq begin-again-flag t)) |
1585 |
(setq word-found-flag t)) |
|
1586 |
|
;; Check for initial last name followed by comma |
1587 |
|
((and (eq ?, (following-char)) |
1588 |
|
(eq word-count 1)) |
1589 |
|
(forward-char 1) |
1590 |
|
(setq last-name-comma-flag t) |
1591 |
|
(or (eq ?\ (following-char)) |
1592 |
|
(insert ?\ ))) |
1593 |
|
|
1594 |
|
;; Stop before trailing comma-separated comment |
1595 |
|
;; THIS CASE MUST BE AFTER THE PRECEDING CASES. |
1596 |
|
;; *** This case is redundant??? |
1597 |
|
;;((eq ?, (following-char)) |
1598 |
|
;; (setq name-done-flag t)) |
1599 |
|
|
1600 |
|
;; Delete parenthesized/quoted comment/nickname |
1601 |
|
((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`)) |
1602 |
|
(setq cbeg (point)) |
1603 |
|
(set-syntax-table mail-extr-address-text-comment-syntax-table) |
1604 |
|
(cond ((memq (following-char) '(?\' ?\`)) |
1605 |
|
(or (search-forward "'" nil t |
1606 |
|
(if (eq ?\' (following-char)) 2 1)) |
1607 |
|
(delete-char 1))) |
1608 |
|
(t |
1609 |
|
(or (mail-extr-safe-move-sexp 1) |
1610 |
|
(goto-char (point-max))))) |
1611 |
|
(set-syntax-table mail-extr-address-text-syntax-table) |
1612 |
|
(setq cend (point)) |
1613 |
|
(cond |
1614 |
|
;; Handle case of entire name being quoted |
1615 |
|
((and (eq word-count 0) |
1616 |
|
(looking-at " *\\'") |
1617 |
|
(>= (- cend cbeg) 2)) |
1618 |
|
(narrow-to-region (1+ cbeg) (1- cend)) |
1619 |
|
(goto-char (point-min))) |
1620 |
|
(t |
1621 |
|
;; Handle case of quoted initial |
1622 |
|
(if (and (or (= 3 (- cend cbeg)) |
1623 |
|
(and (= 4 (- cend cbeg)) |
1624 |
|
(eq ?. (char-after (+ 2 cbeg))))) |
1625 |
|
(not (looking-at " *\\'"))) |
1626 |
|
(setq initial (char-after (1+ cbeg))) |
1627 |
|
(setq initial nil)) |
1628 |
|
(delete-region cbeg cend) |
1629 |
|
(if initial |
1630 |
|
(insert initial ". "))))) |
1631 |
|
|
1632 |
|
;; Handle *Stupid* VMS date stamps |
1633 |
|
((looking-at mail-extr-stupid-vms-date-stamp-pattern) |
1634 |
|
(replace-match "" t)) |
1635 |
|
|
1636 |
|
;; Handle Chinese characters. |
1637 |
|
((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern) |
1638 |
|
(goto-char (match-end 0)) |
1639 |
|
(setq word-found-flag t)) |
1640 |
|
|
1641 |
;; Handle BITNET LISTSERV list names. |
;; Skip initial garbage characters. |
1642 |
((and (eq word-count 0) |
;; THIS CASE MUST BE AFTER THE PRECEDING CASES. |
1643 |
(looking-at mail-extr-listserv-list-name-pattern)) |
((and (eq word-count 0) |
1644 |
(narrow-to-region (match-beginning 1) (match-end 1)) |
(looking-at mail-extr-leading-garbage)) |
1645 |
(setq word-found-flag t) |
(goto-char (match-end 0)) |
1646 |
(setq name-done-flag t)) |
;; *** Skip backward over these??? |
1647 |
|
;; (skip-chars-backward "& \"") |
1648 |
;; Handle & substitution, when & is last and is not first. |
(narrow-to-region (point) (point-max))) |
1649 |
((and (> word-count 0) |
|
1650 |
(eq ?\ (preceding-char)) |
;; Various stopping points |
1651 |
(eq (following-char) ?&) |
((or |
1652 |
(eq (1+ (point)) (point-max))) |
|
1653 |
(delete-char 1) |
;; Stop before ALL CAPS acronyms, if preceded by mixed-case |
1654 |
(capitalize-region |
;; words. Example: XT-DEM. |
1655 |
(point) |
(and (>= word-count 2) |
1656 |
(progn |
mixed-case-flag |
1657 |
(insert-buffer-substring canonicalization-buffer |
(looking-at mail-extr-weird-acronym-pattern) |
1658 |
mbox-beg mbox-end) |
(not (looking-at mail-extr-roman-numeral-pattern))) |
1659 |
(point))) |
|
1660 |
(setq disable-initial-guessing-flag t) |
;; Stop before trailing alternative address |
1661 |
(setq word-found-flag t)) |
(looking-at mail-extr-alternative-address-pattern) |
1662 |
|
|
1663 |
;; Handle & between names, as in "Bob & Susie". |
;; Stop before trailing comment not introduced by comma |
1664 |
((and (> word-count 0) (eq (following-char) ?\&)) |
;; THIS CASE MUST BE AFTER AN EARLIER CASE. |
1665 |
(setq name-beg (point)) |
(looking-at mail-extr-trailing-comment-start-pattern) |
1666 |
(setq name-end (1+ name-beg)) |
|
1667 |
(setq word-found-flag t) |
;; Stop before telephone numbers |
1668 |
(goto-char name-end)) |
(and (>= word-count 1) |
1669 |
|
(looking-at mail-extr-telephone-extension-pattern))) |
1670 |
;; Regular name words |
(setq name-done-flag t)) |
1671 |
((looking-at mail-extr-name-pattern) |
|
1672 |
(setq name-beg (point)) |
;; Delete ham radio call signs |
1673 |
(setq name-end (match-end 0)) |
((looking-at mail-extr-ham-call-sign-pattern) |
1674 |
|
(delete-region (match-beginning 0) (match-end 0))) |
1675 |
;; Certain words will be dropped if they are at the end. |
|
1676 |
(and (>= word-count 2) |
;; Fixup initials |
1677 |
(not lower-case-flag) |
((looking-at mail-extr-initial-pattern) |
1678 |
(or |
(or (eq (following-char) (upcase (following-char))) |
|
;; Trailing 4-or-more letter lowercase words preceded by |
|
|
;; mixed case or uppercase words will be dropped. |
|
|
(looking-at "[[:lower:]]\\{4,\\}[ \t]*\\'") |
|
|
;; Drop a trailing word which is terminated with a period. |
|
|
(eq ?. (char-after (1- name-end)))) |
|
|
(setq drop-this-word-if-trailing-flag t)) |
|
|
|
|
|
;; Set the flags that indicate whether we have seen a lowercase |
|
|
;; word, a mixed case word, and an uppercase word. |
|
|
(if (re-search-forward "[[:lower:]]" name-end t) |
|
|
(if (progn |
|
|
(goto-char name-beg) |
|
|
(re-search-forward "[[:upper:]]" name-end t)) |
|
|
(setq mixed-case-flag t) |
|
1679 |
(setq lower-case-flag t)) |
(setq lower-case-flag t)) |
1680 |
;; (setq upper-case-flag t) |
(forward-char 1) |
1681 |
) |
(if (eq ?. (following-char)) |
1682 |
|
(forward-char 1) |
1683 |
|
(insert ?.)) |
1684 |
|
(or (eq ?\ (following-char)) |
1685 |
|
(insert ?\ )) |
1686 |
|
(setq word-found-flag t)) |
1687 |
|
|
1688 |
(goto-char name-end) |
;; Handle BITNET LISTSERV list names. |
1689 |
(setq word-found-flag t)) |
((and (eq word-count 0) |
1690 |
|
(looking-at mail-extr-listserv-list-name-pattern)) |
1691 |
|
(narrow-to-region (match-beginning 1) (match-end 1)) |
1692 |
|
(setq word-found-flag t) |
1693 |
|
(setq name-done-flag t)) |
1694 |
|
|
1695 |
|
;; Handle & substitution, when & is last and is not first. |
1696 |
|
((and (> word-count 0) |
1697 |
|
(eq ?\ (preceding-char)) |
1698 |
|
(eq (following-char) ?&) |
1699 |
|
(eq (1+ (point)) (point-max))) |
1700 |
|
(delete-char 1) |
1701 |
|
(capitalize-region |
1702 |
|
(point) |
1703 |
|
(progn |
1704 |
|
(insert-buffer-substring canonicalization-buffer |
1705 |
|
mbox-beg mbox-end) |
1706 |
|
(point))) |
1707 |
|
(setq disable-initial-guessing-flag t) |
1708 |
|
(setq word-found-flag t)) |
1709 |
|
|
1710 |
|
;; Handle & between names, as in "Bob & Susie". |
1711 |
|
((and (> word-count 0) (eq (following-char) ?\&)) |
1712 |
|
(setq name-beg (point)) |
1713 |
|
(setq name-end (1+ name-beg)) |
1714 |
|
(setq word-found-flag t) |
1715 |
|
(goto-char name-end)) |
1716 |
|
|
1717 |
|
;; Regular name words |
1718 |
|
((looking-at mail-extr-name-pattern) |
1719 |
|
(setq name-beg (point)) |
1720 |
|
(setq name-end (match-end 0)) |
1721 |
|
|
1722 |
|
;; Certain words will be dropped if they are at the end. |
1723 |
|
(and (>= word-count 2) |
1724 |
|
(not lower-case-flag) |
1725 |
|
(or |
1726 |
|
;; Trailing 4-or-more letter lowercase words preceded by |
1727 |
|
;; mixed case or uppercase words will be dropped. |
1728 |
|
(looking-at "[[:lower:]]\\{4,\\}[ \t]*\\'") |
1729 |
|
;; Drop a trailing word which is terminated with a period. |
1730 |
|
(eq ?. (char-after (1- name-end)))) |
1731 |
|
(setq drop-this-word-if-trailing-flag t)) |
1732 |
|
|
1733 |
|
;; Set the flags that indicate whether we have seen a lowercase |
1734 |
|
;; word, a mixed case word, and an uppercase word. |
1735 |
|
(if (re-search-forward "[[:lower:]]" name-end t) |
1736 |
|
(if (progn |
1737 |
|
(goto-char name-beg) |
1738 |
|
(re-search-forward "[[:upper:]]" name-end t)) |
1739 |
|
(setq mixed-case-flag t) |
1740 |
|
(setq lower-case-flag t)) |
1741 |
|
;; (setq upper-case-flag t) |
1742 |
|
) |
1743 |
|
|
1744 |
|
(goto-char name-end) |
1745 |
|
(setq word-found-flag t)) |
1746 |
|
|
1747 |
|
;; Allow a number as a word, if it doesn't mean anything else. |
1748 |
|
((looking-at "[0-9]+\\>") |
1749 |
|
(setq name-beg (point)) |
1750 |
|
(setq name-end (match-end 0)) |
1751 |
|
(goto-char name-end) |
1752 |
|
(setq word-found-flag t)) |
1753 |
|
|
1754 |
;; Allow a number as a word, if it doesn't mean anything else. |
(t |
1755 |
((looking-at "[0-9]+\\>") |
(setq name-done-flag t) |
1756 |
(setq name-beg (point)) |
)) |
1757 |
(setq name-end (match-end 0)) |
|
1758 |
|
;; Count any word that we skipped over. |
1759 |
|
(if word-found-flag |
1760 |
|
(setq word-count (1+ word-count)))) |
1761 |
|
|
1762 |
|
;; If the last thing in the name is 2 or more periods, or one or more |
1763 |
|
;; other sentence terminators (but not a single period) then keep them |
1764 |
|
;; and the preceding word. This is for the benefit of whole sentences |
1765 |
|
;; in the name field: it's better behavior than dropping the last word |
1766 |
|
;; of the sentence... |
1767 |
|
(if (and (not suffix-flag) |
1768 |
|
(looking-at "\\(\\.+\\|[?!;:.][?!;:.]+\\|[?!;:][?!;:.]*\\)\\'")) |
1769 |
|
(goto-char (setq suffix-flag (point-max)))) |
1770 |
|
|
1771 |
|
;; Drop everything after point and certain trailing words. |
1772 |
|
(narrow-to-region (point-min) |
1773 |
|
(or (and drop-last-word-if-trailing-flag |
1774 |
|
last-word-beg) |
1775 |
|
(point))) |
1776 |
|
|
1777 |
|
;; Xerox's mailers SUCK!!!!!! |
1778 |
|
;; We simply refuse to believe that any last name is PARC or ADOC. |
1779 |
|
;; If it looks like that is the last name, that there is no meaningful |
1780 |
|
;; here at all. Actually I guess it would be best to map patterns |
1781 |
|
;; like foo.hoser@xerox.com into foo@hoser.xerox.com, but I don't |
1782 |
|
;; actually know that that is what's going on. |
1783 |
|
(unless suffix-flag |
1784 |
|
(goto-char (point-min)) |
1785 |
|
(let ((case-fold-search t)) |
1786 |
|
(if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'") |
1787 |
|
(erase-buffer)))) |
1788 |
|
|
1789 |
|
;; If last name first put it at end (but before suffix) |
1790 |
|
(when last-name-comma-flag |
1791 |
|
(goto-char (point-min)) |
1792 |
|
(search-forward ",") |
1793 |
|
(setq name-end (1- (point))) |
1794 |
|
(goto-char (or suffix-flag (point-max))) |
1795 |
|
(or (eq ?\ (preceding-char)) |
1796 |
|
(insert ?\ )) |
1797 |
|
(insert-buffer-substring (current-buffer) (point-min) name-end) |
1798 |
(goto-char name-end) |
(goto-char name-end) |
1799 |
(setq word-found-flag t)) |
(skip-chars-forward "\t ,") |
1800 |
|
(narrow-to-region (point) (point-max))) |
1801 |
|
|
1802 |
(t |
;; Delete leading and trailing junk characters. |
1803 |
(setq name-done-flag t) |
;; *** This is probably completely unneeded now. |
1804 |
)) |
;;(goto-char (point-max)) |
1805 |
|
;;(skip-chars-backward mail-extr-non-end-name-chars) |
1806 |
;; Count any word that we skipped over. |
;;(if (eq ?. (following-char)) |
1807 |
(if word-found-flag |
;; (forward-char 1)) |
1808 |
(setq word-count (1+ word-count)))) |
;;(narrow-to-region (point) |
1809 |
|
;; (progn |
1810 |
;; If the last thing in the name is 2 or more periods, or one or more |
;; (goto-char (point-min)) |
1811 |
;; other sentence terminators (but not a single period) then keep them |
;; (skip-chars-forward mail-extr-non-begin-name-chars) |
1812 |
;; and the preceding word. This is for the benefit of whole sentences |
;; (point))) |
|
;; in the name field: it's better behavior than dropping the last word |
|
|
;; of the sentence... |
|
|
(if (and (not suffix-flag) |
|
|
(looking-at "\\(\\.+\\|[?!;:.][?!;:.]+\\|[?!;:][?!;:.]*\\)\\'")) |
|
|
(goto-char (setq suffix-flag (point-max)))) |
|
|
|
|
|
;; Drop everything after point and certain trailing words. |
|
|
(narrow-to-region (point-min) |
|
|
(or (and drop-last-word-if-trailing-flag |
|
|
last-word-beg) |
|
|
(point))) |
|
|
|
|
|
;; Xerox's mailers SUCK!!!!!! |
|
|
;; We simply refuse to believe that any last name is PARC or ADOC. |
|
|
;; If it looks like that is the last name, that there is no meaningful |
|
|
;; here at all. Actually I guess it would be best to map patterns |
|
|
;; like foo.hoser@xerox.com into foo@hoser.xerox.com, but I don't |
|
|
;; actually know that that is what's going on. |
|
|
(unless suffix-flag |
|
|
(goto-char (point-min)) |
|
|
(let ((case-fold-search t)) |
|
|
(if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'") |
|
|
(erase-buffer)))) |
|
1813 |
|
|
1814 |
;; If last name first put it at end (but before suffix) |
;; Compress whitespace |
|
(when last-name-comma-flag |
|
1815 |
(goto-char (point-min)) |
(goto-char (point-min)) |
1816 |
(search-forward ",") |
(while (re-search-forward "[ \t\n]+" nil t) |
1817 |
(setq name-end (1- (point))) |
(replace-match (if (eobp) "" " ") t)) |
1818 |
(goto-char (or suffix-flag (point-max))) |
)))) |
|
(or (eq ?\ (preceding-char)) |
|
|
(insert ?\ )) |
|
|
(insert-buffer-substring (current-buffer) (point-min) name-end) |
|
|
(goto-char name-end) |
|
|
(skip-chars-forward "\t ,") |
|
|
(narrow-to-region (point) (point-max))) |
|
|
|
|
|
;; Delete leading and trailing junk characters. |
|
|
;; *** This is probably completely unneeded now. |
|
|
;;(goto-char (point-max)) |
|
|
;;(skip-chars-backward mail-extr-non-end-name-chars) |
|
|
;;(if (eq ?. (following-char)) |
|
|
;; (forward-char 1)) |
|
|
;;(narrow-to-region (point) |
|
|
;; (progn |
|
|
;; (goto-char (point-min)) |
|
|
;; (skip-chars-forward mail-extr-non-begin-name-chars) |
|
|
;; (point))) |
|
|
|
|
|
;; Compress whitespace |
|
|
(goto-char (point-min)) |
|
|
(while (re-search-forward "[ \t\n]+" nil t) |
|
|
(replace-match (if (eobp) "" " ") t)) |
|
|
))) |
|
1819 |
|
|
1820 |
|
|
1821 |
|
|