org-contacts.el

   1 ;;; org-contacts.el --- Contacts management  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2010-2014, 2021 Julien Danjou <julien@danjou.info>
   4
   5 ;; Author: Julien Danjou <julien@danjou.info>
   6 ;; Maintainer: stardiviner <numbchild@gmail.com>
   7 ;; Keywords: contacts, org-mode, outlines, hypermedia, calendar
   8 ;; Version: 0
   9 ;;
  10 ;; This file is not part of GNU Emacs.
  11 ;;
  12 ;; This program is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25 ;;
  26 ;;; Commentary:
  27
  28 ;; This file contains the code for managing your contacts into Org-mode.
  29
  30 ;; To enter new contacts, you can use `org-capture' and a minimal template just like
  31 ;; this:
  32
  33 ;;         ("c" "Contacts" entry (file "~/Org/contacts.org")
  34 ;;          "* %(org-contacts-template-name)
  35 ;; :PROPERTIES:
  36 ;; :EMAIL: %(org-contacts-template-email)
  37 ;; :END:")))
  38 ;;
  39 ;; You can also use a complex template, for example:
  40 ;;
  41 ;;         ("c" "Contacts" entry (file "~/Org/contacts.org")
  42 ;;          "* %(org-contacts-template-name)
  43 ;; :PROPERTIES:
  44 ;; :EMAIL: %(org-contacts-template-email)
  45 ;; :PHONE:
  46 ;; :ALIAS:
  47 ;; :NICKNAME:
  48 ;; :IGNORE:
  49 ;; :ICON:
  50 ;; :NOTE:
  51 ;; :ADDRESS:
  52 ;; :BIRTHDAY:
  53 ;; :END:")))
  54
  55 ;;;; Usage:
  56
  57 ;;; How to search?
  58 ;;; - You can use [M-x org-contacts] command to search.
  59 ;;;
  60 ;;; - You can use `org-sparse-tree' [C-c / p] to filter based on a
  61 ;;;   specific property. Or other matcher on `org-sparse-tree'.
  62
  63 ;;; Code:
  64
  65 (require 'cl-lib)
  66 (require 'org)
  67 (require 'gnus-util)
  68 (require 'gnus-art)
  69 (require 'mail-utils)
  70 (require 'org-agenda)
  71 (require 'org-capture)
  72 (require 'ol)
  73
  74 (defgroup org-contacts nil
  75   "Options about contacts management."
  76   :group 'org)
  77
  78 (defcustom org-contacts-files nil
  79   "List of Org files to use as contacts source.
  80 When set to nil, all your Org files will be used."
  81   :type '(repeat file))
  82
  83 (defcustom org-contacts-email-property "EMAIL"
  84   "Name of the property for contact email address."
  85   :type 'string)
  86
  87 (defcustom org-contacts-tel-property "PHONE"
  88   "Name of the property for contact phone number."
  89   :type 'string)
  90
  91 (defcustom org-contacts-address-property "ADDRESS"
  92   "Name of the property for contact address."
  93   :type 'string)
  94
  95 (defcustom org-contacts-birthday-property "BIRTHDAY"
  96   "Name of the property for contact birthday date."
  97   :type 'string)
  98
  99 (defcustom org-contacts-note-property "NOTE"
 100   "Name of the property for contact note."
 101   :type 'string)
 102
 103 (defcustom org-contacts-alias-property "ALIAS"
 104   "Name of the property for contact name alias."
 105   :type 'string)
 106
 107 (defcustom org-contacts-ignore-property "IGNORE"
 108   "Name of the property, which values will be ignored when
 109 completing or exporting to vcard."
 110   :type 'string)
 111
 112
 113 (defcustom org-contacts-birthday-format "Birthday: %l (%Y)"
 114   "Format of the anniversary agenda entry.
 115 The following replacements are available:
 116
 117   %h - Heading name
 118   %l - Link to the heading
 119   %y - Number of year
 120   %Y - Number of year (ordinal)"
 121   :type 'string)
 122
 123 (defcustom org-contacts-last-read-mail-property "LAST_READ_MAIL"
 124   "Name of the property for contact last read email link storage."
 125   :type 'string)
 126
 127 (defcustom org-contacts-icon-property "ICON"
 128   "Name of the property for contact icon."
 129   :type 'string)
 130
 131 (defcustom org-contacts-nickname-property "NICKNAME"
 132   "Name of the property for IRC nickname match."
 133   :type 'string)
 134
 135 (defcustom org-contacts-icon-size 32
 136   "Size of the contacts icons."
 137   :type 'string)
 138
 139 (defcustom org-contacts-icon-use-gravatar (fboundp 'gravatar-retrieve)
 140   "Whether use Gravatar to fetch contact icons."
 141   :type 'boolean)
 142
 143 (defcustom org-contacts-completion-ignore-case t
 144   "Ignore case when completing contacts."
 145   :type 'boolean)
 146
 147 (defcustom org-contacts-group-prefix "+"
 148   "Group prefix."
 149   :type 'string)
 150
 151 (defcustom org-contacts-tags-props-prefix "#"
 152   "Tags and properties prefix."
 153   :type 'string)
 154
 155 (defcustom org-contacts-matcher
 156   (mapconcat #'identity
 157              (mapcar (lambda (x) (concat x "<>\"\""))
 158                      (list org-contacts-email-property
 159                            org-contacts-alias-property
 160                            org-contacts-tel-property
 161                            org-contacts-address-property
 162                            org-contacts-birthday-property))
 163              "|")
 164   "Matching rule for finding heading that are contacts.
 165 This can be a tag name, or a property check."
 166   :type 'string)
 167
 168 (defcustom org-contacts-email-link-description-format "%s (%d)"
 169   "Format used to store links to email.
 170 This overrides `org-email-link-description-format' if set."
 171   :type 'string)
 172
 173 (defcustom org-contacts-vcard-file "contacts.vcf"
 174   "Default file for vcard export."
 175   :type 'file)
 176
 177 (defcustom org-contacts-enable-completion t
 178   "Enable or not the completion in `message-mode' with `org-contacts'."
 179   :type 'boolean)
 180
 181 (defcustom org-contacts-complete-functions
 182   '(org-contacts-complete-group org-contacts-complete-tags-props org-contacts-complete-name)
 183   "List of functions used to complete contacts in `message-mode'."
 184   :type 'hook)
 185
 186 ;; Decalre external functions and variables
 187 (declare-function org-reverse-string "org")
 188 (declare-function diary-ordinal-suffix "ext:diary-lib")
 189 (declare-function wl-summary-message-number "ext:wl-summary")
 190 (declare-function wl-address-header-extract-address "ext:wl-address")
 191 (declare-function wl-address-header-extract-realname "ext:wl-address")
 192 (declare-function erc-buffer-list "ext:erc")
 193 (declare-function erc-get-channel-user-list "ext:erc")
 194 (declare-function google-maps-static-show "ext:google-maps-static")
 195 (declare-function elmo-message-field "ext:elmo-pipe")
 196 (declare-function std11-narrow-to-header "ext:std11")
 197 (declare-function std11-fetch-field "ext:std11")
 198
 199 (defconst org-contacts-property-values-separators "[,; \f\t\n\r\v]+"
 200   "The default value of separators for `org-contacts-split-property'.
 201
 202 A regexp matching strings of whitespace, `,' and `;'.")
 203
 204 (defvar org-contacts-keymap
 205   (let ((map (make-sparse-keymap)))
 206     (define-key map "M" #'org-contacts-view-send-email)
 207     (define-key map "i" #'org-contacts-view-switch-to-irc-buffer)
 208     map)
 209   "The keymap used in `org-contacts' result list.")
 210
 211 (defvar org-contacts-db nil
 212   "Org Contacts database.")
 213
 214 (defvar org-contacts-last-update nil
 215   "Last time the Org Contacts database has been updated.")
 216
 217 (defun org-contacts-files ()
 218   "Return list of Org files to use for contact management."
 219   (or org-contacts-files (org-agenda-files t 'ifmode)))
 220
 221 (defun org-contacts-db-need-update-p ()
 222   "Determine whether `org-contacts-db' needs to be refreshed."
 223   (or (null org-contacts-last-update)
 224       (cl-find-if (lambda (file)
 225                     (or (time-less-p org-contacts-last-update
 226                                      (elt (file-attributes file) 5))))
 227                   (org-contacts-files))
 228       (org-contacts-db-has-dead-markers-p org-contacts-db)))
 229
 230 (defun org-contacts-db-has-dead-markers-p (db)
 231   "Return t if at least one dead marker is found in DB.
 232 A dead marker in this case is a marker pointing to dead or no
 233 buffer."
 234   ;; Scan contacts list looking for dead markers, and return t at first found.
 235   (catch 'dead-marker-found
 236     (while db
 237       (unless (marker-buffer (nth 1 (car db)))
 238         (throw 'dead-marker-found t))
 239       (setq db (cdr db)))
 240     nil))
 241
 242 (defun org-contacts-db ()
 243   "Return the latest Org Contacts Database."
 244   (let* ((org--matcher-tags-todo-only nil)
 245          (contacts-matcher (cdr (org-make-tags-matcher org-contacts-matcher)))
 246          result)
 247     (when (org-contacts-db-need-update-p)
 248       (let ((progress-reporter
 249              (make-progress-reporter "Updating Org Contacts Database..." 0 (length org-contacts-files)))
 250             (i 0))
 251         (dolist (file (org-contacts-files))
 252           (if (catch 'nextfile
 253                 ;; if file doesn't exist and the user agrees to removing it
 254                 ;; from org-agendas-list, 'nextfile is thrown.  Catch it here
 255                 ;; and skip processing the file.
 256                 ;;
 257                 ;; TODO: suppose that the user has set an org-contacts-files
 258                 ;; list that contains an element that doesn't exist in the
 259                 ;; file system: in that case, the org-agenda-files list could
 260                 ;; be updated (and saved to the customizations of the user) if
 261                 ;; it contained the same file even though the org-agenda-files
 262                 ;; list wasn't actually used.  I don't think it is normal that
 263                 ;; org-contacts updates org-agenda-files in this case, but
 264                 ;; short of duplicating org-check-agenda-files and
 265                 ;; org-remove-files, I don't know how to avoid it.
 266                 ;;
 267                 ;; A side effect of the TODO is that the faulty
 268                 ;; org-contacts-files list never gets updated and thus the
 269                 ;; user is always queried about the missing files when
 270                 ;; org-contacts-db-need-update-p returns true.
 271                 (org-check-agenda-file file))
 272               (message "Skipped %s removed from org-agenda-files list."
 273                        (abbreviate-file-name file))
 274             (with-current-buffer (org-get-agenda-file-buffer file)
 275               (unless (eq major-mode 'org-mode)
 276                 (error "File %s is not in `org-mode'" file))
 277               (setf result
 278                     (append result
 279                             (org-scan-tags 'org-contacts-at-point
 280                                            contacts-matcher
 281                                            org--matcher-tags-todo-only)))))
 282           (progress-reporter-update progress-reporter (setq i (1+ i))))
 283         (setf org-contacts-db result
 284               org-contacts-last-update (current-time))
 285         (progress-reporter-done progress-reporter)))
 286     org-contacts-db))
 287
 288 (defun org-contacts-at-point (&optional pom)
 289   "Return the contacts at point-or-marker POM or current position
 290 if nil."
 291   (setq pom (or pom (point)))
 292   (org-with-point-at pom
 293     (list (org-get-heading t) (set-marker (make-marker) pom) (org-entry-properties pom 'all))))
 294
 295 (defun org-contacts-filter (&optional name-match tags-match prop-match)
 296   "Search for a contact matching any of NAME-MATCH, TAGS-MATCH, PROP-MATCH.
 297 If all match values are nil, return all contacts.
 298
 299 The optional PROP-MATCH argument is a single (PROP . VALUE) cons
 300 cell corresponding to the contact properties.
 301 "
 302   (if (and (null name-match)
 303            (null prop-match)
 304            (null tags-match))
 305       (org-contacts-db)
 306     (cl-loop for contact in (org-contacts-db)
 307              if (or
 308                  (and name-match
 309                       (string-match-p name-match
 310                                       (cl-first contact)))
 311                  (and prop-match
 312                       (cl-find-if (lambda (prop)
 313                                     (and (string= (car prop-match) (car prop))
 314                                          (string-match-p (cdr prop-match) (cdr prop))))
 315                                   (caddr contact)))
 316                  (and tags-match
 317                       (cl-find-if (lambda (tag)
 318                                     (string-match-p tags-match tag))
 319                                   (org-split-string
 320                                    (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))
 321              collect contact)))
 322
 323 (defun org-contacts-try-completion-prefix (to-match collection &optional predicate)
 324   "Custom implementation of `try-completion'.
 325 This version works only with list and alist and it looks at all
 326 prefixes rather than just the beginning of the string."
 327   (cl-loop with regexp = (concat "\\b" (regexp-quote to-match))
 328            with ret = nil
 329            with ret-start = nil
 330            with ret-end = nil
 331
 332            for el in collection
 333            for string = (if (listp el) (car el) el)
 334
 335            for start = (when (or (null predicate) (funcall predicate string))
 336                          (string-match regexp string))
 337
 338            if start
 339            do (let ((end (match-end 0))
 340                     (len (length string)))
 341                 (if (= end len)
 342                     (cl-return t)
 343                   (cl-destructuring-bind (string start end)
 344                       (if (null ret)
 345                           (cl-values string start end)
 346                         (org-contacts-common-substring
 347                          ret ret-start ret-end
 348                          string start end))
 349                     (setf ret string
 350                           ret-start start
 351                           ret-end end))))
 352
 353            finally (cl-return
 354                     (replace-regexp-in-string "\\`[ \t\n]*" "" ret))))
 355
 356 (defun org-contacts-compare-strings (s1 start1 end1 s2 start2 end2 &optional ignore-case)
 357   "Compare the contents of two strings, using `compare-strings'.
 358
 359 This function works like `compare-strings' excepted that it
 360 returns a cons.
 361 - The CAR is the number of characters that match at the beginning.
 362 - The CDR is T is the two strings are the same and NIL otherwise."
 363   (let ((ret (compare-strings s1 start1 end1 s2 start2 end2 ignore-case)))
 364     (if (eq ret t)
 365         (cons (or end1 (length s1)) t)
 366       (cons (1- (abs ret)) nil))))
 367
 368 (defun org-contacts-common-substring (s1 start1 end1 s2 start2 end2)
 369   "Extract the common substring between S1 and S2.
 370
 371 This function extracts the common substring between S1 and S2 and
 372 adjust the part that remains common.
 373
 374 START1 and END1 delimit the part in S1 that we know is common
 375 between the two strings. This applies to START2 and END2 for S2.
 376
 377 This function returns a list whose contains:
 378 - The common substring found.
 379 - The new value of the start of the known inner substring.
 380 - The new value of the end of the known inner substring."
 381   ;; Given two strings:
 382   ;; s1: "foo bar baz"
 383   ;; s2: "fooo bar baz"
 384   ;; and the inner substring is "bar"
 385   ;; then: start1 = 4, end1 = 6, start2 = 5, end2 = 7
 386   ;;
 387   ;; To find the common substring we will compare two substrings:
 388   ;; " oof" and " ooof" to find the beginning of the common substring.
 389   ;; " baz" and " baz" to find the end of the common substring.
 390   (let* ((len1 (length s1))
 391          (start1 (or start1 0))
 392          (end1 (or end1 len1))
 393
 394          (len2 (length s2))
 395          (start2 (or start2 0))
 396          (end2 (or end2 len2))
 397
 398          (new-start (car (org-contacts-compare-strings
 399                           (substring (org-reverse-string s1) (- len1 start1)) nil nil
 400                           (substring (org-reverse-string s2) (- len2 start2)) nil nil)))
 401
 402          (new-end (+ end1 (car (org-contacts-compare-strings
 403                                 (substring s1 end1) nil nil
 404                                 (substring s2 end2) nil nil)))))
 405     (list (substring s1 (- start1 new-start) new-end)
 406           new-start
 407           (+ new-start (- end1 start1)))))
 408
 409 (defun org-contacts-all-completions-prefix (to-match collection &optional predicate)
 410   "Custom version of `all-completions'.
 411 This version works only with list and alist and it looks at all
 412 prefixes rather than just the beginning of the string."
 413   (cl-loop with regexp = (concat "\\b" (regexp-quote to-match))
 414            for el in collection
 415            for string = (if (listp el) (car el) el)
 416            for match? = (when (and (or (null predicate) (funcall predicate string)))
 417                           (string-match regexp string))
 418            if match?
 419            collect (progn
 420                      (let ((end (match-end 0)))
 421                        (org-no-properties string)
 422                        (when (< end (length string))
 423                          ;; Here we add a text property that will be used
 424                          ;; later to highlight the character right after
 425                          ;; the common part between each addresses.
 426                          ;; See `org-contacts-display-sort-function'.
 427                          (put-text-property end (1+ end) 'org-contacts-prefix 't string)))
 428                      string)))
 429
 430 (defun org-contacts-make-collection-prefix (collection)
 431   "Make a collection function from COLLECTION which will match on prefixes."
 432   (let ((collection collection))
 433     (lambda (string predicate flag)
 434       (cond ((eq flag nil)
 435              (org-contacts-try-completion-prefix string collection predicate))
 436             ((eq flag t)
 437              ;; `org-contacts-all-completions-prefix' has already been
 438              ;; used to compute `all-completions'.
 439              collection)
 440             ((eq flag 'lambda)
 441              (org-contacts-test-completion-prefix string collection predicate))
 442             ((and (listp flag) (eq (car flag) 'boundaries))
 443              (org-contacts-boundaries-prefix string collection predicate (cdr flag)))
 444             ((eq flag 'metadata)
 445              (org-contacts-metadata-prefix))
 446             (t nil          ; operation unsupported
 447                )))))
 448
 449 (defun org-contacts-display-sort-function (completions)
 450   "Sort function for contacts display."
 451   (mapcar (lambda (string)
 452             (cl-loop with len = (1- (length string))
 453                      for i upfrom 0 to len
 454                      if (memq 'org-contacts-prefix
 455                               (text-properties-at i string))
 456                      do (set-text-properties
 457                          i (1+ i)
 458                          (list 'font-lock-face
 459                                (if (char-equal (aref string i)
 460                                                (string-to-char " "))
 461                                    ;; Spaces can't be bold.
 462                                    'underline
 463                                  'bold)) string)
 464                      else
 465                      do (set-text-properties i (1+ i) nil string)
 466                      finally (cl-return string)))
 467           completions))
 468
 469 (defun org-contacts-test-completion-prefix (string collection predicate)
 470   (cl-find-if (lambda (el)
 471                 (and (or (null predicate) (funcall predicate el))
 472                      (string= string el)))
 473               collection))
 474
 475 (defun org-contacts-boundaries-prefix (string collection predicate suffix)
 476   (cl-list* 'boundaries (completion-boundaries string collection predicate suffix)))
 477
 478 (defun org-contacts-metadata-prefix (&rest _)
 479   '(metadata .
 480              ((cycle-sort-function . org-contacts-display-sort-function)
 481               (display-sort-function . org-contacts-display-sort-function))))
 482
 483 (defun org-contacts-complete-group (string)
 484   "Complete text at START from a group.
 485
 486 A group FOO is composed of contacts with the tag FOO."
 487   (let* ((completion-ignore-case org-contacts-completion-ignore-case)
 488          (group-completion-p (string-match-p
 489                               (concat "^" org-contacts-group-prefix) string)))
 490     (when group-completion-p
 491       (let ((completion-list
 492              (all-completions
 493               string
 494               (mapcar (lambda (group)
 495                         (propertize (concat org-contacts-group-prefix group)
 496                                     'org-contacts-group group))
 497                       (org-uniquify
 498                        (cl-loop for contact in (org-contacts-filter)
 499                                 nconc (org-split-string
 500                                        (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":")))))))
 501
 502         (if (= (length completion-list) 1)
 503             ;; We've found the correct group, returns the address
 504             (let ((tag (get-text-property 0 'org-contacts-group
 505                                           (car completion-list))))
 506               (mapconcat #'identity
 507                          (cl-loop for contact in (org-contacts-filter
 508                                                   nil
 509                                                   tag)
 510                                   ;; The contact name is always the car of the assoc-list
 511                                   ;; returned by `org-contacts-filter'.
 512                                   for contact-name = (car contact)
 513                                   ;; Grab the first email of the contact
 514                                   for email = (org-contacts-strip-link
 515                                                (or (car (org-contacts-split-property
 516                                                          (or
 517                                                           (cdr (assoc-string org-contacts-email-property
 518                                                                              (cl-caddr contact)))
 519                                                           ""))) ""))
 520                                   ;; If the user has an email address, append USER <EMAIL>.
 521                                   if email collect (org-contacts-format-email contact-name email))
 522                          ", "))
 523           ;; We haven't found the correct group
 524           (completion-table-case-fold completion-list
 525                                       (not org-contacts-completion-ignore-case)))))))
 526
 527 (defun org-contacts-complete-tags-props (string)
 528   "Insert emails that match the tags expression.
 529
 530 For example: FOO-BAR will match entries tagged with FOO but not
 531 with BAR.
 532
 533 See (org) Matching tags and properties for a complete
 534 description."
 535   (let* ((completion-ignore-case org-contacts-completion-ignore-case)
 536          (completion-p (string-match-p
 537                         (concat "^" org-contacts-tags-props-prefix) string)))
 538     (when completion-p
 539       (let ((result
 540              (mapconcat
 541               #'identity
 542               (cl-loop for contact in (org-contacts-db)
 543                        for contact-name = (car contact)
 544                        for email = (org-contacts-strip-link
 545                                     (or (car (org-contacts-split-property
 546                                               (or
 547                                                (cdr (assoc-string org-contacts-email-property
 548                                                                   (cl-caddr contact)))
 549                                                "")))
 550                                         ""))
 551                        ;; for tags = (cdr (assoc "TAGS" (nth 2 contact)))
 552                        ;; for tags-list = (if tags
 553                        ;;      (split-string (substring (cdr (assoc "TAGS" (nth 2 contact))) 1 -1) ":")
 554                        ;;    '())
 555                        for marker = (nth 1 contact)
 556                        if (with-current-buffer (marker-buffer marker)
 557                             (save-excursion
 558                               (goto-char marker)
 559                               ;; FIXME: AFAIK, `org-make-tags-matcher' returns
 560                               ;; a cons whose cdr is a function, so why do we
 561                               ;; pass it to `eval' rather than to (say)
 562                               ;; `funcall'?
 563                               (eval (cdr (org-make-tags-matcher (cl-subseq string 1))))))
 564                        collect (org-contacts-format-email contact-name email))
 565               ",")))
 566         (when (not (string= "" result))
 567           result)))))
 568
 569 (defun org-contacts-remove-ignored-property-values (ignore-list list)
 570   "Remove all ignore-list's elements from list and you can use
 571    regular expressions in the ignore list."
 572   (cl-remove-if (lambda (el)
 573                   (cl-find-if (lambda (x)
 574                                 (string-match-p x el))
 575                               ignore-list))
 576                 list))
 577
 578 (defun org-contacts-complete-name (string)
 579   "Complete text at START with a user name and email."
 580   (let* ((completion-ignore-case org-contacts-completion-ignore-case)
 581          (completion-list
 582           (cl-loop for contact in (org-contacts-filter)
 583                    ;; The contact name is always the car of the assoc-list
 584                    ;; returned by `org-contacts-filter'.
 585                    for contact-name = (car contact)
 586
 587                    ;; Build the list of the email addresses which has
 588                    ;; been expired
 589                    for ignore-list = (org-contacts-split-property
 590                                       (or (cdr (assoc-string org-contacts-ignore-property
 591                                                              (nth 2 contact))) ""))
 592                    ;; Build the list of the user email addresses.
 593                    for email-list = (org-contacts-remove-ignored-property-values
 594                                      ignore-list
 595                                      (org-contacts-split-property
 596                                       (or (cdr (assoc-string org-contacts-email-property
 597                                                              (nth 2 contact))) "")))
 598                    ;; If the user has email addresses…
 599                    if email-list
 600                    ;; … append a list of USER <EMAIL>.
 601                    nconc (cl-loop for email in email-list
 602                                   collect (org-contacts-format-email
 603                                            contact-name (org-contacts-strip-link email)))))
 604          (completion-list (org-contacts-all-completions-prefix
 605                            string
 606                            (org-uniquify completion-list))))
 607     (when completion-list
 608       (org-contacts-make-collection-prefix completion-list))))
 609
 610 (defun org-contacts-message-complete-function ()
 611   "Function used in `completion-at-point-functions' in `message-mode'."
 612   (let ((mail-abbrev-mode-regexp
 613          "^\\(Resent-To\\|To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\|Disposition-Notification-To\\|Return-Receipt-To\\):"))
 614     (when (mail-abbrev-in-expansion-header-p)
 615       (let
 616           ((beg
 617             (save-excursion
 618               (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
 619               (goto-char (match-end 0))
 620               (point)))
 621            (end (point)))
 622         (list beg
 623               end
 624               (completion-table-dynamic
 625                (lambda (string)
 626                  (run-hook-with-args-until-success
 627                   'org-contacts-complete-functions string))))))))
 628
 629 (defun org-contacts-org-complete--annotation-function (candidate)
 630   "Return org-contacts tags of contact candidate."
 631   ;; TODO
 632   "Tags: ")
 633
 634 (defun org-contacts-org-complete--doc-function (candidate)
 635   "Return org-contacts content of contact candidate."
 636   (let* ((candidate (substring-no-properties candidate 1 nil))
 637          (contact (seq-find
 638                    (lambda (contact) (string-equal (plist-get contact :name) candidate))
 639                    (org-contacts--all-contacts)))
 640          (name (plist-get contact :name))
 641          (file (plist-get contact :file))
 642          (position (plist-get contact :position)))
 643     (company-doc-buffer
 644      ;; get org-contact headline and property drawer.
 645      (with-current-buffer (find-file-noselect file)
 646        (goto-char position)
 647        (when (derived-mode-p 'org-mode)
 648          ;; `org-edit-src-code' is not a real narrowing command.
 649          ;; Remove this first conditional if you don't want it.
 650          (cond ((ignore-errors (org-edit-src-code))
 651                 (delete-other-windows))
 652                ((org-at-block-p)
 653                 (org-narrow-to-block))
 654                (t (org-narrow-to-subtree)))
 655          (buffer-substring (point-min) (point-max)))))))
 656
 657 (defun org-contacts-org-complete--location-function (candidate)
 658   "Return org-contacts location of contact candidate."
 659   (let ((name (plist-get candidate :name))
 660         (file (plist-get candidate :file))
 661         (position (plist-get candidate :position)))
 662     (with-current-buffer (find-file-noselect file)
 663       (goto-char position)
 664       (cons (current-buffer) position))))
 665
 666 (defun org-contacts-org-complete-function ()
 667   "Function used in `completion-at-point-functions' in `org-mode' to complete @name.
 668 Usage: (add-hook 'completion-at-point-functions 'org-contacts-org-complete-function nil 'local)"
 669   (when-let* ((end (point))
 670               (begin (save-excursion (skip-chars-backward "[:alnum:]@") (point)))
 671               (symbol (buffer-substring-no-properties begin end))
 672               (org-contacts-prefix-p (string-prefix-p "@" symbol)))
 673     (when org-contacts-prefix-p
 674       (list begin
 675             end
 676             (completion-table-dynamic
 677              (lambda (_)
 678                (mapcar
 679                 (lambda (contact) (concat "@" (plist-get contact :name)))
 680                 (org-contacts--all-contacts))))
 681
 682             :predicate 'stringp
 683             :exclusive 'no
 684             ;; properties check out `completion-extra-properties'
 685             :annotation-function #'org-contacts-org-complete--annotation-function
 686             ;; :exit-function ; TODO change completion candidate inserted contact name into org-contact link??
 687
 688             :company-docsig #'identity                                    ; metadata
 689             :company-doc-buffer #'org-contacts-org-complete--doc-function ; doc popup
 690             :company-location #'org-contacts-org-complete--location-function))))
 691
 692 (defun org-contacts-gnus-get-name-email ()
 693   "Get name and email address from Gnus message."
 694   (if (gnus-alive-p)
 695       (gnus-with-article-headers
 696         (mail-extract-address-components
 697          (or (mail-fetch-field "From") "")))))
 698
 699 (defun org-contacts-gnus-article-from-get-marker ()
 700   "Return a marker for a contact based on From."
 701   (let* ((address (org-contacts-gnus-get-name-email))
 702          (name (car address))
 703          (email (cadr address)))
 704     (cl-cadar (or (org-contacts-filter
 705                    nil
 706                    nil
 707                    (cons org-contacts-email-property (concat "\\b" (regexp-quote email) "\\b")))
 708                   (when name
 709                     (org-contacts-filter
 710                      (concat "^" name "$")))))))
 711
 712 (defun org-contacts-gnus-article-from-goto ()
 713   "Go to contact in the From address of current Gnus message."
 714   (interactive)
 715   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 716     (when marker
 717       (switch-to-buffer-other-window (marker-buffer marker))
 718       (goto-char marker)
 719       (when (eq major-mode 'org-mode) (org-show-context 'agenda)))))
 720
 721 (with-no-warnings (defvar date)) ;; unprefixed, from calendar.el
 722 (defun org-contacts-anniversaries (&optional field format)
 723   "Compute FIELD anniversary for each contact, returning FORMAT.
 724 Default FIELD value is \"BIRTHDAY\".
 725
 726 Format is a string matching the following format specification:
 727
 728   %h - Heading name
 729   %l - Link to the heading
 730   %y - Number of year
 731   %Y - Number of year (ordinal)"
 732   (let ((calendar-date-style 'american)
 733         ) ;; (entry "")
 734     (unless format (setq format org-contacts-birthday-format))
 735     (cl-loop for contact in (org-contacts-filter)
 736              for anniv = (let ((anniv (cdr (assoc-string
 737                                             (or field org-contacts-birthday-property)
 738                                             (nth 2 contact)))))
 739                            (when anniv
 740                              (calendar-gregorian-from-absolute
 741                               (org-time-string-to-absolute anniv))))
 742              ;; Use `diary-anniversary' to compute anniversary.
 743              ;; FIXME: should we require `diary-lib' somewhere to be sure
 744              ;; `diary-anniversary' is defined when we get here?
 745              if (and anniv (apply #'diary-anniversary anniv))
 746              collect (format-spec format
 747                                   `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
 748                                     (?h . ,(car contact))
 749                                     (?y . ,(- (calendar-extract-year date)
 750                                               (calendar-extract-year anniv)))
 751                                     (?Y . ,(let ((years (- (calendar-extract-year date)
 752                                                            (calendar-extract-year anniv))))
 753                                              (format "%d%s" years (diary-ordinal-suffix years)))))))))
 754
 755 (defun org-completing-read-date ( prompt _collection
 756                                   &optional _predicate _require-match _initial-input
 757                                   _hist def _inherit-input-method)
 758   "Like `completing-read' but reads a date.
 759 Only PROMPT and DEF are really used."
 760   (org-read-date nil nil nil prompt nil def))
 761
 762 (add-to-list 'org-property-set-functions-alist
 763              `(,org-contacts-birthday-property . org-completing-read-date))
 764
 765 (defun org-contacts-template-name (&optional return-value)
 766   "Try to return the contact name for a template.
 767 If not found return RETURN-VALUE or something that would ask the user."
 768   (or (car (org-contacts-gnus-get-name-email))
 769       return-value
 770       "%^{Name}"))
 771
 772 (defun org-contacts-template-email (&optional return-value)
 773   "Try to return the contact email for a template.
 774 If not found return RETURN-VALUE or something that would ask the user."
 775   (or (cadr (org-contacts-gnus-get-name-email))
 776       return-value
 777       (concat "%^{" org-contacts-email-property "}p")))
 778
 779 (defun org-contacts-gnus-store-last-mail ()
 780   "Store a link between mails and contacts.
 781
 782 This function should be called from `gnus-article-prepare-hook'."
 783   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 784     (when marker
 785       (with-current-buffer (marker-buffer marker)
 786         (save-excursion
 787           (goto-char marker)
 788           (let* ((org-link-email-description-format (or org-contacts-email-link-description-format
 789                                                         org-link-email-description-format))
 790                  (link (gnus-with-article-buffer (org-store-link nil))))
 791             (org-set-property org-contacts-last-read-mail-property link)))))))
 792
 793 (defun org-contacts-icon-as-string ()
 794   "Return the contact icon as a string."
 795   (let ((image (org-contacts-get-icon)))
 796     (concat
 797      (propertize "-" 'display
 798                  (append
 799                   (if image
 800                       image
 801                     `'(space :width (,org-contacts-icon-size)))
 802                   '(:ascent center)))
 803      " ")))
 804
 805 ;;;###autoload
 806 (defun org-contacts (name)
 807   "Create agenda view for contacts matching NAME."
 808   (interactive (list (read-string "Name: ")))
 809   (let ((org-agenda-files (org-contacts-files))
 810         (org-agenda-skip-function
 811          (lambda () (org-agenda-skip-if nil `(notregexp ,name))))
 812         (org-agenda-prefix-format
 813          (propertize
 814           "%(org-contacts-icon-as-string)% s%(org-contacts-irc-number-of-unread-messages) "
 815           'keymap org-contacts-keymap))
 816         (org-agenda-overriding-header
 817          (or org-agenda-overriding-header
 818              (concat "List of contacts matching `" name "':"))))
 819     (setq org-agenda-skip-regexp name)
 820     (org-tags-view nil org-contacts-matcher)
 821     (with-current-buffer org-agenda-buffer-name
 822       (setq org-agenda-redo-command
 823             (list 'org-contacts name)))))
 824
 825 (defun org-contacts-completing-read (prompt
 826                                      &optional predicate
 827                                      initial-input hist def inherit-input-method)
 828   "Call `completing-read' with contacts name as collection."
 829   (org-completing-read
 830    prompt (org-contacts-filter) predicate t initial-input hist def inherit-input-method))
 831
 832 (defun org-contacts-format-name (name)
 833   "Trim any local formatting to get a bare NAME."
 834   ;; Remove radio targets characters
 835   (replace-regexp-in-string org-radio-target-regexp "\\1" name))
 836
 837 (defun org-contacts-format-email (name email)
 838   "Format an EMAIL address corresponding to NAME."
 839   (unless email
 840     (error "`email' cannot be nul"))
 841   (if name
 842       (concat (org-contacts-format-name name) " <" email ">")
 843     email))
 844
 845 (defun org-contacts-check-mail-address (mail)
 846   "Add MAIL address to contact at point if it does not have it."
 847   (let ((mails (org-entry-get (point) org-contacts-email-property)))
 848     (unless (member mail (split-string mails))
 849       (when (yes-or-no-p
 850              (format "Do you want to add this address to %s?" (org-get-heading t)))
 851         (org-set-property org-contacts-email-property (concat mails " " mail))))))
 852
 853 (defun org-contacts-gnus-check-mail-address ()
 854   "Check that contact has the current address recorded.
 855 This function should be called from `gnus-article-prepare-hook'."
 856   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 857     (when marker
 858       (org-with-point-at marker
 859         (org-contacts-check-mail-address (cadr (org-contacts-gnus-get-name-email)))))))
 860
 861 (defun org-contacts-gnus-insinuate ()
 862   "Add some hooks for Gnus user.
 863 This adds `org-contacts-gnus-check-mail-address' and
 864 `org-contacts-gnus-store-last-mail' to
 865 `gnus-article-prepare-hook'.  It also adds a binding on `;' in
 866 `gnus-summary-mode-map' to `org-contacts-gnus-article-from-goto'"
 867   (require 'gnus)
 868   (require 'gnus-art)
 869   (define-key gnus-summary-mode-map ";" #'org-contacts-gnus-article-from-goto)
 870   (add-hook 'gnus-article-prepare-hook #'org-contacts-gnus-check-mail-address)
 871   (add-hook 'gnus-article-prepare-hook #'org-contacts-gnus-store-last-mail))
 872
 873 (defun org-contacts-setup-completion-at-point ()
 874   "Add `org-contacts-message-complete-function' as a new function
 875 to complete the thing at point."
 876   (add-to-list 'completion-at-point-functions
 877                'org-contacts-message-complete-function))
 878
 879 (defun org-contacts-unload-hook ()
 880   (remove-hook 'message-mode-hook #'org-contacts-setup-completion-at-point))
 881
 882 (when (and org-contacts-enable-completion
 883            (boundp 'completion-at-point-functions))
 884   (add-hook 'message-mode-hook #'org-contacts-setup-completion-at-point))
 885
 886 (defun org-contacts-wl-get-from-header-content ()
 887   "Retrieve the content of the `From' header of an email.
 888 Works from wl-summary-mode and mime-view-mode - that is while viewing email.
 889 Depends on Wanderlust been loaded."
 890   (with-current-buffer (org-capture-get :original-buffer)
 891     (cond
 892      ((eq major-mode 'wl-summary-mode) (when (and (boundp 'wl-summary-buffer-elmo-folder)
 893                                                   wl-summary-buffer-elmo-folder)
 894                                          (elmo-message-field
 895                                           wl-summary-buffer-elmo-folder
 896                                           (wl-summary-message-number)
 897                                           'from)))
 898      ((eq major-mode 'mime-view-mode) (std11-narrow-to-header)
 899       (prog1
 900           (std11-fetch-field "From")
 901         (widen))))))
 902
 903 (defun org-contacts-wl-get-name-email ()
 904   "Get name and email address from Wanderlust email.
 905 See `org-contacts-wl-get-from-header-content' for limitations."
 906   (let ((from (org-contacts-wl-get-from-header-content)))
 907     (when from
 908       (list (wl-address-header-extract-realname from)
 909             (wl-address-header-extract-address from)))))
 910
 911 (defun org-contacts-template-wl-name (&optional return-value)
 912   "Try to return the contact name for a template from wl.
 913 If not found, return RETURN-VALUE or something that would ask the
 914 user."
 915   (or (car (org-contacts-wl-get-name-email))
 916       return-value
 917       "%^{Name}"))
 918
 919 (defun org-contacts-template-wl-email (&optional return-value)
 920   "Try to return the contact email for a template from Wanderlust.
 921 If not found return RETURN-VALUE or something that would ask the user."
 922   (or (cadr (org-contacts-wl-get-name-email))
 923       return-value
 924       (concat "%^{" org-contacts-email-property "}p")))
 925
 926 (defun org-contacts-view-send-email (&optional ask)
 927   "Send email to the contact at point.
 928 If ASK is set, ask for the email address even if there's only one
 929 address."
 930   (interactive "P")
 931   (let ((marker (org-get-at-bol 'org-hd-marker)))
 932     (org-with-point-at marker
 933       (let ((emails (org-entry-get (point) org-contacts-email-property)))
 934         (if emails
 935             (let ((email-list (org-contacts-split-property emails)))
 936               (if (and (= (length email-list) 1) (not ask))
 937                   (compose-mail (org-contacts-format-email
 938                                  (org-get-heading t) emails))
 939                 (let ((email (completing-read "Send mail to which address: " email-list)))
 940                   (setq email (org-contacts-strip-link email))
 941                   (org-contacts-check-mail-address email)
 942                   (compose-mail (org-contacts-format-email (org-get-heading t) email)))))
 943           (error (format "This contact has no mail address set (no %s property)"
 944                          org-contacts-email-property)))))))
 945
 946 (defun org-contacts-get-icon (&optional pom)
 947   "Get icon for contact at POM."
 948   (setq pom (or pom (point)))
 949   (catch 'icon
 950     ;; Use `org-contacts-icon-property'
 951     (let* ((link-matcher-regexp
 952             "\\[\\[\\([^]]*\\)\\]\\(\\[\\(.*\\)\\]\\)?\\]")
 953            (contacts-dir (file-name-directory (car org-contacts-files)))
 954            (image-path
 955             (if-let ((avatar (org-entry-get pom org-contacts-icon-property)))
 956                 (cond
 957                  ;; [[file:dir/filename.png]]
 958                  ((string-match-p "\\[\\[.*\\]\\]" avatar)
 959                   ;; FIXME: What if avatar matches the above regexp but the
 960                   ;; one below?
 961                   (when (string-match link-matcher-regexp avatar)
 962                     ;; FIXME: 5 seems to be the length of `file:' but I can't
 963                     ;; see anything that guarantees that the submatch 1 starts
 964                     ;; with `file:'.
 965                     (expand-file-name (substring (match-string-no-properties 1 avatar) 5 nil)
 966                                       contacts-dir)))
 967                  ;; "" (empty string)
 968                  ((string-empty-p avatar) nil)
 969                  (t (expand-file-name avatar contacts-dir))))))
 970       (when image-path
 971         (throw 'icon
 972                (if (featurep 'imagemagick)
 973                    (create-image image-path 'imagemagick nil
 974                                  :height org-contacts-icon-size)
 975                  (create-image image-path nil nil
 976                                :height org-contacts-icon-size)))))
 977     ;; Next, try Gravatar
 978     (when org-contacts-icon-use-gravatar
 979       (defvar gravatar-size)
 980       (let* ((gravatar-size org-contacts-icon-size)
 981              (email-list (org-entry-get pom org-contacts-email-property))
 982              (gravatar
 983               (when email-list
 984                 (cl-loop for email in (org-contacts-split-property email-list)
 985                          for gravatar = (gravatar-retrieve-synchronously (org-contacts-strip-link email))
 986                          if (and gravatar
 987                                  (not (eq gravatar 'error)))
 988                          return gravatar))))
 989         (when gravatar (throw 'icon gravatar))))))
 990
 991 (defun org-contacts-irc-buffer (&optional pom)
 992   "Get the IRC buffer associated with the entry at POM."
 993   (setq pom (or pom (point)))
 994   (let ((nick (org-entry-get pom org-contacts-nickname-property)))
 995     (when nick
 996       (let ((buffer (get-buffer nick)))
 997         (when buffer
 998           (with-current-buffer buffer
 999             (when (eq major-mode 'erc-mode)
1000               buffer)))))))
1001
1002 (defun org-contacts-irc-number-of-unread-messages (&optional pom)
1003   "Return the number of unread messages for contact at POM."
1004   (when (boundp 'erc-modified-channels-alist)
1005     (let ((number (cadr (assoc (org-contacts-irc-buffer pom) erc-modified-channels-alist))))
1006       (if number
1007           (format (concat "%3d unread message" (if (> number 1) "s" " ") " ") number)
1008         (make-string 21 ? )))))
1009
1010 (defun org-contacts-view-switch-to-irc-buffer ()
1011   "Switch to the IRC buffer of the current contact if it has one."
1012   (interactive)
1013   (let ((marker (org-get-at-bol 'org-hd-marker)))
1014     (org-with-point-at marker
1015       (switch-to-buffer-other-window (org-contacts-irc-buffer)))))
1016
1017 (defun org-contacts-completing-read-nickname (prompt collection
1018                                                      &optional predicate require-match initial-input
1019                                                      hist def inherit-input-method)
1020   "Like `completing-read' but reads a nickname."
1021   (org-completing-read prompt (append collection (erc-nicknames-list)) predicate require-match
1022                        initial-input hist def inherit-input-method))
1023
1024 (defun erc-nicknames-list ()
1025   "Return all nicknames of all ERC buffers."
1026   (cl-loop for buffer in (erc-buffer-list)
1027            nconc (with-current-buffer buffer
1028                    (cl-loop for user-entry
1029                             in (mapcar #'car (erc-get-channel-user-list))
1030                             collect (elt user-entry 1)))))
1031
1032 (add-to-list 'org-property-set-functions-alist
1033              `(,org-contacts-nickname-property . org-contacts-completing-read-nickname))
1034
1035 (defun org-contacts-vcard-escape (str)
1036   "Escape ; , and \n in STR for the VCard format."
1037   ;; Thanks to this library for the regexp:
1038   ;; https://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el
1039   (when str
1040     (replace-regexp-in-string
1041      "\n" "\\\\n"
1042      (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" str))))
1043
1044 (defun org-contacts-vcard-encode-name (name)
1045   "Try to encode NAME as VCard's N property.
1046 The N property expects
1047
1048   FamilyName;GivenName;AdditionalNames;Prefix;Postfix.
1049
1050 Org-contacts does not specify how to encode the name.  So we try
1051 to do our best."
1052   (concat (replace-regexp-in-string "\\(\\w+\\) \\(.*\\)" "\\2;\\1" name) ";;;"))
1053
1054 (defun org-contacts-vcard-format (contact)
1055   "Formats CONTACT in VCard 3.0 format."
1056   (let* ((properties (nth 2 contact))
1057          (name (org-contacts-vcard-escape (car contact)))
1058          (n (org-contacts-vcard-encode-name name))
1059          (email (cdr (assoc-string org-contacts-email-property properties)))
1060          (tel (cdr (assoc-string org-contacts-tel-property properties)))
1061          (ignore-list (cdr (assoc-string org-contacts-ignore-property properties)))
1062          (ignore-list (when ignore-list
1063                         (org-contacts-split-property ignore-list)))
1064          (note (cdr (assoc-string org-contacts-note-property properties)))
1065          (bday (org-contacts-vcard-escape (cdr (assoc-string org-contacts-birthday-property properties))))
1066          (addr (cdr (assoc-string org-contacts-address-property properties)))
1067          (nick (org-contacts-vcard-escape (cdr (assoc-string org-contacts-nickname-property properties))))
1068          (head (format "BEGIN:VCARD\nVERSION:3.0\nN:%s\nFN:%s\n" n name))
1069          emails-list result phones-list)
1070     (concat
1071      head
1072      (when email
1073        (progn
1074          (setq emails-list (org-contacts-remove-ignored-property-values
1075                             ignore-list (org-contacts-split-property email)))
1076          (setq result "")
1077          (while emails-list
1078            (setq result (concat result  "EMAIL:" (org-contacts-strip-link (car emails-list)) "\n"))
1079            (setq emails-list (cdr emails-list)))
1080          result))
1081      (when addr
1082        (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr)))
1083      (when tel
1084        (progn
1085          (setq phones-list (org-contacts-remove-ignored-property-values
1086                             ignore-list (org-contacts-split-property tel)))
1087          (setq result "")
1088          (while phones-list
1089            (setq result (concat result  "TEL:" (org-contacts-strip-link
1090                                                 (org-link-unescape (car phones-list))) "\n"))
1091            (setq phones-list (cdr phones-list)))
1092          result))
1093      (when bday
1094        (let ((cal-bday (calendar-gregorian-from-absolute (org-time-string-to-absolute bday))))
1095          (format "BDAY:%04d-%02d-%02d\n"
1096                  (calendar-extract-year cal-bday)
1097                  (calendar-extract-month cal-bday)
1098                  (calendar-extract-day cal-bday))))
1099      (when nick (format "NICKNAME:%s\n" nick))
1100      (when note (format "NOTE:%s\n" note))
1101      "END:VCARD\n\n")))
1102
1103 (defun org-contacts-export-as-vcard (&optional name file to-buffer)
1104   "Export org contacts to V-Card 3.0.
1105
1106 By default, all contacts are exported to `org-contacts-vcard-file'.
1107
1108 When NAME is \\[universal-argument], prompts for a contact name.
1109
1110 When NAME is \\[universal-argument] \\[universal-argument],
1111 prompts for a contact name and a file name where to export.
1112
1113 When NAME is \\[universal-argument] \\[universal-argument]
1114 \\[universal-argument], prompts for a contact name and a buffer where to export.
1115
1116 If the function is not called interactively, all parameters are
1117 passed to `org-contacts-export-as-vcard-internal'."
1118   (interactive "P")
1119   (when (called-interactively-p 'any)
1120     (cl-psetf name
1121               (when name
1122                 (read-string "Contact name: "
1123                              (nth 0 (org-contacts-at-point))))
1124               file
1125               (when (equal name '(16))
1126                 (read-file-name "File: " nil org-contacts-vcard-file))
1127               to-buffer
1128               (when (equal name '(64))
1129                 (read-buffer "Buffer: "))))
1130   (org-contacts-export-as-vcard-internal name file to-buffer))
1131
1132 (defun org-contacts-export-as-vcard-internal (&optional name file to-buffer)
1133   "Export all contacts matching NAME as VCard 3.0.
1134 If TO-BUFFER is nil, the content is written to FILE or
1135 `org-contacts-vcard-file'.  If TO-BUFFER is non-nil, the buffer
1136 is created and the VCard is written into that buffer."
1137   (let* ((filename (or file org-contacts-vcard-file))
1138          (buffer (if to-buffer
1139                      (get-buffer-create to-buffer)
1140                    (find-file-noselect filename))))
1141     (message "Exporting...")
1142     (set-buffer buffer)
1143     (let ((inhibit-read-only t)) (erase-buffer))
1144     (fundamental-mode)
1145     (when (fboundp 'set-buffer-file-coding-system)
1146       (set-buffer-file-coding-system coding-system-for-write))
1147     (cl-loop for contact in (org-contacts-filter name)
1148              do (insert (org-contacts-vcard-format contact)))
1149     (if to-buffer
1150         (current-buffer)
1151       (progn (save-buffer) (kill-buffer)))))
1152
1153 (defun org-contacts-show-map (&optional name)
1154   "Show contacts on a map.
1155 Requires google-maps-el."
1156   (interactive)
1157   (unless (fboundp 'google-maps-static-show)
1158     (error "`org-contacts-show-map' requires `google-maps-el'"))
1159   (google-maps-static-show
1160    :markers
1161    (cl-loop
1162     for contact in (org-contacts-filter name)
1163     for addr = (cdr (assoc-string org-contacts-address-property (nth 2 contact)))
1164     if addr
1165     collect (cons (list addr) (list :label (string-to-char (car contact)))))))
1166
1167 (defun org-contacts-strip-link (link)
1168   "Remove brackets, description, link type and colon from an org
1169 link string and return the pure link target."
1170   (let (startpos colonpos endpos)
1171     (setq startpos (string-match (regexp-opt '("[[tel:" "[[mailto:")) link))
1172     (if startpos
1173         (progn
1174           (setq colonpos (string-match ":" link))
1175           (setq endpos (string-match "\\]" link))
1176           (if endpos (substring link (1+ colonpos) endpos) link))
1177       (progn
1178         (setq startpos (string-match "mailto:" link))
1179         (setq colonpos (string-match ":" link))
1180         (if startpos (substring link (1+ colonpos)) link)))))
1181
1182 ;; Add the link type supported by org-contacts-strip-link
1183 ;; so everything is in order for its use in Org files
1184 (org-link-set-parameters "tel")
1185
1186 (defun org-contacts-split-property (string &optional separators omit-nulls)
1187   "Custom version of `split-string'.
1188 Split a property STRING into sub-strings bounded by matches
1189 for SEPARATORS but keep Org links intact.
1190
1191 The beginning and end of STRING, and each match for SEPARATORS, are
1192 splitting points.  The substrings matching SEPARATORS are removed, and
1193 the substrings between the splitting points are collected as a list,
1194 which is returned.
1195
1196 If SEPARATORS is non-nil, it should be a regular expression
1197 matching text which separates, but is not part of, the
1198 substrings.  If nil it defaults to `org-contacts-property-values-separators',
1199 normally \"[,; \f\t\n\r\v]+\", and OMIT-NULLS is forced to t.
1200
1201 If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
1202 that for the default value of SEPARATORS leading and trailing whitespace
1203 are effectively trimmed).  If nil, all zero-length substrings are retained."
1204   (let* ((omit-nulls (if separators omit-nulls t))
1205          (rexp (or separators org-contacts-property-values-separators))
1206          (inputlist (split-string string rexp omit-nulls))
1207          (linkstring "")
1208          (bufferstring "")
1209          (proplist (list "")))
1210     (while inputlist
1211       (setq bufferstring (pop inputlist))
1212       (if (string-match "\\[\\[" bufferstring)
1213           (progn
1214             (setq linkstring (concat bufferstring " "))
1215             (while (not (string-match "\\]\\]" bufferstring))
1216               (setq bufferstring (pop inputlist))
1217               (setq linkstring (concat  linkstring bufferstring " ")))
1218             (setq proplist (cons (org-trim linkstring) proplist)))
1219         (setq proplist (cons bufferstring proplist))))
1220     (cdr (reverse proplist))))
1221
1222 ;;; Add an Org link type `org-contact:' for easy jump to or searching org-contacts headline.
1223 ;;; link spec: [[org-contact:query][desc]]
1224 (org-link-set-parameters "org-contact"
1225                          :follow #'org-contacts-link-open
1226                          :complete #'org-contacts-link-complete
1227                          :store #'org-contacts-link-store
1228                          :face 'org-contacts-link-face)
1229
1230 (defun org-contacts-link-store ()
1231   "Store the contact in `org-contacts-files' with a link."
1232   (when (and (eq major-mode 'org-mode)
1233              (member (buffer-file-name)
1234                      (mapcar #'expand-file-name org-contacts-files)))
1235     (if (bound-and-true-p org-id-link-to-org-use-id)
1236         (org-id-store-link)
1237       (let ((headline-str (substring-no-properties (org-get-heading t t t t))))
1238         (org-link-store-props
1239          :type "org-contact"
1240          :link headline-str
1241          :description headline-str)
1242         (let ((link (concat "org-contact:" headline-str)))
1243           (org-link-add-props :link link :description headline-str)
1244           link)))))
1245
1246 (defun org-contacts--all-contacts ()
1247   "Return a list of all contacts in `org-contacts-files'.
1248 Each element has the form (NAME . (FILE . POSITION))."
1249   (car (mapcar
1250         (lambda (file)
1251           (unless (buffer-live-p (get-buffer (file-name-nondirectory file)))
1252             (find-file file))
1253           (with-current-buffer (get-buffer (file-name-nondirectory file))
1254             (org-map-entries
1255              (lambda ()
1256                (let ((name (substring-no-properties (org-get-heading t t t t)))
1257                      (file (buffer-file-name))
1258                      (position (point)))
1259                  `(:name ,name :file ,file :position ,position))))))
1260         org-contacts-files)))
1261
1262 (defun org-contacts-link-open (path)
1263   "Open contacts: link type with jumping or searching."
1264   (let ((query path))
1265     (cond
1266      ;; /query/ format searching
1267      ((string-match "/.*/" query)
1268       (let* ((f (car org-contacts-files))
1269              (buf (get-buffer (file-name-nondirectory f))))
1270         (unless (buffer-live-p buf) (find-file f))
1271         (with-current-buffer buf
1272           (string-match "/\\(.*\\)/" query)
1273           (occur (match-string 1 query)))))
1274      ;; jump to contact headline directly
1275      (t
1276       (let* ((f (car org-contacts-files))
1277              (buf (get-buffer (file-name-nondirectory f))))
1278         (unless (buffer-live-p buf) (find-file f))
1279         (with-current-buffer buf
1280           (goto-char (marker-position (org-find-exact-headline-in-buffer query))))
1281         (display-buffer buf '(display-buffer-below-selected)))
1282       ;; FIXME
1283       ;; (let* ((contact-entry (plist-get (org-contacts--all-contacts) query))
1284       ;;         (contact-name (plist-get contact-entry :name))
1285       ;;         (file (plist-get contact-entry :file))
1286       ;;         (position (plist-get contact-entry :position))
1287       ;;         (buf (get-buffer (file-name-nondirectory file))))
1288       ;;    (unless (buffer-live-p buf) (find-file file))
1289       ;;    (with-current-buffer buf (goto-char position)))
1290       ))))
1291
1292 (defun org-contacts-link-complete (&optional _arg)
1293   "Create a org-contacts link using completion."
1294   (let ((name (completing-read "org-contact Name: "
1295                                (mapcar
1296                                 (lambda (plist) (plist-get plist :name))
1297                                 (org-contacts--all-contacts)))))
1298     (concat "org-contact:" name)))
1299
1300 (defun org-contacts-link-face (path)
1301   "Different face color for different org-contacts link query."
1302   (cond
1303    ((string-match "/.*/" path)
1304     '(:background "sky blue" :overline t :slant 'italic))
1305    (t '(:inherit 'org-link))))
1306
1307 (provide 'org-contacts)
1308
1309 ;;; org-contacts.el ends here