;;; ndtp.el --- low-level IO from/to ndtp server

;; Author: YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
;; Created: 9 Dec 1997
;; Version: 1.1beta
;;
;; This program 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 2, or (at your option)
;; any later version.
;;
;; This program 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 this program; if not, you can either send email to this
;; program's author (see above or write to:
;;
;;              The Free Software Foundation, Inc.
;;              675 Mass Ave.
;;              Cambridge, MA 02139, USA.
;;

;;; Commentary:
;;
;; Note:
;;   Input from a ndtp server is not decoded at all, while output to
;;   the server is encoded with Japanese EUC coding.  Code conversion
;;   of the input (i.e., of the process output) should be done by hand.
;;
;; TODO:
;;   more robust error handling
;;   frame-by-line?
;;

;;; Code:

;;;; global variables
(defconst ndtp-version "1.1beta")
(defvar ndtp-buffer-name " *ndtp*")
(defvar ndtp-default-service "ndtp")
;;;(defvar ndtp-warning-buffer-name "*ndtp Warning*")
(defvar ndtp-open-hook nil)
(defvar ndtp-close-hook nil)
(defvar ndtp-close-connection-timeout 2)
(defvar ndtp-log-flag nil)
(defvar ndtp-log-buffer-name-format "*%s Log*")

;;;; buffer-local variables
(defvar ndtp-process)
(defvar ndtp-command-queue)
(defvar ndtp-reader)
(defvar ndtp-result)
(defvar ndtp-status)
(defvar ndtp-error-handler 'ndtp-default-error-handler)

;;;;
(defconst ndtp-emacs-major-version
  (cond ((boundp 'epoch::version)
	 18)
	((boundp 'emacs-major-version)
	 emacs-major-version)
	(t
	 (string-match "^[0-9]+" emacs-version)
	 (string-to-int
	  (substring emacs-version (match-beginning 0) (match-end 0))))))

(defconst ndtp-mule-version
  (cond ((boundp 'mule-version)
	 (string-to-int mule-version))
	((and (featurep 'mule)
	      (string-match "XEmacs\\|Lucid" emacs-version))
	 3)
	(t
	 0)))

;;;; functions and macros for a ndtp command
;;; meanings of elements of a command at each phase:
;;; ---------+------------------------------------------------------
;;;  \ place | (nth 0 command)    (nth 1 command)    (nth 2 command)
;;; phase \  |  aka `process'      aka `result'       aka `string'
;;; ---------+------------------------------------------------------
;;; waiting  |    process (initial reader . callback)     string
;;; running  |    process           callback              string
;;; finished |    status             result               string
;;; ---------+------------------------------------------------------
;;; where
;;;   process:	Subprocess object by which the command communicates.
;;;   string:	String to be sent to the process.
;;;   status:	Command status.  Typically 't or ('error . error-string).
;;;   initial:	Initial value for `ndtp-result'.
;;;   result:	Final value of `ndtp-result'.
;;;   callback:	Function called when the command finished.
;;;		It takes a command as its argument.
;;;		Symbol `nil' means the command was called synchronously.
;;;		Symbol `t' means no callback needed.
;;;   reader:	Reader that interprets the process output.
(defun ndtp-make-command (string process result)
  (list process result string))

(defmacro ndtp-command-process (command)
  (` (car (, command))))

(defmacro ndtp-command-result (command)
  (` (car (cdr (, command)))))

(defmacro ndtp-command-string (command)
  (` (car (cdr (cdr (, command))))))

(defmacro ndtp-set-command-process (command process)
  (` (setcar (, command) (, process))))

(defmacro ndtp-set-command-result (command result)
  (` (setcar (cdr (, command)) (, result))))

;;;; Auxiliary functions
(defun ndtp-setup-coding-system (process)
  (set-process-coding-system process '*noconv* '*euc-japan*unix))
(cond ((boundp 'MULE))			; see above
      ((featurep 'mule)
       (if (string-match "XEmacs\\|Lucid" emacs-version)
           (fset 'ndtp-setup-coding-system
                 (function
                  (lambda (process)
                    (set-process-input-coding-system process 'no-conversion)
                    (set-process-output-coding-system process 'euc-jp-unix))))
         (fset 'ndtp-setup-coding-system
               (function
                (lambda (process)
                  (set-process-coding-system
		   process 'no-conversion 'euc-jp-unix))))))
      ((boundp 'NEMACS)
       (fset 'ndtp-setup-coding-system
	     (function
	      (lambda (process) (set-process-kanji-code process 0)))))
      (t
       (fset 'ndtp-setup-coding-system
	     (function (lambda (process))))))

(defun ndtp-get-log-buffer (process)
  (get-buffer-create
   (format ndtp-log-buffer-name-format (process-name process))))

;;;; Functions which change the status of a command
;;; -> waiting
(defun ndtp-enqueue-command (process string initial reader callback)
  (setq string
	(ndtp-make-command
	 string process (cons initial (cons reader callback))))
  ;; now `string' is a command
  (save-excursion
    (set-buffer (process-buffer process))
    (if (null (prog1 ndtp-command-queue
		(setq ndtp-command-queue
		      (nconc ndtp-command-queue (list string)))))
	(ndtp-send-first-command))
    (if callback
	string				; asynchronous
      (ndtp-wait-command string))))	; synchronous

;;; waiting -> running
(defun ndtp-send-first-command ()
  (let ((command (car ndtp-command-queue)))
    ;; Looks slightly complicated but is equivalent to
    ;; (let ((tmp (ndtp-command-result command)))
    ;;   (setq ndtp-result (car tmp))
    ;;   (setq ndtp-reader (car (cdr tmp)))
    ;;   (ndtp-set-command-result command (cdr (cdr tmp)))),
    ;; and will produce a faster bytecode.
    ;; Note:
    ;;   byte-opt.el in Emacs 20.2 (and maybe former version) doesn't
    ;;   optimize
    ;;     dup (varset ndtp-result) dup (varref ndtp-result)
    ;;   to
    ;;     dup (varset ndtp-result) dup dup
    (ndtp-set-command-result
     command
     (cdr (cdr				; callback
	   (prog1
	       (setq ndtp-result	; (initial reader . callback)
		     (ndtp-command-result command))
	     (setq ndtp-reader		; reader
		   (car (cdr (prog1 ndtp-result
			       (setq ndtp-result ; initial
				     (car ndtp-result))))))))))
    (setq ndtp-status t)
    (if ndtp-log-flag
	(save-excursion
	  (set-buffer (ndtp-get-log-buffer ndtp-process))
	  (goto-char (point-max))
	  (insert "\n\f " (ndtp-command-string command))))
    (process-send-string ndtp-process (ndtp-command-string command))))

;;; running -> finished
(defun ndtp-dequeue-command ()
  (let ((command (car (prog1 ndtp-command-queue
			(setq ndtp-command-queue
			      (cdr ndtp-command-queue))))))
    (if (> (buffer-size) 0)
	(funcall ndtp-error-handler 'unexpected-output
		 (prog1 (buffer-string) (erase-buffer))))
    ;; Store the current result and status into the command, and then
    ;; go next.
    (let ((callback (ndtp-command-result command)))
      (ndtp-set-command-result command ndtp-result)
      (ndtp-set-command-process command ndtp-status)
      ;; Send the next command prior to a call of the current callback
      ;; so as to send a command as soon as possible.  (The callback
      ;; may take much time, and even worse, it may cause an error.)
      ;; As a result, the callback cannot change `ndtp-command-queue'
      ;; in order to change the very next command of the current one.
      ;; Should this behavior be changed?
      (if ndtp-command-queue
	  (ndtp-send-first-command))
      (if (and callback (not (eq callback t)))
	  (save-excursion
	    (condition-case nil
		(funcall callback command)
	      (error nil)))))))

;;;;
;;;###autoload
(defun ndtp-open (host &optional service)
  (let* ((buffer
	  ;; In Emacs 20.2, `open-network-stream' doesn't try to find
	  ;; process-coding-system of the process if
	  ;; `enable-multibyte-characters' is nil in the process
	  ;; buffer.  So we turn off this flag in advance.
	  (let ((default-enable-multibyte-characters nil)
		default-mc-flag default-kanji-flag)
	    (generate-new-buffer ndtp-buffer-name)))
	 (process
	  (condition-case err
	      (open-network-stream "ndtp" buffer host
				   (or service ndtp-default-service))
	    (file-error (progn
			  (kill-buffer buffer)
			  (signal (car err) (cdr err)))))))
    (prog1 process
      (ndtp-initialize-buffer process)
      (set-process-filter process 'ndtp-filter)
      (set-process-sentinel process 'ndtp-sentinel)
      (process-kill-without-query process)
      (ndtp-setup-coding-system process)
      (run-hooks 'ndtp-open-hook))))

(defun ndtp-close (process &optional no-query)
  (save-excursion
    (set-buffer (process-buffer process))
    (if ndtp-command-queue
	(if (or no-query
		;; should show some helps here.
		(y-or-n-p (format "Connection %s is busy.  Close anyway?"
				  (process-name process))))
	    (progn
	      (run-hooks 'ndtp-close-hook)
	      (delete-process process)
	      (kill-buffer (current-buffer))))
      (run-hooks 'ndtp-close-hook)
      (process-send-string process "Q\n")
      (if (>= ndtp-emacs-major-version 19)
	  (if (null (accept-process-output process
					   ndtp-close-connection-timeout))
	      (if (or no-query
		      (y-or-n-p
		       (format "Connection %s won't close.  Forcibly close?"
			       (process-name process))))
		  (progn
		    (delete-process process)
		    (kill-buffer (current-buffer)))))
	;; we don't have timeout argument for `access-process-output'
	(message "waiting for connection %s to close (C-g to forcibly close) ..."
		 (process-name process))
	(condition-case nil
	    (accept-process-output process)
	  (quit
	   (delete-process process)
	   (kill-buffer (current-buffer))
	   (setq quit-flag nil)))
	(message "")))))

(defun ndtp-filter-1 (process string)
  ;; In Emacs 20.4, a process filter receives a null string when the
  ;; process closes its connection.
  (if (not (string= string ""))
      (let ((old-buffer (current-buffer)))
	(unwind-protect
	    (progn
	      (set-buffer (process-buffer process))
	      (goto-char (point-max))
	      (insert string)
	      (if ndtp-log-flag
		  (save-excursion
		    (set-buffer (ndtp-get-log-buffer process))
		    (goto-char (point-max))
		    (insert string)))
	      (goto-char 1)
	      (if (null ndtp-command-queue)
		  (funcall ndtp-error-handler 'unexpected-output
			   (prog1 (buffer-string) (erase-buffer)))
		(while (and (consp ndtp-reader)
			    (setq string (eval (car (car ndtp-reader)))))
		  ;; now `string' is either a new reader or an
		  ;; end-of-string point.
		  (setq ndtp-reader
			(if (not (integer-or-marker-p string))
			    string
			  (cdr (prog1 ndtp-reader
				 (if (not (eq (cdr (car ndtp-reader)) t))
				     (setq ndtp-result
					   (save-excursion
					     (save-restriction
					       (narrow-to-region 1 string)
					       (funcall (cdr (car ndtp-reader))
							ndtp-result)))))
				 (delete-region 1 (point)))))))
		(if (not (consp ndtp-reader))
		    (ndtp-dequeue-command))))
	  (if (buffer-name old-buffer)
	      (set-buffer old-buffer))))))

(defun ndtp-filter (process string)
  (let ((old-match-data (match-data)))
    (unwind-protect
	(ndtp-filter-1 process string)
      (store-match-data old-match-data)))) ; Emacs 18
(cond ((and (not (string-match "XEmacs\\|Lucid" emacs-version))
	    (string-match "\\`20\\.3\\.\\([^.]*\\'\\|9.*\\.\\)"
			  emacs-version))
       ;; In Emacs 20.3, process-filter may receive a multibyte string
       ;; even if no code conversion is applied to the process outout.
       (fset 'ndtp-filter
	     (function
	      (lambda (process string)
		(ndtp-filter-1 process (string-as-unibyte string))))))
      ((> ndtp-emacs-major-version 18)
       (fset 'ndtp-filter (symbol-function 'ndtp-filter-1))))

(defun ndtp-sentinel (process event)
  (save-excursion
    (set-buffer (process-buffer process))
    (if (not (eq (process-status process) 'closed))
	(funcall ndtp-error-handler 'status-change event)
      (if (null ndtp-command-queue)
	  ;; normal exit; possibly timeout.
	  (funcall ndtp-error-handler 'exit event)
	(funcall ndtp-error-handler 'abnormal-exit event))
      (delete-process process)
      (kill-buffer (current-buffer)))))

(defun ndtp-initialize-buffer (process)
  (save-excursion
    (set-buffer (process-buffer process))
    (erase-buffer)
    (kill-all-local-variables)
    ;; Mule 1.x fails to protect the value of `mc-flag' because
    ;; (let (default-mc-flag)
    ;;	 (save-excursion
    ;;	   (set-buffer (generate-new-buffer "foo"))
    ;;	   (assq 'mc-flag (buffer-local-variables))))
    ;; results to `nil' and `kill-all-local-variables' tries to
    ;; set `mc-flag' to its default value.
    (if (boundp 'mc-flag) (setq mc-flag nil))
    (set (make-local-variable 'ndtp-process) process)
    (set (make-local-variable 'ndtp-command-queue)
	 (set (make-local-variable 'ndtp-reader)
	      (set (make-local-variable 'ndtp-result)
		   (set (make-local-variable 'ndtp-status) nil))))
    (make-local-variable 'ndtp-error-handler)
    (setq case-fold-search nil)
    (set-marker (process-mark process) 1)))

(defun ndtp-set-error-handler (process func)
  (save-excursion
    (set-buffer (process-buffer process))
    (setq ndtp-error-handler func)))

;;; not completed yet.
(defun ndtp-default-error-handler (type event)
  (cond ((eq type 'error)
	 (setq ndtp-status (cons type event)))
	((eq type 'unexpected-output)
	 (message "ndtp: unexpected output %s" event))
	((eq type 'status-change)
	 ;; ignore
	 )
	((eq type 'exit)
	 ;; ignore
	 )
	((eq type 'abnormal-exit)
	 ;; SHOULD DUMP
	 )))

;;;; Process output clippers.
;;; Meaning of the return value:
;;;   nil ... Further process output is needed for clipping.
;;;   integer-or-marker ...
;;;           The end point of region which will be processed by a
;;;           picker.  In this case, the clipper should move the
;;;           current point to the end point of the region which will
;;;           be deleted.
;;;   otherwise ...
;;;           The return value is a reader which will be used as a
;;;           continuation.
;;; One can use the process-mark as a place holder; typically the
;;; starting place where the next guard will be examined (see
;;; `ndtp-clip-block').
(defun ndtp-clip-line (&optional n)
  (if (search-forward "\n" nil t n)
      (1- (point))
    nil))

(defun ndtp-clip-block (regexp offset)
  (goto-char (process-mark ndtp-process))
  (if (re-search-forward regexp nil t)
      (goto-char (match-beginning 0))	; returns (match-beginning 0)
    ;; `offset' specifies how many points we should go back for the next time
    (set-marker (process-mark ndtp-process) (- (point-max) offset))
    nil))

(defun ndtp-clip-string (n)
  (if (>= (buffer-size) n)
      (goto-char (1+ n))		; returns (1+ n)
    nil))

(defun ndtp-lookahead-header (reader)
  (if (and (eq (or (char-after 1) ?$) ?$)
	   (memq (char-after 2) '(?? ?N ?< ?^ ?& nil)))
      (if (>= (buffer-size) 2)
	  ;; handle error ... skip the current command and replace it
	  ;;                  with an error handler
	  reader
	;; otherwise, we cannot determine ... stay
	nil)
    ;; not error ... proceed
    1))

(defun ndtp-lookahead-loop (reader)
  (if (and (eq (or (char-after 1) ?$) ?$)
	   (eq (or (char-after 2) ?$) ?$)
	   (eq (or (char-after 3) ?\n) ?\n))
      (if (>= (buffer-size) 3)
	  ;; surely "$$\n" ... proceed
	  1
	;; otherwise, we cannot determine ... stay
	nil)
    ;; must not "$$\n" ... extract loop contents and proceed
    reader))

(defun ndtp-lookahead-loop-titles (reader)
  (if (and (eq (or (char-after 1) ?$) ?$)
	   (eq (or (char-after 2) ?*) ?*)
	   (eq (or (char-after 3) ?\n) ?\n))
      (if (>= (buffer-size) 3)
	  ;; surely "$*\n" ... proceed
	  1
	;; otherwise, we cannot determine ... stay
	nil)
    ;; must not "$*\n" ... extract loop contents and proceed
    reader))

;;;; default pickers
;;; A picker takes the current value of `ndtp-result' as an argument
;;; and returns its new value.  Typically it consumes a visible part
;;; (i.e., narrowed region) of the current buffer.  Pickers can
;;; modify the visible part but should not do so about the outside of
;;; this part.
(defun ndtp-pick-header (result)
  (if (> (point-max) 1)
      (funcall ndtp-error-handler 'error
	       (let ((char (char-after 2)))
		 (cond ((eq char ??) "command syntax error.")
		       ((eq char ?N) "no access permission.")
		       ((eq char ?<) "dictionary not selected.")
		       ((eq char ?^)
			(format "server internal error `%s'."
				(buffer-substring 3 (point-max))))
		       ((eq char ?&) "can't execute command."))))
    ;; do nothing if the clipped region is empty.
    )
  result)

(defun ndtp-pick-set (result)
  (buffer-string))

(defun ndtp-pick-add (result)
  (cons (buffer-string) result))

;;(defun ndtp-pick-nreverse (result)
;;  (nreverse result))

;;; Create a circular data structure in order to implement a loop
;;; construct.
(defun ndtp-make-reader (sequence &optional cont)
  (if (null sequence)
      ;; We use `t' as an end mark of a reader so that `lookahead'
      ;; functions may not return 'nil' as a reader; 'nil' means `more
      ;; input required'.
      (or cont t)
    (setq cont (ndtp-make-reader (cdr sequence) cont))
    (let ((inst (car sequence)))
      (cond ((eq (car inst) 'if)
	     (cons
	      (` (((,@ (nth 1 inst))
		   (quote (, (ndtp-make-reader (nth 2 inst) cont))))
		  (,@ t)))		; . t  -->  (,@ t)
	      (ndtp-make-reader (nthcdr 3 inst) cont)))
	    ((eq (car inst) 'while)
	     (prog1 (setq cont (cons (cons
				      (append (nth 1 inst) '()) ; make a copy
				      t)
				     cont))
	       (nconc (car (car cont))
		      (list (list 'quote
				  (ndtp-make-reader (nthcdr 2 inst) cont))))))
	    (t
	     (cons inst cont))))))

(defun ndtp-add-header-reader (reader)
  (` ((if (ndtp-lookahead-header)
	  ;; . ndtp-pick-header  -->  (,@ 'ndtp-pick-header)
	  (((ndtp-clip-line) (,@ 'ndtp-pick-header)))
	(,@ reader)))))

;;;; default readers construction functions
(defun ndtp-make-line-reader (&optional pick)
  (ndtp-make-reader
   (ndtp-add-header-reader
    ;; . (, (or pick 'ndtp-pick-set))  -->  (,@ (or pick 'ndtp-pick-set))
    (` (((ndtp-clip-line) (,@ (or pick 'ndtp-pick-set)))))
    )))

;;; Some dservers send bogus `dictnum=...' lines before `$A\n'.  Here
;;; is work-around for this.  (Otherwise, one can use
;;; `ndtp-line-reader' as a reader for `ndtp-get-access-permission')
(defun ndtp-make-access-reader (&optional pick)
  (ndtp-make-reader
   (` (((ndtp-clip-block "^\\$[?AN<^&]\n" 2) (,@ t))
       (,@ (ndtp-add-header-reader
	    (` (((ndtp-clip-line) (,@ (or pick 'ndtp-pick-set)))))))))))

(defun ndtp-make-version-reader (&optional pick)
  (ndtp-make-reader
   (ndtp-add-header-reader
    (` (((ndtp-clip-string 2) (,@ t))
	((ndtp-clip-line) (,@ (or pick 'ndtp-pick-set))))))))

(defun ndtp-make-lines-reader (&optional pick-start pick-entry pick-end)
  (ndtp-make-reader
   (ndtp-add-header-reader
    (` (((ndtp-clip-line) (,@ (or pick-start t)))
	(while (ndtp-lookahead-loop)
	  ((ndtp-clip-line) (,@ (or pick-entry 'ndtp-pick-add))))
	((ndtp-clip-line) (,@ (or pick-end   'nreverse))))))))

(defun ndtp-make-2lines-reader (&optional pick-start pick-entry pick-end)
  (ndtp-make-reader
   (ndtp-add-header-reader
    (` (((ndtp-clip-line) (,@ (or pick-start t)))
	(while (ndtp-lookahead-loop)
	  ((ndtp-clip-line 2) (,@ (or pick-entry 'ndtp-pick-add))))
	((ndtp-clip-line) (,@ (or pick-end   'nreverse))))))))

(defun ndtp-make-body-reader (&optional pick-start pick-body pick-end)
  (ndtp-make-reader
   (ndtp-add-header-reader
    (` (((ndtp-clip-line) (,@ (or pick-start t)))
	((ndtp-clip-block "^\\$\\$\n" 2)
			  (,@ (or pick-body  'ndtp-pick-set)))
	((ndtp-clip-line) (,@ (or pick-end   t))))))))

(defun ndtp-make-frame-reader (&optional pick-start pick-frame pick-end)
  (ndtp-make-reader
   (ndtp-add-header-reader
    (` (((ndtp-clip-string    2) (,@ (or pick-start t)))
	((ndtp-clip-string 2048) (,@ (or pick-frame 'ndtp-pick-set)))
	((ndtp-clip-string    1) (,@ (or pick-end   t))))))))

(defun ndtp-make-titles-reader (&optional pick-entry pick-end)
  (ndtp-make-reader
   (ndtp-add-header-reader
    (` ((while (ndtp-lookahead-loop-titles)
	  ((ndtp-clip-line) (,@ (or pick-entry 'ndtp-pick-add))))
	((ndtp-clip-line) (,@ (or pick-end   'nreverse))))))))

;;;; default readers
(defconst ndtp-line-reader    (ndtp-make-line-reader))
(defconst ndtp-access-reader  (ndtp-make-access-reader))
(defconst ndtp-version-reader (ndtp-make-version-reader))
(defconst ndtp-lines-reader   (ndtp-make-lines-reader))
(defconst ndtp-2lines-reader  (ndtp-make-2lines-reader))
(defconst ndtp-body-reader    (ndtp-make-body-reader))
(defconst ndtp-frame-reader   (ndtp-make-frame-reader))
(defconst ndtp-titles-reader  (ndtp-make-titles-reader))

;;; nil ... waiting.  run ... running.
;;; t ... normally finished.  (error . STRING) ... error occured.
;;; closed ... connection closed before command finished.
(defun ndtp-command-status (command)
  (let ((process (ndtp-command-process command)))
    (if (processp process)
	(if (eq (process-status process) 'open)
	    (save-excursion
	      (set-buffer (process-buffer process))
	      (if (eq (car ndtp-command-queue) command) 'run nil))
	  'closed)
      process)))

(defun ndtp-wait-command (command)
  (while (processp (ndtp-command-process command))
    (accept-process-output (ndtp-command-process command)))
  command)

(defun ndtp-busy-p (process)
  (save-excursion
    (set-buffer (process-buffer process))
    (not (null ndtp-command-queue))))

;;; `A' command
(defun ndtp-get-access-permission (process &optional initial reader callback)
  (ndtp-enqueue-command process
			(format "A%s@%s\n" (user-login-name) (system-name))
			initial (or reader ndtp-access-reader) callback))

;;; `L' command
(defun ndtp-get-dictionary (process dictname &optional initial reader callback)
  (ndtp-enqueue-command process (format "L%s\n" dictname)
			initial (or reader ndtp-line-reader) callback))

;;; `v' command
(defun ndtp-get-version (process &optional initial reader callback)
  (ndtp-enqueue-command process "v\n"
			initial (or reader ndtp-version-reader) callback))

;;; `P' command
(defun ndtp-get-entries (process type pattern
				 &optional initial reader callback)
  (ndtp-enqueue-command process (format "P%c%s\n" type pattern)
			initial (or reader ndtp-2lines-reader) callback))

;;; `I' command
(defun ndtp-get-index (process &optional initial reader callback)
  (ndtp-enqueue-command process "I\n"
			initial (or reader ndtp-lines-reader) callback))

;;; `S' command
(defun ndtp-format-S-command (fno)
  (cond ((integerp fno)
	 (format "S%x:0\n" fno))
	((consp fno)
	 (format "S%x:%x\n" (car fno) (or (cdr fno) 0)))
	(t
	 (format "S%s\n" fno))))

(defun ndtp-get-body (process fno &optional initial reader callback)
  (ndtp-enqueue-command process (ndtp-format-S-command fno)
			initial (or reader ndtp-body-reader) callback))

(defun ndtp-get-body-by-line (process fno &optional initial reader callback)
  (ndtp-enqueue-command process (ndtp-format-S-command fno)
			initial (or reader ndtp-lines-reader) callback))

;;; `F' command
(defun ndtp-get-frame (process fno &optional initial reader callback)
  (if (and (integerp fno) (> fno 0))
      (ndtp-enqueue-command process (format "F%x\n" fno)
			    initial (or reader ndtp-frame-reader) callback)
    (ndtp-make-command
     "" '(error . "Frame number must be positive.") initial)))

;;; `T' command
(defun ndtp-get-titles-briefly (process &optional initial reader callback)
  (ndtp-enqueue-command process "T\n"
			initial (or reader ndtp-titles-reader) callback))

;;; `t' command
(defun ndtp-get-titles (process &optional initial reader callback)
  (ndtp-enqueue-command process "t\n"
			initial (or reader ndtp-titles-reader) callback))

;;;; Some useful functions
;;; NEmacs needs no code conversions because its internal code is
;;; actually (a subset of) EUC-JP.
(defun ndtp-decode-euc-jp-string (string)
  (code-convert-string string '*euc-japan* '*internal*))
(cond ((boundp 'MULE))			; see above
      ((featurep 'mule)
       (fset 'ndtp-decode-euc-jp-string
	     (function
	      (lambda (string)
		(decode-coding-string string 'euc-jp)))))
      (t
       (fset 'ndtp-decode-euc-jp-string
	     (function (lambda (string) string)))))

(defun ndtp-decode-euc-jp-region (b e)
  (code-convert-region b e '*euc-japan* '*internal*))
(cond ((boundp 'MULE))			; see above
      ((featurep 'mule)
       (fset 'ndtp-decode-euc-jp-region
	     (function
	      (lambda (b e)
		(decode-coding-region b e 'euc-jp)))))
      (t
       (fset 'ndtp-decode-euc-jp-region (function (lambda (b e))))))

(defun ndtp-insert-and-decode-euc-jp (string)
  (code-convert-region (point) (progn (insert string) (point))
		       '*euc-japan* '*internal*))
(cond ((boundp 'MULE))			; see above
      ((>= ndtp-mule-version 4)
       ;; (fboundp 'string-as-multibyte) may be foiled by `emu'
       ;; package.
       (fset 'ndtp-insert-and-decode-euc-jp
	     (function
	      (lambda (string)
		(decode-coding-region
		 (point)
		 (progn (insert (string-as-multibyte string)) (point))
		 'euc-jp)))))
      ((featurep 'mule)
       (if (string-match "XEmacs\\|Lucid" emacs-version)
	   ;; In XEmacs, `decode-coding-region' moves the current
	   ;; point to the beginning of the decoded region.
	   ;; Unfortunately `save-excursion' does not help.
	   (fset 'ndtp-insert-and-decode-euc-jp
		 (function
		  (lambda (string)
		    (decode-coding-region
		     (point) (prog2 (insert string)
				 (setq string (point-marker))
			       (set-marker-insertion-type string t))
		     'euc-jp)
		    (goto-char string))))
	 (fset 'ndtp-insert-and-decode-euc-jp
	       (function
		(lambda (string)
		  (decode-coding-region
		   (point)
		   (progn (insert string) (point)) 'euc-jp))))))
      (t
       (fset 'ndtp-insert-and-decode-euc-jp
	     (function (lambda (string) (insert string))))))

(defun ndtp-parse-dserver-env (&optional warning-ostream)
  (let ((str (getenv "DSERVER")))
    (if (null str)
	nil
      (let ((start 0) comma colon
	    server-list a-server host service)
	(while
	    (prog1 (setq comma (string-match "," str start))
	      (setq a-server (substring str start comma))
	      (setq colon (string-match ":" a-server))
	      (setq host (substring a-server 0 colon))
	      (cond ((string= host "")
		     (if warning-ostream
			 (princ "Warning: null entry in `DSERVER' env.\n"
				warning-ostream)))
		    (colon
		     (setq service (substring a-server (1+ colon)))
		     (if (string-match "\\`[0-9]+\\'" service)
			 (setq service (string-to-number service)))
		     (setq server-list (cons (cons host service) server-list)))
		    (t			; no port or service part
		     (setq server-list (cons host server-list)))))
	  (setq start (1+ comma)))
	(nreverse server-list)))))

(defun ndtp-guess-server-implementation (process)
  (if (string-match "\\`ndtpd"
		    (ndtp-command-result (ndtp-get-version process)))
      'ndtpd
    'dserver))

;;;; The remaining part is experimental.  It is likely to be changed
;;;; its specification.
(defun ndtp-pick-add-expr (result)
  (goto-char (point-min))
  (cons (read (current-buffer)) result))

(defconst ndtp-expr-lines-reader
  (ndtp-make-lines-reader nil 'ndtp-pick-add-expr nil))

;;; `XI' command
(defun ndtp-get-gaiji-sizes (process &optional initial reader callback)
  (ndtp-enqueue-command process "XI\n"
			initial (or reader ndtp-expr-lines-reader) callback))

;;; `XL' command
(defun ndtp-select-gaiji-size (process size &optional initial reader callback)
  (ndtp-enqueue-command process (format "XL%d\n" size)
			initial (or reader ndtp-line-reader) callback))

(defun ndtp-pick-id (result)
  (cons (buffer-substring 3 (point-max)) result))

(defun ndtp-pick-bitmap (result)
  (prog1 result
    (setcar result (cons (car result) (buffer-string)))))

(defun ndtp-make-bitmaps-reader (&optional pick-start pick-id
					   pick-bitmap pick-end)
  (ndtp-make-reader
   (ndtp-add-header-reader
    (` (((ndtp-clip-line) (,@ (or pick-start t)))
	(while (ndtp-lookahead-loop)
	  ((ndtp-clip-line) (,@ (or pick-id 'ndtp-pick-id)))
	  ((ndtp-clip-block "^\\$\\(\\$\n\\|=\\)" 2)
			    (,@ (or pick-bitmap 'ndtp-pick-bitmap))))
	((ndtp-clip-line) (,@ (or pick-end   'nreverse))))))))

(defconst ndtp-bitmaps-reader (ndtp-make-bitmaps-reader))

;;; `Xb' and `XB' command
(defun ndtp-get-gaiji-bitmap (process id &optional initial reader callback)
  (if (stringp id)
      (ndtp-enqueue-command process (format "Xb%s\n" id)
			    initial (or reader ndtp-body-reader) callback)
    (ndtp-enqueue-command process "XB\n"
			  initial (or reader ndtp-bitmaps-reader) callback)))

(provide 'ndtp)

;;; ndtp.el ends here
