Mercurial > emacs
changeset 809:8a0066235d56
Initial revision
| author | Eric S. Raymond <esr@snark.thyrsus.com> |
|---|---|
| date | Fri, 17 Jul 1992 06:48:03 +0000 |
| parents | 707866b2a190 |
| children | 80303373daae |
| files | lisp/mail/mail-extr.el lisp/progmodes/make-mode.el lisp/textmodes/sgml-mode.el lisp/textmodes/two-column.el |
| diffstat | 4 files changed, 3424 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/mail-extr.el Fri Jul 17 06:48:03 1992 +0000 @@ -0,0 +1,1469 @@ +;;; mail-extr.el --- extract full name and address from RFC 822 mail header. + +;; Author: Joe Wells <jbw@cs.bu.edu> +;; Last-Modified: 7 Apr 1992 +;; Version: 1.0 +;; Adapted-By: ESR +;; Keywords: mail + +;; Copyright (C) 1992 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; Here is `mail-extr', a package for extracting full names and canonical +;; addresses from RFC 822 mail headers. It is intended to be hooked into +;; other Emacs Lisp packages that deal with RFC 822 format messages, such as +;; Gnews, GNUS, RMAIL, MH-E, BBDB, VM, Supercite, etc. Thus, this release is +;; mainly for Emacs Lisp developers. + +;; There are two main benefits: + +;; 1. Higher probability of getting the correct full name for a human than +;; any other package I know of. (On the other hand, it will cheerfully +;; mangle non-human names/comments.) +;; 2. Address part is put in a canonical form. + +;; The interface is not yet carved in stone; please give me suggestions. + +;; I have an extensive test-case collection of funny addresses if you want to +;; work with the code. Developing this code requires frequent testing to +;; make sure you're not breaking functionality. I'm not posting the +;; test-cases because they take over 100K. + +;; If you find an address that mail-extr fails on, please send it to me along +;; with what you think the correct results should be. I do not consider it a +;; bug if mail-extr mangles a comment that does not correspond to a real +;; human full name, although I would prefer that mail-extr would return the +;; comment as-is. + +;; Features: + +;; * Full name handling: + +;; * knows where full names can be found in an address. +;; * avoids using empty comments and quoted text. +;; * extracts full names from mailbox names. +;; * recognizes common formats for comments after a full name. +;; * puts a period and a space after each initial. +;; * understands & referring to the mailbox name capitalized. +;; * strips name prefixes like "Prof.", etc.. +;; * understands what characters can occur in names (not just letters). +;; * figures out middle initial from mailbox name. +;; * removes funny nicknames. +;; * keeps suffixes such as Jr., Sr., III, etc. +;; * reorders "Last, First" type names. + +;; * Address handling: + +;; * parses rfc822 quoted text, comments, and domain literals. +;; * parses rfc822 multi-line headers. +;; * does something reasonable with rfc822 GROUP addresses. +;; * handles many rfc822 noncompliant and garbage addresses. +;; * canonicalizes addresses (after stripping comments/phrases outside <>). +;; * converts ! addresses into .UUCP and %-style addresses. +;; * converts rfc822 ROUTE addresses to %-style addresses. +;; * truncates %-style addresses at leftmost fully qualified domain name. +;; * handles local relative precedence of ! vs. % and @ (untested). + +;; It does almost no string creation. It primarily uses the built-in +;; parsing routines with the appropriate syntax tables. This should +;; result in greater speed. + +;; TODO: + +;; * handle all test cases. (This will take forever.) +;; * software to pick the correct header to use (eg., "Senders-Name:"). +;; * multiple addresses in the "From:" header (almost all of the necessary +;; code is there). +;; * flag to not treat `,' as an address separator. (This is useful when +;; there is a "From:" header but no "Sender:" header, because then there +;; is only allowed to be one address.) +;; * mailbox name does not necessarily contain full name. +;; * fixing capitalization when it's all upper or lowercase. (Hard!) +;; * some of the domain literal handling is missing. (But I've never even +;; seen one of these in a mail address, so maybe no big deal.) +;; * arrange to have syntax tables byte-compiled. +;; * speed hacks. +;; * delete unused variables. +;; * arrange for testing with different relative precedences of ! vs. @ +;; and %. +;; * put variant-method back into mail-extract-address-components. +;; * insert documentation strings! +;; * handle X.400-gatewayed addresses according to RFC 1148. + +;;; Change Log: +;; +;; Mon Apr 6 23:59:09 1992 Joe Wells (jbw at bigbird.bu.edu) +;; +;; * Cleaned up some more. Release version 1.0 to world. +;; +;; Sun Apr 5 19:39:08 1992 Joe Wells (jbw at bigbird.bu.edu) +;; +;; * Cleaned up full name extraction extensively. +;; +;; Sun Feb 2 14:45:24 1992 Joe Wells (jbw at bigbird.bu.edu) +;; +;; * Total rewrite. Integrated mail-canonicalize-address into +;; mail-extract-address-components. Now handles GROUP addresses more +;; or less correctly. Better handling of lots of different cases. +;; +;; Fri Jun 14 19:39:50 1991 +;; * Created. + +;;; Code: + +;; Variable definitions. + +(defvar mail-@-binds-tighter-than-! nil) + +;;---------------------------------------------------------------------- +;; what orderings are meaningful????? +;;(defvar mail-operator-precedence-list '(?! ?% ?@)) +;; Right operand of a % or a @ must be a domain name, period. No other +;; operators allowed. Left operand of a @ is an address relative to that +;; site. + +;; Left operand of a ! must be a domain name. Right operand is an +;; arbitrary address. +;;---------------------------------------------------------------------- + +(defconst mail-space-char 32) + +(defconst mail-whitespace " \t\n") + +;; Any character that can occur in a name in an RFC822 address. +;; Yes, there are weird people with digits in their names. +(defconst mail-all-letters "A-Za-z---{|}'~0-9`.") + +;; Any character that can occur in a name, not counting characters that +;; separate parts of a multipart name. +(defconst mail-all-letters-but-separators "A-Za-z{|}'~0-9`") + +;; Any character that can start a name +(defconst mail-first-letters "A-Za-z") + +;; Any character that can end a name. +(defconst mail-last-letters "A-Za-z`'.") + +;; Matches an initial not followed by both a period and a space. +(defconst mail-bad-initials-pattern + (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)" + mail-all-letters mail-first-letters mail-all-letters)) + +(defconst mail-non-name-chars (concat "^" mail-all-letters ".")) + +(defconst mail-non-begin-name-chars (concat "^" mail-first-letters)) + +(defconst mail-non-end-name-chars (concat "^" mail-last-letters)) + +;; Matches periods used instead of spaces. Must not match the period +;; following an initial. +(defconst mail-bad-\.-pattern + (format "\\([%s][%s]\\)\\.+\\([%s]\\)" + mail-all-letters mail-last-letters mail-first-letters)) + +;; Matches an embedded or leading nickname that should be removed. +(defconst mail-nickname-pattern + (format "\\([ .]\\|\\`\\)[\"'`\[\(]\\([ .%s]+\\)[\]\"'\)] " + mail-all-letters)) + +;; Matches a leading title that is not part of the name (does not +;; contribute to uniquely identifying the person). +(defconst mail-full-name-prefixes + '"\\` *\\(Prof\\|Dr\\|Mrs?\\|Rev\\|Rabbi\\|SysOp\\|LCDR\\)\\.? ") + +;; Matches the occurrence of a generational name suffix, and the last +;; character of the preceding name. +(defconst mail-full-name-suffix-pattern + (format + "\\(,? ?\\([JjSs]r\\.?\\|V?I+V?\\)\\)\\([^%s]\\([^%s]\\|\\'\\)\\|\\'\\)" + mail-all-letters mail-all-letters)) + +(defconst mail-roman-numeral-pattern + "V?I+V?\\b") + +;; Matches a trailing uppercase (with other characters possible) acronym. +;; Must not match a trailing uppercase last name or trailing initial +(defconst mail-weird-acronym-pattern "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)") + +;; Matches a mixed-case or lowercase name (not an initial). +(defconst mail-mixed-case-name-pattern + (format + "\\b\\([a-z][%s]*[%s]\\|[%s][%s]*[a-z][%s]*[%s]\\|[%s][%s]*[a-z]\\)" + mail-all-letters mail-last-letters + mail-first-letters mail-all-letters mail-all-letters mail-last-letters + mail-first-letters mail-all-letters)) + +;; Matches a trailing alternative address. +(defconst mail-alternative-address-pattern "[a-zA-Z.]+[!@][a-zA-Z.]") + +;; Matches a variety of trailing comments not including comma-delimited +;; comments. +(defconst mail-trailing-comment-start-pattern " [-{]\\|--\\|[+@#></\;]") + +;; Matches a name (not an initial). +;; This doesn't force a word boundary at the end because sometimes a +;; comment is separated by a `-' with no preceding space. +(defconst mail-name-pattern + (format + "\\b[%s][%s]*[%s]" + mail-first-letters mail-all-letters mail-last-letters)) + +(defconst mail-initial-pattern + (format "\\b[%s]\\([. ]\\|\\b\\)" mail-first-letters)) + +;; Matches a single name before a comma. +(defconst mail-last-name-first-pattern + (concat "\\`" mail-name-pattern ",")) + +;; Matches telephone extensions. +(defconst mail-telephone-extension-pattern + "\\(\\([Ee]xt\\|[Tt]el\\|[Xx]\\).?\\)? *\\+?[0-9][- 0-9]+") + +;; Matches ham radio call signs. +(defconst mail-ham-call-sign-pattern + "\\b[A-Z]+[0-9][A-Z0-9]*") + +;; Matches normal single-part name +(defconst mail-normal-name-pattern + (format + "\\b[%s][%s]+[%s]" + mail-first-letters mail-all-letters-but-separators mail-last-letters)) + +;; Matches normal two names with missing middle initial +(defconst mail-two-name-pattern + (concat "\\`\\(" mail-normal-name-pattern + "\\|" mail-initial-pattern + "\\) +\\(" mail-normal-name-pattern "\\)\\(,\\|\\'\\)")) + +(defvar address-syntax-table (make-syntax-table)) +(defvar address-comment-syntax-table (make-syntax-table)) +(defvar address-domain-literal-syntax-table (make-syntax-table)) +(defvar address-text-comment-syntax-table (make-syntax-table)) +(defvar address-text-syntax-table (make-syntax-table)) +(mapcar + (function + (lambda (pair) + (let ((syntax-table (symbol-value (car pair)))) + (mapcar + (function + (lambda (item) + (if (eq 2 (length item)) + (modify-syntax-entry (car item) (car (cdr item)) syntax-table) + (let ((char (car item)) + (bound (car (cdr item))) + (syntax (car (cdr (cdr item))))) + (while (<= char bound) + (modify-syntax-entry char syntax syntax-table) + (setq char (1+ char))))))) + (cdr pair))))) + '((address-syntax-table + (0 31 "w") ;control characters + (32 " ") ;SPC + (?! ?~ "w") ;printable characters + (127 "w") ;DEL + (128 255 "w") ;high-bit-on characters + (?\t " ") + (?\r " ") + (?\n " ") + (?\( ".") + (?\) ".") + (?< ".") + (?> ".") + (?@ ".") + (?, ".") + (?\; ".") + (?: ".") + (?\\ "\\") + (?\" "\"") + (?. ".") + (?\[ ".") + (?\] ".") + ;; % and ! aren't RFC822 characters, but it is convenient to pretend + (?% ".") + (?! ".") + ) + (address-comment-syntax-table + (0 255 "w") + (?\( "\(\)") + (?\) "\)\(") + (?\\ "\\")) + (address-domain-literal-syntax-table + (0 255 "w") + (?\[ "\(\]") ;?????? + (?\] "\)\[") ;?????? + (?\\ "\\")) + (address-text-comment-syntax-table + (0 255 "w") + (?\( "\(\)") + (?\) "\)\(") + (?\[ "\(\]") + (?\] "\)\[") + (?\{ "\(\}") + (?\} "\)\{") + (?\\ "\\") + (?\" "\"") + ;; (?\' "\)\`") + ;; (?\` "\(\'") + ) + (address-text-syntax-table + (0 255 ".") + (?A ?Z "w") + (?a ?z "w") + (?- "w") + (?\} "w") + (?\{ "w") + (?| "w") + (?\' "w") + (?~ "w") + (?0 ?9 "w")) + )) + + +;; Utility functions and macros. + +(defmacro undo-backslash-quoting (beg end) + (`(save-excursion + (save-restriction + (narrow-to-region (, beg) (, end)) + (goto-char (point-min)) + ;; undo \ quoting + (while (re-search-forward "\\\\\\(.\\)" nil t) + (replace-match "\\1") + ;; CHECK: does this leave point after the replacement? + ))))) + +(defmacro mail-nuke-char-at (pos) + (` (save-excursion + (goto-char (, pos)) + (delete-char 1) + (insert mail-space-char)))) + +(defmacro mail-nuke-elements-outside-range (list-symbol beg-symbol end-symbol + &optional no-replace) + (` (progn + (setq temp (, list-symbol)) + (while temp + (cond ((or (> (car temp) (, end-symbol)) + (< (car temp) (, beg-symbol))) + (, (or no-replace + (` (mail-nuke-char-at (car temp))))) + (setcar temp nil))) + (setq temp (cdr temp))) + (setq (, list-symbol) (delq nil (, list-symbol)))))) + +(defun mail-demarkerize (marker) + (and marker + (if (markerp marker) + (let ((temp (marker-position marker))) + (set-marker marker nil) + temp) + marker))) + +(defun mail-markerize (pos) + (and pos + (if (markerp pos) + pos + (copy-marker pos)))) + +(defmacro mail-last-element (list) + "Return last element of LIST." + (` (let ((list (, list))) + (while (not (null (cdr list))) + (setq list (cdr list))) + (car list)))) + +(defmacro safe-move-sexp (arg) + "Safely skip over one balanced sexp, if there is one. Return t if success." + (` (condition-case error + (progn + (goto-char (scan-sexps (point) (, arg))) + t) + (error + (if (string-equal (nth 1 error) "Unbalanced parentheses") + nil + (while t + (signal (car error) (cdr error)))))))) + + +;; The main function to grind addresses + +(defun mail-extract-address-components (address) + "Given an rfc 822 ADDRESS, extract full name and canonical address. +Returns a list of the form (FULL-NAME CANONICAL-ADDRESS)." + (let ((canonicalization-buffer (get-buffer-create "*canonical address*")) + (extraction-buffer (get-buffer-create "*extract address components*")) + (foo 'bar) + char + multiple-addresses + <-pos >-pos @-pos :-pos ,-pos !-pos %-pos \;-pos + group-:-pos group-\;-pos route-addr-:-pos + record-pos-symbol + first-real-pos last-real-pos + phrase-beg phrase-end + comment-beg comment-end + quote-beg quote-end + atom-beg atom-end + mbox-beg mbox-end + \.-ends-name + temp + name-suffix + saved-point + fi mi li + saved-%-pos saved-!-pos saved-@-pos + domain-pos \.-pos insert-point) + + (save-excursion + (set-buffer extraction-buffer) + (buffer-flush-undo extraction-buffer) + (set-syntax-table address-syntax-table) + (widen) + (erase-buffer) + (setq case-fold-search nil) + + ;; Insert extra space at beginning to allow later replacement with < + ;; without having to move markers. + (insert mail-space-char address) + + ;; stolen from rfc822.el + ;; Unfold multiple lines. + (goto-char (point-min)) + (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t) + (replace-match "\\1 " t)) + + ;; first pass grabs useful information about address + (goto-char (point-min)) + (while (progn + (skip-chars-forward mail-whitespace) + (not (eobp))) + (setq char (char-after (point))) + (or first-real-pos + (if (not (eq char ?\()) + (setq first-real-pos (point)))) + (cond + ;; comment + ((eq char ?\() + (set-syntax-table address-comment-syntax-table) + ;; only record the first non-empty comment's position + (if (and (not comment-beg) + (save-excursion + (forward-char 1) + (skip-chars-forward mail-whitespace) + (not (eq ?\) (char-after (point)))))) + (setq comment-beg (point))) + ;; TODO: don't record if unbalanced + (or (safe-move-sexp 1) + (forward-char 1)) + (set-syntax-table address-syntax-table) + (if (and comment-beg + (not comment-end)) + (setq comment-end (point)))) + ;; quoted text + ((eq char ?\") + ;; only record the first non-empty quote's position + (if (and (not quote-beg) + (save-excursion + (forward-char 1) + (skip-chars-forward mail-whitespace) + (not (eq ?\" (char-after (point)))))) + (setq quote-beg (point))) + ;; TODO: don't record if unbalanced + (or (safe-move-sexp 1) + (forward-char 1)) + (if (and quote-beg + (not quote-end)) + (setq quote-end (point)))) + ;; domain literals + ((eq char ?\[) + (set-syntax-table address-domain-literal-syntax-table) + (or (safe-move-sexp 1) + (forward-char 1)) + (set-syntax-table address-syntax-table)) + ;; commas delimit addresses when outside < > pairs. + ((and (eq char ?,) + (or (null <-pos) + (and >-pos + ;; handle weird munged addresses + (> (mail-last-element <-pos) (car >-pos))))) + (setq multiple-addresses t) + (delete-char 1) + (narrow-to-region (point-min) (point))) + ;; record the position of various interesting chars, determine + ;; legality later. + ((setq record-pos-symbol + (cdr (assq char + '((?< . <-pos) (?> . >-pos) (?@ . @-pos) + (?: . :-pos) (?, . ,-pos) (?! . !-pos) + (?% . %-pos) (?\; . \;-pos))))) + (set record-pos-symbol + (cons (point) (symbol-value record-pos-symbol))) + (forward-char 1)) + ((eq char ?.) + (forward-char 1)) + ((memq char '( + ;; comment terminator illegal + ?\) + ;; domain literal terminator illegal + ?\] + ;; \ allowed only within quoted strings, + ;; domain literals, and comments + ?\\ + )) + (mail-nuke-char-at (point)) + (forward-char 1)) + (t + (forward-word 1))) + (or (eq char ?\() + (setq last-real-pos (point)))) + + ;; Use only the leftmost <, if any. Replace all others with spaces. + (while (cdr <-pos) + (mail-nuke-char-at (car <-pos)) + (setq <-pos (cdr <-pos))) + + ;; Use only the rightmost >, if any. Replace all others with spaces. + (while (cdr >-pos) + (mail-nuke-char-at (nth 1 >-pos)) + (setcdr >-pos (nthcdr 2 >-pos))) + + ;; If multiple @s and a :, but no < and >, insert around buffer. + ;; This commonly happens on the UUCP "From " line. Ugh. + (cond ((and (> (length @-pos) 1) + :-pos ;TODO: check if between @s + (not <-pos)) + (goto-char (point-min)) + (delete-char 1) + (setq <-pos (list (point))) + (insert ?<))) + + ;; If < but no >, insert > in rightmost possible position + (cond ((and <-pos + (null >-pos)) + (goto-char (point-max)) + (setq >-pos (list (point))) + (insert ?>))) + + ;; If > but no <, replace > with space. + (cond ((and >-pos + (null <-pos)) + (mail-nuke-char-at (car >-pos)) + (setq >-pos nil))) + + ;; Turn >-pos and <-pos into non-lists + (setq >-pos (car >-pos) + <-pos (car <-pos)) + + ;; Trim other punctuation lists of items outside < > pair to handle + ;; stupid MTAs. + (cond (<-pos ; don't need to check >-pos also + ;; handle bozo software that violates RFC 822 by sticking + ;; punctuation marks outside of a < > pair + (mail-nuke-elements-outside-range @-pos <-pos >-pos t) + ;; RFC 822 says nothing about these two outside < >, but + ;; remove those positions from the lists to make things + ;; easier. + (mail-nuke-elements-outside-range !-pos <-pos >-pos t) + (mail-nuke-elements-outside-range %-pos <-pos >-pos t))) + + ;; Check for : that indicates GROUP list and for : part of + ;; ROUTE-ADDR spec. + ;; Can't possibly be more than two :. Nuke any extra. + (while :-pos + (setq temp (car :-pos) + :-pos (cdr :-pos)) + (cond ((and <-pos >-pos + (> temp <-pos) + (< temp >-pos)) + (if (or route-addr-:-pos + (< (length @-pos) 2) + (> temp (car @-pos)) + (< temp (nth 1 @-pos))) + (mail-nuke-char-at temp) + (setq route-addr-:-pos temp))) + ((or (not <-pos) + (and <-pos + (< temp <-pos))) + (setq group-:-pos temp)))) + + ;; Nuke any ; that is in or to the left of a < > pair or to the left + ;; of a GROUP starting :. Also, there may only be one ;. + (while \;-pos + (setq temp (car \;-pos) + \;-pos (cdr \;-pos)) + (cond ((and <-pos >-pos + (> temp <-pos) + (< temp >-pos)) + (mail-nuke-char-at temp)) + ((and (or (not group-:-pos) + (> temp group-:-pos)) + (not group-\;-pos)) + (setq group-\;-pos temp)))) + + ;; Handle junk like ";@host.company.dom" that sendmail adds. + ;; **** should I remember comment positions? + (and group-\;-pos + ;; this is fine for now + (mail-nuke-elements-outside-range !-pos group-:-pos group-\;-pos t) + (mail-nuke-elements-outside-range @-pos group-:-pos group-\;-pos t) + (mail-nuke-elements-outside-range %-pos group-:-pos group-\;-pos t) + (mail-nuke-elements-outside-range ,-pos group-:-pos group-\;-pos t) + (and last-real-pos + (> last-real-pos (1+ group-\;-pos)) + (setq last-real-pos (1+ group-\;-pos))) + (and comment-end + (> comment-end group-\;-pos) + (setq comment-end nil + comment-beg nil)) + (and quote-end + (> quote-end group-\;-pos) + (setq quote-end nil + quote-beg nil)) + (narrow-to-region (point-min) group-\;-pos)) + + ;; Any commas must be between < and : of ROUTE-ADDR. Nuke any + ;; others. + ;; Hell, go ahead an nuke all of the commas. + ;; **** This will cause problems when we start handling commas in + ;; the PHRASE part .... no it won't ... yes it will ... ????? + (mail-nuke-elements-outside-range ,-pos 1 1) + + ;; can only have multiple @s inside < >. The fact that some MTAs + ;; put de-bracketed ROUTE-ADDRs in the UUCP-style "From " line is + ;; handled above. + + ;; Locate PHRASE part of ROUTE-ADDR. + (cond (<-pos + (goto-char <-pos) + (skip-chars-backward mail-whitespace) + (setq phrase-end (point)) + (goto-char (or ;;group-:-pos + (point-min))) + (skip-chars-forward mail-whitespace) + (if (< (point) phrase-end) + (setq phrase-beg (point)) + (setq phrase-end nil)))) + + ;; handle ROUTE-ADDRS with real ROUTEs. + ;; If there are multiple @s, then we assume ROUTE-ADDR syntax, and + ;; any % or ! must be semantically meaningless. + ;; TODO: do this processing into canonicalization buffer + (cond (route-addr-:-pos + (setq !-pos nil + %-pos nil + >-pos (copy-marker >-pos) + route-addr-:-pos (copy-marker route-addr-:-pos)) + (goto-char >-pos) + (insert-before-markers ?X) + (goto-char (car @-pos)) + (while (setq @-pos (cdr @-pos)) + (delete-char 1) + (setq %-pos (cons (point-marker) %-pos)) + (insert "%") + (goto-char (1- >-pos)) + (save-excursion + (insert-buffer-substring extraction-buffer + (car @-pos) route-addr-:-pos) + (delete-region (car @-pos) route-addr-:-pos)) + (or (cdr @-pos) + (setq saved-@-pos (list (point))))) + (setq @-pos saved-@-pos) + (goto-char >-pos) + (delete-char -1) + (mail-nuke-char-at route-addr-:-pos) + (mail-demarkerize route-addr-:-pos) + (setq route-addr-:-pos nil + >-pos (mail-demarkerize >-pos) + %-pos (mapcar 'mail-demarkerize %-pos)))) + + ;; de-listify @-pos + (setq @-pos (car @-pos)) + + ;; TODO: remove comments in the middle of an address + + (set-buffer canonicalization-buffer) + + (buffer-flush-undo canonicalization-buffer) + (set-syntax-table address-syntax-table) + (setq case-fold-search nil) + + (widen) + (erase-buffer) + (insert-buffer-substring extraction-buffer) + + (if <-pos + (narrow-to-region (progn + (goto-char (1+ <-pos)) + (skip-chars-forward mail-whitespace) + (point)) + >-pos) + ;; ****** Oh no! What if the address is completely empty! + (narrow-to-region first-real-pos last-real-pos)) + + (and @-pos %-pos + (mail-nuke-elements-outside-range %-pos (point-min) @-pos)) + (and %-pos !-pos + (mail-nuke-elements-outside-range !-pos (point-min) (car %-pos))) + (and @-pos !-pos (not %-pos) + (mail-nuke-elements-outside-range !-pos (point-min) @-pos)) + + ;; Error condition:?? (and %-pos (not @-pos)) + + (cond (!-pos + ;; **** I don't understand this save-restriction and the + ;; narrow-to-region inside it. Why did I do that? + (save-restriction + (cond ((and @-pos + mail-@-binds-tighter-than-!) + (goto-char @-pos) + (setq %-pos (cons (point) %-pos) + @-pos nil) + (delete-char 1) + (insert "%") + (setq insert-point (point-max))) + (mail-@-binds-tighter-than-! + (setq insert-point (point-max))) + (%-pos + (setq insert-point (mail-last-element %-pos) + saved-%-pos (mapcar 'mail-markerize %-pos) + %-pos nil + @-pos (mail-markerize @-pos))) + (@-pos + (setq insert-point @-pos) + (setq @-pos (mail-markerize @-pos))) + (t + (setq insert-point (point-max)))) + (narrow-to-region (point-min) insert-point) + (setq saved-!-pos (car !-pos)) + (while !-pos + (goto-char (point-max)) + (cond ((and (not @-pos) + (not (cdr !-pos))) + (setq @-pos (point)) + (insert-before-markers "@ ")) + (t + (setq %-pos (cons (point) %-pos)) + (insert-before-markers "% "))) + (backward-char 1) + (insert-buffer-substring + (current-buffer) + (if (nth 1 !-pos) + (1+ (nth 1 !-pos)) + (point-min)) + (car !-pos)) + (delete-char 1) + (or (save-excursion + (safe-move-sexp -1) + (skip-chars-backward mail-whitespace) + (eq ?. (preceding-char))) + (insert-before-markers + (if (save-excursion + (skip-chars-backward mail-whitespace) + (eq ?. (preceding-char))) + "" + ".") + "uucp")) + (setq !-pos (cdr !-pos)))) + (and saved-%-pos + (setq %-pos (append (mapcar 'mail-demarkerize saved-%-pos) + %-pos))) + (setq @-pos (mail-demarkerize @-pos)) + (narrow-to-region (1+ saved-!-pos) (point-max)))) + (cond ((and %-pos + (not @-pos)) + (goto-char (car %-pos)) + (delete-char 1) + (setq @-pos (point)) + (insert "@") + (setq %-pos (cdr %-pos)))) + (setq %-pos (nreverse %-pos)) + ;; RFC 1034 doesn't approve of this, oh well: + (downcase-region (or (car %-pos) @-pos (point-max)) (point-max)) + (cond (%-pos ; implies @-pos valid + (setq temp %-pos) + (catch 'truncated + (while temp + (goto-char (or (nth 1 temp) + @-pos)) + (skip-chars-backward mail-whitespace) + (save-excursion + (safe-move-sexp -1) + (setq domain-pos (point)) + (skip-chars-backward mail-whitespace) + (setq \.-pos (eq ?. (preceding-char)))) + (cond ((and \.-pos + (get + (intern + (buffer-substring domain-pos (point))) + 'domain-name)) + (narrow-to-region (point-min) (point)) + (goto-char (car temp)) + (delete-char 1) + (setq @-pos (point)) + (setcdr temp nil) + (setq %-pos (delq @-pos %-pos)) + (insert "@") + (throw 'truncated t))) + (setq temp (cdr temp)))))) + (setq mbox-beg (point-min) + mbox-end (if %-pos (car %-pos) + (or @-pos + (point-max)))) + + ;; Done canonicalizing address. + + (set-buffer extraction-buffer) + + ;; Find the full name + + (cond ((and phrase-beg + (eq quote-beg phrase-beg) + (<= quote-end phrase-end)) + (narrow-to-region (1+ quote-beg) (1- quote-end)) + (undo-backslash-quoting (point-min) (point-max))) + (phrase-beg + (narrow-to-region phrase-beg phrase-end)) + (comment-beg + (narrow-to-region (1+ comment-beg) (1- comment-end)) + (undo-backslash-quoting (point-min) (point-max))) + (t + ;; *** Work in canon buffer instead? No, can't. Hmm. + (delete-region (point-min) (point-max)) + (insert-buffer-substring canonicalization-buffer + mbox-beg mbox-end) + (goto-char (point-min)) + (setq \.-ends-name (search-forward "_" nil t)) + (goto-char (point-min)) + (while (progn + (skip-chars-forward mail-whitespace) + (not (eobp))) + (setq char (char-after (point))) + (cond + ((eq char ?\") + (setq quote-beg (point)) + (or (safe-move-sexp 1) + ;; TODO: handle this error condition!!!!! + (forward-char 1)) + ;; take into account deletions + (setq quote-end (- (point) 2)) + (save-excursion + (backward-char 1) + (delete-char 1) + (goto-char quote-beg) + (delete-char 1)) + (undo-backslash-quoting quote-beg quote-end) + (or (eq mail-space-char (char-after (point))) + (insert " ")) + (setq \.-ends-name t)) + ((eq char ?.) + (if (eq (char-after (1+ (point))) ?_) + (progn + (forward-char 1) + (delete-char 1) + (insert mail-space-char)) + (if \.-ends-name + (narrow-to-region (point-min) (point)) + (delete-char 1) + (insert " ")))) + ((memq (char-syntax char) '(?. ?\\)) + (delete-char 1) + (insert " ")) + (t + (setq atom-beg (point)) + (forward-word 1) + (setq atom-end (point)) + (save-restriction + (narrow-to-region atom-beg atom-end) + (goto-char (point-min)) + (while (re-search-forward "\\([^_]+\\)_" nil t) + (replace-match "\\1 ")) + (goto-char (point-max)))))))) + + (set-syntax-table address-text-syntax-table) + + (setq xxx (variant-method (buffer-string))) + (delete-region (point-min) (point-max)) + (insert xxx) + (goto-char (point-min)) + +;; ;; Compress whitespace +;; (goto-char (point-min)) +;; (while (re-search-forward "[ \t\n]+" nil t) +;; (replace-match " ")) +;; +;; ;; Fix . used as space +;; (goto-char (point-min)) +;; (while (re-search-forward mail-bad-\.-pattern nil t) +;; (replace-match "\\1 \\2")) +;; +;; ;; Delete trailing parenthesized comment +;; (goto-char (point-max)) +;; (skip-chars-backward mail-whitespace) +;; (cond ((memq (char-after (1- (point))) '(?\) ?\} ?\])) +;; (setq comment-end (point)) +;; (set-syntax-table address-text-comment-syntax-table) +;; (or (safe-move-sexp -1) +;; (backward-char 1)) +;; (set-syntax-table address-text-syntax-table) +;; (setq comment-beg (point)) +;; (skip-chars-backward mail-whitespace) +;; (if (bobp) +;; (narrow-to-region (1+ comment-beg) (1- comment-end)) +;; (narrow-to-region (point-min) (point))))) +;; +;; ;; Find, save, and delete any name suffix +;; ;; *** Broken! +;; (goto-char (point-min)) +;; (cond ((re-search-forward mail-full-name-suffix-pattern nil t) +;; (setq name-suffix (buffer-substring (match-beginning 3) +;; (match-end 3))) +;; (replace-match "\\1 \\4"))) +;; +;; ;; Delete ALL CAPS words and after, if preceded by mixed-case or +;; ;; lowercase words. Eg. XT-DEM. +;; (goto-char (point-min)) +;; ;; ## This will lose on something like "SMITH MAX". +;; ;; ## maybe it should be +;; ;; ## " \\([A-Z]+[-_/][A-Z]+\\|[A-Z][A-Z][A-Z]\\)\\b.*[^A-Z \t]" +;; ;; ## that is, three-letter-upper-case-word with non-upper-case +;; ;; ## characters following it. +;; (if (re-search-forward mail-mixed-case-name-pattern nil t) +;; (if (re-search-forward mail-weird-acronym-pattern nil t) +;; (narrow-to-region (point-min) (match-beginning 0)))) +;; +;; ;; Delete trailing alternative address +;; (goto-char (point-min)) +;; (if (re-search-forward mail-alternative-address-pattern nil t) +;; (narrow-to-region (point-min) (match-beginning 0))) +;; +;; ;; Delete trailing comment +;; (goto-char (point-min)) +;; (if (re-search-forward mail-trailing-comment-start-pattern nil t) +;; (or (progn +;; (goto-char (match-beginning 0)) +;; (skip-chars-backward mail-whitespace) +;; (bobp)) +;; (narrow-to-region (point-min) (match-beginning 0)))) +;; +;; ;; Delete trailing comma-separated comment +;; (goto-char (point-min)) +;; ;; ## doesn't this break "Smith, John"? Yes. +;; (re-search-forward mail-last-name-first-pattern nil t) +;; (while (search-forward "," nil t) +;; (or (save-excursion +;; (backward-char 2) +;; (looking-at mail-full-name-suffix-pattern)) +;; (narrow-to-region (point-min) (1- (point))))) +;; +;; ;; Delete telephone numbers and ham radio call signs +;; (goto-char (point-min)) +;; (if (re-search-forward mail-telephone-extension-pattern nil t) +;; (narrow-to-region (point-min) (match-beginning 0))) +;; (goto-char (point-min)) +;; (if (re-search-forward mail-ham-call-sign-pattern nil t) +;; (if (eq (match-beginning 0) (point-min)) +;; (narrow-to-region (match-end 0) (point-max)) +;; (narrow-to-region (point-min) (match-beginning 0)))) +;; +;; ;; Delete trailing word followed immediately by . +;; (goto-char (point-min)) +;; ;; ## what's this for? doesn't it mess up "Public, Harry Q."? No. +;; (if (re-search-forward "\\b[A-Za-z][A-Za-z]+\\. *\\'" nil t) +;; (narrow-to-region (point-min) (match-beginning 0))) +;; +;; ;; Handle & substitution +;; ;; TODO: remember to disable middle initial guessing +;; (goto-char (point-min)) +;; (cond ((re-search-forward "\\( \\|\\`\\)&\\( \\|\\'\\)" nil t) +;; (goto-char (match-end 1)) +;; (delete-char 1) +;; (capitalize-region +;; (point) +;; (progn +;; (insert-buffer-substring canonicalization-buffer +;; mbox-beg mbox-end) +;; (point))))) +;; +;; ;; Delete nickname +;; (goto-char (point-min)) +;; (if (re-search-forward mail-nickname-pattern nil t) +;; (replace-match (if (eq (match-beginning 2) (1- (match-end 2))) +;; " \\2 " +;; " "))) +;; +;; ;; Fixup initials +;; (while (progn +;; (goto-char (point-min)) +;; (re-search-forward mail-bad-initials-pattern nil t)) +;; (replace-match +;; (if (match-beginning 4) +;; "\\1. \\4" +;; (if (match-beginning 5) +;; "\\1. \\5" +;; "\\1. ")))) +;; +;; ;; Delete title +;; (goto-char (point-min)) +;; (if (re-search-forward mail-full-name-prefixes nil t) +;; (narrow-to-region (point) (point-max))) +;; +;; ;; Delete trailing and preceding non-name characters +;; (goto-char (point-min)) +;; (skip-chars-forward mail-non-begin-name-chars) +;; (narrow-to-region (point) (point-max)) +;; (goto-char (point-max)) +;; (skip-chars-backward mail-non-end-name-chars) +;; (narrow-to-region (point-min) (point)) + + ;; If name is "First Last" and userid is "F?L", then assume + ;; the middle initial is the second letter in the userid. + ;; initially by Jamie Zawinski <jwz@lucid.com> + (cond ((and (eq 3 (- mbox-end mbox-beg)) + (progn + (goto-char (point-min)) + (looking-at mail-two-name-pattern))) + (setq fi (char-after (match-beginning 0)) + li (char-after (match-beginning 3))) + (save-excursion + (set-buffer canonicalization-buffer) + ;; char-equal is ignoring case here, so no need to upcase + ;; or downcase. + (let ((case-fold-search t)) + (and (char-equal fi (char-after mbox-beg)) + (char-equal li (char-after (1- mbox-end))) + (setq mi (char-after (1+ mbox-beg)))))) + (cond ((and mi + ;; TODO: use better table than syntax table + (eq ?w (char-syntax mi))) + (goto-char (match-beginning 3)) + (insert (upcase mi) ". "))))) + +;; ;; Restore suffix +;; (cond (name-suffix +;; (goto-char (point-max)) +;; (insert ", " name-suffix) +;; (backward-word 1) +;; (cond ((memq (following-char) '(?j ?J ?s ?S)) +;; (capitalize-word 1) +;; (or (eq (following-char) ?.) +;; (insert ?.))) +;; (t +;; (upcase-word 1))))) + + ;; Result + (list (buffer-string) + (progn + (set-buffer canonicalization-buffer) + (buffer-string))) + ))) + +;; TODO: put this back in the above function now that it's proven: +(defun variant-method (string) + (let ((variant-buffer (get-buffer-create "*variant method buffer*")) + (word-count 0) + mixed-case-flag lower-case-flag upper-case-flag + suffix-flag last-name-comma-flag + comment-beg comment-end initial beg end + ) + (save-excursion + (set-buffer variant-buffer) + (buffer-flush-undo variant-buffer) + (set-syntax-table address-text-syntax-table) + (widen) + (erase-buffer) + (setq case-fold-search nil) + + (insert string) + + ;; Fix . used as space + (goto-char (point-min)) + (while (re-search-forward mail-bad-\.-pattern nil t) + (replace-match "\\1 \\2")) + + ;; Skip any initial garbage. + (goto-char (point-min)) + (skip-chars-forward mail-non-begin-name-chars) + (skip-chars-backward "& \"") + (narrow-to-region (point) (point-max)) + + (catch 'stop + (while t + (skip-chars-forward mail-whitespace) + + (cond + + ;; Delete title + ((and (eq word-count 0) + (looking-at mail-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-full-name-suffix-pattern)) + (skip-chars-backward mail-whitespace) + (setq suffix-flag (point)) + (if (eq ?, (following-char)) + (forward-char 1) + (insert ?,)) + ;; Enforce at least one space after comma + (or (eq mail-space-char (following-char)) + (insert mail-space-char)) + (skip-chars-forward mail-whitespace) + (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-count (1+ word-count)) + (throw 'stop t)) + + ;; Handle SCA names + ((looking-at "MKA \\(.+\\)") ; "Mundanely Known As" + (setq word-count 0) + (goto-char (match-beginning 1)) + (narrow-to-region (point) (point-max))) + + ;; Various stopping points + ((or + ;; Stop before ALL CAPS acronyms, if preceded by mixed-case or + ;; lowercase words. Eg. XT-DEM. + (and (>= word-count 2) + (or mixed-case-flag lower-case-flag) + (looking-at mail-weird-acronym-pattern) + (not (looking-at mail-roman-numeral-pattern))) + ;; Stop before 4-or-more letter lowercase words preceded by + ;; mixed case or uppercase words. + (and (>= word-count 2) + (or upper-case-flag mixed-case-flag) + (looking-at "[a-z][a-z][a-z][a-z]+\\b")) + ;; Stop before trailing alternative address + (looking-at mail-alternative-address-pattern) + ;; Stop before trailing comment not introduced by comma + (looking-at mail-trailing-comment-start-pattern) + ;; Stop before telephone numbers + (looking-at mail-telephone-extension-pattern)) + (throw 'stop 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 mail-space-char (following-char)) + (insert mail-space-char))) + + ;; Stop before trailing comma-separated comment + ((eq ?, (following-char)) + (throw 'stop t)) + + ;; Delete parenthesized/quoted comment/nickname + ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`)) + (setq comment-beg (point)) + (set-syntax-table address-text-comment-syntax-table) + (cond ((memq (following-char) '(?\' ?\`)) + (if (eq ?\' (following-char)) + (forward-char 1)) + (or (search-forward "'" nil t) + (delete-char 1))) + (t + (or (safe-move-sexp 1) + (goto-char (point-max))))) + (set-syntax-table address-text-syntax-table) + (setq comment-end (point)) + (cond + ;; Handle case of entire name being quoted + ((and (eq word-count 0) + (looking-at " *\\'") + (>= (- comment-end comment-beg) 2)) + (narrow-to-region (1+ comment-beg) (1- comment-end)) + (goto-char (point-min))) + (t + ;; Handle case of quoted initial + (if (and (or (= 3 (- comment-end comment-beg)) + (and (= 4 (- comment-end comment-beg)) + (eq ?. (char-after (+ 2 comment-beg))))) + (not (looking-at " *\\'"))) + (setq initial (char-after (1+ comment-beg))) + (setq initial nil)) + (delete-region comment-beg comment-end) + (if initial + (insert initial ". "))))) + + ;; Delete ham radio call signs + ((looking-at mail-ham-call-sign-pattern) + (delete-region (match-beginning 0) (match-end 0))) + + ;; Handle & substitution + ;; TODO: remember to disable middle initial guessing + ((and (or (bobp) + (eq mail-space-char (preceding-char))) + (looking-at "&\\( \\|\\'\\)")) + (delete-char 1) + (capitalize-region + (point) + (progn + (insert-buffer-substring canonicalization-buffer + mbox-beg mbox-end) + (point)))) + + ;; Fixup initials + ((looking-at mail-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 mail-space-char (following-char)) + (insert mail-space-char)) + (setq word-count (1+ word-count))) + + ;; Regular name words + ((looking-at mail-name-pattern) + (setq beg (point)) + (setq end (match-end 0)) + (set (if (re-search-forward "[a-z]" end t) + (if (progn + (goto-char beg) + (re-search-forward "[A-Z]" end t)) + 'mixed-case-flag + 'lower-case-flag) + 'upper-case-flag) t) + (goto-char end) + (setq word-count (1+ word-count))) + + (t + (throw 'stop t))))) + + (narrow-to-region (point-min) (point)) + + ;; Delete trailing word followed immediately by . + (cond ((not suffix-flag) + (goto-char (point-min)) + (if (re-search-forward "\\b[A-Za-z][A-Za-z]+\\. *\\'" nil t) + (narrow-to-region (point-min) (match-beginning 0))))) + + ;; If last name first put it at end (but before suffix) + (cond (last-name-comma-flag + (goto-char (point-min)) + (search-forward ",") + (setq end (1- (point))) + (goto-char (or suffix-flag (point-max))) + (or (eq mail-space-char (preceding-char)) + (insert mail-space-char)) + (insert-buffer-substring (current-buffer) (point-min) end) + (narrow-to-region (1+ end) (point-max)))) + + (goto-char (point-max)) + (skip-chars-backward mail-non-end-name-chars) + (if (eq ?. (following-char)) + (forward-char 1)) + (narrow-to-region (point) + (progn + (goto-char (point-min)) + (skip-chars-forward mail-non-begin-name-chars) + (point))) + + ;; Compress whitespace + (goto-char (point-min)) + (while (re-search-forward "[ \t\n]+" nil t) + (replace-match " ")) + + (buffer-substring (point-min) (point-max)) + + ))) + +;; The country names are just in there for show right now, and because +;; Jamie thought it would be neat. They aren't used yet. + +;; Keep in mind that the country abbreviations follow ISO-3166. There is +;; a U.S. FIPS that specifies a different set of two-letter country +;; abbreviations. + +;; TODO: put this in its own obarray, instead of cluttering up the main +;; symbol table with junk. + +(mapcar + (function + (lambda (x) + (if (symbolp x) + (put x 'domain-name t) + (put (car x) 'domain-name (nth 1 x))))) + '((ag "Antigua") + (ar "Argentina") ; Argentine Republic + arpa ; Advanced Projects Research Agency + (at "Austria") ; The Republic of _ + (au "Australia") + (bb "Barbados") + (be "Belgium") ; The Kingdom of _ + (bg "Bulgaria") + bitnet ; Because It's Time NET + (bo "Bolivia") ; Republic of _ + (br "Brazil") ; The Federative Republic of _ + (bs "Bahamas") + (bz "Belize") + (ca "Canada") + (ch "Switzerland") ; The Swiss Confederation + (cl "Chile") ; The Republic of _ + (cn "China") ; The People's Republic of _ + (co "Columbia") + com ; Commercial + (cr "Costa Rica") ; The Republic of _ + (cs "Czechoslovakia") + (de "Germany") + (dk "Denmark") + (dm "Dominica") + (do "Dominican Republic") ; The _ + (ec "Ecuador") ; The Republic of _ + edu ; Educational + (eg "Egypt") ; The Arab Republic of _ + (es "Spain") ; The Kingdom of _ + (fi "Finland") ; The Republic of _ + (fj "Fiji") + (fr "France") + gov ; Government (U.S.A.) + (gr "Greece") ; The Hellenic Republic + (hk "Hong Kong") + (hu "Hungary") ; The Hungarian People's Republic (???) + (ie "Ireland") + (il "Israel") ; The State of _ + (in "India") ; The Republic of _ + int ; something British, don't know what + (is "Iceland") ; The Republic of _ + (it "Italy") ; The Italian Republic + (jm "Jamaica") + (jp "Japan") + (kn "St. Kitts and Nevis") + (kr "South Korea") + (lc "St. Lucia") + (lk "Sri Lanka") ; The Democratic Socialist Republic of _ + mil ; Military (U.S.A.) + (mx "Mexico") ; The United Mexican States + (my "Malaysia") ; changed to Myanmar???? + (na "Namibia") + nato ; North Atlantic Treaty Organization + net ; Network + (ni "Nicaragua") ; The Republic of _ + (nl "Netherlands") ; The Kingdom of the _ + (no "Norway") ; The Kingdom of _ + (nz "New Zealand") + org ; Organization + (pe "Peru") + (pg "Papua New Guinea") + (ph "Philippines") ; The Republic of the _ + (pl "Poland") + (pr "Puerto Rico") + (pt "Portugal") ; The Portugese Republic + (py "Paraguay") + (se "Sweden") ; The Kingdom of _ + (sg "Singapore") ; The Republic of _ + (sr "Suriname") + (su "Soviet Union") + (th "Thailand") ; The Kingdom of _ + (tn "Tunisia") + (tr "Turkey") ; The Republic of _ + (tt "Trinidad and Tobago") + (tw "Taiwan") + (uk "United Kingdom") ; The _ of Great Britain + unter-dom ; something German + (us "U.S.A.") ; The United States of America + uucp ; Unix to Unix CoPy + (uy "Uruguay") ; The Eastern Republic of _ + (vc "St. Vincent and the Grenadines") + (ve "Venezuela") ; The Republic of _ + (yu "Yugoslavia") ; The Socialist Federal Republic of _ + ;; Also said to be Zambia ... + (za "South Africa") ; The Republic of _ (why not Zaire???) + (zw "Zimbabwe") ; Republic of _ + )) +;; fipnet + + +;; Code for testing. + +(defun time-extract () + (let (times list) + (setq times (cons (current-time-string) times) + list problem-address-alist) + (while list + (mail-extract-address-components (car (car list))) + (setq list (cdr list))) + (setq times (cons (current-time-string) times)) + (nreverse times))) + +(defun test-extract (&optional starting-point) + (interactive) + (set-buffer (get-buffer-create "*Testing*")) + (erase-buffer) + (sit-for 0) + (mapcar 'test-extract-internal + (if starting-point + (memq starting-point problem-address-alist) + problem-address-alist))) + +(defvar failed-item) +(defun test-extract-internal (item) + (setq failed-item item) + (let* ((address (car item)) + (correct-name (nth 1 item)) + (correct-canon (nth 2 item)) + (result (mail-extract-address-components address)) + (name (car result)) + (canon (nth 1 result)) + (name-correct (or (null correct-name) + (string-equal (downcase correct-name) + (downcase name)))) + (canon-correct (or (null correct-canon) + (string-equal correct-canon canon)))) + (cond ((not (and name-correct canon-correct)) + (pop-to-buffer "*Testing*") + (select-window (get-buffer-window (current-buffer))) + (goto-char (point-max)) + (insert "Address: " address "\n") + (if (not name-correct) + (insert " Correct Name: [" correct-name + "]\; Result: [" name "]\n")) + (if (not canon-correct) + (insert " Correct Canon: [" correct-canon + "]\; Result: [" canon "]\n")) + (insert "\n") + (sit-for 0)))) + (setq failed-item nil)) + +(defun test-continue-extract () + (interactive) + (test-extract failed-item)) + + +;; Assorted junk. + +;; warsaw@nlm.nih.gov (A Bad Dude -- Barry Warsaw) + +;;'(from +;; reply-to +;; return-path +;; x-uucp-from +;; sender +;; resent-from +;; resent-sender +;; resent-reply-to) + +;;; mail-extr.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/progmodes/make-mode.el Fri Jul 17 06:48:03 1992 +0000 @@ -0,0 +1,1043 @@ +;;; makefile.el --- makefile editing commands for Emacs + +;; Author: Thomas Neumann <tom@smart.bo.open.de> +;; Adapted-By: ESR +;; Keywords: unix tools + +;; $Id: makefile.el,v 1.7.1.17 1992/07/15 20:05:15 tom Exp tom $ + +;; Copyright (C) 1992 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Code: + +(provide 'makefile) + +;;; ------------------------------------------------------------ +;;; Configureable stuff +;;; ------------------------------------------------------------ + +(defvar makefile-mode-name "makefile" + "The \"pretty name\" of makefile-mode, as it +appears in the modeline.") + +(defvar makefile-browser-buffer-name "*Macros and Targets*" + "Name of the macro- and target browser buffer.") + +(defvar makefile-target-colon ":" + "The string that gets appended to all target names +inserted by makefile-insert-target. +\":\" or \"::\" are quite common values.") + +(defvar makefile-macro-assign " = " + "The string that gets appended to all macro names +inserted by makefile-insert-macro. +The normal value should be \" = \", since this is what +standard make expects. However, newer makes such as dmake +allow a larger variety of different macro assignments, so you +might prefer to use \" += \" or \" := \" .") + +(defvar makefile-use-curly-braces-for-macros-p nil + "Set this variable to a non-nil value if you prefer curly braces +in macro-references, so it looks like ${this}. A value of nil +will cause makefile-mode to use parantheses, making macro references +look like $(this) .") + +(defvar makefile-tab-after-target-colon t + "If you want a TAB (instead of a space) to be appended after the +target colon, then set this to a non-nil value.") + +(defvar makefile-browser-leftmost-column 10 + "Number of blanks to the left of the browser selection mark.") + +(defvar makefile-browser-cursor-column 10 + "Column in which the cursor is positioned when it moves +up or down in the browser.") + +(defvar makefile-browser-selected-mark "+ " + "String used to mark selected entries in the browser.") + +(defvar makefile-browser-unselected-mark " " + "String used to mark unselected entries in the browser.") + +(defvar makefile-browser-auto-advance-after-selection-p t + "If this variable is set to a non-nil value the cursor +will automagically advance to the next line after an item +has been selected in the browser.") + +(defvar makefile-find-file-autopickup-p t + "If this variable is set to a non-nil value then finding a file in +a makefile-mode buffer will cause an automatic initial pickup of +all macros and targets from the found file.") + +(defvar makefile-pickup-everything-picks-up-filenames-p nil + "If this variable is set to a non-nil value then +makefile-pickup-everything also picks up filenames as targets +(i.e. it calls makefile-find-filenames-as-targets), otherwise +filenames are omitted.") + +(defvar makefile-cleanup-continuations-p t + "If this variable is set to a non-nil value then makefile-mode +will assure that no line in the file ends with a backslash +(the continuation character) followed by any whitespace. +This is done by silently removing the trailing whitespace, leaving +the backslash itself intact. +IMPORTANT: Please note that enabling this option causes makefile-mode +to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \'it seems necessary\'.") + +(defvar makefile-browser-hook '() + "A function or list of functions to be called just before the +browser is entered. This is executed in the makefile buffer, so +you can for example run a makefile-pickup-everything automatically.") + +;; +;; Special targets for DMake, Sun's make ... +;; +(defvar makefile-special-targets-list + '(("DEFAULT") ("DONE") ("ERROR") ("EXPORT") + ("FAILED") ("GROUPEPILOG") ("GROUPPROLOG") ("IGNORE") + ("IMPORT") ("INCLUDE") ("INCLUDEDIRS") ("INIT") + ("KEEP_STATE") ("MAKEFILES") ("MAKE_VERSION") ("NO_PARALLEL") + ("PARALLEL") ("PHONY") ("PRECIOUS") ("REMOVE") + ("SCCS_GET") ("SILENT") ("SOURCE") ("SUFFIXES") + ("WAIT") ("c.o") ("C.o") ("m.o") + ("el.elc") ("y.c") ("s.o")) + "List of special targets. You will be offered to complete +on one of those in the minibuffer whenever you enter a \".\" +at the beginning of a line in makefile-mode.") + +(defvar makefile-runtime-macros-list + '(("@") ("&") (">") ("<") ("*") ("^") ("?") ("%")) + "List of macros that are resolved by make at runtime. +If you insert a macro reference using makefile-insert-macro-ref, the name +of the macro is checked against this list. If it can be found its name will +not be enclosed in { } or ( ).") + +(defconst makefile-dependency-regex + "^[^ \t#:]+\\([ \t]+[^ \t#:]+\\)*[ \t]*:\\($\\|\\([^=].*$\\)\\)" + "Regex used to find dependency lines in a makefile.") + +(defconst makefile-macroassign-regex + "^[^ \t][^:#=]*[\\*:\\+]?:?=.*$" + "Regex used to find macro assignment lines in a makefile.") + +(defconst makefile-ignored-files-in-pickup-regex + "\\(^\\..*\\)\\|\\(.*~$\\)\\|\\(.*,v$\\)" + "Regex for filenames that will NOT be included in the target list.") + +;;; ------------------------------------------------------------ +;;; The following configurable variables are used in the +;;; up-to-date overview . +;;; The standard configuration assumes that your `make' programm +;;; can be run in question/query mode using the `-q' option, this +;;; means that the command +;;; +;;; make -q foo +;;; +;;; should return an exit status of zero if the target `foo' is +;;; up to date and a nonzero exit status otherwise. +;;; Many makes can do this although the docs/manpages do not mention +;;; it. Try it with your favourite one. GNU make and Dennis Vaduras +;;; DMake have no problems. +;;; Set the variable `makefile-brave-make' to the name of the +;;; make utility that does this on your system. +;;; To understand what this is all about see the function defintion +;;; of `makefile-query-by-make-minus-q' . +;;; ------------------------------------------------------------ + +(defvar makefile-brave-make "gmake" + "A make that can handle the \'-q\' option.") + +(defvar makefile-query-one-target-method 'makefile-query-by-make-minus-q + "A function symbol [one that can be used as the first argument to +funcall] that provides a function that must conform to the following +interface: + +* As its first argument, it must accept the name of the target to + be checked, as a string. + +* As its second argument, it may accept the name of a makefile + as a string. Depending on what you\'re going to do you may + not need this. + +* It must return the integer value 0 (zero) if the given target + should be considered up-to-date in the context of the given + makefile, any nonzero integer value otherwise.") + +(defvar makefile-up-to-date-buffer-name "*Makefile Up-to-date overview*" + "Name of the Up-to-date overview buffer.") + +(defvar makefile-target-needs-rebuild-mark " .. NEEDS REBUILD" + "A string that is appended to the target name in the up-to-date +overview if that target is considered to require a rebuild.") + +(defvar makefile-target-up-to-date-mark " .. is up to date" + "A string that is appenden to the target name in the up-to-date +overview if that target is considered up-to-date.") + +;;; --- end of up-to-date-overview configuration ------------------ + + +(defvar makefile-mode-map nil + "The keymap that is used in makefile-mode.") +(if makefile-mode-map + () + (setq makefile-mode-map (make-sparse-keymap)) + ;; set up the keymap + (define-key makefile-mode-map "$" 'makefile-insert-macro-ref) + (define-key makefile-mode-map "\C-c:" 'makefile-insert-target-ref) + (define-key makefile-mode-map ":" 'makefile-electric-colon) + (define-key makefile-mode-map "=" 'makefile-electric-equal) + (define-key makefile-mode-map "." 'makefile-electric-dot) + (define-key makefile-mode-map "\C-c\C-t" 'makefile-pickup-targets) + (define-key makefile-mode-map "\C-c\C-m" 'makefile-pickup-macros) + (define-key makefile-mode-map "\C-c\C-f" 'makefile-pickup-filenames-as-targets) + (define-key makefile-mode-map "\C-c\C-0" 'makefile-forget-everything) + (define-key makefile-mode-map "\C-c0" 'makefile-forget-everything) + (define-key makefile-mode-map "\C-c\C-b" 'makefile-switch-to-browser) + (define-key makefile-mode-map "\C-c\C-p" 'makefile-pickup-everything) + (define-key makefile-mode-map "\C-c\C-u" 'makefile-create-up-to-date-overview) + (define-key makefile-mode-map "\C-c\C-i" 'makefile-insert-gmake-function) + (define-key makefile-mode-map "\M-p" 'makefile-previous-dependency) + (define-key makefile-mode-map "\M-n" 'makefile-next-dependency)) + +(defvar makefile-browser-map nil + "The keymap that is used in the macro- and target browser.") +(if makefile-browser-map + () + (setq makefile-browser-map (make-sparse-keymap)) + (define-key makefile-browser-map "n" 'makefile-browser-next-line) + (define-key makefile-browser-map "\C-n" 'makefile-browser-next-line) + (define-key makefile-browser-map "p" 'makefile-browser-previous-line) + (define-key makefile-browser-map "\C-p" 'makefile-browser-previous-line) + (define-key makefile-browser-map " " 'makefile-browser-toggle) + (define-key makefile-browser-map "i" 'makefile-browser-insert-selection) + (define-key makefile-browser-map "I" 'makefile-browser-insert-selection-and-quit) + (define-key makefile-browser-map "\C-c\C-m" 'makefile-browser-insert-continuation) + (define-key makefile-browser-map "q" 'makefile-browser-quit) + ;; disable horizontal movement + (define-key makefile-browser-map "\C-b" 'undefined) + (define-key makefile-browser-map "\C-f" 'undefined)) + + +(defvar makefile-mode-syntax-table nil + "The syntax-table used in makefile mode.") +(if makefile-mode-syntax-table + () + (setq makefile-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?\( "() " makefile-mode-syntax-table) + (modify-syntax-entry ?\) ")( " makefile-mode-syntax-table) + (modify-syntax-entry ?\[ "(] " makefile-mode-syntax-table) + (modify-syntax-entry ?\] "([ " makefile-mode-syntax-table) + (modify-syntax-entry ?\{ "(} " makefile-mode-syntax-table) + (modify-syntax-entry ?\} "){ " makefile-mode-syntax-table) + (modify-syntax-entry ?# "< " makefile-mode-syntax-table) + (modify-syntax-entry ?\n "> " makefile-mode-syntax-table)) + + +;;; ------------------------------------------------------------ +;;; Internal variables. +;;; You don't need to configure below this line. +;;; ------------------------------------------------------------ + +(defvar makefile-target-table nil + "Table of all targets that have been inserted in +this Makefile buffer using makefile-insert-target or picked up +using makefile-pickup-targets.") + +(defvar makefile-macro-table nil + "Table of all macros that have been iserted in +this Makefile buffer using makefile-insert-macro or picked up +using makefile-pickup-macros.") + +(defvar makefile-browser-client + "A buffer in makefile-mode that is currently using the browser.") + +(defvar makefile-browser-selection-vector nil) + +(defvar makefile-mode-hook '()) + +(defconst makefile-gnumake-functions-alist + + '( + ;; Text functions + ("subst" "From" "To" "In") + ("patsubst" "Pattern" "Replacement" "In") + ("strip" "Text") + ("findstring" "Find what" "In") + ("filter" "Pattern" "Text") + ("filter-out" "Pattern" "Text") + ("sort" "List") + ;; Filename functions + ("dir" "Names") + ("notdir" "Names") + ("suffix" "Names") + ("basename" "Names") + ("addsuffix" "Suffix" "Names") + ("join" "List 1" "List 2") + ("word" "Index" "Text") + ("words" "Text") + ("firstword" "Text") + ("wildcard" "Pattern") + ;; Misc functions + ("foreach" "Variable" "List" "Text") + ("origin" "Variable") + ("shell" "Command")) + "A list of GNU make 3.62 function names associated with +the prompts for each function. +This is used in the function makefile-insert-gmake-function .") + + +;;; ------------------------------------------------------------ +;;; The mode function itself. +;;; ------------------------------------------------------------ + +(defun makefile-mode () + "Major mode for editing Makefiles. +Calling this function invokes the function(s) \"makefile-mode-hook\" before +doing anything else. + +\\{makefile-mode-map} + +In the browser, use the following keys: + +\\{makefile-browser-map} + +makefile-mode can be configured by modifying the following +variables: + +makefile-mode-name: + The \"pretty name\" of makefile-mode, as it + appears in the modeline. + +makefile-browser-buffer-name: + Name of the macro- and target browser buffer. + +makefile-target-colon: + The string that gets appended to all target names + inserted by makefile-insert-target. + \":\" or \"::\" are quite common values. + +makefile-macro-assign: + The string that gets appended to all macro names + inserted by makefile-insert-macro. + The normal value should be \" = \", since this is what + standard make expects. However, newer makes such as dmake + allow a larger variety of different macro assignments, so you + might prefer to use \" += \" or \" := \" . + +makefile-tab-after-target-colon: + If you want a TAB (instead of a space) to be appended after the + target colon, then set this to a non-nil value. + +makefile-browser-leftmost-column: + Number of blanks to the left of the browser selection mark. + +makefile-browser-cursor-column: + Column in which the cursor is positioned when it moves + up or down in the browser. + +makefile-browser-selected-mark: + String used to mark selected entries in the browser. + +makefile-browser-unselected-mark: + String used to mark unselected entries in the browser. + +makefile-browser-auto-advance-after-selection-p: + If this variable is set to a non-nil value the cursor + will automagically advance to the next line after an item + has been selected in the browser. + +makefile-find-file-autopickup-p: + If this variable is set to a non-nil value then finding a file in + a makefile-mode buffer will cause an automatic initial pickup of + all macros and targets from the found file. + +makefile-pickup-everything-picks-up-filenames-p: + If this variable is set to a non-nil value then + makefile-pickup-everything also picks up filenames as targets + (i.e. it calls makefile-find-filenames-as-targets), otherwise + filenames are omitted. + +makefile-cleanup-continuations-p: + If this variable is set to a non-nil value then makefile-mode + will assure that no line in the file ends with a backslash + (the continuation character) followed by any whitespace. + This is done by silently removing the trailing whitespace, leaving + the backslash itself intact. + IMPORTANT: Please note that enabling this option causes makefile-mode + to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \'it seems necessary\'. + +makefile-browser-hook: + A function or list of functions to be called just before the + browser is entered. This is executed in the makefile buffer, so + you can for example run a makefile-pickup-everything automatically. + +makefile-special-targets-list: + List of special targets. You will be offered to complete + on one of those in the minibuffer whenever you enter a \".\" + at the beginning of a line in makefile-mode." + (interactive) + (kill-all-local-variables) + (if (not (memq 'makefile-find-file-autopickup find-file-hooks)) + (setq find-file-hooks + (append find-file-hooks (list 'makefile-find-file-autopickup)))) + (if (not (memq 'makefile-cleanup-continuations write-file-hooks)) + (setq write-file-hooks + (append write-file-hooks (list 'makefile-cleanup-continuations)))) + (make-variable-buffer-local 'makefile-target-table) + (make-variable-buffer-local 'makefile-macro-table) + (makefile-forget-all-macros) + (makefile-forget-all-targets) + (setq comment-start "#") + (setq comment-end "") + (setq comment-start-skip "#[ \t]*") + ;; become the current major mode + (setq major-mode 'makefile-mode) + (setq mode-name makefile-mode-name) + ;; activate keymap + (use-local-map makefile-mode-map) + (set-syntax-table makefile-mode-syntax-table) + (run-hooks 'makefile-mode-hook)) + + +(defun makefile-find-file-autopickup () + (if (eq major-mode 'makefile-mode) + (if makefile-find-file-autopickup-p + (makefile-pickup-everything)))) + +(defun makefile-next-dependency () + "Move (point) to the beginning of the next dependency line +below the current position of (point)." + (interactive) + (let ((here (point))) + (end-of-line) + (if (re-search-forward makefile-dependency-regex (point-max) t) + (progn (beginning-of-line) t) ; indicate success + (goto-char here) nil))) + +(defun makefile-previous-dependency () + "Move (point) to the beginning of the next dependency line +above the current position of (point)." + (interactive) + (let ((here (point))) + (beginning-of-line) + (if (re-search-backward makefile-dependency-regex (point-min) t) + (progn (beginning-of-line) t) ; indicate success + (goto-char here) nil))) + + +(defun makefile-electric-dot () + "At (bol), offer completion on makefile-special-targets-list. +Anywhere else just insert a dot." + (interactive) + (if (bolp) + (makefile-insert-special-target) + (insert "."))) + + +(defun makefile-insert-special-target () + "Offer completion on makefile-special-targets-list and insert +the result at (point)." + (interactive) + (let + ((special-target + (completing-read "Special target: " + makefile-special-targets-list nil nil nil))) + (if (zerop (length special-target)) + () + (insert (format ".%s:" special-target)) + (makefile-forward-after-target-colon)))) + + +(defun makefile-electric-equal () + "At (bol) do makefile-insert-macro. Anywhere else just +self-insert." + (interactive) + (if (bolp) + (call-interactively 'makefile-insert-macro) + (insert "="))) + +(defun makefile-insert-macro (macro-name) + "Prepare definition of a new macro." + (interactive "sMacro Name: ") + (if (not (zerop (length macro-name))) + (progn + (beginning-of-line) + (insert (format "%s%s" macro-name makefile-macro-assign)) + (makefile-remember-macro macro-name)))) + + +(defun makefile-insert-macro-ref (macro-name) + "Offer completion on a list of known macros, then +insert complete macro-ref at (point) ." + (interactive + (list + (completing-read "Refer to macro: " makefile-macro-table nil nil nil))) + (if (not (zerop (length macro-name))) + (if (assoc macro-name makefile-runtime-macros-list) + (insert (format "$%s " macro-name)) + (insert (makefile-format-macro-ref macro-name) " ")))) + + +(defun makefile-insert-target (target-name) + "Prepare definition of a new target (dependency line)." + (interactive "sTarget: ") + (if (not (zerop (length target-name))) + (progn + (beginning-of-line) + (insert (format "%s%s" target-name makefile-target-colon)) + (makefile-forward-after-target-colon) + (end-of-line) + (makefile-remember-target target-name)))) + + +(defun makefile-insert-target-ref (target-name) + "Offer completion on a list of known targets, then +insert complete target-ref at (point) ." + (interactive + (list + (completing-read "Refer to target: " makefile-target-table nil nil nil))) + (if (not (zerop (length target-name))) + (progn + (insert (format "%s " target-name))))) + +(defun makefile-electric-colon () + "At (bol) defines a new target, anywhere else just self-insert ." + (interactive) + (if (bolp) + (call-interactively 'makefile-insert-target) + (insert ":"))) + + +;;; ------------------------------------------------------------ +;;; Extracting targets and macros from an existing makefile +;;; ------------------------------------------------------------ + +(defun makefile-pickup-targets () + "Scan a buffer that contains a makefile for target definitions (dependencies) +and add them to the list of known targets." + (interactive) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward makefile-dependency-regex (point-max) t) + (makefile-add-this-line-targets)))) +; (forward-line 1)))) + +(defun makefile-add-this-line-targets () + (save-excursion + (beginning-of-line) + (let ((done-with-line nil)) + (while (not done-with-line) + (skip-chars-forward " \t") + (if (not (setq done-with-line (or (eolp) + (char-equal (char-after (point)) ?:)))) + (progn + (let* ((start-of-target-name (point)) + (target-name + (progn + (skip-chars-forward "^ \t:#") + (buffer-substring start-of-target-name (point))))) + (if (makefile-remember-target target-name) + (message "Picked up target \"%s\"" target-name))))))))) + + +(defun makefile-pickup-macros () + "Scan a buffer that contains a makefile for macro definitions +and add them to the list of known macros." + (interactive) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward makefile-macroassign-regex (point-max) t) + (makefile-add-this-line-macro) + (forward-line 1)))) + +(defun makefile-add-this-line-macro () + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (if (not (eolp)) + (let* ((start-of-macro-name (point)) + (macro-name (progn + (skip-chars-forward "^ \t:#=*") + (buffer-substring start-of-macro-name (point))))) + (if (makefile-remember-macro macro-name) + (message "Picked up macro \"%s\"" macro-name)))))) + + +(defun makefile-pickup-everything () + "Calls makefile-pickup-targets and makefile-pickup-macros. +See their documentation for what they do." + (interactive) + (makefile-pickup-macros) + (makefile-pickup-targets) + (if makefile-pickup-everything-picks-up-filenames-p + (makefile-pickup-filenames-as-targets))) + + +(defun makefile-pickup-filenames-as-targets () + "Scan the current directory for filenames, check each filename +against makefile-ignored-files-in-pickup-regex and add all qualifying +names to the list of known targets." + (interactive) + (let* ((dir (file-name-directory (buffer-file-name))) + (raw-filename-list (if dir + (file-name-all-completions "" dir) + (file-name-all-completions "" "")))) + (mapcar '(lambda (name) + (if (and (not (file-directory-p name)) + (not (string-match makefile-ignored-files-in-pickup-regex + name))) + (if (makefile-remember-target name) + (message "Picked up file \"%s\" as target" name)))) + raw-filename-list))) + +;;; ------------------------------------------------------------ +;;; The browser window +;;; ------------------------------------------------------------ + + +(defun makefile-browser-format-target-line (target selected) + (format + (concat (make-string makefile-browser-leftmost-column ?\ ) + (if selected + makefile-browser-selected-mark + makefile-browser-unselected-mark) + "%s%s") + target makefile-target-colon)) + +(defun makefile-browser-format-macro-line (macro selected) + (format + (concat (make-string makefile-browser-leftmost-column ?\ ) + (if selected + makefile-browser-selected-mark + makefile-browser-unselected-mark) + (makefile-format-macro-ref macro)))) + +(defun makefile-browser-fill (targets macros) + (setq buffer-read-only nil) + (goto-char (point-min)) + (erase-buffer) + (mapconcat + (function + (lambda (item) (insert (makefile-browser-format-target-line (car item) nil) "\n"))) + targets + "") + (mapconcat + (function + (lambda (item) (insert (makefile-browser-format-macro-line (car item) nil) "\n"))) + macros + "") + (sort-lines nil (point-min) (point-max)) + (goto-char (1- (point-max))) + (delete-char 1) ; remove unnecessary newline at eob + (goto-char (point-min)) + (forward-char makefile-browser-cursor-column) + (setq buffer-read-only t)) + + +;;; +;;; Moving up and down in the browser +;;; + +(defun makefile-browser-next-line () + "Move the browser selection cursor to the next line." + (interactive) + (if (not (makefile-last-line-p)) + (progn + (forward-line 1) + (forward-char makefile-browser-cursor-column)))) + +(defun makefile-browser-previous-line () + "Move the browser selection cursor to the previous line." + (interactive) + (if (not (makefile-first-line-p)) + (progn + (forward-line -1) + (forward-char makefile-browser-cursor-column)))) + +;;; +;;; Quitting the browser (returns to client buffer) +;;; + +(defun makefile-browser-quit () + "Leave the makefile-browser-buffer and return to the buffer +from that it has been entered." + (interactive) + (let ((my-client makefile-browser-client)) + (setq makefile-browser-client nil) ; we quitted, so NO client! + (set-buffer-modified-p nil) + (kill-buffer (current-buffer)) + (pop-to-buffer my-client))) + +;;; +;;; Toggle state of a browser item +;;; + +(defun makefile-browser-toggle () + "Toggle the selection state of the browser item at the cursor position." + (interactive) + (let ((this-line (count-lines (point-min) (point)))) + (setq this-line (max 1 this-line)) + (makefile-browser-toggle-state-for-line this-line) + (goto-line this-line) + (setq buffer-read-only nil) + (beginning-of-line) + (if (makefile-browser-on-macro-line-p) + (let ((macro-name (makefile-browser-this-line-macro-name))) + (kill-line) + (insert + (makefile-browser-format-macro-line + macro-name + (makefile-browser-get-state-for-line this-line)))) + (let ((target-name (makefile-browser-this-line-target-name))) + (kill-line) + (insert + (makefile-browser-format-target-line + target-name + (makefile-browser-get-state-for-line this-line))))) + (setq buffer-read-only t) + (beginning-of-line) + (forward-char makefile-browser-cursor-column) + (if makefile-browser-auto-advance-after-selection-p + (makefile-browser-next-line)))) + +;;; +;;; Making insertions into the client buffer +;;; + +(defun makefile-browser-insert-continuation () + "In the browser\'s client buffer, go to (end-of-line), insert a \'\\\' +character, insert a new blank line, go to that line and indent by one TAB. +This is most useful in the process of creating continued lines when 'sending' large +dependencies from the browser to the client buffer. +(point) advances accordingly in the client buffer." + (interactive) + (save-excursion + (set-buffer makefile-browser-client) + (end-of-line) + (insert "\\\n\t"))) + +(defun makefile-browser-insert-selection () + "Insert all browser-selected targets and/or macros in the browser\'s +client buffer. +Insertion takes place at (point)." + (interactive) + (save-excursion + (goto-line 1) + (let ((current-line 1)) + (while (not (eobp)) + (if (makefile-browser-get-state-for-line current-line) + (makefile-browser-send-this-line-item)) + (forward-line 1) + (setq current-line (1+ current-line)))))) + +(defun makefile-browser-insert-selection-and-quit () + (interactive) + (makefile-browser-insert-selection) + (makefile-browser-quit)) + +(defun makefile-browser-send-this-line-item () + (if (makefile-browser-on-macro-line-p) + (save-excursion + (let ((macro-name (makefile-browser-this-line-macro-name))) + (set-buffer makefile-browser-client) + (insert (makefile-format-macro-ref macro-name) " "))) + (save-excursion + (let ((target-name (makefile-browser-this-line-target-name))) + (set-buffer makefile-browser-client) + (insert target-name " "))))) + + +(defun makefile-browser-start-interaction () + (use-local-map makefile-browser-map) + (setq buffer-read-only t)) + + +(defun makefile-browse (targets macros) + (interactive) + (if (zerop (+ (length targets) (length macros))) + (progn + (beep) + (message "No macros or targets to browse! Consider running 'makefile-pickup-everything\'")) + (let ((browser-buffer (get-buffer-create makefile-browser-buffer-name))) + (pop-to-buffer browser-buffer) + (make-variable-buffer-local 'makefile-browser-selection-vector) + (makefile-browser-fill targets macros) + (setq makefile-browser-selection-vector + (make-vector (+ (length targets) (length macros)) nil)) + (makefile-browser-start-interaction)))) + + +(defun makefile-switch-to-browser () + (interactive) + (run-hooks 'makefile-browser-hook) + (setq makefile-browser-client (current-buffer)) + (makefile-browse makefile-target-table makefile-macro-table)) + + +;;; ------------------------------------------------------------ +;;; Up-to-date overview buffer +;;; ------------------------------------------------------------ + +(defun makefile-create-up-to-date-overview () + "Create a buffer containing an overview of the state of all +known targets from the makefile that is currently being edited. +Known targets are targets that are explicitly defined in that makefile; +in other words, all targets that appear on the left hand side of a +dependency in the makefile." + (interactive) + (if (y-or-n-p "Are you sure that the makefile being edited is consistent? ") + ;; + ;; The rest of this function operates on a temporary makefile, created by + ;; writing the current contents of the makefile buffer. + ;; + (let ((saved-target-table makefile-target-table) + (this-buffer (current-buffer)) + (makefile-up-to-date-buffer + (get-buffer-create makefile-up-to-date-buffer-name)) + (filename (makefile-save-temporary)) + ;; + ;; Forget the target table because it may contain picked-up filenames + ;; that are not really targets in the current makefile. + ;; We don't want to query these, so get a new target-table with just the + ;; targets that can be found in the makefile buffer. + ;; The 'old' target table will be restored later. + ;; + (real-targets (progn + (makefile-forget-all-targets) + (makefile-pickup-targets) + makefile-target-table))) + + (set-buffer makefile-up-to-date-buffer) + (setq buffer-read-only nil) + (erase-buffer) + (makefile-query-targets filename real-targets) + (if (zerop (buffer-size)) ; if it did not get us anything + (progn + (kill-buffer (current-buffer)) + (message "No overview created!"))) + (set-buffer this-buffer) + (setq makefile-target-table saved-target-table) + (if (get-buffer makefile-up-to-date-buffer-name) + (progn + (pop-to-buffer (get-buffer makefile-up-to-date-buffer-name)) + (sort-lines nil (point-min) (point-max)) + (setq buffer-read-only t)))))) + + + +(defun makefile-save-temporary () + "Create a temporary file from the current makefile buffer." + (let ((filename (makefile-generate-temporary-filename))) + (write-region (point-min) (point-max) filename nil 0) + filename)) ; return the filename + +(defun makefile-generate-temporary-filename () + "Create a filename suitable for use in makefile-save-temporary. +Be careful to allow brain-dead file systems (DOS, SYSV ...) to cope +with the generated name !" + (let ((my-name (user-login-name)) + (my-uid (int-to-string (user-uid)))) + (concat "mktmp" + (if (> (length my-name) 3) + (substring my-name 0 3) + my-name) + "." + (if (> (length my-uid) 3) + (substring my-uid 0 3) + my-uid)))) + +(defun makefile-query-targets (filename target-table) + "This function fills the up-to-date-overview-buffer. +It checks each target in target-table using makefile-query-one-target-method +and generates the overview, one line per target name." + (insert + (mapconcat '(lambda (item) + (let ((target-name (car item))) + (makefile-format-up-to-date-buffer-entry + (funcall makefile-query-one-target-method + target-name filename) target-name))) + target-table "\n")) + (goto-char (point-min)) + (delete-file filename)) ; remove the tmpfile + +(defun makefile-query-by-make-minus-q (target &optional filename) + (not (zerop (call-process makefile-brave-make nil nil nil "-f" filename "-q" target)))) + +(defun makefile-format-up-to-date-buffer-entry (needs-rebuild target) + (format "\t%s%s" + target + (if needs-rebuild + makefile-target-needs-rebuild-mark + makefile-target-up-to-date-mark))) + + +;;; ------------------------------------------------------------ +;;; Continuation cleanup +;;; ------------------------------------------------------------ + +(defun makefile-cleanup-continuations () + (if (eq major-mode 'makefile-mode) + (if (and makefile-cleanup-continuations-p + (not buffer-read-only)) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "\\\\[ \t]+$" (point-max) t) + (replace-match "\\" t t)))))) + +;;; ------------------------------------------------------------ +;;; GNU make function support +;;; ------------------------------------------------------------ + +(defun makefile-insert-gmake-function () + "This function is intended to help you using the numerous +macro-like \'function calls\' of GNU make. +It will ask you for the name of the function you wish to +use (with completion), then, after you selected the function, +it will prompt you for all required parameters. +This function \'knows\' about the required parameters of every +GNU make function and will use meaningfull prompts for the +various args, making it much easier to take advantage of this +powerfull GNU make feature." + (interactive) + (let* ((gm-function-name (completing-read + "Function: " + makefile-gnumake-functions-alist + nil t nil)) + (gm-function-prompts + (cdr (assoc gm-function-name makefile-gnumake-functions-alist)))) + (if (not (zerop (length gm-function-name))) + (insert (makefile-format-macro-ref + (concat gm-function-name " " + (makefile-prompt-for-gmake-funargs + gm-function-name gm-function-prompts))) + " ")))) + +(defun makefile-prompt-for-gmake-funargs (function-name prompt-list) + (mapconcat + (function (lambda (one-prompt) + (read-string (format "[%s] %s: " function-name one-prompt) nil))) + prompt-list + ",")) + + + +;;; ------------------------------------------------------------ +;;; Utility functions +;;; ------------------------------------------------------------ + +(defun makefile-forget-all-targets () + "Clear the target-table for this buffer." + (interactive) + (setq makefile-target-table '())) + +(defun makefile-forget-all-macros () + "Clear the macro-table for this buffer." + (interactive) + (setq makefile-macro-table '())) + + +(defun makefile-forget-everything () + "Clear the macro-table AND the target-table for this buffer." + (interactive) + (if (y-or-n-p "Really forget all macro- and target information ? ") + (progn + (makefile-forget-all-targets) + (makefile-forget-all-macros) + (if (get-buffer makefile-browser-buffer-name) + (kill-buffer makefile-browser-buffer-name)) + (message "Cleared macro- and target tables.")))) + +(defun makefile-remember-target (target-name) + "Remember a given target if it is not already remembered for this buffer." + (if (not (zerop (length target-name))) + (if (not (assoc target-name makefile-target-table)) + (setq makefile-target-table + (cons (list target-name) makefile-target-table))))) + +(defun makefile-remember-macro (macro-name) + "Remember a given macro if it is not already remembered for this buffer." + (if (not (zerop (length macro-name))) + (if (not (assoc macro-name makefile-macro-table)) + (setq makefile-macro-table + (cons (list macro-name) makefile-macro-table))))) + +(defun makefile-forward-after-target-colon () +"Move point forward after the terminating colon +of a target has been inserted. +This accts according to the value of makefile-tab-after-target-colon ." + (if makefile-tab-after-target-colon + (insert "\t") + (insert " "))) + +(defun makefile-browser-on-macro-line-p () + "Determine if point is on a macro line in the browser." + (save-excursion + (beginning-of-line) + (re-search-forward "\\$[{(]" (makefile-end-of-line-point) t))) + +(defun makefile-browser-this-line-target-name () + "Extract the target name from a line in the browser." + (save-excursion + (end-of-line) + (skip-chars-backward "^ \t") + (buffer-substring (point) (1- (makefile-end-of-line-point))))) + +(defun makefile-browser-this-line-macro-name () + "Extract the macro name from a line in the browser." + (save-excursion + (beginning-of-line) + (re-search-forward "\\$[{(]" (makefile-end-of-line-point) t) + (let ((macro-start (point))) + (skip-chars-forward "^})") + (buffer-substring macro-start (point))))) + +(defun makefile-format-macro-ref (macro-name) + "Format a macro reference according to the value of the +configuration variable makefile-use-curly-braces-for-macros-p ." + (if makefile-use-curly-braces-for-macros-p + (format "${%s}" macro-name) + (format "$(%s)" macro-name))) + +(defun makefile-browser-get-state-for-line (n) + (aref makefile-browser-selection-vector (1- n))) + +(defun makefile-browser-set-state-for-line (n to-state) + (aset makefile-browser-selection-vector (1- n) to-state)) + +(defun makefile-browser-toggle-state-for-line (n) + (makefile-browser-set-state-for-line n (not (makefile-browser-get-state-for-line n)))) + +(defun makefile-beginning-of-line-point () + (save-excursion + (beginning-of-line) + (point))) + +(defun makefile-end-of-line-point () + (save-excursion + (end-of-line) + (point))) + +(defun makefile-last-line-p () + (= (makefile-end-of-line-point) (point-max))) + +(defun makefile-first-line-p () + (= (makefile-beginning-of-line-point) (point-min))) + +;; makefile.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/textmodes/sgml-mode.el Fri Jul 17 06:48:03 1992 +0000 @@ -0,0 +1,266 @@ +;;; sgml-mode.el --- SGML-editing mode + +;; Maintainer: FSF +;; Last-Modified: 14 Jul 1992 +;; Adapted-By: ESR + +;; Copyright (C) 1992 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; Some suggestions for your .emacs file: +;; +;; (autoload 'sgml-mode "sgml-mode" "SGML mode" t) +;; +;; (setq auto-mode-alist +;; (append (list (cons "\\.sgm$" 'sgml-mode) +;; (cons "\\.sgml$" 'sgml-mode) +;; (cons "\\.dtd$" 'sgml-mode)) +;; auto-mode-alist)) + +;;; Code: + +(provide 'sgml-mode) +(require 'compile) + +;;; sgmls is a free SGML parser available from +;;; ftp.uu.net:pub/text-processing/sgml +;;; Its error messages can be parsed by next-error. +;;; The -s option suppresses output. + +(defconst sgml-validate-command + "sgmls -s" + "*The command to validate an SGML document. +The file name of current buffer file name will be appended to this, +separated by a space.") + +(defvar sgml-saved-validate-command nil + "The command last used to validate in this buffer.") + +(defvar sgml-mode-map nil "Keymap for SGML mode") + +(if sgml-mode-map + () + (setq sgml-mode-map (make-sparse-keymap)) + (define-key sgml-mode-map ">" 'sgml-close-angle) + (define-key sgml-mode-map "/" 'sgml-slash) + (define-key sgml-mode-map "\C-c\C-v" 'sgml-validate)) + +(defun sgml-mode () + "Major mode for editing SGML. +Makes > display the matching <. Makes / display matching /. +Use \\[sgml-validate] to validate your document with an SGML parser." + (interactive) + (kill-all-local-variables) + (setq local-abbrev-table text-mode-abbrev-table) + (use-local-map sgml-mode-map) + (setq mode-name "SGML") + (setq major-mode 'sgml-mode) + (make-local-variable 'paragraph-start) + ;; A start or end tag by itself on a line separates a paragraph. + ;; This is desirable because SGML discards a newline that appears + ;; immediately after a start tag or immediately before an end tag. + (setq paragraph-start + "^[ \t\n]\\|\ +\\(</?\\([A-Za-z]\\([-.A-Za-z0-9= \t\n]\\|\"[^\"]*\"\\|'[^']*'\\)*\\)?>$\\)") + (make-local-variable 'paragraph-separate) + (setq paragraph-separate + "^[ \t\n]*$\\|\ +^</?\\([A-Za-z]\\([-.A-Za-z0-9= \t\n]\\|\"[^\"]*\"\\|'[^']*'\\)*\\)?>$") + (make-local-variable 'sgml-saved-validate-command) + (set-syntax-table text-mode-syntax-table) + (make-local-variable 'comment-start) + (setq comment-start "<!-- ") + (make-local-variable 'comment-end) + (setq comment-end " -->") + (make-local-variable 'comment-indent-hook) + (setq comment-indent-hook 'sgml-comment-indent) + (make-local-variable 'comment-start-skip) + ;; This will allow existing comments within declarations to be + ;; recognized. + (setq comment-start-skip "--[ \t]*") + (run-hooks 'text-mode-hook 'sgml-mode-hook)) + +(defun sgml-comment-indent () + (if (and (looking-at "--") + (not (and (eq (char-after (1- (point))) ?!) + (eq (char-after (- (point) 2)) ?<)))) + (progn + (skip-chars-backward " \t") + (max comment-column (1+ (current-column)))) + 0)) + +(defconst sgml-start-tag-regex + "<[A-Za-z]\\([-.A-Za-z0-9= \n\t]\\|\"[^\"]*\"\\|'[^']*'\\)*" + "Regular expression that matches a non-empty start tag. +Any terminating > or / is not matched.") + +(defvar sgml-mode-markup-syntax-table nil + "Syntax table used for scanning SGML markup.") + +(if sgml-mode-markup-syntax-table + () + (setq sgml-mode-markup-syntax-table (make-syntax-table)) + (modify-syntax-entry ?< "(>" sgml-mode-markup-syntax-table) + (modify-syntax-entry ?> ")<" sgml-mode-markup-syntax-table) + (modify-syntax-entry ?- "_ 1234" sgml-mode-markup-syntax-table) + (modify-syntax-entry ?\' "\"" sgml-mode-markup-syntax-table)) + +(defconst sgml-angle-distance 4000 + "*If non-nil, is the maximum distance to search for matching < +when > is inserted.") + +(defun sgml-close-angle (arg) + "Insert > and display matching <." + (interactive "p") + (insert-char ?> arg) + (if (> arg 0) + (let ((oldpos (point)) + (blinkpos)) + (save-excursion + (save-restriction + (if sgml-angle-distance + (narrow-to-region (max (point-min) + (- (point) sgml-angle-distance)) + oldpos)) + ;; See if it's the end of a marked section. + (and (> (- (point) (point-min)) 3) + (eq (char-after (- (point) 2)) ?\]) + (eq (char-after (- (point) 3)) ?\]) + (re-search-backward "<!\\[\\(-?[A-Za-z0-9. \t\n&;]\\|\ +--\\([^-]\\|-[^-]\\)*--\\)*\\[" + (point-min) + t) + (let ((msspos (point))) + (if (and (search-forward "]]>" oldpos t) + (eq (point) oldpos)) + (setq blinkpos msspos)))) + ;; This handles cases where the > ends one of the following: + ;; markup declaration starting with <! (possibly including a + ;; declaration subset); start tag; end tag; SGML declaration. + (if blinkpos + () + (goto-char oldpos) + (condition-case () + (let ((oldtable (syntax-table)) + (parse-sexp-ignore-comments t)) + (unwind-protect + (progn + (set-syntax-table sgml-mode-markup-syntax-table) + (setq blinkpos (scan-sexps oldpos -1))) + (set-syntax-table oldtable))) + (error nil)) + (and blinkpos + (goto-char blinkpos) + (or + ;; Check that it's a valid delimiter in context. + (not (looking-at + "<\\(\\?\\|/?[A-Za-z>]\\|!\\([[A-Za-z]\\|--\\)\\)")) + ;; Check that it's not a net-enabling start tag + ;; nor an unclosed start-tag. + (looking-at (concat sgml-start-tag-regex "[/<]")) + ;; Nor an unclosed end-tag. + (looking-at "</[A-Za-z][-.A-Za-z0-9]*[ \t]*<")) + (setq blinkpos nil))) + (if blinkpos + () + ;; See if it's the end of a processing instruction. + (goto-char oldpos) + (if (search-backward "<?" (point-min) t) + (let ((pipos (point))) + (if (and (search-forward ">" oldpos t) + (eq (point) oldpos)) + (setq blinkpos pipos)))))) + (if blinkpos + (progn + (goto-char blinkpos) + (if (pos-visible-in-window-p) + (sit-for 1) + (message "Matches %s" + (buffer-substring blinkpos + (progn (end-of-line) + (point))))))))))) + +;;; I doubt that null end tags are used much for large elements, +;;; so use a small distance here. +(defconst sgml-slash-distance 1000 + "*If non-nil, is the maximum distance to search for matching / +when / is inserted.") + +(defun sgml-slash (arg) + "Insert / and display any previous matching /. +Two /s are treated as matching if the first / ends a net-enabling +start tag, and the second / is the corresponding null end tag." + (interactive "p") + (insert-char ?/ arg) + (if (> arg 0) + (let ((oldpos (point)) + (blinkpos) + (level 0)) + (save-excursion + (save-restriction + (if sgml-slash-distance + (narrow-to-region (max (point-min) + (- (point) sgml-slash-distance)) + oldpos)) + (if (and (re-search-backward sgml-start-tag-regex (point-min) t) + (eq (match-end 0) (1- oldpos))) + () + (goto-char (1- oldpos)) + (while (and (not blinkpos) + (search-backward "/" (point-min) t)) + (let ((tagend (save-excursion + (if (re-search-backward sgml-start-tag-regex + (point-min) t) + (match-end 0) + nil)))) + (if (eq tagend (point)) + (if (eq level 0) + (setq blinkpos (point)) + (setq level (1- level))) + (setq level (1+ level))))))) + (if blinkpos + (progn + (goto-char blinkpos) + (if (pos-visible-in-window-p) + (sit-for 1) + (message "Matches %s" + (buffer-substring (progn + (beginning-of-line) + (point)) + (1+ blinkpos)))))))))) + +(defun sgml-validate (command) + "Validate an SGML document. +Runs COMMAND, a shell command, in a separate process asynchronously +with output going to the buffer *compilation*. +You can then use the command \\[next-error] to find the next error message +and move to the line in the SGML document that caused it." + (interactive + (list (read-string "Validate command: " + (or sgml-saved-validate-command + (concat sgml-validate-command + " " + (let ((name (buffer-file-name))) + (and name + (file-name-nondirectory name)))))))) + (setq sgml-saved-validate-command command) + (compile1 command "No more errors")) + +;;; sgml-mode.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/textmodes/two-column.el Fri Jul 17 06:48:03 1992 +0000 @@ -0,0 +1,646 @@ +;;; two-column.el --- minor mode for editing of two-column text + +;; Author: Daniel Pfeiffer <pfeiffer@cix.cict.fr> +;; Last-Modified: 14 May 1991 +;; Adapted-By: ESR + +;; Copyright (C) 1992 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; --8<---- two-column.el ----8<--------8<--------8<--------8<--------8<------- +;; Esperanto: English: + +;; Minora modalo por samtempa dukolumna Minor mode for simultaneous +;; tajpado two-column editing + +;; ^Ci dataro estas ero de GNU Emacs. This file is part of GNU Emacs. + +;; GNU Emacs estas disdonata en la GNU Emacs is distributed in the hope +;; espero ke ^gi estos utila, sed SEN that it will be useful, but WITHOUT +;; IA GARANTIO. Neniu a^utoro a^u ANY WARRANTY. No author or +;; disdonanto akceptas respondecon al distributor accepts responsibility +;; iu ajn por la sekvoj de ^gia uzado, to anyone for the consequences of +;; a^u ^cu ^gi serveblas al iu celo, using it or for whether it serves +;; a^u e^c entute funkcias, se li ni any particular purpose or works at +;; estas skribinta tion. Vidu la GNU all, unless he says so in writing. +;; Emacs ^Generala Publika Licenco por Refer to the GNU Emacs General +;; plenaj detaloj. Public License for full details. + +;; ^Ciu rajtas kopii, modifi kaj ree Everyone is granted permission to +;; disdoni GNU Emacs, sed nur sub la copy, modify and redistribute GNU +;; condi^coj priskribitaj en la GNU Emacs, but only under the conditions +;; Emacs ^Generala Publika Licenco. described in the GNU Emacs General +;; Kopio de tiu licenso estas supozata Public License. A copy of this +;; donita al vi kune kun GNU Emacs, por license is supposed to have been +;; ke vi sciu viajn rajtojn kaj given to you along with GNU Emacs so +;; respondecojn. ^Gi devus esti en you can know your rights and +;; dataro nomata COPYING. Inter responsibilities. It should be in a +;; alia^joj, la notico pri kopirajto file named COPYING. Among other +;; kaj ^ci notico devas esti gardata things, the copyright notice and +;; sur ^ciuj kopioj. this notice must be preserved on all +;; copies. + + +;; Tiu minora modalo ebligas al vi This minor mode allows you to +;; tajpi sendepende en du apudaj independently edit two adjacent +;; bufroj. Vi havas tri eblecojn por buffers. You have three ways to +;; eki ^gin. ^Ciu donas al vi start it up. Each gives you a +;; horizontale disigatan fenestron, horizontally split window similar to +;; simila al fina apareco de via the final outcome of your text: +;; teksto: + +;; C-x 6 2 asocias novan bufron nomatan associates a new buffer called +;; same, sed kun 2C/ anta^u. the same, but with 2C/ +;; prepended. + +;; C-x 6 b asocias alian bufron. Vi povas associates another buffer. +;; anka^u asocii dataron, se vi This can be used to associate a +;; ^jus anta^ue faris C-x C-f. file if you just did C-x C-f. + +;; C-x 6 u disigas jam dukolumnan tekston unmerges a two-column text into +;; en du bufroj ekde la nuna two buffers from the current +;; linio, kaj je la nuna kolumno. line and at the current column. +;; La anta^uaj signoj (ofte The preceding characters (often +;; tabeligilo a^u |) estas la tab or |) are the column +;; kolumna disiganto. Linioj kiuj separator. Lines that don't +;; ne enhavas ilin ne estas have them won't be separated. +;; disigitaj. Kiel la kvara kaj Like the fourth and fifth line +;; la kvina linio se vi disigas if you unmerge this file from +;; ^ci dataron ekde la unua angla the first english word. +;; vorto. + +;; Je ^cia flanko estas bufro, kiu On each side is a buffer that knows +;; konas la alian. Kun la ordonoj C-x about the other. With the commands +;; 6 SPC, C-x 6 DEL kaj C-x 6 RET oni C-x 6 SPC, C-x 6 DEL and C-x 6 RET +;; povas suben- a^u supreniri unu you can simultaneously scroll up or +;; ekranon, kaj subeniri linion, down by a screenfull and by a line +;; samtempe en la du bufroj. Al la alia in both buffers. Empty lines are +;; bufro estas aldonataj linioj se added to the other buffer if +;; necesas, por ke vi vidu la saman necessary, so that you see the same +;; parton. Per C-x 6 C-l vi povas part. With C-x 6 C-l you can +;; recentrigi la linion. Kiam vi nur recenter the line. When you only +;; plu havas unu el la du bufroj have one of the two buffers onscreen +;; surekrane vi revidos la alian per you can get the other back with C-x +;; denove C-x 6 2. 6 2 once more. + +;; Se vi volas meti longajn liniojn If you include long lines, i.e which +;; (ekz. programerojn) en la kunigotan will span both columns (eg. source +;; tekston, ili devas esti en la code), they should be in what will +;; estonte unua kolumno. La alia devas be the first column, with the +;; havi malplenajn linion apud ili. associated buffer having empty lines +;; next to them. + +;; Averto: en Emacs kiam vi ^san^gas la Attention: in Emacs when you change +;; ma^joran modalon, la minoraj modaloj the major mode, the minor modes are +;; estas anka^u elmemorigitaj. Tiu- also purged from memory. In that +;; okaze vi devas religi la du bufrojn case you must reassociate the two +;; per iu C-x 6-ordono, ekz. C-x 6 b. buffers with any C-x 6-command, e.g. +;; C-x 6 b. + +;; Kiam vi estos kontenta de la When you have edited both buffers to +;; rezulto, vi kunmetos la du kolumnojn your content, you merge them with +;; per C-x 6 1. Se vi poste vidas C-x 6 1. If you then see a problem, +;; problemon, vi neniigu la kunmeton you undo the merge with C-x u and +;; per C-x u kaj plue modifu la du continue to edit the two buffers. +;; bufrojn. Kiam vi ne plu volas tajpi When you no longer want to edit in +;; dukolumne, vi eliru el la minora two columns, you turn off the minor +;; modalo per C-x 6 k. mode with C-x 6 k. + + +;; An^stata^u tri `autoload' kaj tri | Instead of three `autoload' and +;; `global-set-key' vi povas uzi la | three `global-set-key' you can use +;; jenon en via dataro ~/.emacs, por | the following in your file +;; memstare ^car^gi la modalon: | ~/.emacs, to automatically load +;; | the mode: + +;; (global-set-key "\C-x6" +;; '(lambda () (interactive) +;; (load-library "two-column") +;; (call-interactively +;; (cdr (assq (read-char) tc-mode-map))))) + +;; Se vi ^satus havi la dukolumnajn | If you'd like to have the +;; ordonojn je funkciklavo <f2>, vi | two-column commands on function +;; povas uzi la jenon en via dataro | key <f2>, you can use the +;; ~/.emacs: | following in your file ~/.emacs: + +;; (define-key function-keymap "\^b" +;; '(lambda () (interactive) +;; (load-library "two-column") +;; (define-key function-keymap "\^b" tc-mode-map) +;; (call-interactively +;; (cdr (assq (read-char) tc-mode-map))))) + +;; In addition to two-column editing of text, for example for writing a +;; bilingual text side-by-side as shown below in the file's prolog, other +;; interesting uses have been found for this minor mode: +;; +;; +;; You can separate the columns with {+} C-x 6 u or <f2> u if you prefer +;; any string that pleases you, by {+} handles these with a prefix argument +;; setting tc-separator. For {+} that enables you to declare the +;; example "{+} " if you like to {+} desired length of such a string. +;; amuse yourself. +;; +;; +;; keyword You can write any text corresponding to a +;; given keyword in a filled paragraph next to +;; it. Note that the width of the first column +;; may be less than window-min-width in the +;; result, but will be displayed at that width. +;; +;; another This is not a three- or multi-column mode. +;; The example in the file's prolog required +;; working on two columns and then treating the +;; result as one column in order to add the +;; third. +;; +;; +;; Programmers might like the ability to split off the comment column of +;; a file that looks like the following. The advantage is that with +;; (setq fill-prefix "-- ") you can run M-q (fill-paragraph) on the +;; comment. The problem is, code quickly gets rather wide, so you need +;; to use a narrower comment column, which is less interesting, unless +;; you have a 132-column screen. Code lines that reach beyond +;; comment-column are no problem, except that you won't always see their +;; end during editing. +;; +;; BEGIN -- This is just some meaningless +;; FOR i IN 1..10 LOOP -- code in Ada, that runs foobar +;; foobar( i ); -- once for each argument from one +;; END LOOP; -- to ten, and then we're already +;; END; -- through with it. +;; +;; Better yet, you can put the point before "This", type M-3 C-x 6 u +;; which makes "-- " the separator between a no-comments Ada buffer, and +;; a plain text comment buffer. When you put them back together, every +;; non-empty line of the 2nd column will again be preceded by "-- ". +;; +;; +;; The <f2> function key hack (which is one of the rare times when +;; function keys are mnemonic) at the end of the file's prolog requires +;; that the lisp/term/*.el for your terminal use the standard +;; conventions. Too bad that some don't (at least not in version 18.55). +;; The Sun one is hopelessly non-standard, and vt2[024]0 somehow forgot +;; to define <f1> thru <f5>. (It defines <pf1> thru <pf4> instead, but +;; that is not what we need on an X terminal.) If you want to use those, +;; you'll need another hack something like: +;; +;; (if (string= (system-name) "cix") +;; (progn +;; (load-library "term/vt200.el") +;; (define-key CSI-map "12~" (cons function-keymap ?\^b))) +;; (global-unset-key "\e[") +;; (define-key esc-map "[225z" (cons function-keymap ?\^b))) +;; +;; where "cix" is the non-sun machine I use. Actually I use the same X +;; terminal to connect to both machines, and I want to keep my ~/.emacs +;; identical on both. Bother, the two Emacses don't recognize the same +;; keys and assign different sequences to those they do! I sure hope all +;; this nonsense will stop with version 19 (or preferably soon) where I'd +;; like to be able to say (define-key some-map '<f2> some-cmd), and see +;; <f2> rather than some unintelligible ESC-sequence in command key +;; sequences. + +;;; Code: + +;;;;; variable declarations ;;;;; + +(provide 'two-column) + +(defvar tc-prefix "\C-x6" + "Prefix tc-mode-map gets bound to. +If you'd like to bind it to function key <f2>, see the prolog of the +source file, lisp/two-column.el") + +(defvar tc-mode-map nil + "Keymap that contains all commands useful with two-column minor mode. +This gets bound globally to `tc-prefix' since minor modes have +no local keymap.") + +(if tc-mode-map + () + (setq tc-mode-map (make-sparse-keymap)) + (define-key tc-mode-map "1" 'tc-merge) + (define-key tc-mode-map "2" 'tc-split) + (define-key tc-mode-map "b" 'tc-associate-buffer) + (define-key tc-mode-map "k" 'tc-kill-association) + (define-key tc-mode-map "\C-l" 'tc-recenter) + (define-key tc-mode-map "o" 'tc-associated-buffer) + (define-key tc-mode-map "u" 'tc-unmerge) + (define-key tc-mode-map "{" 'shrink-window-horizontally) + (define-key tc-mode-map "}" 'enlarge-window-horizontally) + (define-key tc-mode-map " " 'tc-scroll-up) + (define-key tc-mode-map "\^?" 'tc-scroll-down) + (define-key tc-mode-map "\C-m" 'tc-scroll-line)) + +(global-set-key tc-prefix tc-mode-map) + + +;; markers seem to be the only buffer-id not affected by renaming +;; a buffer. This nevertheless loses when a buffer is killed. +(defvar tc-other nil + "Marker to the associated buffer, if non-nil.") +(make-variable-buffer-local 'tc-other) + + +(defvar tc-buffer-list () + "An alist of markers to associated buffers. (Backs up `tc-other')") + +(setq minor-mode-alist (cons '(tc-other " 2C") minor-mode-alist)) + +;; rearranged, so that the pertinent info will show in 40 columns +(defvar tc-mode-line-format + '("-%*- %15b --" (-3 . "%p") "--%[(" mode-name + minor-mode-alist "%n" mode-line-process ")%]%-") + "*Value of mode-line-format for a buffer in two-column minor mode.") + +(defvar tc-separator "" + "*A string inserted between the two columns when merging. +This gets set locally by \\[tc-unmerge].") + +(defvar tc-window-width 40 + "*The width of the first column. (Must be at least `window-min-width') +This value is local for every buffer that sets it.") +(make-variable-buffer-local 'tc-window-width) + +(defvar tc-beyond-fill-column 4 + "*Base for calculating `fill-column' for a buffer in two-column minor mode. +The value of `fill-column' becomes `tc-window-width' for this buffer +minus this value.") + +(defvar tc-mode-hook nil + "Function called, if non-nil, whenever turning on two-column minor mode. +It can get called by \\[tc-split] (tc-split), \\[tc-unmerge] (tc-unmerge) +and \\[tc-associate-buffer] (tc-associate-buffer), on both buffers.") + +;;;;; base functions ;;;;; + +;; the access method for the other buffer. this tries to remedy against +;; lost local variables and lost buffers. +(defun tc-other () + (if (or tc-other + (setq tc-other + ; assoc with a different predicate, since we don't know + ; which marker points to this buffer + (let ((bl tc-buffer-list)) + (while (and bl (not (eq (current-buffer) + (marker-buffer (car (car bl)))))) + (setq bl (cdr bl))) + (cdr (car bl))))) + (or (prog1 + (marker-buffer tc-other) + (setq mode-line-format tc-mode-line-format )) + ; The associated buffer somehow got killed. + (progn + ; The other variables may later be useful if the user + ; reestablishes the association. + (kill-local-variable 'tc-other) + (kill-local-variable 'mode-line-format) + nil)))) + +(defun tc-split (&optional buffer) + "Split current window vertically for two-column editing. + +When called the first time, associates a buffer with the current +buffer. Both buffers are put in two-column minor mode and +tc-mode-hook gets called on both. These buffers remember +about one another, even when renamed. + +When called again, restores the screen layout with the current buffer +first and the associated buffer to it's right. + +If you include long lines, i.e which will span both columns (eg. +source code), they should be in what will be the first column, with +the associated buffer having empty lines next to them. + +You have the following commands at your disposal: + +\\[tc-split] Rearrange screen +\\[tc-associate-buffer] Reassociate buffer after changing major mode +\\[tc-scroll-up] Scroll both buffers up by a screenfull +\\[tc-scroll-down] Scroll both buffers down by a screenful +\\[tc-scroll-line] Scroll both buffers up by one or more lines +\\[tc-recenter] Recenter and realign other buffer +\\[shrink-window-horizontally], \\[enlarge-window-horizontally] Shrink, enlarge current column +\\[tc-associated-buffer] Switch to associated buffer +\\[tc-merge] Merge both buffers + +These keybindings can be customized in your ~/.emacs by `tc-prefix' +and `tc-mode-map'. + +The appearance of the screen can be customized by the variables +`tc-window-width', `tc-beyond-fill-column', +`tc-mode-line-format' and `truncate-partial-width-windows'." + + (interactive "P") + ; first go to full width, so that we can certainly split into + ; two windows + (if (< (window-width) (screen-width)) + (enlarge-window 99999 t)) + (split-window-horizontally + (max window-min-width (min tc-window-width + (- (screen-width) window-min-width)))) + (if (tc-other) + (progn + (other-window 1) + (switch-to-buffer (tc-other)) + (other-window -1) + ; align buffers if necessary + (tc-scroll-line 0)) + + ; set up minor mode linking two buffers + (setq fill-column (- tc-window-width + tc-beyond-fill-column) + mode-line-format tc-mode-line-format) + (run-hooks tc-mode-hook) + (let ((other (point-marker))) + (other-window 1) + (switch-to-buffer + (or buffer + (generate-new-buffer + (concat "2C/" (buffer-name))))) + (or buffer + (text-mode)) + (setq fill-column (- tc-window-width + tc-beyond-fill-column) + mode-line-format tc-mode-line-format + tc-other other + other (point-marker)) + (setq tc-buffer-list (cons (cons tc-other other) + tc-buffer-list)) + (run-hooks tc-mode-hook) + (other-window -1) + (setq tc-buffer-list + (cons (cons other + (save-excursion + (set-buffer (tc-other)) + tc-other)) + tc-buffer-list)) + (setq tc-other other)))) + +(fset 'tc-mode 'tc-split) + +(defun tc-associate-buffer () + "Associate another buffer with this one in two-column minor mode. +Can also be used to associate a just previously visited file, by +accepting the proposed default buffer. + +See \\[tc-split] and `lisp/two-column.el' for further details." + (interactive) + (let ((b1 (current-buffer)) + (b2 (or (tc-other) + (read-buffer "Associate buffer: " (other-buffer))))) + (save-excursion + (setq tc-other nil) + (set-buffer b2) + (and (tc-other) + (not (eq b1 (tc-other))) + (error "Buffer already associated with buffer `%s'." + (buffer-name (tc-other)))) + (setq b1 (and (assq 'tc-window-width (buffer-local-variables)) + tc-window-width))) + ; if other buffer has a local width, adjust here too + (if b1 (setq tc-window-width (- (screen-width) b1))) + (tc-split b2))) + +(defun tc-unmerge (arg) + "Unmerge a two-column text into two buffers in two-column minor mode. +The text is unmerged at the cursor's column which becomes the local +value of tc-window-width. Only lines that have the ARG same +preceding characters at that column get split. The ARG preceding +characters without any leading whitespace become the local value for +`tc-separator'. This way lines that continue across both +columns remain untouched in the first buffer. + +This function can be used with a prototype line, to set up things as +you like them. You write the first line of each column with the +separator you like and then unmerge that line. E.g.: + +First column's text sSs Second columns text + \\___/\\ + / \\ + 5 character Separator You type M-5 \\[tc-unmerge] with the point here + +See \\[tc-split] and `lisp/two-column.el' for further details." + (interactive "p") + (and (tc-other) + (if (y-or-n-p (concat "Overwrite associated buffer `" + (buffer-name (tc-other)) + "'? ")) + (save-excursion + (set-buffer (tc-other)) + (erase-buffer)) + (signal 'quit nil))) + (let ((point (point)) + ; make next-line always come back to same column + (goal-column (current-column)) + ; a counter for empty lines in other buffer + (n (1- (count-lines (point-min) (point)))) + chars other) + (save-excursion + (backward-char arg) + (setq chars (buffer-substring (point) point)) + (skip-chars-forward " \t" point) + (make-variable-buffer-local 'tc-separator) + (setq tc-separator (buffer-substring (point) point) + tc-window-width (current-column))) + (tc-split) + (setq other (tc-other)) + ; now we're ready to actually unmerge + (save-excursion + (while (not (eobp)) + (if (not (and (= (current-column) goal-column) + (string= chars + (buffer-substring (point) + (save-excursion + (backward-char arg) + (point)))))) + (setq n (1+ n)) + (setq point (point)) + (backward-char arg) + (skip-chars-backward " \t") + (delete-region point (point)) + (setq point (point)) + (insert-char ?\n n) + (append-to-buffer other point (progn (end-of-line) + (if (eobp) + (point) + (1+ (point))))) + (delete-region point (point)) + (setq n 0)) + (next-line 1))))) + +(defun tc-kill-association () + "Turn off two-column minor mode in current and associated buffer. +If the associated buffer is unmodified and empty, it is killed." + (interactive) + (let ((buffer (current-buffer))) + (save-excursion + (and (tc-other) + (prog2 + (setq tc-buffer-list + (delq (assq tc-other tc-buffer-list) + tc-buffer-list)) + (set-buffer (tc-other)) + (setq tc-buffer-list + (delq (assq tc-other tc-buffer-list) + tc-buffer-list))) + (or (not (tc-other)) + (eq buffer (tc-other))) + (if (and (not (buffer-modified-p)) + (eobp) (bobp)) + (kill-buffer nil) + (kill-local-variable 'tc-other) + (kill-local-variable 'tc-window-width) + (kill-local-variable 'tc-separator) + (kill-local-variable 'mode-line-format) + (kill-local-variable 'fill-column)))) + (kill-local-variable 'tc-other) + (kill-local-variable 'tc-window-width) + (kill-local-variable 'tc-separator) + (kill-local-variable 'mode-line-format) + (kill-local-variable 'fill-column))) + + +;; this doesn't use yank-rectangle, so that the first column can +;; contain long lines +(defun tc-merge () + "Merges the associated buffer with the current buffer. +They get merged at the column, which is the value of +`tc-window-width', i.e. usually at the vertical window +separator. This separator gets replaced with white space. Beyond +that the value of gets inserted on merged lines. The two columns are +thus pasted side by side, in a single text. If the other buffer is +not displayed to the left of this one, then this one becomes the left +column. + +If you want `tc-separator' on empty lines in the second column, +you should put just one space in them. In the final result, you can strip +off trailing spaces with \\[beginning-of-buffer] \\[replace-regexp] [ SPC TAB ] + $ RET RET" + + (interactive) + (or (tc-other) + (error "You must first set two-column minor mode.")) + (and (> (car (window-edges)) 0) ; not touching left edge of screen + (eq (window-buffer (previous-window)) + (tc-other)) + (other-window -1)) + (save-excursion + (let ((b1 (current-buffer)) + (b2 (tc-other)) + string) + (goto-char (point-min)) + (set-buffer b2) + (goto-char (point-min)) + (while (not (eobp)) + (setq string (buffer-substring (point) + (progn (end-of-line) (point)))) + (or (eobp) + (forward-char)) ; next line + (set-buffer b1) + (if (string= string "") + () + (end-of-line) + (indent-to-column tc-window-width) + (insert tc-separator string)) + (next-line 1) ; add one if necessary + (set-buffer b2)))) + (if (< (window-width) (screen-width)) + (enlarge-window 99999 t))) + +;;;;; utility functions ;;;;; + +(defun tc-associated-buffer () + "Switch to associated buffer." + (interactive) + (or (tc-other) + (error "You must set two-column minor mode.")) + (if (get-buffer-window (tc-other)) + (select-window (get-buffer-window (tc-other))) + (switch-to-buffer (tc-other)))) + +;; It would be desirable to intercept anything that causes the current +;; window to scroll. Maybe a `scroll-hook'? +(defun tc-scroll-line (arg) + "Scroll current window upward by ARG lines. +The associated window gets scrolled to the same line." + (interactive "p") + (or (tc-other) + (error "You must set two-column minor mode.")) + ; scroll-up has a bug on arg 0 at end of buffer + (or (zerop arg) + (scroll-up arg)) + (setq arg (count-lines (point-min) (window-start))) + ; too bad that pre 18.57 Emacs makes save-window-excursion restore + ; the point. When it becomes extinct, we can simplify this. + (if (get-buffer-window (tc-other)) + (let ((window (selected-window))) + (select-window (get-buffer-window (tc-other))) + (setq arg (- arg (count-lines (point-min) (window-start)))) + ; make sure that other buffer has enough lines + (save-excursion + (goto-char (point-max)) + (insert-char ?\n + (- arg (count-lines (window-start) (point-max)) -1))) + (or (zerop arg) + (scroll-up arg)) + (select-window window)))) + +(defun tc-scroll-up (arg) + "Scroll current window upward by ARG screens. +The associated window gets scrolled to the same line." + (interactive "p") + (tc-scroll-line (* arg (- (window-height) + next-screen-context-lines 1)))) + +(defun tc-scroll-down (arg) + "Scroll current window downward by ARG screens. +The associated window gets scrolled to the same line." + (interactive "p") + (tc-scroll-line (* arg (- next-screen-context-lines + (window-height) -1)))) + +(defun tc-recenter (arg) + "Center point in window. With ARG, put point on line ARG. +This counts from bottom if ARG is negative. The associated window +gets scrolled to the same line." + (interactive "P") + (setq arg (and arg (prefix-numeric-value arg))) + (tc-scroll-line (- (count-lines (window-start) (point)) + (cond ((null arg) (/ (window-height) 2)) + ((< arg 0) (+ (window-height) arg)) + ( arg))))) + +(defun enlarge-window-horizontally (arg) + "Make current window ARG columns wider." + (interactive "p") + (enlarge-window arg t) + (and (tc-other) + (setq tc-window-width (+ tc-window-width arg)) + (set-buffer (tc-other)) + (setq tc-window-width (- tc-window-width arg)))) + +(defun shrink-window-horizontally (arg) + "Make current window ARG columns narrower." + (interactive "p") + (enlarge-window-horizontally (- arg))) + +;;; two-column.el ends here