jabber-widget.el

   1 ;; jabber-widget.el - display various kinds of forms
   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.  One of:
  32 'x-data, jabber:x:data
  33 'register, as used in jabber:iq:register and jabber:iq:search")
  34
  35 (defvar jabber-submit-to nil
  36   "JID of the entity to which form data is to be sent")
  37
  38 (add-to-list 'jabber-advertised-features "jabber:x:data")
  39
  40 (define-widget 'jid 'string
  41   "JID widget."
  42   :value-to-internal (lambda (widget value)
  43                        (let ((displayname (jabber-jid-rostername value)))
  44                          (if displayname
  45                              (format "%s <%s>" displayname value)
  46                            value)))
  47   :value-to-external (lambda (widget value)
  48                        (if (string-match "<\\([^>]+\\)>[ \t]*$" value)
  49                            (match-string 1 value)
  50                          value))
  51   :complete-function 'jid-complete)
  52
  53 (defun jid-complete ()
  54   "Perform completion on JID preceding point."
  55   (interactive)
  56   ;; mostly stolen from widget-color-complete
  57   (let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
  58                                                  (point)))
  59          (list (append (mapcar #'symbol-name *jabber-roster*)
  60                        (delq nil
  61                              (mapcar #'(lambda (item)
  62                                          (when (jabber-jid-rostername item)
  63                                            (format "%s <%s>" (jabber-jid-rostername item)
  64                                                    (symbol-name item))))
  65                                      *jabber-roster*))))
  66          (completion (try-completion prefix list)))
  67     (cond ((eq completion t)
  68            (message "Exact match."))
  69           ((null completion)
  70            (error "Can't find completion for \"%s\"" prefix))
  71           ((not (string-equal prefix completion))
  72            (insert-and-inherit (substring completion (length prefix))))
  73           (t
  74            (message "Making completion list...")
  75            (with-output-to-temp-buffer "*Completions*"
  76              (display-completion-list (all-completions prefix list nil)
  77                                       prefix))
  78            (message "Making completion list...done")))))
  79
  80
  81 (defun jabber-init-widget-buffer (submit-to)
  82   "Setup buffer-local variables for widgets."
  83   (make-local-variable 'jabber-widget-alist)
  84   (make-local-variable 'jabber-submit-to)
  85   (setq jabber-widget-alist nil)
  86   (setq jabber-submit-to submit-to)
  87   (setq buffer-read-only nil)
  88   ;; XXX: This is because data from other queries would otherwise be
  89   ;; appended to this buffer, which would fail since widget buffers
  90   ;; are read-only... or something like that.  Maybe there's a
  91   ;; better way.
  92   (rename-uniquely))
  93
  94 (defun jabber-render-register-form (query &optional default-username)
  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 JEP-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 in the widgets of the current buffer."
 147   (mapcar
 148    (lambda (widget-cons)
 149      (list (car widget-cons)
 150            nil
 151            (widget-value (cdr widget-cons))))
 152    jabber-widget-alist))
 153
 154 (defun jabber-render-xdata-form (x &optional defaults)
 155   "Display widgets from <x/> element in jabber:x:data namespace.
 156 DEFAULTS is an alist associating variable names with default values.
 157 DEFAULTS takes precedence over values specified in the form."
 158   (make-local-variable 'jabber-widget-alist)
 159   (setq jabber-widget-alist nil)
 160   (make-local-variable 'jabber-form-type)
 161   (setq jabber-form-type 'xdata)
 162
 163   (let ((title (car (jabber-xml-node-children (car (jabber-xml-get-children x 'title))))))
 164     (if (stringp title)
 165         (widget-insert (jabber-propertize title 'face 'jabber-title-medium) "\n\n")))
 166   (let ((instructions (car (jabber-xml-node-children (car (jabber-xml-get-children x 'instructions))))))
 167     (if (stringp instructions)
 168         (widget-insert "Instructions: " instructions "\n\n")))
 169
 170   (dolist (field (jabber-xml-get-children x 'field))
 171     (let* ((var (jabber-xml-get-attribute field 'var))
 172            (label (jabber-xml-get-attribute field 'label))
 173            (type (jabber-xml-get-attribute field 'type))
 174            (required (jabber-xml-get-children field 'required))
 175            (values (jabber-xml-get-children field 'value))
 176            (options (jabber-xml-get-children field 'option))
 177            (desc (car (jabber-xml-get-children field 'desc)))
 178            (default-value (assoc var defaults)))
 179       ;; "required" not implemented yet
 180
 181       (cond
 182        ((string= type "fixed")
 183         (widget-insert (car (jabber-xml-node-children (car values)))))
 184
 185        ((string= type "text-multi")
 186         (if (or label var)
 187             (widget-insert (or label var) ":\n"))
 188         (push (cons (cons var type)
 189                     (widget-create 'text (or (cdr default-value)
 190                                               (mapconcat #'(lambda (val)
 191                                                              (car (jabber-xml-node-children val)))
 192                                                          values "\n")
 193                                              "")))
 194               jabber-widget-alist))
 195
 196        ((string= type "list-single")
 197         (if (or label var)
 198             (widget-insert (or label var) ":\n"))
 199         (push (cons (cons var type)
 200                     (apply 'widget-create
 201                            'radio-button-choice
 202                            :value (or (cdr default-value)
 203                                       (car (xml-node-children (car values))))
 204                            (mapcar (lambda (option)
 205                                      `(item :tag ,(jabber-xml-get-attribute option 'label)
 206                                             :value ,(car (jabber-xml-node-children (car (jabber-xml-get-children option 'value))))))
 207                                    options)))
 208               jabber-widget-alist))
 209
 210        ((string= type "boolean")
 211         (push (cons (cons var type)
 212                     (widget-create 'checkbox
 213                                    :tag (or label var)
 214                                    :value (if default-value
 215                                               (cdr default-value)
 216                                             (not (null
 217                                                   (member (car (xml-node-children (car values))) '("1" "true")))))))
 218               jabber-widget-alist)
 219         (if (or label var)
 220             (widget-insert " " (or label var) "\n")))
 221
 222        (t       ; in particular including text-single and text-private
 223         (if (or label var)
 224             (widget-insert (or label var) ": "))
 225         (setq jabber-widget-alist
 226               (cons
 227                (cons (cons var type)
 228                      (widget-create 'editable-field
 229                                     :secret (if (string= type "text-private") ?* nil)
 230                                     (or (cdr default-value)
 231                                         (car (jabber-xml-node-children (car values)))
 232                                         "")))
 233                jabber-widget-alist))))
 234       (when (and desc (car (jabber-xml-node-children desc)))
 235         (widget-insert "\n" (car (jabber-xml-node-children desc))))
 236       (widget-insert "\n"))))
 237
 238 (defun jabber-parse-xdata-form ()
 239   "Return an <x/> tag containing information entered in the widgets of the current buffer."
 240   `(x ((xmlns . "jabber:x:data")
 241        (type . "submit"))
 242       ,@(mapcar
 243          (lambda (widget-cons)
 244            (let ((values (jabber-xdata-value-convert (widget-value (cdr widget-cons)) (cdar widget-cons))))
 245              ;; empty fields are not included
 246              (when values
 247                `(field ((var . ,(caar widget-cons)))
 248                        ,@(mapcar
 249                           (lambda (value)
 250                             (list 'value nil value))
 251                           values)))))
 252          jabber-widget-alist)))
 253
 254 (defun jabber-xdata-value-convert (value type)
 255   "Convert VALUE from form used by widget library to form required by JEP-0004.
 256 Return a list of strings, each of which to be included as cdata in a <value/> tag."
 257   (cond
 258    ((string= type "boolean")
 259     (if value (list "1") (list "0")))
 260    ((string= type "text-multi")
 261     (split-string value "[\n\r]"))
 262    (t                                   ; in particular including text-single, text-private and list-single
 263     (if (zerop (length value))
 264         nil
 265       (list value)))))
 266
 267 (defun jabber-render-xdata-search-results (xdata)
 268   "Render search results in x:data form."
 269
 270   (let ((title (car (jabber-xml-get-children xdata 'title))))
 271     (when title
 272       (insert (jabber-propertize (car (jabber-xml-node-children title)) 'face 'jabber-title-medium) "\n")))
 273
 274   (if (jabber-xml-get-children xdata 'reported)
 275       (jabber-render-xdata-search-results-multi xdata)
 276     (jabber-render-xdata-search-results-single xdata)))
 277
 278 (defun jabber-render-xdata-search-results-multi (xdata)
 279   "Render multi-record search results."
 280   (let (fields
 281         (jid-fields 0))
 282     (let ((reported (car (jabber-xml-get-children xdata 'reported)))
 283           (column 0))
 284       (dolist (field (jabber-xml-get-children reported 'field))
 285         (let (width)
 286           ;; Clever algorithm for estimating width based on field type goes here.
 287           (setq width 20)
 288
 289           (setq fields
 290                 (append
 291                  fields
 292                  (list (cons (jabber-xml-get-attribute field 'var)
 293                              (list 'label (jabber-xml-get-attribute field 'label)
 294                                    'type (jabber-xml-get-attribute field 'type)
 295                                    'column column)))))
 296           (setq column (+ column width))
 297           (if (string= (jabber-xml-get-attribute field 'type) "jid-single")
 298               (setq jid-fields (1+ jid-fields))))))
 299
 300     (dolist (field-cons fields)
 301       (indent-to (plist-get (cdr field-cons) 'column) 1)
 302       (insert (jabber-propertize (plist-get (cdr field-cons) 'label) 'face 'bold)))
 303     (insert "\n\n")
 304
 305     ;; Now, the items
 306     (dolist (item (jabber-xml-get-children xdata 'item))
 307
 308       (let ((start-of-line (point))
 309             jid)
 310
 311         ;; The following code assumes that the order of the <field/>s in each
 312         ;; <item/> is the same as in the <reported/> tag.
 313         (dolist (field (jabber-xml-get-children item 'field))
 314           (let ((field-plist (cdr (assoc (jabber-xml-get-attribute field 'var) fields)))
 315                 (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value))))))
 316
 317             (indent-to (plist-get field-plist 'column) 1)
 318
 319             ;; Absent values are sometimes "", sometimes nil.  insert
 320             ;; doesn't like nil.
 321             (when value
 322               ;; If there is only one JID field, let the whole row
 323               ;; have the jabber-jid property.  If there are many JID
 324               ;; fields, the string belonging to each field has that
 325               ;; property.
 326               (if (string= (plist-get field-plist 'type) "jid-single")
 327                   (if (not (eq jid-fields 1))
 328                       (insert (jabber-propertize value 'jabber-jid value))
 329                     (setq jid value)
 330                     (insert value))
 331                 (insert value)))))
 332
 333         (if jid
 334             (put-text-property start-of-line (point)
 335                                'jabber-jid jid))
 336         (insert "\n")))))
 337
 338 (defun jabber-render-xdata-search-results-single (xdata)
 339   "Render single-record search results."
 340   (dolist (field (jabber-xml-get-children xdata 'field))
 341     (let ((label (jabber-xml-get-attribute field 'label))
 342           (type (jabber-xml-get-attribute field 'type))
 343           (values (mapcar #'(lambda (val)
 344                               (car (jabber-xml-node-children val)))
 345                           (jabber-xml-get-children field 'value))))
 346       ;; XXX: consider type
 347       (insert (jabber-propertize (concat label ": ") 'face 'bold))
 348       (indent-to 30)
 349       (insert (apply #'concat values) "\n"))))
 350
 351 (defun jabber-xdata-formtype (x)
 352   "Return the form type of the xdata form in X, by JEP-0068.
 353 Return nil if no form type is specified."
 354   (catch 'found-formtype
 355     (dolist (field (jabber-xml-get-children x 'field))
 356       (when (and (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE")
 357                  (string= (jabber-xml-get-attribute field 'type) "hidden"))
 358         (throw 'found-formtype (car (jabber-xml-node-children
 359                                      (car (jabber-xml-get-children field 'value)))))))))
 360
 361 (provide 'jabber-widget)
 362
 363 ;;; arch-tag: da3312f3-1970-41d5-a974-14b8d76156b8