org-contacts.el

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