crepu.dev Git - config.git/blob - djavu-asus/emacs/elpa/jabber-20230715.456/jabber-widget.el

1 ;; jabber-widget.el - display various kinds of forms -*- lexical-binding: t; -*-

6 ;; This file is a part of jabber.el.

8 ;; This program is free software; you can redistribute it and/or modify

9 ;; it under the terms of the GNU General Public License as published by

10 ;; the Free Software Foundation; either version 2 of the License, or

11 ;; (at your option) any later version.

13 ;; This program is distributed in the hope that it will be useful,

14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of

15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

16 ;; GNU General Public License for more details.

18 ;; You should have received a copy of the GNU General Public License

19 ;; along with this program; if not, write to the Free Software

20 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

22 (require 'widget)

23 (require 'wid-edit)

24 (require 'jabber-util)

25 (require 'jabber-disco)

27 (defvar jabber-widget-alist nil

28 "Alist of widgets currently used.")

30 (defvar jabber-form-type nil

31 "Type of form.

32 One of:

33 'x-data, jabber:x:data

34 'register, as used in jabber:iq:register and jabber:iq:search.")

36 (defvar jabber-submit-to nil

37 "JID of the entity to which form data is to be sent.")

39 (jabber-disco-advertise-feature "jabber:x:data")

41 (define-widget 'jid 'string

42 "JID widget."

43 :value-to-internal (lambda (widget value)

44 (let ((displayname (jabber-jid-rostername value)))

45 (if displayname

46 (format "%s <%s>" displayname value)

47 value)))

48 :value-to-external (lambda (widget value)

49 (if (string-match "<\$[^>]+\$>[ \t]*$" value)

50 (match-string 1 value)

51 value))

52 :complete-function 'jid-complete)

54 (defun jid-complete ()

55 "Perform completion on JID preceding point."

56 (interactive)

57 ;; mostly stolen from widget-color-complete

58 (let* ((prefix (buffer-substring-no-properties (widget-field-start widget)

59 (point)))

60 (list (append (mapcar #'symbol-name *jabber-roster*)

61 (delq nil

62 (mapcar #'(lambda (item)

63 (when (jabber-jid-rostername item)

64 (format "%s <%s>" (jabber-jid-rostername item)

65 (symbol-name item))))

66 *jabber-roster*))))

67 (completion (try-completion prefix list)))

68 (cond ((eq completion t)

69 (message "Exact match."))

70 ((null completion)

71 (error "Can't find completion for \"%s\"" prefix))

72 ((not (string-equal prefix completion))

73 (insert-and-inherit (substring completion (length prefix))))

74 (t

75 (message "Making completion list...")

76 (with-output-to-temp-buffer "*Completions*"

77 (display-completion-list (all-completions prefix list nil)))

78 (message "Making completion list...done")))))

80 (defun jabber-init-widget-buffer (submit-to)

81 "Setup buffer-local variables for widgets."

82 (make-local-variable 'jabber-widget-alist)

83 (make-local-variable 'jabber-submit-to)

84 (setq jabber-widget-alist nil)

85 (setq jabber-submit-to submit-to)

86 (setq buffer-read-only nil)

87 ;; XXX: This is because data from other queries would otherwise be

88 ;; appended to this buffer, which would fail since widget buffers

89 ;; are read-only... or something like that. Maybe there's a

90 ;; better way.

91 (rename-uniquely))

93 (defun jabber-render-register-form (query &optional default-username)

94 "Display widgets from <query/> element in IQ register or search namespace.

95 Display widgets from <query/> element in jabber:iq:{register,search} namespace.

96 DEFAULT-USERNAME is the default value for the username field."

97 (make-local-variable 'jabber-widget-alist)

98 (setq jabber-widget-alist nil)

99 (make-local-variable 'jabber-form-type)

100 (setq jabber-form-type 'register)

101

102 (if (jabber-xml-get-children query 'instructions)

103 (widget-insert "Instructions: " (car (jabber-xml-node-children (car (jabber-xml-get-children query 'instructions)))) "\n"))

104 (if (jabber-xml-get-children query 'registered)

105 (widget-insert "You are already registered. You can change your details here.\n"))

106 (widget-insert "\n")

107

108 (let ((possible-fields

109 ;; taken from XEP-0077

110 '((username . "Username")

111 (nick . "Nickname")

112 (password . "Password")

113 (name . "Full name")

114 (first . "First name")

115 (last . "Last name")

116 (email . "E-mail")

117 (address . "Address")

118 (city . "City")

119 (state . "State")

120 (zip . "Zip")

121 (phone . "Telephone")

122 (url . "Web page")

123 (date . "Birth date"))))

124 (dolist (field (jabber-xml-node-children query))

125 (let ((entry (assq (jabber-xml-node-name field) possible-fields)))

126 (when entry

127 (widget-insert (cdr entry) "\t")

128 ;; Special case: when registering a new account, the default

129 ;; username is the one specified in jabber-username. Things

130 ;; will break if the user changes that name, though...

131 (let ((default-value (or (when (eq (jabber-xml-node-name field) 'username)

132 default-username)

133 "")))

134 (setq jabber-widget-alist

135 (cons

136 (cons (car entry)

137 (widget-create 'editable-field

138 :secret (if (eq (car entry) 'password)

139 ?* nil)

140 (or (car (jabber-xml-node-children

141 field)) default-value)))

142 jabber-widget-alist)))

143 (widget-insert "\n"))))))

144

145 (defun jabber-parse-register-form ()

146 "Return children of a <query/> tag containing information entered.

147 Return children of a <query/> tag containing information entered in the

148 widgets of the current buffer."

149 (mapcar

150 (lambda (widget-cons)

151 (list (car widget-cons)

152 nil

153 (widget-value (cdr widget-cons))))

154 jabber-widget-alist))

155

156 (defun jabber-render-xdata-form (x &optional defaults)

157 "Display widgets from <x/> element in jabber:x:data namespace.

158 DEFAULTS is an alist associating variable names with default values.

159 DEFAULTS takes precedence over values specified in the form."

160 (make-local-variable 'jabber-widget-alist)

161 (setq jabber-widget-alist nil)

162 (make-local-variable 'jabber-form-type)

163 (setq jabber-form-type 'xdata)

164

165 (let ((title (car (jabber-xml-node-children (car (jabber-xml-get-children x 'title))))))

166 (if (stringp title)

167 (widget-insert (jabber-propertize title 'face 'jabber-title-medium) "\n\n")))

168 (let ((instructions (car (jabber-xml-node-children (car (jabber-xml-get-children x 'instructions))))))

169 (if (stringp instructions)

170 (widget-insert "Instructions: " instructions "\n\n")))

171

172 (dolist (field (jabber-xml-get-children x 'field))

173 (let* ((var (jabber-xml-get-attribute field 'var))

174 (label (jabber-xml-get-attribute field 'label))

175 (type (jabber-xml-get-attribute field 'type))

176 (required (jabber-xml-get-children field 'required))

177 (values (jabber-xml-get-children field 'value))

178 (options (jabber-xml-get-children field 'option))

179 (desc (car (jabber-xml-get-children field 'desc)))

180 (default-value (assoc var defaults)))

181 ;; "required" not implemented yet

182

183 (cond

184 ((string= type "fixed")

185 (widget-insert (car (jabber-xml-node-children (car values)))))

186

187 ((string= type "text-multi")

188 (if (or label var)

189 (widget-insert (or label var) ":\n"))

190 (push (cons (cons var type)

191 (widget-create 'text (or (cdr default-value)

192 (mapconcat #'(lambda (val)

193 (car (jabber-xml-node-children val)))

194 values "\n")

195 "")))

196 jabber-widget-alist))

197

198 ((string= type "list-single")

199 (if (or label var)

200 (widget-insert (or label var) ":\n"))

201 (push (cons (cons var type)

202 (apply 'widget-create

203 'radio-button-choice

204 :value (or (cdr default-value)

205 (car (xml-node-children (car values))))

206 (mapcar (lambda (option)

207 `(item :tag ,(jabber-xml-get-attribute option 'label)

208 :value ,(car (jabber-xml-node-children (car (jabber-xml-get-children option 'value))))))

209 options)))

210 jabber-widget-alist))

211

212 ((string= type "boolean")

213 (push (cons (cons var type)

214 (widget-create 'checkbox

215 :tag (or label var)

216 :value (if default-value

217 (cdr default-value)

218 (not (null

219 (member (car (xml-node-children (car values))) '("1" "true")))))))

220 jabber-widget-alist)

221 (if (or label var)

222 (widget-insert " " (or label var) "\n")))

223

224 (t ; in particular including text-single and text-private

225 (if (or label var)

226 (widget-insert (or label var) ": "))

227 (setq jabber-widget-alist

228 (cons

229 (cons (cons var type)

230 (widget-create 'editable-field

231 :secret (if (string= type "text-private") ?* nil)

232 (or (cdr default-value)

233 (car (jabber-xml-node-children (car values)))

234 "")))

235 jabber-widget-alist))))

236 (when (and desc (car (jabber-xml-node-children desc)))

237 (widget-insert "\n" (car (jabber-xml-node-children desc))))

238 (widget-insert "\n"))))

239

240 (defun jabber-parse-xdata-form ()

241 "Return an <x/> tag containing information entered in the widgets.

242 Return an <x/> tag containing information entered in the widgets of the current

243 buffer."

244 `(x ((xmlns . "jabber:x:data")

245 (type . "submit"))

246 ,@(mapcar

247 (lambda (widget-cons)

248 (let ((values (jabber-xdata-value-convert (widget-value (cdr widget-cons)) (cdar widget-cons))))

249 ;; empty fields are not included

250 (when values

251 `(field ((var . ,(caar widget-cons)))

252 ,@(mapcar

253 (lambda (value)

254 (list 'value nil value))

255 values)))))

256 jabber-widget-alist)))

257

258 (defun jabber-xdata-value-convert (value type)

259 "Convert VALUE from form used by widget library to form required by XEP-0004.

260 Return a list of strings, each of which to be included as cdata in a

261 <value/> tag."

262 (cond

263 ((string= type "boolean")

264 (if value (list "1") (list "0")))

265 ((string= type "text-multi")

266 (split-string value "[\n\r]"))

267 (t ; in particular including text-single, text-private and list-single

268 (if (zerop (length value))

269 nil

270 (list value)))))

271

272 (defun jabber-render-xdata-search-results (xdata)

273 "Render search results in x:data form."

274 (let ((title (car (jabber-xml-get-children xdata 'title))))

275 (when title

276 (insert (jabber-propertize (car (jabber-xml-node-children title)) 'face 'jabber-title-medium) "\n")))

277 (if (jabber-xml-get-children xdata 'reported)

278 (jabber-render-xdata-search-results-multi xdata)

279 (jabber-render-xdata-search-results-single xdata)))

280

281 (defun jabber-render-xdata-search-results-multi (xdata)

282 "Render multi-record search results."

283 (let (fields

284 (jid-fields 0))

285 (let ((reported (car (jabber-xml-get-children xdata 'reported)))

286 (column 0))

287 (dolist (field (jabber-xml-get-children reported 'field))

288 (let (width)

289 ;; Clever algorithm for estimating width based on field type goes here.

290 (setq width 20)

291

292 (setq fields

293 (append

294 fields

295 (list (cons (jabber-xml-get-attribute field 'var)

296 (list 'label (jabber-xml-get-attribute field 'label)

297 'type (jabber-xml-get-attribute field 'type)

298 'column column)))))

299 (setq column (+ column width))

300 (if (string= (jabber-xml-get-attribute field 'type) "jid-single")

301 (setq jid-fields (1+ jid-fields))))))

302

303 (dolist (field-cons fields)

304 (indent-to (plist-get (cdr field-cons) 'column) 1)

305 (insert (jabber-propertize (plist-get (cdr field-cons) 'label) 'face 'bold)))

306 (insert "\n\n")

307

308 ;; Now, the items

309 (dolist (item (jabber-xml-get-children xdata 'item))

310

311 (let ((start-of-line (point))

312 jid)

313

314 ;; The following code assumes that the order of the <field/>s in each

315 ;; <item/> is the same as in the <reported/> tag.

316 (dolist (field (jabber-xml-get-children item 'field))

317 (let ((field-plist (cdr (assoc (jabber-xml-get-attribute field 'var) fields)))

318 (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value))))))

319

320 (indent-to (plist-get field-plist 'column) 1)

321

322 ;; Absent values are sometimes "", sometimes nil. insert

323 ;; doesn't like nil.

324 (when value

325 ;; If there is only one JID field, let the whole row

326 ;; have the jabber-jid property. If there are many JID

327 ;; fields, the string belonging to each field has that

328 ;; property.

329 (if (string= (plist-get field-plist 'type) "jid-single")

330 (if (not (eq jid-fields 1))

331 (insert (jabber-propertize value 'jabber-jid value))

332 (setq jid value)

333 (insert value))

334 (insert value)))))

335

336 (if jid

337 (put-text-property start-of-line (point)

338 'jabber-jid jid))

339 (insert "\n")))))

340

341 (defun jabber-render-xdata-search-results-single (xdata)

342 "Render single-record search results."

343 (dolist (field (jabber-xml-get-children xdata 'field))

344 (let ((label (jabber-xml-get-attribute field 'label))

345 (type (jabber-xml-get-attribute field 'type))

346 (values (mapcar #'(lambda (val)

347 (car (jabber-xml-node-children val)))

348 (jabber-xml-get-children field 'value))))

349 ;; XXX: consider type

350 (insert (jabber-propertize (concat label ": ") 'face 'bold))

351 (indent-to 30)

352 (insert (apply #'concat values) "\n"))))

353

354 (defun jabber-xdata-formtype (x)

355 "Return the form type of the xdata form in X, by XEP-0068.

356 Return nil if no form type is specified."

357 (catch 'found-formtype

358 (dolist (field (jabber-xml-get-children x 'field))

359 (when (and (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE")

360 (string= (jabber-xml-get-attribute field 'type) "hidden"))

361 (throw 'found-formtype (car (jabber-xml-node-children

362 (car (jabber-xml-get-children field 'value)))))))))

363

364 (provide 'jabber-widget)

365

366 ;;; arch-tag: da3312f3-1970-41d5-a974-14b8d76156b8