cgit.sxemacs.org Git - packages/blob - xemacs-packages/dictionary/dictionary.el

   1 ;; dictionary.el -- an interface to RFC 2229 dictionary server
   2
   3 ;; Author: Torsten Hilbrich <dictionary@myrkr.in-berlin.de>
   4 ;; Keywords: interface, dictionary
   5 ;; $Id: dictionary.el,v 1.41 2004-10-02 06:39:20 torsten Exp $
   6
   7 ;; This file is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11
  12 ;; This file is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  19 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 ;; Boston, MA 02111-1307, USA.
  21
  22 (eval-when-compile
  23   (require 'cl))
  24
  25 (require 'easymenu)
  26 (require 'custom)
  27 (require 'connection)
  28 (require 'link)
  29
  30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31 ;; Stuff for customizing.
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33
  34 (eval-when-compile
  35   (unless (fboundp 'defface)
  36     (message "Please update your custom.el file: %s"
  37              "http://www.dina.kvl.dk/~abraham/custom/"))
  38
  39   (unless (fboundp 'defgroup)
  40     (defmacro defgroup (&rest ignored))
  41     (defmacro defcustom (var value doc &rest ignored)
  42       (list 'defvar var value doc))))
  43
  44 (defgroup dictionary nil
  45   "Client for accessing the dictd server based dictionaries"
  46   :group 'hypermedia)
  47
  48 (defgroup dictionary-proxy nil
  49   "Proxy configuration options for the dictionary client"
  50   :group 'dictionary)
  51
  52 (defcustom dictionary-server
  53   "dict.org"
  54   "This server is contacted for searching the dictionary"
  55   :group 'dictionary
  56   :type 'string)
  57
  58 (defcustom dictionary-port
  59   2628
  60   "The port of the dictionary server.
  61  This port is propably always 2628 so there should be no need to modify it."
  62   :group 'dictionary
  63   :type 'number)
  64
  65 (defcustom dictionary-identification
  66   "dictionary.el emacs lisp dictionary client"
  67   "This is the identification string that will be sent to the server."
  68   :group 'dictionary
  69   :type 'string)
  70
  71 (defcustom dictionary-default-dictionary
  72   "*"
  73   "The dictionary which is used for searching definitions and matching.
  74  * and ! have a special meaning, * search all dictionaries, ! search until
  75  one dictionary yields matches."
  76   :group 'dictionary
  77   :type 'string)
  78
  79 (defcustom dictionary-default-strategy
  80   "."
  81   "The default strategy for listing matching words."
  82   :group 'dictionary
  83   :type 'string)
  84
  85 (defcustom dictionary-default-popup-strategy
  86   "exact"
  87   "The default strategy for listing matching words within a popup window.
  88
  89 The following algorithm (defined by the dictd server) are supported
  90 by the choice value:
  91
  92 - Exact match
  93
  94   The found word exactly matches the searched word.
  95
  96 - Similiar sounding
  97
  98   The found word sounds similiar to the searched word.  For this match type
  99   the soundex algorithm defined by Donald E. Knuth is used.  It will only
 100   works with english words and the algorithm is not very reliable (i.e.,
 101   the soundex algorithm is quite simple).
 102
 103 - Levenshtein distance one
 104
 105   The Levenshtein distance is defined as the number of insertions, deletions,
 106   or replacements needed to get the searched word.  This algorithm searches
 107   for word where spelling mistakes are allowed.  Levenshtein distance one
 108   means there is either a deleted character, an inserted character, or a
 109   modified one.
 110
 111 - User choice
 112
 113   Here you can enter any matching algorithm supported by your
 114   dictionary server.
 115 "
 116   :group 'dictionary
 117   :type '(choice (const :tag "Exact match" "exact")
 118                  (const :tag "Similiar sounding" "soundex")
 119                  (const :tag "Levenshtein distance one" "lev")
 120                  (string :tag "User choice")))
 121
 122 (defcustom dictionary-create-buttons
 123   t
 124   "Create some clickable buttons on top of the window if non-nil."
 125   :group 'dictionary
 126   :type 'boolean)
 127
 128 (defcustom dictionary-mode-hook
 129   nil
 130   "Hook run in dictionary mode buffers."
 131   :group 'dictionary
 132   :type 'hook)
 133
 134 (defcustom dictionary-use-http-proxy
 135   nil
 136   "Connects via a HTTP proxy using the CONNECT command when not nil."
 137   :group 'dictionary-proxy
 138   :type 'boolean)
 139
 140 (defcustom dictionary-proxy-server
 141   "proxy"
 142   "The name of the HTTP proxy to use when dictionary-use-http-proxy is set."
 143   :group 'dictionary-proxy
 144   :type 'string)
 145
 146 (defcustom dictionary-proxy-port
 147   3128
 148   "The port of the proxy server, used only when dictionary-use-http-proxy is set."
 149   :group 'dictionary-proxy
 150   :type 'number)
 151
 152 (defcustom dictionary-use-single-buffer
 153   nil
 154   "Should the dictionary command reuse previous dictionary buffers?"
 155   :group 'dictionary
 156   :type 'boolean)
 157
 158 (defcustom dictionary-description-open-delimiter
 159   ""
 160   "The delimiter to display in front of the dictionaries description"
 161   :group 'dictionary
 162   :type 'string)
 163
 164 (defcustom dictionary-description-close-delimiter
 165   ""
 166   "The delimiter to display after of the dictionaries description"
 167   :group 'dictionary
 168   :type 'string)
 169
 170 ;; Define only when coding-system-list is available
 171 (when (fboundp 'coding-system-list)
 172   (defcustom dictionary-coding-systems-for-dictionaries
 173     '( ("mueller" . koi8-r))
 174     "Mapping of dictionaries to coding systems.
 175  Each entry in this list defines the coding system to be used for that
 176  dictionary.  The default coding system for all other dictionaries
 177  is utf-8"
 178     :group 'dictionary
 179     :type `(repeat (cons :tag "Association"
 180                          (string :tag "Dictionary name")
 181                          (choice :tag "Coding system"
 182                                  :value 'utf-8
 183                                  ,@(mapcar (lambda (x) (list 'const x))
 184                                            (coding-system-list))
 185                                  ))))
 186
 187   )
 188
 189 (if (fboundp 'defface)
 190     (progn
 191
 192       (defface dictionary-word-entry-face
 193         '((((type x))
 194            (:italic t))
 195           (((type tty) (class color))
 196            (:foreground "green"))
 197           (t
 198            (:inverse t)))
 199         "The face that is used for displaying the initial word entry line."
 200         :group 'dictionary)
 201
 202       (defface dictionary-button-face
 203         '((t
 204            (:bold t)))
 205         "The face that is used for displaying buttons."
 206         :group 'dictionary)
 207
 208       (defface dictionary-reference-face
 209         '((((type x)
 210             (class color)
 211             (background dark))
 212            (:foreground "yellow"))
 213           (((type tty)
 214             (class color)
 215             (background dark))
 216            (:foreground "cyan"))
 217           (((class color)
 218             (background light))
 219            (:foreground "blue"))
 220           (t
 221            (:underline t)))
 222
 223         "The face that is used for displaying a reference word."
 224         :group 'dictionary)
 225
 226       )
 227
 228   ;; else
 229   (copy-face 'italic 'dictionary-word-entry-face)
 230   (copy-face 'bold 'dictionary-button-face)
 231   (copy-face 'default 'dictionary-reference-face)
 232   (set-face-foreground 'dictionary-reference-face "blue"))
 233
 234 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 235 ;; Buffer local variables for storing the current state
 236 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 237
 238 (defvar dictionary-window-configuration
 239   nil
 240   "The window configuration to be restored upon closing the buffer")
 241
 242 (defvar dictionary-selected-window
 243   nil
 244   "The currently selected window")
 245
 246 (defvar dictionary-position-stack
 247   nil
 248   "The history buffer for point and window position")
 249
 250 (defvar dictionary-data-stack
 251   nil
 252   "The history buffer for functions and arguments")
 253
 254 (defvar dictionary-positions
 255   nil
 256   "The current positions")
 257
 258 (defvar dictionary-current-data
 259   nil
 260   "The item that will be placed on stack next time")
 261
 262 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 263 ;; Global variables
 264 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 265 (defvar dictionary-mode-map
 266   nil
 267   "Keymap for dictionary mode")
 268
 269 (defvar dictionary-connection
 270   nil
 271   "The current network connection")
 272
 273 (defvar dictionary-instances
 274   0
 275   "The number of open dictionary buffers")
 276
 277 (defvar dictionary-marker
 278   nil
 279   "Stores the point position while buffer display.")
 280
 281 (defvar dictionary-color-support
 282   (condition-case nil
 283       (x-display-color-p)
 284     (error nil))
 285   "Stores the point position while buffer display.")
 286
 287 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 288 ;; Basic function providing startup actions
 289 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 290
 291 ;;;###autoload
 292 (defun dictionary-mode ()
 293   "This is a mode for searching a dictionary server implementing
 294  the protocol defined in RFC 2229.
 295
 296  This is a quick reference to this mode describing the default key bindings:
 297
 298  * q close the dictionary buffer
 299  * h display this help information
 300  * s ask for a new word to search
 301  * d search the word at point
 302  * n or Tab place point to the next link
 303  * p or S-Tab place point to the prev link
 304
 305  * m ask for a pattern and list all matching words.
 306  * D select the default dictionary
 307  * M select the default search strategy
 308
 309  * Return or Button2 visit that link
 310  * M-Return or M-Button2 search the word beneath link in all dictionaries
 311  "
 312
 313   (unless (eq major-mode 'dictionary-mode)
 314     (incf dictionary-instances))
 315
 316   (kill-all-local-variables)
 317   (buffer-disable-undo)
 318   (use-local-map dictionary-mode-map)
 319   (setq major-mode 'dictionary-mode)
 320   (setq mode-name "Dictionary")
 321
 322   (make-local-variable 'dictionary-data-stack)
 323   (setq dictionary-data-stack nil)
 324   (make-local-variable 'dictionary-position-stack)
 325   (setq dictionary-position-stack nil)
 326
 327   (make-local-variable 'dictionary-current-data)
 328   (make-local-variable 'dictionary-positions)
 329
 330   (make-local-variable 'dictionary-default-dictionary)
 331   (make-local-variable 'dictionary-default-strategy)
 332
 333   (make-local-hook 'kill-buffer-hook)
 334   (add-hook 'kill-buffer-hook 'dictionary-close t t)
 335   (run-hooks 'dictionary-mode-hook))
 336
 337 ;;;###autoload
 338 (defun dictionary ()
 339   "Create a new dictonary buffer and install dictionary-mode"
 340   (interactive)
 341   (let ((buffer (or (and dictionary-use-single-buffer
 342                          (get-buffer "*Dictionary buffer*"))
 343                     (generate-new-buffer "*Dictionary buffer*")))
 344         (window-configuration (current-window-configuration))
 345         (selected-window (frame-selected-window)))
 346
 347     (switch-to-buffer-other-window buffer)
 348     (dictionary-mode)
 349
 350     (make-local-variable 'dictionary-window-configuration)
 351     (make-local-variable 'dictionary-selected-window)
 352     (setq dictionary-window-configuration window-configuration)
 353     (setq dictionary-selected-window selected-window)
 354     (dictionary-check-connection)
 355     (dictionary-new-buffer)
 356     (dictionary-store-positions)
 357     (dictionary-store-state 'dictionary-new-buffer nil)))
 358
 359 (defun dictionary-new-buffer (&rest ignore)
 360   "Create a new and clean buffer"
 361
 362   (dictionary-pre-buffer)
 363   (dictionary-post-buffer))
 364
 365
 366 (unless dictionary-mode-map
 367   (setq dictionary-mode-map (make-sparse-keymap))
 368   (suppress-keymap dictionary-mode-map)
 369
 370   (define-key dictionary-mode-map "q" 'dictionary-close)
 371   (define-key dictionary-mode-map "h" 'dictionary-help)
 372   (define-key dictionary-mode-map "s" 'dictionary-search)
 373   (define-key dictionary-mode-map "d" 'dictionary-lookup-definition)
 374   (define-key dictionary-mode-map "D" 'dictionary-select-dictionary)
 375   (define-key dictionary-mode-map "M" 'dictionary-select-strategy)
 376   (define-key dictionary-mode-map "m" 'dictionary-match-words)
 377   (define-key dictionary-mode-map "l" 'dictionary-previous)
 378
 379   (if (and (string-match "GNU" (emacs-version))
 380            (not window-system))
 381       (define-key dictionary-mode-map [9] 'dictionary-next-link)
 382     (define-key dictionary-mode-map [tab] 'dictionary-next-link))
 383
 384   ;; shift-tabs normally is supported on window systems only, but
 385   ;; I do not enforce it
 386   (define-key dictionary-mode-map [(shift tab)] 'dictionary-prev-link)
 387
 388   (define-key dictionary-mode-map "n" 'dictionary-next-link)
 389   (define-key dictionary-mode-map "p" 'dictionary-prev-link)
 390
 391   (define-key dictionary-mode-map " " 'scroll-up)
 392   (define-key dictionary-mode-map [(meta space)] 'scroll-down)
 393
 394   (link-initialize-keymap dictionary-mode-map))
 395
 396 (defun dictionary-check-connection ()
 397   "Check if there is already a connection open"
 398   (if (not (and dictionary-connection
 399                 (eq (connection-status dictionary-connection) 'up)))
 400       (let ((wanted 'raw-text)
 401             (coding-system nil))
 402         (if (and (fboundp 'coding-system-list)
 403                  (member wanted (coding-system-list)))
 404             (setq coding-system wanted))
 405         (let ((coding-system-for-read coding-system)
 406               (coding-system-for-write coding-system))
 407           (message "Opening connection to %s:%s" dictionary-server
 408                    dictionary-port)
 409           (connection-close dictionary-connection)
 410           (setq dictionary-connection
 411                 (if dictionary-use-http-proxy
 412                     (connection-open dictionary-proxy-server
 413                                      dictionary-proxy-port)
 414                   (connection-open dictionary-server dictionary-port)))
 415
 416           (when dictionary-use-http-proxy
 417             (message "Proxy CONNECT to %s:%d"
 418                      dictionary-proxy-server
 419                      dictionary-proxy-port)
 420             (dictionary-send-command (format "CONNECT %s:%d HTTP/1.1"
 421                                              dictionary-server
 422                                              dictionary-port))
 423             ;; just a \r\n combination
 424             (dictionary-send-command "")
 425
 426             ;; read first line of reply
 427             (let* ((reply (dictionary-read-reply))
 428                    (reply-list (dictionary-split-string reply)))
 429               ;; first item is protocol, second item is code
 430               (unless (= (string-to-number (cadr reply-list)) 200)
 431                 (error "Bad reply from proxy server %s" reply))
 432
 433               ;; skip the following header lines until empty found
 434               (while (not (equal reply ""))
 435                 (setq reply (dictionary-read-reply)))))
 436
 437           (dictionary-check-initial-reply)
 438           (dictionary-send-command (concat "client " dictionary-identification))
 439           (let ((reply (dictionary-read-reply-and-split)))
 440             (message nil)
 441             (unless (dictionary-check-reply reply 250)
 442               (error "Unknown server answer: %s"
 443                      (dictionary-reply reply))))))))
 444
 445 (defun dictionary-mode-p ()
 446   "Return non-nil if current buffer has dictionary-mode"
 447   (eq major-mode 'dictionary-mode))
 448
 449 (defun dictionary-ensure-buffer ()
 450   "If current buffer is not a dictionary buffer, create a new one."
 451   (unless (dictionary-mode-p)
 452     (dictionary)))
 453
 454 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 455 ;; Dealing with closing the buffer
 456 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 457
 458 (defun dictionary-close (&rest ignore)
 459   "Close the current dictionary buffer and its connection"
 460   (interactive)
 461   (if (eq major-mode 'dictionary-mode)
 462       (progn
 463         (setq major-mode nil)
 464         (if (<= (decf dictionary-instances) 0)
 465             (connection-close dictionary-connection))
 466         (let ((configuration dictionary-window-configuration)
 467               (selected-window dictionary-selected-window))
 468           (kill-buffer (current-buffer))
 469           (set-window-configuration configuration)
 470           (select-window selected-window)))))
 471
 472 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 473 ;; Helpful functions
 474 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 475
 476 (defun dictionary-send-command (string)
 477   "Send the command `string' to the network connection."
 478   (dictionary-check-connection)
 479   ;;;; #####
 480   (connection-send-crlf dictionary-connection string))
 481
 482 (defun dictionary-read-reply ()
 483   "Read the reply line from the server"
 484   (let ((answer (connection-read-crlf dictionary-connection)))
 485     (if (string-match "\r?\n" answer)
 486         (substring answer 0 (match-beginning 0))
 487       answer)))
 488
 489 (defun dictionary-split-string (string)
 490   "Split the `string' constiting of space separated words into elements.
 491 This function knows about the special meaning of quotes (\")"
 492   (let ((list))
 493     (while (and string (> (length string) 0))
 494       (let ((search "\\(\\s-+\\)")
 495             (start 0))
 496         (if (= (aref string 0) ?\")
 497             (setq search "\\(\"\\)\\s-*"
 498                   start 1))
 499         (if (string-match search string start)
 500             (progn
 501               (setq list (cons (substring string start (- (match-end 1) 1)) list)
 502                     string (substring string (match-end 0))))
 503           (setq list (cons string list)
 504                 string nil))))
 505     (nreverse list)))
 506
 507 (defun dictionary-read-reply-and-split ()
 508   "Read the reply, split it into words and return it"
 509   (let ((answer (make-symbol "reply-data"))
 510         (reply (dictionary-read-reply)))
 511     (let ((reply-list (dictionary-split-string reply)))
 512       (put answer 'reply reply)
 513       (put answer 'reply-list reply-list)
 514       (put answer 'reply-code (string-to-number (car reply-list)))
 515       answer)))
 516
 517 (defmacro dictionary-reply-code (reply)
 518   "Return the reply code stored in `reply'."
 519   (list 'get reply ''reply-code))
 520
 521 (defmacro dictionary-reply (reply)
 522   "Return the string reply stored in `reply'."
 523   (list 'get reply ''reply))
 524
 525 (defmacro dictionary-reply-list (reply)
 526   "Return the reply list stored in `reply'."
 527   (list 'get reply ''reply-list))
 528
 529 (defun dictionary-read-answer ()
 530   "Read an answer delimited by a . on a single line"
 531   (let ((answer (connection-read-to-point dictionary-connection))
 532         (start 0))
 533     (while (string-match "\r\n" answer start)
 534       (setq answer (replace-match "\n" t t answer))
 535       (setq start (1- (match-end 0))))
 536     (setq start 0)
 537     (if (string-match "\n\\.\n.*" answer start)
 538         (setq answer (replace-match "" t t answer)))
 539     answer))
 540
 541 (defun dictionary-check-reply (reply code)
 542   "Check if the reply in `reply' has the `code'."
 543   (let ((number (dictionary-reply-code reply)))
 544     (and (numberp number)
 545          (= number code))))
 546
 547 (defun dictionary-coding-system (dictionary)
 548   "Select coding system to use for that dictionary"
 549   (when (boundp 'dictionary-coding-systems-for-dictionaries)
 550     (let ((coding-system
 551            (or (cdr (assoc dictionary
 552                            dictionary-coding-systems-for-dictionaries))
 553                'utf-8)))
 554       (if (member coding-system (coding-system-list))
 555           coding-system
 556         nil))))
 557
 558 (defun dictionary-decode-charset (text dictionary)
 559   "Convert the text from the charset defined by the dictionary given."
 560   (let ((coding-system (dictionary-coding-system dictionary)))
 561     (if coding-system
 562         (decode-coding-string text coding-system)
 563       text)))
 564
 565 (defun dictionary-encode-charset (text dictionary)
 566   "Convert the text to the charset defined by the dictionary given."
 567   (let ((coding-system (dictionary-coding-system dictionary)))
 568     (if coding-system
 569         (encode-coding-string text coding-system)
 570       text)))
 571
 572 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 573 ;; Communication functions
 574 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 575
 576 (defun dictionary-check-initial-reply ()
 577   "Read the first reply from server and check it."
 578   (let ((reply (dictionary-read-reply-and-split)))
 579     (unless (dictionary-check-reply reply 220)
 580       (connection-close dictionary-connection)
 581       (error "Server returned: %s" (dictionary-reply reply)))))
 582
 583 ;; Store the current state
 584 (defun dictionary-store-state (function data)
 585   "Stores the current state of operation for later restore."
 586
 587   (if dictionary-current-data
 588       (progn
 589         (push dictionary-current-data dictionary-data-stack)
 590         (unless dictionary-positions
 591           (error "dictionary-store-state called before dictionary-store-positions"))
 592         (push dictionary-positions dictionary-position-stack)))
 593   (setq dictionary-current-data
 594         (cons function data)))
 595
 596 (defun dictionary-store-positions ()
 597   "Stores the current positions for later restore."
 598
 599   (setq dictionary-positions (cons (point) (window-start))))
 600
 601 ;; Restore the previous state
 602 (defun dictionary-restore-state (&rest ignored)
 603   "Restore the state just before the last operation"
 604   (let ((position (pop dictionary-position-stack))
 605         (data (pop dictionary-data-stack)))
 606     (unless position
 607       (error "Already at begin of history"))
 608     (apply (car data) (cdr data))
 609     (set-window-start (selected-window) (cdr position))
 610     (goto-char (car position))
 611     (setq dictionary-current-data data)))
 612
 613 ;; The normal search
 614
 615 (defun dictionary-new-search (args &optional all)
 616   "Save the current state and start a new search"
 617   (interactive)
 618   (dictionary-store-positions)
 619   (let ((word (car args))
 620         (dictionary (cdr args)))
 621
 622     (if all
 623         (setq dictionary dictionary-default-dictionary))
 624     (dictionary-ensure-buffer)
 625     (dictionary-new-search-internal word dictionary 'dictionary-display-search-result)
 626     (dictionary-store-state 'dictionary-new-search-internal
 627                             (list word dictionary 'dictionary-display-search-result))))
 628
 629 (defun dictionary-new-search-internal (word dictionary function)
 630   "Starts a new search after preparing the buffer"
 631   (dictionary-pre-buffer)
 632   (dictionary-do-search word dictionary function))
 633
 634 (defun dictionary-do-search (word dictionary function &optional nomatching)
 635   "The workhorse for doing the search"
 636
 637   (message "Searching for %s in %s" word dictionary)
 638   (dictionary-send-command (concat "define " dictionary " \""
 639                                    (dictionary-encode-charset word dictionary)
 640                                    "\""))
 641
 642   (message nil)
 643   (let ((reply (dictionary-read-reply-and-split)))
 644     (if (dictionary-check-reply reply 552)
 645         (progn
 646           (unless nomatching
 647             (beep)
 648             (insert "Word not found, maybe you are looking "
 649                     "for one of these words\n\n")
 650             (dictionary-do-matching word
 651                                     dictionary
 652                                     "."
 653                                     'dictionary-display-only-match-result)
 654             (dictionary-post-buffer)))
 655       (if (dictionary-check-reply reply 550)
 656           (error "Dictionary \"%s\" is unknown, please select an existing one."
 657                  dictionary)
 658         (unless (dictionary-check-reply reply 150)
 659           (error "Unknown server answer: %s" (dictionary-reply reply)))
 660         (funcall function reply)))))
 661
 662 (defun dictionary-pre-buffer ()
 663   "These commands are executed at the begin of a new buffer"
 664   (toggle-read-only 0)
 665   (erase-buffer)
 666   (if dictionary-create-buttons
 667       (progn
 668         (link-insert-link "[Back]" 'dictionary-button-face
 669                           'dictionary-restore-state nil
 670                           "Mouse-2 to go backwards in history")
 671         (insert " ")
 672         (link-insert-link "[Search Definition]"
 673                           'dictionary-button-face
 674                           'dictionary-search nil
 675                           "Mouse-2 to look up a new word")
 676         (insert "         ")
 677
 678         (link-insert-link "[Matching words]"
 679                           'dictionary-button-face
 680                           'dictionary-match-words nil
 681                           "Mouse-2 to find matches for a pattern")
 682         (insert "        ")
 683
 684         (link-insert-link "[Quit]" 'dictionary-button-face
 685                           'dictionary-close nil
 686                           "Mouse-2 to close this window")
 687
 688         (insert "\n       ")
 689
 690         (link-insert-link "[Select Dictionary]"
 691                           'dictionary-button-face
 692                           'dictionary-select-dictionary nil
 693                           "Mouse-2 to select dictionary for future searches")
 694         (insert "         ")
 695         (link-insert-link "[Select Match Strategy]"
 696                           'dictionary-button-face
 697                           'dictionary-select-strategy nil
 698                           "Mouse-2 to select matching algorithm")
 699         (insert "\n\n")))
 700   (setq dictionary-marker (point-marker)))
 701
 702 (defun dictionary-post-buffer ()
 703   "These commands are executed at the end of a new buffer"
 704   (goto-char dictionary-marker)
 705
 706   (set-buffer-modified-p nil)
 707   (toggle-read-only 1))
 708
 709 (defun dictionary-display-search-result (reply)
 710   "This function starts displaying the result starting with the `reply'."
 711
 712   (let ((number (nth 1 (dictionary-reply-list reply))))
 713     (insert number (if (equal number "1")
 714                        " definition"
 715                      " definitions")
 716             " found\n\n")
 717     (setq reply (dictionary-read-reply-and-split))
 718     (while (dictionary-check-reply reply 151)
 719       (let* ((reply-list (dictionary-reply-list reply))
 720              (dictionary (nth 2 reply-list))
 721              (description (nth 3 reply-list))
 722              (word (nth 1 reply-list)))
 723         (dictionary-display-word-entry word dictionary description)
 724         (setq reply (dictionary-read-answer))
 725         (dictionary-display-word-definition reply word dictionary)
 726         (setq reply (dictionary-read-reply-and-split))))
 727     (dictionary-post-buffer)))
 728
 729 (defun dictionary-display-word-entry (word dictionary description)
 730   "Insert an explanation for the current definition."
 731   (let ((start (point)))
 732     (insert "From "
 733             dictionary-description-open-delimiter
 734             (dictionary-decode-charset description dictionary)
 735             dictionary-description-close-delimiter
 736             " [" (dictionary-decode-charset dictionary dictionary) "]:"
 737             "\n\n")
 738     (put-text-property start (point) 'face 'dictionary-word-entry-face)))
 739
 740 (defun dictionary-display-word-definition (reply word dictionary)
 741   "Insert the definition for the current word"
 742   (let ((start (point)))
 743     (insert (dictionary-decode-charset reply dictionary))
 744     (insert "\n\n")
 745     (let ((regexp "\\({+\\)\\([^ '\"][^}]*\\)\\(}+\\)"))
 746       (goto-char start)
 747       (while (< (point) (point-max))
 748         (if (search-forward-regexp regexp nil t)
 749             (let ((match-start (match-beginning 1))
 750                   (match-end (match-end 2)))
 751               (if dictionary-color-support
 752                   (progn
 753                     (replace-match "\\2")
 754                     ;; Compensate for the replacement
 755                     (let ((brace-match-length (- (match-end 1)
 756                                                  (match-beginning 1))))
 757                       (setq match-start (- (match-beginning 2)
 758                                            brace-match-length))
 759                       (setq match-end (- (match-end 2)
 760                                          brace-match-length)))))
 761               (dictionary-mark-reference match-start match-end
 762                                          'dictionary-new-search
 763                                          word dictionary))
 764           (goto-char (point-max)))))))
 765
 766 (defun dictionary-mark-reference (start end call displayed-word dictionary)
 767   "Format the area from `start' to `end' as link calling `call'.
 768 The word is taken from the buffer, the `dictionary' is given as argument."
 769   (let ((word (buffer-substring-no-properties start end)))
 770     (while (string-match "\n\\s-*" word)
 771       (setq word (replace-match " " t t word)))
 772     (while (string-match "[*\"]" word)
 773       (setq word (replace-match "" t t word)))
 774
 775     (unless (equal word displayed-word)
 776       (link-create-link start end 'dictionary-reference-face
 777                         call (cons word dictionary)
 778                         (concat "Press Mouse-2 to lookup \""
 779                                 word "\" in \"" dictionary "\"")))))
 780
 781 (defun dictionary-select-dictionary (&rest ignored)
 782   "Save the current state and start a dictionary selection"
 783   (interactive)
 784   (dictionary-ensure-buffer)
 785   (dictionary-store-positions)
 786   (dictionary-do-select-dictionary)
 787   (dictionary-store-state 'dictionary-do-select-dictionary nil))
 788
 789 (defun dictionary-do-select-dictionary (&rest ignored)
 790   "The workhorse for doing the dictionary selection."
 791
 792   (message "Looking up databases and descriptions")
 793   (dictionary-send-command "show db")
 794
 795   (let ((reply (dictionary-read-reply-and-split)))
 796     (message nil)
 797     (if (dictionary-check-reply reply 554)
 798         (error "No dictionary present")
 799       (unless (dictionary-check-reply reply 110)
 800         (error "Unknown server answer: %s"
 801                (dictionary-reply reply)))
 802       (dictionary-display-dictionarys reply))))
 803
 804 (defun dictionary-simple-split-string (string &optional pattern)
 805   "Return a list of substrings of STRING which are separated by PATTERN.
 806 If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
 807   (or pattern
 808       (setq pattern "[ \f\t\n\r\v]+"))
 809   ;; The FSF version of this function takes care not to cons in case
 810   ;; of infloop.  Maybe we should synch?
 811   (let (parts (start 0))
 812     (while (string-match pattern string start)
 813       (setq parts (cons (substring string start (match-beginning 0)) parts)
 814             start (match-end 0)))
 815     (nreverse (cons (substring string start) parts))))
 816
 817 (defun dictionary-display-dictionarys (reply)
 818   "Handle the display of all dictionaries existing on the server"
 819   (dictionary-pre-buffer)
 820   (insert "Please select your default dictionary:\n\n")
 821   (dictionary-display-dictionary-line "* \"All dictionaries\"")
 822   (dictionary-display-dictionary-line "! \"The first matching dictionary\"")
 823   (let* ((reply (dictionary-read-answer))
 824          (list (dictionary-simple-split-string reply "\n+")))
 825     (mapcar 'dictionary-display-dictionary-line list))
 826   (dictionary-post-buffer))
 827
 828 (defun dictionary-display-dictionary-line (string)
 829   "Display a single dictionary"
 830   (let* ((list (dictionary-split-string string))
 831          (dictionary (car list))
 832          (description (cadr list))
 833          (translated (dictionary-decode-charset description dictionary)))
 834     (if dictionary
 835         (progn
 836           (link-insert-link (concat dictionary ": " translated)
 837                             'dictionary-reference-face
 838                             'dictionary-set-dictionary
 839                             (cons dictionary description)
 840                             "Mouse-2 to select this dictionary")
 841           (insert "\n")))))
 842
 843 (defun dictionary-set-dictionary (param &optional more)
 844   "Select this dictionary as new default"
 845
 846   (if more
 847       (dictionary-display-more-info param)
 848     (let ((dictionary (car param)))
 849       (setq dictionary-default-dictionary dictionary)
 850       (dictionary-restore-state)
 851       (message "Dictionary %s has been selected" dictionary))))
 852
 853 (defun dictionary-display-more-info (param)
 854   "Display the available information on the dictionary"
 855
 856   (let ((dictionary (car param))
 857         (description (cdr param)))
 858     (unless (or (equal dictionary "*")
 859                 (equal dictionary "!"))
 860       (dictionary-store-positions)
 861       (message "Requesting more information on %s" dictionary)
 862       (dictionary-send-command (concat "show info " dictionary))
 863       (let ((reply (dictionary-read-reply-and-split)))
 864         (message nil)
 865         (if (dictionary-check-reply reply 550)
 866             (error "Dictionary \"%s\" not existing" dictionary)
 867           (unless (dictionary-check-reply reply 112)
 868             (error "Unknown server answer: %s" (dictionary-reply reply)))
 869           (dictionary-pre-buffer)
 870           (insert "Information on dictionary: ")
 871           (link-insert-link description 'dictionary-reference-face
 872                             'dictionary-set-dictionary
 873                             (cons dictionary description)
 874                             "Mouse-2 to select this dictionary")
 875           (insert "\n\n")
 876           (setq reply (dictionary-read-answer))
 877           (insert reply)
 878           (dictionary-post-buffer)))
 879
 880       (dictionary-store-state 'dictionary-display-more-info dictionary))))
 881
 882 (defun dictionary-select-strategy (&rest ignored)
 883   "Save the current state and start a strategy selection"
 884   (interactive)
 885   (dictionary-ensure-buffer)
 886   (dictionary-store-positions)
 887   (dictionary-do-select-strategy)
 888   (dictionary-store-state 'dictionary-do-select-strategy nil))
 889
 890 (defun dictionary-do-select-strategy ()
 891   "The workhorse for doing the strategy selection."
 892
 893   (message "Request existing matching algorithm")
 894   (dictionary-send-command "show strat")
 895
 896   (let ((reply (dictionary-read-reply-and-split)))
 897     (message nil)
 898     (if (dictionary-check-reply reply 555)
 899         (error "No strategies available")
 900       (unless (dictionary-check-reply reply 111)
 901         (error "Unknown server answer: %s"
 902                (dictionary-reply reply)))
 903       (dictionary-display-strategies reply))))
 904
 905 (defun dictionary-display-strategies (reply)
 906   "Handle the display of all strategies existing on the server"
 907   (dictionary-pre-buffer)
 908   (insert "Please select your default search strategy:\n\n")
 909   (dictionary-display-strategy-line ". \"The servers default\"")
 910   (let* ((reply (dictionary-read-answer))
 911          (list (dictionary-simple-split-string reply "\n+")))
 912     (mapcar 'dictionary-display-strategy-line list))
 913   (dictionary-post-buffer))
 914
 915 (defun dictionary-display-strategy-line (string)
 916   "Display a single strategy"
 917   (let* ((list (dictionary-split-string string))
 918          (strategy (car list))
 919          (description (cadr list)))
 920     (if strategy
 921         (progn
 922           (link-insert-link description 'dictionary-reference-face
 923                             'dictionary-set-strategy strategy
 924                             "Mouse-2 to select this matching algorithm")
 925           (insert "\n")))))
 926
 927 (defun dictionary-set-strategy (strategy &rest ignored)
 928   "Select this strategy as new default"
 929   (setq dictionary-default-strategy strategy)
 930   (dictionary-restore-state)
 931   (message "Strategy %s has been selected" strategy))
 932
 933 (defun dictionary-new-matching (word)
 934   "Run a new matching search on `word'."
 935   (dictionary-ensure-buffer)
 936   (dictionary-store-positions)
 937   (dictionary-do-matching word dictionary-default-dictionary
 938                           dictionary-default-strategy
 939                           'dictionary-display-match-result)
 940   (dictionary-store-state 'dictionary-do-matching
 941                           (list word dictionary-default-dictionary
 942                                 dictionary-default-strategy
 943                                 'dictionary-display-match-result)))
 944
 945 (defun dictionary-do-matching (word dictionary strategy function)
 946   "Ask the server about matches to `word' and display it."
 947
 948   (message "Lookup matching words for %s in %s using %s"
 949            word dictionary strategy)
 950   (dictionary-send-command
 951    (concat "match " dictionary " "
 952            strategy " \"" (dictionary-encode-charset word "") "\""))
 953   (let ((reply (dictionary-read-reply-and-split)))
 954     (message nil)
 955     (if (dictionary-check-reply reply 550)
 956         (error "Dictionary \"%s\" is invalid" dictionary))
 957     (if (dictionary-check-reply reply 551)
 958         (error "Strategy \"%s\" is invalid" strategy))
 959     (if (dictionary-check-reply reply 552)
 960         (error (concat
 961                 "No match for \"%s\" with strategy \"%s\" in "
 962                 "dictionary \"%s\".")
 963                word strategy dictionary))
 964     (unless (dictionary-check-reply reply 152)
 965       (error "Unknown server answer: %s" (dictionary-reply reply)))
 966     (funcall function reply)))
 967
 968 (defun dictionary-display-only-match-result (reply)
 969   "Display the results from the current matches without the headers."
 970
 971   (let ((number (nth 1 (dictionary-reply-list reply)))
 972         (list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
 973     (insert number " matching word" (if (equal number "1") "" "s")
 974             " found\n\n")
 975     (let ((result nil))
 976       (mapcar (lambda (item)
 977                 (let* ((list (dictionary-split-string item))
 978                        (dictionary (car list))
 979                        (word (cadr list))
 980                        (hash (assoc dictionary result)))
 981                   (if dictionary
 982                       (if hash
 983                           (setcdr hash (cons word (cdr hash)))
 984                         (setq result (cons
 985                                       (cons dictionary (list word))
 986                                       result))))))
 987               list)
 988       (dictionary-display-match-lines (reverse result)))))
 989
 990 (defun dictionary-display-match-result (reply)
 991   "Display the results from the current matches."
 992   (dictionary-pre-buffer)
 993
 994   (let ((number (nth 1 (dictionary-reply-list reply)))
 995         (list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
 996     (insert number " matching word" (if (equal number "1") "" "s")
 997             " found\n\n")
 998     (let ((result nil))
 999       (mapcar (lambda (item)
1000                 (let* ((list (dictionary-split-string item))
1001                        (dictionary (car list))
1002                        (word (cadr list))
1003                        (hash (assoc dictionary result)))
1004                   (if dictionary
1005                       (if hash
1006                           (setcdr hash (cons word (cdr hash)))
1007                         (setq result (cons
1008                                       (cons dictionary (list word))
1009                                       result))))))
1010               list)
1011       (dictionary-display-match-lines (reverse result))))
1012   (dictionary-post-buffer))
1013
1014 (defun dictionary-display-match-lines (list)
1015   "Display the match lines."
1016   (mapcar (lambda (item)
1017             (let ((dictionary (car item))
1018                   (word-list (cdr item)))
1019               (insert "Matches from " dictionary ":\n")
1020               (mapcar (lambda (word)
1021                         (setq word (dictionary-decode-charset word dictionary))
1022                         (insert "  ")
1023                         (link-insert-link word
1024                                           'dictionary-reference-face
1025                                           'dictionary-new-search
1026                                           (cons word dictionary)
1027                                           "Mouse-2 to lookup word")
1028                         (insert "\n")) (reverse word-list))
1029               (insert "\n")))
1030           list))
1031
1032 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1033 ;; User callable commands
1034 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1035
1036 ;;;###autoload
1037 (defun dictionary-search (word &optional dictionary)
1038   "Search the `word' in `dictionary' if given or in all if nil.
1039 It presents the word at point as default input and allows editing it."
1040   (interactive
1041    (list (read-string "Search word: " (current-word))
1042          (if current-prefix-arg
1043              (read-string "Dictionary: " dictionary-default-dictionary)
1044            dictionary-default-dictionary)))
1045
1046   ;; if called by pressing the button
1047   (unless word
1048     (setq word (read-string "Search word: ")))
1049   ;; just in case non-interactivly called
1050   (unless dictionary
1051     (setq dictionary dictionary-default-dictionary))
1052   (dictionary-new-search (cons word dictionary)))
1053
1054 ;;;###autoload
1055 (defun dictionary-lookup-definition ()
1056   "Unconditionally lookup the word at point."
1057   (interactive)
1058   (dictionary-new-search (cons (current-word) dictionary-default-dictionary)))
1059
1060 (defun dictionary-previous ()
1061   "Go to the previous location in the current buffer"
1062   (interactive)
1063   (unless (dictionary-mode-p)
1064     (error "Current buffer is no dictionary buffer"))
1065   (dictionary-restore-state))
1066
1067 (defun dictionary-next-link ()
1068   "Place the cursor to the next link."
1069   (interactive)
1070   (let ((pos (link-next-link)))
1071     (if pos
1072         (goto-char pos)
1073       (error "There is no next link"))))
1074
1075 (defun dictionary-prev-link ()
1076   "Place the cursor to the previous link."
1077   (interactive)
1078   (let ((pos (link-prev-link)))
1079     (if pos
1080         (goto-char pos)
1081       (error "There is no previous link"))))
1082
1083 (defun dictionary-help ()
1084   "Display a little help"
1085   (interactive)
1086   (describe-function 'dictionary-mode))
1087
1088 ;;;###autoload
1089 (defun dictionary-match-words (&optional pattern &rest ignored)
1090   "Search `pattern' in current default dictionary using default strategy."
1091   (interactive)
1092   ;; can't use interactive because of mouse events
1093   (or pattern
1094       (setq pattern (read-string "Search pattern: ")))
1095   (dictionary-new-matching pattern))
1096
1097 ;;;###autoload
1098 (defun dictionary-mouse-popup-matching-words (event)
1099   "Display entries matching the word at the cursor"
1100   (interactive "e")
1101   (let ((word (save-window-excursion
1102                 (save-excursion
1103                   (mouse-set-point event)
1104                   (current-word)))))
1105     (selected-window)
1106     (dictionary-popup-matching-words word)))
1107
1108 ;;;###autoload
1109 (defun dictionary-popup-matching-words (&optional word)
1110   "Display entries matching the word at the point"
1111   (interactive)
1112   (unless (functionp 'popup-menu)
1113     (error "Sorry, popup menus are not available in this emacs version"))
1114   (dictionary-do-matching (or word (current-word))
1115                           dictionary-default-dictionary
1116                           dictionary-default-popup-strategy
1117                           'dictionary-process-popup-replies))
1118
1119 (defun dictionary-process-popup-replies (reply)
1120   (let ((number (nth 1 (dictionary-reply-list reply)))
1121         (list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
1122
1123     (let ((result (mapcar (lambda (item)
1124                             (let* ((list (dictionary-split-string item))
1125                                    (dictionary (car list))
1126                                    (word (dictionary-decode-charset
1127                                           (cadr list) dictionary)))
1128                               (message word)
1129                               (if (equal word "")
1130                                   [ "-" nil nil]
1131                                 (vector (concat "[" dictionary "] " word)
1132                                         `(dictionary-new-search
1133                                           '(,word . ,dictionary))
1134                                         t ))))
1135
1136                           list)))
1137       (let ((menu (make-sparse-keymap 'dictionary-popup)))
1138
1139         (easy-menu-define dictionary-mode-map-menu dictionary-mode-map
1140           "Menu used for displaying dictionary popup"
1141           (cons "Matching words"
1142                 `(,@result)))
1143         (popup-menu dictionary-mode-map-menu)))))
1144
1145 ;;; Tooltip support
1146
1147 ;; Common to GNU Emacs and XEmacs
1148
1149 ;; Add a mode indicater named "Dict"
1150 (defvar dictionary-tooltip-mode
1151   nil
1152   "Indicates wheather the dictionary tooltip mode is active")
1153 (nconc minor-mode-alist '((dictionary-tooltip-mode " Dict")))
1154
1155 (defcustom dictionary-tooltip-dictionary
1156   nil
1157   "This dictionary to lookup words for tooltips"
1158   :group 'dictionary
1159   :type 'string)
1160
1161 (defun dictionary-definition (word &optional dictionary)
1162   (interactive)
1163   (unwind-protect
1164       (let ((dictionary (or dictionary dictionary-default-dictionary)))
1165         (dictionary-do-search word dictionary 'dictionary-read-definition t))
1166     nil))
1167
1168 (defun dictionary-read-definition (reply)
1169   (let ((list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
1170     (mapconcat 'identity (cdr list) "\n")))
1171
1172 (defconst dictionary-use-balloon-help
1173   (eval-when-compile
1174     (condition-case nil
1175         (require 'balloon-help)
1176       (error nil))))
1177
1178 (if dictionary-use-balloon-help
1179     (progn
1180
1181 ;; The following definition are only valid for XEmacs with balloon-help
1182
1183 (defvar dictionary-balloon-help-position nil
1184   "Current position to lookup word")
1185
1186 (defun dictionary-balloon-help-store-position (event)
1187   (setq dictionary-balloon-help-position (event-point event)))
1188
1189 (defun dictionary-balloon-help-description (&rest extent)
1190   "Get the word from the cursor and lookup it"
1191   (if dictionary-balloon-help-position
1192       (let ((word (save-window-excursion
1193                     (save-excursion
1194                       (goto-char dictionary-balloon-help-position)
1195                       (current-word)))))
1196         (let ((definition
1197                 (dictionary-definition word dictionary-tooltip-dictionary)))
1198           (if definition
1199               (dictionary-decode-charset definition
1200                                          dictionary-tooltip-dictionary)
1201             nil)))))
1202
1203 (defvar dictionary-balloon-help-extent nil
1204   "The extent for activating the balloon help")
1205
1206 (make-variable-buffer-local 'dictionary-balloon-help-extent)
1207
1208 ;;;###autoload
1209 (defun dictionary-tooltip-mode (&optional arg)
1210    "Display tooltips for the current word"
1211    (interactive "P")
1212    (let* ((on (if arg
1213                   (> (prefix-numeric-value arg) 0)
1214                 (not dictionary-tooltip-mode))))
1215      (make-local-variable 'dictionary-tooltip-mode)
1216      (if on
1217          ;; active mode
1218          (progn
1219            ;; remove old extend
1220            (if dictionary-balloon-help-extent
1221                (delete-extent dictionary-balloon-help-extent))
1222            ;; create new one
1223            (setq dictionary-balloon-help-extent (make-extent (point-min)
1224                                                              (point-max)))
1225            (set-extent-property dictionary-balloon-help-extent
1226                                 'balloon-help
1227                                 'dictionary-balloon-help-description)
1228            (set-extent-property dictionary-balloon-help-extent
1229                                 'start-open nil)
1230            (set-extent-property dictionary-balloon-help-extent
1231                                 'end-open nil)
1232            (add-hook 'mouse-motion-hook
1233                      'dictionary-balloon-help-store-position))
1234
1235        ;; deactivate mode
1236        (if dictionary-balloon-help-extent
1237            (delete-extent dictionary-balloon-help-extent))
1238        (remove-hook 'mouse-motion-hook
1239                      'dictionary-balloon-help-store-position))
1240      (setq dictionary-tooltip-mode on)
1241      (balloon-help-minor-mode on)))
1242
1243 ) ;; end of XEmacs part
1244
1245 (defvar global-dictionary-tooltip-mode
1246   nil)
1247
1248 ;;; Tooltip support for GNU Emacs
1249 (defun dictionary-display-tooltip (event)
1250   "Search the current word in the `dictionary-tooltip-dictionary'."
1251   (interactive "e")
1252   (if dictionary-tooltip-dictionary
1253       (let ((word (save-window-excursion
1254                     (save-excursion
1255                       (mouse-set-point event)
1256                       (current-word)))))
1257         (let ((definition
1258                 (dictionary-definition word dictionary-tooltip-dictionary)))
1259           (if definition
1260               (tooltip-show
1261                (dictionary-decode-charset definition
1262                                           dictionary-tooltip-dictionary)))
1263           t))
1264     nil))
1265
1266 ;;;###autoload
1267 (defun dictionary-tooltip-mode (&optional arg)
1268   "Display tooltips for the current word"
1269   (interactive "P")
1270   (require 'tooltip)
1271   (let ((on (if arg
1272                 (> (prefix-numeric-value arg) 0)
1273               (not dictionary-tooltip-mode))))
1274     (make-local-variable 'dictionary-tooltip-mode)
1275     (setq dictionary-tooltip-mode on)
1276     ;; make sure that tooltip is still (global available) even is on
1277     ;; if nil
1278     (tooltip-mode 1)
1279     (add-hook 'tooltip-hook 'dictionary-display-tooltip)
1280     (make-local-variable 'track-mouse)
1281     (setq track-mouse on)))
1282
1283 ;;;###autoload
1284 (defun global-dictionary-tooltip-mode (&optional arg)
1285   "Enable/disable dictionary-tooltip-mode for all buffers"
1286   (interactive "P")
1287   (require 'tooltip)
1288   (let* ((on (if arg (> (prefix-numeric-value arg) 0)
1289               (not global-dictionary-tooltip-mode)))
1290          (hook-fn (if on 'add-hook 'remove-hook)))
1291     (setq global-dictionary-tooltip-mode on)
1292     (tooltip-mode 1)
1293     (funcall hook-fn 'tooltip-hook 'dictionary-display-tooltip)
1294     (setq-default dictionary-tooltip-mode on)
1295     (setq-default track-mouse on)))
1296
1297 ) ;; end of GNU Emacs part
1298
1299 (provide 'dictionary)
1300