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-bye-p (response)
 449   (assq 'bye response))
 450
 451 (defun acap-response-bye-message (response)
 452   (nth 1 (cdr (assq 'bye response))))
 453
 454 (defun acap-response-cont-p (response)
 455   (assq 'cont response))
 456
 457 (defun acap-response-cont-string (response)
 458   (cdr (assq 'cont response)))
 459
 460 (defun acap-response-body (response)
 461   (cdr (or (assq 'done-ok response)
 462            (assq 'done-no response)
 463            (assq 'done-bad response))))
 464
 465 (defun acap-response-entries (response)
 466   (let (entries)
 467     (dolist (ent response)
 468       (if (eq (car ent) 'entry)
 469           (setq entries (cons ent entries))))
 470     entries))
 471
 472 (defun acap-response-entry-entry (entry)
 473   (car (cdr entry)))
 474
 475 (defun acap-response-entry-return-data-list (entry)
 476   (nth 1 (cdr entry)))
 477
 478 (defun acap-response-return-data-list-get-value (name return-data-list)
 479   (nth 1 (assoc name return-data-list)))
 480
 481 (defun acap-response-listrights (response)
 482   (cdr (assq 'listrights response)))
 483
 484 ;;; Send command, data.
 485 (defun acap-response-clear (process)
 486   (with-current-buffer (process-buffer process)
 487     (setq acap-response nil)))
 488
 489 (defun acap-send-command-wait (process command)
 490   (acap-wait-for-response process (acap-send-command process command)))
 491
 492 (defun acap-send-data-wait (process string tag)
 493   (cond ((stringp string)
 494          (acap-send-command-1 process string))
 495         ((bufferp string)
 496          (with-current-buffer string
 497            (acap-response-clear process)
 498            (acap-send-command-1 process (format "{%d}" (buffer-size)))
 499            (if (acap-response-cont-p (acap-wait-for-response process tag))
 500                (with-current-buffer string
 501                  (acap-response-clear process)
 502                  (process-send-region process (point-min)
 503                                       (point-max))
 504                  (process-send-string process acap-client-eol)))
 505            (acap-debug (concat (buffer-string) acap-client-eol)))))
 506   (acap-wait-for-response process tag))
 507
 508 (defun acap-send-command-1 (process cmdstr)
 509   (acap-debug (concat "<-" cmdstr acap-client-eol))
 510   (process-send-string process (concat cmdstr acap-client-eol)))
 511
 512 (defun acap-send-command (process command)
 513   (with-current-buffer (process-buffer process)
 514     (setq acap-response nil)
 515     (if (not (listp command)) (setq command (list command)))
 516     (let ((tag (setq acap-tag (1+ acap-tag)))
 517           cmd cmdstr response)
 518       (setq cmdstr (concat (number-to-string acap-tag) " "))
 519       (while (setq cmd (pop command))
 520         (cond ((stringp cmd)
 521                (setq cmdstr (concat cmdstr cmd)))
 522               ((bufferp cmd)
 523                (with-current-buffer cmd
 524                  (setq cmdstr (concat cmdstr (format "{%d}" (buffer-size)))))
 525                (unwind-protect
 526                    (progn
 527                      (acap-send-command-1 process cmdstr)
 528                      (setq cmdstr nil
 529                            response (acap-wait-for-response process tag))
 530                      (if (not (acap-response-cont-p response))
 531                          (setq command nil) ;; abort command if no cont-req
 532                        (with-current-buffer cmd
 533                          (process-send-region process (point-min)
 534                                               (point-max))
 535                          (process-send-string process acap-client-eol))))))
 536               (t (error "Unknown command type"))))
 537       (when cmdstr
 538         (acap-send-command-1 process cmdstr))
 539       tag)))
 540
 541 (defun acap-wait-for-response (process tag)
 542   (with-current-buffer (process-buffer process)
 543     (while (and (not (acap-response-cont-p acap-response))
 544                 (< acap-reached-tag tag))
 545       (when (acap-response-bye-p acap-response)
 546         (error (prog1 (acap-response-bye-message acap-response)
 547                  (setq acap-response nil))))
 548       (or (and (not (memq (process-status process) '(open run)))
 549                (sit-for 1))
 550           (let ((len (/ (point-max) 1024))
 551                 message-log-max)
 552             (unless (< len 10)
 553               (message "acap read: %dk" len))
 554             (accept-process-output process 1))))
 555     (message "")
 556     acap-response))
 557
 558 ;;; Sentinel, Filter.
 559 (defun acap-sentinel (process string)
 560   (delete-process process))
 561
 562 (defun acap-find-next-line ()
 563   (when (re-search-forward (concat acap-server-eol "\\|{\\([0-9+]+\\)}"
 564                                    acap-server-eol)
 565                            nil t)
 566     (if (match-string 1)
 567         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
 568             nil
 569           (goto-char (+ (point) (string-to-number (match-string 1))))
 570           (acap-find-next-line))
 571       (point))))
 572
 573 (defun acap-arrival-filter (proc string)
 574   "ACAP process filter."
 575   (acap-debug string)
 576   (with-current-buffer (process-buffer proc)
 577     (goto-char (point-max))
 578     (insert string)
 579     (let (end)
 580       (goto-char (point-min))
 581       (while (setq end (acap-find-next-line))
 582         (save-restriction
 583           (narrow-to-region (point-min) end)
 584           (delete-backward-char (length acap-server-eol))
 585           (goto-char (point-min))
 586           (unwind-protect
 587               (cond ((or (eq acap-state 'auth)
 588                          (eq acap-state 'initial)
 589                          (eq acap-state 'nonauth))
 590                      (acap-parse-response))
 591                     (t
 592                      (message "Unknown state %s in arrival filter"
 593                               acap-state)))
 594             (delete-region (point-min) (point-max))))))))
 595
 596 ;;; acap parser.
 597 (defsubst acap-forward ()
 598   (or (eobp) (forward-char)))
 599
 600 (defsubst acap-parse-number ()
 601   (when (looking-at "[0-9]+")
 602     (prog1
 603         (string-to-number (match-string 0))
 604       (goto-char (match-end 0)))))
 605
 606 (defsubst acap-parse-literal ()
 607   (when (looking-at "{\\([0-9]+\\)}\r\n")
 608     (let ((pos (match-end 0))
 609           (len (string-to-number (match-string 1))))
 610       (if (< (point-max) (+ pos len))
 611           nil
 612         (goto-char (+ pos len))
 613         (buffer-substring pos (+ pos len))))))
 614
 615 (defun acap-parse-greeting ()
 616   (when (looking-at "* ACAP")
 617     (goto-char (match-end 0))
 618     (acap-forward)
 619     (let (capabilities)
 620       (while (eq (char-after (point)) ?\()
 621         (push (read (current-buffer)) capabilities)
 622         (acap-forward))
 623       (nreverse capabilities))))
 624
 625 ;; resp-body = ["(" resp-code ")" SP] quoted
 626 (defun acap-parse-resp-body ()
 627   (let ((body (read (current-buffer))))
 628     (if (listp body) ; resp-code
 629         (list body (read (current-buffer)))
 630       (list nil body) ; no resp-code.
 631       )))
 632
 633 ;;   string          = quoted / literal
 634 ;;
 635 ;;   quoted          = DQUOTE *QUOTED-CHAR DQUOTE
 636 ;;
 637 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
 638 ;;                     "\" quoted-specials
 639 ;;
 640 ;;   quoted-specials = DQUOTE / "\"
 641 ;;
 642 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
 643
 644 (defsubst acap-parse-string ()
 645   (cond ((eq (char-after) ?\")
 646          (forward-char 1)
 647          (let ((p (point)) (name ""))
 648            (skip-chars-forward "^\"\\\\")
 649            (setq name (buffer-substring p (point)))
 650            (while (eq (char-after) ?\\)
 651              (setq p (1+ (point)))
 652              (forward-char 2)
 653              (skip-chars-forward "^\"\\\\")
 654              (setq name (concat name (buffer-substring p (point)))))
 655            (forward-char 1)
 656            name))
 657         ((eq (char-after) ?{)
 658          (acap-parse-literal))))
 659
 660 ;;   nil             = "NIL"
 661
 662 (defsubst acap-parse-nil ()
 663   (if (looking-at "NIL")
 664       (goto-char (match-end 0))))
 665
 666 ;; entry              = entry-name / entry-path
 667 ;; entry-name         = string-utf8
 668 ;;                        ;; entry name MUST NOT contain slash
 669 ;;                        ;; MUST NOT begin with "."
 670 ;; entry-path         = string-utf8
 671 ;;                        ;; slash-separated path to entry
 672 ;;                        ;; begins with slash
 673
 674 (defsubst acap-parse-quoted ()
 675   (if (eq (char-after) ?\")
 676       (read (current-buffer))))
 677
 678 (defun acap-parse-entry ()
 679   (acap-parse-quoted))
 680
 681 ;; value              = string
 682 (defun acap-parse-value ()
 683   (acap-parse-string))
 684
 685 ;; value-list         = "(" [value *(SP value)] ")"
 686 (defun acap-parse-value-list ()
 687   ;; same as acl.
 688   (when (eq (char-after (point)) ?\()
 689     (let (values)
 690       (while (not (eq (char-after (point)) ?\)))
 691         (acap-forward)
 692         (push (acap-parse-value) values))
 693       (acap-forward)
 694       (nreverse values))))
 695
 696 ;;
 697 ;;   return-data-list   = return-data *(SP return-data)
 698 ;;
 699 ;;   return-data        = return-metadata / return-metalist /
 700 ;;                        return-attr-list
 701
 702 (defun acap-parse-return-data-list ()
 703   (let (rlist r)
 704     (setq rlist (list (acap-parse-return-metadata-or-return-metalist)))
 705     (acap-forward)
 706     (while (setq r (acap-parse-return-metadata-or-return-metalist))
 707       (setq rlist (nconc rlist (list r)))
 708       (acap-forward))
 709     rlist))
 710
 711 (defun acap-parse-return-metadata-or-return-metalist ()
 712   (or (acap-parse-string)
 713       (acap-parse-value-or-return-metalist)
 714       (and (acap-parse-nil) nil)))
 715
 716 (defun acap-parse-value-or-return-metalist ()
 717   (when (eq (char-after (point)) ?\()
 718     (let (elems)
 719       (while (not (eq (char-after (point)) ?\)))
 720         (acap-forward)
 721         (push (or (acap-parse-value)
 722                   (acap-parse-return-metalist))
 723               elems))
 724       (acap-forward)
 725       (nreverse elems))))
 726
 727 ;;   return-metalist    = "(" return-metadata *(SP return-metadata) ")"
 728 ;;                        ;; occurs when multiple metadata items requested
 729 ;;
 730 (defun acap-parse-return-metalist ()
 731   (when (eq (char-after (point)) ?\()
 732     (let (metadatas)
 733       (while (not (eq (char-after (point)) ?\)))
 734         (acap-forward)
 735         (push (acap-parse-return-metadata) metadatas))
 736       (acap-forward)
 737       (nreverse metadatas))))
 738
 739 ;;   return-metadata    = nil / string / value-list / acl
 740 (defun acap-parse-return-metadata ()
 741   (or (acap-parse-string)
 742       (acap-parse-value-list)
 743       (and (acap-parse-nil) nil)
 744       ;; (acap-parse-acl) acl is same as value-list.
 745       ))
 746
 747 ;;   return-attr-list   = "(" return-metalist *(SP return-metalist) ")"
 748 ;;                        ;; occurs when "*" in RETURN pattern on SEARCH
 749 (defun acap-parse-return-attr-list ()
 750   (when (eq (char-after (point)) ?\()
 751     (let (metalists)
 752       (while (not (eq (char-after (point)) ?\)))
 753         (acap-forward)
 754         (push (acap-parse-return-metalist) metalists))
 755       (acap-forward)
 756       (nreverse metalists))))
 757
 758 (defun acap-parse-time ()
 759   (acap-parse-quoted))
 760
 761 ;; quoted *(SP quoted)
 762 (defun acap-parse-quoted-list ()
 763   (let (qlist q)
 764     (setq qlist (list (acap-parse-quoted)))
 765     (acap-forward)
 766     (while (setq q (acap-parse-quoted))
 767       (setq qlist (nconc qlist (list q)))
 768       (acap-forward))
 769     qlist))
 770
 771 (defun acap-parse-any ()
 772   (read (current-buffer)))
 773
 774 (defun acap-parse-extension-data ()
 775   (let (elist e)
 776     (setq elist (list (acap-parse-any)))
 777     (acap-forward)
 778     (while (setq e (acap-parse-any))
 779       (setq elist (nconc elist (list e)))
 780       (acap-forward))
 781     elist))
 782
 783 (defun acap-parse-response ()
 784   "Parse a ACAP command response."
 785   (let ((token (read (current-buffer)))
 786         tag)
 787     (setq
 788      acap-response
 789      (cons
 790       (cond
 791        ((eq token '+)
 792         (acap-forward)
 793         (cons 'cont (acap-parse-string)))
 794        ((eq token '*)
 795         ;; untagged response.
 796         (case (prog1 (setq token (read (current-buffer)))
 797                 (acap-forward))
 798           (ADDTO (cons 'addto
 799                        (list (acap-parse-quoted)
 800                              (progn
 801                                (acap-forward)
 802                                (acap-parse-quoted))
 803                              (progn
 804                                (acap-forward)
 805                                (acap-parse-number))
 806                              (progn
 807                                (acap-forward)
 808                                (acap-parse-return-data-list)))))
 809           (ALERT ;(cons 'alert (acap-parse-resp-body))
 810            (message (nth 1 (acap-parse-resp-body))))
 811           ((BYE Bye bye)
 812            (cons 'bye (acap-parse-resp-body)))
 813           (CHANGE (cons 'change
 814                         (list (acap-parse-quoted)
 815                               (progn
 816                                 (acap-forward)
 817                                 (acap-parse-quoted))
 818                               (progn
 819                                 (acap-forward)
 820                                 (acap-parse-number))
 821                               (progn
 822                                 (acap-forward)
 823                                 (acap-parse-number))
 824                               (progn
 825                                 (acap-forward)
 826                                 (acap-parse-return-data-list)))))
 827           (LANG (cons 'lang (list (acap-parse-quoted-list))))
 828           ;; response-stat
 829           (OK   (cons 'stat-ok (acap-parse-resp-body)))
 830           (NO   (cons 'stat-no (acap-parse-resp-body)))
 831           (BAD  ;(cons 'stat-bad (acap-parse-resp-body))
 832            ;; XXX cyrus-sml-acap does not return tagged bad response?
 833            (error (nth 1 (acap-parse-resp-body))))))
 834        ((integerp token)
 835         ;; tagged response.
 836         (setq tag token)
 837         (case (prog1 (setq token (read (current-buffer)))
 838                 (acap-forward))
 839           (DELETED   (cons 'deleted (acap-parse-quoted)))
 840           ;; response-done
 841           ((OK Ok ok) (prog1 (cons 'done-ok (acap-parse-resp-body))
 842                         (setq acap-reached-tag tag)))
 843           ((NO No no)   (prog1 (cons 'done-no (acap-parse-resp-body))
 844                           (setq acap-reached-tag tag)))
 845           ((BAD Bad bad) (prog1 (cons 'done-bad (acap-parse-resp-body))
 846                            (setq acap-reached-tag tag)))
 847           (ENTRY (cons 'entry
 848                        (list
 849                         (acap-parse-entry)
 850                         (progn (acap-forward)
 851                                (acap-parse-return-data-list)))))
 852           (LISTRIGHTS (cons 'listrights
 853                             (acap-parse-quoted-list)))
 854           (MODTIME    (cons 'modtime (acap-parse-time)))
 855           (MYRIGHTS   (cons 'myrights (acap-parse-quoted)))
 856           (QUOTA      (cons 'quota
 857                             (list (acap-parse-quoted)
 858                                   (progn
 859                                     (acap-forward)
 860                                     (acap-parse-number))
 861                                   (progn
 862                                     (acap-forward)
 863                                     (acap-parse-number))
 864                                   (acap-parse-extension-data))))
 865           (REFER      (cons 'refer (list (acap-parse-quoted)
 866                                          (acap-parse-quoted))))
 867           (REMOVEFROM (cons 'removefrom
 868                             (list (acap-parse-quoted)
 869                                   (progn
 870                                     (acap-forward)
 871                                     (acap-parse-quoted))
 872                                   (progn
 873                                     (acap-forward)
 874                                     (acap-parse-number)))))
 875           ;; response-extend
 876           (t ; extend-token
 877            (cons 'extend (list token (acap-parse-extension-data))))))
 878        (t ; garbage
 879         (list 'garbage token)))
 880       acap-response))))
 881
 882 ;;; Utilities.
 883 (defun acap-flatten (l)
 884   "Flatten list-of-list."
 885   (unless (null l)
 886     (append
 887      (if (and (car l)
 888               (listp (car l)))
 889          (car l)
 890        (list (car l)))
 891      (acap-flatten (cdr l)))))
 892
 893 (defun acap-flatten-r (l)
 894   "Flatten list-of-list recursively."
 895   (cond
 896    ((null l) '())
 897    ((listp l)
 898     (append (acap-flatten (car l)) (acap-flatten (cdr l))))
 899    (t (list l))))
 900
 901 (defun acap-encode-time (time)
 902   (format-time-string "%Y%m%d%H%M%S" (current-time) t)) ; Universal time.
 903
 904 (defun acap-decode-time (acap-time)
 905   (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)
 906     (encode-time (string-to-number (match-string 6 acap-time))
 907                  (string-to-number (match-string 5 acap-time))
 908                  (string-to-number (match-string 4 acap-time))
 909                  (string-to-number (match-string 3 acap-time))
 910                  (string-to-number (match-string 2 acap-time))
 911                  (string-to-number (match-string 1 acap-time))
 912                  t)))
 913
 914 (provide 'acap)
 915
 916 ;;; acap.el ends here