summaryrefslogtreecommitdiff
path: root/jabber-widget.el
diff options
context:
space:
mode:
Diffstat (limited to 'jabber-widget.el')
-rw-r--r--jabber-widget.el363
1 files changed, 363 insertions, 0 deletions
diff --git a/jabber-widget.el b/jabber-widget.el
new file mode 100644
index 0000000..8e8fd0b
--- /dev/null
+++ b/jabber-widget.el
@@ -0,0 +1,363 @@
+;; jabber-widget.el - display various kinds of forms
+
+;; 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)
+ prefix))
+ (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 <query/> 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 JEP-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 <query/> 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 <x/> 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 <x/> 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 JEP-0004.
+Return a list of strings, each of which to be included as cdata in a <value/> 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 <field/>s in each
+ ;; <item/> is the same as in the <reported/> tag.
+ (dolist (field (jabber-xml-get-children item 'field))
+ (let ((field-plist (cdr (assoc (jabber-xml-get-attribute field 'var) fields)))
+ (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value))))))
+
+ (indent-to (plist-get field-plist 'column) 1)
+
+ ;; Absent values are sometimes "", sometimes nil. insert
+ ;; doesn't like nil.
+ (when value
+ ;; If there is only one JID field, let the whole row
+ ;; have the jabber-jid property. If there are many JID
+ ;; fields, the string belonging to each field has that
+ ;; property.
+ (if (string= (plist-get field-plist 'type) "jid-single")
+ (if (not (eq jid-fields 1))
+ (insert (jabber-propertize value 'jabber-jid value))
+ (setq jid value)
+ (insert value))
+ (insert value)))))
+
+ (if jid
+ (put-text-property start-of-line (point)
+ 'jabber-jid jid))
+ (insert "\n")))))
+
+(defun jabber-render-xdata-search-results-single (xdata)
+ "Render single-record search results."
+ (dolist (field (jabber-xml-get-children xdata 'field))
+ (let ((label (jabber-xml-get-attribute field 'label))
+ (type (jabber-xml-get-attribute field 'type))
+ (values (mapcar #'(lambda (val)
+ (car (jabber-xml-node-children val)))
+ (jabber-xml-get-children field 'value))))
+ ;; XXX: consider type
+ (insert (jabber-propertize (concat label ": ") 'face 'bold))
+ (indent-to 30)
+ (insert (apply #'concat values) "\n"))))
+
+(defun jabber-xdata-formtype (x)
+ "Return the form type of the xdata form in X, by JEP-0068.
+Return nil if no form type is specified."
+ (catch 'found-formtype
+ (dolist (field (jabber-xml-get-children x 'field))
+ (when (and (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE")
+ (string= (jabber-xml-get-attribute field 'type) "hidden"))
+ (throw 'found-formtype (car (jabber-xml-node-children
+ (car (jabber-xml-get-children field 'value)))))))))
+
+(provide 'jabber-widget)
+
+;;; arch-tag: da3312f3-1970-41d5-a974-14b8d76156b8
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-01 06:53:56 +0000