/[emacs]/emacs/lisp/mail/mail-extr.el
ViewVC logotype

Diff of /emacs/lisp/mail/mail-extr.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.43 by fx, Thu Oct 23 11:41:50 2003 UTC revision 1.44 by handa, Thu Aug 5 00:15:15 2004 UTC
# Line 1434  consing a string.)" Line 1434  consing a string.)"
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    

Legend:
Removed from v.1.43  
changed lines
  Added in v.1.44

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26