;;; webster19.el --- Interface to the American Webster dictionary. ;; Copyright (C) 1995-1997 Georges Brun-Cottan ;; Author: Georges Brun-Cottan ;; Maintainer: Georges Brun-Cottan ;; Author of the original webster package for emacs 18 : Jason R. Glasgow. ;; Keywords: dictionary, webster ;; $Revision: 1.30.1.2 $ ;; LCD Archive Entry: ;; webster19.el|Georges Brun-Cottan|Georges.Brun-Cottan@inria.fr| ;; Interface to the American Webster dictionary. ;; $Date: 1997/04/05 12:43:44 $|$Revision: 1.30.1.2 $|~/interfaces/webster19.el.gz ;;; Copyright: ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of version 2 of the GNU General Public ;; License as published by the Free Software Foundation. ;; ;; This program 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. If you did not, write to the Free Software Foundation, ;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. ;;; Commentary: ;; This package is a client interface to the webster online dictionary ;; that runs on NeXT workstations. More precisely to the webster server ;; stub written for NeXT station by Steve Hayman ;; (see ftp.cs.indiana.edu:/pub/webster or ;; ftp.inria.fr:/pub/ftp/network/misc/websterd.tar.Z). ;; It allows to find word definitions, spelling, completions and synonyms ;; with a couple of key strokes under emacs. ;; ;; This package is taken from the webster.el package of Jason R. Glasgow ;; (3/18/89) last modified by Dave Sill (3/21/89). It has been ;; extensively rewritten. ;; ;; Although this package has been tested for a while, I guess you will ;; find a lot of bugs or features :-). Please, feel free to send me ;; comments, ideas and BUG FIXES. (see gripe 'g' in webster-mode) ;; ;; The last version can be found at ;; http://prof.inria.fr/~bruncott/elisp/webster19.el ;; You're invited to look at the last alpha version at ;; http://prof.inria.fr/~bruncott/elisp/webster19-alpha.el ;; ;; Required environment : ;; ;; - Emacs19. ;; - An accessible webster server on the net. I think only NeXTs run such ;; a program, so you must have one available on your net ... ;; ;; Setup ;; ;; Before using this package you have to set the `webster-host' ;; variable (see line (defvar webster-host ...) in the source) to the ;; name or the list of names of websterd server(s) available on your ;; site. You must also set the `webster-port' variable (see line ;; (defvar webster-port ...) in the source). ;; ;; It is easier also to put this in your .emacs ;; ;; (autoload 'webster-minor-mode "webster19") ;; (autoload 'webster "webster19") ;; ;; *General ;; ;; Aside from the general setup of the package (see the beginning of the ;; source code), three hooks are available for general users: ;; - webster-mode-hook ;; is called at the termination of the webster-mode installation. ;; default is nil. ;; - webster-minor-mode-hook ;; is called at the termination of the webster-minor-mode ;; installation. default is nil ;; ;; These two hooks are normal hooks. (no args) ;; ;; - webster-reply-hook ;; is called after each successful reply. The ;; hook is called with two arguments, START and END, delimiting the ;; region of the reply in the *Webster definition* buffer. Before ;; calling the hook, the window displaying the *Webster ;; definition* buffer is made the current editing window (hence, ;; the current buffer is also the *Webster definition* ;; buffer). default is webster-hilit-default-reply-hook. ;; ;; ;; *Coloring ;; Default setup is: use hilit if hilit is already used. ;; ;; ;; *Example ;; ;; To change the prefix key for the minor mode, put something like ;; (setq webster-minor-mode-prefix-key "\C-z") ;; in your .emacs before loading the package. ;; ;; Once the package is loaded, you can still change (add) the prefix ;; key, by evaluating something like that ;; (setq webster-minor-mode-hook ;; '(lambda () ;; (define-key webster-minor-mode-map ;; "\C-z" webster-minor-mode-submap))) ;; ;; or simply ;; (define-key webster-minor-mode-map ;; "\C-z" webster-minor-mode-submap))) ;; ;; To use font-lock rather than hilit or nothing ;; (add-hook 'webster-mode-hook 'webster-font-lock-default-hook-2) ;; ;; ;; For instance, following is my .emacs part related to webster19: ;; ;; (autoload 'webster-minor-mode "webster19") ;; (autoload 'webster "webster19") ;; ;; (setq webster-minor-mode-prefix-key "\C-z") ;; before loading webster ;; (add-hook 'webster-mode-hook 'webster-font-lock-default-hook-2) ;; (add-hook 'webster-mode-hook ;; (function (lambda () ;; (push webster-buffer-name ;; special-display-buffer-names) ;; (if (featurep 'framepop) ;; (push webster-buffer-name ;; framepop-do-not-display-list))))) ;; ;; History and various things: ;; ;; This package is taken from the webster.el package of Jason R. Glasgow ;; (3/18/89) last modified by Dave Sill (3/21/89). It has been extensively ;; rewritten. ;; ;; The main differences with original are: ;; ;; - Emacs19 compatible. ;; - Use TCP in place of telnet subprocess (faster request). ;; - minor-mode added. (surely, the most useful feature). ;; - hilit support added. (colorize reply). ;; - mouse support added (can iterate through synonyms, matches...). ;; - requests caching added (faster). ;; - additionnal webster functions (index & complete) added. ;; ;; And a lot of coding and other things. ;; ;; ;; Original author Jason R. Glasgow (glasgow@cs.yale.edu) ;; Modified from telnet.el by William F. Schelter ;; But almost entirely different. ;; ;; Modified by Dirk Grunwald to maintain an open connection. ;; ;; 3/18/89 Ashwin Ram ;; Added webster-mode. ;; Fixed documentation. ;; ;; 3/20/89 Dirk Grunwald ;; Merged Rams changes with new additions: smarter window placement, ;; correctly handles un-exposed webster windows, minor cleanups. ;; Also, ``webster-word'', akin to ``spell-word''. ;; ;; To use this, you might want to add this line to your .emacs file: ;; ;; (autoload 'webster "webster" "look up a word in Webster's 7th edition" t) ;; ;; Then just hit M-x webster to look up a word. ;; ;; 3/21/89 Dave Sill ;; Removed webster-word and webster-define, adding default of current word to ;; webster, webster-spell, and webster-endings instead. ;; ;; May,June 1995, Georges Brun-Cottan ;; - Make the package Emacs-19 compatible. ;; - Take advantages of emacs provision for TCP connection. Don't spawn any ;; subprocess. ;; - Add a webster minor mode. minor-mode-keymap is bound on ;; webster-minor-mode-prefix-key. ;; - Add a mouse choose-by-click mechanism to easily iterate on ;; synonyms, spelling, or ending choices provided in replies. ;; - Provide a default hilit style. Surely not the better, but the ;; layout of webster replies are far to be homogeneous. ;; - The filter algorithm is still sensible to the way filter input ;; is splitted. To stay simple, I avoided any buffering ;; mechanism. It seems to work; until now, I've never received ;; splitted header. ;; - webster-mode-hook and webster-minor-mode-hook are run ;; resp. by webster-mode and webster-minor-mode. ;; - Remember definition requests so further similar requests just set ;; the point. Warning, the memory actually does not consider the ;; webster index used for the request. If you change the index used ;; by webster, you may have to raz the memory (webster-raz-memory) or to ;; toggle memory off in order for the request to be what you expect. ;;; Change log: ;; $Id: webster19.el,v 1.30.1.2 1997/04/05 12:43:44 bruncott Exp $ ;; $Log: webster19.el,v $ ; Revision 1.30.1.2 1997/04/05 12:43:44 bruncott ; rewrote defun-func (no-prompt definitions). ; ; Revision 1.30.1.1 1997/04/04 16:48:08 bruncott ; Use easy-mmode. Binding cleaner. ; ; Revision 1.30 1997/02/16 12:59:19 bruncott ; Use reporter for gripe report. ; Supress cache related bindings (stable enough). ; ; Revision 1.29 1997/02/14 14:32:52 bruncott ; You can now associate a specific port to a specific host. See the ; webster-host documentation. Suggestion from Sam Steingold ; . ; ; Revision 1.28 1997/02/11 17:01:55 bruncott ; Works with Xemacs, but with no menu. I am confused by XEmacs menus... ; ; Revision 1.27 1997/01/28 11:02:00 bruncott ; *** empty log message *** ; ; Revision 1.26 1997/01/28 10:50:18 bruncott ; Better menu names. ; ; Revision 1.25 1997/01/09 21:03:45 bruncott ; added webster-display-buffer-new-frame to easily open a webster ; session. Nice in conjunction with gnudoit. ; ; Revision 1.24 1996/12/12 10:32:28 bruncott ; (fix) Do not use the mark anymore for the history --> ; Requests are no more highlighted in transient-mark-mode. ; ; Revision 1.23 1996/12/12 09:12:00 bruncott ; Added menu. ; Very primitive backend to the Merriam Webster on the Web. ; No Cache. Use browse-url and all the rest in your web browser... ; ; Revision 1.22 1996/07/24 13:22:29 bruncott ; Bug fixed. ; ; Revision 1.21 1996/07/24 13:15:14 bruncott ; Rewrote the cache management. The design itself was buggy. It is ; cleaner. Filter processing has had to be changed accordingly. It is ; cleaner and faster. ; ; Revision 1.20 1996/07/20 14:59:56 bruncott ; *** empty log message *** ; ; Revision 1.19 1996/07/19 18:23:10 bruncott ; Bug relating to the cache management fixed. Better coding. ; ; Revision 1.18 1996/07/16 08:28:55 bruncott ; Added temporary thesaurus request ('t' key). Also mapped on the mouse ; (S-mouse3). Idea from Vladimir Alexiev . ; ; Revision 1.17 1996/07/02 19:48:20 bruncott ; Added support for Font-Lock. ; Added XEmacs (19.14) compatibility. ; ; ; Revision 1.16 1996/03/25 09:23:17 bruncott ; Packaged for elisp archive submission ; ;; Revision 1.15 1995/12/14 08:08:04 bruncott ;; bug fixed ;; ;; Revision 1.14 1995/12/13 20:14:48 bruncott ;; Suppress the annoying confirmation when we exit Emacs while a webster ;; connection is active. Also fixed a bug in the request memory. ;; ;; Revision 1.13 1995/10/26 10:57:42 bruncott ;; Better documentation. key `l' to jump back to the previous point we ;; were. button 2 has the button 3 capability. Bugs fixed and better ;; coding. ;; ;; Revision 1.12 1995/10/25 14:14:57 bruncott ;; bugs fixed. ;; ;; Revision 1.11 1995/10/25 13:44:30 bruncott ;; bugs fixed. ;; ;; Revision 1.10 1995/10/25 10:21:34 bruncott ;; Old bugs fixed. The memory toggle and raz are not furthermore useful; ;; I plan to suppress them. ;; ;; Revision 1.9 1995/10/24 15:20:39 bruncott ;; Memory mechanism is now correct regarding the thesaurus used by ;; queries. Default is now a raw display of pronunciation ;; rubrics (better semantics). Added a gripe mode 'g'. ;; ;; Revision 1.8 1995/09/12 14:26:23 bruncott ;; Character nul '\0' is now considered as a reply terminator. I had ;; mistakenly suppressed this property from the original package. ;; ;; Revision 1.7 1995/09/04 17:01:37 bruncott ;; Created a default webster-reply-hook for hilit. ;; Fixed the phonetic characters. ;; ;; Revision 1.6 1995/08/10 11:48:01 bruncott ;; webster-host is now a list of servers. Servers are successively tried ;; until the first one found to be working. ;; ;; Revision 1.5 1995/08/07 12:00:07 bruncott ;; Added compatibility with other webster packages concerning ;; webster-port. A port number can now be a string. ;; ;; Revision 1.4 1995/07/24 19:38:16 bruncott ;; Hilit is now optional. Added webster-reply-hook. ;; Added some of the format treatment from Gabor J.Toth ;; Added autocompletion of crossref from package (9/14/91) of ;; Jamie Zawinski ;; Added another support for mouse. Button 3 now make a request on the word ;; the mouse is on. ;; Cross references (even smart ones pointing on subdefinition) are better ;; managed. ;; ;; Revision 1.3 1995/07/19 14:40:17 bruncott ;; Added webster-mode-version ;; ;; Revision 1.2 1995/07/19 12:02:31 bruncott ;; Bug fix: the process mark point now on the webster-buffer. ;;; Code: (require 'ring) ; for navigating through the past (require 'easy-mmode) ; for webster-minor-mode (eval-when-compile (require 'browse-url) (require 'font-lock)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Configure the two variables below according to your site. ;; Accesses to most of the webster hosts below are restricted. Sorry ... ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconst webster-url-request "http://www.m-w.com/cgi-bin/mweb" "*URL for webster request. for info http://www.m-w.com/ is the home page of Merriam Webster.") (defconst webster-host '( "sapa.inria.fr" "truite.inria.fr" "clip.inria.fr" "orsay.inria.fr" ("hangout.rutgers.edu" . 765) ("citi.umich.edu" . 2627) ("agate.Berkeley.EDU" . 2627) ("exemple1" . "webster") ("exemple2" . 2627) ("exemple2" . "2627") ) "*INRIA-Rocquencourt webster server Hosts. It can be a string, a list of string, a list of conses whose car is a string matching the host-name and the cdr the webster port in the same syntax as the 'webster-port' variable.") (defconst webster-port 2627 "The default port the webster server is listening to. An integer means a tcp port number. A string means either the webster service name in the /etc/services or the tcp port number according to the string specification.") (defvar webster-mode-hook nil "*webster mode hook.") (defvar webster-memory t "*nil means that request will be made on the webster server, even if a previous similar request was already made") (defvar webster-reply-hook 'webster-hilit-default-reply-hook "Hook ran each time a reply is inserted in the webster buffer. hooks must accept two parameters START and END identifying the region of the webster buffer modified by the reply. This hook is primarily intended for hilit or font-lock treatment.") (defconst webster-history-size 32 "Depth of the navigational graph memorized. See webster-history.") (defvar webster-minor-mode-prefix-key "\C-c\C-w" "prefix key for the webster minor mode.") (defvar webster-menu-map (easy-mmode-define-keymap '(([gripe] . ("Gripe" . webster-gripe)) ([help] . ("Describe mode" . describe-mode)) ([separator-help] . ("--")) ([backward] . ("Backward" . webster-previous-reply)) ([forward] . ("Forward" . webster-next-reply)) ([last] . ("Last" . webster-pop-history)) ([separator-move] . ("--")) ([index] . ("Index" . webster-index)) ([thesaurus] . ("Thesaurus" . webster-thesaurus)) ([spelling] . ("Spelling" . webster-spell)) ([ending] . ("Endings" . webster-endings)) ([completion] . ("Completion" . webster-complete)) ([definition] . ("Definition" . webster))) "Webster") "Webster mode menu map.") (defvar webster-mode-map (easy-mmode-define-keymap (let ((lmap (append (list (cons [menu-bar webster-map] (cons "Webster" webster-menu-map))) '(("?" . describe-mode) ("c" . webster-complete) ("d" . webster) ("e" . webster-endings) ("g" . webster-gripe) ("l" . webster-pop-history) ("i" . webster-index) ("q" . webster-quit) ("s" . webster-spell) ("t" . webster-thesaurus) ("\M-p" . webster-previous-reply) ("\M-n" . webster-next-reply) ("\C-c" . webster-complete-no-prompt) ("\C-d" . webster-no-prompt) ("\C-e" . webster-endings-no-prompt) ("\C-s" . webster-spell-no-prompt) ("\C-t" . webster-thesaurus-no-prompt))))) (if window-system (append lmap (if (string-match "XEmacs" emacs-version) '(([(button2)] . webster-mouse-choose-completion) ([(button3)] . webster-mouse-webster) ([(shift button3)] . webster-mouse-thesaurus)) '(([mouse-2] . webster-mouse-choose-completion) ([mouse-3] . webster-mouse-webster) ([S-mouse-3] . webster-mouse-thesaurus)))) lmap))) "Webster mode map. Inherited by webster minor mode map.") (defvar webster-minor-menu-map (easy-mmode-define-keymap '(([thesaurus] . ("Thesaurus" . webster-thesaurus)) ([spelling] . ("Spelling" . webster-spell)) ([ending] . ("Ending" . webster-endings)) ([completion] . ("Completion" . webster-complete)) ([definition] . ("Definition" . webster)) ([banner] . ("-- With prompt --")) ([thesaurus-np] . ("Thesaurus" . webster-thesaurus-no-prompt)) ([spelling-np] . ("Spelling" . webster-spell-no-prompt)) ([ending-np] . ("Ending" . webster-endings-no-prompt)) ([completion-np] . ("Completion" . webster-complete-no-prompt)) ([definition-np] . ("Definition" . webster-no-prompt)) ([banner-np] . ("-- No prompt --"))) "Webster") "Webster minor mode menu map.") (defvar webster-minor-mode-map (let ((map (make-sparse-keymap))) (define-key map [menu-bar webster-map] (cons "Webster" webster-minor-menu-map)) (define-key map webster-minor-mode-prefix-key webster-mode-map) map) "Webster minor mode map. Inherited by webster minor mode map.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; You don't need to modify anything below ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconst webster-mode-version "$Id: webster19.el,v 1.30.1.2 1997/04/05 12:43:44 bruncott Exp $" "*Current version of the webster package.") (defconst webster-backend-supported '(w3 next) "List of kind of supported webster server") (defvar webster-backend 'next "The kind of webster backend chosen") (defvar webster-actual-server-host nil "Server we are actually connected with.") (defvar webster-buffer-name "*Webster definition*" "The name of the buffer used to record replies from the webster server.") (defvar webster-process nil "The current webster tcp handle") (defvar webster-process-name "webster" "The current webster tcp handle name") (defvar webster-buffer nil "The current webster tcp buffer.") ;;(defvar webster-pending-request-p nil ;; "True if a request is pending.") (defvar webster-current-request nil "Last request. Its associated plist is used to hold state of the request. 'pending is on after a request have been made until completion. 'header-matched is on after the reply header have been received. 'reply-in-buffer is t when the reply has to be inserted in the buffer, nil when the reply is a message. ") (defvar webster-separator "---------------------------------------\n" "Separator inserted between webster replies in the webster buffer." ) (defvar webster-separator-regexp webster-separator "regexp to match separator in the webster buffer. Must be set accordingly to webster-separator " ) (defvar webster-request-assoc nil "Alist used to record (memorize) definition replies and their corresponding buffer position. Key is a two or three member list consisting of Value is either a position in the webster-definition buffer or a message (string) to display." ) (defvar webster-thesaurus-list '(("dictionary") ("thesaurus") ("dictionary-full")) "Set of thesaurus known by webster19. dictionary thesaurus is the classic dictionary. It contains word definitions. thesaurus thesaurus must be used when looking for synonym. dictionary-full reply words whose definition include the one looked for.") (defvar webster-command-list '( (definition . "DEFINE") (spelling . "SPELL") (completion . "COMPLETE") (endings . "ENDINGS") (index . "INDEX") (as-is . "")) "Alist of supported webster action and their associated command") (defvar webster-default-thesaurus "dictionary") (defvar webster-current-thesaurus webster-default-thesaurus "Used by the memory mechanism.") (defvar webster-reply-header "^\\(SPELLING\\|MATCHS\\|WILD\\|DEFINITION\\|AMBIGUOUS\\|COMPLETION\\)" "regexp matching KEYWORDs presents in webster replies") (defvar webster-reply-header-to-delete "^DEFINITION.*[\n]") (defvar webster-translate-symbol-table nil ;; '(("a^-" . "å") ;; ("a^:" . "ä") ;; ("a." . "à") ;; ("e^-" . "ê") ;; ("[0xF5]^-" . "î") ;; ("o^-" . "ô") ;; ("o[0xC7]". "ò") ;; (":u" . "ü")) "Alist describing the translation of pronunciation symbols. Set it to nil to disable translation.") ;; (defvar webster-phonetic-section "\\[[]]*\\]") (defvar webster-crossref-hilit-pattern "[A-Z][A-Z]+\\( [A-Z][A-Z]+\\)*") (defvar webster-crossref-pattern (concat "\\<" "\\([0-9]\\)*" "\\([A-Z][A-Z]+\\([ ][A-Z][A-Z]+\\)*\\)\\>" "[ ]*\\([0-9]+[a-z]*\\)*" "\\>") "pattern for cross references.") (defconst webster-completion-table (make-vector 511 0) "All requests and cross references are remembered here. Use for autocompletion") (defvar webster-history (make-ring webster-history-size) "Ring saving request point in the webster definition buffer. Use for navigating backward and forward.") (defvar webster-history-pos 0 "Where am I in the ring") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; GNU emacs do not have event-point (eval-and-compile (if (not (fboundp 'event-point)) (defun event-point (event) (posn-point (event-start event))))) ;;; The webster buffer is selected and displayed. ;;; BODY is then evaluated. The webster buffer point is ;;; not saved. (defmacro webster-window-excursion (&rest body) (` (let ((current-window (selected-window))) (unwind-protect (progn (webster-display-buffer) (select-window (get-buffer-window webster-buffer t)) (,@ body)) (select-window current-window))))) ;;; The webster buffer is first made the current editing buffer. ;;; Then BODY is evaluated. Webster cursor and point are not saved. (defmacro webster-excursion (&rest body) (` (let ((current-buffer (current-buffer))) (unwind-protect (progn (set-buffer webster-buffer) (,@ body)) (set-buffer current-buffer) )))) (defun webster-add-request-state (value) (let ((state-pl (get 'webster-current-request 'state))) (put 'webster-current-request 'state (if state-pl (cons value state-pl) (list value))))) (defun webster-del-request-state (value) (let ((state-pl (get 'webster-current-request 'state))) (if state-pl (put 'webster-current-request 'state (delq value state-pl))))) (defun webster-raz-request-state () (put 'webster-current-request 'state () )) (defsubst webster-request-state-p (state) (memq state (get 'webster-current-request 'state))) (defun webster-intern (string) (while (string-match "\\." string) (setq string (concat (substring string 0 (match-beginning 0)) (substring string (match-end 0))))) (intern (downcase string) webster-completion-table)) ;;; Manage webster crossref request (defun webster-mouse-choose-completion (event) (interactive "e") (webster-window-excursion (goto-char (event-point event)) (let ((crossref (get-text-property (point) 'webster))) (if crossref (webster-crossref crossref) (webster-mouse-choice event))))) ;;; Make a webster request on the highlighted word ;;; webster-buffer must be the current buffer (defun webster-mouse-choice (event) (save-excursion (goto-char (event-point event)) (let (beg end) (and (not (eobp)) (get-text-property (point) 'mouse-face) (setq end (point) beg (1+ (point)))) (if (null beg) (webster (current-word 'strict)) ; as webster-mouse-choose (setq beg (previous-single-property-change beg 'mouse-face)) (setq end (or (next-single-property-change end 'mouse-face) (point-max))) (webster (buffer-substring beg end)))))) ;;; Retrieve the crossref definition and set the cursor on it. ;;; webster-window must be the current editing window (defun webster-crossref (crossref) (webster (symbol-name (car crossref))) ;; wait for complete answer (while (webster-request-state-p 'pending) (accept-process-output webster-process)) (and (re-search-forward (concat "^" (if (equal (nth 1 crossref) "") "1*" (nth 1 crossref)) (symbol-name (nth 0 crossref))) nil t) (if (nth 2 crossref) (re-search-forward (concat "^" (nth 2 crossref) ".*:.*") nil t) t) ;; some errors can occur because some webster crossrefs ;; are not exact words (e.g whatnot in place of what-not) ;; of the definition they refer to. So we want to be sure before ;; putting the point in the cyberspace. (progn (goto-char (match-beginning 0)))) (recenter 0)) ;;; make a webster request on the word under the mouse. (defun webster-mouse-interaction (event func) (webster-window-excursion (goto-char (event-point event)) (funcall func (current-word 'strict)))) (defun webster-mouse-webster (event) "Webster request using the mouse" (interactive "e") (webster-mouse-interaction event 'webster)) (defun webster-mouse-thesaurus (event) "Webster thesaurus request using the mouse" (interactive "e") (webster-mouse-interaction event 'webster-thesaurus)) (defun webster-translate-symbols () ;; Beware! It doesn't preserve point. (if webster-translate-symbol-table (standard-display-european 1)) (let (maxp minp table entry) (while (setq maxp (re-search-forward "\\\\[^\\]*\\\\" nil t)) (setq minp (search-backward "\\" nil t 2) table webster-translate-symbol-table) (while table (setq entry (car table) table (cdr table)) (goto-char minp) (while (search-forward (car entry) maxp 't) (replace-match (cdr entry) nil 't))) (goto-char maxp)))) (defun webster-parse-region (begin end) "Parses the region between BEGIN and END, reformating the text and looking for possible cross references. Such references can be selected with the mouse, as in the *Completion* buffer." (save-restriction (let (case-fold-search buffer-read-only) (narrow-to-region begin end) ;; translate pronunciation symbols (goto-char (point-min)) (webster-translate-symbols) ;; change things like "1b1 --" to "1b1:", they are appearantly the same (goto-char (point-min)) (while (re-search-forward "\\(^[0-9]+[^:-]*\\) --" nil t) (replace-match "\\1:")) (goto-char (point-min)) (if (re-search-forward "^\\(MATCH\\|SPELLING\\|WILD\\)" nil t) ;; Reply follows a simple format: (while (re-search-forward "^[0-9]+ \\(\\w+\\)" nil t) (add-text-properties (match-beginning 1) (match-end 1) '(mouse-face highlight))) ;; Reply is a DEFINITION reply. Look for uppercase word, (while (re-search-forward webster-crossref-pattern nil t) (let ((crossref (webster-intern (buffer-substring (match-beginning 2) (match-end 2)))) (definition-section (if (match-beginning 1) (buffer-substring (match-beginning 1) (match-end 1)) "")) (label-section (if (match-beginning 4) (buffer-substring (match-beginning 4) (match-end 4))))) (add-text-properties (match-beginning 2) (match-end 2) (list 'mouse-face 'highlight 'webster (list crossref definition-section label-section))))))))) (defun webster-filter-presentation (string) "Makes some aesthetic surgery on the reply. Also looks for the end of replies." (goto-char (point-max)) (let ((now (point)) buffer-read-only) (insert string) (save-restriction (narrow-to-region now (point)) ;; convert dos-like carriage return (goto-char (point-min)) (while (re-search-forward "\\(\0\\|\015\\|\200\\)" nil t) (replace-match "" nil t)) ;; delete Webster header stuff if any (goto-char (point-min)) (if (looking-at webster-reply-header-to-delete) (replace-match "" nil t)) ))) (defun webster-filter-1 (string) (if (webster-request-state-p 'header-matched) t ; we avoid expensive pattern-matching (webster-add-request-state 'header-matched) (cond ((string-match "^SPELLING \\([01]\\)" string) (message (webster-update-memory webster-current-request (if (char-equal (aref string (match-beginning 1)) ?0) "...Word not found in webster" "...Spelled correctly")))) ((string-match "^AMBIGUOUS \\([0-9]+\\)" string) (message (webster-update-memory webster-current-request (format "Ambiguous: %s word(s) match your prefix. (see webster-endings command) " (substring string (match-beginning 1) (match-end 1)))))) ((string-match "^COMPLETION \\(.*\\)" string) (message (webster-update-memory webster-current-request (substring string (match-beginning 1) (match-end 1))))) (t (webster-add-request-state 'reply-in-buffer) (if (string-match webster-reply-header string) (webster-window-excursion (webster-update-memory webster-current-request (goto-char (point-max))) (let (buffer-read-only) (insert-string webster-separator)) (recenter 1))) )))) ;;; Upcall entry-point. webster replies are formatted with a dos ;;; newline format. End of some replies is the char \200. These ;;; replies are those relating to definitions and to ambigous request ;;; which terminates in choices to be display. We use this useful ;;; property to wait the reply to be complete before doing any smart ;;; treatment. So we are more robust relating to the way input is ;;; splitted. The drawback is that, on long reply, the user have to ;;; wait a short time to see the region hilited and ready for mouse ;;; manipulation but correctness is, in no doubt, more important. (defun webster-filter (proc string) (save-match-data ;; upon end-marker reception, we set the predicate ;; webster-pending-request-p (if (string-match "\200\\|\0" string) (webster-del-request-state 'pending)) (webster-filter-1 string) (if (webster-request-state-p 'reply-in-buffer) (webster-excursion (webster-filter-presentation string) (if (not (webster-request-state-p 'pending)) ;; request is complete and updated the buffer. post reply treatment. (progn (webster-parse-region (process-mark proc) (point-max)) (run-hook-with-args 'webster-reply-hook (process-mark proc) (point-max)) (if (eq (selected-window ) (get-buffer-window webster-buffer t)) ;; if the selected window is the webster window ;; we set the point at the reply beginning. (progn (goto-char (process-mark proc)) (recenter 0))) (set-marker (process-mark proc) (point-max))))) ))) (defun webster-init-process () (delete-process webster-process) (setq webster-actual-server-host nil) (setq webster-current-thesaurus "dictionary")) ; for future connection (defun webster-sentinel (proc event) (save-match-data (let ((case-fold-search t)) (if (string-match "finish\\|exit\\|abort" event) (webster-init-process))))) (defsubst webster-portp (port) (or (stringp port) (integerp port))) (defsubst webster-hostp (host) (stringp host)) (defun webster-get-server (webster-host) "Return a cons (host-name . port) of the server webster-host." (cond ((null webster-host) nil) ((and (webster-hostp webster-host) (webster-portp webster-port)) (cons webster-host webster-port)) ((and (consp webster-host) (webster-hostp (car webster-host)) (webster-portp (cdr webster-host))) webster-host) (t (error "Invalid host format: consp or stringp: %S" webster-host)))) (defun webster-init-session () "init a TCP connection with the server. Initialize the buffer, filter and sentinel." (setq webster-buffer (get-buffer-create webster-buffer-name) webster-process (let ((whost (cond ((listp webster-host) webster-host) ((or (consp webster-host) (stringp webster-host)) (list webster-host)) (t (error "Invalid host format: %S"))))) (catch 'websterd-found (mapcar (function (lambda (host) (setq host (webster-get-server host)) (setq webster-actual-server-host host) (message (format "looking on %S ..." webster-actual-server-host)) (let ((wprocess (condition-case nil (open-network-stream webster-process-name webster-buffer (car host) (cdr host)) (error nil)))) (if wprocess (progn (message (format "using %S" webster-actual-server-host)) (throw 'websterd-found wprocess)))))) whost) (error "No valid webster server found amongst %S" webster-host)))) (process-kill-without-query webster-process) (set-marker (process-mark webster-process) (point-min) webster-buffer) (set-process-filter webster-process 'webster-filter) (set-process-sentinel webster-process 'webster-sentinel) ;; set output buffer in webster mode (webster-excursion (webster-mode) (setq buffer-read-only t))) (defsubst webster-init () "If not already done. init a webster session." (if (or (not webster-buffer) (not webster-process) (not (eq (process-status webster-process) 'open))) ;; first init a webster session (webster-init-session) t )) ;;; The main client function. Send requests to the webster server. ;;; Init a TCP connection with the server, the first time a request is ;;; made. (defun webster-send-request-raw (request arg) (webster-init) (setq webster-current-request (list arg request webster-current-thesaurus)) (webster-raz-request-state) (webster-add-request-state 'pending) (process-send-string webster-process (concat (cdr (assq request webster-command-list)) " " arg "\n"))) (defun webster-w3-get-current-thesaurus () (if (not (member webster-current-thesaurus '("dictionary" "thesaurus"))) (error "Unsupported thesaurus in WWW mode") (capitalize webster-current-thesaurus))) (defun webster-w3-send-request (request word) (require 'browse-url) (if (not (member webster-current-thesaurus '("dictionary" "thesaurus"))) (error "Unsupported thesaurus in WWW mode")) (if (member request '(definition) ) (let ((book (webster-w3-get-current-thesaurus))) (browse-url (format "%s?book=%s&va=%s" webster-url-request book word))))) (defun webster-send-request-with-memory (request word) (if (eq webster-backend 'w3) (webster-w3-send-request request word) (if (not webster-memory) (webster-send-request-raw request word) (webster-canonize-word word) (if (not (and webster-buffer (equal (buffer-name webster-buffer) webster-buffer-name))) ;; we raz the request memory in case webster buffer has been killed (setq webster-request-assoc nil)) (let ((pos (webster-get-in-memory word request webster-current-thesaurus))) (if pos ;; yes, in memory. (cond ((stringp pos) (message pos)) ((integer-or-marker-p pos) (webster-window-excursion (goto-char pos) (recenter 0))) (t (error "Illegal memory entry %S" pos))) (webster-put-in-memory nil word request webster-current-thesaurus) (webster-send-request-raw request word) ))))) (defun webster-display-buffer () "Make a Webster window visible " (interactive) (let ((gbw (get-buffer-window webster-buffer t))) (if (not gbw) (display-buffer webster-buffer) (make-frame-visible (window-frame gbw))))) ;;; A frame is created displaying a window on the webster buffer ;;; Nice for external request. (defun webster-display-buffer-new-frame () (unwind-protect (save-window-excursion (set-buffer webster-buffer) (make-frame)))) ;;;###autoload (defun webster-previous-reply () "Set the cursor to the beginning of the previous reply." (interactive) (webster-display-buffer) (webster-excursion (if (search-backward webster-separator-regexp nil t) (recenter 0) (message "At the first reply.")))) ;;;###autoload (defun webster-next-reply () "Set the cursor to the beginning of the next reply." (interactive) (webster-display-buffer) (webster-excursion (if (search-forward webster-separator-regexp nil t) (recenter 1) (message "At the last reply.")))) (defun webster-put-in-memory (point word type &optional thesaurus) (setq webster-request-assoc (cons (cons (list word type thesaurus) point) webster-request-assoc))) (defun webster-get-in-memory (word type &optional thesaurus) (cdr (assoc (list word type thesaurus) webster-request-assoc))) (defun webster-update-memory (key value) (let ((elem (assoc key webster-request-assoc))) (if elem (setcdr elem value) value))) (defun webster-canonize-word (word) ;; Needed as word will be inserted in a Alist and equal (and not ;; string-equal) is used by assoc. (set-text-properties 0 (length word) nil word) (if (equal word "") ;;if we don't check for that we'll end up in a deadlock (error "Webster19: no word specified."))) (defun webster-push-history () (if (equal (window-buffer) webster-buffer) (progn (ring-insert webster-history (point)) (setq webster-history-pos 0)))) (defun webster-pop-history () "Go back to the previous position" (interactive) (if (ring-empty-p webster-history) (error "No previous request") (goto-char (ring-ref webster-history webster-history-pos)) (setq webster-history-pos (1+ webster-history-pos)))) ;;; Top level Webster commands ;;;###autoload (defun webster (word) "Look up a word in the Webster's dictionary." (interactive (list (let ((completion-ignore-case t) (prompt "Look up word in webster: ") (initial-input (current-word 'strict))) (downcase (completing-read prompt webster-completion-table nil nil initial-input))))) (webster-intern word) (webster-push-history) (webster-send-request-with-memory 'definition word)) ;;;###autoload (defun webster-thesaurus (word) "Make a request in the webster thesaurus. Current index is preserved for future request" (interactive (list (let ((completion-ignore-case t) (prompt "Look up word in the webster thesaurus: ") (initial-input (current-word 'strict))) (downcase (completing-read prompt webster-completion-table nil nil initial-input))))) (let ((index webster-current-thesaurus)) (webster-index "thesaurus") (webster word) (webster-index index))) ;;;###autoload (defun webster-endings (word) "Look up endings for a word in the Webster's dictionary." (interactive (list (read-string "Find endings for word in webster: " (current-word 'strict)))) (webster-send-request-with-memory 'endings word)) ;;;###autoload (defun webster-spell (word) "Look spelling for a word in the Webster's dictionary." (interactive (list (read-string "Try to spell word in webster: " (current-word 'strict)))) (webster-send-request-with-memory 'spelling word)) ;;;###autoload (defun webster-complete (word) "Look spelling for a word in the Webster's dictionary." (interactive (list (read-string "Try to spell word in webster: " (current-word 'strict)))) (webster-send-request-with-memory 'completion word)) ;;;###autoload (defun webster-index (index) "Select index for future webster look up." (interactive (list (completing-read "Index: " '(("dictionary") ("thesaurus") ("dictionary-full")) nil 1 (cond ((string-equal webster-current-thesaurus "thesaurus") "dictionary") ((string-equal webster-current-thesaurus "dictionary") "thesaurus") (t "dictionary"))))) (if (not (string= webster-current-thesaurus index)) (webster-send-request-raw 'index (setq webster-current-thesaurus index)))) ;;;###autoload (defun webster-request (command) "Ask for a request to be send to the websterd." (interactive (list (read-string "Request : "))) (webster-send-request-raw 'as-is command)) ;;;###autoload (defun webster-quit () "Close connection and quit webster-mode. Buffer is not deleted." (interactive) (message "Closing connection to %s..." webster-actual-server-host) (delete-process webster-process) (message "Closing connection to %s... done" webster-actual-server-host) (setq webster-actual-server-host nil) (setq webster-current-thesaurus "dictionary")) (defmacro defun-func (func) "Define the no-prompt-version of FUNC. FUNC is not evaluated." (let* ((func-name (symbol-name func)) (new-name (concat func-name "-no-prompt")) (new-symbol (intern new-name))) `(defun ,new-symbol () ,(format "Execute %s on the current word" func-name) (interactive) (,func (current-word 'strict))))) (mapcar (function (lambda (f) (eval `(defun-func ,f)))) '(webster webster-complete webster-endings webster-spell webster-thesaurus)) ;;;###autoload (defun webster-mode () "Major mode for interacting with on-line Webster's dictionary. \\{webster-mode-map} Use webster-mode-hook for customization." (interactive) (kill-all-local-variables) (setq major-mode 'webster-mode) (setq mode-name "Webster") (use-local-map webster-mode-map) (make-local-variable 'font-lock-defaults) (setq font-lock-defaults '(webster-font-lock-keywords t)) (run-hooks 'webster-mode-hook)) ;;;###autoload (autoload 'webster-minor-mode) (easy-mmode-define-minor-mode webster-minor "Minor mode for interacting with on-line Webster's dictionary. no argument toggles the mode. non-null prefix argument turns on the mode. null prefix argument turns off the mode. Use `webster-minor-mode-hook', `webster-minor-mode-on-hook' and `webster-minor-mode-off-hook' for customization. Default bindings for control keys is to not prompt for the webster request. No promtp function use the current word as argument. \\{webster-minor-mode-map}" nil " Webster" webster-minor-mode-map) ;;;###autoload (defun webster-toggle-memory (arg) "no argument toggle the request memory. non nul prefix argument turn on request memory. nul prefix argument turn off the request memory." (interactive "P") ;; set or toggle according to args (message (if (setq webster-memory (if (null arg) (not webster-memory) (> (prefix-numeric-value arg) 0))) "webster memory ON" "webster memory OFF"))) ;;;###autoload (defun webster-raz-memory () "Erase the request memory." (interactive) (setq webster-request-assoc nil) (message "webster memory erased")) ;;;###autoload (defun webster-gripe () "Send a gripe to the author." (interactive) (reporter-submit-bug-report "Georges.Brun-Cottan@inria.fr" webster-mode-version '( webster-mode-version webster-actual-server-host webster-host webster-port ) (function (lambda () (save-excursion (mail-position-on-field "subject") (insert "webster gripe report")))) )) ;;; Be careful. The following code is quite sensible to the ;;; webster-separator and webster-separator-regexp definitions. ;;; Hilit19 support (defvar webster-hilit-patterns (list (list webster-separator-regexp nil 'comment) ; separator (list (concat webster-separator ".*") nil 'decl) (list webster-crossref-hilit-pattern nil 'crossref) ;cross reference '("^[0-9]+[^:\n]*:" nil label) ; sub definition '("^[0-9]+ [^:\n]*" ":" label) ; sub definition '("^[0-9][a-zA-Z]+[^:\n]*" nil defun) '("\\\\[^\\\n]*\\\\" nil string) '("<" ">" msg-quote)) "Default hilit patterns for webster mode. The declaration order of patterns is important.") (defvar webster-hilit-patterns-2 (list (list webster-separator-regexp nil 'comment) ; separator '("\\\\[^\\\n]*\\\\" nil string) (list (concat webster-separator ".*") nil 'decl) (list webster-crossref-hilit-pattern nil 'keyword) ;cross reference '("^[0-9]+[^:\n]*:" nil defun) ; sub definition '("^[0-9]+ [^:\n]*" ":" defun) ; sub definition '("^[0-9][a-zA-Z]+[^:\n]*" nil decl) '("<" ">" define)) "Alternative hilit patterns for webster mode. The declaration order of patterns is important.") ;; we load patterns only if hilit is already present (and window-system (featurep 'hilit19) (hilit-set-mode-patterns 'webster-mode webster-hilit-patterns)) ;; uncomment this one if you prefer ;; (and window-system ;; (featurep 'hilit19) ;; (hilit-set-mode-patterns 'webster-mode webster-hilit-patterns-2)) (defun webster-hilit-default-reply-hook (start end) "Highlight the reply region in the webster definition buffer" (and window-system (featurep 'hilit19) (hilit-highlight-region start end nil t))) ;;; Font-Lock support ;;; We just have to create a face for each syntaxic components. ;;; If you do not like these faces, just redefine them. (defvar webster-comment-face (make-face 'webster-comment-face)) (defvar webster-definition-face(make-face 'webster-definition-face)) (defvar webster-subdefinition-face (make-face 'webster-subdefinition-face)) (defvar webster-string-face (make-face 'webster-string-face)) (defvar webster-quote-face (make-face 'webster-quote-face)) (defvar webster-crossref-face (make-face 'webster-crossref-face)) (defun webster-match-head-definition (limit) "Used by font-lock. Match first definition of webster reply." (if (re-search-forward webster-separator-regexp limit t) (re-search-forward ".*"))) (defvar webster-font-lock-keywords (list '(webster-match-head-definition 0 webster-definition-face) (list webster-crossref-hilit-pattern 0 'webster-crossref-face t) ;crossref (list webster-separator-regexp 0 webster-comment-face t) '("^[0-9][a-zA-Z]+[^\n:]*" 0 webster-definition-face t) '("^[0-9]+[^:\n]*:" 0 webster-subdefinition-face t) ; sub definition '("\\\\[^\\\n]*\\\\" 0 webster-string-face t) ; phonetic rubric '("<.*>" 0 webster-quote-face t) '("<[^>\n]*$" 0 webster-quote-face t) '("^[^<\n]*>" 0 webster-quote-face t) ) "Expressions to highlight in webster mode") (defun webster-font-lock-default-hook () "A sample default hook for font-lock. Put (add-hook 'webster-mode-hook 'webster-font-lock-default-hook) in your .emacs to use it. This hook uses standard font-lock faces." (turn-on-font-lock) (copy-face font-lock-comment-face webster-comment-face) (copy-face font-lock-function-name-face webster-definition-face) (copy-face font-lock-keyword-face webster-subdefinition-face) (copy-face font-lock-string-face webster-string-face) (copy-face font-lock-type-face webster-quote-face) (copy-face font-lock-reference-face webster-crossref-face) (setq webster-reply-hook 'font-lock-fontify-region) ) (defun webster-font-lock-default-hook-2 () "A sample default hook for font-lock. Put (add-hook 'webster-mode-hook 'webster-font-lock-default-hook-2) in your .emacs to use it. This hook uses example of custom faces." (turn-on-font-lock) (set-face-foreground webster-comment-face "Magenta") (set-face-foreground webster-definition-face "Red") (set-face-foreground webster-subdefinition-face "Blue") (set-face-foreground webster-string-face "DimGrey") (set-face-foreground webster-quote-face "Brown") (set-face-foreground webster-crossref-face "LimeGreen") (setq webster-reply-hook 'font-lock-fontify-region) ) (provide 'webster19) ;;; webster19.el ends here ;; ;; Local Variables: ;; eval: (if window-system (set-frame-width (selected-frame) 100)) ;; End: ;;