1 ;;; jabber-vcard.el --- vcards according to JEP-0054
3 ;; Copyright (C) 2005, 2007 Magnus Henoch
5 ;; Author: Magnus Henoch <mange@freemail.hu>
7 ;; This file is a part of jabber.el.
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)
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.
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.
26 ;; There are great variations in Jabber vcard implementations. This
27 ;; one adds some spice to the mix, while trying to follow the JEP
30 ;; Fields not implemented: GEO, LOGO, AGENT, ORG, CATEGORIES, SOUND,
33 ;; The internal data structure used for vCards is an alist. All
34 ;; keys are uppercase symbols.
36 ;; FN, NICKNAME, BDAY, JABBERID, MAILER, TZ, TITLE, ROLE, NOTE,
37 ;; PRODID, REV, SORT-STRING, UID, URL, DESC:
41 ;; Value is an alist, with keys FAMILY, GIVEN, MIDDLE, PREFIX and SUFFIX.
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.
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,
55 ;; The cdr is the phone number as a string.
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.
66 (require 'jabber-core
)
67 (require 'jabber-widget
)
69 (require 'jabber-avatar
)
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
)
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"))
82 (dolist (verbatim-node '(FN NICKNAME BDAY JABBERID MAILER TZ
83 TITLE ROLE NOTE PRODID REV SORT-STRING
85 ;; There should only be one of each of these. They are
87 (let ((node (car (jabber-xml-get-children vcard
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
)))
96 (let ((node (car (jabber-xml-get-children vcard
'N
))))
97 ;; Subnodes are FAMILY, GIVEN, MIDDLE, PREFIX, SUFFIX
100 (dolist (subnode (jabber-xml-node-children node
))
101 (when (and (memq (jabber-xml-node-name subnode
)
102 '(FAMILY GIVEN MIDDLE PREFIX SUFFIX
))
104 (car (jabber-xml-node-children
106 (push (cons (jabber-xml-node-name subnode
)
107 (car (jabber-xml-node-children
113 ;; There can be several addresses
115 (dolist (adr (jabber-xml-get-children vcard
'ADR
))
116 ;; Find address type(s)
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
)))
123 (dolist (component (jabber-xml-node-children adr
))
124 (when (and (memq (jabber-xml-node-name component
)
125 '(POBOX EXTADD STREET LOCALITY REGION
128 (car (jabber-xml-node-children
130 (push (cons (jabber-xml-node-name component
)
131 (car (jabber-xml-node-children component
)))
134 (push (cons types components
) addresses
))))
137 (push (cons 'ADR addresses
) result
)))
139 ;; Likewise for 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
)))))
146 ;; Some clients put no NUMBER node. Avoid that.
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
)))
153 (push (cons types number
) phone-numbers
))))
156 (push (cons 'TEL phone-numbers
) result
)))
158 ;; And for e-mail addresses
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
)))))
164 ;; Some clients put no USERID node. Avoid that.
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
)
171 (push 'INTERNET types
))
173 (push (cons types userid
) e-mails
))))
176 (push (cons 'EMAIL e-mails
) result
)))
178 ;; JEP-0153: vCard-based avatars
179 (let ((photo-tag (car (jabber-xml-get-children vcard
'PHOTO
))))
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
)))))
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
))))
195 (setq jabber-vcard-photo nil
))
198 (setq jabber-vcard-photo
199 (jabber-avatar-from-base64-string
200 (nth 1 photo
) (nth 0 photo
))))
201 ;; New photo from file
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
)))))
209 `(vCard ((xmlns .
"vcard-temp"))
210 ;; Put in simple fields
213 (when (and (assq (car field
) jabber-vcard-fields
)
214 (not (zerop (length (cdr field
)))))
215 (list (car field
) nil
(cdr field
))))
217 ;; Put in decomposited name
221 (when (not (zerop (length (cdr name-part
))))
222 (list (car name-part
) nil
(cdr name-part
))))
223 (cdr (assq 'N parsed
))))
228 (mapcar 'list
(nth 0 address
))
229 (mapcar (lambda (field)
230 (list (car field
) nil
(cdr field
)))
232 (cdr (assq 'ADR parsed
)))
233 ;; Put in phone numbers
237 (mapcar 'list
(car phone
))
238 (list (list 'NUMBER nil
(cdr phone
)))))
239 (cdr (assq 'TEL parsed
)))
240 ;; Put in e-mail addresses
243 (append '(EMAIL) '(())
244 (mapcar 'list
(car email
))
245 (list (list 'USERID nil
(cdr email
)))))
246 (cdr (assq 'EMAIL parsed
)))
248 ,@(when jabber-vcard-photo
250 (TYPE () ,(avatar-mime-type jabber-vcard-photo
))
251 (BINVAL () ,(avatar-base64-data jabber-vcard-photo
)))))))
253 (add-to-list 'jabber-jid-info-menu
254 (cons "Request vcard" 'jabber-vcard-get
))
256 (defun jabber-vcard-get (jc jid
)
257 "Request vcard from JID."
258 (interactive (list (jabber-read-account)
259 (jabber-read-jid-completing "Request vcard from: " nil nil nil
'bare-or-muc
)))
260 (jabber-send-iq jc jid
262 '(vCard ((xmlns .
"vcard-temp")))
263 #'jabber-process-data
#'jabber-vcard-display
264 #'jabber-process-data
"Vcard request failed"))
266 (defun jabber-vcard-edit (jc)
267 "Edit your own vcard."
268 (interactive (list (jabber-read-account)))
269 (jabber-send-iq jc nil
271 '(vCard ((xmlns .
"vcard-temp")))
272 #'jabber-vcard-do-edit nil
273 #'jabber-report-success
"Vcard request failed"))
275 (defconst jabber-vcard-fields
'((FN .
"Full name")
276 (NICKNAME .
"Nickname")
280 (MAILER .
"User agent")
284 (REV .
"Last changed")
285 (DESC .
"Description")
288 (defconst jabber-vcard-name-fields
'((PREFIX .
"Prefix")
289 (GIVEN .
"Given name")
290 (MIDDLE .
"Middle name")
291 (FAMILY .
"Family name")
292 (SUFFIX .
"Suffix")))
294 (defconst jabber-vcard-phone-types
'((HOME .
"Home")
300 (CELL .
"Cell phone")
307 (defconst jabber-vcard-email-types
'((HOME .
"Home")
309 (INTERNET .
"Internet")
311 (PREF .
"Preferred")))
313 (defconst jabber-vcard-address-types
'((HOME .
"Home")
318 (INTL .
"International")
319 (PREF .
"Preferred")))
321 (defconst jabber-vcard-address-fields
'((POBOX .
"Post box")
322 (EXTADD .
"Ext. address")
324 (LOCALITY .
"Locality")
326 (PCODE .
"Post code")
329 (defun jabber-vcard-display (jc xml-data
)
330 "Display received vcard."
331 (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data
))))
332 (dolist (simple-field jabber-vcard-fields
)
333 (let ((field (assq (car simple-field
) parsed
)))
335 (insert (cdr simple-field
))
337 (insert (cdr field
) "\n"))))
339 (let ((names (cdr (assq 'N parsed
))))
342 (dolist (name-field jabber-vcard-name-fields
)
343 (let ((field (assq (car name-field
) names
)))
345 (insert (cdr name-field
))
347 (insert (cdr field
) "\n"))))))
349 (let ((email-addresses (cdr (assq 'EMAIL parsed
))))
350 (when email-addresses
352 (insert (jabber-propertize "E-mail addresses:\n"
353 'face
'jabber-title-medium
))
354 (dolist (email email-addresses
)
355 (insert (mapconcat (lambda (type)
356 (cdr (assq type jabber-vcard-email-types
)))
359 (insert ": " (cdr email
) "\n"))))
361 (let ((phone-numbers (cdr (assq 'TEL parsed
))))
364 (insert (jabber-propertize "Phone numbers:\n"
365 'face
'jabber-title-medium
))
366 (dolist (number phone-numbers
)
367 (insert (mapconcat (lambda (type)
368 (cdr (assq type jabber-vcard-phone-types
)))
371 (insert ": " (cdr number
) "\n"))))
373 (let ((addresses (cdr (assq 'ADR parsed
))))
376 (insert (jabber-propertize "Addresses:\n"
377 'face
'jabber-title-medium
))
378 (dolist (address addresses
)
379 (insert (jabber-propertize
380 (mapconcat (lambda (type)
381 (cdr (assq type jabber-vcard-address-types
)))
384 'face
'jabber-title-small
))
386 (dolist (address-field jabber-vcard-address-fields
)
387 (let ((field (assq (car address-field
) address
)))
389 (insert (cdr address-field
))
391 (insert (cdr field
) "\n")))))))
393 ;; JEP-0153: vCard-based avatars
394 (let ((photo-type (nth 1 (assq 'PHOTO parsed
)))
395 (photo-binval (nth 2 (assq 'PHOTO parsed
))))
396 (when (and photo-type photo-binval
)
398 ;; ignore the type, let create-image figure it out.
399 (let ((image (create-image (base64-decode-string photo-binval
) nil t
)))
400 (insert-image image
"[Photo]")
402 (error (insert "Couldn't display photo\n")))))))
404 (defun jabber-vcard-do-edit (jc xml-data closure-data
)
405 (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data
)))
407 (with-current-buffer (get-buffer-create "Edit vcard")
408 (jabber-init-widget-buffer nil
)
410 (setq jabber-buffer-connection jc
)
412 (setq start-position
(point))
414 (dolist (simple-field jabber-vcard-fields
)
415 (widget-insert (cdr simple-field
))
417 (let ((default-value (cdr (assq (car simple-field
) parsed
))))
418 (push (cons (car simple-field
)
419 (widget-create 'editable-field
(or default-value
"")))
420 jabber-widget-alist
)))
425 '(set :tag
"Decomposited name"
426 (cons :tag
"Prefix" :format
"%t: %v" (const :format
"" PREFIX
) (string :format
"%v"))
427 (cons :tag
"Given name" :format
"%t: %v" (const :format
"" GIVEN
) (string :format
"%v"))
428 (cons :tag
"Middle name" :format
"%t: %v" (const :format
"" MIDDLE
) (string :format
"%v"))
429 (cons :tag
"Family name" :format
"%t: %v" (const :format
"" FAMILY
) (string :format
"%v"))
430 (cons :tag
"Suffix" :format
"%t: %v" (const :format
"" SUFFIX
) (string :format
"%v")))
431 :value
(cdr (assq 'N parsed
))))
437 '(repeat :tag
"Postal addresses"
441 (const :tag
"Home" HOME
)
442 (const :tag
"Work" WORK
)
443 (const :tag
"Postal" POSTAL
)
444 (const :tag
"Parcel" PARCEL
)
445 (const :tag
"Domestic" DOM
)
446 (const :tag
"International" INTL
)
447 (const :tag
"Preferred" PREF
))
450 (cons :tag
"Post box" :format
"%t: %v"
451 (const :format
"" POBOX
) (string :format
"%v"))
452 (cons :tag
"Ext. address" :format
"%t: %v"
453 (const :format
"" EXTADD
) (string :format
"%v"))
454 (cons :tag
"Street" :format
"%t: %v"
455 (const :format
"" STREET
) (string :format
"%v"))
456 (cons :tag
"Locality" :format
"%t: %v"
457 (const :format
"" LOCALITY
) (string :format
"%v"))
458 (cons :tag
"Region" :format
"%t: %v"
459 (const :format
"" REGION
) (string :format
"%v"))
460 (cons :tag
"Post code" :format
"%t: %v"
461 (const :format
"" PCODE
) (string :format
"%v"))
462 (cons :tag
"Country" :format
"%t: %v"
463 (const :format
"" CTRY
) (string :format
"%v")))))
464 :value
(cdr (assq 'ADR parsed
))))
470 '(repeat :tag
"Phone numbers"
473 (const :tag
"Home" HOME
)
474 (const :tag
"Work" WORK
)
475 (const :tag
"Voice" VOICE
)
476 (const :tag
"Fax" FAX
)
477 (const :tag
"Pager" PAGER
)
478 (const :tag
"Message" MSG
)
479 (const :tag
"Cell phone" CELL
)
480 (const :tag
"Video" VIDEO
)
481 (const :tag
"BBS" BBS
)
482 (const :tag
"Modem" MODEM
)
483 (const :tag
"ISDN" ISDN
)
484 (const :tag
"PCS" PCS
))
485 (string :tag
"Number")))
486 :value
(cdr (assq 'TEL parsed
))))
492 '(repeat :tag
"E-mail addresses"
495 (const :tag
"Home" HOME
)
496 (const :tag
"Work" WORK
)
497 (const :tag
"Internet" INTERNET
)
498 (const :tag
"X400" X400
)
499 (const :tag
"Preferred" PREF
))
500 (string :tag
"Address")))
501 :value
(cdr (assq 'EMAIL parsed
))))
505 (widget-insert "Photo/avatar:\n")
506 (let* ((photo (assq 'PHOTO parsed
))
508 (jabber-avatar-from-base64-string (nth 2 photo
)
513 `(radio-button-choice (const :tag
"None" nil
)
519 (jabber-propertize " "
520 'display
(jabber-avatar-image avatar
)))
522 (file :must-match t
:tag
"From file"))
524 jabber-widget-alist
))
527 (widget-create 'push-button
:notify
#'jabber-vcard-submit
"Submit")
530 (widget-minor-mode 1)
531 (switch-to-buffer (current-buffer))
532 (goto-char start-position
))))
534 (defun jabber-vcard-submit (&rest ignore
)
535 (let ((to-publish (jabber-vcard-reassemble
536 (mapcar (lambda (entry)
537 (cons (car entry
) (widget-value (cdr entry
))))
538 jabber-widget-alist
))))
539 (jabber-send-iq jabber-buffer-connection nil
542 #'jabber-report-success
"Changing vCard"
543 #'jabber-report-success
"Changing vCard")
544 (when (bound-and-true-p jabber-vcard-avatars-publish
)
545 (jabber-vcard-avatars-update-current
546 jabber-buffer-connection
547 (and jabber-vcard-photo
(avatar-sha1-sum jabber-vcard-photo
))))))
549 (provide 'jabber-vcard
)
550 ;; arch-tag: 65B95E9C-63BD-11D9-94A9-000A95C2FCD0