edictc.el

   1 ;;; edictc.el --- DICT client for Emacs
   2
   3 ;; Author: Vaidheeswaran C <vaidheeswaran.chinnaraju@gmail.com>
   4 ;; Keywords:
   5
   6 ;; This file is not part of GNU Emacs.
   7
   8 ;; This program is free software: you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;; Code:
  24
  25 ;;; Dependencies
  26
  27 (eval-when-compile
  28   (require 'cl))
  29
  30 (require 'thingatpt)
  31 (require 'tabulated-list)
  32 (require 'outline)
  33 (require 'easymenu)
  34 (require 'help-mode)
  35
  36 ;;; Regex for parsing command responses
  37
  38 (defvar edictc-ws-re
  39   `(or " " "\t"))
  40
  41 (defvar edictc-dqtext-re
  42   `(one-or-more (not (in "\"" "\\" control))))
  43
  44 (defvar edictc-quoted-pair-re
  45   '(and "\\" anything))
  46
  47 (defvar edictc-dqstring-re
  48   `(and "\"" (zero-or-more (or ,edictc-dqtext-re ,edictc-quoted-pair-re)) "\""))
  49
  50 (defvar edictc-sqtext-re
  51   `(one-or-more (not (in "'" "\\" control))))
  52
  53 (defvar edictc-sqstring-re
  54   `(and "'" (zero-or-more (or ,edictc-dqtext-re ,edictc-quoted-pair-re)) "'"))
  55
  56 (defvar edictc-atom-re
  57   `(one-or-more (not (in " " "\t" "\"" "'" "\\"))))
  58
  59 (defvar edictc-string-re
  60   `(zero-or-more (or ,edictc-dqstring-re ,edictc-sqstring-re ,edictc-quoted-pair-re)))
  61
  62 (defvar edictc-word-re
  63   `(zero-or-more (or ,edictc-atom-re ,edictc-string-re)))
  64
  65 (defvar edictc-description-re
  66   `(zero-or-more (or ,edictc-word-re ,edictc-ws-re)))
  67
  68 (defvar edictc-text-re
  69   `(zero-or-more (or ,edictc-word-re ,edictc-ws-re)))
  70
  71 (defvar edictc-status-re
  72   '(and (group-n 1 (and (zero-or-more "0")
  73                         (in (?1 . ?9))
  74                         (repeat 2 digit)))
  75         (zero-or-more " ")
  76         (group-n 2 (zero-or-more anything))))
  77
  78 (defvar edictc-msg-atom-re
  79   '(one-or-more (not (in " " control "<" ">" "." "\\"))))
  80
  81 (defvar edictc-capabilities-re
  82   `(and "<" ,edictc-msg-atom-re (zero-or-more (and "." ,edictc-msg-atom-re)) ">"))
  83
  84 (defvar edictc-local-part-re
  85   `(and ,edictc-msg-atom-re (zero-or-more (and "." ,edictc-msg-atom-re))))
  86
  87 (defvar edictc-domain-re
  88   `(and ,edictc-msg-atom-re (zero-or-more (and "." ,edictc-msg-atom-re))))
  89
  90 (defvar edictc-spec-re
  91   `(and ,edictc-local-part-re "@" ,edictc-domain-re))
  92
  93 (defvar edictc-msg-id-re
  94   `(and "<" ,edictc-spec-re ">"))
  95
  96 (defvar edictc-param-text-re
  97   `(or ,edictc-atom-re ,edictc-dqstring-re))
  98
  99 (defvar edictc-banner-re
 100   `(and "220"
 101         " " (group-n 1 ,edictc-text-re)
 102         " " (group-n 2 (zero-or-one ,edictc-capabilities-re))
 103         " " (group-n 3 ,edictc-msg-id-re)
 104         ))
 105
 106 (defvar edictc-database-description-re
 107   `(and (group-n 1 (or ,edictc-atom-re ,edictc-dqstring-re))
 108         (one-or-more " ")
 109         (group-n 2 (or ,edictc-atom-re ,edictc-dqstring-re))))
 110
 111 (defvar edictc-strategy-description-re
 112   `(and (group-n 1 (or ,edictc-atom-re ,edictc-dqstring-re))
 113         (one-or-more " ")
 114         (group-n 2 (or ,edictc-atom-re ,edictc-dqstring-re))))
 115
 116 (defvar edictc-word-definition-re
 117   `(and (group-n 1 (or ,edictc-atom-re ,edictc-dqstring-re))
 118         (one-or-more " ")
 119         (group-n 2 (or ,edictc-atom-re ,edictc-dqstring-re))
 120         (one-or-more " ")
 121         (group-n 3 (or ,edictc-atom-re ,edictc-dqstring-re))))
 122
 123 (defvar edictc-match-description-re
 124   `(and (group-n 1 (or ,edictc-atom-re ,edictc-dqstring-re))
 125         (one-or-more " ")
 126         (group-n 2 (or ,edictc-atom-re ,edictc-dqstring-re))))
 127
 128 ;;; Global Constants
 129
 130 (defconst edictc-port 2628)
 131
 132 (defvar edictc-process-name "edictc")
 133
 134 (defvar edictc-output-buffer-name "edictc")
 135 (defvar edictc-debug-buffer-name "edictc debug")
 136
 137 ;;; User Customization
 138
 139 (defgroup edictc nil
 140   "Emacs DICT client."
 141   :link '(custom-manual "(emacs)Highlight Interactively")
 142   :group 'processes)
 143
 144 (defcustom edictc-servers
 145   `(("DICT Dev. Group" :server "dict.org" :about "http://www.dict.org/")
 146     ("GNU Dico" :server "dicoweb.gnu.org.ua" :about "http://dicoweb.gnu.org.ua")
 147     ("FreeDict" :server "dict.freedict.org" :about "http://freedict.org/dict")
 148     ("localhost" :server "localhost"))
 149   "List of DICT servers."
 150   :type '(repeat (cons (string :tag "Dict server name")
 151                        (plist :options ((:server         string)
 152                                         (:port           integer)
 153                                         (:about          string)
 154                                         (:user-name      string)
 155                                         (:password       string)))))
 156   :group 'edictc)
 157
 158 (defcustom edictc-server (caar edictc-servers)
 159   "Default DICT Server."
 160   :type '(choice (const :tag "None" nil)
 161                  (string :tag "DICT Server"))
 162   :group 'edictc)
 163
 164 ;; "*" ; retrieve matches from ALL databases that provide a match.
 165 ;; "!" ; retrieve matches from database that provides the first match.
 166
 167 (defcustom edictc-default-database "*"
 168   "Default Database."
 169   :type '(choice (const :tag "Retrieve from ALL databases" "*")
 170                  (const :tag "Retrieve match from the first databases" "!"))
 171   :group 'edictc)
 172
 173 (defcustom edictc-default-strategy "prefix"
 174   "Default Match strategy."
 175   :type '(choice (const :tag "Exact match" "exact")
 176                  (const :tag "Prefix" "prefix")
 177                  (const :tag "Server default" "."))
 178   :group 'edictc)
 179
 180 ;;; DICT protocol handling
 181
 182 (defvar edictc-process nil)
 183 (put 'edictc-process 'permanent-local t)
 184
 185 (defvar edictc-process-list nil)
 186
 187 (defstruct (edictc-database (:type list) :named)
 188   handle
 189   description)
 190
 191 (defstruct (edictc-strategy (:type list) :named)
 192   handle
 193   description)
 194
 195 ;; (defstruct (edictc-connection (:type list) :named)
 196 ;;   server
 197 ;;   port
 198 ;;   about
 199 ;;   user-name
 200 ;;   password
 201
 202 ;;   process
 203 ;;   process-buffer
 204
 205 ;;   state
 206
 207 ;;   receivef
 208 ;;   filterf
 209
 210 ;;   server-string
 211 ;;   server-capabilities
 212 ;;   msg-id
 213
 214 ;;   databases
 215 ;;   strategies
 216
 217 ;;   database
 218 ;;   strategy
 219
 220 ;;   num-responses
 221 ;;   responses
 222
 223 ;;   cmdq-head
 224 ;;   cmdq-tail
 225
 226 ;;   owner-buffer
 227
 228 ;;   output-buffer
 229 ;;   debug-buffer
 230 ;;   )
 231
 232 (defstruct (edictc-word-definition (:type list) :named)
 233   word
 234   db-handle
 235   db-description
 236   text)
 237
 238 (defstruct (edictc-word-match (:type list) :named)
 239   db-handle
 240   text)
 241
 242 ;;;; Debugging
 243
 244 (defcustom edictc-debug t
 245   "Enable debugging"
 246   :type '(choice (const :tag "none" nil)
 247                  (const :tag "all" t))
 248   :group 'edictc)
 249
 250 (defun edictc-get-create-debug-buffer (ep)
 251   (let ((buffer (process-get ep :debug-buffer)))
 252     (unless (buffer-live-p buffer)
 253       (setq buffer (generate-new-buffer edictc-debug-buffer-name))
 254       (process-put ep :debug-buffer buffer)
 255       (with-current-buffer buffer
 256         (setq-local edictc-process ep)
 257         (edictc-mode)))
 258     buffer))
 259
 260 (defun edictc--debug (ep &rest args)
 261   (if quit-flag
 262       (error "Interrupted!"))
 263   (if (eq edictc-debug t)
 264       (with-current-buffer (edictc-get-create-debug-buffer ep)
 265         (goto-char (point-max))
 266         (insert
 267          (format "%s -> %s\n" (process-name (process-get ep :process))
 268                  (apply 'format args))))))
 269
 270 (defsubst edictc-debug (ep &rest args)
 271   (if quit-flag
 272       (let* ((proc (process-get ep :process)))
 273         ;; The user hit C-g, honor it!  Some things can get in an
 274         ;; incredibly tight loop (chunked encoding)
 275         (if proc
 276             (progn
 277               (set-process-sentinel proc nil)
 278               (set-process-filter proc nil)))
 279         (error "Transfer interrupted!")))
 280   (apply 'edictc--debug ep args))
 281
 282 ;;; DICT Commands
 283
 284 (defun edictc-send-command (ep &optional request)
 285   (when (eq (process-get ep :state) 'READY)
 286     (unless request
 287       (setq request (caar (process-get ep :cmdq-head))))
 288
 289     (when request
 290       (let* ((string (edictc-request->string request))
 291              (tag (edictc-request->tag request))
 292              (command (concat string "\r\n")))
 293         (process-put ep :state tag)
 294         (message "[%s] <- %s" (process-get ep :server-nick)
 295                  string)
 296         (edictc-debug ep "COMMAND SENT: %S" string)
 297         (process-send-string (process-get ep :process) command)))))
 298
 299 (defun edictc-queue-command (ep request &rest request-context)
 300   (let ((r request))
 301     (while r
 302       (when (stringp (car r))
 303         (setcar r (edictc-quote-parameter (car r))))
 304       (setq r (cdr r))))
 305
 306   (let* ((send-immediate nil)
 307          (elt (cons request request-context)))
 308     (edictc-debug ep "STATE: %s" (process-get ep :state))
 309     (edictc-debug ep "COMMAND QUEUED: %s, %S"
 310                   (edictc-request->string request)
 311                   request-context)
 312     (if (derived-mode-p 'edictc-debug-mode)
 313         ;; In debug mode, send the command immediately.
 314         (edictc-send-command ep request)
 315       ;; Otherwise, queue the command.
 316       (cond
 317        ((process-get ep :cmdq-head)
 318         ;; There is a pending command.
 319         (edictc-debug ep "COMMAND HEAD before ENQUEUE: %S" (process-get ep :cmdq-head))
 320         (edictc-debug ep "COMMAND TAIL before ENQUEUE: %S" (process-get ep :cmdq-tail))
 321         (process-put ep :cmdq-tail
 322               (setcdr (process-get ep :cmdq-tail) (list elt))))
 323        (t
 324         ;; This is the only outstanding command
 325         (process-put ep :cmdq-head (list elt))
 326         (process-put ep :cmdq-tail
 327               (process-get ep :cmdq-head))
 328         ;; Send it immediately.
 329         (setq send-immediate t)))
 330       (edictc-debug ep "COMMAND HEAD after ENQUEUE: %S" (process-get ep :cmdq-head))
 331       (edictc-debug ep "COMMAND TAIL after ENQUEUE: %S" (process-get ep :cmdq-tail))
 332       (edictc-debug ep "STATE: %s SEND IMMEDIATE: %s"
 333                     (process-get ep :state) send-immediate)
 334       (when (and (eq (process-get ep :state) 'READY) send-immediate)
 335         ;; Initial handshake is done and there is no pending command.
 336         (edictc-send-command ep)))))
 337
 338 (defun edictc-response-type (status-code)
 339   (or (and (numberp status-code) (> status-code 99) (< status-code 600)
 340            (assoc-default (/ status-code 100)
 341                           '((1 . positive-preliminary)
 342                             (2 . positive)
 343                             (3 . positive-intermediate)
 344                             (4 . transient-negative)
 345                             (5 . permanent-negative))))
 346       'invalid))
 347
 348 (defun edictc-unqueue-command (ep)
 349   (assert (numberp (process-get ep :state)))
 350   (let* ((gratis-response (= (process-get ep :state) 220))
 351          (response-type (edictc-response-type (process-get ep :state))))
 352
 353     (when (memq  response-type '(positive permanent-negative))
 354       ;; Ready for next command.
 355       (process-put ep :state 'READY))
 356
 357     (when (and (null gratis-response)
 358                (eq (process-get ep :state) 'READY))
 359       ;; A command is now finished.  Unqueue it from the pending list.
 360       (assert (process-get ep :cmdq-head))
 361       (let* ((elt (pop (process-get ep :cmdq-head)))
 362              (last-request (car elt))
 363              (last-command (edictc-request->string last-request))
 364              (last-command-tag (edictc-request->tag last-request))
 365              (last-request-context (cdr elt))
 366              (success-callback (car last-request-context))
 367              (success-callback-args (cdr last-request-context)))
 368
 369         (message "[%s] ->  %s (%s)" (process-get ep :server-nick)
 370                  last-command
 371                  response-type)
 372         (edictc-debug ep "COMMAND DONE: %s STAUS: %s" last-command response-type)
 373
 374         (unless (process-get ep :cmdq-head)
 375           ;; No more pending commands.
 376           (process-put ep :cmdq-tail nil))
 377
 378         (when last-request
 379           (edictc-debug ep "COMMAND DONE: %s STATUS: %s" last-command response-type))
 380
 381         (edictc-debug ep "COMMAND HEAD after UNQUEUE: %S"
 382                       (process-get ep :cmdq-head))
 383         (edictc-debug ep "COMMAND TAIL after UNQUEUE: %S"
 384                       (process-get ep :cmdq-tail))
 385
 386         (case response-type
 387           (positive
 388            (when success-callback
 389              (apply success-callback ep last-request success-callback-args)))
 390           (permanent-negative
 391            (edictc-display-error ep last-request))
 392           (otherwise
 393            (error "Don't know how to handle %s" response-type)))
 394         ;; Clear the current responses.
 395         (process-put ep :num-responses nil)
 396         (process-put ep :responses nil))))
 397
 398   ;; Send over the pending command, if any
 399   (edictc-send-command ep))
 400
 401 ;;;; Interactive helpers
 402
 403 (defun edictc-quote-parameter (parameter)
 404   (cond
 405    ((string-match (rx-to-string `(and bos ,edictc-atom-re eos)) parameter) parameter)
 406    ((string-match (rx-to-string `(and bos ,edictc-dqstring-re eos)) parameter) parameter)
 407    ((string-match (rx-to-string '(and bos (zero-or-one "\"")
 408                                       (group-n 1 (minimal-match
 409                                                   (zero-or-more not-newline)))
 410                                       (zero-or-one "\"") eos))
 411                   parameter)
 412     (let ((retval (concat "\"" (replace-regexp-in-string "\"" "\\\""
 413                                            (match-string 1 parameter) t t)
 414             "\"")))
 415       (prog1 retval
 416         (assert (string-match (rx-to-string `(or ,edictc-atom-re
 417                                                  ,edictc-dqstring-re))
 418                               retval)))))))
 419
 420 (defun edictc-select-database (ep &optional include-wild-cards-p)
 421   ;; "*"                                ; retrieve matches from ALL databases
 422   ;;                            ; that provide a match.
 423   ;; "!"                                ; retrieve matches from database that
 424   ;;                            ; provides the first match.
 425   (let ((db (completing-read "Use Database: "
 426                              (nconc
 427                               (and include-wild-cards-p
 428                                    (list "*" "!"))
 429                               (mapcar
 430                                (lambda (entity)
 431                                  (edictc-database-handle entity))
 432                                (process-get ep :databases)))
 433                              nil t)))
 434     db))
 435
 436 (defun edictc-select-strategy (ep)
 437
 438   ;; (or "prefix" "exact")      ; well-known strategies supported by all DICT
 439   ;;                    ; servers
 440
 441   (let ((strategy (completing-read
 442                    "Use Match Strategy: "
 443                    (nconc
 444                     (list "prefix" "exact")
 445                     (mapcar
 446                      (lambda (entity)
 447                        (edictc-strategy-handle entity))
 448                      (process-get ep :strategies)))
 449                    nil t)))
 450     strategy))
 451
 452 ;;;; CLIENT text
 453
 454 (defun edictc-command-client (&optional ep text)
 455   "Set client string."
 456   (interactive (list (edictc)))
 457   (let ((text (or text "edictc")))
 458     (edictc-queue-command ep (list 'CLIENT text))))
 459
 460 ;;;; DEFINE database word
 461
 462 (defun edictc-command-define (ep word &optional database)
 463   "Lookup WORD in DATABASE."
 464   (interactive
 465    (let* ((word (or (and (region-active-p)
 466                          (buffer-substring (region-beginning) (region-end)))
 467                     (word-at-point)))
 468           (word (and word (substring-no-properties word)))
 469           (prompt (format "Define word%s: " (if word (format " (%s)" word) "")))
 470           (word (read-string prompt  nil nil word))
 471           (ep (edictc)))
 472      (list ep word
 473            (if current-prefix-arg
 474                (edictc-select-database ep 'include-wild-cards)
 475              (or (process-get ep :database)
 476                  edictc-default-database)))))
 477   (edictc-queue-command ep (list 'DEFINE database word)
 478                         'edictc-display-definition))
 479
 480 ;;;; HELP
 481
 482 (defun edictc-command-help (&optional ep)
 483   "Show commands accepted by DICT server."
 484   (interactive (list (edictc)))
 485   (edictc-queue-command ep (list 'HELP)
 486                         'edictc-display-information))
 487
 488 ;;;; MATCH database strategy word
 489
 490 (defun edictc-command-match (ep word &optional strategy database)
 491   "Match WORD in DATABASE using STRATEGY."
 492   (interactive
 493    (let* ((default (word-at-point))
 494           (prompt (format "Match word%s: " (if default (format " (%s)" default) "")))
 495           (word (read-string prompt nil nil default))
 496           (ep (edictc)))
 497      (list ep word
 498            (if current-prefix-arg
 499                (edictc-select-strategy ep)
 500              (or (process-get ep :strategy)
 501                  edictc-default-strategy))
 502            (if current-prefix-arg
 503                (edictc-select-database ep 'include-wild-cards)
 504              (or (process-get ep :database)
 505                  edictc-default-database)))))
 506   (edictc-queue-command ep (list 'MATCH database strategy word)
 507                         'edictc-display-match ))
 508
 509 ;;;; OPTION
 510
 511 (defun edictc-command-option (&optional ep)
 512   (interactive (list (edictc)))
 513   (edictc-queue-command ep (list 'OPTION)))
 514
 515 ;;;; QUIT
 516
 517 (defun edictc-command-quit (&optional ep)
 518   "Close connection to the DICT server."
 519   (interactive (list (edictc)))
 520   (edictc-queue-command ep (list 'QUIT)))
 521
 522 ;;;; SHOW DATABASES
 523 (defun edictc-command-show-databases (&optional ep)
 524   (interactive (list (edictc)))
 525   (edictc-queue-command ep (list 'SHOW 'DATABASES)
 526                         'edictc-display-databases
 527                         (not (called-interactively-p 'any))))
 528
 529 ;;;; SHOW INFO database
 530
 531 (defun edictc-command-show-info (ep database)
 532   (interactive
 533    (let ((ep (edictc)))
 534      (list ep (edictc-select-database ep))))
 535   (edictc-queue-command ep (list 'SHOW 'INFO database)
 536                         'edictc-display-information))
 537
 538 ;;;; SHOW SERVER
 539
 540 (defun edictc-command-show-server (&optional ep suppress-display)
 541   (interactive (list (edictc) nil))
 542   (edictc-queue-command ep (list 'SHOW 'SERVER)
 543                         'edictc-display-server
 544                         suppress-display))
 545
 546 ;;;; SHOW STRATEGIES
 547
 548 (defun edictc-command-show-strategies (&optional ep)
 549   (interactive (list (edictc)))
 550   (edictc-queue-command ep (list 'SHOW 'STRATEGIES)
 551                         'edictc-display-strategies
 552                         (not (called-interactively-p 'any))))
 553
 554 ;;;; STATUS
 555
 556 (defun edictc-command-status (&optional ep)
 557   "Show timing or debugging information."
 558   (interactive (list (edictc)))
 559   (edictc-queue-command ep (list 'STATUS)
 560                         'edictc-display-information))
 561
 562 ;;; Developer Commands
 563
 564 (defun edictc-command-kill (&optional ep)
 565   "Kill connection to the DICT server."
 566   (interactive (list (edictc)))
 567   (delete-process (process-get ep :process)))
 568
 569 (defun edictc--devel-command-unknown-command (&optional ep)
 570   "Trigger 500 Syntax error, command not recognized"
 571   (interactive (list (edictc)))
 572   (edictc-queue-command ep (list 'HELLO 'WORLD)
 573                         'edictc-display-information))
 574
 575 (defun edictc--devel-command-invalid-database (&optional ep)
 576   "Trigger 500 Syntax error, command not recognized"
 577   (interactive (list (edictc)))
 578   (edictc-command-define ep "hello" "junk-database"))
 579
 580 (defun edictc--devel-command-invalid-strategy (&optional ep)
 581   "Trigger 500 Syntax error, command not recognized"
 582   (interactive (list (edictc)))
 583   (edictc-command-match ep "hello" "junk-strategy" "*"))
 584
 585 (defun edictc--devel-command-invalid-parameters (&optional ep)
 586   "Trigger 500 Syntax error, command not recognized"
 587   (interactive (list (edictc)))
 588   (edictc-command-define ep "hello" ""))
 589
 590 ;;; DICT Response Handling
 591
 592 (defun edictc-request->tag (request)
 593   (intern (mapconcat (lambda (s)
 594                        (when (symbolp s)
 595                          (symbol-name s))) request "")))
 596
 597 (defun edictc-request->string (request)
 598   (mapconcat (lambda (s) (format "%s" s)) request " "))
 599
 600 (defvar edictc-status-codes
 601   '(
 602     ;; 110 n databases present - text follows
 603     (110 n-dbs-present textual-response)
 604     ;; 111 n strategies available - text follows
 605     (111 n-strategies-available textual-response)
 606     ;; 112 database information follows
 607     (112 database-info textual-response)
 608     ;; 113 help text follows
 609     (113 help-text textual-response)
 610     ;; 114 server information follows
 611     (114 server-info textual-response)
 612     ;; 130 challenge follows
 613     (130 challenge)
 614     ;; 150 n definitions retrieved - definitions follow
 615     (150 n-definitions-retrieved)
 616     ;; 151 word database name - text follows
 617     (151 word-db-name textual-response)
 618     ;; 152 n matches found - text follows
 619     (152 n-matches-found textual-response)
 620     ;; 210 (optional timing and statistical information here)
 621     (210 timing-and-statistical-information-here)
 622     ;; 220 text msg-id
 623     (220 text-msg-id)
 624     ;; 221 Closing Connection
 625     (221 closing-connection)
 626     ;; 230 Authentication successful
 627     (230 authentication-successful)
 628     ;; 250 ok (optional timing information here)
 629     (250 ok)
 630     ;; 330 send response
 631     (330 send-response)
 632     ;; 420 Server temporarily unavailable
 633     (420 server-temporarily-unavailable)
 634     ;; 421 Server shutting down at operator request
 635     (421 server-shutting-down-at-operator-request)
 636     ;; 500 Syntax error, command not recognized
 637     (500 syntax-error--command-not-recognized)
 638     ;; 501 Syntax error, illegal parameters
 639     (501 syntax-error--illegal-parameters)
 640     ;; 502 Command not implemented
 641     (502 command-not-implemented)
 642     ;; 503 Command parameter not implemented
 643     (503 command-parameter-not-implemented)
 644     ;; 530 Access denied
 645     (530 access-denied)
 646     ;; 531 Access denied, use "SHOW INFO" for server information
 647     (531 access-denied--use--show-info--for-server-info)
 648     ;; 532 Access denied, unknown mechanism
 649     (532 access-denied--unknown-mechanism)
 650     ;; 550 Invalid database, use "SHOW DB" for list of databases
 651     (550 invalid-db)
 652     ;; 551 Invalid strategy, use "SHOW STRAT" for a list of strategies
 653     (551 invalid-strategy)
 654     ;; 552 No match
 655     (552 no-match)
 656     ;; 554 No databases present
 657     (554 no-dbs-present)
 658     ;; 555 No strategies available
 659     (555 no-strategies-available)))
 660
 661 (defvar edictc-in-out-states
 662   '((START . (220 420 421))
 663     (READY . nil)
 664     (DEFINE . (150))
 665     (150 . (151))
 666     (151 . (151 250))
 667     (MATCH . (152))
 668     (152 . (250))
 669     (SHOWDATABASES . (110))
 670     (110 . (250))
 671     (SHOWSTRATEGIES . (111))
 672     (111 . (250))
 673     (SHOWINFO . (112))
 674     (112 . (250))
 675     (SHOWSERVER . (114))
 676     (114 . (250))
 677     (CLIENT . (250))
 678     (STATUS . (210))
 679     (HELP . (113))
 680     (113 . (250))
 681     (QUIT . (221))))
 682
 683 (defun edictc-receive (ep &optional st nd length)
 684   (unless length
 685     (edictc-debug ep "DATA RECEIVED"))
 686   (edictc-debug ep "DATA OUTSTANDING:\n%s<-" (buffer-substring (point-min) (point-max)))
 687
 688   (goto-char (point-min))
 689   (when (looking-at
 690          (rx-to-string
 691           '(and (group-n 1 (and (group-n 2 (one-or-more digit))
 692                                 (zero-or-more " ")
 693                                 (group-n 3 (minimal-match (one-or-more anything)))))
 694                 "\r\n")))
 695     ;; Received a status response.
 696     (let* ((status-response (match-string 1))
 697            (status-code (string-to-number (match-string 2)))
 698            (response-type (edictc-response-type status-code))
 699            (status-rest (match-string 3))
 700            (end-of-status-response (match-end 0))
 701
 702            (textual-response-codes '(110 111 112 113 114 151 152))
 703            (text nil))
 704       (edictc-debug ep "Peeking at status code: %s" status-code)
 705
 706       ;; Check if status code falls in the expected range.
 707       (when (eq response-type 'invalid)
 708         (error "Invalid status code: %d" status-code))
 709
 710       (unless (memq response-type '(permanent-negative))
 711         ;; Check if the status code agrees with what we expect.
 712         (let ((expected-status-codes
 713                (assoc-default (process-get ep :state) edictc-in-out-states)))
 714           (unless (memq status-code expected-status-codes)
 715             (error
 716              (concat
 717               (format "Unexpected status code %d while in %s state;"
 718                       status-code (process-get ep :state))
 719               (format "\nExpecting one of the following status codes: %S"
 720                       expected-status-codes))))))
 721
 722       (cond
 723        ((member status-code textual-response-codes)
 724         (goto-char end-of-status-response)
 725         (when (re-search-forward "\r\n\\.\r\n" nil t)
 726           (process-put ep :state status-code)
 727           ;; Recieved full textual response.
 728           (setq text (replace-regexp-in-string
 729                       "\r\n" "\n" (buffer-substring end-of-status-response
 730                                                     (match-beginning 0))
 731                       t t))
 732           ;; Erase the whole response.
 733           (delete-region (point-min) (match-end 0))
 734           (edictc-debug ep "STATE: %s" (process-get ep :state))))
 735        (t
 736         (delete-region (point-min) end-of-status-response)
 737         (process-put ep :state status-code)))
 738
 739       ;; Take a peek at the code.
 740       (case status-code
 741         ;; * 110 n databases present - text follows
 742         (110
 743          (when text
 744            (when (string-match (rx-to-string '(and bos (one-or-more digit))) status-rest)
 745              (process-put ep :num-responses
 746                           (string-to-number (match-string 0 status-rest))))
 747
 748            (let ((dbs (split-string text "\n")))
 749              (process-put ep :responses
 750                           (mapcar
 751                            (lambda (db) ; database description
 752                              (if (string-match (rx-to-string edictc-database-description-re) db)
 753                                  (make-edictc-database
 754                                   :handle (match-string 1 db)
 755                                   :description (match-string 2 db))
 756                                (error "Unable to parse database list: %s" db)))
 757                            dbs)))
 758            ;; Start processing rest of text.
 759            (edictc-receive ep)))
 760         ;; * 111 n strategies available - text follows
 761         (111
 762          (when text
 763            (when (string-match (rx-to-string '(and bos (one-or-more digit))) status-rest)
 764              (process-put ep :num-responses
 765                           (string-to-number (match-string 0 status-rest))))
 766
 767            (let ((strategies (split-string text "\n")))
 768              (process-put ep :responses
 769                           (mapcar
 770                            (lambda (strategy)   ; strategy description
 771                              (if (string-match (rx-to-string edictc-strategy-description-re) strategy)
 772                                  (make-edictc-strategy
 773                                   :handle (match-string 1 strategy)
 774                                   :description (match-string 2 strategy))
 775                                (error "Unable to parse database list: %s" strategy)))
 776                            strategies)))
 777            (edictc-receive ep)))
 778         ;;   112 database information follows
 779         (112
 780          (when text
 781            (process-put ep :responses (cons status-rest text))
 782            (edictc-receive ep)))
 783         ;;   113 help text follows
 784         (113
 785          (when text
 786            (process-put ep :responses (cons status-rest text))
 787            (edictc-receive ep)))
 788         ;;   114 server information follows
 789         (114
 790          (when text
 791            (process-put ep :responses (cons status-rest text))
 792            (edictc-receive ep)))
 793         ;;   130 challenge follows
 794         (130
 795
 796          )
 797         ;; * 150 n definitions retrieved - definitions follow
 798         (150
 799          (when (string-match (rx-to-string '(and bos (one-or-more digit))) status-rest)
 800            (process-put ep :num-responses
 801                         (string-to-number (match-string 0 status-rest))))
 802          (edictc-receive ep))
 803         ;; * 151 word database name - text follows
 804         (151
 805          (when text
 806            (let (word database name)
 807              (when (string-match (rx-to-string edictc-word-definition-re) status-rest)
 808                (setq word (match-string 1 status-rest))
 809                (setq database (match-string 2 status-rest))
 810                (setq name (match-string 3 status-rest)))
 811
 812              (let ((word-definition
 813                     (make-edictc-word-definition
 814                      :word word :db-handle database :db-description name
 815                      :text text)))
 816                (push word-definition (process-get ep :responses))))
 817            (edictc-receive ep)))
 818         ;; * 152 n matches found - text follows
 819         (152
 820          (when text
 821            (when (string-match (rx-to-string '(and bos (one-or-more digit))) status-rest)
 822              (process-put ep :num-responses
 823                           (string-to-number (match-string 0 status-rest))))
 824            (let* ((matches (split-string text "\n"))
 825                   (matches-list
 826                    (mapcar
 827                     (lambda (match)     ; database word
 828                       (if (string-match (rx-to-string edictc-match-description-re) match)
 829                           (make-edictc-word-match
 830                            :db-handle (match-string 1 match)
 831                            :text (match-string 2 match))
 832                         (error "Unable to parse match list: %s" match)))
 833                     matches)))
 834              (process-put ep :responses matches-list))
 835            (edictc-receive ep)))
 836         ;;   210 (optional timing and statistical information here)
 837         (210
 838          (process-put ep :responses status-rest)
 839          (edictc-unqueue-command ep)
 840          (process-put ep :num-responses nil)
 841          (process-put ep :responses nil))
 842         ;; * 220 text msg-id
 843         (220
 844          (when (string-match (rx-to-string edictc-banner-re) status-response)
 845            (process-put ep :server-string
 846                         (match-string 1 status-response))
 847            (process-put ep :server-capabilities
 848                         (match-string 2 status-response))
 849            (process-put ep :msg-id
 850                         (match-string 3 status-response)))
 851          (edictc-debug ep "EDICTC ACTIVE")
 852          (edictc-unqueue-command ep))
 853         ;;   221 Closing Connection
 854         (221
 855
 856          )
 857         ;;   230 Authentication successful
 858         (230
 859
 860          )
 861         ;;   250 ok (optional timing information here)
 862         (250
 863          (edictc-unqueue-command ep))
 864         ;;   330 send response
 865         (330
 866
 867          )
 868         ;;   420 Server temporarily unavailable
 869         (420
 870
 871          )
 872         ;;   421 Server shutting down at operator request
 873         (421
 874
 875          )
 876         ;;   500 Syntax error, command not recognized
 877         ;;   501 Syntax error, illegal parameters
 878         ;;   502 Command not implemented
 879         ;;   503 Command parameter not implemented
 880         ;;   530 Access denied
 881         ;;   531 Access denied, use "SHOW INFO" for server information
 882         ;;   532 Access denied, unknown mechanism
 883         ;;   550 Invalid database, use "SHOW DB" for list of databases
 884         ;;   551 Invalid strategy, use "SHOW STRAT" for a list of strategies
 885         ;;   552 No match
 886         ;;   554 No databases present
 887         ;;   555 No strategies available
 888         ((500 501 501 501 502 503 530 531 532 550 551 552 554 555)
 889          (process-put ep :responses status-rest)
 890          (edictc-unqueue-command ep))
 891         (otherwise
 892          (error "Received unknown status response: %s" status-response))))))
 893
 894 (defun edictc-process-filter (proc data)
 895   ;; (edictc-debug ep "FILTER RECEIVED: %s" data)
 896   (let* ((ep proc)
 897          (buffer (process-get ep :process-buffer)))
 898     (assert ep)
 899     (when buffer
 900       ;; (display-buffer buffer)
 901       (with-current-buffer (process-buffer proc)
 902         (let* ((start (point-max))
 903                (inhibit-read-only t))
 904           ;; Append received data in to process buffer.
 905           (goto-char (point-max))
 906           (insert data)
 907           ;; Hand over the data for protocol processing, when not in
 908           ;; debug mode.
 909           (unless (derived-mode-p 'edictc-debug-mode)
 910             (let* ((end (point-max))
 911                    (length (length data)))
 912               (assert (not (zerop length)))
 913               (funcall (process-get ep :receivef) ep start end length))))))))
 914
 915 (defun edictc-cleanup (ep why)
 916   (let* ((process-buffer (process-get ep :process-buffer))
 917          (output-buffer (process-get ep :output-buffer))
 918          (debug-buffer (process-get ep :debug-buffer))
 919          (owner-buffer (process-get ep :owner-buffer)))
 920
 921     (when (eq edictc-process ep)
 922       (setq edictc-process nil))
 923
 924     (with-current-buffer debug-buffer
 925       (setq-local edictc-process nil))
 926
 927     (with-current-buffer output-buffer
 928       (setq-local edictc-process nil))
 929
 930     (cond
 931      (owner-buffer
 932       (message "[%s] CONNECTION RESET" (process-get ep :server-nick))
 933
 934       (with-current-buffer owner-buffer
 935         (kill-local-variable 'edictc-process)))
 936      (t
 937       (message "[%s] QUIT, %s" (process-get ep :server-nick) why)
 938       (set-default 'edictc-process nil)))
 939
 940     (with-current-buffer debug-buffer
 941       (setq edictc-process nil))
 942
 943     ;; FIXME: Remove it from connection list.
 944
 945     (when process-buffer
 946       (kill-buffer process-buffer))
 947
 948     ;; (when output-buffer
 949     ;;   (kill-buffer output-buffer))
 950
 951     (if (get-buffer-window-list output-buffer)
 952         (when (y-or-n-p (format "DICT buffer %s is orphaned. Kill it?" output-buffer))
 953           (kill-buffer output-buffer))
 954       (kill-buffer output-buffer))
 955
 956     (when debug-buffer
 957       (let ((debug-output (with-current-buffer debug-buffer
 958                             (prog1 (buffer-string)
 959                               (kill-buffer (current-buffer))))))
 960         ;; (with-current-buffer-window (get-buffer-create "*debug*") nil nil
 961         ;;                          (erase-buffer)
 962         ;;                          (insert debug-output))
 963         ))))
 964
 965 (defun edictc-process-sentinel (ep why)
 966   (edictc-debug ep "edictc-process-sentinel in buffer (%s). REASON %s"
 967                 (process-buffer ep) why)
 968   (let ((why (format "[%s: %s]" (process-status ep) why)))
 969     (case (process-status ep)
 970       ;; Kill => closed: deleted.
 971       ;; Quit => closed: connection broken by remote peer.
 972       (closed
 973        (edictc-cleanup ep why))
 974       (otherwise
 975        (error "FIXME: Don't know how to handle process-status %s" why)))))
 976
 977 (defun edictc ()
 978   (if edictc-process edictc-process
 979     (edictc-connect edictc-server)))
 980
 981 (defun edictc-connect (&optional server-nick type)
 982   (interactive (list edictc-server))
 983
 984   (assert (memq type '(nil this-buffer-only orphan)))
 985   (setq server-nick (or server-nick edictc-server))
 986
 987   (when edictc-process
 988     (when (and (memq type '(orphan this-buffer-only))
 989                (local-variable-p 'edictc-process))
 990       (user-error (concat
 991                    "Refusing to start another local connection.\n"
 992                    "First, shutdown the existing connection.")))
 993
 994     (when (and (null type) (default-value 'edictc-process))
 995       (user-error (concat
 996                    "Refusing to start another default connection.\n"
 997                    "First shutdown the existing connection or\n"
 998                    "Start a connection specific to this buffer."))))
 999
1000   (let* ((server-settings (assoc server-nick edictc-servers))
1001          (server-plist (cdr server-settings))
1002          (host (plist-get server-plist :server))
1003          (port (or (plist-get server-plist :port) edictc-port))
1004          (ep (open-network-stream edictc-process-name nil host port))
1005          (buffer (generate-new-buffer
1006                   (format " *%s %s:%d*" edictc-process-name host port))))
1007     (if (not ep)
1008         ;; Failed to open the connection for some reason
1009         (progn
1010           (kill-buffer buffer)
1011           (setq buffer nil)
1012           (error "Could not create connection to %s:%d" host port))
1013       (set-process-plist ep
1014                          (append
1015                           (list :server-nick server-nick)
1016                           server-plist
1017                           (list
1018                            :state 'START
1019                            :process ep
1020                            :database (or (plist-get server-plist :database)
1021                                          edictc-default-database)
1022                            :strategy (or (plist-get server-plist :strategy)
1023                                          edictc-default-strategy)
1024                            :process-buffer buffer
1025                            :receivef 'edictc-receive)))
1026
1027       (with-current-buffer buffer
1028         (setq mode-line-format "%b [%s]")
1029         (setq-local edictc-process ep)
1030         (edictc-mode))
1031
1032       (with-current-buffer (edictc-get-create-output-buffer ep)
1033         (erase-buffer))
1034
1035       (with-current-buffer (edictc-get-create-debug-buffer ep)
1036         (erase-buffer))
1037
1038       (case type
1039         (orphan
1040          (process-put ep :owner-buffer
1041                       (process-get ep :output-buffer)))
1042         (this-buffer-only
1043          (setq-local edictc-process ep)
1044          (process-put ep :owner-buffer (current-buffer)))
1045         (otherwise
1046          (setq edictc-process ep)
1047          (process-put ep :owner-buffer nil)))
1048
1049       ;; (edictc-debug-mode)
1050
1051       (push ep edictc-process-list)
1052
1053       (set-process-buffer ep buffer)
1054       (set-process-filter ep 'edictc-process-filter)
1055       (set-process-coding-system ep 'utf-8-unix 'utf-8-unix)
1056       (pcase (process-status ep)
1057         (`connect
1058          ;; Asynchronous connection
1059          (set-process-sentinel ep 'edictc-async-sentinel))
1060         (`failed
1061          ;; Asynchronous connection failed
1062          (error "Could not create connection to %s:%d" host port))
1063         (_
1064          (message "Connected to %s:%s" host port)
1065          (set-process-sentinel ep
1066                                'edictc-process-sentinel)
1067          ;; (process-send-string connection (edictc-create-request))
1068          ))
1069       ;; Queue some commands.
1070       (edictc-command-client ep)
1071       (edictc-command-show-databases ep)
1072       (edictc-command-show-strategies ep)
1073       (edictc-command-show-server ep))
1074     ep))
1075
1076 (defvar edictc-mode-map
1077   (let ((map (copy-keymap special-mode-map)))
1078     (define-key map "h" 'edictc-command-show-server)
1079     (define-key map "d" 'edictc-command-show-databases)
1080     (define-key map "s" 'edictc-command-show-strategies)
1081     (define-key map "c" 'edictc-command-help)
1082     (define-key map "q" 'edictc-command-quit)
1083     (define-key map "i" 'edictc-command-show-info)
1084     map)
1085   "Local keymap for `tabulated-list-mode' buffers.")
1086
1087 (defvar-local edictc-mode-line nil)
1088
1089 (defun edictc-describe-process-or-nick (ep-or-nick &optional for)
1090   (cond
1091    ((processp ep-or-nick)
1092     (case for
1093       (mode-line
1094        (format "%s (%s--%s) {%d Dbs/%d Strats}"
1095                (process-get ep-or-nick :server-nick)
1096                (process-get ep-or-nick :database)
1097                (process-get ep-or-nick :strategy)
1098                (length (process-get ep-or-nick :databases))
1099                (length (process-get ep-or-nick :strategies))))
1100       (menubar
1101        (format "%s (%s--%s) [Active %s]"
1102                (process-get edictc-process :server-nick)
1103                (process-get edictc-process :database)
1104                (process-get edictc-process :strategy)
1105                (if (local-variable-p 'edictc-process)
1106                    "locally"
1107                  "globally")))
1108       (otherwise
1109        (user-error "This should not happen"))))
1110    ((stringp ep-or-nick)
1111     (let ((server-plist (assoc-default ep-or-nick edictc-servers)))
1112       (format "%s    (%s--%s)"
1113               ep-or-nick
1114               (or (plist-get server-plist :database)
1115                   edictc-default-database)
1116               (or (plist-get server-plist :strategy)
1117                   edictc-default-strategy))))
1118    (t nil)))
1119
1120 (define-minor-mode edictc-mode
1121   "Edictc Mode"
1122   :lighter (" " edictc-mode-line)
1123   (setq edictc-mode-line
1124         (edictc-describe-process-or-nick edictc-process 'mode-line)))
1125
1126 (defvar edictc-debug-mode-map edictc-mode-map)
1127
1128 (define-derived-mode edictc-debug-mode edictc-mode "DICTC Debug"
1129   "Control buffer for interacting with DICT servers.
1130 Use it to interact with DICT server as via telnet."
1131
1132   )
1133
1134 ;;; Display Results
1135
1136 ;;;; Display Helpers
1137
1138 (defun edictc-get-create-output-buffer (ep)
1139   (if (null ep)
1140       (generate-new-buffer edictc-output-buffer-name)
1141     (let ((buffer (process-get ep :output-buffer)))
1142       (unless (buffer-live-p buffer)
1143         (setq buffer (generate-new-buffer edictc-output-buffer-name))
1144         (process-put ep :output-buffer buffer)
1145         (with-current-buffer buffer
1146           (setq-local edictc-process ep)
1147           (edictc-mode)))
1148       buffer)))
1149
1150 (defmacro edictc-display-text (ep &rest body)
1151   (declare (indent 1) (debug t))
1152   `(with-current-buffer (edictc-get-create-output-buffer ep)
1153      (erase-buffer)
1154      (progn
1155        ,@body)
1156      (edictc-mode)
1157      (goto-char (point-min))
1158      (display-buffer (current-buffer))))
1159
1160 (defun edictc-normalize-text (text &optional indent)
1161   ;; Delete trailing whitespace
1162   (setq text (replace-regexp-in-string
1163               (rx-to-string '(and (one-or-more blank) eol)) "" text t t))
1164
1165   ;; Replace 2 or more newlines with just 2 newlines
1166   (setq text (replace-regexp-in-string
1167               (rx-to-string '(>= 2 "\n")) "\n\n" text t t))
1168
1169   ;; No leading or trailing newlines
1170   (setq text (replace-regexp-in-string
1171               (rx-to-string '(or (and bos (one-or-more "\n"))
1172                                  (and (one-or-more "\n") eos))) "" text t t))
1173
1174   ;; Optionally indent the text.
1175   (when indent
1176     (let ((leading-space (make-string indent (string-to-char " "))))
1177       (setq text (replace-regexp-in-string
1178                   (rx-to-string '(and bol (group-n 1 nonl)))
1179                   (concat leading-space "\\1") text t))))
1180
1181   ;; Return normalized text.
1182   text)
1183
1184 ;;;; DEFINE database word
1185
1186 (defun edictc-display-definition (ep request)
1187   (edictc-display-text ep
1188     (outline-mode)
1189     (let* ((word-definitions (process-get ep :responses))
1190            ;; (list 'DEFINE database word)
1191            (database (nth 1 request))
1192            (word (nth 2 request)))
1193       (cond
1194        (word-definitions
1195         (message "Displaying all %d definitions for %s" (length word-definitions) word)
1196         (insert (format "* Definition for %s\n\n" word))
1197         (insert (mapconcat
1198                  (lambda (definition)
1199                    (format "** Definition for %s from %s\n\n%s"
1200                            (edictc-word-definition-word definition)
1201                            (edictc-word-definition-db-description definition)
1202                            (edictc-normalize-text
1203                             (edictc-word-definition-text definition) 1)))
1204                  word-definitions "\n\n")))
1205        (t (edictc-display-information ep request))))))
1206
1207 ;;;; MATCH database strategy word
1208
1209 (defun edictc-display-match (ep request)
1210   (edictc-display-text ep
1211     (outline-mode)
1212     (let* ((word-matches (process-get ep :responses))
1213            ;; (list 'MATCH database strategy word)
1214            (database (nth 1 request))
1215            (strategy (nth 2 request))
1216            (word (nth 3 request)))
1217       (cond
1218        (word-matches
1219         (message "Displaying all %d matches for %s" (length word-matches) word)
1220         (insert (format "* Match for %s\n\n" word))
1221         (insert (mapconcat
1222                  (lambda (match)
1223                    (format "** Match for %s from %s\n\n%s"
1224                            word
1225                            (edictc-word-match-db-handle match)
1226                            (edictc-normalize-text (edictc-word-match-text match) 1)))
1227                  word-matches "\n\n")))
1228        (t (insert (format "No matches found for %s" word)))))))
1229
1230 ;;; Interactive functions
1231
1232 ;;;; Buttons
1233
1234 (define-button-type 'edictc-browse-server
1235   :supertype 'help-xref
1236   'help-function (lambda (server-nick)
1237                    (let ((ep (edictc-connect server-nick 'orphan)))
1238                      (lambda (ep) (edictc-command-show-server ep nil))))
1239   ;; 'help-echo (purecopy "mouse-2, RET: customize variable")
1240   )
1241
1242 (define-button-type 'edictc-help-server
1243   :supertype 'help-xref
1244   'help-function (lambda (ep)
1245                    (edictc-command-show-server ep nil))
1246   ;; 'help-echo (purecopy "mouse-2, RET: customize variable")
1247   )
1248
1249 (define-button-type 'edictc-help-server-commands
1250   :supertype 'help-xref
1251   'help-function (lambda (ep)
1252                    (edictc-command-help ep))
1253   ;; 'help-echo (purecopy "mouse-2, RET: customize variable")
1254   )
1255
1256 (define-button-type 'edictc-help-server-status
1257   :supertype 'help-xref
1258   'help-function (lambda (ep)
1259                    (edictc-command-status ep))
1260   ;; 'help-echo (purecopy "mouse-2, RET: customize variable")
1261   )
1262
1263 (define-button-type 'edictc-help-databases
1264   :supertype 'help-xref
1265   'help-function (lambda (ep)
1266                    (call-interactively 'edictc-command-show-databases))
1267   ;; 'help-echo (purecopy "mouse-2, RET: customize variable")
1268   )
1269
1270 (define-button-type 'edictc-help-strategies
1271   :supertype 'help-xref
1272   'help-function (lambda (ep)
1273                    (call-interactively 'edictc-command-show-strategies))
1274   ;; 'help-echo (purecopy "mouse-2, RET: customize variable")
1275   )
1276
1277 (define-button-type 'edictc-help-database
1278   :supertype 'help-xref
1279   'help-function (lambda (ep database)
1280                    (edictc-command-show-info ep database))
1281   ;; 'help-echo (purecopy "mouse-2, RET: customize variable")
1282   )
1283
1284 ;;;; SHOW DATABASES
1285
1286 (defvar edictc-databases-menu-mode-map
1287   (let ((map (make-sparse-keymap))
1288         (menu-map (make-sparse-keymap "Font Family")))
1289     (set-keymap-parent map tabulated-list-mode-map)
1290     (define-key map "\C-m" 'edictc-databases-menu-set-default-database)
1291     map)
1292   "Local keymap for `font-family-menu-mode' buffers.")
1293
1294 (define-derived-mode edictc-databases-menu-mode tabulated-list-mode "DICT"
1295   (edictc-mode)
1296   (setq tabulated-list-format
1297         `[("Database" 30 t)
1298           ("Text" 30 t)])
1299   (setq tabulated-list-padding 2)
1300   (setq tabulated-list-sort-key (cons "Database" nil))
1301   (setq tabulated-list-use-header-line nil)
1302   (setq header-line-format
1303         (make-text-button "Show Server" nil 'type 'edictc-help-server
1304                           'help-args (list (edictc))))
1305   (add-hook 'tabulated-list-revert-hook 'edictc-databases-menu--refresh nil t)
1306   (edictc-databases-menu--refresh)
1307   (tabulated-list-init-header)
1308   (tabulated-list-print))
1309
1310 (defun edictc-menu-show-database (&optional button)
1311   (interactive)
1312   (let* (;; (context (list tabulated-list-sort-key (point) (window-start)))
1313          (ep (button-get button 'ep))
1314          (database-handle (button-get button 'database-handle)))
1315     (edictc-command-show-info ep database-handle)))
1316
1317 (defun edictc-databases-menu--refresh ()
1318   (setq tabulated-list-entries
1319         (let* ((ep (edictc)))
1320           (mapcar
1321            (lambda (entity)
1322              (list (edictc-database-handle entity)
1323                    (vector
1324                     (list (edictc-database-handle entity)
1325                           'type 'edictc-help-database
1326                           'help-args (list ep (edictc-database-handle entity)))
1327                     (edictc-database-description entity))))
1328            (process-get ep :databases)))))
1329
1330 (defun edictc-display-databases (ep request &optional suppress-display)
1331   (interactive)
1332
1333   (unless (process-get ep :databases)
1334     (process-put ep :databases
1335           (process-get ep :responses))
1336     (with-current-buffer (edictc-get-create-output-buffer ep)
1337       ;; Update `edictc-mode-line'
1338       (edictc-mode)))
1339
1340   (unless suppress-display
1341     (with-current-buffer (edictc-get-create-output-buffer ep)
1342         (edictc-databases-menu-mode)
1343         (pop-to-buffer (current-buffer)))))
1344
1345 ;;;; Selecting a Database
1346
1347 (defun edictc-database-set-default-database (ep database-handle)
1348   (let ((current-database (or (process-get ep :database)
1349                               edictc-default-database)))
1350     (when (y-or-n-p (format "Switch Database from %s to %s?"
1351                             current-database database-handle))
1352       (message "Database set to %s" database-handle)
1353       (process-put ep :database database-handle)
1354       ;; Update mode line.
1355       (edictc-mode))))
1356
1357 ;;;; SHOW INFO database & Other commands
1358
1359 (defun edictc-display-information (ep request)
1360   (edictc-display-text ep
1361     (setq header-line-format
1362           (make-text-button "Databases" nil 'type
1363                             'edictc-help-databases 'help-args (list ep)))
1364     (let* ((response (process-get ep :responses)))
1365       (cond
1366        ((stringp response)
1367         (insert (edictc-normalize-text response)))
1368        ((consp response)
1369         (insert (format "* %s\n\n%s"
1370                         (propertize (capitalize (car response)) 'face 'bold)
1371                         (edictc-normalize-text (cdr response) 1))))
1372        (t (insert "This should not happen"))))))
1373
1374 (defun edictc-display-error (ep request)
1375   (edictc-display-text ep
1376     (let* ((response (process-get ep :responses)))
1377       (cond
1378        ((stringp response)
1379         (insert (edictc-normalize-text response)))
1380        ((consp response)
1381         (insert (format "* %s\n\n%s"
1382                         (propertize (capitalize (car response)) 'face 'bold)
1383                         (edictc-normalize-text (cdr response) 1))))
1384        (t (insert "This should not happen"))))))
1385
1386 ;;;; SHOW SERVER
1387
1388 (defun edictc-display-server (ep request suppress-display)
1389   (unless suppress-display
1390     (edictc-display-text ep
1391       (let* ((response (process-get ep :responses)))
1392         (when (stringp response)
1393           (setq response (cons "Server Information" response)))
1394         (setq header-line-format
1395               (concat
1396                (make-text-button "Databases" nil 'type
1397                                  'edictc-help-databases 'help-args (list ep))
1398                (propertize " " 'display `(space :align-to 20))
1399                (make-text-button "Match Strategies" nil 'type
1400                                  'edictc-help-strategies 'help-args (list ep))
1401
1402                (when edictc-debug
1403                  (concat
1404                   (propertize " " 'display `(space :align-to 40))
1405                   (make-text-button "Server Commands" nil 'type
1406                                     'edictc-help-server-commands 'help-args (list ep))))
1407
1408                (when edictc-debug
1409                  (concat
1410                   (propertize " " 'display `(space :align-to 60))
1411                   (make-text-button "Server Status" nil 'type
1412                                     'edictc-help-server-status 'help-args (list ep))))))
1413
1414         (insert "\n")
1415         (insert (propertize (capitalize (car response)) 'face 'bold) "\n\n")
1416         (insert (cdr response))))))
1417
1418 ;;;; SHOW STRATEGIES
1419
1420 (defvar edictc-strategies-menu-mode-map
1421   (let ((map (make-sparse-keymap))
1422         (menu-map (make-sparse-keymap "Font Family")))
1423     (set-keymap-parent map tabulated-list-mode-map)
1424     (define-key map "\C-m" 'edictc-strategies-menu-set-default-strategy)
1425     map)
1426   "Local keymap for `font-family-menu-mode' buffers.")
1427
1428 (define-derived-mode edictc-strategies-menu-mode tabulated-list-mode "DICT Strategies"
1429   (edictc-mode)
1430   (setq tabulated-list-format
1431         `[("Strategy" 30 t)
1432           ("Text" 30 t)])
1433   (setq tabulated-list-padding 2)
1434   (setq tabulated-list-sort-key (cons "Strategy" nil))
1435   (add-hook 'tabulated-list-revert-hook 'edictc-strategies-menu--refresh nil t)
1436   (setq tabulated-list-use-header-line nil)
1437   (setq header-line-format
1438         (make-text-button "Show Server" nil 'type 'edictc-help-server
1439                           'help-args (list (edictc))))
1440   (edictc-strategies-menu--refresh)
1441   (tabulated-list-init-header)
1442   (tabulated-list-print))
1443
1444 (defun edictc-strategies-menu--refresh ()
1445   (setq tabulated-list-entries
1446         (let* ((ep (edictc)))
1447           (mapcar
1448            (lambda (entity)
1449              (list (edictc-strategy-handle entity)
1450                    (vector (edictc-strategy-handle entity)
1451                            (edictc-strategy-description entity))))
1452            (process-get ep :strategies)))))
1453
1454 (defun edictc-display-strategies (ep request &optional suppress-display)
1455   (interactive)
1456
1457   (unless (process-get ep :strategies)
1458     (process-put ep :strategies
1459           (process-get ep :responses))
1460     ;; Update `edictc-mode-line'
1461     (with-current-buffer (edictc-get-create-output-buffer ep)
1462       (edictc-mode)))
1463
1464   (unless suppress-display
1465     (with-current-buffer (edictc-get-create-output-buffer ep)
1466       (edictc-strategies-menu-mode)
1467       (pop-to-buffer (current-buffer)))))
1468
1469 (defun edictc-databases-menu-set-default-database ()
1470   (interactive)
1471   (when (derived-mode-p 'edictc-databases-menu-mode)
1472     (let ((database-handle (tabulated-list-get-id)))
1473       (edictc-database-set-default-database (edictc) database-handle))))
1474
1475 ;;;; Selecting a Strategy
1476
1477 (defun edictc-strategies-menu-set-default-strategy ()
1478   (interactive)
1479   (when (derived-mode-p 'edictc-strategies-menu-mode)
1480     (let ((strategy-handle (tabulated-list-get-id)))
1481       (when (and strategy-handle
1482                  (y-or-n-p (concat "Set match strategy to " strategy-handle)))
1483         (message "Match strategy set to %s" strategy-handle)
1484         (process-put (edictc) :strategy strategy-handle)
1485         ;; Update mode line.
1486         (edictc-mode)))))
1487
1488 ;;;; SHOW SERVERS
1489
1490 (defvar edictc-servers-menu-mode-map
1491   (let ((map (make-sparse-keymap))
1492         (menu-map (make-sparse-keymap "Font Family")))
1493     (set-keymap-parent map tabulated-list-mode-map)
1494     (define-key map "\C-m" 'edictc-servers-menu-set-default-server)
1495     map)
1496   "Local keymap for `font-family-menu-mode' buffers.")
1497
1498 (define-derived-mode edictc-servers-menu-mode tabulated-list-mode "DICT Servers"
1499   (setq tabulated-list-format
1500         `[("Name" 20 t)
1501           ("DICT Host" 30)
1502           ("About" 30)])
1503   (setq tabulated-list-padding 2)
1504   (setq tabulated-list-sort-key (cons "Name" nil))
1505   (add-hook 'tabulated-list-revert-hook 'edictc-servers-menu--refresh nil t)
1506   (edictc-servers-menu--refresh)
1507   (tabulated-list-init-header)
1508   (tabulated-list-print))
1509
1510 (defun edictc-servers-menu--refresh ()
1511   (setq tabulated-list-entries
1512         (mapcar
1513          (lambda (server)
1514            (list (car server)
1515                  (vector (list (car server)
1516                                'type 'edictc-browse-server
1517                                'help-args (list (car server)))
1518                          (or (plist-get (cdr server) :server) "Unknown")
1519                          (or (plist-get (cdr server) :about) "Unknown"))))
1520          edictc-servers)))
1521
1522 (put 'edictc-display-servers 'disabled t)
1523 (defun edictc-display-servers (&optional suppress-display)
1524   (interactive)
1525   (unless suppress-display
1526     (with-current-buffer (edictc-get-create-output-buffer nil)
1527       (edictc-servers-menu-mode)
1528       (pop-to-buffer (current-buffer)))))
1529
1530 ;;;; Selecting a Server
1531
1532 (defun edictc-servers-menu-set-default-server ()
1533   (interactive)
1534   (when (derived-mode-p 'edictc-servers-menu-mode)
1535     (let ((server-nick (tabulated-list-get-id)))
1536       (when (and server-nick
1537                  (y-or-n-p (concat "Set match server to " server-nick)))
1538         (customize-save-variable 'edictc-server server-nick)
1539         (message "Match server set to %s" server-nick)))))
1540
1541 ;;;; Easy Menu
1542
1543 (easy-menu-define edictc-menu edictc-mode "Dictionary menu"
1544   `("Dict"
1545     ["Define word" edictc-command-define t]
1546     ["Match word" edictc-command-match t]
1547     ["--" nil :visible edictc-process]
1548     ["About Server" edictc-command-show-server :visible edictc-process]
1549     ["Available Databases" edictc-command-show-databases :visible edictc-process]
1550     ["Available Strategies" edictc-command-show-strategies :visible edictc-process]
1551     ["Server Status" edictc-command-status :visible (and edictc-debug edictc-process)]
1552     ["Server Commands" edictc-command-help :visible edictc-process]
1553     ["About a Database" edictc-command-show-info :visible (and edictc-debug edictc-process)]
1554     ["Shutdown" edictc-command-quit :visible edictc-process]
1555     ["Save Session Options"
1556      (lambda nil
1557        (interactive)
1558        (let* ((default-settings (assoc (process-get edictc-process :server-nick)
1559                                        edictc-servers)))
1560          (unless (string= (process-get edictc-process :database)
1561                           (plist-get (cdr default-settings) :database))
1562            (plist-put (cdr default-settings) :database
1563                       (process-get edictc-process :database)))
1564          (unless (string= (process-get edictc-process :strategy)
1565                           (plist-get (cdr default-settings) :strategy))
1566            (plist-put (cdr default-settings) :strategy
1567                       (process-get edictc-process :strategy)))
1568          (customize-save-variable 'edictc-servers edictc-servers)
1569          (edictc-update-menu)))
1570      :visible (let ((default-settings (assoc (process-get edictc-process :server-nick)
1571                                              edictc-servers)))
1572                 (not (and (string= (process-get edictc-process :database)
1573                                    (plist-get (cdr default-settings) :database))
1574                           (string= (process-get edictc-process :strategy)
1575                                    (plist-get (cdr default-settings) :strategy)))))]
1576     ["Kill" edictc-command-kill :visible (and edictc-debug edictc-process)]
1577     ["--" nil :visible (or (null edictc-process)
1578                            (null (default-value 'edictc-process))
1579                            (null (local-variable-p 'edictc-process)))]
1580     ["Start" edictc-connect :visible (null (default-value 'edictc-process))]
1581     ["Start for this buffer" (lambda nil
1582                                (interactive)
1583                                (edictc-connect nil 'this-buffer-only))
1584      :visible (null (local-variable-p 'edictc-process))]
1585     "--"
1586     ("Select DICT Server")
1587     ("Save Option")
1588     ["--" nil :visible edictc-debug]
1589     ("Developer Commands" :visible edictc-debug
1590      "--"
1591      ["EDICTC Dashboard" edictc-display-servers t]
1592      ["Client string" edictc-command-client t]
1593      ["Option" edictc-command-option t]
1594      ["Show Debug" (lambda (ep)
1595                      (interactive (list edictc-process))
1596                      (if ep
1597                          (pop-to-buffer (process-get ep :debug-buffer))
1598                        (user-error "No running instance of edictc")))
1599       t]
1600      ["Trigger Unknown Command" edictc--devel-command-unknown-command t]
1601      ["Trigger Invalid Database" edictc--devel-command-invalid-database t]
1602      ["Trigger Invalid Strategy" edictc--devel-command-invalid-strategy t]
1603      ["Trigger Invalid Parameters" edictc--devel-command-invalid-parameters t]
1604      )))
1605
1606 (easy-menu-add-item menu-bar-tools-menu nil edictc-menu "Spell checking")
1607
1608 (add-hook 'menu-bar-update-hook 'edictc-update-menu)
1609
1610 (defun edictc-update-menu ()
1611   (easy-menu-define edictc-servers-menu nil "DICT Server menu"
1612     (cons "Select DICT Server"
1613           (mapcar (lambda (server)
1614                     (vector (edictc-describe-process-or-nick (car server))
1615                               (list (lambda (server-nick)
1616                                       (customize-save-variable
1617                                        'edictc-server server-nick))
1618                                     (car server))
1619                               :style 'radio
1620                               :selected `(string= ,(car server)
1621                                                   edictc-server)))
1622                   edictc-servers)))
1623
1624   (easy-menu-add-item edictc-menu nil edictc-servers-menu)
1625
1626   (easy-menu-add-item
1627    edictc-menu nil
1628    (vector "Active Server" nil
1629            :enable nil
1630            :label (when edictc-process
1631                     (edictc-describe-process-or-nick edictc-process 'menubar)))
1632
1633    "About Server")
1634
1635   (easy-menu-add-item
1636    edictc-menu nil
1637    (vector "Default Server" nil
1638            :enable nil
1639            :visible (or (null edictc-process)
1640                         (null (default-value 'edictc-process))
1641                         (null (local-variable-p 'edictc-process)))
1642            :label (edictc-describe-process-or-nick edictc-server))
1643    "Start"))
1644
1645 (edictc-update-menu)
1646
1647 ;;; Global Bindings
1648
1649 (define-key esc-map "#" 'edictc-command-define)
1650 (define-key esc-map "*" 'edictc-command-match)
1651
1652 (provide 'edictc)
1653
1654 ;;; edictc.el ends here