elmo/acap.el

   1 ;;; acap.el --- An ACAP interface.
   2
   3 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   4 ;; Keywords: ACAP
   5
   6 ;; Copyright (C) 2001 Yuuichi Teranishi <teranisi@gohome.org>
   7
   8 ;; This file is not part of GNU Emacs
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;  Some codes are based on imap.el.
  28
  29 ;;; History:
  30 ;;
  31
  32 ;;; Code:
  33
  34 (eval-when-compile
  35   (require 'cl)
  36   (require 'static))
  37 (require 'pces)
  38 (require 'sasl)
  39
  40 ;; User variables.
  41 (defgroup acap nil
  42   "Low level ACAP issues."
  43   :group 'applications)
  44
  45 (defcustom acap-default-user (user-login-name)
  46   "Default username to use."
  47   :type 'string
  48   :group 'acap)
  49
  50 (defcustom acap-default-port 674
  51   "Default port for ACAP."
  52   :type 'integer
  53   :group 'acap)
  54
  55 (defcustom acap-stock-passphrase nil
  56   "Stock passphrase on memory if t."
  57   :type 'boolean
  58   :group 'acap)
  59
  60 ;; Constants.
  61 (defconst acap-server-eol "\r\n"
  62   "The EOL string sent from the server.")
  63
  64 (defconst acap-client-eol "\r\n"
  65   "The EOL string sent from the server.")
  66
  67 ;; Internal variables.
  68 (defvar acap-state 'closed
  69   "ACAP state.
  70 Valid states are `closed', `initial', `auth'.")
  71
  72 (defvar acap-capability nil
  73   "Capability for server.")
  74
  75 (defvar acap-reached-tag 0
  76   "Lower limit on command tags that have been parsed.")
  77
  78 (defvar acap-tag 0
  79   "Command tag number.")
  80
  81 (defvar acap-auth nil
  82   "Authenticated mechanism name.")
  83
  84 (defvar acap-process nil
  85   "Process for the buffer.")
  86
  87 (defvar acap-server nil
  88   "Server name.")
  89
  90 (defvar acap-port nil
  91   "Port number.")
  92
  93 (defvar acap-response nil
  94   "ACAP Response.")
  95
  96 (make-variable-buffer-local 'acap-state)
  97 (make-variable-buffer-local 'acap-auth)
  98 (make-variable-buffer-local 'acap-capability)
  99 (make-variable-buffer-local 'acap-reached-tag)
 100 (make-variable-buffer-local 'acap-failed-tag)
 101 (make-variable-buffer-local 'acap-tag)
 102 (make-variable-buffer-local 'acap-server)
 103 (make-variable-buffer-local 'acap-port)
 104 (make-variable-buffer-local 'acap-response)
 105
 106 (defvar acap-network-stream-alist
 107   '((default . open-network-stream-as-binary)))
 108
 109 (defun acap-network-stream-open (buffer server port &optional type)
 110   (let* ((port (or port acap-default-port))
 111          (process (progn
 112                     (message "Connecting to %s..." server)
 113                     (funcall (cdr (assq (or type 'default)
 114                                         acap-network-stream-alist))
 115                              "ACAP" buffer server port))))
 116     (when process
 117       (with-current-buffer buffer
 118         (while (and (memq (process-status process) '(open run))
 119                     (goto-char (point-min))
 120                     (not (setq acap-capability (acap-parse-greeting))))
 121           (message "Waiting for response from %s..." server)
 122           (accept-process-output process 1))
 123         (message "Waiting for response from %s...done" server)
 124         (when (memq (process-status process) '(open run))
 125           process)))))
 126
 127 (defvar acap-passphrase nil)
 128 (defvar acap-rp-user nil)
 129 (defvar acap-rp-server nil)
 130 (defvar acap-rp-auth nil)
 131
 132 (defvar acap-passphrase-alist nil)
 133
 134 (defun acap-read-passphrase (prompt)
 135   "Prompt is not used."
 136   (or acap-passphrase
 137       (progn
 138         (setq prompt (format "%s passphrase for %s@%s: "
 139                              acap-rp-auth acap-rp-user acap-rp-server))
 140         (if (functionp 'read-passwd)
 141             (read-passwd prompt)
 142           (if (load "passwd" t)
 143               (read-passwd prompt))))))
 144
 145 ;;; Debug.
 146 (defvar acap-debug t)
 147 (defvar acap-debug-buffer nil)
 148 (defun acap-debug (string)
 149   "Insert STRING to the debug buffer."
 150   (when acap-debug
 151     (if (or (null acap-debug-buffer)
 152             (not (bufferp acap-debug-buffer))
 153             (not (buffer-live-p acap-debug-buffer)))
 154         (setq acap-debug-buffer (get-buffer-create "*Debug acap*")))
 155     (with-current-buffer acap-debug-buffer
 156       (goto-char (point-max))
 157       (insert string))))
 158
 159 ;;; Stock passphrase (Not implemented yet)
 160 (defun acap-stock-passphrase (user server auth passphrase)
 161   (let ((key (format "%s/%s/%s" user server auth))
 162         pair)
 163     (when (setq pair (assoc key acap-passphrase-alist))
 164       (setq acap-passphrase-alist (delete pair acap-passphrase-alist)))
 165     (setq acap-passphrase-alist (cons
 166                                  (cons key passphrase)
 167                                  acap-passphrase-alist))))
 168
 169 (defun acap-stocked-passphrase (user server auth)
 170   (when acap-stock-passphrase
 171     (let ((key (format "%s/%s/%s" user server auth)))
 172       (cdr (assoc key acap-passphrase-alist)))))
 173
 174 (defun acap-remove-stocked-passphrase (user server auth)
 175   (let ((key (format "%s/%s/%s" user server auth)))
 176     (setq acap-passphrase-alist
 177           (delq (assoc key acap-passphrase-alist)
 178                 acap-passphrase-alist))))
 179
 180 ;;; Open, Close
 181 (defun acap-open (server &optional user auth port type)
 182   (let* ((user (or user acap-default-user))
 183          (buffer (get-buffer-create (concat " *acap on " user " at " server)))
 184          process passphrase mechanism tag)
 185     (with-current-buffer buffer
 186       (if acap-process
 187           (delete-process acap-process))
 188       (setq process (acap-network-stream-open buffer server port type)
 189             acap-process process)
 190       (erase-buffer)
 191       (set-buffer-multibyte nil)
 192       (buffer-disable-undo)
 193       (setq acap-state 'initial)
 194       (set-process-filter process 'acap-arrival-filter)
 195       (set-process-sentinel process 'acap-sentinel)
 196       (while (and (memq (process-status process) '(open run))
 197                   (not (eq acap-state 'auth)))
 198         (setq acap-auth
 199               (unwind-protect
 200                   (let* ((mechanism
 201                           (sasl-find-mechanism
 202                            (if auth
 203                                (list auth)
 204                              (cdr (or (assq 'Sasl acap-capability)
 205                                       (assq 'SASL acap-capability))))))
 206                          (sclient
 207                           (sasl-make-client mechanism user "acap" server))
 208                          (sasl-read-passphrase 'acap-read-passphrase)
 209                          (acap-rp-user user)
 210                          (acap-rp-server server)
 211                          (acap-rp-auth (sasl-mechanism-name mechanism))
 212                          acap-passphrase step response cont-string)
 213                     (unless (string= (sasl-mechanism-name mechanism)
 214                                      "ANONYMOUS")
 215                       (setq acap-passphrase (acap-read-passphrase nil)))
 216                     (setq tag (acap-send-command
 217                                process
 218                                (concat
 219                                 (format "AUTHENTICATE \"%s\""
 220                                         (sasl-mechanism-name mechanism))
 221                                 (if (and (setq step
 222                                                (sasl-next-step sclient nil))
 223                                          (sasl-step-data step))
 224                                     (concat " " (prin1-to-string
 225                                                  (sasl-step-data step)))))))
 226                     (when (setq response (acap-wait-for-response process tag))
 227                       (while (acap-response-cont-p response)
 228                         (sasl-step-set-data
 229                          step (acap-response-cont-string response))
 230                         (acap-response-clear process)
 231                         (if (setq step (sasl-next-step sclient step))
 232                             (with-temp-buffer
 233                               (insert (or (sasl-step-data step) ""))
 234                               (setq response (acap-send-data-wait
 235                                               process (current-buffer) tag)))
 236                           (setq response nil)))
 237                       (if (acap-response-ok-p response)
 238                           (progn
 239                             (setq acap-state 'auth)
 240                             mechanism)
 241                         (message "Authentication failed.")
 242                         (sit-for 1))))
 243                 nil)))
 244       (unless acap-auth
 245         (message "acap: Connecting to %s...failed" server))
 246       (setq acap-server server
 247             acap-port port)
 248       process)))
 249
 250 (defun acap-close (process)
 251   (with-current-buffer (process-buffer process)
 252     (unless (acap-response-ok-p (acap-send-command-wait process "LOGOUT"))
 253       (message "Server %s didn't let me log out" acap-server))
 254     (when (memq (process-status process) '(open run))
 255       (delete-process process))
 256     (erase-buffer)
 257     t))
 258
 259 ;;; Commands
 260
 261 (defun acap-noop (process)
 262   "Execute NOOP command on PROCESS."
 263   (acap-send-command-wait process "NOOP"))
 264
 265 (defun acap-lang (process lang-list)
 266   "Execute LANG command on PROCESS."
 267   (acap-send-command-wait process
 268                           (mapconcat
 269                            'identity
 270                            (nconc (list "LANG")
 271                                   (mapcar 'prin1-to-string lang-list))
 272                            " ")))
 273
 274 (defun acap-search (process target &optional modifier criteria)
 275   "Execute SEARCH command on PROCESS.
 276 TARGET is a string which specifies what is to be searched
 277 \(dataset or context name\).
 278 MODIFIER is an alist of modifiers. Each element should be a list like
 279 \(MODIFIER-NAME DATA1 DATA2...\).
 280 CRITERIA is a search criteria string.
 281 If CRITERIA is not specified, \"ALL\" is assumed,
 282 Modifiers and search criteria are described in section 6.4.1 of RFC2244.
 283
 284 Examples:
 285 \(acap-search process
 286              \"/addressbook/\"
 287              '\((DEPTH 3\)
 288                \(RETURN \(\"addressbook.Alias\"
 289                         \"addressbook.Email\"
 290                         \"addressbook.List\"\)\)\)
 291              \"OR NOT EQUAL \\\"addressbook.Email\\\" \\\"i\;octed\\\" NIL\\
 292                  NOT EQUAL \\\"addressbook.Email\\\" \\\"i\;octed\\\" NIL\"\)
 293
 294 \(acap-search process
 295              \"/addressbook/user/fred/\"
 296              '\(\(RETURN \(\"*\"\)\)
 297              \"EQUAL \\\"entry\\\" \\\"i\;octed\\\" \\\"A0345\\\"\"\)"
 298   (acap-send-command-wait process
 299                           (concat "SEARCH " (prin1-to-string target)
 300                                   (if modifier " ")
 301                                   (mapconcat
 302                                    'prin1-to-string
 303                                    (acap-flatten modifier)
 304                                    " ")
 305                                   " "
 306                                   (or criteria "ALL"))))
 307
 308 (defun acap-freecontext (process name)
 309   "Execute FREECONTEXT command on PROCESS."
 310   (acap-send-command-wait process
 311                           (concat "FREECONTEXT " name)))
 312
 313 (defun acap-updatecontext (process names)
 314   "Execute UPDATECONTEXT command on PROCESS."
 315   (acap-send-command-wait process
 316                           (mapconcat
 317                            'identity
 318                            (nconc (list "FREECONTEXT") names)
 319                            " ")))
 320
 321 (defun acap-store (process entries)
 322   "Execute STORE command on PROCESS.
 323 ENTRIES is a store-entry list."
 324   (acap-send-command-wait process (concat "STORE " (prin1-to-string entries))))
 325
 326 (defun acap-deletedsince (process name time)
 327   "Execute DELETEDSINCE command on PROCESS."
 328   (acap-send-command-wait process
 329                           (concat "DELETEDSINCE "
 330                                   (prin1-to-string name)
 331                                   " "
 332                                   (prin1-to-string (acap-encode-time time)))))
 333
 334 (defun acap-setacl (process object identifier rights)
 335   "Execute SETACL command on PROCESS."
 336   (acap-send-command-wait process
 337                           (concat "SETACL "
 338                                   (prin1-to-string object)
 339                                   " "
 340                                   (prin1-to-string identifier)
 341                                   " "
 342                                   (prin1-to-string rights))))
 343
 344 (defun acap-deleteacl (process object &optional identifier)
 345   "Execute DELETEACL command on PROCESS."
 346   (acap-send-command-wait process
 347                           (concat
 348                            "DELETEACL "
 349                            (prin1-to-string object)
 350                            (if identifier
 351                                (concat " " (prin1-to-string identifier))))))
 352
 353 (defun acap-myrights (process object)
 354   "Execute MYRIGHTS command on PROCESS."
 355   (acap-send-command-wait process
 356                           (concat
 357                            "MYRIGHTS "
 358                            (prin1-to-string object))))
 359
 360 (defun acap-listrights (process object identifier)
 361   "Execute LISTRIGHTS command on PROCESS."
 362   (acap-send-command-wait process
 363                           (concat
 364                            "LISTRIGHTS "
 365                            (prin1-to-string object)
 366                            " "
 367                            (prin1-to-string identifier))))
 368
 369 (defun acap-getquota (process dataset)
 370   "Execute GETQUOTA command on PROCESS."
 371   (acap-send-command-wait process
 372                           (concat
 373                            "GETQUOTA "
 374                            (prin1-to-string dataset))))
 375
 376 ;;; response accessor.
 377 (defun acap-response-ok-p (response)
 378   (assq 'done-ok response))
 379
 380 (defun acap-response-cont-p (response)
 381   (assq 'cont response))
 382
 383 (defun acap-response-cont-string (response)
 384   (cdr (assq 'cont response)))
 385
 386 (defun acap-response-body (response)
 387   (cdr (or (assq 'done-ok response)
 388            (assq 'done-no response)
 389            (assq 'done-bad response))))
 390
 391 (defun acap-response-entries (response)
 392   (let (entries)
 393     (dolist (ent response)
 394       (if (eq (car ent) 'entry)
 395           (setq entries (cons ent entries))))
 396     entries))
 397
 398 (defun acap-response-entry-entry (entry)
 399   (car (cdr entry)))
 400
 401 (defun acap-response-entry-return-data-list (entry)
 402   (nth 1 (cdr entry)))
 403
 404 (defun acap-response-return-data-list-get-value (name return-data-list)
 405   (nth 1 (assoc name return-data-list)))
 406
 407 (defun acap-response-listrights (response)
 408   (cdr (assq 'listrights response)))
 409
 410 ;;; Send command, data.
 411 (defun acap-response-clear (process)
 412   (with-current-buffer (process-buffer process)
 413     (setq acap-response nil)))
 414
 415 (defun acap-send-command-wait (process command)
 416   (acap-wait-for-response process (acap-send-command process command)))
 417
 418 (defun acap-send-data-wait (process string tag)
 419   (cond ((stringp string)
 420          (acap-send-command-1 process string))
 421         ((bufferp string)
 422          (with-current-buffer string
 423            (acap-response-clear process)
 424            (acap-send-command-1 process (format "{%d}" (buffer-size)))
 425            (if (acap-response-cont-p (acap-wait-for-response process tag))
 426                (with-current-buffer string
 427                  (acap-response-clear process)
 428                  (process-send-region process (point-min)
 429                                       (point-max))
 430                  (process-send-string process acap-client-eol)))
 431            (acap-debug (concat (buffer-string) acap-client-eol)))))
 432   (acap-wait-for-response process tag))
 433
 434 (defun acap-send-command-1 (process cmdstr)
 435   (acap-debug (concat "<-" cmdstr acap-client-eol))
 436   (process-send-string process (concat cmdstr acap-client-eol)))
 437
 438 (defun acap-send-command (process command)
 439   (with-current-buffer (process-buffer process)
 440     (setq acap-response nil)
 441     (if (not (listp command)) (setq command (list command)))
 442     (let ((tag (setq acap-tag (1+ acap-tag)))
 443           cmd cmdstr response)
 444       (setq cmdstr (concat (number-to-string acap-tag) " "))
 445       (while (setq cmd (pop command))
 446         (cond ((stringp cmd)
 447                (setq cmdstr (concat cmdstr cmd)))
 448               ((bufferp cmd)
 449                (with-current-buffer cmd
 450                  (setq cmdstr (concat cmdstr (format "{%d}" (buffer-size)))))
 451                (unwind-protect
 452                    (progn
 453                      (acap-send-command-1 process cmdstr)
 454                      (setq cmdstr nil
 455                            response (acap-wait-for-response process tag))
 456                      (if (not (acap-response-cont-p response))
 457                          (setq command nil) ;; abort command if no cont-req
 458                        (with-current-buffer cmd
 459                          (process-send-region process (point-min)
 460                                               (point-max))
 461                          (process-send-string process acap-client-eol))))))
 462               (t (error "Unknown command type"))))
 463       (when cmdstr
 464         (acap-send-command-1 process cmdstr))
 465       tag)))
 466
 467 (defun acap-wait-for-response (process tag)
 468   (with-current-buffer (process-buffer process)
 469     (while (and (not (acap-response-cont-p acap-response))
 470                 (< acap-reached-tag tag))
 471       (or (and (not (memq (process-status process) '(open run)))
 472                (sit-for 1))
 473           (let ((len (/ (point-max) 1024))
 474                 message-log-max)
 475             (unless (< len 10)
 476               (message "acap read: %dk" len))
 477             (accept-process-output process 1))))
 478     (message "")
 479     acap-response))
 480
 481 ;;; Sentinel, Filter.
 482 (defun acap-sentinel (process string)
 483   (delete-process process))
 484
 485 (defun acap-find-next-line ()
 486   (when (re-search-forward (concat acap-server-eol "\\|{\\([0-9+]+\\)}"
 487                                    acap-server-eol)
 488                            nil t)
 489     (if (match-string 1)
 490         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
 491             nil
 492           (goto-char (+ (point) (string-to-number (match-string 1))))
 493           (acap-find-next-line))
 494       (point))))
 495
 496 (defun acap-arrival-filter (proc string)
 497   "ACAP process filter."
 498   (acap-debug string)
 499   (with-current-buffer (process-buffer proc)
 500     (goto-char (point-max))
 501     (insert string)
 502     (let (end)
 503       (goto-char (point-min))
 504       (while (setq end (acap-find-next-line))
 505         (save-restriction
 506           (narrow-to-region (point-min) end)
 507           (delete-backward-char (length acap-server-eol))
 508           (goto-char (point-min))
 509           (unwind-protect
 510               (cond ((or (eq acap-state 'auth)
 511                          (eq acap-state 'initial)
 512                          (eq acap-state 'nonauth))
 513                      (acap-parse-response))
 514                     (t
 515                      (message "Unknown state %s in arrival filter"
 516                               acap-state)))
 517             (delete-region (point-min) (point-max))))))))
 518
 519 ;;; acap parser.
 520 (defsubst acap-forward ()
 521   (or (eobp) (forward-char)))
 522
 523 (defsubst acap-parse-number ()
 524   (when (looking-at "[0-9]+")
 525     (prog1
 526         (string-to-number (match-string 0))
 527       (goto-char (match-end 0)))))
 528
 529 (defsubst acap-parse-literal ()
 530   (when (looking-at "{\\([0-9]+\\)}\r\n")
 531     (let ((pos (match-end 0))
 532           (len (string-to-number (match-string 1))))
 533       (if (< (point-max) (+ pos len))
 534           nil
 535         (goto-char (+ pos len))
 536         (buffer-substring pos (+ pos len))))))
 537
 538 (defun acap-parse-greeting ()
 539   (when (looking-at "* ACAP")
 540     (goto-char (match-end 0))
 541     (acap-forward)
 542     (let (capabilities)
 543       (while (eq (char-after (point)) ?\()
 544         (push (read (current-buffer)) capabilities)
 545         (acap-forward))
 546       (nreverse capabilities))))
 547
 548 ;; resp-body = ["(" resp-code ")" SP] quoted
 549 (defun acap-parse-resp-body ()
 550   (let ((body (read (current-buffer))))
 551     (if (listp body) ; resp-code
 552         (list body (read (current-buffer)))
 553       (list nil body) ; no resp-code.
 554       )))
 555
 556 ;;   string          = quoted / literal
 557 ;;
 558 ;;   quoted          = DQUOTE *QUOTED-CHAR DQUOTE
 559 ;;
 560 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
 561 ;;                     "\" quoted-specials
 562 ;;
 563 ;;   quoted-specials = DQUOTE / "\"
 564 ;;
 565 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
 566
 567 (defsubst acap-parse-string ()
 568   (cond ((eq (char-after) ?\")
 569          (forward-char 1)
 570          (let ((p (point)) (name ""))
 571            (skip-chars-forward "^\"\\\\")
 572            (setq name (buffer-substring p (point)))
 573            (while (eq (char-after) ?\\)
 574              (setq p (1+ (point)))
 575              (forward-char 2)
 576              (skip-chars-forward "^\"\\\\")
 577              (setq name (concat name (buffer-substring p (point)))))
 578            (forward-char 1)
 579            name))
 580         ((eq (char-after) ?{)
 581          (acap-parse-literal))))
 582
 583 ;;   nil             = "NIL"
 584
 585 (defsubst acap-parse-nil ()
 586   (if (looking-at "NIL")
 587       (goto-char (match-end 0))))
 588
 589 ;; entry              = entry-name / entry-path
 590 ;; entry-name         = string-utf8
 591 ;;                        ;; entry name MUST NOT contain slash
 592 ;;                        ;; MUST NOT begin with "."
 593 ;; entry-path         = string-utf8
 594 ;;                        ;; slash-separated path to entry
 595 ;;                        ;; begins with slash
 596
 597 (defsubst acap-parse-quoted ()
 598   (if (eq (char-after) ?\")
 599       (read (current-buffer))))
 600
 601 (defun acap-parse-entry ()
 602   (acap-parse-quoted))
 603
 604 ;; value              = string
 605 (defun acap-parse-value ()
 606   (acap-parse-string))
 607
 608 ;; value-list         = "(" [value *(SP value)] ")"
 609 (defun acap-parse-value-list ()
 610   ;; same as acl.
 611   (when (eq (char-after (point)) ?\()
 612     (let (values)
 613       (while (not (eq (char-after (point)) ?\)))
 614         (acap-forward)
 615         (push (acap-parse-value) values))
 616       (acap-forward)
 617       (nreverse values))))
 618
 619 ;;
 620 ;;   return-data-list   = return-data *(SP return-data)
 621 ;;
 622 ;;   return-data        = return-metadata / return-metalist /
 623 ;;                        return-attr-list
 624
 625 (defun acap-parse-return-data-list ()
 626   (let (rlist r)
 627     (setq rlist (list (acap-parse-return-metadata-or-return-metalist)))
 628     (acap-forward)
 629     (while (setq r (acap-parse-return-metadata-or-return-metalist))
 630       (setq rlist (nconc rlist (list r)))
 631       (acap-forward))
 632     rlist))
 633
 634 (defun acap-parse-return-metadata-or-return-metalist ()
 635   (or (acap-parse-nil)
 636       (acap-parse-string)
 637       (acap-parse-value-or-return-metalist)))
 638
 639 (defun acap-parse-value-or-return-metalist ()
 640   (when (eq (char-after (point)) ?\()
 641     (let (elems)
 642       (while (not (eq (char-after (point)) ?\)))
 643         (acap-forward)
 644         (push (or (acap-parse-value)
 645                   (acap-parse-return-metalist))
 646               elems))
 647       (acap-forward)
 648       (nreverse elems))))
 649
 650 ;;   return-metalist    = "(" return-metadata *(SP return-metadata) ")"
 651 ;;                        ;; occurs when multiple metadata items requested
 652 ;;
 653 (defun acap-parse-return-metalist ()
 654   (when (eq (char-after (point)) ?\()
 655     (let (metadatas)
 656       (while (not (eq (char-after (point)) ?\)))
 657         (acap-forward)
 658         (push (acap-parse-return-metadata) metadatas))
 659       (acap-forward)
 660       (nreverse metadatas))))
 661
 662 ;;   return-metadata    = nil / string / value-list / acl
 663 (defun acap-parse-return-metadata ()
 664   (or (acap-parse-nil)
 665       (acap-parse-string)
 666       (acap-parse-value-list)
 667       ;; (acap-parse-acl) acl is same as value-list.
 668       ))
 669
 670 ;;   return-attr-list   = "(" return-metalist *(SP return-metalist) ")"
 671 ;;                        ;; occurs when "*" in RETURN pattern on SEARCH
 672 (defun acap-parse-return-attr-list ()
 673   (when (eq (char-after (point)) ?\()
 674     (let (metalists)
 675       (while (not (eq (char-after (point)) ?\)))
 676         (acap-forward)
 677         (push (acap-parse-return-metalist) metalists))
 678       (acap-forward)
 679       (nreverse metalists))))
 680
 681 (defun acap-parse-time ()
 682   (acap-parse-quoted))
 683
 684 ;; quoted *(SP quoted)
 685 (defun acap-parse-quoted-list ()
 686   (let (qlist q)
 687     (setq qlist (list (acap-parse-quoted)))
 688     (acap-forward)
 689     (while (setq q (acap-parse-quoted))
 690       (setq qlist (nconc qlist (list q)))
 691       (acap-forward))
 692     qlist))
 693
 694 (defun acap-parse-any ()
 695   (read (current-buffer)))
 696
 697 (defun acap-parse-extension-data ()
 698   (let (elist e)
 699     (setq elist (list (acap-parse-any)))
 700     (acap-forward)
 701     (while (setq e (acap-parse-any))
 702       (setq elist (nconc elist (list e)))
 703       (acap-forward))
 704     elist))
 705
 706 (defun acap-parse-response ()
 707   "Parse a ACAP command response."
 708   (let ((token (read (current-buffer)))
 709         tag)
 710     (setq
 711      acap-response
 712      (cons
 713       (cond
 714        ((eq token '+)
 715         (acap-forward)
 716         (cons 'cont (acap-parse-string)))
 717        ((eq token '*)
 718         ;; untagged response.
 719         (case (prog1 (setq token (read (current-buffer)))
 720                 (acap-forward))
 721           (ADDTO (cons 'addto
 722                        (list (acap-parse-quoted)
 723                              (progn
 724                                (acap-forward)
 725                                (acap-parse-quoted))
 726                              (progn
 727                                (acap-forward)
 728                                (acap-parse-number))
 729                              (progn
 730                                (acap-forward)
 731                                (acap-parse-return-data-list)))))
 732           (ALERT ;(cons 'alert (acap-parse-resp-body))
 733            (message (nth 1 (acap-parse-resp-body))))
 734           (BYE   ;(cons 'bye (acap-parse-resp-body)))
 735            ;;(message (nth 1  (acap-parse-resp-body)))
 736            ;;(ding)
 737            (delete-process acap-process))
 738           (CHANGE (cons 'change
 739                         (list (acap-parse-quoted)
 740                               (progn
 741                                 (acap-forward)
 742                                 (acap-parse-quoted))
 743                               (progn
 744                                 (acap-forward)
 745                                 (acap-parse-number))
 746                               (progn
 747                                 (acap-forward)
 748                                 (acap-parse-number))
 749                               (progn
 750                                 (acap-forward)
 751                                 (acap-parse-return-data-list)))))
 752           (LANG (cons 'lang (list (acap-parse-quoted-list))))
 753           ;; response-stat
 754           (OK   (cons 'stat-ok (acap-parse-resp-body)))
 755           (NO   (cons 'stat-no (acap-parse-resp-body)))
 756           (BAD  ;(cons 'stat-bad (acap-parse-resp-body))
 757            ;; XXX cyrus-sml-acap does not return tagged bad response?
 758            (error (nth 1 (acap-parse-resp-body))))))
 759        ((integerp token)
 760         ;; tagged response.
 761         (setq tag token)
 762         (case (prog1 (setq token (read (current-buffer)))
 763                 (acap-forward))
 764           (DELETED   (cons 'deleted (acap-parse-quoted)))
 765           ;; response-done
 766           ((OK Ok ok) (prog1 (cons 'done-ok (acap-parse-resp-body))
 767                         (setq acap-reached-tag tag)))
 768           ((NO No no)   (prog1 (cons 'done-no (acap-parse-resp-body))
 769                           (setq acap-reached-tag tag)))
 770           ((BAD Bad bad) (prog1 (cons 'done-bad (acap-parse-resp-body))
 771                            (setq acap-reached-tag tag)))
 772           (ENTRY (cons 'entry
 773                        (list
 774                         (acap-parse-entry)
 775                         (progn (acap-forward)
 776                                (acap-parse-return-data-list)))))
 777           (LISTRIGHTS (cons 'listrights
 778                             (acap-parse-quoted-list)))
 779           (MODTIME    (cons 'modtime (acap-parse-time)))
 780           (MYRIGHTS   (cons 'myrights (acap-parse-quoted)))
 781           (QUOTA      (cons 'quota
 782                             (list (acap-parse-quoted)
 783                                   (progn
 784                                     (acap-forward)
 785                                     (acap-parse-number))
 786                                   (progn
 787                                     (acap-forward)
 788                                     (acap-parse-number))
 789                                   (acap-parse-extension-data))))
 790           (REFER      (cons 'refer (list (acap-parse-quoted)
 791                                          (acap-parse-quoted))))
 792           (REMOVEFROM (cons 'removefrom
 793                             (list (acap-parse-quoted)
 794                                   (progn
 795                                     (acap-forward)
 796                                     (acap-parse-quoted))
 797                                   (progn
 798                                     (acap-forward)
 799                                     (acap-parse-number)))))
 800           ;; response-extend
 801           (t ; extend-token
 802            (cons 'extend (list token (acap-parse-extension-data))))))
 803        (t ; garbage
 804         (list 'garbage token)))
 805       acap-response))))
 806
 807 ;;; Utilities.
 808 (defun acap-flatten (l)
 809   "Flatten list-of-list."
 810   (unless (null l)
 811     (append
 812      (if (and (car l)
 813               (listp (car l)))
 814          (car l)
 815        (list (car l)))
 816      (acap-flatten (cdr l)))))
 817
 818 (defun acap-flatten-r (l)
 819   "Flatten list-of-list recursively."
 820   (cond
 821    ((null l) '())
 822    ((listp l)
 823     (append (acap-flatten (car l)) (acap-flatten (cdr l))))
 824    (t (list l))))
 825
 826 (defun acap-encode-time (time)
 827   (format-time-string "%Y%m%d%H%M%S" (current-time) t)) ; Universal time.
 828
 829 (defun acap-decode-time (acap-time)
 830   (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)
 831     (encode-time (string-to-number (match-string 6 acap-time))
 832                  (string-to-number (match-string 5 acap-time))
 833                  (string-to-number (match-string 4 acap-time))
 834                  (string-to-number (match-string 3 acap-time))
 835                  (string-to-number (match-string 2 acap-time))
 836                  (string-to-number (match-string 1 acap-time))
 837                  t)))
 838
 839 (provide 'acap)
 840
 841 ;;; acap.el ends here