cgit.sxemacs.org Git - packages/blob - mule-packages/lookup/lisp/ndtp.el

   1 ;;; ndtp.el --- Lookup NDTP client
   2 ;; Copyright (C) 1999 Lookup Development Team <lookup@ring.gr.jp>
   3
   4 ;; Author: Keisuke Nishida <kei@psn.net>
   5 ;; Version: $Id: ndtp.el,v 1.4 1999/05/23 17:27:23 knishida Exp $
   6
   7 ;; This file is part of Lookup.
   8
   9 ;; Lookup is free software; you can redistribute it and/or modify it
  10 ;; under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; Lookup is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with Lookup; if not, write to the Free Software Foundation,
  21 ;; Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  22
  23 ;;; Code:
  24
  25 (require 'lookup)
  26
  27 (defconst ndtp-version "1.0")
  28
  29 \f
  30 ;;;
  31 ;:: Internal variables
  32 ;;;
  33
  34 (defvar ndtp-current-agent nil)
  35 (defvar ndtp-current-dictionary nil)
  36 (defvar ndtp-current-process nil)
  37
  38 (defconst ndtp-process-coding-system
  39   (if (featurep 'evi-mule) (evi-coding-system 'euc-jp)))
  40
  41 (put 'ndtp ':methods '(exact prefix suffix))
  42 (put 'ndtp ':gaiji-regexp "<gaiji:\\([^>]*\\)>")
  43 (put 'ndtp ':reference-pattern
  44      '("\\(\e$B"*\e(B\\(\\([^<\n]\\|<gaiji:[^>]*>\\)+\\)\\)?<\\([0-9a-f:]+\\)>"
  45        (or (match-string 1) "(->link)")
  46        (or (match-string 2) (match-string 4)) 4))
  47
  48 (put 'ndtp ':headings '(lookup-arrange-gaijis))
  49
  50 (put 'ndtp ':arranges
  51      '(lookup-arrange-references
  52        lookup-arrange-gaijis
  53        lookup-arrange-squeezed-references
  54        lookup-arrange-default-headings
  55        lookup-arrange-fill-lines))
  56
  57 (put 'ndtp ':adjusts
  58      '(lookup-adjust-show-gaijis
  59        lookup-adjust-check-references
  60        lookup-adjust-goto-min))
  61
  62 ;;;
  63 ;:: types
  64 ;;;
  65
  66 ;; ndtp agent:
  67 ;;
  68 ;;   (ndtp SERVER)
  69 ;;
  70 ;; SERVER  - host name of NDTP server
  71 ;;
  72 ;; [option]
  73 ;; :service - same as SERVICE above
  74 ;; :port    - same as PORT above
  75 ;; :account - same as `ndtp-account-name'
  76 ;;
  77 ;; [property]
  78 ;; ndtp-process - NDTP connection related with agent
  79 ;; ndtp-dict    - last used dictionary
  80
  81 (defalias 'ndtp-agent-server 'lookup-agent-location)
  82
  83 (defun ndtp-agent-service (agent)
  84   (or (lookup-agent-option agent ':port)
  85       (lookup-agent-option agent ':service)
  86       "ndtp"))
  87
  88 (defun ndtp-agent-account (agent)
  89   (or (lookup-agent-option agent ':account)
  90       (concat (user-login-name) "@" (system-name))))
  91
  92 (defun ndtp-agent-coding (agent)
  93   (or (lookup-agent-option agent ':coding)
  94       ndtp-process-coding-system))
  95
  96 ;; ndtp dictionary:
  97 ;;
  98 ;; CODE  - same as NAME below
  99 ;; NAME  - given by server `t' command
 100 ;;
 101 ;; [option]
 102 ;; :coding  - same as `ndtp-process-coding-system'
 103 ;;
 104 ;; [property]
 105 ;; ndtp-gaiji-cache - cache buffer for gaiji datas or `disable' if no support
 106
 107 (defun ndtp-make-dictionary (name title)
 108   (lookup-new-dictionary ndtp-current-agent name name title))
 109
 110 (defun ndtp-dictionary-coding (dictionary)
 111   (or (lookup-dictionary-option dictionary ':coding t)
 112       ndtp-process-coding-system))
 113
 114 ;; ndtp entry:
 115 ;;
 116 ;; CODE    - entry specific code (e.g. "2c00:340") by server `Px' command
 117 ;; HEADING - given by server `Px' command
 118
 119 (defun ndtp-make-entry (code heading)
 120   (lookup-make-entry ndtp-current-dictionary code heading))
 121
 122 ;;;
 123 ;:: macros
 124 ;;;
 125
 126 (put 'ndtp-with-agent 'lisp-indent-function 1)
 127 (defmacro ndtp-with-agent (agent &rest body)
 128   (` (let ((ndtp-current-agent (, agent))
 129            (ndtp-current-process (ndtp-agent-process (, agent))))
 130        (,@ body))))
 131
 132 (put 'ndtp-with-dictionary 'lisp-indent-function 1)
 133 (defmacro ndtp-with-dictionary (dictionary &rest body)
 134   (` (ndtp-with-agent (lookup-dictionary-agent (, dictionary))
 135        (let ((ndtp-current-dictionary (, dictionary)))
 136          (unless (eq (, dictionary)
 137                      (lookup-agent-get-property ndtp-current-agent 'ndtp-dict))
 138            ;; \e$BI,MW$J$H$-$@$1<-=q$r\e(B select \e$B$9$k!#\e(B
 139            ;; \e$B30It%W%m%;%9$H$d$j$H$j$9$k$h$j$3$NJ}$,9bB.$@$m$&$7!"\e(B
 140            ;; \e$B%G%P%C%0$N$H$-%P%C%U%!$,$4$A$c$4$A$c$9$k$N$O$&$6$C$?$$!#\e(B
 141            (ndtp-require-select (, dictionary))
 142            (lookup-agent-put-property ndtp-current-agent 'ndtp-dict
 143                                       (, dictionary))
 144            ;; \e$B<-=qKh$KJ8;z%3!<%I$r@_Dj$9$k!#\e(B
 145            (let ((code (ndtp-dictionary-coding (, dictionary))))
 146              (when code
 147                (set-process-coding-system ndtp-current-process code code))))
 148          (,@ body)))))
 149
 150 (defun ndtp-agent-process (agent)
 151   (let ((process (lookup-agent-get-property agent 'ndtp-process)))
 152     (unless (and process (eq (process-status process) 'open))
 153       (if process (lookup-process-kill process))
 154       (setq process (ndtp-process-open (ndtp-agent-server agent)
 155                                        (ndtp-agent-service agent)))
 156       ;; \e$B:G=i$K<-=q0lMw$rF@$k$N$KJ8;z%3!<%I$N@_Dj$,I,MW!#\e(B
 157       (let ((coding (ndtp-agent-coding agent)))
 158         (when coding
 159           (set-process-coding-system process coding coding)))
 160       ;; \e$B%5!<%P$X$N@\B3Kh$K9T$J$&I,MW$N$"$k=hM}!#\e(B
 161       (let ((ndtp-current-process process))
 162         (ndtp-process-require (concat "A" (ndtp-agent-account agent)) "\n"))
 163       (lookup-foreach
 164        (lambda (dictionary)
 165          (lookup-dictionary-put-property dictionary 'ndtp-gaiji-enable nil))
 166        (lookup-agent-dictionaries agent))
 167       (lookup-agent-put-property agent 'ndtp-process process)
 168       (lookup-agent-put-property agent 'ndtp-dict nil))
 169     process))
 170
 171 (defun ndtp-agent-kill-process (agent)
 172   (let ((process (lookup-agent-get-property agent 'ndtp-process)))
 173     (when process
 174       (if (eq (process-status process) 'open)
 175           (process-send-string process "Q\n"))
 176       (lookup-process-kill process)
 177       (lookup-agent-put-property agent 'ndtp-process nil))))
 178
 179 \f
 180 ;;;
 181 ;:: Interface functions
 182 ;;;
 183
 184 (defconst ndtp-dictionary-regexp
 185   (eval-when-compile
 186     (let ((_ "[ \t]+") (num "[0-9]+") (title ".+") (name "[^ \t\n]+"))
 187       (concat "^ *" num _ "\\(" title "\\)" _ "\\(" name "\\)" _
 188               num _ num _ num "[ \t]*$"))))
 189
 190 (put 'ndtp 'setup 'ndtp-setup)
 191 (defun ndtp-setup (agent)
 192   (ndtp-with-agent agent
 193     (ndtp-process-require "t" "^$\\*\n"
 194       (lambda (process)
 195         (let (name title dicts)
 196           (while (re-search-forward ndtp-dictionary-regexp nil t)
 197             (setq title (match-string 1) name (match-string 2))
 198             (setq dicts (cons (ndtp-make-dictionary name title) dicts)))
 199           (nreverse dicts))))))
 200
 201 (put 'ndtp 'clear 'ndtp-clear)
 202 (defun ndtp-clear (agent)
 203   (ndtp-agent-kill-process agent))
 204
 205 (put 'ndtp 'search 'ndtp-dictionary-search)
 206 (defun ndtp-dictionary-search (dictionary query)
 207   (let ((method (lookup-query-method query))
 208         (string (lookup-query-string query)))
 209     ;; build the search command
 210     (setq string
 211           (if (and (featurep 'mule)
 212                    (memq 'japanese-jisx0208 (find-charset-string string)))
 213               (cond ((eq method 'prefix)
 214                      (concat "Pk" string "*"))
 215                     ((eq method 'suffix)
 216                      (concat "PK" (lookup-reverse-string string) "*"))
 217                     (t (concat "Pk" string)))
 218             (cond ((eq method 'prefix)
 219                    (concat "Pa" string "*"))
 220                   ((eq method 'suffix)
 221                    (concat "PA" (lookup-reverse-string string) "*"))
 222                   (t (concat "Pa" string)))))
 223     ;; search the pattern
 224     (ndtp-with-dictionary dictionary
 225       (ndtp-process-require string "^$[$&N]\n"
 226         (lambda (process)
 227           (let (code heading last-code last-heading entries)
 228             (while (re-search-forward "^[^$].*" nil t)
 229               (if (not heading)
 230                   (setq heading (match-string 0))
 231                 (setq code (match-string 0))
 232                 ;; \e$BF1$8%(%s%H%j$,O"B3$7$F$$$J$$$+%A%'%C%/$9$k!#\e(B
 233                 ;; \e$B$3$l$,$1$C$3$&$"$k$s$@!&!&\e(B
 234                 (when (or (not (string= code last-code))
 235                           (not (string= heading last-heading)))
 236                   (setq entries (cons (ndtp-make-entry code heading) entries))
 237                   (setq last-code code last-heading heading))
 238                 (setq heading nil)))
 239             (nreverse entries)))))))
 240
 241 (put 'ndtp 'content 'ndtp-dictionary-content)
 242 (defun ndtp-dictionary-content (dictionary entry)
 243   (ndtp-with-dictionary dictionary
 244     (let ((command (concat "S" (lookup-entry-code entry))))
 245       (substring (ndtp-process-require command "^$$\n") 3))))
 246
 247 (put 'ndtp 'gaiji 'ndtp-dictionary-gaiji)
 248 (defun ndtp-dictionary-gaiji (dictionary code)
 249   (let ((buffer (lookup-dictionary-get-property dictionary 'ndtp-gaiji-cache)))
 250     (when buffer
 251       (with-current-buffer buffer
 252         (goto-char (point-min))
 253         (if (re-search-forward (format "^$=%s$" code) nil t)
 254             (buffer-substring (point) (or (search-forward "$=" nil t)
 255                                           (point-max))))))))
 256
 257 \f
 258 ;;;
 259 ;:: Internal functions
 260 ;;;
 261
 262 (defun ndtp-require-select (dictionary)
 263   (ndtp-process-require (concat "L" (lookup-dictionary-code dictionary)) "\n")
 264   (and
 265    lookup-enable-gaiji
 266    (lookup-gaiji-glyph-possible-p)
 267    (ndtp-process-require "XL16" "^$.\n")
 268    (let ((buffer (lookup-dictionary-get-property
 269                   dictionary 'ndtp-gaiji-cache)))
 270      (unless buffer
 271        (if (not (string-match "16" (ndtp-process-require "XI" "^$[$N?]\n")))
 272            (setq buffer 'disable)
 273          (setq buffer (generate-new-buffer
 274                        (format " *ndtp gaiji table for %s*"
 275                                (lookup-dictionary-id dictionary))))
 276          (ndtp-process-require "XL16" "^$.\n")
 277          (with-current-buffer buffer
 278            (insert (ndtp-process-require "XB" "^$$\n"))))
 279        (lookup-dictionary-put-property dictionary 'ndtp-gaiji-cache buffer)))))
 280
 281 ;;;
 282 ;:: ndtp process
 283 ;;;
 284
 285 (defun ndtp-process-open (server service)
 286   (lookup-proceeding-message (format "connecting to %s..." server))
 287   (let* ((buffer (lookup-open-process-buffer (concat " *ndtp+" server "*")))
 288          (process (open-network-stream "ndtp" buffer server service)))
 289     (process-kill-without-query process)
 290     process))
 291
 292 (put 'ndtp-process-require 'lisp-indent-function 2)
 293 (defun ndtp-process-require (command separator &optional filter)
 294   (lookup-process-require ndtp-current-process (concat command "\n")
 295                           separator filter))
 296
 297 (provide 'ndtp)
 298
 299 ;;; ndtp.el ends here