]>
Commit | Line | Data |
---|---|---|
1 | ;;; jabber-vcard.el --- vcards according to JEP-0054 -*- lexical-binding: t; -*- | |
2 | ||
3 | ;; Copyright (C) 2005, 2007 Magnus Henoch | |
4 | ||
5 | ;; Author: Magnus Henoch <mange@freemail.hu> | |
6 | ||
7 | ;; This file is a part of jabber.el. | |
8 | ||
9 | ;; This program is free software; you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation; either version 2, or (at your option) | |
12 | ;; any later version. | |
13 | ||
14 | ;; This program is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with GNU Emacs; see the file COPYING. If not, write to | |
21 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
22 | ;; Boston, MA 02111-1307, USA. | |
23 | ||
24 | ;;; Commentary: | |
25 | ||
26 | ;; There are great variations in Jabber vcard implementations. This | |
27 | ;; one adds some spice to the mix, while trying to follow the JEP | |
28 | ;; closely. | |
29 | ||
30 | ;; Fields not implemented: GEO, LOGO, AGENT, ORG, CATEGORIES, SOUND, | |
31 | ;; CLASS, KEY. | |
32 | ||
33 | ;; The internal data structure used for vCards is an alist. All | |
34 | ;; keys are uppercase symbols. | |
35 | ;; | |
36 | ;; FN, NICKNAME, BDAY, JABBERID, MAILER, TZ, TITLE, ROLE, NOTE, | |
37 | ;; PRODID, REV, SORT-STRING, UID, URL, DESC: | |
38 | ;; Value is a string. | |
39 | ;; | |
40 | ;; N: | |
41 | ;; Value is an alist, with keys FAMILY, GIVEN, MIDDLE, PREFIX and SUFFIX. | |
42 | ;; | |
43 | ;; ADR: | |
44 | ;; Value is a list, each element representing a separate address. | |
45 | ;; The car of each address is a list of types; possible values are | |
46 | ;; HOME, WORK, POSTAL, PARCEL, DOM, INTL, PREF. | |
47 | ;; The cdr of each address is an alist, with keys POBOX, EXTADD, | |
48 | ;; STREET, LOCALITY, REGION, PCODE, CTRY, and values being strings. | |
49 | ;; | |
50 | ;; TEL: | |
51 | ;; Value is a list, each element representing a separate phone number. | |
52 | ;; The car of each number is a list of types; possible values are | |
53 | ;; HOME, WORK, VOICE, FAX, PAGER, MSG, CELL, VIDEO, BBS, MODEM, ISDN, | |
54 | ;; PCS, PREF | |
55 | ;; The cdr is the phone number as a string. | |
56 | ;; | |
57 | ;; EMAIL: | |
58 | ;; Value is a list, each element representing a separate e-mail address. | |
59 | ;; The car of each address is a list of types; possible values are | |
60 | ;; HOME, WORK, INTERNET, PREF, X400. At least one of INTERNET and | |
61 | ;; X400 is always present. | |
62 | ;; The cdr is the address as a string. | |
63 | ||
64 | ;;; Code: | |
65 | ||
66 | (require 'jabber-core) | |
67 | (require 'jabber-widget) | |
68 | (require 'jabber-iq) | |
69 | (require 'jabber-avatar) | |
70 | ||
71 | (defvar jabber-vcard-photo nil | |
72 | "The avatar structure for the photo in the vCard edit buffer.") | |
73 | (make-variable-buffer-local 'jabber-vcard-photo) | |
74 | ||
75 | (defun jabber-vcard-parse (vcard) | |
76 | "Parse the vCard XML structure given in VCARD. | |
77 | The top node should be the `vCard' node." | |
78 | ;; Hm... stpeter has a <query/> as top node... | |
79 | ;;(unless (eq (jabber-xml-node-name vcard) 'vCard) | |
80 | ;; (error "Invalid vCard")) | |
81 | (let (result) | |
82 | (dolist (verbatim-node '(FN NICKNAME BDAY JABBERID MAILER TZ | |
83 | TITLE ROLE NOTE PRODID REV SORT-STRING | |
84 | UID URL DESC)) | |
85 | ;; There should only be one of each of these. They are | |
86 | ;; used verbatim. | |
87 | (let ((node (car (jabber-xml-get-children vcard | |
88 | verbatim-node)))) | |
89 | ;; Some clients include the node, but without data | |
90 | (when (car (jabber-xml-node-children node)) | |
91 | (push (cons (jabber-xml-node-name node) | |
92 | (car (jabber-xml-node-children node))) | |
93 | result)))) | |
94 | ||
95 | ;; Name components | |
96 | (let ((node (car (jabber-xml-get-children vcard 'N)))) | |
97 | ;; Subnodes are FAMILY, GIVEN, MIDDLE, PREFIX, SUFFIX | |
98 | (push (cons 'N | |
99 | (let (name) | |
100 | (dolist (subnode (jabber-xml-node-children node)) | |
101 | (when (and (memq (jabber-xml-node-name subnode) | |
102 | '(FAMILY GIVEN MIDDLE PREFIX SUFFIX)) | |
103 | (not (zerop (length | |
104 | (car (jabber-xml-node-children | |
105 | subnode)))))) | |
106 | (push (cons (jabber-xml-node-name subnode) | |
107 | (car (jabber-xml-node-children | |
108 | subnode))) | |
109 | name))) | |
110 | name)) | |
111 | result)) | |
112 | ||
113 | ;; There can be several addresses | |
114 | (let (addresses) | |
115 | (dolist (adr (jabber-xml-get-children vcard 'ADR)) | |
116 | ;; Find address type(s) | |
117 | (let (types) | |
118 | (dolist (possible-type '(HOME WORK POSTAL PARCEL DOM INTL PREF)) | |
119 | (when (jabber-xml-get-children adr possible-type) | |
120 | (push possible-type types))) | |
121 | ||
122 | (let (components) | |
123 | (dolist (component (jabber-xml-node-children adr)) | |
124 | (when (and (memq (jabber-xml-node-name component) | |
125 | '(POBOX EXTADD STREET LOCALITY REGION | |
126 | PCODE CTRY)) | |
127 | (not (zerop (length | |
128 | (car (jabber-xml-node-children | |
129 | component)))))) | |
130 | (push (cons (jabber-xml-node-name component) | |
131 | (car (jabber-xml-node-children component))) | |
132 | components))) | |
133 | ||
134 | (push (cons types components) addresses)))) | |
135 | ||
136 | (when addresses | |
137 | (push (cons 'ADR addresses) result))) | |
138 | ||
139 | ;; Likewise for phone numbers | |
140 | (let (phone-numbers) | |
141 | (dolist (tel (jabber-xml-get-children vcard 'TEL)) | |
142 | ;; Find phone type(s) | |
143 | (let ((number (car (jabber-xml-node-children | |
144 | (car (jabber-xml-get-children tel 'NUMBER))))) | |
145 | types) | |
146 | ;; Some clients put no NUMBER node. Avoid that. | |
147 | (when number | |
148 | (dolist (possible-type '(HOME WORK VOICE FAX PAGER MSG CELL | |
149 | VIDEO BBS MODEM ISDN PCS PREF)) | |
150 | (when (jabber-xml-get-children tel possible-type) | |
151 | (push possible-type types))) | |
152 | ||
153 | (push (cons types number) phone-numbers)))) | |
154 | ||
155 | (when phone-numbers | |
156 | (push (cons 'TEL phone-numbers) result))) | |
157 | ||
158 | ;; And for e-mail addresses | |
159 | (let (e-mails) | |
160 | (dolist (email (jabber-xml-get-children vcard 'EMAIL)) | |
161 | (let ((userid (car (jabber-xml-node-children | |
162 | (car (jabber-xml-get-children email 'USERID))))) | |
163 | types) | |
164 | ;; Some clients put no USERID node. Avoid that. | |
165 | (when userid | |
166 | (dolist (possible-type '(HOME WORK INTERNET PREF X400)) | |
167 | (when (jabber-xml-get-children email possible-type) | |
168 | (push possible-type types))) | |
169 | (unless (or (memq 'INTERNET types) | |
170 | (memq 'X400 types)) | |
171 | (push 'INTERNET types)) | |
172 | ||
173 | (push (cons types userid) e-mails)))) | |
174 | ||
175 | (when e-mails | |
176 | (push (cons 'EMAIL e-mails) result))) | |
177 | ||
178 | ;; XEP-0153: vCard-based avatars | |
179 | (let ((photo-tag (car (jabber-xml-get-children vcard 'PHOTO)))) | |
180 | (when photo-tag | |
181 | (let ((type (jabber-xml-path photo-tag '(TYPE ""))) | |
182 | (binval (jabber-xml-path photo-tag '(BINVAL "")))) | |
183 | (when (and type binval) | |
184 | (push (list 'PHOTO type binval) result))))) | |
185 | ||
186 | result)) | |
187 | ||
188 | (defun jabber-vcard-reassemble (parsed) | |
189 | "Create a vCard XML structure from PARSED." | |
190 | ;; Save photo in jabber-vcard-photo, to avoid excessive processing. | |
191 | (let ((photo (cdr (assq 'PHOTO parsed)))) | |
192 | (cond | |
193 | ;; No photo | |
194 | ((null photo) | |
195 | (setq jabber-vcard-photo nil)) | |
196 | ;; Existing photo | |
197 | ((listp photo) | |
198 | (setq jabber-vcard-photo | |
199 | (jabber-avatar-from-base64-string | |
200 | (nth 1 photo) (nth 0 photo)))) | |
201 | ;; New photo from file | |
202 | (t | |
203 | (access-file photo "Avatar file not found") | |
204 | ;; Maximum allowed size is 8 kilobytes | |
205 | (when (> (nth 7 (file-attributes photo)) 8192) | |
206 | (error "Avatar bigger than 8 kilobytes")) | |
207 | (setq jabber-vcard-photo (jabber-avatar-from-file photo))))) | |
208 | ||
209 | `(vCard ((xmlns . "vcard-temp")) | |
210 | ;; Put in simple fields | |
211 | ,@(mapcar | |
212 | (lambda (field) | |
213 | (when (and (assq (car field) jabber-vcard-fields) | |
214 | (not (zerop (length (cdr field))))) | |
215 | (list (car field) nil (cdr field)))) | |
216 | parsed) | |
217 | ;; Put in decomposited name | |
218 | (N nil | |
219 | ,@(mapcar | |
220 | (lambda (name-part) | |
221 | (when (not (zerop (length (cdr name-part)))) | |
222 | (list (car name-part) nil (cdr name-part)))) | |
223 | (cdr (assq 'N parsed)))) | |
224 | ;; Put in addresses | |
225 | ,@(mapcar | |
226 | (lambda (address) | |
227 | (append '(ADR) '(()) | |
228 | (mapcar 'list (nth 0 address)) | |
229 | (mapcar (lambda (field) | |
230 | (list (car field) nil (cdr field))) | |
231 | (cdr address)))) | |
232 | (cdr (assq 'ADR parsed))) | |
233 | ;; Put in phone numbers | |
234 | ,@(mapcar | |
235 | (lambda (phone) | |
236 | (append '(TEL) '(()) | |
237 | (mapcar 'list (car phone)) | |
238 | (list (list 'NUMBER nil (cdr phone))))) | |
239 | (cdr (assq 'TEL parsed))) | |
240 | ;; Put in e-mail addresses | |
241 | ,@(mapcar | |
242 | (lambda (email) | |
243 | (append '(EMAIL) '(()) | |
244 | (mapcar 'list (car email)) | |
245 | (list (list 'USERID nil (cdr email))))) | |
246 | (cdr (assq 'EMAIL parsed))) | |
247 | ;; Put in photo | |
248 | ,@(when jabber-vcard-photo | |
249 | `((PHOTO () | |
250 | (TYPE () ,(avatar-mime-type jabber-vcard-photo)) | |
251 | (BINVAL () ,(avatar-base64-data jabber-vcard-photo))))))) | |
252 | ||
253 | (add-to-list 'jabber-jid-info-menu | |
254 | (cons "Request vcard" 'jabber-vcard-get)) | |
255 | ||
256 | (defun jabber-vcard-get (jc jid) | |
257 | "Request vcard from JID. | |
258 | ||
259 | JC is the Jabber connection." | |
260 | (interactive (list (jabber-read-account) | |
261 | (jabber-read-jid-completing "Request vcard from: " nil nil nil 'bare-or-muc))) | |
262 | (jabber-send-iq jc jid | |
263 | "get" | |
264 | '(vCard ((xmlns . "vcard-temp"))) | |
265 | #'jabber-process-data #'jabber-vcard-display | |
266 | #'jabber-process-data "Vcard request failed")) | |
267 | ||
268 | (defun jabber-vcard-edit (jc) | |
269 | "Edit your own vcard. | |
270 | ||
271 | JC is the Jabber connection." | |
272 | (interactive (list (jabber-read-account))) | |
273 | (jabber-send-iq jc nil | |
274 | "get" | |
275 | '(vCard ((xmlns . "vcard-temp"))) | |
276 | #'jabber-vcard-do-edit nil | |
277 | #'jabber-report-success "Vcard request failed")) | |
278 | ||
279 | (defconst jabber-vcard-fields '((FN . "Full name") | |
280 | (NICKNAME . "Nickname") | |
281 | (BDAY . "Birthday") | |
282 | (URL . "URL") | |
283 | (JABBERID . "JID") | |
284 | (MAILER . "User agent") | |
285 | (TZ . "Time zone") | |
286 | (TITLE . "Title") | |
287 | (ROLE . "Role") | |
288 | (REV . "Last changed") | |
289 | (DESC . "Description") | |
290 | (NOTE . "Note"))) | |
291 | ||
292 | (defconst jabber-vcard-name-fields '((PREFIX . "Prefix") | |
293 | (GIVEN . "Given name") | |
294 | (MIDDLE . "Middle name") | |
295 | (FAMILY . "Family name") | |
296 | (SUFFIX . "Suffix"))) | |
297 | ||
298 | (defconst jabber-vcard-phone-types '((HOME . "Home") | |
299 | (WORK . "Work") | |
300 | (VOICE . "Voice") | |
301 | (FAX . "Fax") | |
302 | (PAGER . "Pager") | |
303 | (MSG . "Message") | |
304 | (CELL . "Cell phone") | |
305 | (VIDEO . "Video") | |
306 | (BBS . "BBS") | |
307 | (MODEM . "Modem") | |
308 | (ISDN . "ISDN") | |
309 | (PCS . "PCS"))) | |
310 | ||
311 | (defconst jabber-vcard-email-types '((HOME . "Home") | |
312 | (WORK . "Work") | |
313 | (INTERNET . "Internet") | |
314 | (X400 . "X400") | |
315 | (PREF . "Preferred"))) | |
316 | ||
317 | (defconst jabber-vcard-address-types '((HOME . "Home") | |
318 | (WORK . "Work") | |
319 | (POSTAL . "Postal") | |
320 | (PARCEL . "Parcel") | |
321 | (DOM . "Domestic") | |
322 | (INTL . "International") | |
323 | (PREF . "Preferred"))) | |
324 | ||
325 | (defconst jabber-vcard-address-fields '((POBOX . "Post box") | |
326 | (EXTADD . "Ext. address") | |
327 | (STREET . "Street") | |
328 | (LOCALITY . "Locality") | |
329 | (REGION . "Region") | |
330 | (PCODE . "Post code") | |
331 | (CTRY . "Country"))) | |
332 | ||
333 | (defun jabber-vcard-display (jc xml-data) | |
334 | "Display received vcard. | |
335 | ||
336 | JC is the Jabber connection. | |
337 | XML-DATA is the parsed tree data from the stream (stanzas) | |
338 | obtained from `xml-parse-region'." | |
339 | (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data)))) | |
340 | (dolist (simple-field jabber-vcard-fields) | |
341 | (let ((field (assq (car simple-field) parsed))) | |
342 | (when field | |
343 | (insert (cdr simple-field)) | |
344 | (indent-to 20) | |
345 | (insert (cdr field) "\n")))) | |
346 | ||
347 | (let ((names (cdr (assq 'N parsed)))) | |
348 | (when names | |
349 | (insert "\n") | |
350 | (dolist (name-field jabber-vcard-name-fields) | |
351 | (let ((field (assq (car name-field) names))) | |
352 | (when field | |
353 | (insert (cdr name-field)) | |
354 | (indent-to 20) | |
355 | (insert (cdr field) "\n")))))) | |
356 | ||
357 | (let ((email-addresses (cdr (assq 'EMAIL parsed)))) | |
358 | (when email-addresses | |
359 | (insert "\n") | |
360 | (insert (jabber-propertize "E-mail addresses:\n" | |
361 | 'face 'jabber-title-medium)) | |
362 | (dolist (email email-addresses) | |
363 | (insert (mapconcat (lambda (type) | |
364 | (cdr (assq type jabber-vcard-email-types))) | |
365 | (car email) | |
366 | " ")) | |
367 | (insert ": " (cdr email) "\n")))) | |
368 | ||
369 | (let ((phone-numbers (cdr (assq 'TEL parsed)))) | |
370 | (when phone-numbers | |
371 | (insert "\n") | |
372 | (insert (jabber-propertize "Phone numbers:\n" | |
373 | 'face 'jabber-title-medium)) | |
374 | (dolist (number phone-numbers) | |
375 | (insert (mapconcat (lambda (type) | |
376 | (cdr (assq type jabber-vcard-phone-types))) | |
377 | (car number) | |
378 | " ")) | |
379 | (insert ": " (cdr number) "\n")))) | |
380 | ||
381 | (let ((addresses (cdr (assq 'ADR parsed)))) | |
382 | (when addresses | |
383 | (insert "\n") | |
384 | (insert (jabber-propertize "Addresses:\n" | |
385 | 'face 'jabber-title-medium)) | |
386 | (dolist (address addresses) | |
387 | (insert (jabber-propertize | |
388 | (mapconcat (lambda (type) | |
389 | (cdr (assq type jabber-vcard-address-types))) | |
390 | (car address) | |
391 | " ") | |
392 | 'face 'jabber-title-small)) | |
393 | (insert "\n") | |
394 | (dolist (address-field jabber-vcard-address-fields) | |
395 | (let ((field (assq (car address-field) address))) | |
396 | (when field | |
397 | (insert (cdr address-field)) | |
398 | (indent-to 20) | |
399 | (insert (cdr field) "\n"))))))) | |
400 | ||
401 | ;; XEP-0153: vCard-based avatars | |
402 | (let ((photo-type (nth 1 (assq 'PHOTO parsed))) | |
403 | (photo-binval (nth 2 (assq 'PHOTO parsed)))) | |
404 | (when (and photo-type photo-binval) | |
405 | (condition-case nil | |
406 | ;; ignore the type, let create-image figure it out. | |
407 | (let ((image (jabber-create-image (base64-decode-string photo-binval) nil t))) | |
408 | (insert-image image "[Photo]") | |
409 | (insert "\n")) | |
410 | (error (insert "Couldn't display photo\n"))))))) | |
411 | ||
412 | (defun jabber-vcard-do-edit (jc xml-data closure-data) | |
413 | (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data))) | |
414 | start-position) | |
415 | (with-current-buffer (get-buffer-create "Edit vcard") | |
416 | (jabber-init-widget-buffer nil) | |
417 | ||
418 | (setq jabber-buffer-connection jc) | |
419 | ||
420 | (setq start-position (point)) | |
421 | ||
422 | (dolist (simple-field jabber-vcard-fields) | |
423 | (widget-insert (cdr simple-field)) | |
424 | (indent-to 15) | |
425 | (let ((default-value (cdr (assq (car simple-field) parsed)))) | |
426 | (push (cons (car simple-field) | |
427 | (widget-create 'editable-field (or default-value ""))) | |
428 | jabber-widget-alist))) | |
429 | ||
430 | (widget-insert "\n") | |
431 | (push (cons 'N | |
432 | (widget-create | |
433 | '(set :tag "Decomposited name" | |
434 | (cons :tag "Prefix" :format "%t: %v" (const :format "" PREFIX) (string :format "%v")) | |
435 | (cons :tag "Given name" :format "%t: %v" (const :format "" GIVEN) (string :format "%v")) | |
436 | (cons :tag "Middle name" :format "%t: %v" (const :format "" MIDDLE) (string :format "%v")) | |
437 | (cons :tag "Family name" :format "%t: %v" (const :format "" FAMILY) (string :format "%v")) | |
438 | (cons :tag "Suffix" :format "%t: %v" (const :format "" SUFFIX) (string :format "%v"))) | |
439 | :value (cdr (assq 'N parsed)))) | |
440 | jabber-widget-alist) | |
441 | ||
442 | (widget-insert "\n") | |
443 | (push (cons 'ADR | |
444 | (widget-create | |
445 | '(repeat :tag "Postal addresses" | |
446 | (cons | |
447 | :tag "Address" | |
448 | (set :tag "Type" | |
449 | (const :tag "Home" HOME) | |
450 | (const :tag "Work" WORK) | |
451 | (const :tag "Postal" POSTAL) | |
452 | (const :tag "Parcel" PARCEL) | |
453 | (const :tag "Domestic" DOM) | |
454 | (const :tag "International" INTL) | |
455 | (const :tag "Preferred" PREF)) | |
456 | (set | |
457 | :tag "Address" | |
458 | (cons :tag "Post box" :format "%t: %v" | |
459 | (const :format "" POBOX) (string :format "%v")) | |
460 | (cons :tag "Ext. address" :format "%t: %v" | |
461 | (const :format "" EXTADD) (string :format "%v")) | |
462 | (cons :tag "Street" :format "%t: %v" | |
463 | (const :format "" STREET) (string :format "%v")) | |
464 | (cons :tag "Locality" :format "%t: %v" | |
465 | (const :format "" LOCALITY) (string :format "%v")) | |
466 | (cons :tag "Region" :format "%t: %v" | |
467 | (const :format "" REGION) (string :format "%v")) | |
468 | (cons :tag "Post code" :format "%t: %v" | |
469 | (const :format "" PCODE) (string :format "%v")) | |
470 | (cons :tag "Country" :format "%t: %v" | |
471 | (const :format "" CTRY) (string :format "%v"))))) | |
472 | :value (cdr (assq 'ADR parsed)))) | |
473 | jabber-widget-alist) | |
474 | ||
475 | (widget-insert "\n") | |
476 | (push (cons 'TEL | |
477 | (widget-create | |
478 | '(repeat :tag "Phone numbers" | |
479 | (cons :tag "Number" | |
480 | (set :tag "Type" | |
481 | (const :tag "Home" HOME) | |
482 | (const :tag "Work" WORK) | |
483 | (const :tag "Voice" VOICE) | |
484 | (const :tag "Fax" FAX) | |
485 | (const :tag "Pager" PAGER) | |
486 | (const :tag "Message" MSG) | |
487 | (const :tag "Cell phone" CELL) | |
488 | (const :tag "Video" VIDEO) | |
489 | (const :tag "BBS" BBS) | |
490 | (const :tag "Modem" MODEM) | |
491 | (const :tag "ISDN" ISDN) | |
492 | (const :tag "PCS" PCS)) | |
493 | (string :tag "Number"))) | |
494 | :value (cdr (assq 'TEL parsed)))) | |
495 | jabber-widget-alist) | |
496 | ||
497 | (widget-insert "\n") | |
498 | (push (cons 'EMAIL | |
499 | (widget-create | |
500 | '(repeat :tag "E-mail addresses" | |
501 | (cons :tag "Address" | |
502 | (set :tag "Type" | |
503 | (const :tag "Home" HOME) | |
504 | (const :tag "Work" WORK) | |
505 | (const :tag "Internet" INTERNET) | |
506 | (const :tag "X400" X400) | |
507 | (const :tag "Preferred" PREF)) | |
508 | (string :tag "Address"))) | |
509 | :value (cdr (assq 'EMAIL parsed)))) | |
510 | jabber-widget-alist) | |
511 | ||
512 | (widget-insert "\n") | |
513 | (widget-insert "Photo/avatar:\n") | |
514 | (let* ((photo (assq 'PHOTO parsed)) | |
515 | (avatar (when photo | |
516 | (jabber-avatar-from-base64-string (nth 2 photo) | |
517 | (nth 1 photo))))) | |
518 | (push (cons | |
519 | 'PHOTO | |
520 | (widget-create | |
521 | `(radio-button-choice (const :tag "None" nil) | |
522 | ,@(when photo | |
523 | (list | |
524 | `(const :tag | |
525 | ,(concat | |
526 | "Existing: " | |
527 | (jabber-propertize " " | |
528 | 'display (jabber-avatar-image avatar))) | |
529 | ,(cdr photo)))) | |
530 | (file :must-match t :tag "From file")) | |
531 | :value (cdr photo))) | |
532 | jabber-widget-alist)) | |
533 | ||
534 | (widget-insert "\n") | |
535 | (widget-create 'push-button :notify #'jabber-vcard-submit "Submit") | |
536 | ||
537 | (widget-setup) | |
538 | (widget-minor-mode 1) | |
539 | (switch-to-buffer (current-buffer)) | |
540 | (goto-char start-position)))) | |
541 | ||
542 | (defun jabber-vcard-submit (&rest ignore) | |
543 | (let ((to-publish (jabber-vcard-reassemble | |
544 | (mapcar (lambda (entry) | |
545 | (cons (car entry) (widget-value (cdr entry)))) | |
546 | jabber-widget-alist)))) | |
547 | (jabber-send-iq jabber-buffer-connection nil | |
548 | "set" | |
549 | to-publish | |
550 | #'jabber-report-success "Changing vCard" | |
551 | #'jabber-report-success "Changing vCard") | |
552 | (when (bound-and-true-p jabber-vcard-avatars-publish) | |
553 | (jabber-vcard-avatars-update-current | |
554 | jabber-buffer-connection | |
555 | (and jabber-vcard-photo (avatar-sha1-sum jabber-vcard-photo)))))) | |
556 | ||
557 | (provide 'jabber-vcard) | |
558 | ;; arch-tag: 65B95E9C-63BD-11D9-94A9-000A95C2FCD0 |