org-contacts.el 26 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619
  1. ;;; org-contacts.el --- Contacts management
  2. ;; Copyright (C) 2010-2011 Julien Danjou <julien@danjou.info>
  3. ;; Author: Julien Danjou <julien@danjou.info>
  4. ;; Keywords: outlines, hypermedia, calendar
  5. ;;
  6. ;; This file is NOT part of GNU Emacs.
  7. ;;
  8. ;; GNU Emacs 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 3 of the License, or
  11. ;; (at your option) any later version.
  12. ;; GNU Emacs is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;; GNU General Public License for more details.
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
  18. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19. ;;
  20. ;;; Commentary:
  21. ;; This file contains the code for managing your contacts into Org-mode.
  22. ;; To enter new contacts, you can use `org-capture' and a template just like
  23. ;; this:
  24. ;; ("c" "Contacts" entry (file "~/Org/contacts.org")
  25. ;; "* %(org-contacts-template-name)
  26. ;; :PROPERTIES:
  27. ;; :EMAIL: %(org-contacts-template-email)
  28. ;; :END:")))
  29. ;;
  30. ;;; Code:
  31. (eval-when-compile
  32. (require 'cl))
  33. (eval-and-compile
  34. (require 'org))
  35. (defgroup org-contacts nil
  36. "Options concerning contacts management."
  37. :group 'org)
  38. (defcustom org-contacts-files nil
  39. "List of Org files to use as contacts source.
  40. If set to nil, all your Org files will be used."
  41. :type '(repeat file)
  42. :group 'org-contacts)
  43. (defcustom org-contacts-email-property "EMAIL"
  44. "Name of the property for contact email address."
  45. :type 'string
  46. :group 'org-contacts)
  47. (defcustom org-contacts-address-property "ADDRESS"
  48. "Name of the property for contact address."
  49. :type 'string
  50. :group 'org-contacts)
  51. (defcustom org-contacts-birthday-property "BIRTHDAY"
  52. "Name of the property for contact birthday date."
  53. :type 'string
  54. :group 'org-contacts)
  55. (defcustom org-contacts-birthday-format "Birthday: %l (%Y)"
  56. "Format of the anniversary agenda entry. The following replacements are available:
  57. %h - Heading name
  58. %l - Link to the heading
  59. %y - Number of year
  60. %Y - Number of year (ordinal)"
  61. :type 'string
  62. :group 'org-contacts)
  63. (defcustom org-contacts-last-read-mail-property "LAST_READ_MAIL"
  64. "Name of the property for contact last read email link storage."
  65. :type 'string
  66. :group 'org-contacts)
  67. (defcustom org-contacts-icon-property "ICON"
  68. "Name of the property for contact icon."
  69. :type 'string
  70. :group 'org-contacts)
  71. (defcustom org-contacts-nickname-property "NICKNAME"
  72. "Name of the property for IRC nickname match."
  73. :type 'string
  74. :group 'org-contacts)
  75. (defcustom org-contacts-icon-size 32
  76. "Size of the contacts icons."
  77. :type 'string
  78. :group 'org-contacts)
  79. (defcustom org-contacts-icon-use-gravatar (fboundp 'gravatar-retrieve)
  80. "Whether use Gravatar to fetch contact icons."
  81. :type 'boolean
  82. :group 'org-contacts)
  83. (defcustom org-contacts-completion-ignore-case t
  84. "Ignore case when completing contacts."
  85. :type 'boolean
  86. :group 'org-contacts)
  87. (defcustom org-contacts-group-prefix "+"
  88. "Group prefix."
  89. :type 'string
  90. :group 'org-contacts)
  91. (defcustom org-contacts-matcher (concat org-contacts-email-property "<>\"\"")
  92. "Matching rule for finding heading that are contacts.
  93. This can be a tag name, or a property check."
  94. :type 'string
  95. :group 'org-contacts)
  96. (defcustom org-contacts-email-link-description-format "%s (%d)"
  97. "Format used to store links to email.
  98. This overrides `org-email-link-description-format' if set."
  99. :group 'org-contacts
  100. :type 'string)
  101. (defcustom org-contacts-vcard-file "contacts.vcf"
  102. "Default file for vcard export."
  103. :group 'org-contacts
  104. :type 'file)
  105. (defvar org-contacts-keymap
  106. (let ((map (make-sparse-keymap)))
  107. (define-key map "M" 'org-contacts-view-send-email)
  108. (define-key map "i" 'org-contacts-view-switch-to-irc-buffer)
  109. map)
  110. "The keymap used in `org-contacts' result list.")
  111. (defun org-contacts-files ()
  112. "Return list of Org files to use for contact management."
  113. (or org-contacts-files (org-agenda-files t 'ifmode)))
  114. (defun org-contacts-filter (&optional name-match tags-match)
  115. "Search for a contact maching NAME-MATCH and TAGS-MATCH.
  116. If both match values are nil, return all contacts."
  117. (let ((tags-matcher
  118. (if tags-match
  119. (cdr (org-make-tags-matcher tags-match))
  120. t))
  121. (name-matcher
  122. (if name-match
  123. '(org-string-match-p name-match (org-get-heading t))
  124. t))
  125. (contacts-matcher
  126. (cdr (org-make-tags-matcher org-contacts-matcher)))
  127. markers result)
  128. (dolist (file (org-contacts-files))
  129. (org-check-agenda-file file)
  130. (with-current-buffer (org-get-agenda-file-buffer file)
  131. (unless (eq major-mode 'org-mode)
  132. (error "File %s is no in `org-mode'" file))
  133. (org-scan-tags
  134. '(add-to-list 'markers (set-marker (make-marker) (point)))
  135. `(and ,contacts-matcher ,tags-matcher ,name-matcher))))
  136. (dolist (marker markers result)
  137. (org-with-point-at marker
  138. (add-to-list 'result
  139. (list (org-get-heading t) marker (org-entry-properties marker 'all)))))))
  140. (when (not (fboundp 'completion-table-case-fold))
  141. ;; That function is new in Emacs 24...
  142. (defun completion-table-case-fold (table &optional dont-fold)
  143. (lambda (string pred action)
  144. (let ((completion-ignore-case (not dont-fold)))
  145. (complete-with-action action table string pred)))))
  146. (defun org-contacts-complete-name (&optional start)
  147. "Complete text at START with a user name and email."
  148. (let* ((end (point))
  149. (start (or start
  150. (save-excursion
  151. (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
  152. (goto-char (match-end 0))
  153. (point))))
  154. (orig (buffer-substring start end))
  155. (completion-ignore-case org-contacts-completion-ignore-case)
  156. (group-completion-p (org-string-match-p (concat "^" org-contacts-group-prefix) orig))
  157. (completion-list
  158. (if group-completion-p
  159. (mapcar (lambda (group) (propertize (concat org-contacts-group-prefix group) 'org-contacts-group group))
  160. (org-uniquify
  161. (loop for contact in (org-contacts-filter)
  162. with group-list
  163. nconc (org-split-string
  164. (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))
  165. (loop for contact in (org-contacts-filter)
  166. ;; The contact name is always the car of the assoc-list
  167. ;; returned by `org-contacts-filter'.
  168. for contact-name = (car contact)
  169. ;; Build the list of the user email addresses.
  170. for email-list = (split-string (or
  171. (cdr (assoc-string org-contacts-email-property (caddr contact)))
  172. ""))
  173. ;; If the user has email addresses…
  174. if email-list
  175. ;; … append a list of USER <EMAIL>.
  176. nconc (loop for email in email-list
  177. collect (org-contacts-format-email contact-name email)))))
  178. (completion-list (all-completions orig completion-list)))
  179. ;; If we are completing a group, and that's the only group, just return
  180. ;; the real result.
  181. (when (and group-completion-p
  182. (= (length completion-list) 1))
  183. (setq completion-list
  184. (list (concat (car completion-list) ";: "
  185. (mapconcat 'identity
  186. (loop for contact in (org-contacts-filter
  187. nil
  188. (get-text-property 0 'org-contacts-group (car completion-list)))
  189. ;; The contact name is always the car of the assoc-list
  190. ;; returned by `org-contacts-filter'.
  191. for contact-name = (car contact)
  192. ;; Grab the first email of the contact
  193. for email = (car (split-string (or
  194. (cdr (assoc-string org-contacts-email-property (caddr contact)))
  195. "")))
  196. ;; If the user has an email address, append USER <EMAIL>.
  197. if email collect (org-contacts-format-email contact-name email))
  198. ", ")))))
  199. (list start end (completion-table-case-fold completion-list (not org-contacts-completion-ignore-case)))))
  200. (defun org-contacts-message-complete-function ()
  201. "Function used in `completion-at-point-functions' in `message-mode'."
  202. (let ((mail-abbrev-mode-regexp
  203. "^\\(Resent-To\\|To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\|Disposition-Notification-To\\|Return-Receipt-To\\):"))
  204. (when (mail-abbrev-in-expansion-header-p)
  205. (org-contacts-complete-name))))
  206. (defun org-contacts-gnus-get-name-email ()
  207. "Get name and email address from Gnus message."
  208. (if (gnus-alive-p)
  209. (gnus-with-article-headers
  210. (mail-extract-address-components
  211. (or (mail-fetch-field "From") "")))))
  212. (defun org-contacts-gnus-article-from-get-marker ()
  213. "Return a marker for a contact based on From."
  214. (let* ((address (org-contacts-gnus-get-name-email))
  215. (name (car address))
  216. (email (cadr address)))
  217. (cadar (or (org-contacts-filter
  218. nil
  219. (concat org-contacts-email-property "={\\b" (regexp-quote email) "\\b}"))
  220. (when name
  221. (org-contacts-filter
  222. (concat "^" name "$")))))))
  223. (defun org-contacts-gnus-article-from-goto ()
  224. "Go to contact in the From address of current Gnus message."
  225. (interactive)
  226. (let ((marker (org-contacts-gnus-article-from-get-marker)))
  227. (when marker
  228. (switch-to-buffer-other-window (marker-buffer marker))
  229. (goto-char marker)
  230. (when (eq major-mode 'org-mode)
  231. (org-show-context 'agenda)
  232. (save-excursion
  233. (and (outline-next-heading)
  234. ;; show the next heading
  235. (org-flag-heading nil)))))))
  236. (defun org-contacts-anniversaries (&optional field format)
  237. "Compute FIELD anniversary for each contact, returning FORMAT.
  238. Default FIELD value is \"BIRTHDAY\".
  239. Format is a string matching the following format specification:
  240. %h - Heading name
  241. %l - Link to the heading
  242. %y - Number of year
  243. %Y - Number of year (ordinal)"
  244. (let ((calendar-date-style 'american)
  245. (entry ""))
  246. (unless format (setq format org-contacts-birthday-format))
  247. (loop for contact in (org-contacts-filter)
  248. for anniv = (let ((anniv (cdr (assoc-string
  249. (or field org-contacts-birthday-property)
  250. (caddr contact)))))
  251. (when anniv
  252. (calendar-gregorian-from-absolute
  253. (org-time-string-to-absolute anniv))))
  254. ;; Use `diary-anniversary' to compute anniversary.
  255. if (and anniv (apply 'diary-anniversary anniv))
  256. collect (format-spec format
  257. `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
  258. (?h . ,(car contact))
  259. (?y . ,(- (calendar-extract-year date)
  260. (calendar-extract-year anniv)))
  261. (?Y . ,(let ((years (- (calendar-extract-year date)
  262. (calendar-extract-year anniv))))
  263. (format "%d%s" years (diary-ordinal-suffix years)))))))))
  264. (defun org-completing-read-date (prompt collection
  265. &optional predicate require-match initial-input
  266. hist def inherit-input-method)
  267. "Like `completing-read' but reads a date.
  268. Only PROMPT and DEF are really used."
  269. (org-read-date nil nil nil prompt nil def))
  270. (add-to-list 'org-property-set-functions-alist
  271. `(,org-contacts-birthday-property . org-completing-read-date))
  272. (defun org-contacts-template-name (&optional return-value)
  273. "Try to return the contact name for a template.
  274. If not found return RETURN-VALUE or something that would ask the user."
  275. (or (car (org-contacts-gnus-get-name-email))
  276. return-value
  277. "%^{Name}"))
  278. (defun org-contacts-template-email (&optional return-value)
  279. "Try to return the contact email for a template.
  280. If not found return RETURN-VALUE or something that would ask the user."
  281. (or (cadr (org-contacts-gnus-get-name-email))
  282. return-value
  283. (concat "%^{" org-contacts-email-property "}p")))
  284. (defun org-contacts-gnus-store-last-mail ()
  285. "Store a link between mails and contacts.
  286. This function should be called from `gnus-article-prepare-hook'."
  287. (let ((marker (org-contacts-gnus-article-from-get-marker)))
  288. (when marker
  289. (with-current-buffer (marker-buffer marker)
  290. (save-excursion
  291. (goto-char marker)
  292. (let* ((org-email-link-description-format (or org-contacts-email-link-description-format
  293. org-email-link-description-format))
  294. (link (gnus-with-article-buffer (org-store-link nil))))
  295. (org-set-property org-contacts-last-read-mail-property link)))))))
  296. (defun org-contacts-icon-as-string ()
  297. (let ((image (org-contacts-get-icon)))
  298. (concat
  299. (propertize "-" 'display
  300. (append
  301. (if image
  302. image
  303. `'(space :width (,org-contacts-icon-size)))
  304. '(:ascent center)))
  305. " ")))
  306. ;;;###autoload
  307. (defun org-contacts (name)
  308. "Create agenda view for contacts matching NAME."
  309. (interactive (list (read-string "Name: ")))
  310. (let ((org-agenda-files (org-contacts-files))
  311. (org-agenda-skip-function
  312. (lambda () (org-agenda-skip-if nil `(notregexp ,name))))
  313. (org-agenda-format (propertize
  314. "%(org-contacts-icon-as-string)% p% s%(org-contacts-irc-number-of-unread-messages)%+T"
  315. 'keymap org-contacts-keymap))
  316. (org-agenda-overriding-header
  317. (or org-agenda-overriding-header
  318. (concat "List of contacts matching `" name "':"))))
  319. (setq org-agenda-skip-regexp name)
  320. (org-tags-view nil org-contacts-matcher)
  321. (with-current-buffer org-agenda-buffer-name
  322. (setq org-agenda-redo-command
  323. (list 'org-contacts name)))))
  324. (defun org-contacts-completing-read (prompt
  325. &optional predicate
  326. initial-input hist def inherit-input-method)
  327. "Call `completing-read' with contacts name as collection."
  328. (org-completing-read
  329. prompt (org-contacts-filter) predicate t initial-input hist def inherit-input-method))
  330. (defun org-contacts-format-email (name email)
  331. "Format a mail address."
  332. (unless email
  333. (error "`email' cannot be nul"))
  334. (if name
  335. (concat name " <" email ">")
  336. email))
  337. (defun org-contacts-check-mail-address (mail)
  338. "Add MAIL address to contact at point if it does not have it."
  339. (let ((mails (org-entry-get (point) org-contacts-email-property)))
  340. (unless (member mail (split-string mails))
  341. (when (yes-or-no-p
  342. (format "Do you want to this address to %s?" (org-get-heading t)))
  343. (org-set-property org-contacts-email-property (concat mails " " mail))))))
  344. (defun org-contacts-gnus-check-mail-address ()
  345. "Check that contact has the current address recorded.
  346. This function should be called from `gnus-article-prepare-hook'."
  347. (let ((marker (org-contacts-gnus-article-from-get-marker)))
  348. (when marker
  349. (org-with-point-at marker
  350. (org-contacts-check-mail-address (cadr (org-contacts-gnus-get-name-email)))))))
  351. (defun org-contacts-gnus-insinuate ()
  352. "Add some hooks for Gnus user.
  353. This adds `org-contacts-gnus-check-mail-address' and
  354. `org-contacts-gnus-store-last-mail' to
  355. `gnus-article-prepare-hook'. It also adds a binding on `;' in
  356. `gnus-summary-mode-map' to `org-contacts-gnus-article-from-goto'"
  357. (require 'gnus)
  358. (require 'gnus-art)
  359. (define-key gnus-summary-mode-map ";" 'org-contacts-gnus-article-from-goto)
  360. (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-check-mail-address)
  361. (add-hook 'gnus-article-prepare-hook 'org-contacts-gnus-store-last-mail))
  362. (when (boundp 'completion-at-point-functions)
  363. (add-hook 'message-mode-hook
  364. (lambda ()
  365. (add-to-list 'completion-at-point-functions
  366. 'org-contacts-message-complete-function))))
  367. (defun org-contacts-wl-get-from-header-content ()
  368. "Retrieve the content of the `From' header of an email.
  369. Works from wl-summary-mode and mime-view-mode - that is while viewing email.
  370. Depends on Wanderlust been loaded."
  371. (with-current-buffer (org-capture-get :original-buffer)
  372. (cond
  373. ((eq major-mode 'wl-summary-mode) (when wl-summary-buffer-elmo-folder
  374. (elmo-message-field
  375. wl-summary-buffer-elmo-folder
  376. (wl-summary-message-number)
  377. 'from)))
  378. ((eq major-mode 'mime-view-mode) (std11-narrow-to-header)
  379. (prog1
  380. (std11-fetch-field "From")
  381. (widen))))))
  382. (defun org-contacts-wl-get-name-email ()
  383. "Get name and email address from wanderlust email.
  384. See `org-contacts-wl-get-from-header-content' for limitations."
  385. (let ((from (org-contacts-wl-get-from-header-content)))
  386. (when from
  387. (list (wl-address-header-extract-realname from)
  388. (wl-address-header-extract-address from)))))
  389. (defun org-contacts-template-wl-name (&optional return-value)
  390. "Try to return the contact name for a template from wl.
  391. If not found return RETURN-VALUE or something that would ask the user."
  392. (or (car (org-contacts-wl-get-name-email))
  393. return-value
  394. "%^{Name}"))
  395. (defun org-contacts-template-wl-email (&optional return-value)
  396. "Try to return the contact email for a template from wl.
  397. If not found return RETURN-VALUE or something that would ask the user."
  398. (or (cadr (org-contacts-wl-get-name-email))
  399. return-value
  400. (concat "%^{" org-contacts-email-property "}p")))
  401. (defun org-contacts-view-send-email (&optional ask)
  402. "Send email to the contact at point.
  403. If ASK is set, ask for the email address even if there's only one address."
  404. (interactive "P")
  405. (let ((marker (org-get-at-bol 'org-hd-marker)))
  406. (org-with-point-at marker
  407. (let ((emails (org-entry-get (point) org-contacts-email-property)))
  408. (if emails
  409. (let ((email-list (split-string emails)))
  410. (if (and (= (length email-list) 1) (not ask))
  411. (compose-mail (org-contacts-format-email
  412. (org-get-heading t) emails))
  413. (let ((email (completing-read "Send mail to which address: " email-list)))
  414. (org-contacts-check-mail-address email)
  415. (compose-mail (org-contacts-format-email (org-get-heading t) email)))))
  416. (error (format "This contact has no mail address set (no %s property)."
  417. org-contacts-email-property)))))))
  418. (defun org-contacts-get-icon (&optional pom)
  419. "Get icon for contact at POM."
  420. (setq pom (or pom (point)))
  421. (catch 'icon
  422. ;; Use `org-contacts-icon-property'
  423. (let ((image-data (org-entry-get pom org-contacts-icon-property)))
  424. (when image-data
  425. (throw 'icon
  426. (if (fboundp 'gnus-rescale-image)
  427. (gnus-rescale-image (create-image image-data)
  428. (cons org-contacts-icon-size org-contacts-icon-size))
  429. (create-image image-data)))))
  430. ;; Next, try Gravatar
  431. (when org-contacts-icon-use-gravatar
  432. (let* ((gravatar-size org-contacts-icon-size)
  433. (email-list (org-entry-get pom org-contacts-email-property))
  434. (gravatar
  435. (when email-list
  436. (loop for email in (split-string email-list)
  437. for gravatar = (gravatar-retrieve-synchronously email)
  438. if (and gravatar
  439. (not (eq gravatar 'error)))
  440. return gravatar))))
  441. (when gravatar (throw 'icon gravatar))))))
  442. (defun org-contacts-irc-buffer (&optional pom)
  443. "Get the IRC buffer associated with the entry at POM."
  444. (setq pom (or pom (point)))
  445. (let ((nick (org-entry-get pom org-contacts-nickname-property)))
  446. (when nick
  447. (let ((buffer (get-buffer nick)))
  448. (when buffer
  449. (with-current-buffer buffer
  450. (when (eq major-mode 'erc-mode)
  451. buffer)))))))
  452. (defun org-contacts-irc-number-of-unread-messages (&optional pom)
  453. "Return the number of unread messages for contact at POM."
  454. (when (boundp 'erc-modified-channels-alist)
  455. (let ((number (cadr (assoc (org-contacts-irc-buffer pom) erc-modified-channels-alist))))
  456. (if number
  457. (format (concat "%3d unread message" (if (> number 1) "s" " ") " ") number)
  458. (make-string 21 ? )))))
  459. (defun org-contacts-view-switch-to-irc-buffer ()
  460. "Switch to the IRC buffer of the current contact if it has one."
  461. (interactive)
  462. (let ((marker (org-get-at-bol 'org-hd-marker)))
  463. (org-with-point-at marker
  464. (switch-to-buffer-other-window (org-contacts-irc-buffer)))))
  465. (defun org-contacts-completing-read-nickname (prompt collection
  466. &optional predicate require-match initial-input
  467. hist def inherit-input-method)
  468. "Like `completing-read' but reads a nickname."
  469. (org-completing-read prompt (append collection (erc-nicknames-list)) predicate require-match
  470. initial-input hist def inherit-input-method))
  471. (defun erc-nicknames-list ()
  472. "Return all nicknames of all ERC buffers."
  473. (if (fboundp 'erc-buffer-list)
  474. (loop for buffer in (erc-buffer-list)
  475. nconc (with-current-buffer buffer
  476. (loop for user-entry in (mapcar 'car (erc-get-channel-user-list))
  477. collect (elt user-entry 1))))))
  478. (add-to-list 'org-property-set-functions-alist
  479. `(,org-contacts-nickname-property . org-contacts-completing-read-nickname))
  480. (defun org-contacts-vcard-escape (str)
  481. "Escape ; , and \n in STR for use in the VCard format.
  482. Thanks to http://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el for the regexp."
  483. (when str
  484. (replace-regexp-in-string "\n" "\\\\n" (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" str))))
  485. (defun org-contacts-vcard-encode-name (name)
  486. "Try to encode NAME as VCard's N property. The N property expects FamilyName;GivenName;AdditionalNames;Prefix;Postfix.
  487. Org-contacts does not specify how to encode the name. So we try to do our best."
  488. (concat (replace-regexp-in-string "\\(\\w+\\) \\(.*\\)" "\\2;\\1" name) ";;;"))
  489. (defun org-contacts-vcard-format (contact)
  490. "Formats CONTACT in VCard 3.0 format."
  491. (let* ((properties (caddr contact))
  492. (name (org-contacts-vcard-escape (car contact)))
  493. (n (org-contacts-vcard-encode-name name))
  494. (email (org-contacts-vcard-escape (cdr (assoc-string org-contacts-email-property properties))))
  495. (bday (org-contacts-vcard-escape (cdr (assoc-string org-contacts-birthday-property properties))))
  496. (addr (cdr (assoc-string org-contacts-address-property properties)))
  497. (nick (org-contacts-vcard-escape (cdr (assoc-string org-contacts-nickname-property properties))))
  498. (head (format "BEGIN:VCARD\nVERSION:3.0\nN:%s\nFN:%s\n" n name)))
  499. (concat head
  500. (when email (format "EMAIL:%s\n" email))
  501. (when addr
  502. (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr)))
  503. (when bday
  504. (let ((cal-bday (calendar-gregorian-from-absolute (org-time-string-to-absolute bday))))
  505. (format "BDAY:%04d-%02d-%02d\n"
  506. (calendar-extract-year cal-bday)
  507. (calendar-extract-month cal-bday)
  508. (calendar-extract-day cal-bday))))
  509. (when nick (format "NICKNAME:%s\n" nick))
  510. "END:VCARD\n\n")))
  511. (defun org-contacts-export-as-vcard (&optional name file to-buffer)
  512. "Export all contacts matching NAME as VCard 3.0. It TO-BUFFER is nil, the content is written to FILE or `org-contacts-vcard-file'. If TO-BUFFER is non-nil, the buffer is created and the VCard is written into that buffer."
  513. (interactive) ; TODO ask for name?
  514. (let* ((filename (or file org-contacts-vcard-file))
  515. (buffer (if to-buffer
  516. (get-buffer-create to-buffer)
  517. (find-file-noselect filename))))
  518. (message "Exporting...")
  519. (set-buffer buffer)
  520. (let ((inhibit-read-only t)) (erase-buffer))
  521. (fundamental-mode)
  522. (org-install-letbind)
  523. (when (fboundp 'set-buffer-file-coding-system)
  524. (set-buffer-file-coding-system coding-system-for-write))
  525. (loop for contact in (org-contacts-filter name)
  526. do (insert (org-contacts-vcard-format contact)))
  527. (if to-buffer
  528. (current-buffer)
  529. (progn (save-buffer) (kill-buffer)))))
  530. (defun org-contacts-show-map (&optional name)
  531. "Show contacts on a map. Requires google-maps-el."
  532. (interactive)
  533. (unless (fboundp 'google-maps-static-show)
  534. (error "org-contacts-show-map requires google-maps-el."))
  535. (google-maps-static-show
  536. :markers
  537. (loop
  538. for contact in (org-contacts-filter name)
  539. for addr = (cdr (assoc-string org-contacts-address-property (caddr contact)))
  540. if addr
  541. collect (cons (list addr) (list :label (string-to-char (car contact)))))))
  542. (provide 'org-contacts)