* elmo.el (elmo-folder-list-flagged): New generic function.
[elisp/wanderlust.git] / elmo / slp.el
1 ;;; slp.el --- An SLP interface.
2
3 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
4 ;; Keywords: SLP
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 ;; slp.el is an elisp library providing an interface for SLP (RFC2614)
29 ;; using OpenSLP(http://www.openslp.org/) slptool .
30 ;;
31 ;;; History:
32 ;; 28 Aug 2001 Created.
33
34 ;;; Code:
35
36 (defgroup slp nil
37   "Interface for `Service Location Protocol'."
38   :group 'comm)
39
40 (defcustom slp-program "slptool"
41   "SLP client program (OpenSLP's slptool)."
42   :type 'string
43   :group 'slp)
44
45 (defcustom slp-program-arguments nil
46   "Option argument for SLP client program."
47   :type '(repeat string)
48   :group 'slp)
49
50 (defun slp-exec-wait (type &rest args)
51   "Synchronous execution of slp-program.
52 TYPE is a symbol (one of `srvs', `attrs', `srvtypes', `as-is', `ignore')."
53   (with-temp-buffer
54     (let ((result (apply 'call-process slp-program nil t nil
55                          (append slp-program-arguments (delq nil args)))))
56       (unless (zerop result)
57         (error "SLP error: " (buffer-string)))
58       (goto-char (point-min))
59       (case type
60         (srvs (slp-parse-srvs))
61         (attrs (slp-parse-attrs))
62         (srvtypes (slp-parse-srvtypes))
63         (as-is (buffer-string))))))
64
65 ;; Response parser.
66 (defun slp-parse-srvs ()
67   (let (srvtype hostport host port lifetime srvs)
68     (while (and
69             (not (eobp))
70             (looking-at "service:\\([^:]+\\):/[^/]*/\\([^,]+\\),\\([0-9]+\\)"))
71       (setq srvtype (match-string 1)
72             hostport (match-string 2)
73             lifetime (string-to-number (match-string 3)))
74       (if (string-match ":\\([0-9]+\\)" hostport)
75           (setq host (substring hostport 0 (match-beginning 0))
76                 port (string-to-number (match-string 1 hostport)))
77         (setq host hostport
78               port nil))
79       (push (cons (list srvtype host port) lifetime) srvs)
80       (forward-line 1))
81     (list 'srvs (nreverse srvs))))
82
83 (defsubst slp-forward ()
84   (or (eobp) (forward-char)))
85
86 (defun slp-parse-attr ()
87   (when (looking-at "(\\([^=]+\\)=\\([^)]+\\))")
88     (prog1 (cons (match-string 1) (match-string 2))
89       (goto-char (match-end 0)))))
90
91 (defun slp-parse-attrs ()
92   (let (attrs)
93     (push (slp-parse-attr) attrs)
94     (while (eq (char-after (point)) ?,)
95       (slp-forward)
96       (push (slp-parse-attr) attrs))
97     (list 'attrs (nreverse attrs))))
98
99 (defun slp-parse-srvtypes ()
100   (let (types)
101     (while (not (eobp))
102       (when (looking-at "^service:\\([^/\n]+\\)$")
103         (push (buffer-substring (match-beginning 1) (match-end 1)) types))
104       (forward-line 1))
105     (list 'srvtypes (nreverse types))))
106
107 ;; Response accessor.
108 (defsubst slp-response-type (response)
109   (nth 0 response))
110
111 (defsubst slp-response-body (response)
112   (nth 1 response))
113
114 (defsubst slp-response-srv-url-service-type (srv)
115   (nth 0 (car srv)))
116
117 (defsubst slp-response-srv-url-host (srv)
118   (nth 1 (car srv)))
119
120 (defsubst slp-response-srv-url-port (srv)
121   (nth 2 (car srv)))
122
123 (defsubst slp-response-srv-lifetime (srv)
124   (cdr srv))
125
126 ;; Commands
127 (defun slp-findsrvs (service-type &optional filter)
128   (slp-exec-wait 'srvs "findsrvs" service-type filter))
129
130 (defun slp-findattrs (url &rest attrids)
131   (apply 'slp-exec-wait 'attrs "findattrs" url attrids))
132
133 (defun slp-findsrvtypes (&optional authority)
134   (slp-exec-wait 'srvtypes "findsrvtypes" authority))
135
136 (defun slp-findscopes ()
137   (slp-exec-wait 'as-is "findscopes"))
138
139 (defun slp-register (url &optional attrs)
140   (slp-exec-wait 'ignore "register" url (mapconcat
141                                          (lambda (pair)
142                                            (format "(%s=%s)"
143                                                    (car pair)
144                                                    (cdr pair)))
145                                          attrs
146                                          ",")))
147
148 (defun slp-deregister (url)
149   (slp-exec-wait 'ignore "deregister" url))
150
151 (defun slp-getproperty (propertyname)
152   (slp-exec-wait 'as-is "getproperty" propertyname))
153
154 (provide 'slp)
155
156 ;;; slp.el ends here