;; jabber-widget.el - display various kinds of forms -*- lexical-binding: t; -*-
;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu
;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
;; This file is a part of jabber.el.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(require 'widget)
(require 'wid-edit)
(require 'jabber-util)
(require 'jabber-disco)
(defvar jabber-widget-alist nil
"Alist of widgets currently used.")
(defvar jabber-form-type nil
"Type of form.
One of:
'x-data, jabber:x:data
'register, as used in jabber:iq:register and jabber:iq:search.")
(defvar jabber-submit-to nil
"JID of the entity to which form data is to be sent.")
(jabber-disco-advertise-feature "jabber:x:data")
(define-widget 'jid 'string
"JID widget."
:value-to-internal (lambda (widget value)
(let ((displayname (jabber-jid-rostername value)))
(if displayname
(format "%s <%s>" displayname value)
value)))
:value-to-external (lambda (widget value)
(if (string-match "<\\([^>]+\\)>[ \t]*$" value)
(match-string 1 value)
value))
:complete-function 'jid-complete)
(defun jid-complete ()
"Perform completion on JID preceding point."
(interactive)
;; mostly stolen from widget-color-complete
(let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
(point)))
(list (append (mapcar #'symbol-name *jabber-roster*)
(delq nil
(mapcar #'(lambda (item)
(when (jabber-jid-rostername item)
(format "%s <%s>" (jabber-jid-rostername item)
(symbol-name item))))
*jabber-roster*))))
(completion (try-completion prefix list)))
(cond ((eq completion t)
(message "Exact match."))
((null completion)
(error "Can't find completion for \"%s\"" prefix))
((not (string-equal prefix completion))
(insert-and-inherit (substring completion (length prefix))))
(t
(message "Making completion list...")
(with-output-to-temp-buffer "*Completions*"
(display-completion-list (all-completions prefix list nil)))
(message "Making completion list...done")))))
(defun jabber-init-widget-buffer (submit-to)
"Setup buffer-local variables for widgets."
(make-local-variable 'jabber-widget-alist)
(make-local-variable 'jabber-submit-to)
(setq jabber-widget-alist nil)
(setq jabber-submit-to submit-to)
(setq buffer-read-only nil)
;; XXX: This is because data from other queries would otherwise be
;; appended to this buffer, which would fail since widget buffers
;; are read-only... or something like that. Maybe there's a
;; better way.
(rename-uniquely))
(defun jabber-render-register-form (query &optional default-username)
"Display widgets from element in IQ register or search namespace.
Display widgets from element in jabber:iq:{register,search} namespace.
DEFAULT-USERNAME is the default value for the username field."
(make-local-variable 'jabber-widget-alist)
(setq jabber-widget-alist nil)
(make-local-variable 'jabber-form-type)
(setq jabber-form-type 'register)
(if (jabber-xml-get-children query 'instructions)
(widget-insert "Instructions: " (car (jabber-xml-node-children (car (jabber-xml-get-children query 'instructions)))) "\n"))
(if (jabber-xml-get-children query 'registered)
(widget-insert "You are already registered. You can change your details here.\n"))
(widget-insert "\n")
(let ((possible-fields
;; taken from XEP-0077
'((username . "Username")
(nick . "Nickname")
(password . "Password")
(name . "Full name")
(first . "First name")
(last . "Last name")
(email . "E-mail")
(address . "Address")
(city . "City")
(state . "State")
(zip . "Zip")
(phone . "Telephone")
(url . "Web page")
(date . "Birth date"))))
(dolist (field (jabber-xml-node-children query))
(let ((entry (assq (jabber-xml-node-name field) possible-fields)))
(when entry
(widget-insert (cdr entry) "\t")
;; Special case: when registering a new account, the default
;; username is the one specified in jabber-username. Things
;; will break if the user changes that name, though...
(let ((default-value (or (when (eq (jabber-xml-node-name field) 'username)
default-username)
"")))
(setq jabber-widget-alist
(cons
(cons (car entry)
(widget-create 'editable-field
:secret (if (eq (car entry) 'password)
?* nil)
(or (car (jabber-xml-node-children
field)) default-value)))
jabber-widget-alist)))
(widget-insert "\n"))))))
(defun jabber-parse-register-form ()
"Return children of a tag containing information entered.
Return children of a tag containing information entered in the
widgets of the current buffer."
(mapcar
(lambda (widget-cons)
(list (car widget-cons)
nil
(widget-value (cdr widget-cons))))
jabber-widget-alist))
(defun jabber-render-xdata-form (x &optional defaults)
"Display widgets from element in jabber:x:data namespace.
DEFAULTS is an alist associating variable names with default values.
DEFAULTS takes precedence over values specified in the form."
(make-local-variable 'jabber-widget-alist)
(setq jabber-widget-alist nil)
(make-local-variable 'jabber-form-type)
(setq jabber-form-type 'xdata)
(let ((title (car (jabber-xml-node-children (car (jabber-xml-get-children x 'title))))))
(if (stringp title)
(widget-insert (jabber-propertize title 'face 'jabber-title-medium) "\n\n")))
(let ((instructions (car (jabber-xml-node-children (car (jabber-xml-get-children x 'instructions))))))
(if (stringp instructions)
(widget-insert "Instructions: " instructions "\n\n")))
(dolist (field (jabber-xml-get-children x 'field))
(let* ((var (jabber-xml-get-attribute field 'var))
(label (jabber-xml-get-attribute field 'label))
(type (jabber-xml-get-attribute field 'type))
(required (jabber-xml-get-children field 'required))
(values (jabber-xml-get-children field 'value))
(options (jabber-xml-get-children field 'option))
(desc (car (jabber-xml-get-children field 'desc)))
(default-value (assoc var defaults)))
;; "required" not implemented yet
(cond
((string= type "fixed")
(widget-insert (car (jabber-xml-node-children (car values)))))
((string= type "text-multi")
(if (or label var)
(widget-insert (or label var) ":\n"))
(push (cons (cons var type)
(widget-create 'text (or (cdr default-value)
(mapconcat #'(lambda (val)
(car (jabber-xml-node-children val)))
values "\n")
"")))
jabber-widget-alist))
((string= type "list-single")
(if (or label var)
(widget-insert (or label var) ":\n"))
(push (cons (cons var type)
(apply 'widget-create
'radio-button-choice
:value (or (cdr default-value)
(car (xml-node-children (car values))))
(mapcar (lambda (option)
`(item :tag ,(jabber-xml-get-attribute option 'label)
:value ,(car (jabber-xml-node-children (car (jabber-xml-get-children option 'value))))))
options)))
jabber-widget-alist))
((string= type "boolean")
(push (cons (cons var type)
(widget-create 'checkbox
:tag (or label var)
:value (if default-value
(cdr default-value)
(not (null
(member (car (xml-node-children (car values))) '("1" "true")))))))
jabber-widget-alist)
(if (or label var)
(widget-insert " " (or label var) "\n")))
(t ; in particular including text-single and text-private
(if (or label var)
(widget-insert (or label var) ": "))
(setq jabber-widget-alist
(cons
(cons (cons var type)
(widget-create 'editable-field
:secret (if (string= type "text-private") ?* nil)
(or (cdr default-value)
(car (jabber-xml-node-children (car values)))
"")))
jabber-widget-alist))))
(when (and desc (car (jabber-xml-node-children desc)))
(widget-insert "\n" (car (jabber-xml-node-children desc))))
(widget-insert "\n"))))
(defun jabber-parse-xdata-form ()
"Return an tag containing information entered in the widgets.
Return an tag containing information entered in the widgets of the current
buffer."
`(x ((xmlns . "jabber:x:data")
(type . "submit"))
,@(mapcar
(lambda (widget-cons)
(let ((values (jabber-xdata-value-convert (widget-value (cdr widget-cons)) (cdar widget-cons))))
;; empty fields are not included
(when values
`(field ((var . ,(caar widget-cons)))
,@(mapcar
(lambda (value)
(list 'value nil value))
values)))))
jabber-widget-alist)))
(defun jabber-xdata-value-convert (value type)
"Convert VALUE from form used by widget library to form required by XEP-0004.
Return a list of strings, each of which to be included as cdata in a
tag."
(cond
((string= type "boolean")
(if value (list "1") (list "0")))
((string= type "text-multi")
(split-string value "[\n\r]"))
(t ; in particular including text-single, text-private and list-single
(if (zerop (length value))
nil
(list value)))))
(defun jabber-render-xdata-search-results (xdata)
"Render search results in x:data form."
(let ((title (car (jabber-xml-get-children xdata 'title))))
(when title
(insert (jabber-propertize (car (jabber-xml-node-children title)) 'face 'jabber-title-medium) "\n")))
(if (jabber-xml-get-children xdata 'reported)
(jabber-render-xdata-search-results-multi xdata)
(jabber-render-xdata-search-results-single xdata)))
(defun jabber-render-xdata-search-results-multi (xdata)
"Render multi-record search results."
(let (fields
(jid-fields 0))
(let ((reported (car (jabber-xml-get-children xdata 'reported)))
(column 0))
(dolist (field (jabber-xml-get-children reported 'field))
(let (width)
;; Clever algorithm for estimating width based on field type goes here.
(setq width 20)
(setq fields
(append
fields
(list (cons (jabber-xml-get-attribute field 'var)
(list 'label (jabber-xml-get-attribute field 'label)
'type (jabber-xml-get-attribute field 'type)
'column column)))))
(setq column (+ column width))
(if (string= (jabber-xml-get-attribute field 'type) "jid-single")
(setq jid-fields (1+ jid-fields))))))
(dolist (field-cons fields)
(indent-to (plist-get (cdr field-cons) 'column) 1)
(insert (jabber-propertize (plist-get (cdr field-cons) 'label) 'face 'bold)))
(insert "\n\n")
;; Now, the items
(dolist (item (jabber-xml-get-children xdata 'item))
(let ((start-of-line (point))
jid)
;; The following code assumes that the order of the s in each
;;