;; The present file contains all the infrastructure needed for that.
;;
;; Generally, to implement a new multisession capability within Ediff,
-;; you need to tell it
+;; you need to tell it
;;
;; 1. How to display the session group buffer.
;; This function must indicate which Ediff sessions are active (+) and
;; elements must describe individual sessions.
;; This descriptor must be a list of two, three, or four elements (nil
;; or string). The function ediff-redraw-registry-buffer displays the
-;; second through last of these in the registry buffer.
+;; second through last of these in the registry buffer.
;; Also, keep in mind that the function ediff-prepare-meta-buffer
;; (which see) prepends the session group buffer to the descriptor, and
-;; nil in front of each subsequent list (i.e., the above list
+;; nil in front of each subsequent list (i.e., the above list
;; will become
;; ((meta-buf descriptor) (nil obj1 obj2 obj3) (nil ...) ...)
;; Ediff expects that your function (in 2 above) will arrange to
;; and obj3 are markers that specify the patch corresponding to the
;; file (whose name is obj1).
;; 4. Write a function that makes a call to ediff-prepare-meta-buffer
-;; passing all this info.
+;; passing all this info.
;; You may be able to use ediff-directories-internal as a template.
;; 5. If you intend to add several related pieces of functionality,
;; you may want to keep the function in 4 as an internal version
;; with different parameters.
;; See how ediff-directories, ediff-merge-directories, and
;; ediff-merge-directories-with-ancestor all use
-;; ediff-directories-internal.
+;; ediff-directories-internal.
;;
;; A useful addition here could be session groups selected by patterns
;; (which are different in each directory). For instance, one may want to
;; which may be in the same or different directories. Or, one may want to
;; compare all files of the form {something} to files of the form {something}~.
;;
-;; Implementing this requires writing an collating function, which should pair
+;; Implementing this requires writing a collating function, which should pair
;; up appropriate files. It will also require a generalization of the
;; functions that do the layout of the meta- and differences buffers and of
;; ediff-filegroup-action.
This hook can be used to save the previous window config, which can be restored
on ediff-quit, ediff-suspend, or ediff-quit-session-group-hook."
:type 'hook
- :group 'ediff-hook)
+ :group 'ediff-hook)
(defcustom ediff-after-session-group-setup-hook nil
"*Hooks run just after a meta-buffer controlling a session group, such as
ediff-directories, is run."
;; checks if the session is a meta session
(defun ediff-meta-session-p (session-info)
(and (stringp (ediff-get-session-objA-name session-info))
- (file-directory-p (ediff-get-session-objA-name session-info))
+ (file-directory-p (ediff-get-session-objA-name session-info))
(stringp (ediff-get-session-objB-name session-info))
(file-directory-p (ediff-get-session-objB-name session-info))
(if (stringp (ediff-get-session-objC-name session-info))
;;; (while (ediff-get-session-status
;;; (ediff-get-meta-info (current-buffer) pos 'noerror))
;;; (setq pos (ediff-previous-meta-overlay-start pos)))
-
+
(if pos (goto-char pos))
(if (eq ediff-metajob-name 'ediff-registry)
(if (and (ediff-get-meta-info (current-buffer) pos 'noerror)
lis1 (directory-files auxdir1 nil regexp)
lis1 (delete "." lis1)
lis1 (delete ".." lis1)
- lis1 (mapcar
+ lis1 (mapcar
(lambda (elt)
(ediff-add-slash-if-directory auxdir1 elt))
lis1)
auxdir2 (file-name-as-directory dir2)
- lis2 (mapcar
+ lis2 (mapcar
(lambda (elt)
(ediff-add-slash-if-directory auxdir2 elt))
(directory-files auxdir2 nil regexp)))
(if (stringp dir3)
(setq auxdir3 (file-name-as-directory dir3)
- lis3 (mapcar
+ lis3 (mapcar
(lambda (elt)
(ediff-add-slash-if-directory auxdir3 elt))
(directory-files auxdir3 nil regexp))))
)
difflist)
(setq difflist (cons (list regexp auxdir1 auxdir2 auxdir3) difflist))
-
+
;; return the difference list back to the calling function
(set diff-var difflist)
;; return result
(cons (list regexp auxdir1 auxdir2 auxdir3 merge-autostore-dir)
(mapcar
- (lambda (elt)
+ (lambda (elt)
(list (concat auxdir1 elt)
(concat auxdir2 elt)
(if lis3
(mapcar (lambda (elt) (list (concat auxdir1 elt) nil nil))
common))
))
-
+
;; If file groups selected by patterns will ever be implemented, this
;; comparison function might become useful.
(defun ediff-prepare-meta-buffer (action-func meta-list
meta-buffer-name redraw-function
jobname &optional startup-hooks)
- (let* ((meta-buffer-name
+ (let* ((meta-buffer-name
(ediff-unique-buffer-name meta-buffer-name "*"))
(meta-buffer (get-buffer-create meta-buffer-name)))
(ediff-with-current-buffer meta-buffer
;; comes after ediff-meta-action-function is set
(ediff-setup-meta-map)
-
+
(if (eq ediff-metajob-name 'ediff-registry)
(progn
(setq ediff-registry-buffer meta-buffer
(mapcar (lambda (obj) (list obj nil))
elt))))
(cdr meta-list)))))
-
+
(or (eq meta-buffer ediff-registry-buffer)
(setq ediff-session-registry
(cons meta-buffer ediff-session-registry)))
-
+
;; redraw-function uses ediff-meta-list
(funcall redraw-function ediff-meta-list)
-
+
;; set read-only/non-modified
(setq buffer-read-only t)
(set-buffer-modified-p nil)
(or (ediff-one-filegroup-metajob jobname)
(ediff-draw-dir-diffs ediff-dir-difference-list))
- (define-key
+ (define-key
ediff-meta-buffer-map "h" 'ediff-mark-for-hiding-at-pos)
(define-key ediff-meta-buffer-map "x" 'ediff-hide-marked-sessions)
- (define-key
+ (define-key
ediff-meta-buffer-map "m" 'ediff-mark-for-operation-at-pos)
(define-key ediff-meta-buffer-map "u" nil)
(define-key
ediff-meta-buffer-map "um" 'ediff-unmark-all-for-operation)
- (define-key
+ (define-key
ediff-meta-buffer-map "uh" 'ediff-unmark-all-for-hiding)
(cond ((ediff-collect-diffs-metajob jobname)
(define-key
;; Insert session status at point. Status is either ?H (marked for hiding), or
;; ?I (hidden or invalid), or ?* (meaning marked for an operation; currently,
;; such op can only be checking for equality)), or SPC (meaning neither marked
-;; nor invalid)
+;; nor invalid)
(defun ediff-insert-session-status-in-meta-buffer (session)
(insert
(cond ((ediff-get-session-status session)) ; session has status: ?H, ?I, ?*
(if ediff-emacs-p
(mapcar 'delete-overlay (overlays-in 1 1))
(map-extents 'delete-extent))
-
+
(insert (format ediff-meta-buffer-message
(ediff-abbrev-jobname ediff-metajob-name)))
(setq regexp (ediff-get-group-regexp meta-list)
merge-autostore-dir
(ediff-get-group-merge-autostore-dir meta-list))
-
+
(cond ((ediff-collect-diffs-metajob)
(insert
" P:\tcollect custom diffs of all marked sessions\n"))
----------------------------------------------
")
-
+
;; discard info on directories and regexp
(setq meta-list (cdr meta-list)
tmp-list meta-list)
(if empty
(insert
" ****** ****** This session group has no members\n"))
-
+
;; now organize file names like this:
;; use-mark sizeA dateA sizeB dateB filename
;; make sure directories are displayed with a trailing slash.
(dir3 (if (stringp dir3) (ediff-abbreviate-file-name dir3)))
(meta-buf (ediff-get-group-buffer diff-list))
(underline (make-string 26 ?-))
- file code
+ file code
buffer-read-only)
;; skip the directory part
(setq diff-list (cdr diff-list))
(insert (format "%-26s" "---")))
(if (stringp dir3)
(if (= (mod code 5) 0) ; dir3
- (insert (format " %-25s"
+ (insert (format " %-25s"
(ediff-truncate-string-left
(ediff-abbreviate-file-name
(if (file-directory-p (concat dir3 file))
(ediff-show-meta-buffer
ediff-parent-meta-buffer ediff-meta-session-number)
(error "This session group has no parent")))
-
+
;; argument is ignored
(defun ediff-redraw-registry-buffer (&optional ignore)
(while registry-list
(setq elt (car registry-list)
registry-list (cdr registry-list))
-
+
(if (ediff-buffer-live-p elt)
(if (ediff-with-current-buffer elt
(setq job-name ediff-metajob-name
;;; (error "Can't hide active session, %s" (buffer-name session-buf)))
(t (ediff-set-session-status info ?H))))
unmark)
-
+
(defun ediff-mark-for-operation-at-pos (unmark)
"Mark session for a group operation. With prefix arg, unmark."
(save-excursion
(setq numMarked (1+ numMarked))
(funcall operation elt sessionNum)))
- ((and (ediff-meta-session-p elt)
- (ediff-buffer-live-p
+ ((and (ediff-meta-session-p elt)
+ (ediff-buffer-live-p
(setq session-buf (ediff-get-session-buffer elt))))
(setq numMarked
- (+ numMarked
+ (+ numMarked
(ediff-with-current-buffer session-buf
;; pass meta-diff along
(setq ediff-meta-diff-buffer diff-buffer)
(goto-char (point-max))
(insert-buffer custom-diff-buf)
(insert "\n")))
- ((memq metajob '(ediff-directories
+ ((memq metajob '(ediff-directories
ediff-merge-directories
ediff-merge-directories-with-ancestor))
;; get diffs by calling shell command on ediff-custom-diff-program
))
(error "The patch buffer wasn't found"))))
-
+
;; This function executes in meta buffer. It knows where event happened.
(defun ediff-filegroup-action ()
"Execute appropriate action for the selected session."
;; do ediff/ediff-merge on subdirectories
(if (ediff-buffer-live-p session-buf)
(ediff-show-meta-buffer session-buf)
- (setq regexp (read-string "Filter through regular expression: "
+ (setq regexp (read-string "Filter through regular expression: "
nil 'ediff-filtering-regexp-history))
(ediff-directories-internal
file1 file2 file3 regexp
ediff-session-action-function
- ediff-metajob-name
+ ediff-metajob-name
;; make it update (car info) after startup
- `(list (lambda ()
+ `(list (lambda ()
;; child session group should know its parent
(setq ediff-parent-meta-buffer
(quote ,ediff-meta-buffer)
(file-directory-p file1))
(if (ediff-buffer-live-p session-buf)
(ediff-show-meta-buffer session-buf)
- (setq regexp (read-string "Filter through regular expression: "
+ (setq regexp (read-string "Filter through regular expression: "
nil 'ediff-filtering-regexp-history))
(ediff-directory-revisions-internal
file1 regexp
ediff-session-action-function ediff-metajob-name
;; make it update (car info) after startup
- `(list (lambda ()
+ `(list (lambda ()
;; child session group should know its parent and
;; its number
(setq ediff-parent-meta-buffer
"This session has no ancestor. Merge without the ancestor? ")
(ediff-merge-files
file1 file2
- ;; provide startup hooks
- `(list (lambda ()
+ ;; provide startup hooks
+ `(list (lambda ()
(add-hook
'ediff-after-quit-hook-internal
(lambda ()
((ediff-one-filegroup-metajob) ; needs 1 file arg
(funcall ediff-session-action-function
file1
- ;; provide startup hooks
- `(list (lambda ()
+ ;; provide startup hooks
+ `(list (lambda ()
(add-hook
'ediff-after-quit-hook-internal
(lambda ()
((not (ediff-metajob3)) ; need 2 file args
(funcall ediff-session-action-function
file1 file2
- ;; provide startup hooks
- `(list (lambda ()
+ ;; provide startup hooks
+ `(list (lambda ()
(add-hook
'ediff-after-quit-hook-internal
(lambda ()
((ediff-metajob3) ; need 3 file args
(funcall ediff-session-action-function
file1 file2 file3
- ;; arrange startup hooks
- `(list (lambda ()
+ ;; arrange startup hooks
+ `(list (lambda ()
(add-hook
'ediff-after-quit-hook-internal
(lambda ()
(set-window-buffer (selected-window) meta-buf)))
))
(if (and (ediff-window-display-p)
- (window-live-p
+ (window-live-p
(setq wind (ediff-get-visible-buffer-window meta-buf))))
(progn
(setq frame (window-frame wind))
))
(if (ediff-window-display-p)
(progn
- (setq frame
+ (setq frame
(window-frame
(ediff-get-visible-buffer-window ediff-registry-buffer)))
(raise-frame frame)
(ediff-with-current-buffer (current-buffer)
(if (ediff-buffer-live-p ediff-registry-buffer)
(ediff-redraw-registry-buffer)
- (ediff-prepare-meta-buffer
+ (ediff-prepare-meta-buffer
'ediff-registry-action
ediff-session-registry
"*Ediff Registry"
'ediff-registry))
))
-;; If meta-buf exists, it is redrawn along with parent.
+;; If meta-buf exists, it is redrawn along with parent.
;; Otherwise, nothing happens.
(defun ediff-cleanup-meta-buffer (meta-buffer)
(if (ediff-buffer-live-p meta-buffer)
(if (ediff-buffer-live-p ediff-dir-diffs-buffer)
(kill-buffer ediff-dir-diffs-buffer)))
(kill-buffer buf))
-
+
;; Obtain information on a meta record where the user clicked or typed
;; BUF is the buffer where this happened and POINT is the position
res))
-;; Make sure WIN always starts at the beginning of an whole screen
+;; Make sure WIN always starts at the beginning of a whole screen
;; line. If WIN is not aligned the start is updated which probably
;; will lead to a redisplay of the screen later on.
;;
;; If REG is a CCL register symbol (e.g. r0, r1...), the register
;; number is embedded. If OP is one of unconditional jumps, DATA is
-;; changed to an relative jump address.
+;; changed to a relative jump address.
(defun ccl-embed-code (op reg data &optional reg2)
(if (and (> data 0) (get op 'jump-flag))
(ccl-embed-data op)
(ccl-embed-data arg))
(ccl-check-register arg cmd)
- (ccl-embed-code (if read-flag 'read-jump-cond-expr-register
+ (ccl-embed-code (if read-flag 'read-jump-cond-expr-register
'jump-cond-expr-register)
rrr 0)
(ccl-embed-data op)
(error "CCL: Invalid argument %s: %s" arg cmd)))
(ccl-embed-code 'read-jump rrr ccl-loop-head))
t)
-
+
;; Compile READ statement.
(defun ccl-compile-read (cmd)
(if (< (length cmd) 2)
add 1))
(setq arg (cdr arg)
len (+ len add)))
- (if mp
+ (if mp
(cons (- len) result)
result))))
(setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd))
(rrr (ash (logand code 255) -5))
(cc (ash code -8)))
(insert (format "%5d:[%s] " (1- ccl-current-ic) cmd))
- (funcall (get cmd 'ccl-dump-function) rrr cc)))
+ (funcall (get cmd 'ccl-dump-function) rrr cc)))
(defun ccl-dump-set-register (rrr cc)
(insert (format "r%d = r%d\n" rrr cc)))
(insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))
\f
-;; CCL emulation staffs
+;; CCL emulation staffs
;; Not yet implemented.
\f
;; (REG <8= ARG) is the same as:
;; ((REG <<= 8)
;; (REG |= ARG))
- | <8=
+ | <8=
;; (REG >8= ARG) is the same as:
;; ((r7 = (REG & 255))
;; The entry point of this code is
;;
;; mail-extract-address-components: (address &optional all)
-;;
+;;
;; Given an RFC-822 ADDRESS, extract full name and canonical address.
;; Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
;; If no name can be extracted, FULL-NAME will be nil.
-;; ADDRESS may be a string or a buffer. If it is a buffer, the visible
+;; ADDRESS may be a string or a buffer. If it is a buffer, the visible
;; (narrowed) portion of the buffer will be interpreted as the address.
;; (This feature exists so that the clever caller might be able to avoid
;; consing a string.)
;; make sure you're not breaking functionality. The test cases aren't included
;; because they are over 100K.
;;
-;; If you find an address that mail-extr fails on, please send it to the
+;; If you find an address that mail-extr fails on, please send it to the
;; maintainer along with what you think the correct results should be. We do
;; not consider it a bug if mail-extr mangles a comment that does not
-;; correspond to a real human full name, although we would prefer that
+;; correspond to a real human full name, although we would prefer that
;; mail-extr would return the comment as-is.
;;
;; Features:
;; * insert documentation strings!
;; * handle X.400-gatewayed addresses according to RFC 1148.
-;;; Change Log:
-;;
+;;; Change Log:
+;;
;; Thu Feb 17 17:57:33 1994 Jamie Zawinski (jwz@lucid.com)
;;
;; * merged with jbw's latest version
;; * some more cleanup, doc, added provide
;;
;; Tue Mar 23 21:23:18 1993 Joe Wells (jbw at csd.bu.edu)
-;;
+;;
;; * Made mail-full-name-prefixes a user-customizable variable.
;; Allow passing the address as a buffer as well as as a string.
;; Allow [ and ] as name characters (Finnish character set).
-;;
+;;
;; Mon Mar 22 21:20:56 1993 Joe Wells (jbw at bigbird.bu.edu)
-;;
+;;
;; * Handle "null" addresses. Handle = used for spacing in mailbox
;; name. Fix bug in handling of ROUTE-ADDR-type addresses that are
;; missing their brackets. Handle uppercase "JR". Extract full
;; names from X.400 addresses encoded in RFC-822. Fix bug in
;; handling of multiple addresses where first has trailing comment.
;; Handle more kinds of telephone extension lead-ins.
-;;
+;;
;; Mon Mar 22 20:16:57 1993 Joe Wells (jbw at bigbird.bu.edu)
-;;
+;;
;; * Handle HZ encoding for embedding GB encoded chinese characters.
-;;
+;;
;; Mon Mar 22 00:46:12 1993 Joe Wells (jbw at bigbird.bu.edu)
-;;
+;;
;; * Fixed too broad matching of ham radio call signs. Fixed bug in
;; handling an unmatched ' in a name string. Enhanced recognition
;; of when . in the mailbox name terminates the name portion.
;; introduced in switching last name order. Fixed bug in handling
;; address with ! and % but no @. Narrowed the cases in which
;; certain trailing words are discarded.
-;;
+;;
;; Sun Mar 21 21:41:06 1993 Joe Wells (jbw at bigbird.bu.edu)
-;;
+;;
;; * Fixed bugs in handling GROUP addresses. Certain words in the
;; middle of a name no longer terminate it. Handle LISTSERV list
;; names. Ignore comment field containing mailbox name.
-;;
+;;
;; Sun Mar 21 14:39:38 1993 Joe Wells (jbw at bigbird.bu.edu)
-;;
+;;
;; * Moved variant-method code back into main function. Handle
;; underscores as spaces in comments. Handle leading nickname. Add
;; flag to ignore single-word names. Other changes.
-;;
+;;
;; Mon Feb 1 22:23:31 1993 Joe Wells (jbw at bigbird.bu.edu)
-;;
+;;
;; * Added in changes by Rod Whitby and Jamie Zawinski. This
;; includes the flag mail-extr-guess-middle-initial and the fix for
;; handling multiple addresses correctly. (Whitby just changed
;; a > to a <.)
-;;
+;;
;; 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.
(defconst mail-extr-leading-garbage
(purecopy (format "[^%s]+" mail-extr-first-letters)))
-;; (defconst mail-extr-non-name-chars
+;; (defconst mail-extr-non-name-chars
;; (purecopy (concat "^" mail-extr-all-letters ".")))
;; (defconst mail-extr-non-begin-name-chars
;; (purecopy (concat "^" mail-extr-first-letters)))
;; (defconst mail-extr-non-end-name-chars
;; (purecopy (concat "^" mail-extr-last-letters)))
-;; Matches an initial not followed by both a period and a space.
+;; Matches an initial not followed by both a period and a space.
;; (defconst mail-extr-bad-initials-pattern
-;; (purecopy
+;; (purecopy
;; (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)"
;; mail-extr-all-letters mail-extr-first-letters mail-extr-all-letters)))
;; Must not match a trailing uppercase last name or trailing initial
(defconst mail-extr-weird-acronym-pattern
(purecopy "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)"))
-
+
;; Matches a mixed-case or lowercase name (not an initial).
;; #### Match Latin1 lower case letters here too?
;; (defconst mail-extr-mixed-case-name-pattern
;; Matches a trailing alternative address.
;; #### Match Latin1 letters here too?
-;; #### Match _ before @ here too?
+;; #### Match _ before @ here too?
(defconst mail-extr-alternative-address-pattern
(purecopy "\\(aka *\\)?[a-zA-Z.]+[!@][a-zA-Z.]"))
;; Matches a single word name.
;; (defconst mail-extr-one-name-pattern
;; (purecopy (concat "\\`" mail-extr-normal-name-pattern "\\'")))
-
+
;; Matches normal two names with missing middle initial
;; The first name is not allowed to have a hyphen because this can cause
;; false matches where the "middle initial" is actually the first letter
;; encountered. The character '~' is an escape character. By convention, it
;; must be immediately followed ONLY by '~', '{' or '\n' (<LF>), with the
;; following special meaning.
-;;
+;;
;; o The escape sequence '~~' is interpreted as a '~'.
;; o The escape-to-GB sequence '~{' switches the mode from ASCII to GB.
;; o The escape sequence '~\n' is a line-continuation marker to be consumed
;; with no output produced.
-;;
+;;
;; In GB mode, characters are interpreted two bytes at a time as (pure) GB
;; codes until the escape-from-GB code '~}' is read. This code switches the
;; mode from GB back to ASCII. (Note that the escape-from-GB code '~}'
(widen)
(erase-buffer)
(setq case-fold-search nil)
-
+
;; Insert extra space at beginning to allow later replacement with <
;; without having to move markers.
(insert ?\ )
(buffer-disable-undo canonicalization-buffer)
(setq case-fold-search nil))
-
+
;; Unfold multiple lines.
(goto-char (point-min))
(while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t)
(replace-match "\\1 " t))
-
+
;; Loop over addresses until we have as many as we want.
(while (and (or all (null value-list))
(progn (goto-char (point-min))
;; Any commas must be between < and : of ROUTE-ADDR. Nuke any
;; others.
- ;; Hell, go ahead an nuke all of the commas.
+ ;; Hell, go ahead and 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-extr-nuke-outside-range comma-pos 1 1)
(setq %-pos (cons (point) %-pos))
(insert-before-markers "% ")))
(backward-char 1)
- (insert-buffer-substring
+ (insert-buffer-substring
(current-buffer)
(if (nth 1 !-pos)
(1+ (nth 1 !-pos))
(if (bobp)
(delete-region (point) cbeg)
(just-one-space))))))
-
+
;; This was moved above.
;; Fix . used as space
;; But it belongs here because it occurs not only as
;; Loop over the words (and other junk) in the name.
(goto-char (point-min))
(while (not name-done-flag)
-
+
(cond (word-found-flag
;; Last time through this loop we skipped over a word.
(setq last-word-beg this-word-beg)
;; (setq upper-case-flag nil)
(setq begin-again-flag nil)
))
-
+
;; Initialize for this iteration of the loop.
(mail-extr-skip-whitespace-forward)
(if (eq word-count 0) (narrow-to-region (point) (point-max)))
(setq this-word-beg (point))
(setq drop-this-word-if-trailing-flag nil)
-
+
;; Decide what to do based on what we are looking at.
(cond
-
+
;; Delete title
((and (eq word-count 0)
(looking-at mail-extr-full-name-prefixes))
(goto-char (match-end 0))
(narrow-to-region (point) (point-max)))
-
+
;; Stop after name suffix
((and (>= word-count 2)
(looking-at mail-extr-full-name-suffix-pattern))
(upcase-word 1)))
(setq word-found-flag t)
(setq name-done-flag t))
-
+
;; Handle SCA names
((looking-at "MKA \\(.+\\)") ; "Mundanely Known As"
(goto-char (match-beginning 1))
(narrow-to-region (point) (point-max))
(setq begin-again-flag t))
-
+
;; Check for initial last name followed by comma
((and (eq ?, (following-char))
(eq word-count 1))
(setq last-name-comma-flag t)
(or (eq ?\ (following-char))
(insert ?\ )))
-
+
;; Stop before trailing comma-separated comment
;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
;; *** This case is redundant???
;;((eq ?, (following-char))
;; (setq name-done-flag t))
-
+
;; Delete parenthesized/quoted comment/nickname
((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))
(setq cbeg (point))
(delete-region cbeg cend)
(if initial
(insert initial ". ")))))
-
+
;; Handle *Stupid* VMS date stamps
((looking-at mail-extr-stupid-vms-date-stamp-pattern)
(replace-match "" t))
-
+
;; Handle Chinese characters.
((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern)
(goto-char (match-end 0))
(setq word-found-flag t))
-
+
;; Skip initial garbage characters.
;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
((and (eq word-count 0)
;; *** Skip backward over these???
;; (skip-chars-backward "& \"")
(narrow-to-region (point) (point-max)))
-
+
;; Various stopping points
((or
-
+
;; Stop before ALL CAPS acronyms, if preceded by mixed-case
;; words. Example: XT-DEM.
(and (>= word-count 2)
mixed-case-flag
(looking-at mail-extr-weird-acronym-pattern)
(not (looking-at mail-extr-roman-numeral-pattern)))
-
+
;; Stop before trailing alternative address
(looking-at mail-extr-alternative-address-pattern)
-
+
;; Stop before trailing comment not introduced by comma
;; THIS CASE MUST BE AFTER AN EARLIER CASE.
(looking-at mail-extr-trailing-comment-start-pattern)
-
+
;; Stop before telephone numbers
(looking-at mail-extr-telephone-extension-pattern))
(setq name-done-flag t))
-
+
;; Delete ham radio call signs
((looking-at mail-extr-ham-call-sign-pattern)
(delete-region (match-beginning 0) (match-end 0)))
-
+
;; Fixup initials
((looking-at mail-extr-initial-pattern)
(or (eq (following-char) (upcase (following-char)))
(or (eq ?\ (following-char))
(insert ?\ ))
(setq word-found-flag t))
-
+
;; Handle BITNET LISTSERV list names.
((and (eq word-count 0)
(looking-at mail-extr-listserv-list-name-pattern))
(narrow-to-region (match-beginning 1) (match-end 1))
(setq word-found-flag t)
(setq name-done-flag t))
-
+
;; Handle & substitution, when & is last and is not first.
((and (> word-count 0)
(eq ?\ (preceding-char))
((looking-at mail-extr-name-pattern)
(setq name-beg (point))
(setq name-end (match-end 0))
-
+
;; Certain words will be dropped if they are at the end.
(and (>= word-count 2)
(not lower-case-flag)
;; Drop a trailing word which is terminated with a period.
(eq ?. (char-after (1- name-end))))
(setq drop-this-word-if-trailing-flag t))
-
+
;; Set the flags that indicate whether we have seen a lowercase
;; word, a mixed case word, and an uppercase word.
(if (re-search-forward "[a-z]" name-end t)
(setq lower-case-flag t))
;; (setq upper-case-flag t)
)
-
+
(goto-char name-end)
(setq word-found-flag t))
(t
(setq name-done-flag t)
))
-
+
;; Count any word that we skipped over.
(if word-found-flag
(setq word-count (1+ word-count))))
-
+
;; If the last thing in the name is 2 or more periods, or one or more
;; other sentence terminators (but not a single period) then keep them
;; and the preceding word. This is for the benefit of whole sentences
(or (and drop-last-word-if-trailing-flag
last-word-beg)
(point)))
-
+
;; Xerox's mailers SUCK!!!!!!
;; We simply refuse to believe that any last name is PARC or ADOC.
;; If it looks like that is the last name, that there is no meaningful
(goto-char name-end)
(skip-chars-forward "\t ,")
(narrow-to-region (point) (point-max))))
-
+
;; Delete leading and trailing junk characters.
;; *** This is probably completely unneeded now.
;;(goto-char (point-max))
;; (goto-char (point-min))
;; (skip-chars-forward mail-extr-non-begin-name-chars)
;; (point)))
-
+
;; Compress whitespace
(goto-char (point-min))
(while (re-search-forward "[ \t\n]+" nil t)
\f
;(let ((all nil))
; (mapatoms #'(lambda (x)
-; (if (and (boundp x)
+; (if (and (boundp x)
; (string-match "^mail-extr-" (symbol-name x)))
; (setq all (cons x all)))))
; (setq all (sort all #'string-lessp))
;; The main entry points of EUDC are:
;; `eudc-query-form': Query a directory server from a query form
;; `eudc-expand-inline': Query a directory server for the e-mail address
-;; of the name before cursor and insert it in the
+;; of the name before cursor and insert it in the
;; buffer
;; `eudc-get-phone': Get a phone number from a directory server
;; `eudc-get-email': Get an e-mail address from a directory server
;; List of variables that have server- or protocol-local bindings
(defvar eudc-local-vars nil)
-;; Protocol local. Query function
+;; Protocol local. Query function
(defvar eudc-query-function nil)
;; Protocol local. A function that retrieves a list of valid attribute names
newtext)))
(concat rtn-str (substring str start))))
-;;}}}
+;;}}}
;;{{{ Server and Protocol Variable Routines
(defun eudc-default-set (var val)
"Set the EUDC default value of VAR to VAL.
The current binding of VAR is not changed."
- (put var 'eudc-locals
+ (put var 'eudc-locals
(plist-put (get var 'eudc-locals) 'default val))
(add-to-list 'eudc-local-vars var))
(protocol-locals (eudc-plist-get eudc-locals 'protocol)))
(setq protocol-locals (plist-put protocol-locals (or protocol
eudc-protocol) val))
- (setq eudc-locals
+ (setq eudc-locals
(plist-put eudc-locals 'protocol protocol-locals))
(put var 'eudc-locals eudc-locals)
(add-to-list 'eudc-local-vars var)
(unless protocol
(eudc-update-variable var))))
-
+
(defun eudc-server-set (var val &optional server)
"Set the SERVER-local binding of VAR to VAL.
If omitted SERVER defaults to the current value of `eudc-server'.
(server-locals (eudc-plist-get eudc-locals 'server)))
(setq server-locals (plist-put server-locals (or server
eudc-server) val))
- (setq eudc-locals
+ (setq eudc-locals
(plist-put eudc-locals 'server server-locals))
(put var 'eudc-locals eudc-locals)
(add-to-list 'eudc-local-vars var)
(defun eudc-set (var val)
"Set the most local (server, protocol or default) binding of VAR to VAL.
The current binding of VAR is also set to VAL"
- (cond
+ (cond
((not (eq 'unbound (eudc-variable-server-value var)))
(eudc-server-set var val))
((not (eq 'unbound (eudc-variable-protocol-value var)))
(eudc-plist-member eudc-locals 'protocol)))
'unbound
(setq protocol-locals (eudc-plist-get eudc-locals 'protocol))
- (eudc-lax-plist-get protocol-locals
+ (eudc-lax-plist-get protocol-locals
(or protocol
eudc-protocol) 'unbound))))
(eudc-plist-member eudc-locals 'server)))
'unbound
(setq server-locals (eudc-plist-get eudc-locals 'server))
- (eudc-lax-plist-get server-locals
+ (eudc-lax-plist-get server-locals
(or server
eudc-server) 'unbound))))
to the current `eudc-server' and `eudc-protocol' then it is set
accordingly. Otherwise it is set to its EUDC default binding"
(let (val)
- (cond
+ (cond
((not (eq 'unbound (setq val (eudc-variable-server-value var))))
(set var val))
((not (eq 'unbound (setq val (eudc-variable-protocol-value var))))
;; Add PROTOCOL to the list of supported protocols
(defun eudc-register-protocol (protocol)
(unless (memq protocol eudc-supported-protocols)
- (setq eudc-supported-protocols
+ (setq eudc-supported-protocols
(cons protocol eudc-supported-protocols))
- (put 'eudc-protocol 'custom-type
+ (put 'eudc-protocol 'custom-type
`(choice :menu-tag "Protocol"
- ,@(mapcar (lambda (s)
+ ,@(mapcar (lambda (s)
(list 'string ':tag (symbol-name s)))
eudc-supported-protocols))))
(or (memq protocol eudc-known-protocols)
`eudc-protocol-attributes-translation-alist'."
(if eudc-protocol-attributes-translation-alist
(mapcar '(lambda (attribute)
- (let ((trans (assq (car attribute)
+ (let ((trans (assq (car attribute)
(symbol-value eudc-protocol-attributes-translation-alist))))
(if trans
(cons (cdr trans) (cdr attribute))
attribute)))
query)
- query))
+ query))
(defun eudc-translate-attribute-list (list)
"Translate a list of attribute names LIST.
(setq eudc-pre-select-window-configuration (current-window-configuration))
(setq eudc-insertion-marker (point-marker))
(with-output-to-temp-buffer "*EUDC Completions*"
- (apply 'display-completion-list
- choices
+ (apply 'display-completion-list
+ choices
(if eudc-xemacs-p
'(:activate-callback eudc-insert-selected)))))
"Query the current directory server with QUERY.
QUERY is a list of cons cells (ATTR . VALUE) where ATTR is an attribute
name and VALUE the corresponding value.
-If NO-TRANSLATION is non-nil, ATTR is translated according to
+If NO-TRANSLATION is non-nil, ATTR is translated according to
`eudc-protocol-attributes-translation-alist'.
-RETURN-ATTRIBUTES is a list of attributes to return defaulting to
+RETURN-ATTRIBUTES is a list of attributes to return defaulting to
`eudc-default-return-attributes'."
(unless eudc-query-function
(error "Don't know how to perform the query"))
(if no-translation
(funcall eudc-query-function query (or return-attributes
eudc-default-return-attributes))
-
- (funcall eudc-query-function
+
+ (funcall eudc-query-function
(eudc-translate-query query)
- (cond
+ (cond
(return-attributes
(eudc-translate-attribute-list return-attributes))
((listp eudc-default-return-attributes)
(defun eudc-format-attribute-name-for-display (attribute)
"Format a directory attribute name for display.
-ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced
+ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced
by the corresponding user name if any. Otherwise it is capitalized and
underscore characters are replaced by spaces."
(let ((match (assq attribute eudc-user-attribute-names-alist)))
(if match
(cdr match)
- (capitalize
- (mapconcat 'identity
+ (capitalize
+ (mapconcat 'identity
(split-string (symbol-name attribute) "_")
" ")))))
(defun eudc-print-attribute-value (field)
"Insert the value of the directory FIELD at point.
-The directory attribute name in car of FIELD is looked up in
-`eudc-attribute-display-method-alist' and the corresponding method,
+The directory attribute name in car of FIELD is looked up in
+`eudc-attribute-display-method-alist' and the corresponding method,
if any, is called to print the value in cdr of FIELD."
(let ((match (assoc (downcase (car field))
eudc-attribute-display-method-alist))
(defun eudc-print-record-field (field column-width)
"Print the record field FIELD.
FIELD is a list (ATTR VALUE1 VALUE2 ...) or cons-cell (ATTR . VAL)
-COLUMN-WIDTH is the width of the first display column containing the
+COLUMN-WIDTH is the width of the first display column containing the
attribute name ATTR."
(let ((field-beg (point)))
;; The record field that is passed to this function has already been processed
;; by `eudc-format-attribute-name-for-display' so we don't need to call it
;; again to display the attribute name
- (insert (format (concat "%" (int-to-string column-width) "s: ")
+ (insert (format (concat "%" (int-to-string column-width) "s: ")
(car field)))
(put-text-property field-beg (point) 'face 'bold)
(indent-to (+ 2 column-width))
(eudc-print-attribute-value field)))
(defun eudc-display-records (records &optional raw-attr-names)
- "Display the record list RECORDS in a formatted buffer.
+ "Display the record list RECORDS in a formatted buffer.
If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed
otherwise they are formatted according to `eudc-user-attribute-names-alist'."
(let ((buffer (get-buffer-create "*Directory Query Results*"))
beg
first-record
attribute-name)
- (switch-to-buffer buffer)
+ (switch-to-buffer buffer)
(setq buffer-read-only t)
(setq inhibit-read-only t)
(erase-buffer)
""))
;; Replace field names with user names, compute max width
(setq precords
- (mapcar
+ (mapcar
(function
(lambda (record)
- (mapcar
+ (mapcar
(function
(lambda (field)
- (setq attribute-name
+ (setq attribute-name
(if raw-attr-names
(symbol-name (car field))
(eudc-format-attribute-name-for-display (car field))))
records))
;; Display the records
(setq first-record (point))
- (mapcar
+ (mapcar
(function
(lambda (record)
(setq beg (point))
;; Map over the record fields to print the attribute/value pairs
- (mapcar (function
+ (mapcar (function
(lambda (field)
- (eudc-print-record-field field width)))
+ (eudc-print-record-field field width)))
record)
;; Store the record internal format in some convenient place
(overlay-put (make-overlay beg (point))
(if (not (and (boundp 'eudc-form-widget-list)
eudc-form-widget-list))
(error "Not in a directory query form buffer")
- (mapcar (function
+ (mapcar (function
(lambda (wid-field)
(setq value (widget-value (cdr wid-field)))
(if (not (string= value ""))
eudc-form-widget-list)
(kill-buffer (current-buffer))
(eudc-display-records (eudc-query query-alist) eudc-use-raw-directory-names))))
-
-
+
+
(defun eudc-filter-duplicate-attributes (record)
"Filter RECORD according to `eudc-duplicate-attribute-handling-method'."
(if (null (eudc-cdar rec))
(list record) ; No duplicate attrs in this record
- (mapcar (function
+ (mapcar (function
(lambda (field)
(if (listp (cdr field))
(setq duplicates (cons field duplicates))
record)
(setq result (list unique))
;; Map over the record fields that have multiple values
- (mapcar
+ (mapcar
(function
(lambda (field)
(let ((method (if (consp eudc-duplicate-attribute-handling-method)
- (cdr
- (assq
- (or
- (car
- (rassq
+ (cdr
+ (assq
+ (or
+ (car
+ (rassq
(car field)
- (symbol-value
+ (symbol-value
eudc-protocol-attributes-translation-alist)))
(car field))
eudc-duplicate-attribute-handling-method))
eudc-duplicate-attribute-handling-method)))
(cond
((or (null method) (eq 'list method))
- (setq result
+ (setq result
(eudc-add-field-to-records field result)))
((eq 'first method)
- (setq result
- (eudc-add-field-to-records (cons (car field)
- (eudc-cadr field))
+ (setq result
+ (eudc-add-field-to-records (cons (car field)
+ (eudc-cadr field))
result)))
((eq 'concat method)
- (setq result
+ (setq result
(eudc-add-field-to-records (cons (car field)
- (mapconcat
+ (mapconcat
'identity
(cdr field)
"\n")) result)))
(defun eudc-filter-partial-records (records attrs)
"Eliminate records that do not caontain all ATTRS from RECORDS."
- (delq nil
- (mapcar
- (function
+ (delq nil
+ (mapcar
+ (function
(lambda (rec)
- (if (eval (cons 'and
- (mapcar
- (function
+ (if (eval (cons 'and
+ (mapcar
+ (function
(lambda (attr)
(consp (assq attr rec))))
attrs)))
rec)))
records)))
-
+
(defun eudc-add-field-to-records (field records)
"Add FIELD to each individual record in RECORDS and return the resulting list."
(mapcar (function
(while values
(setcdr values (delete (car values) (cdr values)))
(setq values (cdr values)))
- (mapcar
+ (mapcar
(function
(lambda (value)
(let ((result-list (copy-sequence records)))
- (setq result-list (eudc-add-field-to-records
+ (setq result-list (eudc-add-field-to-records
(cons (car field) value)
result-list))
(setq result (append result-list result))
(run-hooks 'eudc-mode-hook)
)
-;;}}}
+;;}}}
;;{{{ High-level interfaces (interactive functions)
;;;###autoload
(defun eudc-set-server (server protocol &optional no-save)
"Set the directory server to SERVER using PROTOCOL.
-Unless NO-SAVE is non-nil, the server is saved as the default
+Unless NO-SAVE is non-nil, the server is saved as the default
server for future sessions."
(interactive (list
(read-from-minibuffer "Directory Server: ")
- (intern (completing-read "Protocol: "
+ (intern (completing-read "Protocol: "
(mapcar '(lambda (elt)
(cons (symbol-name elt)
elt))
(call-interactively 'eudc-set-server))
(let ((result (eudc-query (list (cons 'name name)) '(email)))
email)
- (if (null (cdr result))
+ (if (null (cdr result))
(setq email (eudc-cdaar result))
(error "Multiple match. Use the query form"))
(if (interactive-p)
(call-interactively 'eudc-set-server))
(let ((result (eudc-query (list (cons 'name name)) '(phone)))
phone)
- (if (null (cdr result))
+ (if (null (cdr result))
(setq phone (eudc-cdaar result))
(error "Multiple match. Use the query form"))
(if (interactive-p)
(interactive)
(if eudc-list-attributes-function
(let ((entries (funcall eudc-list-attributes-function (interactive-p))))
- (if entries
+ (if entries
(if (interactive-p)
(eudc-display-records entries t)
entries)))
(if format
(progn
(while (and words format)
- (setq query-alist (cons (cons (car format) (car words))
+ (setq query-alist (cons (cons (car format) (car words))
query-alist))
(setq words (cdr words)
format (cdr format)))
(let (formats)
(while (and (null formats)
(> n 0))
- (setq formats
+ (setq formats
(delq nil
(mapcar '(lambda (format)
(if (= n
format-list)))
(setq n (1- n)))
formats))
-
+
;;;###autoload
(defun eudc-expand-inline (&optional replace)
"Query the directory server, and expand the query string before point.
The query string consists of the buffer substring from the point back to
-the preceding comma, colon or beginning of line.
-The variable `eudc-inline-query-format' controls how to associate the
+the preceding comma, colon or beginning of line.
+The variable `eudc-inline-query-format' controls how to associate the
individual inline query words with directory attribute names.
-After querying the server for the given string, the expansion specified by
+After querying the server for the given string, the expansion specified by
`eudc-inline-expansion-format' is inserted in the buffer at point.
If REPLACE is non nil, then this expansion replaces the name in the buffer.
`eudc-expansion-overwrites-query' being non nil inverts the meaning of REPLACE.
-Multiple servers can be tried with the same query until one finds a match,
+Multiple servers can be tried with the same query until one finds a match,
see `eudc-inline-expansion-servers'"
(interactive)
- (if (memq eudc-inline-expansion-servers
+ (if (memq eudc-inline-expansion-servers
'(current-server server-then-hotlist))
(or eudc-server
(call-interactively 'eudc-set-server))
(error "No server in the hotlist")))
(let* ((end (point))
(beg (save-excursion
- (if (re-search-backward "\\([:,]\\|^\\)[ \t]*"
+ (if (re-search-backward "\\([:,]\\|^\\)[ \t]*"
(save-excursion
(beginning-of-line)
(point))
;; Prepare the list of servers to query
(setq servers (copy-sequence eudc-server-hotlist))
(setq servers
- (cond
+ (cond
((eq eudc-inline-expansion-servers 'hotlist)
eudc-server-hotlist)
((eq eudc-inline-expansion-servers 'server-then-hotlist)
(condition-case signal
(progn
- (setq response
+ (setq response
(catch 'found
;; Loop on the servers
(while servers
(eudc-set-server (eudc-caar servers) (eudc-cdar servers) t)
-
+
;; Determine which formats apply in the query-format list
(setq query-formats
- (or
+ (or
(eudc-extract-n-word-formats eudc-inline-query-format
(length query-words))
(if (null eudc-protocol-has-default-query-attributes)
'(name))))
-
+
;; Loop on query-formats
(while query-formats
(setq response
(if (null response)
(error "No match")
-
+
;; Process response through eudc-inline-expansion-format
(while response
- (setq response-string (apply 'format
+ (setq response-string (apply 'format
(car eudc-inline-expansion-format)
- (mapcar (function
+ (mapcar (function
(lambda (field)
- (or (cdr (assq field (car response)))
+ (or (cdr (assq field (car response)))
"")))
(eudc-translate-attribute-list
(cdr eudc-inline-expansion-format)))))
(setq response-strings
(cons response-string response-strings)))
(setq response (cdr response)))
-
+
(if (or
(and replace (not eudc-expansion-overwrites-query))
(and (not replace) eudc-expansion-overwrites-query))
(delete-region beg end))
- (cond
+ (cond
((or (= (length response-strings) 1)
(null eudc-multiple-match-handling-method)
(eq eudc-multiple-match-handling-method 'first))
(equal eudc-protocol eudc-former-protocol))
(eudc-set-server eudc-former-server eudc-former-protocol t))
(signal (car signal) (cdr signal))))))
-
+
;;;###autoload
(defun eudc-query-form (&optional get-fields-from-server)
"Display a form to query the directory server.
(widget-insert "Directory Query Form\n")
(widget-insert "====================\n\n")
(widget-insert "Current server is: " (or eudc-server
- (progn
+ (progn
(call-interactively 'eudc-set-server)
eudc-server))
"\n")
(if (> (length prompt) width)
(setq width (length prompt)))))
prompts)
- ;; Insert the first widget out of the mapcar to leave the cursor
- ;; in the first field
+ ;; Insert the first widget out of the mapcar to leave the cursor
+ ;; in the first field
(widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ") (car prompts)))
(setq pt (point))
(setq widget (widget-create 'editable-field :size 15))
(error "No more records before point")))))
-
+
;;}}}
-;;{{{ Menus an keymaps
+;;{{{ Menus and keymaps
(require 'easymenu)
-(setq eudc-mode-map
+(setq eudc-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "q" 'kill-this-buffer)
(define-key map "x" 'kill-this-buffer)
(defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc)))
-(defconst eudc-tail-menu
+(defconst eudc-tail-menu
`(["---" nil nil]
["Query with Form" eudc-query-form t]
["Expand Inline Query" eudc-expand-inline t]
- ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb
+ ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb
(and (or (featurep 'bbdb)
(prog1 (locate-library "bbdb") (message "")))
(overlays-at (point))
(overlay-get (car (overlays-at (point))) 'eudc-record))]
- ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb
+ ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb
(and (eq major-mode 'eudc-mode)
(or (featurep 'bbdb)
(prog1 (locate-library "bbdb") (message ""))))]
["List Valid Attribute Names" eudc-get-attribute-list t]
["---" nil nil]
,(cons "Customize" eudc-custom-generated-menu)))
-
-(defconst eudc-server-menu
+
+(defconst eudc-server-menu
'(["---" nil nil]
["Bookmark Current Server" eudc-bookmark-current-server t]
["Edit Server List" eudc-edit-hotlist t]
(let (command)
(append '("Directory Search")
(list
- (append
+ (append
'("Server")
- (mapcar
- (function
+ (mapcar
+ (function
(lambda (servspec)
(let* ((server (car servspec))
(protocol (cdr servspec))
(proto-name (symbol-name protocol)))
- (setq command (intern (concat "eudc-set-server-"
- server
- "-"
+ (setq command (intern (concat "eudc-set-server-"
+ server
+ "-"
proto-name)))
(if (not (fboundp command))
- (fset command
+ (fset command
`(lambda ()
(interactive)
(eudc-set-server ,server (quote ,protocol))
- (message "Selected directory server is now %s (%s)"
- ,server
+ (message "Selected directory server is now %s (%s)"
+ ,server
,proto-name))))
(vector (format "%s (%s)" server proto-name)
command
eudc-tail-menu)))
(defun eudc-install-menu ()
- (cond
+ (cond
((and eudc-xemacs-p (featurep 'menubar))
(add-submenu '("Tools") (eudc-menu)))
(eudc-emacs-p
global-map
[menu-bar tools directory-search]
(cons "Directory Search"
- (easy-menu-create-menu "Directory Search" (cdr (eudc-menu))))))
+ (easy-menu-create-menu "Directory Search" (cdr (eudc-menu))))))
((fboundp 'easy-menu-add-item)
(let ((menu (eudc-menu)))
(easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu)
(cdr menu)))))
((fboundp 'easy-menu-create-keymaps)
(easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu))
- (define-key
+ (define-key
global-map
- [menu-bar tools eudc]
+ [menu-bar tools eudc]
(cons "Directory Search"
(easy-menu-create-keymaps "Directory Search" (cdr (eudc-menu))))))
(t
(message "")) ; Remove modeline message
(not (featurep 'eudc-options-file)))
(load eudc-options-file))
-
-
+
+
;;; Install the full menu
(unless (featurep 'infodock)
(eudc-install-menu))
(cond ((not (string-match "XEmacs" emacs-version))
(defvar eudc-tools-menu (make-sparse-keymap "Directory Search"))
(fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))
-
+
(define-key eudc-tools-menu [phone]
'("Get Phone" . eudc-get-phone))
(define-key eudc-tools-menu [email]
'("New Server" . eudc-set-server))
(define-key eudc-tools-menu [load]
'("Load Hotlist of Servers" . eudc-load-eudc)))
-
+
(t
(let ((menu '("Directory Search"
["Load Hotlist of Servers" eudc-load-eudc t]
(not (featurep 'infodock)))
(add-submenu '("Tools") menu))
(require 'easymenu)
- (cond
+ (cond
((fboundp 'easy-menu-add-item)
(easy-menu-add-item nil '("tools")
(easy-menu-create-menu (car menu)
(cdr menu))))
((fboundp 'easy-menu-create-keymaps)
- (define-key
+ (define-key
global-map
- [menu-bar tools eudc]
+ [menu-bar tools eudc]
(cons "Directory Search"
(easy-menu-create-keymaps "Directory Search"
(cdr menu)))))))))))
-
+
;;}}}
-
+
(provide 'eudc)
;;; eudc.el ends here
(defvar inferior-octave-receive-in-progress nil)
(defconst octave-maintainer-address
- "Kurt Hornik <Kurt.Hornik@ci.tuwien.ac.at>, bug-gnu-emacs@gnu.org"
+ "Kurt Hornik <Kurt.Hornik@ci.tuwien.ac.at>, bug-gnu-emacs@gnu.org"
"Current maintainer of the Emacs Octave package.")
(defvar octave-abbrev-table nil
(define-key map "\n" 'octave-reindent-then-newline-and-indent)
(define-key map "\t" 'indent-according-to-mode)
(define-key map "\e;" 'octave-indent-for-comment)
- (define-key map "\e\n" 'octave-indent-new-comment-line)
+ (define-key map "\e\n" 'octave-indent-new-comment-line)
(define-key map "\e\t" 'octave-complete-symbol)
(define-key map "\M-\C-a" 'octave-beginning-of-defun)
(define-key map "\M-\C-e" 'octave-end-of-defun)
(define-key map "\M-\C-h" 'octave-mark-defun)
- (define-key map "\M-\C-q" 'octave-indent-defun)
+ (define-key map "\M-\C-q" 'octave-indent-defun)
(define-key map "\C-c;" 'octave-comment-region)
- (define-key map "\C-c:" 'octave-uncomment-region)
+ (define-key map "\C-c:" 'octave-uncomment-region)
(define-key map "\C-c\C-b" 'octave-submit-bug-report)
(define-key map "\C-c\C-p" 'octave-previous-code-line)
(define-key map "\C-c\C-n" 'octave-next-code-line)
(define-key map "\C-c\C-a" 'octave-beginning-of-line)
- (define-key map "\C-c\C-e" 'octave-end-of-line)
+ (define-key map "\C-c\C-e" 'octave-end-of-line)
(define-key map "\C-c\M-\C-n" 'octave-forward-block)
(define-key map "\C-c\M-\C-p" 'octave-backward-block)
(define-key map "\C-c\M-\C-u" 'octave-backward-up-block)
(define-key map "\C-cil" 'octave-send-line)
(define-key map "\C-cib" 'octave-send-block)
(define-key map "\C-cif" 'octave-send-defun)
- (define-key map "\C-cir" 'octave-send-region)
+ (define-key map "\C-cir" 'octave-send-region)
(define-key map "\C-cis" 'octave-show-process-buffer)
(define-key map "\C-cih" 'octave-hide-process-buffer)
(define-key map "\C-cik" 'octave-kill-process)
"Alist of Octave symbols for completion in Octave mode.
Each element looks like (VAR . VAR), where the car and cdr are the same
symbol (an Octave command or variable name).
-Currently, only builtin variables can be completed.")
+Currently, only builtin variables can be completed.")
(defvar octave-mode-imenu-generic-expression
(list
(setq mode-name "Octave")
(setq local-abbrev-table octave-abbrev-table)
(set-syntax-table octave-mode-syntax-table)
-
+
(make-local-variable 'indent-line-function)
(setq indent-line-function 'octave-indent-line)
- (make-local-variable 'comment-start)
+ (make-local-variable 'comment-start)
(setq comment-start octave-comment-start)
(make-local-variable 'comment-end)
(setq comment-end "")
(make-local-variable 'comment-column)
- (setq comment-column 32)
+ (setq comment-column 32)
(make-local-variable 'comment-start-skip)
(setq comment-start-skip "\\s<+\\s-*")
(make-local-variable 'comment-indent-function)
(describe-function major-mode))
(defun octave-point (position)
- "Returns the value of point at certain positions."
+ "Returns the value of point at certain positions."
(save-excursion
(cond
((eq position 'bol) (beginning-of-line))
(interactive "r\nP")
(let ((comment-start (char-to-string octave-comment-char)))
(comment-region beg end arg)))
-
+
(defun octave-uncomment-region (beg end &optional arg)
"Uncomment each line in the region as Octave code."
(interactive "r\nP")
"Maybe insert and indent an Octave comment.
If there is no comment already on this line, create a code-level comment
(started by two comment characters) if the line is empty, or an in-line
-comment (started by one comment character) otherwise.
+comment (started by one comment character) otherwise.
Point is left after the start of the comment which is properly aligned."
(interactive)
(indent-for-comment)
(defun octave-indent-new-comment-line ()
"Break Octave line at point, continuing comment if within one.
If within code, insert `octave-continuation-string' before breaking the
-line. If within a string, signal an error.
-The new line is properly indented."
+line. If within a string, signal an error.
+The new line is properly indented."
(interactive)
(delete-horizontal-space)
(cond
(setq n (forward-line inc)))
(setq arg (- arg inc)))
n))
-
+
(defun octave-previous-code-line (&optional arg)
"Move ARG lines of Octave code backward (forward if ARG is negative).
Skips past all empty and comment lines. Default for ARG is 1.
(looking-at octave-continuation-regexp)))
(zerop (forward-line 1)))))
(end-of-line)))
-
+
(defun octave-scan-blocks (from count depth)
"Scan from character number FROM by COUNT Octave begin-end blocks.
Returns the character number of the position thus found.
(interactive "p")
(or arg (setq arg 1))
(and (< arg 0) (skip-syntax-backward "w"))
- (and (> arg 0) (skip-syntax-forward "w"))
+ (and (> arg 0) (skip-syntax-forward "w"))
(if (octave-in-defun-p)
(setq arg (- arg 1)))
(if (= arg 0) (setq arg -1))
(exchange-point-and-mark))
(goto-char pos)
(message "No function to mark found"))))
-
+
\f
;;; Filling
(defun octave-auto-fill ()
(let (fc give-up)
(if (or (null (setq fc (current-fill-column)))
(save-excursion
- (beginning-of-line)
+ (beginning-of-line)
(and auto-fill-inhibit-regexp
(looking-at auto-fill-inhibit-regexp))))
nil ; Can't do anything
(defun octave-fill-paragraph (&optional arg)
"Fill paragraph of Octave code, handling Octave comments."
(interactive "P")
- (save-excursion
+ (save-excursion
(let ((end (progn (forward-paragraph) (point)))
(beg (progn
(forward-paragraph -1)
(beginning-of-line)
(looking-at "^\\s-*\\s<+\\s-*$"))))
;; This is a nonempty comment line which does not extend
- ;; past the fill column. If it is followed by an nonempty
+ ;; past the fill column. If it is followed by a nonempty
;; comment line with the same comment prefix, try to
;; combine them, and repeat this until either we reach the
;; fill-column or there is nothing more to combine.
(let ((list (all-completions string octave-completion-alist))
(conf (current-window-configuration)))
;; Taken from comint.el
- (message "Making completion list...")
+ (message "Making completion list...")
(with-output-to-temp-buffer "*Completions*"
(display-completion-list list))
(message "Hit space to flush")
(set-window-configuration conf)
(setq unread-command-events
(listify-key-sequence key))))))))))
-
+
\f
;;; Electric characters && friends
(defun octave-reindent-then-newline-and-indent ()
(indent-according-to-mode)
(newline 2)
(insert prefix "usage: " string)
- (reindent-then-newline-and-indent)
+ (reindent-then-newline-and-indent)
(insert prefix)
- (reindent-then-newline-and-indent)
+ (reindent-then-newline-and-indent)
(insert prefix)
(indent-according-to-mode)
(save-excursion
(newline 2)
(insert "endfunction")
(indent-according-to-mode))))
-
+
\f
;;; Menu
(defun octave-add-octave-menu ()
"Adds the `Octave' menu to the menu bar in Octave mode."
- (require 'easymenu)
+ (require 'easymenu)
(easy-menu-define octave-mode-menu-map octave-mode-map
"Menu keymap for Octave mode." octave-mode-menu)
(easy-menu-add octave-mode-menu-map octave-mode-map))
(defun octave-send-region (beg end)
"Send current region to the inferior Octave process."
(interactive "r")
- (inferior-octave t)
+ (inferior-octave t)
(let ((proc inferior-octave-process)
(string (buffer-substring-no-properties beg end))
line)
(display-buffer inferior-octave-buffer)))
(defun octave-send-block ()
- "Send current Octave block to the inferior Octave process."
+ "Send current Octave block to the inferior Octave process."
(interactive)
(save-excursion
(octave-mark-block)
(print-escape-newlines nil)
(opoint (point)))
(terpri)
- (prin1
+ (prin1
(save-excursion
(forward-sexp -1)
(inferior-octave-send-list-and-digest
;; To enable Flyspell in text representing computer programs, type
;; M-x flyspell-prog-mode.
;; In that mode only text inside comments is checked.
-;;
+;;
;; Note: consider setting the variable ispell-parser to `tex' to
;; avoid TeX command checking; use `(setq ispell-parser 'tex)'.
-;;
+;;
;; Some user variables control the behavior of flyspell. They are
;; those defined under the `User variables' comment.
:group 'flyspell
:version "21.1"
:type 'boolean)
-
+
;;;###autoload
(defcustom flyspell-mode-line-string " Fly"
"*String displayed on the modeline when flyspell is active.
The default flyspell behavior is to highlight incorrect words.
With no argument, this command toggles Flyspell mode.
With a prefix argument ARG, turn Flyspell minor mode on iff ARG is positive.
-
+
Bindings:
\\[ispell-word]: correct words (using Ispell).
\\[flyspell-auto-correct-word]: automatically correct word.
;* For remembering buffers running flyspell */
;*---------------------------------------------------------------------*/
(defvar flyspell-buffers nil)
-
+
;*---------------------------------------------------------------------*/
;* flyspell-minibuffer-p ... */
;*---------------------------------------------------------------------*/
(format "Welcome to flyspell. Use %s or Mouse-2 to correct words."
(key-description binding))
"Welcome to flyspell. Use Mouse-2 to correct words."))))
-
+
;; Use this so that we can still get major mode bindings at a
;; misspelled word (unless they're overridden by
;; `flyspell-mouse-map').
(insert (format " cache-start: %S\n" flyspell-word-cache-start))
(insert (format " cache-end : %S\n" flyspell-word-cache-end))
(goto-char (point-max)))))
-
+
;*---------------------------------------------------------------------*/
;* flyspell-debug-signal-word-checked ... */
;*---------------------------------------------------------------------*/
(setq flyspell-ispell-casechars-cache ispell-casechars)
(setq flyspell-casechars-cache ispell-casechars)
flyspell-casechars-cache))))
-
+
;*---------------------------------------------------------------------*/
;* flyspell-get-not-casechars-cache ... */
;*---------------------------------------------------------------------*/
;; have to kill the temporary buffer
(kill-buffer flyspell-external-ispell-buffer)
(setq flyspell-external-ispell-buffer nil)))
-
+
;*---------------------------------------------------------------------*/
;* flyspell-large-region ... */
;*---------------------------------------------------------------------*/
;*---------------------------------------------------------------------*/
;* flyspell-properties-at-p ... */
;* ------------------------------------------------------------- */
-;* Is there an highlight properties at position pos? */
+;* Is there a highlight properties at position pos? */
;*---------------------------------------------------------------------*/
(defun flyspell-properties-at-p (pos)
"Return t if there is a text property at POS, not counting `local-map'.
flyspell-overlay-keymap-property-name
flyspell-local-mouse-map))
flyspell-overlay))
-
+
;*---------------------------------------------------------------------*/
;* flyspell-highlight-incorrect-region ... */
;*---------------------------------------------------------------------*/
(if (eq flyspell-emacs 'xemacs)
(flyspell-correct-word/mouse-keymap event)
(flyspell-correct-word/local-keymap event)))
-
+
;*---------------------------------------------------------------------*/
;* flyspell-correct-word/local-keymap ... */
;*---------------------------------------------------------------------*/
(let ((flyspell-mode nil))
(if (key-binding (this-command-keys))
(command-execute (key-binding (this-command-keys))))))))))
-
+
;*---------------------------------------------------------------------*/
;* flyspell-correct-word/mouse-keymap ... */
;*---------------------------------------------------------------------*/
;*---------------------------------------------------------------------*/
(defun flyspell-change-abbrev (table old new)
(set (abbrev-symbol old table) new))
-
+
(provide 'flyspell)
;;; flyspell.el ends here
;; other alternatives (search for "Oemacs"). There is also a keymap
;; which you can bind to a prefix key, which may give some more
;; intuitive alternatives in some cases, see `The vcursor keymap' below.
-;;
+;;
;; Holding down control and shift and pressing insert (vcursor-copy)
;; copies one character from wherever the virtual cursor is to point;
;; point and the virtual cursor advance in the separate and equal
;; station to which... (etc.). M-C-S-return (vcursor-copy-line)
;; copies to the end of the line instead of just one character,
;; C-S-delete or C-S-remove (vcursor-copy-word) copies a word.
-;;
+;;
;; A more general way of copying is to use C-S-tab, which is a toggle.
;; In the "on" state, moving the virtual cursor will copy the
;; moved-over text to the normal cursor position (including when going
;; window. (See the function (vcursor-find-window) for details of how
;; this window is chosen.) This gives you fingertip control over two
;; windows at once.
-;;
+;;
;; C-S-return (vcursor-disable) disables the virtual cursor, removing
;; it so that it starts from point whenever you move it again --- note
;; that simply moving the cursor and virtual cursor on top of one
;; another does not have this effect.
-;;
+;;
;; If you give C-S-return a positive prefix arg, it will also delete the
;; window (unless it's the current one). Whenever the virtual cursor
;; goes off-screen in its own window, point in that window is moved as
;; remember the current cursor location for examining or copying from
;; that buffer. (I just hit C-S-right C-S-left, but I'm a hopeless
;; lowbrow.)
-;;
+;;
;; There is also C-S-f6 (vcursor-other-window) which behaves like
;; C-x o on the virtual rather than the real cursor, except that it
;; will create another window if necessary.
;;
;; Key bindings
;; ============
-;;
+;;
;; There is an alternative set of key bindings which will be used
;; automatically for a PC if Oemacs is detected. This set uses separate
;; control, shift and meta keys with function keys 1 to 10. In
;;
;; If Emacs has set the variable window-system to nil, vcursor will
;; assume that overlays cannot be displayed in a different face,
-;; and will instead use an string (the variable vcursor-string, by
+;; and will instead use a string (the variable vcursor-string, by
;; default "**>") to show its position. This was first implemented
;; in Emacs 19.29. Unlike the old-fashioned overlay arrow (as used
;; by debuggers), this appears between existing text, which can
;; get an easy key binding for the vcursor keys on a generic terminal.
;; Consequently a special keymap is defined for you to use traditional
;; methods: the keymap, however, is available on any terminal type.
-;;
+;;
;; The vcursor keymap
;; ==================
;;
;; does something else. To get this effect, set
;; vcursor-interpret-input to t. This is normally not a good idea as
;; interpreting input is very much slower than copying text.
-;;
+;;
;; Un-features
;; ===========
;;
;;; "\M-[\C-f\M-\C-s" C-S-delete
;;; "\M-[\C-f\M-\C-d" C-S-prior
;;; "\M-[\C-fv" C-S-next
-;;;
+;;;
;;; "\M-[\C-f^" C-S-f1
;;; "\M-[\C-f_" C-S-f2
;;; "\M-[\C-f`" C-S-f3
(global-set-key (vcursor-cs-binding "down") 'vcursor-next-line)
(global-set-key (vcursor-cs-binding "left") 'vcursor-backward-char)
(global-set-key (vcursor-cs-binding "right") 'vcursor-forward-char)
-
+
(global-set-key (vcursor-cs-binding "return") 'vcursor-disable)
(global-set-key (vcursor-cs-binding "insert") 'vcursor-copy)
(global-set-key (vcursor-cs-binding "delete") 'vcursor-copy-word)
(global-set-key (vcursor-cs-binding "down" t) 'vcursor-end-of-buffer)
(global-set-key (vcursor-cs-binding "prior") 'vcursor-scroll-down)
(global-set-key (vcursor-cs-binding "next") 'vcursor-scroll-up)
-
+
(global-set-key (vcursor-cs-binding "f6") 'vcursor-other-window)
(global-set-key (vcursor-cs-binding "f7") 'vcursor-goto)
- (global-set-key (vcursor-cs-binding "select")
+ (global-set-key (vcursor-cs-binding "select")
'vcursor-swap-point) ; DEC keyboards
(global-set-key (vcursor-cs-binding "tab" t) 'vcursor-swap-point)
- (global-set-key (vcursor-cs-binding "find")
+ (global-set-key (vcursor-cs-binding "find")
'vcursor-isearch-forward) ; DEC keyboards
(global-set-key (vcursor-cs-binding "f8") 'vcursor-isearch-forward)
:group 'vcursor
:version "20.3")
-(defvar vcursor-overlay nil
+(defvar vcursor-overlay nil
"Overlay for the virtual cursor.
It is nil if that is not enabled.")
;; could do some memq-ing with last-command instead, but this will
;; automatically handle any new commands using the primitives.
-(defcustom vcursor-copy-flag nil
+(defcustom vcursor-copy-flag nil
"*Non-nil means moving vcursor should copy characters moved over to point."
:type 'boolean
:group 'vcursor)
;; If vcursor-key-bindings is already set on loading, bind the keys now.
;; This hybrid way of doing it retains compatibility while allowing
;; customize to work smoothly.
-(if vcursor-key-bindings
+(if vcursor-key-bindings
(vcursor-bind-keys 'vcursor-key-bindings vcursor-key-bindings))
(defun vcursor-locate ()
(pos-visible-in-window-p (point) vcursor-window))
(progn
(walk-windows
- (function
+ (function
(lambda (win)
(and (not winok)
(eq (current-buffer) (window-buffer win))
projects / emacs.git / commitdiff