djavu-asus/elpa/jabber-20230715.456/jabber-widget.el

   1 ;; jabber-widget.el - display various kinds of forms  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu
   4 ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
   5
   6 ;; This file is a part of jabber.el.
   7
   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.
  12
  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.
  17
  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
  21
  22 (require 'widget)
  23 (require 'wid-edit)
  24 (require 'jabber-util)
  25 (require 'jabber-disco)
  26
  27 (defvar jabber-widget-alist nil
  28   "Alist of widgets currently used.")
  29
  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.")
  35
  36 (defvar jabber-submit-to nil
  37   "JID of the entity to which form data is to be sent.")
  38
  39 (jabber-disco-advertise-feature "jabber:x:data")
  40
  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)
  53
  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")))))
  79
  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))
  92
  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