From 43c361c04976918c3b14b94dbe54e1a952a8093c Mon Sep 17 00:00:00 2001 From: teranisi Date: Tue, 28 Aug 2001 01:00:01 +0000 Subject: [PATCH] * acap.el: New file. --- elmo/ChangeLog | 4 + elmo/acap.el | 838 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 842 insertions(+) create mode 100644 elmo/acap.el diff --git a/elmo/ChangeLog b/elmo/ChangeLog index c2812ac..220511c 100644 --- a/elmo/ChangeLog +++ b/elmo/ChangeLog @@ -1,3 +1,7 @@ +2001-08-28 Yuuichi Teranishi + + * acap.el: New file. + 2001-08-20 Tatsuya Kinoshita * elmo-pop3.el (elmo-pop3-parse-uidl-response): Allow multiple diff --git a/elmo/acap.el b/elmo/acap.el new file mode 100644 index 0000000..a52406d --- /dev/null +++ b/elmo/acap.el @@ -0,0 +1,838 @@ +;;; acap.el --- An ACAP interface. + +;; Author: Yuuichi Teranishi +;; Keywords: ACAP + +;; Copyright (C) 2001 Yuuichi Teranishi + +;; This file is not part of GNU Emacs + +;; 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 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: +;; Some codes are based on imap.el. + +;;; History: +;; + +;;; Code: + +(eval-when-compile + (require 'cl) + (require 'static)) +(require 'pces) +(require 'sasl) + +;; User variables. +(defgroup acap nil + "Low level ACAP issues." + :group 'applications) + +(defcustom acap-default-user (user-login-name) + "Default username to use." + :type 'string + :group 'acap) + +(defcustom acap-default-port 674 + "Default port for ACAP." + :type 'integer + :group 'acap) + +(defcustom acap-stock-passphrase nil + "Stock passphrase on memory if t." + :type 'boolean + :group 'acap) + +;; Constants. +(defconst acap-server-eol "\r\n" + "The EOL string sent from the server.") + +(defconst acap-client-eol "\r\n" + "The EOL string sent from the server.") + +;; Internal variables. +(defvar acap-state 'closed + "ACAP state. +Valid states are `closed', `initial', `auth'.") + +(defvar acap-capability nil + "Capability for server.") + +(defvar acap-reached-tag 0 + "Lower limit on command tags that have been parsed.") + +(defvar acap-tag 0 + "Command tag number.") + +(defvar acap-auth nil + "Authenticated mechanism name.") + +(defvar acap-process nil + "Process for the buffer.") + +(defvar acap-server nil + "Server name.") + +(defvar acap-port nil + "Port number.") + +(defvar acap-response nil + "ACAP Response.") + +(make-variable-buffer-local 'acap-state) +(make-variable-buffer-local 'acap-auth) +(make-variable-buffer-local 'acap-capability) +(make-variable-buffer-local 'acap-reached-tag) +(make-variable-buffer-local 'acap-failed-tag) +(make-variable-buffer-local 'acap-tag) +(make-variable-buffer-local 'acap-server) +(make-variable-buffer-local 'acap-port) +(make-variable-buffer-local 'acap-response) + +(defvar acap-network-stream-alist + '((default . open-network-stream-as-binary))) + +(defun acap-network-stream-open (buffer server port &optional type) + (let* ((port (or port acap-default-port)) + (process (funcall (cdr (assq (or type 'default) + acap-network-stream-alist)) + "ACAP" buffer server port))) + (when process + (with-current-buffer buffer + (while (and (memq (process-status process) '(open run)) + (goto-char (point-min)) + (not (setq acap-capability (acap-parse-greeting)))) + (message "Waiting for response from %s..." server) + (accept-process-output process 1)) + (message "Waiting for response from %s...done" server) + (when (memq (process-status process) '(open run)) + process))))) + +(defvar acap-passphrase nil) +(defvar acap-rp-user nil) +(defvar acap-rp-server nil) +(defvar acap-rp-auth nil) + +(defvar acap-passphrase-alist nil) + +(defun acap-read-passphrase (prompt) + "Prompt is not used." + (or acap-passphrase + (progn + (setq prompt (format "%s passphrase for %s@%s: " + acap-rp-auth acap-rp-user acap-rp-server)) + (if (functionp 'read-passwd) + (read-passwd prompt) + (if (load "passwd" t) + (read-passwd prompt)))))) + +;;; Debug. +(defvar acap-debug t) +(defvar acap-debug-buffer nil) +(defun acap-debug (string) + "Insert STRING to the debug buffer." + (when acap-debug + (if (or (null acap-debug-buffer) + (not (bufferp acap-debug-buffer)) + (not (buffer-live-p acap-debug-buffer))) + (setq acap-debug-buffer (get-buffer-create "*Debug acap*"))) + (with-current-buffer acap-debug-buffer + (goto-char (point-max)) + (insert string)))) + +;;; Stock passphrase (Not implemented yet) +(defun acap-stock-passphrase (user server auth passphrase) + (let ((key (format "%s/%s/%s" user server auth)) + pair) + (when (setq pair (assoc key acap-passphrase-alist)) + (setq acap-passphrase-alist (delete pair acap-passphrase-alist))) + (setq acap-passphrase-alist (cons + (cons key passphrase) + acap-passphrase-alist)))) + +(defun acap-stocked-passphrase (user server auth) + (when acap-stock-passphrase + (let ((key (format "%s/%s/%s" user server auth))) + (cdr (assoc key acap-passphrase-alist))))) + +(defun acap-remove-stocked-passphrase (user server auth) + (let ((key (format "%s/%s/%s" user server auth))) + (setq acap-passphrase-alist + (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))) + process passphrase mechanism tag) + (with-current-buffer 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) + (set-process-filter process 'acap-arrival-filter) + (set-process-sentinel process 'acap-sentinel) + (while (and (memq (process-status process) '(open run)) + (not (eq acap-state 'auth))) + (setq acap-auth + (unwind-protect + (let* ((mechanism + (sasl-find-mechanism + (if auth + (list auth) + (cdr (or (assq 'Sasl acap-capability) + (assq 'SASL acap-capability)))))) + (sclient + (sasl-make-client mechanism user "acap" server)) + (sasl-read-passphrase 'acap-read-passphrase) + (acap-rp-user user) + (acap-rp-server server) + (acap-rp-auth (sasl-mechanism-name mechanism)) + acap-passphrase step response cont-string) + (unless (string= (sasl-mechanism-name mechanism) + "ANONYMOUS") + (setq acap-passphrase (acap-read-passphrase nil))) + (setq tag (acap-send-command + process + (concat + (format "AUTHENTICATE \"%s\"" + (sasl-mechanism-name mechanism)) + (if (and (setq step + (sasl-next-step sclient nil)) + (sasl-step-data step)) + (concat " " (prin1-to-string + (sasl-step-data step))))))) + (when (setq response (acap-wait-for-response process tag)) + (while (acap-response-cont-p response) + (sasl-step-set-data + step (acap-response-cont-string response)) + (acap-response-clear process) + (if (setq step (sasl-next-step sclient step)) + (with-temp-buffer + (insert (or (sasl-step-data step) "")) + (setq response (acap-send-data-wait + process (current-buffer) tag))) + (setq response nil))) + (if (acap-response-ok-p response) + (progn + (setq acap-state 'auth) + mechanism) + (message "Authentication failed.") + (sit-for 1)))) + nil))) + (unless acap-auth + (message "acap: Connecting to %s...failed" server)) + (setq acap-server server + acap-port port) + process))) + +(defun acap-close (process) + (with-current-buffer (process-buffer process) + (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)) + (delete-process process)) + (erase-buffer) + t)) + +;;; Commands + +(defun acap-noop (process) + "Execute NOOP command on PROCESS." + (acap-send-command-wait process "NOOP")) + +(defun acap-lang (process lang-list) + "Execute LANG command on PROCESS." + (acap-send-command-wait process + (mapconcat + 'identity + (nconc (list "LANG") + (mapcar 'prin1-to-string lang-list)) + " "))) + +(defun acap-search (process target &optional modifier criteria) + "Execute SEARCH command on PROCESS. +TARGET is a string which specifies what is to be searched +\(dataset or context name\). +MODIFIER is an alist of modifiers. Each element should be a list like +\(MODIFIER-NAME DATA1 DATA2...\). +CRITERIA is a search criteria string. +If CRITERIA is not specified, \"ALL\" is assumed, +Modifiers and search criteria are described in section 6.4.1 of RFC2244. + +Examples: +\(acap-search process + \"/addressbook/\" + '\((DEPTH 3\) + \(RETURN \(\"addressbook.Alias\" + \"addressbook.Email\" + \"addressbook.List\"\)\)\) + \"OR NOT EQUAL \\\"addressbook.Email\\\" \\\"i\;octed\\\" NIL\\ + NOT EQUAL \\\"addressbook.Email\\\" \\\"i\;octed\\\" NIL\"\) + +\(acap-search process + \"/addressbook/user/fred/\" + '\(\(RETURN \(\"*\"\)\) + \"EQUAL \\\"entry\\\" \\\"i\;octed\\\" \\\"A0345\\\"\"\)" + (acap-send-command-wait process + (concat "SEARCH " (prin1-to-string target) + (if modifier " ") + (mapconcat + 'prin1-to-string + (acap-flatten modifier) + " ") + " " + (or criteria "ALL")))) + +(defun acap-freecontext (process name) + "Execute FREECONTEXT command on PROCESS." + (acap-send-command-wait process + (concat "FREECONTEXT " name))) + +(defun acap-updatecontext (process names) + "Execute UPDATECONTEXT command on PROCESS." + (acap-send-command-wait process + (mapconcat + 'identity + (nconc (list "FREECONTEXT") names) + " "))) + +(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)))) + +(defun acap-deletedsince (process name time) + "Execute DELETEDSINCE command on PROCESS." + (acap-send-command-wait process + (concat "DELETEDSINCE " + (prin1-to-string name) + " " + (prin1-to-string (acap-encode-time time))))) + +(defun acap-setacl (process object identifier rights) + "Execute SETACL command on PROCESS." + (acap-send-command-wait process + (concat "SETACL " + (prin1-to-string object) + " " + (prin1-to-string identifier) + " " + (prin1-to-string rights)))) + +(defun acap-deleteacl (process object &optional identifier) + "Execute DELETEACL command on PROCESS." + (acap-send-command-wait process + (concat + "DELETEACL " + (prin1-to-string object) + (if identifier + (concat " " (prin1-to-string identifier)))))) + +(defun acap-myrights (process object) + "Execute MYRIGHTS command on PROCESS." + (acap-send-command-wait process + (concat + "MYRIGHTS " + (prin1-to-string object)))) + +(defun acap-listrights (process object identifier) + "Execute LISTRIGHTS command on PROCESS." + (acap-send-command-wait process + (concat + "LISTRIGHTS " + (prin1-to-string object) + " " + (prin1-to-string identifier)))) + +(defun acap-getquota (process dataset) + "Execute GETQUOTA command on PROCESS." + (acap-send-command-wait process + (concat + "GETQUOTA " + (prin1-to-string dataset)))) + +;;; response accessor. +(defun acap-response-ok-p (response) + (assq 'done-ok response)) + +(defun acap-response-cont-p (response) + (assq 'cont response)) + +(defun acap-response-cont-string (response) + (cdr (assq 'cont response))) + +(defun acap-response-body (response) + (cdr (or (assq 'done-ok response) + (assq 'done-no response) + (assq 'done-bad response)))) + +(defun acap-response-entries (response) + (let (entries) + (dolist (ent response) + (if (eq (car ent) 'entry) + (setq entries (cons ent entries)))) + entries)) + +(defun acap-response-entry-entry (entry) + (car (cdr entry))) + +(defun acap-response-entry-return-data-list (entry) + (nth 1 (cdr entry))) + +(defun acap-response-return-data-list-get-value (name return-data-list) + (nth 1 (assoc name return-data-list))) + +(defun acap-response-listrights (response) + (cdr (assq 'listrights response))) + +;;; Send command, data. +(defun acap-response-clear (process) + (with-current-buffer (process-buffer process) + (setq acap-response nil))) + +(defun acap-send-command-wait (process command) + (acap-wait-for-response process (acap-send-command process command))) + +(defun acap-send-data-wait (process string tag) + (cond ((stringp string) + (acap-send-command-1 process string)) + ((bufferp string) + (with-current-buffer string + (acap-response-clear process) + (acap-send-command-1 process (format "{%d}" (buffer-size))) + (if (acap-response-cont-p (acap-wait-for-response process tag)) + (with-current-buffer string + (acap-response-clear process) + (process-send-region process (point-min) + (point-max)) + (process-send-string process acap-client-eol))) + (acap-debug (concat (buffer-string) acap-client-eol))))) + (acap-wait-for-response process tag)) + +(defun acap-send-command-1 (process cmdstr) + (acap-debug (concat "<-" cmdstr acap-client-eol)) + (process-send-string process (concat cmdstr acap-client-eol))) + +(defun acap-send-command (process command) + (with-current-buffer (process-buffer process) + (setq acap-response nil) + (if (not (listp command)) (setq command (list command))) + (let ((tag (setq acap-tag (1+ acap-tag))) + cmd cmdstr response) + (setq cmdstr (concat (number-to-string acap-tag) " ")) + (while (setq cmd (pop command)) + (cond ((stringp cmd) + (setq cmdstr (concat cmdstr cmd))) + ((bufferp cmd) + (with-current-buffer cmd + (setq cmdstr (concat cmdstr (format "{%d}" (buffer-size))))) + (unwind-protect + (progn + (acap-send-command-1 process cmdstr) + (setq cmdstr nil + response (acap-wait-for-response process tag)) + (if (not (acap-response-cont-p response)) + (setq command nil) ;; abort command if no cont-req + (with-current-buffer cmd + (process-send-region process (point-min) + (point-max)) + (process-send-string process acap-client-eol)))))) + (t (error "Unknown command type")))) + (when cmdstr + (acap-send-command-1 process cmdstr)) + tag))) + +(defun acap-wait-for-response (process tag) + (with-current-buffer (process-buffer process) + (while (and (not (acap-response-cont-p acap-response)) + (< acap-reached-tag tag)) + (or (and (not (memq (process-status process) '(open run))) + (sit-for 1)) + (let ((len (/ (point-max) 1024)) + message-log-max) + (unless (< len 10) + (message "acap read: %dk" len)) + (accept-process-output process 1)))) + (message "") + acap-response)) + +;;; Sentinel, Filter. +(defun acap-sentinel (process string) + (delete-process process)) + +(defun acap-find-next-line () + (when (re-search-forward (concat acap-server-eol "\\|{\\([0-9+]+\\)}" + acap-server-eol) + nil t) + (if (match-string 1) + (if (< (point-max) (+ (point) (string-to-number (match-string 1)))) + nil + (goto-char (+ (point) (string-to-number (match-string 1)))) + (acap-find-next-line)) + (point)))) + +(defun acap-arrival-filter (proc string) + "ACAP process filter." + (acap-debug string) + (with-current-buffer (process-buffer proc) + (goto-char (point-max)) + (insert string) + (let (end) + (goto-char (point-min)) + (while (setq end (acap-find-next-line)) + (save-restriction + (narrow-to-region (point-min) end) + (delete-backward-char (length acap-server-eol)) + (goto-char (point-min)) + (unwind-protect + (cond ((or (eq acap-state 'auth) + (eq acap-state 'initial) + (eq acap-state 'nonauth)) + (acap-parse-response)) + (t + (message "Unknown state %s in arrival filter" + acap-state))) + (delete-region (point-min) (point-max)))))))) + +;;; acap parser. +(defsubst acap-forward () + (or (eobp) (forward-char))) + +(defsubst acap-parse-number () + (when (looking-at "[0-9]+") + (prog1 + (string-to-number (match-string 0)) + (goto-char (match-end 0))))) + +(defsubst acap-parse-literal () + (when (looking-at "{\\([0-9]+\\)}\r\n") + (let ((pos (match-end 0)) + (len (string-to-number (match-string 1)))) + (if (< (point-max) (+ pos len)) + nil + (goto-char (+ pos len)) + (buffer-substring pos (+ pos len)))))) + +(defun acap-parse-greeting () + (when (looking-at "* ACAP") + (goto-char (match-end 0)) + (acap-forward) + (let (capabilities) + (while (eq (char-after (point)) ?\() + (push (read (current-buffer)) capabilities) + (acap-forward)) + (nreverse capabilities)))) + +;; resp-body = ["(" resp-code ")" SP] quoted +(defun acap-parse-resp-body () + (let ((body (read (current-buffer)))) + (if (listp body) ; resp-code + (list body (read (current-buffer))) + (list nil body) ; no resp-code. + ))) + +;; string = quoted / literal +;; +;; quoted = DQUOTE *QUOTED-CHAR DQUOTE +;; +;; QUOTED-CHAR = / +;; "\" quoted-specials +;; +;; quoted-specials = DQUOTE / "\" +;; +;; TEXT-CHAR = + +(defsubst acap-parse-string () + (cond ((eq (char-after) ?\") + (forward-char 1) + (let ((p (point)) (name "")) + (skip-chars-forward "^\"\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^\"\\\\") + (setq name (concat name (buffer-substring p (point))))) + (forward-char 1) + name)) + ((eq (char-after) ?{) + (acap-parse-literal)))) + +;; nil = "NIL" + +(defsubst acap-parse-nil () + (if (looking-at "NIL") + (goto-char (match-end 0)))) + +;; entry = entry-name / entry-path +;; entry-name = string-utf8 +;; ;; entry name MUST NOT contain slash +;; ;; MUST NOT begin with "." +;; entry-path = string-utf8 +;; ;; slash-separated path to entry +;; ;; begins with slash + +(defsubst acap-parse-quoted () + (if (eq (char-after) ?\") + (read (current-buffer)))) + +(defun acap-parse-entry () + (acap-parse-quoted)) + +;; value = string +(defun acap-parse-value () + (acap-parse-string)) + +;; value-list = "(" [value *(SP value)] ")" +(defun acap-parse-value-list () + ;; same as acl. + (when (eq (char-after (point)) ?\() + (let (values) + (while (not (eq (char-after (point)) ?\))) + (acap-forward) + (push (acap-parse-value) values)) + (acap-forward) + (nreverse values)))) + +;; +;; return-data-list = return-data *(SP return-data) +;; +;; return-data = return-metadata / return-metalist / +;; return-attr-list + +(defun acap-parse-return-data-list () + (let (rlist r) + (setq rlist (list (acap-parse-return-metadata-or-return-metalist))) + (acap-forward) + (while (setq r (acap-parse-return-metadata-or-return-metalist)) + (setq rlist (nconc rlist (list r))) + (acap-forward)) + rlist)) + +(defun acap-parse-return-metadata-or-return-metalist () + (or (acap-parse-nil) + (acap-parse-string) + (acap-parse-value-or-return-metalist))) + +(defun acap-parse-value-or-return-metalist () + (when (eq (char-after (point)) ?\() + (let (elems) + (while (not (eq (char-after (point)) ?\))) + (acap-forward) + (push (or (acap-parse-value) + (acap-parse-return-metalist)) + elems)) + (acap-forward) + (nreverse elems)))) + +;; return-metalist = "(" return-metadata *(SP return-metadata) ")" +;; ;; occurs when multiple metadata items requested +;; +(defun acap-parse-return-metalist () + (when (eq (char-after (point)) ?\() + (let (metadatas) + (while (not (eq (char-after (point)) ?\))) + (acap-forward) + (push (acap-parse-return-metadata) metadatas)) + (acap-forward) + (nreverse metadatas)))) + +;; return-metadata = nil / string / value-list / acl +(defun acap-parse-return-metadata () + (or (acap-parse-nil) + (acap-parse-string) + (acap-parse-value-list) + ;; (acap-parse-acl) acl is same as value-list. + )) + +;; return-attr-list = "(" return-metalist *(SP return-metalist) ")" +;; ;; occurs when "*" in RETURN pattern on SEARCH +(defun acap-parse-return-attr-list () + (when (eq (char-after (point)) ?\() + (let (metalists) + (while (not (eq (char-after (point)) ?\))) + (acap-forward) + (push (acap-parse-return-metalist) metalists)) + (acap-forward) + (nreverse metalists)))) + +(defun acap-parse-time () + (acap-parse-quoted)) + +;; quoted *(SP quoted) +(defun acap-parse-quoted-list () + (let (qlist q) + (setq qlist (list (acap-parse-quoted))) + (acap-forward) + (while (setq q (acap-parse-quoted)) + (setq qlist (nconc qlist (list q))) + (acap-forward)) + qlist)) + +(defun acap-parse-any () + (read (current-buffer))) + +(defun acap-parse-extension-data () + (let (elist e) + (setq elist (list (acap-parse-any))) + (acap-forward) + (while (setq e (acap-parse-any)) + (setq elist (nconc elist (list e))) + (acap-forward)) + elist)) + +(defun acap-parse-response () + "Parse a ACAP command response." + (let ((token (read (current-buffer))) + tag) + (setq + acap-response + (cons + (cond + ((eq token '+) + (acap-forward) + (cons 'cont (acap-parse-string))) + ((eq token '*) + ;; untagged response. + (case (prog1 (setq token (read (current-buffer))) + (acap-forward)) + (ADDTO (cons 'addto + (list (acap-parse-quoted) + (progn + (acap-forward) + (acap-parse-quoted)) + (progn + (acap-forward) + (acap-parse-number)) + (progn + (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 (acap-parse-resp-body)) + (ding) + (delete-process acap-process)) + (CHANGE (cons 'change + (list (acap-parse-quoted) + (progn + (acap-forward) + (acap-parse-quoted)) + (progn + (acap-forward) + (acap-parse-number)) + (progn + (acap-forward) + (acap-parse-number)) + (progn + (acap-forward) + (acap-parse-return-data-list))))) + (LANG (cons 'lang (list (acap-parse-quoted-list)))) + ;; response-stat + (OK (cons 'stat-ok (acap-parse-resp-body))) + (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)))))) + ((integerp token) + ;; tagged response. + (setq tag token) + (case (prog1 (setq token (read (current-buffer))) + (acap-forward)) + (DELETED (cons 'deleted (acap-parse-quoted))) + ;; response-done + ((OK Ok ok) (prog1 (cons 'done-ok (acap-parse-resp-body)) + (setq acap-reached-tag tag))) + ((NO No no) (prog1 (cons 'done-no (acap-parse-resp-body)) + (setq acap-reached-tag tag))) + ((BAD Bad bad) (prog1 (cons 'done-bad (acap-parse-resp-body)) + (setq acap-reached-tag tag))) + (ENTRY (cons 'entry + (list + (acap-parse-entry) + (progn (acap-forward) + (acap-parse-return-data-list))))) + (LISTRIGHTS (cons 'listrights + (acap-parse-quoted-list))) + (MODTIME (cons 'modtime (acap-parse-time))) + (MYRIGHTS (cons 'myrights (acap-parse-quoted))) + (QUOTA (cons 'quota + (list (acap-parse-quoted) + (progn + (acap-forward) + (acap-parse-number)) + (progn + (acap-forward) + (acap-parse-number)) + (acap-parse-extension-data)))) + (REFER (cons 'refer (list (acap-parse-quoted) + (acap-parse-quoted)))) + (REMOVEFROM (cons 'removefrom + (list (acap-parse-quoted) + (progn + (acap-forward) + (acap-parse-quoted)) + (progn + (acap-forward) + (acap-parse-number))))) + ;; response-extend + (t ; extend-token + (cons 'extend (list token (acap-parse-extension-data)))))) + (t ; garbage + (list 'garbage token))) + acap-response)))) + +;;; Utilities. +(defun acap-flatten (l) + "Flatten list-of-list." + (unless (null l) + (append + (if (and (car l) + (listp (car l))) + (car l) + (list (car l))) + (acap-flatten (cdr l))))) + +(defun acap-flatten-r (l) + "Flatten list-of-list recursively." + (cond + ((null l) '()) + ((listp l) + (append (acap-flatten (car l)) (acap-flatten (cdr l)))) + (t (list l)))) + +(defun acap-encode-time (time) + (format-time-string "%Y%m%d%H%M%S" (current-time) t)) ; Universal time. + +(defun acap-decode-time (acap-time) + (when (string-match "^\\([0-9][0-9][0-9][0-9]\\)\\([0-1][0-9]\\)\\([0-3][0-9]\\)\\([0-2][0-9]\\)\\([0-5][0-9]\\)\\([0-5][0-9]\\)" acap-time) + (encode-time (string-to-number (match-string 6 acap-time)) + (string-to-number (match-string 5 acap-time)) + (string-to-number (match-string 4 acap-time)) + (string-to-number (match-string 3 acap-time)) + (string-to-number (match-string 2 acap-time)) + (string-to-number (match-string 1 acap-time)) + t))) + +(provide 'acap) + +;;; acap.el ends here -- 1.7.10.4