[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master c429657: Merge branch 'feature/integration-of-dictionary-el'
|
From: |
Torsten Hilbrich |
|
Subject: |
master c429657: Merge branch 'feature/integration-of-dictionary-el' |
|
Date: |
Mon, 14 Dec 2020 06:11:58 -0500 (EST) |
branch: master
commit c42965745daa607ac434c56ce19a37a94fb9a2c7
Merge: c6c4e74 62d14e1
Author: Torsten Hilbrich <torsten.hilbrich@gmx.net>
Commit: Torsten Hilbrich <torsten.hilbrich@gmx.net>
Merge branch 'feature/integration-of-dictionary-el'
b6227446d9 Importing dictionary module
658ec3ccee Renamed connection.el
e2ebffdd62 Renamed link.el
723906c444 Removed some compability parts in dictionary
5dc17d73b0 Add :version tag to defcustom statement
49c250b388 Dont't check coding-system-list for existence
99a7e918c8 Don't check for existence of defface
1773b9b687 Dictionary now uses button
329b6a0210 Adding details page for dictionary
837505075c Fix dictionary tooltip mode
2f1e4fbc42 Support nil value for dictionary-server
91ff1c8f7c Move placement of dictionary-tooltip-mouse-event
28fe134971 Remove text property from empty line
7ca331a4f9 Add history of search words to read-string
d5a4da25b0 * lisp/net/dictionary.el: Remove remnants of package
cc5f280378 * lisp/net/dictionary.el: Add lexical-binding:t
09952ce434 Removed useless check for popup-menu
81ebe86d8d Show error message when asking to match for nothing
0044a2e888 * lisp/net/dictionary-connection.el: Add lexical-binding:t
f58443780c * lisp/net/dictionary-connection.el: Remove obsolete Version
54a3964e29 Update GPL version
a557a103cc * lisp/net/dictionary-connection.el: Prefer defsubst
ffa7d6671d * lisp/net/dictionary.el: Prefer defsubst over defmacro
4deb8618e4 * lisp/net/dictionary.el (dictionary-mode): Use setq-local
d30618cbc1 * lisp/net/dictionary.el (dictionary-tooltip-mode): Use ...
a25a12ddaf Use when where else case returns nil
89e9c1686e * lisp/net/dictionary.el (dictionary-display-more-info): ...
d466231c3e A number of docstring fixes
b18217eb87 A number of docstring fixes
ca0de4d1e0 * etc/NEWS: Add entry for dictionary.el
62d14e10f9 * lisp/net/dictionary.el (dictionary-pre-buffer): Unify casing
---
etc/NEWS | 9 +
lisp/net/dictionary-connection.el | 155 +++++
lisp/net/dictionary.el | 1355 +++++++++++++++++++++++++++++++++++++
3 files changed, 1519 insertions(+)
diff --git a/etc/NEWS b/etc/NEWS
index 02edabf..635da2d 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1770,6 +1770,15 @@ using 'M-x customize-themes' or 'load-theme' from your
init file.
Consult the Modus Themes Info manual for more information on the user
options they provide.
+** Dictionary mode
+
+This is a mode for searching a RFC 2229 dictionary
+server. 'dictionary' opens a buffer for starting
+operations. 'dictionary-search' performs a lookup for a word. It also
+supports a 'dictionary-tooltip-mode' which performs a lookup of the
+word under the mouse in 'dictionary-tooltip-dictionary' (which must be
+customized first).
+
* Incompatible Editing Changes in Emacs 28.1
diff --git a/lisp/net/dictionary-connection.el
b/lisp/net/dictionary-connection.el
new file mode 100644
index 0000000..d88c0b4
--- /dev/null
+++ b/lisp/net/dictionary-connection.el
@@ -0,0 +1,155 @@
+;;; dictionary-connection.el --- TCP-based client connection for dictionary
-*- lexical-binding:t -*-
+
+;; Author: Torsten Hilbrich <torsten.hilbrich@gmx.net>
+;; Keywords: network
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; dictionary-connection allows to handle TCP-based connections in
+;; client mode where text-based information are exchanged. There is
+;; special support for handling CR LF (and the usual CR LF . CR LF
+;; terminater).
+
+;;; Code:
+
+(defsubst dictionary-connection-p (connection)
+ "Returns non-nil if CONNECTION is a connection object."
+ (get connection 'connection))
+
+(defsubst dictionary-connection-read-point (connection)
+ "Return the read point of the CONNECTION object."
+ (get connection 'dictionary-connection-read-point))
+
+(defsubst dictionary-connection-process (connection)
+ "Return the process of the CONNECTION object."
+ (get connection 'dictionary-connection-process))
+
+(defsubst dictionary-connection-buffer (connection)
+ "Return the buffer of the CONNECTION object."
+ (get connection 'dictionary-connection-buffer))
+
+(defsubst dictionary-connection-set-read-point (connection point)
+ "Set the read-point for CONNECTION to POINT."
+ (put connection 'dictionary-connection-read-point point))
+
+(defsubst dictionary-connection-set-process (connection process)
+ "Set the process for CONNECTION to PROCESS."
+ (put connection 'dictionary-connection-process process))
+
+(defsubst dictionary-connection-set-buffer (connection buffer)
+ "Set the buffer for CONNECTION to BUFFER."
+ (put connection 'dictionary-connection-buffer buffer))
+
+(defun dictionary-connection-create-data (buffer process point)
+ "Create a new connection data based on BUFFER, PROCESS, and POINT."
+ (let ((connection (make-symbol "connection")))
+ (put connection 'connection t)
+ (dictionary-connection-set-read-point connection point)
+ (dictionary-connection-set-process connection process)
+ (dictionary-connection-set-buffer connection buffer)
+ connection))
+
+(defun dictionary-connection-open (server port)
+ "Open a connection to SERVER at PORT.
+A data structure identifing the connection is returned"
+
+ (let ((process-buffer (generate-new-buffer (format " connection to %s:%s"
+ server
+ port)))
+ (process))
+ (with-current-buffer process-buffer
+ (setq process (open-network-stream "connection" process-buffer
+ server port))
+ (dictionary-connection-create-data process-buffer process (point-min)))))
+
+(defun dictionary-connection-status (connection)
+ "Return the status of the CONNECTION.
+Possible return values are the symbols:
+nil: argument is no connection object
+'none: argument has no connection
+'up: connection is open and buffer is existing
+'down: connection is closed
+'alone: connection is not associated with a buffer"
+ (when (dictionary-connection-p connection)
+ (let ((process (dictionary-connection-process connection))
+ (buffer (dictionary-connection-buffer connection)))
+ (if (not process)
+ 'none
+ (if (not (buffer-live-p buffer))
+ 'alone
+ (if (not (eq (process-status process) 'open))
+ 'down
+ 'up))))))
+
+(defun dictionary-connection-close (connection)
+ "Force closing of the CONNECTION."
+ (when (dictionary-connection-p connection)
+ (let ((buffer (dictionary-connection-buffer connection))
+ (process (dictionary-connection-process connection)))
+ (if process
+ (delete-process process))
+ (if buffer
+ (kill-buffer buffer))
+
+ (dictionary-connection-set-process connection nil)
+ (dictionary-connection-set-buffer connection nil))))
+
+(defun dictionary-connection-send (connection data)
+ "Send DATA to the process stored in CONNECTION."
+ (unless (eq (dictionary-connection-status connection) 'up)
+ (error "Connection is not up"))
+ (with-current-buffer (dictionary-connection-buffer connection)
+ (goto-char (point-max))
+ (dictionary-connection-set-read-point connection (point))
+ (process-send-string (dictionary-connection-process connection) data)))
+
+(defun dictionary-connection-send-crlf (connection data)
+ "Send DATA together with CRLF to the process found in CONNECTION."
+ (dictionary-connection-send connection (concat data "\r\n")))
+
+(defun dictionary-connection-read (connection delimiter)
+ "Read data from CONNECTION until DELIMITER is found inside the buffer."
+ (unless (eq (dictionary-connection-status connection) 'up)
+ (error "Connection is not up"))
+ (let ((case-fold-search nil)
+ match-end)
+ (with-current-buffer (dictionary-connection-buffer connection)
+ (goto-char (dictionary-connection-read-point connection))
+ ;; Wait until there is enough data
+ (while (not (search-forward-regexp delimiter nil t))
+ (accept-process-output (dictionary-connection-process connection) 3)
+ (goto-char (dictionary-connection-read-point connection)))
+ (setq match-end (point))
+ ;; Return the result
+ (let ((result (buffer-substring (dictionary-connection-read-point
connection)
+ match-end)))
+ (dictionary-connection-set-read-point connection match-end)
+ result))))
+
+(defun dictionary-connection-read-crlf (connection)
+ "Read from CONNECTION until a line is completed with CRLF."
+ (dictionary-connection-read connection "\015?\012"))
+
+(defun dictionary-connection-read-to-point (connection)
+ "Read from CONNECTION until an end of entry is encountered.
+End of entry is a decimal point found on a line by itself.
+"
+ (dictionary-connection-read connection "\015?\012[.]\015?\012"))
+
+(provide 'dictionary-connection)
+;;; dictionary-connection.el ends here
diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el
new file mode 100644
index 0000000..0df9d8b
--- /dev/null
+++ b/lisp/net/dictionary.el
@@ -0,0 +1,1355 @@
+;;; dictionary.el --- Client for rfc2229 dictionary servers -*-
lexical-binding:t -*-
+
+;; Author: Torsten Hilbrich <torsten.hilbrich@gmx.net>
+;; Keywords: interface, dictionary
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; dictionary allows you to interact with dictionary servers.
+;; Use M-x customize-group dictionary to modify user settings.
+;;
+;; Main functions for interaction are:
+;; dictionary - opens a new dictionary buffer
+;; dictionary-search - search for the definition of a word
+;;
+;; You can find more information in the README file of the GitHub
+;; repository https://github.com/myrkr/dictionary-el
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'easymenu)
+(require 'custom)
+(require 'dictionary-connection)
+(require 'button)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Stuff for customizing.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar dictionary-current-server)
+(defun dictionary-set-server-var (name value)
+ "Customize helper for setting variable NAME to VALUE.
+The helper is used by customize to check for an active connection
+when setting a variable. The user has then the choice to close
+the existing connection."
+ (if (and (boundp 'dictionary-connection)
+ dictionary-connection
+ (eq (dictionary-connection-status dictionary-connection) 'up)
+ (y-or-n-p
+ (concat "Close existing connection to " dictionary-current-server
"? ")))
+ (dictionary-connection-close dictionary-connection))
+ (set-default name value))
+
+(defgroup dictionary nil
+ "Client for accessing the dictd server based dictionaries"
+ :group 'hypermedia)
+
+(defgroup dictionary-proxy nil
+ "Proxy configuration options for the dictionary client"
+ :group 'dictionary)
+
+(defcustom dictionary-server
+ nil
+ "This server is contacted for searching the dictionary.
+
+You can specify here:
+
+- Automatic: First try localhost, then dict.org after confirmation
+- localhost: Only use localhost
+- dict.org: Only use dict.org
+- User-defined: You can specify your own server here
+"
+ :group 'dictionary
+ :set 'dictionary-set-server-var
+ :type '(choice (const :tag "Automatic" nil)
+ (const :tag "localhost" "localhost")
+ (const :tag "dict.org" "dict.org")
+ (string :tag "User-defined"))
+ :version "28.1")
+
+(defcustom dictionary-port
+ 2628
+ "The port of the dictionary server.
+ This port is propably always 2628 so there should be no need to modify it."
+ :group 'dictionary
+ :set 'dictionary-set-server-var
+ :type 'number
+ :version "28.1")
+
+(defcustom dictionary-identification
+ "dictionary.el emacs lisp dictionary client"
+ "This is the identification string that will be sent to the server."
+ :group 'dictionary
+ :type 'string
+ :version "28.1")
+
+(defcustom dictionary-default-dictionary
+ "*"
+ "The dictionary which is used for searching definitions and matching.
+ * and ! have a special meaning, * search all dictionaries, ! search until
+ one dictionary yields matches."
+ :group 'dictionary
+ :type 'string
+ :version "28.1")
+
+(defcustom dictionary-default-strategy
+ "."
+ "The default strategy for listing matching words."
+ :group 'dictionary
+ :type 'string
+ :version "28.1")
+
+(defcustom dictionary-default-popup-strategy
+ "exact"
+ "The default strategy for listing matching words within a popup window.
+
+The following algorithm (defined by the dictd server) are supported
+by the choice value:
+
+- Exact match
+
+ The found word exactly matches the searched word.
+
+- Similiar sounding
+
+ The found word sounds similiar to the searched word. For this match type
+ the soundex algorithm defined by Donald E. Knuth is used. It will only
+ works with english words and the algorithm is not very reliable (i.e.,
+ the soundex algorithm is quite simple).
+
+- Levenshtein distance one
+
+ The Levenshtein distance is defined as the number of insertions, deletions,
+ or replacements needed to get the searched word. This algorithm searches
+ for word where spelling mistakes are allowed. Levenshtein distance one
+ means there is either a deleted character, an inserted character, or a
+ modified one.
+
+- User choice
+
+ Here you can enter any matching algorithm supported by your
+ dictionary server.
+"
+ :group 'dictionary
+ :type '(choice (const :tag "Exact match" "exact")
+ (const :tag "Similiar sounding" "soundex")
+ (const :tag "Levenshtein distance one" "lev")
+ (string :tag "User choice"))
+ :version "28.1")
+
+(defcustom dictionary-create-buttons
+ t
+ "Create some clickable buttons on top of the window if non-nil."
+ :group 'dictionary
+ :type 'boolean
+ :version "28.1")
+
+(defcustom dictionary-mode-hook
+ nil
+ "Hook run in dictionary mode buffers."
+ :group 'dictionary
+ :type 'hook
+ :version "28.1")
+
+(defcustom dictionary-use-http-proxy
+ nil
+ "Connects via a HTTP proxy using the CONNECT command when not nil."
+ :group 'dictionary-proxy
+ :set 'dictionary-set-server-var
+ :type 'boolean
+ :version "28.1")
+
+(defcustom dictionary-proxy-server
+ "proxy"
+ "The name of the HTTP proxy to use when dictionary-use-http-proxy is set."
+ :group 'dictionary-proxy
+ :set 'dictionary-set-server-var
+ :type 'string
+ :version "28.1")
+
+(defcustom dictionary-proxy-port
+ 3128
+ "The port of the proxy server, used only when dictionary-use-http-proxy is
set."
+ :group 'dictionary-proxy
+ :set 'dictionary-set-server-var
+ :type 'number
+ :version "28.1")
+
+(defcustom dictionary-use-single-buffer
+ nil
+ "Should the dictionary command reuse previous dictionary buffers?"
+ :group 'dictionary
+ :type 'boolean
+ :version "28.1")
+
+(defcustom dictionary-description-open-delimiter
+ ""
+ "The delimiter to display in front of the dictionaries description"
+ :group 'dictionary
+ :type 'string
+ :version "28.1")
+
+(defcustom dictionary-description-close-delimiter
+ ""
+ "The delimiter to display after of the dictionaries description"
+ :group 'dictionary
+ :type 'string
+ :version "28.1")
+
+;; Define only when coding-system-list is available
+(defcustom dictionary-coding-systems-for-dictionaries
+ '( ("mueller" . koi8-r))
+ "Mapping of dictionaries to coding systems.
+Each entry in this list defines the coding system to be used for that
+dictionary. The default coding system for all other dictionaries
+is utf-8"
+ :group 'dictionary
+ :type `(repeat (cons :tag "Association"
+ (string :tag "Dictionary name")
+ (choice :tag "Coding system"
+ :value 'utf-8
+ ,@(mapcar (lambda (x) (list 'const x))
+ (coding-system-list))
+ )))
+ :version "28.1")
+
+(defface dictionary-word-definition-face
+'((((supports (:family "DejaVu Serif")))
+ (:family "DejaVu Serif"))
+ (((type x))
+ (:font "Sans Serif"))
+ (t
+ (:font "default")))
+"The face that is used for displaying the definition of the word."
+:group 'dictionary
+:version "28.1")
+
+(defface dictionary-word-entry-face
+ '((((type x))
+ (:italic t))
+ (((type tty) (class color))
+ (:foreground "green"))
+ (t
+ (:inverse t)))
+ "The face that is used for displaying the initial word entry line."
+ :group 'dictionary
+ :version "28.1")
+
+(defface dictionary-button-face
+ '((t
+ (:bold t)))
+ "The face that is used for displaying buttons."
+ :group 'dictionary
+ :version "28.1")
+
+(defface dictionary-reference-face
+ '((((type x)
+ (class color)
+ (background dark))
+ (:foreground "yellow"))
+ (((type tty)
+ (class color)
+ (background dark))
+ (:foreground "cyan"))
+ (((class color)
+ (background light))
+ (:foreground "blue"))
+ (t
+ (:underline t)))
+
+ "The face that is used for displaying a reference word."
+ :group 'dictionary
+ :version "28.1")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Buffer local variables for storing the current state
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar dictionary-window-configuration
+ nil
+ "The window configuration to be restored upon closing the buffer")
+
+(defvar dictionary-selected-window
+ nil
+ "The currently selected window")
+
+(defvar dictionary-position-stack
+ nil
+ "The history buffer for point and window position")
+
+(defvar dictionary-data-stack
+ nil
+ "The history buffer for functions and arguments")
+
+(defvar dictionary-positions
+ nil
+ "The current positions")
+
+(defvar dictionary-current-data
+ nil
+ "The item that will be placed on stack next time")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Global variables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar dictionary-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (set-keymap-parent map button-buffer-map)
+
+ (define-key map "q" 'dictionary-close)
+ (define-key map "h" 'dictionary-help)
+ (define-key map "s" 'dictionary-search)
+ (define-key map "d" 'dictionary-lookup-definition)
+ (define-key map "D" 'dictionary-select-dictionary)
+ (define-key map "M" 'dictionary-select-strategy)
+ (define-key map "m" 'dictionary-match-words)
+ (define-key map "l" 'dictionary-previous)
+ (define-key map "n" 'forward-button)
+ (define-key map "p" 'backward-button)
+ (define-key map " " 'scroll-up)
+ (define-key map (read-kbd-macro "M-SPC") 'scroll-down)
+ map)
+ "Keymap for the dictionary mode.")
+
+(defvar dictionary-connection
+ nil
+ "The current network connection")
+
+(defvar dictionary-instances
+ 0
+ "The number of open dictionary buffers")
+
+(defvar dictionary-marker
+ nil
+ "Stores the point position while buffer display.")
+
+(defvar dictionary-color-support
+ (condition-case nil
+ (x-display-color-p)
+ (error nil))
+ "Determines if the Emacs has support to display color")
+
+(defvar dictionary-word-history
+ '()
+ "History list of searched word")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Basic function providing startup actions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;###autoload
+(defun dictionary-mode ()
+ "Mode for searching a dictionary.
+This is a mode for searching a dictionary server implementing the
+protocol defined in RFC 2229.
+
+This is a quick reference to this mode describing the default key bindings:
+
+* q close the dictionary buffer
+* h display this help information
+* s ask for a new word to search
+* d search the word at point
+* n or Tab place point to the next link
+* p or S-Tab place point to the prev link
+
+* m ask for a pattern and list all matching words.
+* D select the default dictionary
+* M select the default search strategy
+
+* Return or Button2 visit that link
+"
+
+ (unless (eq major-mode 'dictionary-mode)
+ (cl-incf dictionary-instances))
+
+ (kill-all-local-variables)
+ (buffer-disable-undo)
+ (use-local-map dictionary-mode-map)
+ (setq major-mode 'dictionary-mode)
+ (setq mode-name "Dictionary")
+
+ (setq-local dictionary-data-stack nil)
+ (setq-local dictionary-position-stack nil)
+
+ (make-local-variable 'dictionary-current-data)
+ (make-local-variable 'dictionary-positions)
+
+ (make-local-variable 'dictionary-default-dictionary)
+ (make-local-variable 'dictionary-default-strategy)
+
+ (add-hook 'kill-buffer-hook 'dictionary-close t t)
+ (run-hooks 'dictionary-mode-hook))
+
+;;;###autoload
+(defun dictionary ()
+ "Create a new dictonary buffer and install dictionary-mode."
+ (interactive)
+ (let ((buffer (or (and dictionary-use-single-buffer
+ (get-buffer "*Dictionary*"))
+ (generate-new-buffer "*Dictionary*")))
+ (window-configuration (current-window-configuration))
+ (selected-window (frame-selected-window)))
+
+ (switch-to-buffer-other-window buffer)
+ (dictionary-mode)
+
+ (setq-local dictionary-window-configuration window-configuration)
+ (setq-local dictionary-selected-window selected-window)
+ (dictionary-check-connection)
+ (dictionary-new-buffer)
+ (dictionary-store-positions)
+ (dictionary-store-state 'dictionary-new-buffer nil)))
+
+(defun dictionary-new-buffer ()
+ "Create a new and clean buffer."
+
+ (dictionary-pre-buffer)
+ (dictionary-post-buffer))
+
+(defsubst dictionary-reply-code (reply)
+ "Return the reply code stored in REPLY."
+ (get reply 'reply-code))
+
+(defsubst dictionary-reply (reply)
+ "Return the string reply stored in REPLY."
+ (get reply 'reply))
+
+(defsubst dictionary-reply-list (reply)
+ "Return the reply list stored in REPLY."
+ (get reply 'reply-list))
+
+(defun dictionary-open-server (server)
+ "Opens a new connection to SERVER.
+The connection takes the proxy setting in customization group
+`dictionary-proxy' into account."
+ (let ((wanted 'raw-text)
+ (coding-system nil))
+ (if (member wanted (coding-system-list))
+ (setq coding-system wanted))
+ (let ((coding-system-for-read coding-system)
+ (coding-system-for-write coding-system))
+ (setq dictionary-current-server server)
+ (message "Opening connection to %s:%s" server
+ dictionary-port)
+ (dictionary-connection-close dictionary-connection)
+ (setq dictionary-connection
+ (if dictionary-use-http-proxy
+ (dictionary-connection-open dictionary-proxy-server
+ dictionary-proxy-port)
+ (dictionary-connection-open server dictionary-port)))
+ (set-process-query-on-exit-flag
+ (dictionary-connection-process dictionary-connection)
+ nil)
+
+ (when dictionary-use-http-proxy
+ (message "Proxy CONNECT to %s:%d"
+ dictionary-proxy-server
+ dictionary-proxy-port)
+ (dictionary-send-command (format "CONNECT %s:%d HTTP/1.1"
+ server
+ dictionary-port))
+ ;; just a \r\n combination
+ (dictionary-send-command "")
+
+ ;; read first line of reply
+ (let* ((reply (dictionary-read-reply))
+ (reply-list (dictionary-split-string reply)))
+ ;; first item is protocol, second item is code
+ (unless (= (string-to-number (cadr reply-list)) 200)
+ (error "Bad reply from proxy server %s" reply))
+
+ ;; skip the following header lines until empty found
+ (while (not (equal reply ""))
+ (setq reply (dictionary-read-reply)))))
+
+ (dictionary-check-initial-reply)
+ (dictionary-send-command (concat "client " dictionary-identification))
+ (let ((reply (dictionary-read-reply-and-split)))
+ (message nil)
+ (unless (dictionary-check-reply reply 250)
+ (error "Unknown server answer: %s"
+ (dictionary-reply reply)))))))
+
+(defun dictionary-check-connection ()
+ "Check if there is already a connection open."
+ (if (not (and dictionary-connection
+ (eq (dictionary-connection-status dictionary-connection) 'up)))
+ (if dictionary-server
+ (dictionary-open-server dictionary-server)
+ (let ((server "localhost"))
+ (condition-case nil
+ (dictionary-open-server server)
+ (error
+ (if (y-or-n-p
+ (format "Failed to open server %s, continue with dict.org?"
+ server))
+ (dictionary-open-server "dict.org")
+ (error "Failed automatic server selection, please customize
dictionary-server"))))))))
+
+(defun dictionary-mode-p ()
+ "Return non-nil if current buffer has dictionary-mode."
+ (eq major-mode 'dictionary-mode))
+
+(defun dictionary-ensure-buffer ()
+ "If current buffer is not a dictionary buffer, create a new one."
+ (unless (dictionary-mode-p)
+ (dictionary)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Dealing with closing the buffer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun dictionary-close ()
+ "Close the current dictionary buffer and its connection."
+ (interactive)
+ (if (eq major-mode 'dictionary-mode)
+ (progn
+ (setq major-mode nil)
+ (if (<= (cl-decf dictionary-instances) 0)
+ (dictionary-connection-close dictionary-connection))
+ (let ((configuration dictionary-window-configuration)
+ (selected-window dictionary-selected-window))
+ (kill-buffer (current-buffer))
+ (set-window-configuration configuration)
+ (select-window selected-window)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Helpful functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun dictionary-send-command (string)
+ "Send the command `string' to the network connection."
+ (dictionary-check-connection)
+ ;;;; #####
+ (dictionary-connection-send-crlf dictionary-connection string))
+
+(defun dictionary-read-reply ()
+ "Read the reply line from the server."
+ (let ((answer (dictionary-connection-read-crlf dictionary-connection)))
+ (if (string-match "\r?\n" answer)
+ (substring answer 0 (match-beginning 0))
+ answer)))
+
+(defun dictionary-split-string (string)
+ "Split STRING constiting of space-separated words into elements.
+This function knows about the special meaning of quotes (\")"
+ (let ((list))
+ (while (and string (> (length string) 0))
+ (let ((search "\\(\\s-+\\)")
+ (start 0))
+ (if (= (aref string 0) ?\")
+ (setq search "\\(\"\\)\\s-*"
+ start 1))
+ (if (string-match search string start)
+ (progn
+ (setq list (cons (substring string start (- (match-end 1) 1))
list)
+ string (substring string (match-end 0))))
+ (setq list (cons string list)
+ string nil))))
+ (nreverse list)))
+
+(defun dictionary-read-reply-and-split ()
+ "Reads the reply, splits it into words and returns it."
+ (let ((answer (make-symbol "reply-data"))
+ (reply (dictionary-read-reply)))
+ (let ((reply-list (dictionary-split-string reply)))
+ (put answer 'reply reply)
+ (put answer 'reply-list reply-list)
+ (put answer 'reply-code (string-to-number (car reply-list)))
+ answer)))
+
+(defun dictionary-read-answer ()
+ "Read the complete answer.
+The answer is delimited by a decimal point (.) on a line by itself."
+ (let ((answer (dictionary-connection-read-to-point dictionary-connection))
+ (start 0))
+ (while (string-match "\r\n" answer start)
+ (setq answer (replace-match "\n" t t answer))
+ (setq start (1- (match-end 0))))
+ (setq start 0)
+ (if (string-match "\n\\.\n.*" answer start)
+ (setq answer (replace-match "" t t answer)))
+ answer))
+
+(defun dictionary-check-reply (reply code)
+ "Extract the reply code from REPLY and checks against CODE."
+ (let ((number (dictionary-reply-code reply)))
+ (and (numberp number)
+ (= number code))))
+
+(defun dictionary-coding-system (dictionary)
+ "Select coding system to use for DICTIONARY."
+ (let ((coding-system
+ (or (cdr (assoc dictionary
+ dictionary-coding-systems-for-dictionaries))
+ 'utf-8)))
+ (if (member coding-system (coding-system-list))
+ coding-system
+ nil)))
+
+(defun dictionary-decode-charset (text dictionary)
+ "Convert TEXT from the charset configured for DICTIONARY."
+ (let ((coding-system (dictionary-coding-system dictionary)))
+ (if coding-system
+ (decode-coding-string text coding-system)
+ text)))
+
+(defun dictionary-encode-charset (text dictionary)
+ "Convert TEXT to the charset defined for DICTIONARY."
+ (let ((coding-system (dictionary-coding-system dictionary)))
+ (if coding-system
+ (encode-coding-string text coding-system)
+ text)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Communication functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun dictionary-check-initial-reply ()
+ "Reads the first reply from server and checks it."
+ (let ((reply (dictionary-read-reply-and-split)))
+ (unless (dictionary-check-reply reply 220)
+ (dictionary-connection-close dictionary-connection)
+ (error "Server returned: %s" (dictionary-reply reply)))))
+
+;; Store the current state
+(defun dictionary-store-state (function data)
+ "Stores the current state of operation for later restore.
+The current state consist of a tuple of FUNCTION and DATA. This
+is basically an implementation of a history to return to a
+previous state."
+ (if dictionary-current-data
+ (progn
+ (push dictionary-current-data dictionary-data-stack)
+ (unless dictionary-positions
+ (error "dictionary-store-state called before
dictionary-store-positions"))
+ (push dictionary-positions dictionary-position-stack)))
+ (setq dictionary-current-data
+ (cons function data)))
+
+(defun dictionary-store-positions ()
+ "Stores the current positions for later restore."
+
+ (setq dictionary-positions (cons (point) (window-start))))
+
+;; Restore the previous state
+(defun dictionary-restore-state (&rest ignored)
+ "Restore the state just before the last operation."
+ (let ((position (pop dictionary-position-stack))
+ (data (pop dictionary-data-stack)))
+ (unless position
+ (error "Already at begin of history"))
+ (apply (car data) (cdr data))
+ (set-window-start (selected-window) (cdr position))
+ (goto-char (car position))
+ (setq dictionary-current-data data)))
+
+;; The normal search
+
+(defun dictionary-new-search (args &optional all)
+ "Saves the current state and starts a new search based on ARGS.
+The parameter ARGS is a cons cell where car is the word to search
+and cdr is the dictionary where to search the word in."
+ (interactive)
+ (dictionary-store-positions)
+ (let ((word (car args))
+ (dictionary (cdr args)))
+
+ (if all
+ (setq dictionary dictionary-default-dictionary))
+ (dictionary-ensure-buffer)
+ (dictionary-new-search-internal word dictionary
'dictionary-display-search-result)
+ (dictionary-store-state 'dictionary-new-search-internal
+ (list word dictionary
'dictionary-display-search-result))))
+
+(defun dictionary-new-search-internal (word dictionary function)
+ "Starts a new search for WORD in DICTIONARY after preparing the buffer.
+FUNCTION is the callback which is called for each search result.
+"
+ (dictionary-pre-buffer)
+ (dictionary-do-search word dictionary function))
+
+(defun dictionary-do-search (word dictionary function &optional nomatching)
+ "Searches WORD in DICTIONARY and calls FUNCTION for each result.
+The parameter NOMATCHING controls whether to suppress the display
+of matching words."
+
+ (message "Searching for %s in %s" word dictionary)
+ (dictionary-send-command (concat "define "
+ (dictionary-encode-charset dictionary "")
+ " \""
+ (dictionary-encode-charset word dictionary)
+ "\""))
+
+ (message nil)
+ (let ((reply (dictionary-read-reply-and-split)))
+ (if (dictionary-check-reply reply 552)
+ (progn
+ (unless nomatching
+ (beep)
+ (insert "Word not found, maybe you are looking "
+ "for one of these words\n\n")
+ (dictionary-do-matching word
+ dictionary
+ "."
+ 'dictionary-display-only-match-result)
+ (dictionary-post-buffer)))
+ (if (dictionary-check-reply reply 550)
+ (error "Dictionary \"%s\" is unknown, please select an existing one."
+ dictionary)
+ (unless (dictionary-check-reply reply 150)
+ (error "Unknown server answer: %s" (dictionary-reply reply)))
+ (funcall function reply)))))
+
+(define-button-type 'dictionary-link
+ 'face 'dictionary-reference-face
+ 'action (lambda (button)
+ (let ((func (button-get button 'callback))
+ (data (button-get button 'data))
+ (list-data (button-get button 'list-data)))
+ (if list-data
+ (apply func list-data)
+ (funcall func data)))))
+
+(define-button-type 'dictionary-button
+ :supertype 'dictionary-link
+ 'face 'dictionary-button-face)
+
+(defun dictionary-pre-buffer ()
+ "These commands are executed at the begin of a new buffer."
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (if dictionary-create-buttons
+ (progn
+ (insert-button "[Back]" :type 'dictionary-button
+ 'callback 'dictionary-restore-state
+ 'help-echo (purecopy "Mouse-2 to go backwards in
history"))
+ (insert " ")
+ (insert-button "[Search definition]" :type 'dictionary-button
+ 'callback 'dictionary-search
+ 'help-echo (purecopy "Mouse-2 to look up a new word"))
+ (insert " ")
+
+ (insert-button "[Matching words]" :type 'dictionary-button
+ 'callback 'dictionary-match-words
+ 'help-echo (purecopy "Mouse-2 to find matches for a
pattern"))
+ (insert " ")
+
+ (insert-button "[Quit]" :type 'dictionary-button
+ 'callback 'dictionary-close
+ 'help-echo (purecopy "Mouse-2 to close this window"))
+
+ (insert "\n ")
+
+ (insert-button "[Select dictionary]" :type 'dictionary-button
+ 'callback 'dictionary-select-dictionary
+ 'help-echo (purecopy "Mouse-2 to select dictionary for
future searches"))
+ (insert " ")
+ (insert-button "[Select match strategy]" :type 'dictionary-button
+ 'callback 'dictionary-select-strategy
+ 'help-echo (purecopy "Mouse-2 to select matching
algorithm"))
+ (insert "\n\n")))
+ (setq dictionary-marker (point-marker)))
+
+(defun dictionary-post-buffer ()
+ "These commands are executed at the end of a new buffer."
+ (goto-char dictionary-marker)
+
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t))
+
+(defun dictionary-display-search-result (reply)
+ "This function starts displaying the result in REPLY."
+
+ (let ((number (nth 1 (dictionary-reply-list reply))))
+ (insert number (if (equal number "1")
+ " definition"
+ " definitions")
+ " found\n\n")
+ (setq reply (dictionary-read-reply-and-split))
+ (while (dictionary-check-reply reply 151)
+ (let* ((reply-list (dictionary-reply-list reply))
+ (dictionary (nth 2 reply-list))
+ (description (nth 3 reply-list))
+ (word (nth 1 reply-list)))
+ (dictionary-display-word-entry dictionary description)
+ (setq reply (dictionary-read-answer))
+ (dictionary-display-word-definition reply word dictionary)
+ (setq reply (dictionary-read-reply-and-split))))
+ (dictionary-post-buffer)))
+
+(defun dictionary-display-word-entry (dictionary description)
+ "Insert an explanation for DESCRIPTION from DICTIONARY.
+The DICTIONARY is only used for decoding the bytes to display the DESCRIPTION."
+ (let ((start (point)))
+ (insert "From "
+ dictionary-description-open-delimiter
+ (dictionary-decode-charset description dictionary)
+ dictionary-description-close-delimiter
+ " [" (dictionary-decode-charset dictionary dictionary) "]:")
+ (put-text-property start (point) 'face 'dictionary-word-entry-face)
+ (insert "\n\n")))
+
+(defun dictionary-display-word-definition (reply word dictionary)
+ "Insert the definition in REPLY for the current WORD from DICTIONARY.
+It will replace links which are found in the REPLY and replace
+them with buttons to perform a a new search.
+"
+ (let ((start (point)))
+ (insert (dictionary-decode-charset reply dictionary))
+ (insert "\n\n")
+ (put-text-property start (point) 'face 'dictionary-word-definition-face)
+ (let ((regexp "\\({+\\)\\([^ '\"][^}]*\\)\\(}+\\)"))
+ (goto-char start)
+ (while (< (point) (point-max))
+ (if (search-forward-regexp regexp nil t)
+ (let ((match-start (match-beginning 2))
+ (match-end (match-end 2)))
+ (if dictionary-color-support
+ ;; Compensate for the replacement
+ (let ((brace-match-length (- (match-end 1)
+ (match-beginning 1))))
+ (setq match-start (- (match-beginning 2)
+ brace-match-length))
+ (setq match-end (- (match-end 2)
+ brace-match-length))
+ (replace-match "\\2")))
+ (dictionary-mark-reference match-start match-end
+ 'dictionary-new-search
+ word dictionary))
+ (goto-char (point-max)))))))
+
+(defun dictionary-mark-reference (start end call displayed-word dictionary)
+ "Format the area from START to END as link calling CALL.
+The word is taken from the buffer, the DICTIONARY is given as argument."
+ (let ((word (buffer-substring-no-properties start end)))
+ (while (string-match "\n\\s-*" word)
+ (setq word (replace-match " " t t word)))
+ (while (string-match "[*\"]" word)
+ (setq word (replace-match "" t t word)))
+
+ (unless (equal word displayed-word)
+ (make-button start end :type 'dictionary-link
+ 'callback call
+ 'data (cons word dictionary)
+ 'help-echo (concat "Press Mouse-2 to lookup \""
+ word "\" in \"" dictionary "\"")))))
+
+(defun dictionary-select-dictionary (&rest ignored)
+ "Save the current state and start a dictionary selection."
+ (interactive)
+ (dictionary-ensure-buffer)
+ (dictionary-store-positions)
+ (dictionary-do-select-dictionary)
+ (dictionary-store-state 'dictionary-do-select-dictionary nil))
+
+(defun dictionary-do-select-dictionary (&rest ignored)
+ "The workhorse for doing the dictionary selection."
+
+ (message "Looking up databases and descriptions")
+ (dictionary-send-command "show db")
+
+ (let ((reply (dictionary-read-reply-and-split)))
+ (message nil)
+ (if (dictionary-check-reply reply 554)
+ (error "No dictionary present")
+ (unless (dictionary-check-reply reply 110)
+ (error "Unknown server answer: %s"
+ (dictionary-reply reply)))
+ (dictionary-display-dictionarys))))
+
+(defun dictionary-simple-split-string (string &optional pattern)
+ "Return a list of substrings of STRING which are separated by PATTERN.
+If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
+ (or pattern
+ (setq pattern "[ \f\t\n\r\v]+"))
+ ;; The FSF version of this function takes care not to cons in case
+ ;; of infloop. Maybe we should synch?
+ (let (parts (start 0))
+ (while (string-match pattern string start)
+ (setq parts (cons (substring string start (match-beginning 0)) parts)
+ start (match-end 0)))
+ (nreverse (cons (substring string start) parts))))
+
+(defun dictionary-display-dictionarys ()
+ "Handle the display of all dictionaries existing on the server."
+ (dictionary-pre-buffer)
+ (insert "Please select your default dictionary:\n\n")
+ (dictionary-display-dictionary-line "* \"All dictionaries\"")
+ (dictionary-display-dictionary-line "! \"The first matching dictionary\"")
+ (let* ((reply (dictionary-read-answer))
+ (list (dictionary-simple-split-string reply "\n+")))
+ (mapc 'dictionary-display-dictionary-line list))
+ (dictionary-post-buffer))
+
+(defun dictionary-display-dictionary-line (string)
+ "Display a single dictionary and its description read from STRING."
+ (let* ((list (dictionary-split-string string))
+ (dictionary (car list))
+ (description (cadr list))
+ (translated (dictionary-decode-charset description dictionary)))
+ (if dictionary
+ (if (equal dictionary "--exit--")
+ (insert "(end of default search list)\n")
+ (insert-button (concat dictionary ": " translated) :type
'dictionary-link
+ 'callback 'dictionary-set-dictionary
+ 'data (cons dictionary description)
+ 'help-echo (purecopy "Mouse-2 to select this
dictionary"))
+ (unless (dictionary-special-dictionary dictionary)
+ (insert " ")
+ (insert-button "(Details)" :type 'dictionary-link
+ 'callback 'dictionary-set-dictionary
+ 'list-data (list (cons dictionary description) t)
+ 'help-echo (purecopy "Mouse-2 to get more
information")))
+ (insert "\n")))))
+
+(defun dictionary-set-dictionary (param &optional more)
+ "Select the dictionary which is the car of PARAM as new default."
+
+ (if more
+ (dictionary-display-more-info param)
+ (let ((dictionary (car param)))
+ (setq dictionary-default-dictionary dictionary)
+ (dictionary-restore-state)
+ (message "Dictionary %s has been selected" dictionary))))
+
+(defun dictionary-special-dictionary (name)
+ "Checks whether the special * or ! dictionary are seen in NAME."
+ (or (equal name "*")
+ (equal name "!")))
+
+(defun dictionary-display-more-info (param)
+ "Display the available information on the dictionary found in PARAM."
+
+ (let ((dictionary (car param))
+ (description (cdr param)))
+ (unless (dictionary-special-dictionary dictionary)
+ (dictionary-store-positions)
+ (message "Requesting more information on %s" dictionary)
+ (dictionary-send-command
+ (concat "show info " (dictionary-encode-charset dictionary "")))
+ (let ((reply (dictionary-read-reply-and-split)))
+ (message nil)
+ (if (dictionary-check-reply reply 550)
+ (error "Dictionary \"%s\" does not exist" dictionary)
+ (unless (dictionary-check-reply reply 112)
+ (error "Unknown server answer: %s" (dictionary-reply reply)))
+ (dictionary-pre-buffer)
+ (insert "Information on dictionary: ")
+ (insert-button description :type 'dictionary-link
+ 'callback 'dictionary-set-dictionary
+ 'data (cons dictionary description)
+ 'help-echo (purecopy "Mouse-2 to select this
dictionary"))
+ (insert "\n\n")
+ (setq reply (dictionary-read-answer))
+ (insert reply)
+ (dictionary-post-buffer)))
+
+ (dictionary-store-state 'dictionary-display-more-info dictionary))))
+
+(defun dictionary-select-strategy (&rest ignored)
+ "Save the current state and start a strategy selection."
+ (interactive)
+ (dictionary-ensure-buffer)
+ (dictionary-store-positions)
+ (dictionary-do-select-strategy)
+ (dictionary-store-state 'dictionary-do-select-strategy nil))
+
+(defun dictionary-do-select-strategy ()
+ "The workhorse for doing the strategy selection."
+
+ (message "Request existing matching algorithm")
+ (dictionary-send-command "show strat")
+
+ (let ((reply (dictionary-read-reply-and-split)))
+ (message nil)
+ (if (dictionary-check-reply reply 555)
+ (error "No strategies available")
+ (unless (dictionary-check-reply reply 111)
+ (error "Unknown server answer: %s"
+ (dictionary-reply reply)))
+ (dictionary-display-strategies))))
+
+(defun dictionary-display-strategies ()
+ "Handle the display of all strategies existing on the server."
+ (dictionary-pre-buffer)
+ (insert "Please select your default search strategy:\n\n")
+ (dictionary-display-strategy-line ". \"The servers default\"")
+ (let* ((reply (dictionary-read-answer))
+ (list (dictionary-simple-split-string reply "\n+")))
+ (mapc 'dictionary-display-strategy-line list))
+ (dictionary-post-buffer))
+
+(defun dictionary-display-strategy-line (string)
+ "Display a single strategy found in STRING."
+ (let* ((list (dictionary-split-string string))
+ (strategy (car list))
+ (description (cadr list)))
+ (if strategy
+ (progn
+ (insert-button description :type 'dictionary-link
+ 'callback 'dictionary-set-strategy
+ 'data strategy
+ 'help-echo (purecopy "Mouse-2 to select this matching
algorithm"))
+ (insert "\n")))))
+
+(defun dictionary-set-strategy (strategy &rest ignored)
+ "Select this STRATEGY as new default"
+ (setq dictionary-default-strategy strategy)
+ (dictionary-restore-state)
+ (message "Strategy %s has been selected" strategy))
+
+(defun dictionary-new-matching (word)
+ "Run a new matching search on WORD."
+ (dictionary-ensure-buffer)
+ (dictionary-store-positions)
+ (dictionary-do-matching word dictionary-default-dictionary
+ dictionary-default-strategy
+ 'dictionary-display-match-result)
+ (dictionary-store-state 'dictionary-do-matching
+ (list word dictionary-default-dictionary
+ dictionary-default-strategy
+ 'dictionary-display-match-result)))
+
+(defun dictionary-do-matching (word dictionary strategy function)
+ "Find matches for WORD with STRATEGY in DICTIONARY and displays them with
FUNCTION."
+
+ (message "Lookup matching words for %s in %s using %s"
+ word dictionary strategy)
+ (dictionary-send-command
+ (concat "match " (dictionary-encode-charset dictionary "") " "
+ (dictionary-encode-charset strategy "") " \""
+ (dictionary-encode-charset word "") "\""))
+ (let ((reply (dictionary-read-reply-and-split)))
+ (message nil)
+ (if (dictionary-check-reply reply 550)
+ (error "Dictionary \"%s\" is invalid" dictionary))
+ (if (dictionary-check-reply reply 551)
+ (error "Strategy \"%s\" is invalid" strategy))
+ (if (dictionary-check-reply reply 552)
+ (error (concat
+ "No match for \"%s\" with strategy \"%s\" in "
+ "dictionary \"%s\".")
+ word strategy dictionary))
+ (unless (dictionary-check-reply reply 152)
+ (error "Unknown server answer: %s" (dictionary-reply reply)))
+ (funcall function reply)))
+
+(defun dictionary-display-only-match-result (reply)
+ "Display the results from the current matches in REPLY without the headers."
+
+ (let ((number (nth 1 (dictionary-reply-list reply)))
+ (list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
+ (insert number " matching word" (if (equal number "1") "" "s")
+ " found\n\n")
+ (let ((result nil))
+ (mapc (lambda (item)
+ (let* ((list (dictionary-split-string item))
+ (dictionary (car list))
+ (word (cadr list))
+ (hash (assoc dictionary result)))
+ (if dictionary
+ (if hash
+ (setcdr hash (cons word (cdr hash)))
+ (setq result (cons
+ (cons dictionary (list word))
+ result))))))
+ list)
+ (dictionary-display-match-lines (reverse result)))))
+
+(defun dictionary-display-match-result (reply)
+ "Display the results in REPLY from a match operation."
+ (dictionary-pre-buffer)
+
+ (let ((number (nth 1 (dictionary-reply-list reply)))
+ (list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
+ (insert number " matching word" (if (equal number "1") "" "s")
+ " found\n\n")
+ (let ((result nil))
+ (mapc (lambda (item)
+ (let* ((list (dictionary-split-string item))
+ (dictionary (car list))
+ (word (cadr list))
+ (hash (assoc dictionary result)))
+ (if dictionary
+ (if hash
+ (setcdr hash (cons word (cdr hash)))
+ (setq result (cons
+ (cons dictionary (list word))
+ result))))))
+ list)
+ (dictionary-display-match-lines (reverse result))))
+ (dictionary-post-buffer))
+
+(defun dictionary-display-match-lines (list)
+ "Display a line for each match found in LIST."
+ (mapc (lambda (item)
+ (let ((dictionary (car item))
+ (word-list (cdr item)))
+ (insert "Matches from " dictionary ":\n")
+ (mapc (lambda (word)
+ (setq word (dictionary-decode-charset word dictionary))
+ (insert " ")
+ (insert-button word :type 'dictionary-link
+ 'callback 'dictionary-new-search
+ 'data (cons word dictionary)
+ 'help-echo (purecopy "Mouse-2 to lookup
word"))
+ (insert "\n")) (reverse word-list))
+ (insert "\n")))
+ list))
+
+;; Returns a sensible default for dictionary-search:
+;; - if region is active returns its contents
+;; - otherwise return the word near the point
+(defun dictionary-search-default ()
+ (if (use-region-p)
+ (buffer-substring-no-properties (region-beginning) (region-end))
+ (current-word t)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; User callable commands
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;###autoload
+(defun dictionary-search (word &optional dictionary)
+ "Search the WORD in DICTIONARY if given or in all if nil.
+It presents the selection or word at point as default input and
+allows editing it."
+ (interactive
+ (list (let ((default (dictionary-search-default)))
+ (read-string (if default
+ (format "Search word (%s): " default)
+ "Search word: ")
+ nil 'dictionary-word-history default))
+ (if current-prefix-arg
+ (read-string (if dictionary-default-dictionary
+ (format "Dictionary (%s): "
dictionary-default-dictionary)
+ "Dictionary: ")
+ nil nil dictionary-default-dictionary)
+ dictionary-default-dictionary)))
+
+ ;; if called by pressing the button
+ (unless word
+ (setq word (read-string "Search word: " nil 'dictionary-word-history)))
+ ;; just in case non-interactivly called
+ (unless dictionary
+ (setq dictionary dictionary-default-dictionary))
+ (dictionary-new-search (cons word dictionary)))
+
+;;;###autoload
+(defun dictionary-lookup-definition ()
+ "Unconditionally lookup the word at point."
+ (interactive)
+ (dictionary-new-search (cons (current-word) dictionary-default-dictionary)))
+
+(defun dictionary-previous ()
+ "Go to the previous location in the current buffer."
+ (interactive)
+ (unless (dictionary-mode-p)
+ (error "Current buffer is no dictionary buffer"))
+ (dictionary-restore-state))
+
+(defun dictionary-help ()
+ "Display a little help."
+ (interactive)
+ (describe-function 'dictionary-mode))
+
+;;;###autoload
+(defun dictionary-match-words (&optional pattern &rest ignored)
+ "Search PATTERN in current default dictionary using default strategy."
+ (interactive)
+ ;; can't use interactive because of mouse events
+ (or pattern
+ (setq pattern (read-string "Search pattern: "
+ nil 'dictionary-word-history)))
+ (dictionary-new-matching pattern))
+
+;;;###autoload
+(defun dictionary-mouse-popup-matching-words (event)
+ "Display entries matching the word at the cursor retrieved using EVENT."
+ (interactive "e")
+ (let ((word (save-window-excursion
+ (save-excursion
+ (mouse-set-point event)
+ (current-word)))))
+ (selected-window)
+ (dictionary-popup-matching-words word)))
+
+;;;###autoload
+(defun dictionary-popup-matching-words (&optional word)
+ "Display entries matching WORD or the current word if not given."
+ (interactive)
+ (dictionary-do-matching (or word (current-word) (error "Nothing to search
for"))
+ dictionary-default-dictionary
+ dictionary-default-popup-strategy
+ 'dictionary-process-popup-replies))
+
+(defun dictionary-process-popup-replies (&ignore)
+ (let ((list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
+
+ (let ((result (mapcar (lambda (item)
+ (let* ((list (dictionary-split-string item))
+ (dictionary (car list))
+ (word (dictionary-decode-charset
+ (cadr list) dictionary)))
+ (message word)
+ (if (equal word "")
+ [ "-" nil nil]
+ (vector (concat "[" dictionary "] " word)
+ `(dictionary-new-search
+ '(,word . ,dictionary))
+ t ))))
+
+ list)))
+ (easy-menu-define dictionary-mode-map-menu dictionary-mode-map
+ "Menu used for displaying dictionary popup"
+ (cons "Matching words"
+ `(,@result)))
+ (popup-menu dictionary-mode-map-menu))))
+
+;;; Tooltip support
+
+;; Add a mode indicater named "Dict"
+(defvar dictionary-tooltip-mode
+ nil
+ "Indicates wheather the dictionary tooltip mode is active.")
+(nconc minor-mode-alist '((dictionary-tooltip-mode " Dict")))
+
+(defcustom dictionary-tooltip-dictionary
+ nil
+ "This dictionary to lookup words for tooltips"
+ :group 'dictionary
+ :type '(choice (const :tag "None" nil) string)
+ :version "28.1")
+
+(defun dictionary-definition (word &optional dictionary)
+ (interactive)
+ (unwind-protect
+ (let ((dictionary (or dictionary dictionary-default-dictionary)))
+ (dictionary-do-search word dictionary 'dictionary-read-definition t))
+ nil))
+
+(defun dictionary-read-definition (&ignore)
+ (let ((list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
+ (mapconcat 'identity (cdr list) "\n")))
+
+;;; Tooltip support for GNU Emacs
+(defvar global-dictionary-tooltip-mode
+ nil)
+
+(defun dictionary-word-at-mouse-event (event)
+ (with-current-buffer (tooltip-event-buffer event)
+ (let ((point (posn-point (event-end event))))
+ (if (use-region-p)
+ (when (and (<= (region-beginning) point) (<= point (region-end)))
+ (buffer-substring (region-beginning) (region-end)))
+ (save-excursion
+ (goto-char point)
+ (current-word))))))
+
+(defvar dictionary-tooltip-mouse-event nil
+ "Event that triggered the tooltip mode.")
+
+(defun dictionary-display-tooltip (&ignore)
+ "Search the current word in the `dictionary-tooltip-dictionary'."
+ (interactive "e")
+ (if (and dictionary-tooltip-mode dictionary-tooltip-dictionary)
+ (let ((word (dictionary-word-at-mouse-event
dictionary-tooltip-mouse-event)))
+ (if word
+ (let ((definition
+ (dictionary-definition word
dictionary-tooltip-dictionary)))
+ (if definition
+ (tooltip-show (dictionary-decode-charset definition
+
dictionary-tooltip-dictionary)))))
+ t)
+ nil))
+
+(defun dictionary-tooltip-track-mouse (event)
+ "Called whenever a dictionary tooltip display is about to be triggered."
+ (interactive "e")
+ (tooltip-hide)
+ (when dictionary-tooltip-mode
+ (setq dictionary-tooltip-mouse-event (copy-sequence event))
+ (tooltip-start-delayed-tip)))
+
+(defun dictionary-switch-tooltip-mode (on)
+ "Turn off or on support for the dictionary tooltip mode.
+
+It is normally internally called with 1 to enable support for the
+tooltip mode. The hook function will check the value of the
+variable dictionary-tooltip-mode to decide if some action must be
+taken. When disabling the tooltip mode the value of this variable
+will be set to nil.
+"
+ (interactive)
+ (tooltip-mode on)
+ (if on
+ (add-hook 'tooltip-functions 'dictionary-display-tooltip)
+ (remove-hook 'tooltip-functions 'dictionary-display-tooltip)))
+
+;;;###autoload
+(defun dictionary-tooltip-mode (&optional arg)
+ "Display tooltips for the current word.
+
+This function can be used to enable or disable the tooltip mode
+for the current buffer (based on ARG). If global-tooltip-mode is
+active it will overwrite that mode for the current buffer.
+"
+
+ (interactive "P")
+ (require 'tooltip)
+ (let ((on (if arg
+ (> (prefix-numeric-value arg) 0)
+ (not dictionary-tooltip-mode))))
+ (setq-local dictionary-tooltip-mode on)
+ (setq-local track-mouse on)
+ (make-local-variable 'dictionary-tooltip-mouse-event)
+ (dictionary-switch-tooltip-mode 1)
+ (if on
+ (local-set-key [mouse-movement] 'dictionary-tooltip-track-mouse)
+ (local-set-key [mouse-movement] 'ignore))
+ on))
+
+;;;###autoload
+(defun global-dictionary-tooltip-mode (&optional arg)
+ "Enable/disable dictionary-tooltip-mode for all buffers.
+
+Internally it provides a default for the dictionary-tooltip-mode.
+It can be overwritten for each buffer using dictionary-tooltip-mode.
+
+Note: (global-dictionary-tooltip-mode 0) will not disable the mode
+any buffer where (dictionary-tooltip-mode 1) has been called.
+"
+ (interactive "P")
+ (require 'tooltip)
+ (let ((on (if arg (> (prefix-numeric-value arg) 0)
+ (not global-dictionary-tooltip-mode))))
+ (setq global-dictionary-tooltip-mode on)
+ (setq-default dictionary-tooltip-mode on)
+ (make-local-variable 'dictionary-tooltip-mouse-event)
+ (setq-default track-mouse on)
+ (dictionary-switch-tooltip-mode 1)
+ (if on
+ (global-set-key [mouse-movement] 'dictionary-tooltip-track-mouse)
+ (global-set-key [mouse-movement] 'ignore))
+ on))
+
+(provide 'dictionary)
+;;; dictionary.el ends here