emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Emacs-diffs] Changes to emacs/lisp/mail/mail-extr.el [lexbind]


From: Miles Bader
Subject: [Emacs-diffs] Changes to emacs/lisp/mail/mail-extr.el [lexbind]
Date: Sat, 04 Sep 2004 05:47:35 -0400

Index: emacs/lisp/mail/mail-extr.el
diff -c emacs/lisp/mail/mail-extr.el:1.36.4.3 
emacs/lisp/mail/mail-extr.el:1.36.4.4
*** emacs/lisp/mail/mail-extr.el:1.36.4.3       Fri Nov 21 00:36:08 2003
--- emacs/lisp/mail/mail-extr.el        Sat Sep  4 09:21:45 2004
***************
*** 1434,1807 ****
      (if all (nreverse value-list) (car value-list))
      ))
  
  (defun mail-extr-voodoo (mbox-beg mbox-end canonicalization-buffer)
!   (let ((word-count 0)
!       (case-fold-search nil)
!       mixed-case-flag lower-case-flag ;;upper-case-flag
!       suffix-flag last-name-comma-flag
!       ;;cbeg cend
!       initial
!       begin-again-flag
!       drop-this-word-if-trailing-flag
!       drop-last-word-if-trailing-flag
!       word-found-flag
!       this-word-beg last-word-beg
!       name-beg name-end
!       name-done-flag
!       )
!     (save-excursion
!       (set-syntax-table mail-extr-address-text-syntax-table)
! 
!       ;; Get rid of comments.
!       (goto-char (point-min))
!       (while (not (eobp))
!       ;; Initialize for this iteration of the loop.
!       (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
!       ;;   address@hidden (Piet.Rypens)
!       ;; but also as
!       ;;   "Piet.Rypens" <address@hidden>
!       ;;(goto-char (point-min))
!       ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t)
!       ;;  (replace-match "\\1 \\2" t))
  
!       (unless (search-forward " " nil t)
        (goto-char (point-min))
!       (cond ((search-forward "_" nil t)
!              ;; Handle the *idiotic* use of underlines as spaces.
!              ;; Example: address@hidden (First_M._Last)
!              (goto-char (point-min))
!              (while (search-forward "_" nil t)
!                (replace-match " " t)))
!             ((search-forward "." nil t)
!              ;; Fix . used as space
!              ;; Example: address@hidden (daniel.jacobson)
!              (goto-char (point-min))
!              (while (re-search-forward mail-extr-bad-dot-pattern nil t)
!                (replace-match "\\1 \\2" t)))))
! 
!       ;; Loop over the words (and other junk) in the name.
!       (goto-char (point-min))
!       (while (not name-done-flag)
! 
!       (when word-found-flag
!         ;; Last time through this loop we skipped over a word.
!         (setq last-word-beg this-word-beg)
!         (setq drop-last-word-if-trailing-flag
!               drop-this-word-if-trailing-flag)
!         (setq word-found-flag nil))
! 
!       (when begin-again-flag
!         ;; Last time through the loop we found something that
!         ;; indicates we should pretend we are beginning again from
!         ;; the start.
!         (setq word-count 0)
!         (setq last-word-beg nil)
!         (setq drop-last-word-if-trailing-flag nil)
!         (setq mixed-case-flag nil)
!         (setq lower-case-flag nil)
!         ;;           (setq upper-case-flag nil)
!         (setq begin-again-flag nil))
! 
!       ;; Initialize for this iteration of the loop.
!       (mail-extr-skip-whitespace-forward)
!       (if (eq word-count 0) (narrow-to-region (point) (point-max)))
!       (setq this-word-beg (point))
!       (setq drop-this-word-if-trailing-flag nil)
! 
!       ;; Decide what to do based on what we are looking at.
!       (cond
! 
!        ;; Delete title
!        ((and (eq word-count 0)
!              (looking-at mail-extr-full-name-prefixes))
!         (goto-char (match-end 0))
!         (narrow-to-region (point) (point-max)))
  
!        ;; Stop after name suffix
!        ((and (>= word-count 2)
!              (looking-at mail-extr-full-name-suffix-pattern))
!         (mail-extr-skip-whitespace-backward)
!         (setq suffix-flag (point))
!         (if (eq ?, (following-char))
!             (forward-char 1)
!           (insert ?,))
!         ;; Enforce at least one space after comma
!         (or (eq ?\  (following-char))
!             (insert ?\ ))
          (mail-extr-skip-whitespace-forward)
!         (cond ((memq (following-char) '(?j ?J ?s ?S))
!                (capitalize-word 1)
!                (if (eq (following-char) ?.)
!                    (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)))
  
!        ;; Various stopping points
!        ((or
  
!          ;; Stop before ALL CAPS acronyms, if preceded by mixed-case
!          ;; words.  Example: XT-DEM.
!          (and (>= word-count 2)
!               mixed-case-flag
!               (looking-at mail-extr-weird-acronym-pattern)
!               (not (looking-at mail-extr-roman-numeral-pattern)))
! 
!          ;; Stop before trailing alternative address
!          (looking-at mail-extr-alternative-address-pattern)
! 
!          ;; Stop before trailing comment not introduced by comma
!          ;; THIS CASE MUST BE AFTER AN EARLIER CASE.
!          (looking-at mail-extr-trailing-comment-start-pattern)
! 
!          ;; Stop before telephone numbers
!          (and (>= word-count 1)
!               (looking-at mail-extr-telephone-extension-pattern)))
!         (setq name-done-flag t))
! 
!        ;; Delete ham radio call signs
!        ((looking-at mail-extr-ham-call-sign-pattern)
!         (delete-region (match-beginning 0) (match-end 0)))
! 
!        ;; Fixup initials
!        ((looking-at mail-extr-initial-pattern)
!         (or (eq (following-char) (upcase (following-char)))
!             (setq lower-case-flag t))
!         (forward-char 1)
!         (if (eq ?. (following-char))
!             (forward-char 1)
!           (insert ?.))
!         (or (eq ?\  (following-char))
!             (insert ?\ ))
!         (setq word-found-flag t))
  
!        ;; Handle BITNET LISTSERV list names.
!        ((and (eq word-count 0)
!              (looking-at mail-extr-listserv-list-name-pattern))
!         (narrow-to-region (match-beginning 1) (match-end 1))
!         (setq word-found-flag t)
!         (setq name-done-flag t))
! 
!        ;; Handle & substitution, when & is last and is not first.
!        ((and (> word-count 0)
!              (eq ?\  (preceding-char))
!              (eq (following-char) ?&)
!              (eq (1+ (point)) (point-max)))
!         (delete-char 1)
!         (capitalize-region
!          (point)
!          (progn
!            (insert-buffer-substring canonicalization-buffer
!                                     mbox-beg mbox-end)
!            (point)))
!         (setq disable-initial-guessing-flag t)
!         (setq word-found-flag t))
! 
!        ;; Handle & between names, as in "Bob & Susie".
!        ((and (> word-count 0) (eq (following-char) ?\&))
!         (setq name-beg (point))
!         (setq name-end (1+ name-beg))
!         (setq word-found-flag t)
!         (goto-char name-end))
! 
!        ;; Regular name words
!        ((looking-at mail-extr-name-pattern)
!         (setq name-beg (point))
!         (setq name-end (match-end 0))
! 
!         ;; Certain words will be dropped if they are at the end.
!         (and (>= word-count 2)
!              (not lower-case-flag)
!              (or
!               ;; 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)
                (setq lower-case-flag t))
! ;;        (setq upper-case-flag t)
!           )
  
!         (goto-char name-end)
!         (setq word-found-flag t))
  
!        ;; Allow a number as a word, if it doesn't mean anything else.
!        ((looking-at "[0-9]+\\>")
!         (setq name-beg (point))
!         (setq name-end (match-end 0))
          (goto-char name-end)
!         (setq word-found-flag t))
  
!        (t
!         (setq name-done-flag t)
!         ))
! 
!       ;; Count any word that we skipped over.
!       (if word-found-flag
!           (setq word-count (1+ word-count))))
! 
!       ;; If the last thing in the name is 2 or more periods, or one or more
!       ;; other sentence terminators (but not a single period) then keep them
!       ;; and the preceding word.  This is for the benefit of whole sentences
!       ;; 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 address@hidden into address@hidden, 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))))
  
!       ;; If last name first put it at end (but before suffix)
!       (when last-name-comma-flag
        (goto-char (point-min))
!       (search-forward ",")
!       (setq name-end (1- (point)))
!       (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))
!       )))
  
  
  
--- 1434,1821 ----
      (if all (nreverse value-list) (car value-list))
      ))
  
+ (defcustom mail-extr-disable-voodoo "\\cj"
+   "*If it is a regexp, names matching it will never be modified.
+ If it is neither nil nor a string, modifying of names will never take
+ place.  It affects how `mail-extract-address-components' works."
+   :type '(choice (regexp :size 0)
+                (const :tag "Always enabled" nil)
+                (const :tag "Always disabled" t))
+   :group 'mail-extr)
+ 
  (defun mail-extr-voodoo (mbox-beg mbox-end canonicalization-buffer)
!   (unless (and mail-extr-disable-voodoo
!              (or (not (stringp mail-extr-disable-voodoo))
!                  (progn
!                    (goto-char (point-min))
!                    (re-search-forward mail-extr-disable-voodoo nil t))))
!     (let ((word-count 0)
!         (case-fold-search nil)
!         mixed-case-flag lower-case-flag ;;upper-case-flag
!         suffix-flag last-name-comma-flag
!         ;;cbeg cend
!         initial
!         begin-again-flag
!         drop-this-word-if-trailing-flag
!         drop-last-word-if-trailing-flag
!         word-found-flag
!         this-word-beg last-word-beg
!         name-beg name-end
!         name-done-flag
!         )
!       (save-excursion
!       (set-syntax-table mail-extr-address-text-syntax-table)
  
!       ;; Get rid of comments.
        (goto-char (point-min))
!       (while (not (eobp))
!         ;; Initialize for this iteration of the loop.
!         (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
!       ;;   address@hidden (Piet.Rypens)
!       ;; but also as
!       ;;   "Piet.Rypens" <address@hidden>
!       ;;(goto-char (point-min))
!       ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t)
!       ;;  (replace-match "\\1 \\2" t))
! 
!       (unless (search-forward " " nil t)
!         (goto-char (point-min))
!         (cond ((search-forward "_" nil t)
!                ;; Handle the *idiotic* use of underlines as spaces.
!                ;; Example: address@hidden (First_M._Last)
!                (goto-char (point-min))
!                (while (search-forward "_" nil t)
!                  (replace-match " " t)))
!               ((search-forward "." nil t)
!                ;; Fix . used as space
!                ;; Example: address@hidden (daniel.jacobson)
!                (goto-char (point-min))
!                (while (re-search-forward mail-extr-bad-dot-pattern nil t)
!                  (replace-match "\\1 \\2" t)))))
  
!       ;; Loop over the words (and other junk) in the name.
!       (goto-char (point-min))
!       (while (not name-done-flag)
! 
!         (when word-found-flag
!           ;; Last time through this loop we skipped over a word.
!           (setq last-word-beg this-word-beg)
!           (setq drop-last-word-if-trailing-flag
!                 drop-this-word-if-trailing-flag)
!           (setq word-found-flag nil))
! 
!         (when begin-again-flag
!           ;; Last time through the loop we found something that
!           ;; indicates we should pretend we are beginning again from
!           ;; the start.
!           (setq word-count 0)
!           (setq last-word-beg nil)
!           (setq drop-last-word-if-trailing-flag nil)
!           (setq mixed-case-flag nil)
!           (setq lower-case-flag nil)
!           ;;         (setq upper-case-flag nil)
!           (setq begin-again-flag nil))
! 
!         ;; Initialize for this iteration of the loop.
          (mail-extr-skip-whitespace-forward)
!         (if (eq word-count 0) (narrow-to-region (point) (point-max)))
!         (setq this-word-beg (point))
!         (setq drop-this-word-if-trailing-flag nil)
  
!         ;; Decide what to do based on what we are looking at.
!         (cond
  
!          ;; Delete title
!          ((and (eq word-count 0)
!                (looking-at mail-extr-full-name-prefixes))
!           (goto-char (match-end 0))
!           (narrow-to-region (point) (point-max)))
! 
!          ;; Stop after name suffix
!          ((and (>= word-count 2)
!                (looking-at mail-extr-full-name-suffix-pattern))
!           (mail-extr-skip-whitespace-backward)
!           (setq suffix-flag (point))
!           (if (eq ?, (following-char))
!               (forward-char 1)
!             (insert ?,))
!           ;; Enforce at least one space after comma
!           (or (eq ?\  (following-char))
!               (insert ?\ ))
!           (mail-extr-skip-whitespace-forward)
!           (cond ((memq (following-char) '(?j ?J ?s ?S))
!                  (capitalize-word 1)
!                  (if (eq (following-char) ?.)
!                      (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)))
! 
!          ;; Various stopping points
!          ((or
! 
!            ;; Stop before ALL CAPS acronyms, if preceded by mixed-case
!            ;; words.  Example: XT-DEM.
!            (and (>= word-count 2)
!                 mixed-case-flag
!                 (looking-at mail-extr-weird-acronym-pattern)
!                 (not (looking-at mail-extr-roman-numeral-pattern)))
! 
!            ;; Stop before trailing alternative address
!            (looking-at mail-extr-alternative-address-pattern)
! 
!            ;; Stop before trailing comment not introduced by comma
!            ;; THIS CASE MUST BE AFTER AN EARLIER CASE.
!            (looking-at mail-extr-trailing-comment-start-pattern)
! 
!            ;; Stop before telephone numbers
!            (and (>= word-count 1)
!                 (looking-at mail-extr-telephone-extension-pattern)))
!           (setq name-done-flag t))
! 
!          ;; Delete ham radio call signs
!          ((looking-at mail-extr-ham-call-sign-pattern)
!           (delete-region (match-beginning 0) (match-end 0)))
! 
!          ;; Fixup initials
!          ((looking-at mail-extr-initial-pattern)
!           (or (eq (following-char) (upcase (following-char)))
                (setq lower-case-flag t))
!           (forward-char 1)
!           (if (eq ?. (following-char))
!               (forward-char 1)
!             (insert ?.))
!           (or (eq ?\  (following-char))
!               (insert ?\ ))
!           (setq word-found-flag t))
  
!          ;; Handle BITNET LISTSERV list names.
!          ((and (eq word-count 0)
!                (looking-at mail-extr-listserv-list-name-pattern))
!           (narrow-to-region (match-beginning 1) (match-end 1))
!           (setq word-found-flag t)
!           (setq name-done-flag t))
! 
!          ;; Handle & substitution, when & is last and is not first.
!          ((and (> word-count 0)
!                (eq ?\  (preceding-char))
!                (eq (following-char) ?&)
!                (eq (1+ (point)) (point-max)))
!           (delete-char 1)
!           (capitalize-region
!            (point)
!            (progn
!              (insert-buffer-substring canonicalization-buffer
!                                       mbox-beg mbox-end)
!              (point)))
!           (setq disable-initial-guessing-flag t)
!           (setq word-found-flag t))
! 
!          ;; Handle & between names, as in "Bob & Susie".
!          ((and (> word-count 0) (eq (following-char) ?\&))
!           (setq name-beg (point))
!           (setq name-end (1+ name-beg))
!           (setq word-found-flag t)
!           (goto-char name-end))
! 
!          ;; Regular name words
!          ((looking-at mail-extr-name-pattern)
!           (setq name-beg (point))
!           (setq name-end (match-end 0))
! 
!           ;; Certain words will be dropped if they are at the end.
!           (and (>= word-count 2)
!                (not lower-case-flag)
!                (or
!                 ;; 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)
!                 (setq lower-case-flag t))
!             ;;            (setq upper-case-flag t)
!             )
! 
!           (goto-char name-end)
!           (setq word-found-flag t))
! 
!          ;; Allow a number as a word, if it doesn't mean anything else.
!          ((looking-at "[0-9]+\\>")
!           (setq name-beg (point))
!           (setq name-end (match-end 0))
!           (goto-char name-end)
!           (setq word-found-flag t))
  
!          (t
!           (setq name-done-flag t)
!           ))
! 
!         ;; Count any word that we skipped over.
!         (if word-found-flag
!             (setq word-count (1+ word-count))))
! 
!       ;; If the last thing in the name is 2 or more periods, or one or more
!       ;; other sentence terminators (but not a single period) then keep them
!       ;; and the preceding word.  This is for the benefit of whole sentences
!       ;; 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 address@hidden into address@hidden, 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))))
! 
!       ;; If last name first put it at end (but before suffix)
!       (when last-name-comma-flag
!         (goto-char (point-min))
!         (search-forward ",")
!         (setq name-end (1- (point)))
!         (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))
!       ))))
  
  
  




reply via email to

[Prev in Thread] Current Thread [Next in Thread]