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