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