Reorganización de directorios

[config.git] / djavu-asus / emacs / elpa / jabber-20230715.456 / jabber-widget.el

;; 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 <query/> element in IQ register or search namespace.
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 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 <query/> tag containing information entered.
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.
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 XEP-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 XEP-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