;;
;;; Commentary:
-;; Some codes are based on imap.el.
+;;
+;; acap.el is an elisp library providing an interface for talking to
+;; ACAP (RFC2244) servers.
+;;
+;; This is a transcript of short interactive session for demonstration
+;; purposes.
+
+;; (setq proc (acap-open "my.acap.server" "username" "CRAM-MD5"))
+;; => #<process ACAP>
+;;
+;; (acap-search proc "/addressbook/" '((RETURN ("*")))))
+;; => ((done-ok nil "search completed")
+;; (modtime . "20010828091433000010")
+;; (entry "user"
+;; ((("subdataset"
+;; ("."))
+;; ("modtime" "20010824004532000003")
+;; ("entry" "user"))))
+;; (entry ""
+;; ((("modtime" "20010824004532000002")
+;; ("entry" "")
+;; ("dataset.owner" "anonymous")
+;; ("dataset.acl" ("$anyone xrwia")))))
+;;
+;; (acap-close proc)
+;; => t
+;;
+;; Todo:
+;; * Send literal data for STORE.
;;; History:
-;;
+;;
+;; 27 Aug 2001 Created (Some codes are based on imap.el.).
;;; Code:
-(eval-when-compile
- (require 'cl)
- (require 'static))
+(eval-when-compile (require 'cl))
(require 'pces)
(require 'sasl)
(defvar acap-response nil
"ACAP Response.")
+(defvar acap-logging-out nil
+ "Non-nil when ACAP is logging out.")
+
(make-variable-buffer-local 'acap-state)
(make-variable-buffer-local 'acap-auth)
(make-variable-buffer-local 'acap-capability)
(make-variable-buffer-local 'acap-server)
(make-variable-buffer-local 'acap-port)
(make-variable-buffer-local 'acap-response)
+(make-variable-buffer-local 'acap-logging-out)
(defvar acap-network-stream-alist
'((default . open-network-stream-as-binary)))
(defvar acap-passphrase-alist nil)
+(eval-and-compile
+ (autoload 'ange-ftp-read-passwd "ange-ftp"))
+
(defun acap-read-passphrase (prompt)
"Prompt is not used."
(or acap-passphrase
(if (functionp 'read-passwd)
(read-passwd prompt)
(if (load "passwd" t)
- (read-passwd prompt))))))
+ (read-passwd prompt)
+ (ange-ftp-read-passwd prompt))))))
;;; Debug.
(defvar acap-debug t)
(delq (assoc key acap-passphrase-alist)
acap-passphrase-alist))))
-;;; Open, Close
-(defun acap-open (user server &optional auth port type)
- (let* ((buffer (get-buffer-create (concat " *acap on " user " at " server)))
+;;; Open, Close
+(defun acap-open (server &optional user auth port type)
+ (let* ((user (or user acap-default-user))
+ (buffer (get-buffer-create (concat " *acap on " user " at " server)))
process passphrase mechanism tag)
(with-current-buffer buffer
+ (erase-buffer)
(if acap-process
(delete-process acap-process))
(setq process (acap-network-stream-open buffer server port type)
acap-process process)
- (erase-buffer)
(set-buffer-multibyte nil)
(buffer-disable-undo)
(setq acap-state 'initial)
(defun acap-close (process)
(with-current-buffer (process-buffer process)
+ (setq acap-logging-out t)
(unless (acap-response-ok-p (acap-send-command-wait process "LOGOUT"))
(message "Server %s didn't let me log out" acap-server))
(when (memq (process-status process) '(open run))
(defun acap-store (process entries)
"Execute STORE command on PROCESS.
ENTRIES is a store-entry list."
- (acap-send-command-wait process (concat "STORE " (prin1-to-string entries))))
+ (with-temp-buffer
+ ;; As far as I know, current implementation of ACAP server
+ ;; (cyrus-smlacapd 0.5) does not accept literal argument for STORE.
+ ;; If literal argument is available, command arguments can be sent using
+ ;; function `acap-send-command-wait'.
+ (set-buffer-multibyte nil)
+ (insert "STORE (")
+ (let (beg tag)
+ (while entries
+ (cond
+ ((stringp (car entries))
+ (setq beg (point))
+ (insert (car entries))
+ (goto-char beg)
+ (while (re-search-forward "\\\\" nil t)
+ (replace-match "\\\\\\\\"))
+ (goto-char beg)
+ (while (re-search-forward "\"" nil t)
+ (replace-match "\\\\\""))
+ (goto-char beg)
+ (insert "\"")
+ (goto-char (point-max))
+ (insert "\""))
+ ((symbolp (car entries))
+ (insert (prin1-to-string (car entries)))))
+ (if (cdr entries)(insert " "))
+ (setq entries (cdr entries)))
+ (insert ")")
+ (goto-char (point-min))
+ (insert (with-current-buffer (process-buffer process)
+ (number-to-string (setq tag (setq acap-tag (1+ acap-tag)))))
+ " ")
+ (process-send-region process (point-min) (point-max))
+ (acap-debug (concat (buffer-string) acap-client-eol))
+ (process-send-string process acap-client-eol)
+ (acap-wait-for-response process tag))))
(defun acap-deletedsince (process name time)
"Execute DELETEDSINCE command on PROCESS."
(defun acap-response-ok-p (response)
(assq 'done-ok response))
+(defun acap-response-bye-p (response)
+ (assq 'bye response))
+
+(defun acap-response-bye-message (response)
+ (nth 1 (cdr (assq 'bye response))))
+
(defun acap-response-cont-p (response)
(assq 'cont response))
(with-current-buffer (process-buffer process)
(while (and (not (acap-response-cont-p acap-response))
(< acap-reached-tag tag))
+ (when (acap-response-bye-p acap-response)
+ (if acap-logging-out
+ (setq acap-response nil)
+ (error "%s"
+ (prog1 (acap-response-bye-message acap-response)
+ (setq acap-response nil)))))
(or (and (not (memq (process-status process) '(open run)))
(sit-for 1))
- (let ((len (/ (point-max) 1024))
+ (let ((len (/ (point-max) 1024))
message-log-max)
- (unless (< len 10)
- (message "acap read: %dk" len))
- (accept-process-output process 1))))
+ (unless (< len 10)
+ (message "acap read: %dk" len))
+ (accept-process-output process 1))))
(message "")
acap-response))
rlist))
(defun acap-parse-return-metadata-or-return-metalist ()
- (or (acap-parse-nil)
- (acap-parse-string)
- (acap-parse-value-or-return-metalist)))
+ (or (acap-parse-string)
+ (acap-parse-value-or-return-metalist)
+ (and (acap-parse-nil) nil)))
(defun acap-parse-value-or-return-metalist ()
(when (eq (char-after (point)) ?\()
;; return-metadata = nil / string / value-list / acl
(defun acap-parse-return-metadata ()
- (or (acap-parse-nil)
- (acap-parse-string)
+ (or (acap-parse-string)
(acap-parse-value-list)
+ (and (acap-parse-nil) nil)
;; (acap-parse-acl) acl is same as value-list.
))
(acap-forward)
(acap-parse-return-data-list)))))
(ALERT ;(cons 'alert (acap-parse-resp-body))
- (message (nth 1 (acap-parse-resp-body))))
- (BYE ;(cons 'bye (acap-parse-resp-body)))
- ;;(message (nth 1 (acap-parse-resp-body)))
- ;;(ding)
- (delete-process acap-process))
+ (message "%s" (nth 1 (acap-parse-resp-body))))
+ ((BYE Bye bye)
+ (cons 'bye (acap-parse-resp-body)))
(CHANGE (cons 'change
(list (acap-parse-quoted)
(progn
(NO (cons 'stat-no (acap-parse-resp-body)))
(BAD ;(cons 'stat-bad (acap-parse-resp-body))
;; XXX cyrus-sml-acap does not return tagged bad response?
- (error (nth 1 (acap-parse-resp-body))))))
+ (error "%s" (nth 1 (acap-parse-resp-body))))))
((integerp token)
;; tagged response.
(setq tag token)