;;; simap4-console.el --- An Emacs mode to intractively examine IMAP server.

;; Copyright (C) 2000 Takeshi Morishima

;; Author: Takeshi Morishima
;; Keywords: mail, imap4
;; Version: 1.0

;; GNU Emacs 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.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; This is an implementation of IMAP4 user interface. IMAP4 command
;; can be interactively executed on emacs using simap4.el module.

;;; Code:
(require 'simap4)

(defvar simap4-console-object nil)
(defvar simap4-console-map nil)
(setq simap4-console-map (make-sparse-keymap))
(define-key simap4-console-map "\C-m" 'simap4-console-execute-command)
(define-key simap4-console-map "\C-a" 'simap4-console-beginning-of-line)

(defun simap4-console (arg)
  (interactive "P")
  (let (account server login passwd client-id)
    (setq account (completing-read
		   "Enter client-id:user@server (SPC for completion): "
		   (simap4-console-make-comp-tab)))
    (switch-to-buffer (get-buffer-create (concat "SIMAP4-CONSOLE-" account)))
    (erase-buffer)
    (make-local-variable 'simap4-console-object)
    (if (string-match "^\\([^:]+\\):\\([^@]+\\)@\\([^ \t\n]+\\)$" account)
	(progn
	  (setq client-id (match-string 1 account))
	  (setq login (match-string 2 account))
	  (setq server (match-string 3 account))
	  (setq simap4-console-object
		(simap4-find-object-by-account client-id login server))))
    (if (null simap4-console-object)
	(progn
	  (setq passwd (read-passwd "password: "))
	  (setq simap4-console-object
		(simap4-object-create client-id server login passwd))))
    (setq major-mode 'simap4-console-mode)
    (use-local-map simap4-console-map)
    (insert "-- SIMAP4 Console -- type help for usage.\n")
    (insert "SIMAP4> ")))

(defun simap4-console-make-comp-tab ()
  (mapcar '(lambda (obj) (list (concat (simap4-get-client-id obj) ":"
				       (simap4-get-login obj) "@"
				       (simap4-get-server obj))))
	  *simap4-object-list))

(defconst *simap4-console-imap4-commands
  '("connect" "capability" "noop" "logout" "login" "select" "examine"
    "create" "delete" "rename" "subscribe" "unsubscribe" "list"
    "lsub" "status" "append" "check" "close" "expunge" "search"
    "fetch" "store" "copy"))

(defconst *simap4-console-native-commands
  '("print" "show" "help" "showbuf"))

(defconst simap4-console-print-config
  '(buffer port client-id server login connection-timeout
	   keepalive-interval use-prog-disp calc-throughput))

(defconst simap4-console-print-status
  '(proc selected-mailbox selected-mailbox-read-only state failure-cause
	 current-job job-queue last-job checker-timer command-timeout
	 command-retries))

(defconst simap4-console-print-throughput
  '(use-prog-disp calc-throughput throughput valid-period  invalid-period
		  max-throughput total-bytes total-period expected-size
		  current-size progress))

(defconst simap4-console-print-job-resp
  '(resp-ok resp-no resp-bad resp-preauth resp-bye resp-capability
	    resp-list resp-lsub resp-status resp-search resp-flags
	    resp-exists resp-recent resp-expunge resp-fetch))

(defconst simap4-console-print-job-result
  '(command-string start-point end-point
		   result-code result-resp-code result-explanation
		   start-time end-time checkpoint checktime))

(defun simap4-console-print-attributes (obj &optional attrs)
  (let ((attr-list (append simap4-console-print-config
			   simap4-console-print-status
			   simap4-console-print-throughput))
	attr attr-str value get-func)
    (while attr-list
      (setq attr (car attr-list))
      (setq attr-list (cdr attr-list))
      (if (and (or (null attrs) (member attr attrs)))
	  (progn
	    (setq attr-str (symbol-name attr))
	    (setq get-func (intern (concat "simap4-get-" attr-str)))
	    (setq value (funcall get-func obj))
	    (insert (format "%s: %s\n" attr-str (prin1-to-string value))))))))

(defun simap4-console-print-job-attributes (job &optional attrs)
  (let ((attr-list (append simap4-console-print-job-result
			   simap4-console-print-job-resp))
	attr attr-str value get-func)
    (while attr-list
      (setq attr (car attr-list))
      (setq attr-list (cdr attr-list))
      (if (and (or (null attrs) (member attr attrs)))
	  (progn
	    (setq attr-str (symbol-name attr))
	    (setq get-func (intern (concat "simap4-job-get-" attr-str)))
	    (setq value (funcall get-func job))
	    (insert (format "%s: %s\n" attr-str (prin1-to-string value))))))))

(defun simap4-console-execute-command ()
  (interactive)
  (beginning-of-line)
  (if (looking-at
       "^SIMAP4>[ \t]*\\(\\([^ \t\n]+\\)[ \t]*\\([^\n]*\\)\\)[ \t]*$")
      (let* ((cmd (match-string 2))
	     (args (match-string 3))
	     (cmd-func (intern (concat "simap4-console-cmd-" cmd))))
	(kill-new (match-string 1))
	(goto-char (point-max))
	(if (not (bolp)) (insert "\n"))
	(sit-for 0)
	(cond ((member cmd *simap4-console-imap4-commands)
	       (funcall 'simap4-console-cmd-imap4
			simap4-console-object cmd args))
	      ((member cmd *simap4-console-native-commands)
	       (funcall cmd-func simap4-console-object args))
	      (t (insert "Error: command not found.\n")))))
  (goto-char (point-max))
  (if (not (bolp)) (insert "\n"))
  (insert "SIMAP4> "))

(defun simap4-console-cmd-imap4 (obj cmd args)
  (let ((arg-list (simap4-read (concat "(" args ")")))
	(func (intern (concat "simap4-" cmd))) job)
    (if (functionp func)
	(condition-case data
	    (progn
	      (apply func obj arg-list)
	      (setq job (simap4-get-current-job obj))
	      (if job
		  (simap4-console-print-job-attributes
		   job (append simap4-console-print-job-result
			       simap4-console-print-job-resp))))
	  (error (insert (format "Error: %s\n" (prin1-to-string data)))))
      (insert (format "Error: function not defined %s"
		      (prin1-to-string func))))))

(defun simap4-console-cmd-print (obj args)
  (cond ((or (string= args "all") (string= args ""))
	 (simap4-console-print-attributes obj))
	((string= args "full")
	 (simap4-console-print-attributes obj))
	((string= args "config")
	 (simap4-console-print-attributes obj simap4-console-print-config))
	((string= args "status")
	 (simap4-console-print-attributes obj simap4-console-print-status))
	((string= args "throughput")
	 (simap4-console-print-attributes obj
					  simap4-console-print-throughput))
	((string= args "resp")
	 (let ((job (simap4-get-last-job obj)))
	   (if job (simap4-console-print-job-attributes
		    job simap4-console-print-job-resp))))
	((string= args "result")
	 (let ((job (simap4-get-last-job obj)))
	   (if job (simap4-console-print-job-attributes
		    job simap4-console-print-job-result))))
	(t (insert "Valid arguments are:\nall, full, config, status, resp, result and throughput\n"))))

(defalias 'simap4-console-cmd-show 'simap4-console-cmd-print)

(defun simap4-console-cmd-help (obj args)
  (cond
   ((string= args "")
    (insert (format "Available commands are:\n%s\n"
		    (append *simap4-console-imap4-commands
			    *simap4-console-native-commands))))
   ((and (member args (append *simap4-console-imap4-commands
			      *simap4-console-native-commands))
	 (functionp (intern (concat "simap4-" args))))
    (let* ((function (intern (concat "simap4-" args)))
	   (def (symbol-function function))
	   (arglist (mapcar
		     '(lambda (arg)
			(if (memq arg '(&optional &rest))
			    arg
			  (intern (upcase (symbol-name arg)))))
		     (cond ((byte-code-function-p def)
			    (car (append def nil)))
			   ((eq (car-safe def) 'lambda)
			    (nth 1 def))))))
      (insert (format "Function syntax: %s\n\n" (cons function arglist)))
      (insert (format "%s\n\n" (or (documentation function) "Not documented")))
      (insert (format "Console syntax: %s %s\n\n" args
		      (mapconcat '(lambda (arg) (format "%s" arg))
				 (cdr arglist) " ")))))
   (t (insert "Help not available.\n"))))

(defun simap4-console-cmd-showbuf (obj args)
  (let ((curbuf (current-buffer)))
    (switch-to-buffer-other-window (simap4-get-buffer obj))
    (goto-char (point-max))
    (select-window (get-buffer-window curbuf))))

(defun simap4-console-beginning-of-line ()
  (interactive)
  (beginning-of-line)
  (if (looking-at "SIMAP4> ")
      (goto-char (match-end 0))))

(provide 'simap4-console)
