Mercurial > hg > xemacs-beta

comparison lisp/packages/webster.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;; Copyright (C) 1989 Free Software Foundation
2
3 ;; This file is part of GNU Emacs.
4
5 ;; GNU Emacs is distributed in the hope that it will be useful,
6 ;; but WITHOUT ANY WARRANTY. No author or distributor
7 ;; accepts responsibility to anyone for the consequences of using it
8 ;; or for whether it serves any particular purpose or works at all,
9 ;; unless he says so in writing. Refer to the GNU Emacs General Public
10 ;; License for full details.
11
12 ;; Everyone is granted permission to copy, modify and redistribute
13 ;; GNU Emacs, but only under the conditions described in the
14 ;; GNU Emacs General Public License. A copy of this license is
15 ;; supposed to have been given to you along with GNU Emacs so you
16 ;; can know your rights and responsibilities. It should be in a
17 ;; file named COPYING. Among other things, the copyright notice
18 ;; and this notice must be preserved on all copies.
19 ;;
20 ;;; Synched up with: Not in FSF.
21
22 ;; Author Jason R. Glasgow (glasgow@cs.yale.edu)
23 ;; Modified from telnet.el by William F. Schelter
24 ;; But almost entirely different.
25 ;;
26 ;; Modified by Dirk Grunwald to maintain an open connection.
27 ;;
28 ;; 3/18/89 Ashwin Ram <Ram-Ashwin@yale.edu>
29 ;; Added webster-mode.
30 ;; Fixed documentation.
31 ;;
32 ;; 3/20/89 Dirk Grunwald <grunwald@flute.cs.uiuc.edu>
33 ;; Merged Rams changes with new additions: smarter window placement,
34 ;; correctly handles un-exposed webster windows, minor cleanups.
35 ;; Also, ``webster-word'', akin to ``spell-word''.
36 ;;
37 ;; To use this, you might want to add this line to your .emacs file:
38 ;;
39 ;; (autoload 'webster "webster" "look up a word in Webster's 7th edition" t)
40 ;;
41 ;; Then just hit M-x webster to look up a word.
42 ;;
43 ;; 3/21/89 Dave Sill <dsill@relay.nswc.navy.mil>
44 ;; Removed webster-word and webster-define, adding default of current word to
45 ;; webster, webster-spell, and webster-endings instead.
46 ;;
47 ;; 1/21/91 Jamie Zawinski <jwz@lucid.com>
48 ;; Added webster-reformat to produce better looking output. Made it notice
49 ;; references to other words in the definitions (all upper-case) and do
50 ;; completion on them in the string read by meta-x webster.
51 ;;
52 ;; 9/14/91 Jamie Zawinski <jwz@lucid.com>
53 ;; Improved the above.
54 ;;
55 ;; 4/15/92 Jamie Zawinski <jwz@lucid.com>
56 ;; Improved formatting some more, and added Lucid GNU Emacs font and mouse
57 ;; support (mostly cannibalized from webster-ucb.el.)
58
59 (defvar webster-host "agate.berkeley.edu" ;"129.79.254.192"
60 "The host to use as a webster server.")
61
62 (defvar webster-port "2627"
63 "The port to connect to. Either 103 or 2627")
64
65 (defvar webster-process nil
66 "The current webster process")
67
68 (defvar webster-process-name "webster"
69 "The current webster process")
70
71 (defvar webster-buffer nil
72 "The current webster process")
73
74 (defvar webster-running nil
75 "Used to determine when connection is established")
76
77 ;;;
78 ;;; Initial filter for ignoring information until successfully connected
79 ;;;
80 (defun webster-initial-filter (proc string)
81 (let ((this-buffer (current-buffer)))
82 (set-buffer webster-buffer)
83 (goto-char (point-max))
84 (cond ((not (eq (process-status webster-process) 'run))
85 (setq webster-running t)
86 (message "Webster died"))
87 ((string-match "No such host" string)
88 (setq webster-running t)
89 (kill-buffer (process-buffer proc))
90 (error "No such host."))
91 ((string-match "]" string)
92 (setq webster-running t)
93 (set-process-filter proc 'webster-filter)))
94 (set-buffer this-buffer)))
95
96 (defvar webster-reformat t
97 "*Set this to t if you want the webster output to be prettied up, and
98 for the \\[webster] prompt to do completion across the set of words known
99 to be in the dictionary (words you've looked up, or which appeared in
100 definitions as crossreferences.)")
101
102 (defun webster-filter (proc string)
103 (let ((this-buffer (current-buffer))
104 (endp nil))
105 (set-buffer webster-buffer)
106 (cond ((not (eq (process-status webster-process) 'run))
107 (message "Webster died"))
108 ((string-match "Connection closed" string)
109 (message "Closing webster connection...")
110 (kill-process proc)
111 (replace-regexp "Process webster killed" "" nil)
112 (goto-char 1)
113 (message "Closing webster connection...Done."))
114 ((string-match "SPELLING 0" string)
115 (insert "...Word not found in webster\n"))
116 ((string-match "SPELLING 1" string)
117 (insert "...Spelled correctly\n"))
118 ((let ((end-def-message (or (string-match "\200" string)
119 (string-match "\0" string))))
120 (if end-def-message
121 (progn
122 (webster-filter
123 proc
124 (concat (substring string 0 (- end-def-message 1)) "\n\n"))
125 (setq endp t)
126 (goto-char (point-max))
127 t))))
128 (t
129 (goto-char (point-max))
130 (let ((now (point)))
131 (insert string)
132 (delete-char-in-region now (point) "\^M" " "))
133 (if (process-mark proc)
134 (set-marker (process-mark proc) (point)))))
135 (if endp
136 ;; if the webster window is visible, move the last line to the
137 ;; bottom of that window
138 (let ((webster-window (get-buffer-window webster-buffer))
139 (window (selected-window)))
140 (if webster-reformat (webster-reformat (process-mark proc)))
141 (if webster-window
142 (progn
143 (select-window webster-window)
144 (goto-char (point-max))
145 (recenter (1- (window-height webster-window)))
146 (select-window window)))))))
147
148 (defconst webster-completion-table (make-vector 511 0))
149
150 (defun webster-intern (string)
151 (while (string-match "\\." string)
152 (setq string (concat (substring string 0 (match-beginning 0))
153 (substring string (match-end 0)))))
154 (intern (downcase string) webster-completion-table))
155
156 (defvar webster-fontify (string-match "XEmacs" emacs-version)
157 "*Set to t to use the XEmacs/Lucid Emacs font-change mechanism.")
158
159 (cond ((fboundp 'make-face)
160 (or (find-face 'webster)
161 (face-differs-from-default-p (make-face 'webster))
162 (copy-face 'default 'webster))
163 (or (find-face 'webster-bold)
164 (face-differs-from-default-p (make-face 'webster-bold))
165 (copy-face 'bold 'webster-bold))
166 (or (find-face 'webster-italic)
167 (face-differs-from-default-p (make-face 'webster-italic))
168 (copy-face 'italic 'webster-italic))
169 (or (find-face 'webster-bold-italic)
170 (face-differs-from-default-p (make-face 'webster-bold-italic))
171 (copy-face 'bold-italic 'webster-bold-italic))
172 (or (find-face 'webster-small)
173 (face-differs-from-default-p (make-face 'webster-small))
174 (copy-face 'webster-bold 'webster-small))
175 ))
176
177 (defun webster-fontify (start end face &optional highlight)
178 (let ((e (make-extent start end (current-buffer))))
179 (set-extent-face e face)
180 (if highlight (set-extent-property e 'highlight t))))
181
182
183 (defun webster-reformat (end)
184 "Clean up the output of the webster server, and gather words for the
185 completion table."
186 (if (not webster-reformat) nil
187 (goto-char end)
188 (let ((case-fold-search nil))
189 (re-search-backward "^[A-Z]+" nil t)
190 (if webster-fontify
191 (save-excursion
192 (previous-line 1)
193 (if (looking-at "^DEFINE \\([^ \n]+\\)")
194 (webster-fontify (match-beginning 1) (match-end 1)
195 'webster-bold t))))
196 (cond
197 ((or (looking-at "^DEFINITION [0-9]")
198 (looking-at "^SPELLING"))
199 (forward-line 1)
200 (let ((p (point))
201 (indent 2))
202 (search-forward "\n\n" nil 0)
203 (narrow-to-region p (point))
204 (goto-char p)
205 (while (search-forward "\n" nil t)
206 (delete-char -1)
207 (just-one-space))
208 (goto-char p)
209 (while (not (eobp))
210 (if (looking-at " *\n")
211 (delete-region (match-beginning 0) (match-end 0)))
212 (cond ((looking-at "^[0-9]+ ")
213 (if webster-fontify
214 (webster-fontify (point) (match-end 0)
215 'webster-bold-italic))
216 (goto-char (match-end 0))
217 (if (looking-at "[^\n0-9]+ [0-9]")
218 (save-excursion
219 (goto-char (1- (match-end 0)))
220 (insert "\n")))
221 (if (looking-at "[a-z]+\\( [a-z]+\\)*[ \n]")
222 (webster-intern
223 (buffer-substring (point) (1- (match-end 0)))))
224 (if webster-fontify
225 (webster-fontify (point) (1- (match-end 0))
226 'webster-bold t))
227 (goto-char (1- (match-end 0)))
228 (if (looking-at " *\n") (forward-line 1)))
229 ((looking-at " *[0-9]+\\. ")
230 (setq indent 5)
231 (delete-horizontal-space)
232 (insert (if (= (preceding-char) ?\n) " " "\n "))
233 (skip-chars-forward "0-9. ")
234 (if webster-fontify
235 (webster-fontify
236 (save-excursion (beginning-of-line) (point))
237 (point)
238 'webster-bold-italic)))
239 ((looking-at " *\\([0-9]+\\): *")
240 (let ((n (buffer-substring (match-beginning 1)
241 (match-end 1))))
242 (delete-region (match-beginning 0) (match-end 0))
243 (insert "\n")
244 (indent-to (- 6 (length n)))
245 (insert n " : ")
246 (setq indent 9)
247 (if webster-fontify
248 (webster-fontify
249 (save-excursion (beginning-of-line) (point))
250 (point)
251 'webster-bold-italic))))
252 ((looking-at " *\\([0-9]+\\)\\([a-z]+\\): *")
253 (let ((n (buffer-substring (match-beginning 1)
254 (match-end 1)))
255 (m (buffer-substring (match-beginning 2)
256 (match-end 2))))
257 (if (not (equal m "a")) (setq n " "))
258 (delete-region (match-beginning 0) (match-end 0))
259 (insert "\n")
260 (indent-to (- 6 (length n)))
261 (insert n " ")
262 (insert m " : ")
263 (setq indent 12)
264 (if webster-fontify
265 (webster-fontify
266 (save-excursion (beginning-of-line) (point))
267 (point)
268 'webster-bold-italic))))
269 ((looking-at " *\\([0-9]+\\)\\([a-z]+\\)\\([0-9]+\\): *")
270 (let ((n (buffer-substring (match-beginning 1)
271 (match-end 1)))
272 (m (buffer-substring (match-beginning 2)
273 (match-end 2)))
274 (o (buffer-substring (match-beginning 3)
275 (match-end 3))))
276 (if (not (equal o "1")) (setq m " "))
277 (if (not (equal m "a")) (setq n " "))
278 (delete-region (match-beginning 0) (match-end 0))
279 (insert "\n")
280 (indent-to (- 6 (length n)))
281 (insert n " ")
282 (insert m " ")
283 (insert "(" o ") : ")
284 (setq indent 17)
285 (if webster-fontify
286 (webster-fontify
287 (save-excursion (beginning-of-line) (point))
288 (point)
289 'webster-bold-italic))))
290 ((looking-at " *\\\\")
291 (setq indent 5)
292 (setq p (point))
293 (goto-char (match-end 0))
294 (search-forward "\\")
295 (if (> (current-column) fill-column)
296 (progn
297 (goto-char p)
298 (insert "\n")
299 (indent-to 18)
300 (search-forward "\\")))
301 (if webster-fontify
302 (webster-fontify p (point) 'webster-italic)))
303 ((looking-at " *\\[")
304 (setq indent 6)
305 (delete-horizontal-space)
306 (insert "\n")
307 (indent-to 5)
308 (forward-char 1))
309 ((and (= (preceding-char) ?\])
310 (looking-at " *:"))
311 (delete-horizontal-space)
312 (setq indent 5)
313 (insert "\n "))
314 ((looking-at " *SYN *")
315 (delete-region (point) (match-end 0))
316 (insert "\n")
317 (delete-horizontal-space)
318 (insert " ")
319 (setq indent 6)
320 (if (looking-at "syn ")
321 (progn
322 (if webster-fontify
323 (webster-fontify (point) (+ (point) 3)
324 'webster-bold))
325 (goto-char (match-end 0))
326 (insert "see "))))
327 (t
328 (setq p (point))
329 (skip-chars-forward " ,:;-")
330 (if (or (looking-at
331 "\\([A-Z][-A-Z]+[A-Z]\\)\\( [A-Z][-A-Z]*[A-Z]\\)*")
332 (looking-at "[a-z][-a-z]*\\(\\.[a-z][-a-z]*\\)+"))
333 (let ((s (buffer-substring (point) (match-end 0))))
334 (if webster-fontify
335 (webster-fontify (point) (match-end 0)
336 'webster-bold t))
337 (while (string-match "\\." s)
338 (setq s (concat (substring s 0 (match-beginning 0))
339 (substring s (match-end 0)))))
340 (webster-intern s)))
341 (skip-chars-forward "^ \\")
342 (if (> (current-column) fill-column)
343 (progn
344 (goto-char p)
345 (insert "\n")
346 (delete-horizontal-space)
347 (indent-to indent)
348 (skip-chars-forward " ")
349 (skip-chars-forward "^ \\")
350 )))
351 )))
352 (goto-char (point-min))
353 (while (looking-at "\n") (delete-char 1))
354 (goto-char (point-max))
355 (insert "\n\n")
356 (widen))))))
357
358 ;; " \\(\\(slang\\|cap\\|pl\\|aj\\|av\\|n\\|v\\|vt\\|vi\\)\\(,[ \n]+\\)?\\)+\n"
359
360 ;;;
361 ;;; delete char1 and char2 if it precedes char1
362 ;;; used to get rid of <space><return>
363 (defun delete-char-in-region (start end char1 char2)
364 (goto-char start)
365 (setq char2 (aref char2 0))
366 (while (search-forward char1 end t)
367 (delete-char -1)
368 (if (= (char-after (- (point) 1)) char2)
369 (delete-char -1))))
370
371 ;;;###autoload
372 (defun webster (arg)
373 "Look up a word in the Webster's dictionary.
374 Open a network login connection to a webster host if necessary.
375 Communication with host is recorded in a buffer *webster*."
376 (interactive (list
377 (let ((prompt (concat "Look up word in webster ("
378 (current-word) "): "))
379 (completion-ignore-case t))
380 (downcase
381 (if webster-reformat
382 (completing-read prompt webster-completion-table
383 nil nil)
384 (read-string prompt))))))
385 (if (equal "" arg) (setq arg (current-word)))
386 (webster-send-request "DEFINE" arg))
387
388 ;;;###autoload
389 (defun webster-endings (arg)
390 "Look up endings for a word in the Webster's dictionary.
391 Open a network login connection to a webster host if necessary.
392 Communication with host is recorded in a buffer *webster*."
393 (interactive (list
394 (read-string
395 (concat
396 "Find endings for word in webster (" (current-word) "): "))))
397 (if (equal "" arg) (setq arg (current-word)))
398 (webster-send-request "ENDINGS" arg))
399
400 ;;;###autoload
401 (defun webster-spell (arg)
402 "Look spelling for a word in the Webster's dictionary.
403 Open a network login connection to a webster host if necessary.
404 Communication with host is recorded in a buffer *webster*."
405 (interactive (list
406 (read-string
407 (concat
408 "Try to spell word in webster (" (current-word) "): "))))
409 (if (equal "" arg) (setq arg (current-word)))
410 (webster-send-request "SPELL" arg))
411
412 (defun webster-send-request (kind word)
413 (require 'shell)
414 (let
415 ((webster-command (concat "open " webster-host " " webster-port "\n")))
416
417 (if (or
418 (not webster-buffer)
419 (not webster-process)
420 (not (eq (process-status webster-process) 'run)))
421 (progn
422 (message
423 (concat "Attempting to connect to server " webster-host "..."))
424 (setq webster-buffer
425 (if (not (fboundp 'make-shell)) ;emacs19
426 (make-comint webster-process-name "telnet")
427 (make-shell webster-process-name "telnet")))
428 (let
429 ((this-buffer (current-buffer)))
430 (set-buffer webster-buffer)
431 (webster-mode)
432 (set-buffer this-buffer))
433
434 (setq webster-process (get-process webster-process-name))
435 (set-process-filter webster-process 'webster-initial-filter)
436 (process-send-string webster-process webster-command)
437 (setq webster-running nil);
438 (while (not webster-running) ; wait for feedback
439 (accept-process-output)))) ;
440 (display-buffer webster-buffer nil)
441 (process-send-string webster-process (concat kind " " word "\n"))))
442
443 (defun webster-quit ()
444 "Close connection and quit webster-mode. Buffer is not deleted."
445 (interactive)
446 (message "Closing connection to %s..." webster-host)
447 (kill-process webster-process)
448 (message "Closing connection to %s...done" webster-host)
449 (bury-buffer))
450
451 (defvar webster-mode-map nil)
452
453 (defun webster-mode ()
454 "Major mode for interacting with on-line Webster's dictionary.
455 \\{webster-mode-map}
456 Use webster-mode-hook for customization."
457 (interactive)
458 (kill-all-local-variables)
459 (setq major-mode 'webster-mode)
460 (setq mode-name "Webster")
461 (use-local-map webster-mode-map)
462 (run-hooks 'webster-mode-hook))
463
464 (if webster-mode-map
465 nil
466 (setq webster-mode-map (make-sparse-keymap))
467 (define-key webster-mode-map "?" 'describe-mode)
468 (define-key webster-mode-map "d" 'webster)
469 (define-key webster-mode-map "e" 'webster-endings)
470 (define-key webster-mode-map "q" 'webster-quit)
471 (define-key webster-mode-map "s" 'webster-spell)
472 (if (string-match "XEmacs" emacs-version)
473 (define-key webster-mode-map 'button2 'webster-xref-word)))
474
475 ;; now in simple.el
476 ;(defun current-word ()
477 ; "Word cursor is over, as a string."
478 ; (save-excursion
479 ; (let (beg end)
480 ; (re-search-backward "\\w" nil 2)
481 ; (re-search-backward "\\b" nil 2)
482 ; (setq beg (point))
483 ; (re-search-forward "\\w*\\b" nil 2)
484 ; (setq end (point))
485 ; (buffer-substring beg end))))
486
487 (defun webster-xref-word (event)
488 "Define the highlighted word under the mouse.
489 Words which are known to have definitions are highlighted when the mouse
490 moves over them. You may define any word by selecting it with the left
491 mouse button and then clicking middle."
492 (interactive "e")
493 (let* ((buffer (event-buffer event))
494 (extent (extent-at (event-point event) buffer 'highlight))
495 text)
496 (cond (extent
497 (setq text (save-excursion
498 (set-buffer buffer)
499 (buffer-substring
500 (extent-start-position extent)
501 (extent-end-position extent)))))
502 ((x-selection-owner-p) ; the selection is in this emacs process.
503 (setq text (x-get-selection)))
504 (t
505 (error "click on a highlighted word to define")))
506 (while (string-match "\\." text)
507 (setq text (concat (substring text 0 (match-beginning 0))
508 (substring text (match-end 0)))))
509 (message "looking up %s..." (upcase text))
510 (goto-char (point-max))
511 (webster text)))