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 ;;;###autoload
 630 (defun org-contacts-org-complete--annotation-function (candidate)
 631   "Return org-contacts tags of contact candidate."
 632   ;; TODO
 633   "Tags: ")
 634
 635 ;;;###autoload
 636 (defun org-contacts-org-complete--doc-function (candidate)
 637   "Return org-contacts content of contact candidate."
 638   (let* ((candidate (substring-no-properties candidate 1 nil))
 639          (contact (seq-find
 640                    (lambda (contact) (string-equal (plist-get contact :name) candidate))
 641                    (org-contacts--all-contacts)))
 642          (name (plist-get contact :name))
 643          (file (plist-get contact :file))
 644          (position (plist-get contact :position))
 645          (doc-buffer (get-buffer-create " *org-contact*"))
 646          (org-contact-buffer (get-buffer (find-file-noselect file)))
 647          ;; get org-contact headline and property drawer.
 648          (contents (with-current-buffer org-contact-buffer
 649                      (when (derived-mode-p 'org-mode)
 650                        (save-excursion
 651                          (goto-char position)
 652                          (cond ((ignore-errors (org-edit-src-code))
 653                                 (delete-other-windows))
 654                                ((org-at-block-p)
 655                                 (org-narrow-to-block))
 656                                (t (org-narrow-to-subtree)))
 657                          (let ((content (buffer-substring (point-min) (point-max))))
 658                            (when (buffer-narrowed-p) (widen))
 659                            content))))))
 660     (with-current-buffer doc-buffer
 661       (read-only-mode 1)
 662       (let ((inhibit-read-only t))
 663         (erase-buffer)
 664         (insert contents)
 665         (org-mode)
 666         (org-show-all)
 667         (font-lock-ensure)))
 668     doc-buffer))
 669
 670 ;;; display company-mode doc buffer bellow current window.
 671 (add-to-list 'display-buffer-alist '("^ \\*org-contact\\*" . (display-buffer-below-selected)))
 672
 673 ;;;###autoload
 674 (defun org-contacts-org-complete--location-function (candidate)
 675   "Return org-contacts location of contact candidate."
 676   (let* ((candidate (substring-no-properties candidate 1 nil))
 677          (contact (seq-find
 678                    (lambda (contact) (string-equal (plist-get contact :name) candidate))
 679                    (org-contacts--all-contacts)))
 680          (name (plist-get contact :name))
 681          (file (plist-get contact :file))
 682          (position (plist-get contact :position)))
 683     (with-current-buffer (find-file-noselect file)
 684       (goto-char position)
 685       (cons (current-buffer) position))))
 686
 687 ;;;###autoload
 688 (defun org-contacts-org-complete-function ()
 689   "Function used in `completion-at-point-functions' in `org-mode' to complete @name.
 690 Usage: (add-hook 'completion-at-point-functions 'org-contacts-org-complete-function nil 'local)"
 691   (when-let* ((end (point))
 692               (begin (save-excursion (skip-chars-backward "[:alnum:]@") (point)))
 693               (symbol (buffer-substring-no-properties begin end))
 694               (org-contacts-prefix-p (string-prefix-p "@" symbol)))
 695     (when org-contacts-prefix-p
 696       (list begin
 697             end
 698             (completion-table-dynamic
 699              (lambda (_)
 700                (mapcar
 701                 (lambda (contact) (concat "@" (plist-get contact :name)))
 702                 (org-contacts--all-contacts))))
 703
 704             :predicate 'stringp
 705             :exclusive 'no
 706             ;; properties check out `completion-extra-properties'
 707             :annotation-function #'org-contacts-org-complete--annotation-function
 708             ;; :exit-function ; TODO change completion candidate inserted contact name into org-contact link??
 709
 710             :company-docsig #'identity                                    ; metadata
 711             :company-doc-buffer #'org-contacts-org-complete--doc-function ; doc popup
 712             :company-location #'org-contacts-org-complete--location-function))))
 713
 714 (defun org-contacts-gnus-get-name-email ()
 715   "Get name and email address from Gnus message."
 716   (if (gnus-alive-p)
 717       (gnus-with-article-headers
 718         (mail-extract-address-components
 719          (or (mail-fetch-field "From") "")))))
 720
 721 (defun org-contacts-gnus-article-from-get-marker ()
 722   "Return a marker for a contact based on From."
 723   (let* ((address (org-contacts-gnus-get-name-email))
 724          (name (car address))
 725          (email (cadr address)))
 726     (cl-cadar (or (org-contacts-filter
 727                    nil
 728                    nil
 729                    (cons org-contacts-email-property (concat "\\b" (regexp-quote email) "\\b")))
 730                   (when name
 731                     (org-contacts-filter
 732                      (concat "^" name "$")))))))
 733
 734 (defun org-contacts-gnus-article-from-goto ()
 735   "Go to contact in the From address of current Gnus message."
 736   (interactive)
 737   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 738     (when marker
 739       (switch-to-buffer-other-window (marker-buffer marker))
 740       (goto-char marker)
 741       (when (eq major-mode 'org-mode) (org-show-context 'agenda)))))
 742
 743 (with-no-warnings (defvar date)) ;; unprefixed, from calendar.el
 744 (defun org-contacts-anniversaries (&optional field format)
 745   "Compute FIELD anniversary for each contact, returning FORMAT.
 746 Default FIELD value is \"BIRTHDAY\".
 747
 748 Format is a string matching the following format specification:
 749
 750   %h - Heading name
 751   %l - Link to the heading
 752   %y - Number of year
 753   %Y - Number of year (ordinal)"
 754   (let ((calendar-date-style 'american)
 755         ) ;; (entry "")
 756     (unless format (setq format org-contacts-birthday-format))
 757     (cl-loop for contact in (org-contacts-filter)
 758              for anniv = (let ((anniv (cdr (assoc-string
 759                                             (or field org-contacts-birthday-property)
 760                                             (nth 2 contact)))))
 761                            (when anniv
 762                              (calendar-gregorian-from-absolute
 763                               (org-time-string-to-absolute anniv))))
 764              ;; Use `diary-anniversary' to compute anniversary.
 765              ;; FIXME: should we require `diary-lib' somewhere to be sure
 766              ;; `diary-anniversary' is defined when we get here?
 767              if (and anniv (apply #'diary-anniversary anniv))
 768              collect (format-spec format
 769                                   `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
 770                                     (?h . ,(car contact))
 771                                     (?y . ,(- (calendar-extract-year date)
 772                                               (calendar-extract-year anniv)))
 773                                     (?Y . ,(let ((years (- (calendar-extract-year date)
 774                                                            (calendar-extract-year anniv))))
 775                                              (format "%d%s" years (diary-ordinal-suffix years)))))))))
 776
 777 (defun org-completing-read-date ( prompt _collection
 778                                   &optional _predicate _require-match _initial-input
 779                                   _hist def _inherit-input-method)
 780   "Like `completing-read' but reads a date.
 781 Only PROMPT and DEF are really used."
 782   (org-read-date nil nil nil prompt nil def))
 783
 784 (add-to-list 'org-property-set-functions-alist
 785              `(,org-contacts-birthday-property . org-completing-read-date))
 786
 787 (defun org-contacts-template-name (&optional return-value)
 788   "Try to return the contact name for a template.
 789 If not found return RETURN-VALUE or something that would ask the user."
 790   (or (car (org-contacts-gnus-get-name-email))
 791       return-value
 792       "%^{Name}"))
 793
 794 (defun org-contacts-template-email (&optional return-value)
 795   "Try to return the contact email for a template.
 796 If not found return RETURN-VALUE or something that would ask the user."
 797   (or (cadr (org-contacts-gnus-get-name-email))
 798       return-value
 799       (concat "%^{" org-contacts-email-property "}p")))
 800
 801 (defun org-contacts-gnus-store-last-mail ()
 802   "Store a link between mails and contacts.
 803
 804 This function should be called from `gnus-article-prepare-hook'."
 805   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 806     (when marker
 807       (with-current-buffer (marker-buffer marker)
 808         (save-excursion
 809           (goto-char marker)
 810           (let* ((org-link-email-description-format (or org-contacts-email-link-description-format
 811                                                         org-link-email-description-format))
 812                  (link (gnus-with-article-buffer (org-store-link nil))))
 813             (org-set-property org-contacts-last-read-mail-property link)))))))
 814
 815 (defun org-contacts-icon-as-string ()
 816   "Return the contact icon as a string."
 817   (let ((image (org-contacts-get-icon)))
 818     (concat
 819      (propertize "-" 'display
 820                  (append
 821                   (if image
 822                       image
 823                     `'(space :width (,org-contacts-icon-size)))
 824                   '(:ascent center)))
 825      " ")))
 826
 827 ;;;###autoload
 828 (defun org-contacts (name)
 829   "Create agenda view for contacts matching NAME."
 830   (interactive (list (read-string "Name: ")))
 831   (let ((org-agenda-files (org-contacts-files))
 832         (org-agenda-skip-function
 833          (lambda () (org-agenda-skip-if nil `(notregexp ,name))))
 834         (org-agenda-prefix-format
 835          (propertize
 836           "%(org-contacts-icon-as-string)% s%(org-contacts-irc-number-of-unread-messages) "
 837           'keymap org-contacts-keymap))
 838         (org-agenda-overriding-header
 839          (or org-agenda-overriding-header
 840              (concat "List of contacts matching `" name "':"))))
 841     (setq org-agenda-skip-regexp name)
 842     (org-tags-view nil org-contacts-matcher)
 843     (with-current-buffer org-agenda-buffer-name
 844       (setq org-agenda-redo-command
 845             (list 'org-contacts name)))))
 846
 847 (defun org-contacts-completing-read (prompt
 848                                      &optional predicate
 849                                      initial-input hist def inherit-input-method)
 850   "Call `completing-read' with contacts name as collection."
 851   (org-completing-read
 852    prompt (org-contacts-filter) predicate t initial-input hist def inherit-input-method))
 853
 854 (defun org-contacts-format-name (name)
 855   "Trim any local formatting to get a bare NAME."
 856   ;; Remove radio targets characters
 857   (replace-regexp-in-string org-radio-target-regexp "\\1" name))
 858
 859 (defun org-contacts-format-email (name email)
 860   "Format an EMAIL address corresponding to NAME."
 861   (unless email
 862     (error "`email' cannot be nul"))
 863   (if name
 864       (concat (org-contacts-format-name name) " <" email ">")
 865     email))
 866
 867 (defun org-contacts-check-mail-address (mail)
 868   "Add MAIL address to contact at point if it does not have it."
 869   (let ((mails (org-entry-get (point) org-contacts-email-property)))
 870     (unless (member mail (split-string mails))
 871       (when (yes-or-no-p
 872              (format "Do you want to add this address to %s?" (org-get-heading t)))
 873         (org-set-property org-contacts-email-property (concat mails " " mail))))))
 874
 875 (defun org-contacts-gnus-check-mail-address ()
 876   "Check that contact has the current address recorded.
 877 This function should be called from `gnus-article-prepare-hook'."
 878   (let ((marker (org-contacts-gnus-article-from-get-marker)))
 879     (when marker
 880       (org-with-point-at marker
 881         (org-contacts-check-mail-address (cadr (org-contacts-gnus-get-name-email)))))))
 882
 883 (defun org-contacts-gnus-insinuate ()
 884   "Add some hooks for Gnus user.
 885 This adds `org-contacts-gnus-check-mail-address' and
 886 `org-contacts-gnus-store-last-mail' to
 887 `gnus-article-prepare-hook'.  It also adds a binding on `;' in
 888 `gnus-summary-mode-map' to `org-contacts-gnus-article-from-goto'"
 889   (require 'gnus)
 890   (require 'gnus-art)
 891   (define-key gnus-summary-mode-map ";" #'org-contacts-gnus-article-from-goto)
 892   (add-hook 'gnus-article-prepare-hook #'org-contacts-gnus-check-mail-address)
 893   (add-hook 'gnus-article-prepare-hook #'org-contacts-gnus-store-last-mail))
 894
 895 (defun org-contacts-setup-completion-at-point ()
 896   "Add `org-contacts-message-complete-function' as a new function
 897 to complete the thing at point."
 898   (add-to-list 'completion-at-point-functions
 899                'org-contacts-message-complete-function))
 900
 901 (defun org-contacts-unload-hook ()
 902   (remove-hook 'message-mode-hook #'org-contacts-setup-completion-at-point))
 903
 904 (when (and org-contacts-enable-completion
 905            (boundp 'completion-at-point-functions))
 906   (add-hook 'message-mode-hook #'org-contacts-setup-completion-at-point))
 907
 908 (defun org-contacts-wl-get-from-header-content ()
 909   "Retrieve the content of the `From' header of an email.
 910 Works from wl-summary-mode and mime-view-mode - that is while viewing email.
 911 Depends on Wanderlust been loaded."
 912   (with-current-buffer (org-capture-get :original-buffer)
 913     (cond
 914      ((eq major-mode 'wl-summary-mode) (when (and (boundp 'wl-summary-buffer-elmo-folder)
 915                                                   wl-summary-buffer-elmo-folder)
 916                                          (elmo-message-field
 917                                           wl-summary-buffer-elmo-folder
 918                                           (wl-summary-message-number)
 919                                           'from)))
 920      ((eq major-mode 'mime-view-mode) (std11-narrow-to-header)
 921       (prog1
 922           (std11-fetch-field "From")
 923         (widen))))))
 924
 925 (defun org-contacts-wl-get-name-email ()
 926   "Get name and email address from Wanderlust email.
 927 See `org-contacts-wl-get-from-header-content' for limitations."
 928   (let ((from (org-contacts-wl-get-from-header-content)))
 929     (when from
 930       (list (wl-address-header-extract-realname from)
 931             (wl-address-header-extract-address from)))))
 932
 933 (defun org-contacts-template-wl-name (&optional return-value)
 934   "Try to return the contact name for a template from wl.
 935 If not found, return RETURN-VALUE or something that would ask the
 936 user."
 937   (or (car (org-contacts-wl-get-name-email))
 938       return-value
 939       "%^{Name}"))
 940
 941 (defun org-contacts-template-wl-email (&optional return-value)
 942   "Try to return the contact email for a template from Wanderlust.
 943 If not found return RETURN-VALUE or something that would ask the user."
 944   (or (cadr (org-contacts-wl-get-name-email))
 945       return-value
 946       (concat "%^{" org-contacts-email-property "}p")))
 947
 948 (defun org-contacts-view-send-email (&optional ask)
 949   "Send email to the contact at point.
 950 If ASK is set, ask for the email address even if there's only one
 951 address."
 952   (interactive "P")
 953   (let ((marker (org-get-at-bol 'org-hd-marker)))
 954     (org-with-point-at marker
 955       (let ((emails (org-entry-get (point) org-contacts-email-property)))
 956         (if emails
 957             (let ((email-list (org-contacts-split-property emails)))
 958               (if (and (= (length email-list) 1) (not ask))
 959                   (compose-mail (org-contacts-format-email
 960                                  (org-get-heading t) emails))
 961                 (let ((email (completing-read "Send mail to which address: " email-list)))
 962                   (setq email (org-contacts-strip-link email))
 963                   (org-contacts-check-mail-address email)
 964                   (compose-mail (org-contacts-format-email (org-get-heading t) email)))))
 965           (error (format "This contact has no mail address set (no %s property)"
 966                          org-contacts-email-property)))))))
 967
 968 (defun org-contacts-get-icon (&optional pom)
 969   "Get icon for contact at POM."
 970   (setq pom (or pom (point)))
 971   (catch 'icon
 972     ;; Use `org-contacts-icon-property'
 973     (let* ((link-matcher-regexp
 974             "\\[\\[\\([^]]*\\)\\]\\(\\[\\(.*\\)\\]\\)?\\]")
 975            (contacts-dir (file-name-directory (car org-contacts-files)))
 976            (image-path
 977             (if-let ((avatar (org-entry-get pom org-contacts-icon-property)))
 978                 (cond
 979                  ;; [[file:dir/filename.png]]
 980                  ((string-match-p "\\[\\[.*\\]\\]" avatar)
 981                   ;; FIXME: What if avatar matches the above regexp but the
 982                   ;; one below?
 983                   (when (string-match link-matcher-regexp avatar)
 984                     ;; FIXME: 5 seems to be the length of `file:' but I can't
 985                     ;; see anything that guarantees that the submatch 1 starts
 986                     ;; with `file:'.
 987                     (expand-file-name (substring (match-string-no-properties 1 avatar) 5 nil)
 988                                       contacts-dir)))
 989                  ;; "" (empty string)
 990                  ((string-empty-p avatar) nil)
 991                  (t (expand-file-name avatar contacts-dir))))))
 992       (when image-path
 993         (throw 'icon
 994                (if (featurep 'imagemagick)
 995                    (create-image image-path 'imagemagick nil
 996                                  :height org-contacts-icon-size)
 997                  (create-image image-path nil nil
 998                                :height org-contacts-icon-size)))))
 999     ;; Next, try Gravatar
1000     (when org-contacts-icon-use-gravatar
1001       (defvar gravatar-size)
1002       (let* ((gravatar-size org-contacts-icon-size)
1003              (email-list (org-entry-get pom org-contacts-email-property))
1004              (gravatar
1005               (when email-list
1006                 (cl-loop for email in (org-contacts-split-property email-list)
1007                          for gravatar = (gravatar-retrieve-synchronously (org-contacts-strip-link email))
1008                          if (and gravatar
1009                                  (not (eq gravatar 'error)))
1010                          return gravatar))))
1011         (when gravatar (throw 'icon gravatar))))))
1012
1013 (defun org-contacts-irc-buffer (&optional pom)
1014   "Get the IRC buffer associated with the entry at POM."
1015   (setq pom (or pom (point)))
1016   (let ((nick (org-entry-get pom org-contacts-nickname-property)))
1017     (when nick
1018       (let ((buffer (get-buffer nick)))
1019         (when buffer
1020           (with-current-buffer buffer
1021             (when (eq major-mode 'erc-mode)
1022               buffer)))))))
1023
1024 (defun org-contacts-irc-number-of-unread-messages (&optional pom)
1025   "Return the number of unread messages for contact at POM."
1026   (when (boundp 'erc-modified-channels-alist)
1027     (let ((number (cadr (assoc (org-contacts-irc-buffer pom) erc-modified-channels-alist))))
1028       (if number
1029           (format (concat "%3d unread message" (if (> number 1) "s" " ") " ") number)
1030         (make-string 21 ? )))))
1031
1032 (defun org-contacts-view-switch-to-irc-buffer ()
1033   "Switch to the IRC buffer of the current contact if it has one."
1034   (interactive)
1035   (let ((marker (org-get-at-bol 'org-hd-marker)))
1036     (org-with-point-at marker
1037       (switch-to-buffer-other-window (org-contacts-irc-buffer)))))
1038
1039 (defun org-contacts-completing-read-nickname (prompt collection
1040                                                      &optional predicate require-match initial-input
1041                                                      hist def inherit-input-method)
1042   "Like `completing-read' but reads a nickname."
1043   (org-completing-read prompt (append collection (erc-nicknames-list)) predicate require-match
1044                        initial-input hist def inherit-input-method))
1045
1046 (defun erc-nicknames-list ()
1047   "Return all nicknames of all ERC buffers."
1048   (cl-loop for buffer in (erc-buffer-list)
1049            nconc (with-current-buffer buffer
1050                    (cl-loop for user-entry
1051                             in (mapcar #'car (erc-get-channel-user-list))
1052                             collect (elt user-entry 1)))))
1053
1054 (add-to-list 'org-property-set-functions-alist
1055              `(,org-contacts-nickname-property . org-contacts-completing-read-nickname))
1056
1057 (defun org-contacts-vcard-escape (str)
1058   "Escape ; , and \n in STR for the VCard format."
1059   ;; Thanks to this library for the regexp:
1060   ;; https://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el
1061   (when str
1062     (replace-regexp-in-string
1063      "\n" "\\\\n"
1064      (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" str))))
1065
1066 (defun org-contacts-vcard-encode-name (name)
1067   "Try to encode NAME as VCard's N property.
1068 The N property expects
1069
1070   FamilyName;GivenName;AdditionalNames;Prefix;Postfix.
1071
1072 Org-contacts does not specify how to encode the name.  So we try
1073 to do our best."
1074   (concat (replace-regexp-in-string "\\(\\w+\\) \\(.*\\)" "\\2;\\1" name) ";;;"))
1075
1076 (defun org-contacts-vcard-format (contact)
1077   "Formats CONTACT in VCard 3.0 format."
1078   (let* ((properties (nth 2 contact))
1079          (name (org-contacts-vcard-escape (car contact)))
1080          (n (org-contacts-vcard-encode-name name))
1081          (email (cdr (assoc-string org-contacts-email-property properties)))
1082          (tel (cdr (assoc-string org-contacts-tel-property properties)))
1083          (ignore-list (cdr (assoc-string org-contacts-ignore-property properties)))
1084          (ignore-list (when ignore-list
1085                         (org-contacts-split-property ignore-list)))
1086          (note (cdr (assoc-string org-contacts-note-property properties)))
1087          (bday (org-contacts-vcard-escape (cdr (assoc-string org-contacts-birthday-property properties))))
1088          (addr (cdr (assoc-string org-contacts-address-property properties)))
1089          (nick (org-contacts-vcard-escape (cdr (assoc-string org-contacts-nickname-property properties))))
1090          (head (format "BEGIN:VCARD\nVERSION:3.0\nN:%s\nFN:%s\n" n name))
1091          emails-list result phones-list)
1092     (concat
1093      head
1094      (when email
1095        (progn
1096          (setq emails-list (org-contacts-remove-ignored-property-values
1097                             ignore-list (org-contacts-split-property email)))
1098          (setq result "")
1099          (while emails-list
1100            (setq result (concat result  "EMAIL:" (org-contacts-strip-link (car emails-list)) "\n"))
1101            (setq emails-list (cdr emails-list)))
1102          result))
1103      (when addr
1104        (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr)))
1105      (when tel
1106        (progn
1107          (setq phones-list (org-contacts-remove-ignored-property-values
1108                             ignore-list (org-contacts-split-property tel)))
1109          (setq result "")
1110          (while phones-list
1111            (setq result (concat result  "TEL:" (org-contacts-strip-link
1112                                                 (org-link-unescape (car phones-list))) "\n"))
1113            (setq phones-list (cdr phones-list)))
1114          result))
1115      (when bday
1116        (let ((cal-bday (calendar-gregorian-from-absolute (org-time-string-to-absolute bday))))
1117          (format "BDAY:%04d-%02d-%02d\n"
1118                  (calendar-extract-year cal-bday)
1119                  (calendar-extract-month cal-bday)
1120                  (calendar-extract-day cal-bday))))
1121      (when nick (format "NICKNAME:%s\n" nick))
1122      (when note (format "NOTE:%s\n" note))
1123      "END:VCARD\n\n")))
1124
1125 (defun org-contacts-export-as-vcard (&optional name file to-buffer)
1126   "Export org contacts to V-Card 3.0.
1127
1128 By default, all contacts are exported to `org-contacts-vcard-file'.
1129
1130 When NAME is \\[universal-argument], prompts for a contact name.
1131
1132 When NAME is \\[universal-argument] \\[universal-argument],
1133 prompts for a contact name and a file name where to export.
1134
1135 When NAME is \\[universal-argument] \\[universal-argument]
1136 \\[universal-argument], prompts for a contact name and a buffer where to export.
1137
1138 If the function is not called interactively, all parameters are
1139 passed to `org-contacts-export-as-vcard-internal'."
1140   (interactive "P")
1141   (when (called-interactively-p 'any)
1142     (cl-psetf name
1143               (when name
1144                 (read-string "Contact name: "
1145                              (nth 0 (org-contacts-at-point))))
1146               file
1147               (when (equal name '(16))
1148                 (read-file-name "File: " nil org-contacts-vcard-file))
1149               to-buffer
1150               (when (equal name '(64))
1151                 (read-buffer "Buffer: "))))
1152   (org-contacts-export-as-vcard-internal name file to-buffer))
1153
1154 (defun org-contacts-export-as-vcard-internal (&optional name file to-buffer)
1155   "Export all contacts matching NAME as VCard 3.0.
1156 If TO-BUFFER is nil, the content is written to FILE or
1157 `org-contacts-vcard-file'.  If TO-BUFFER is non-nil, the buffer
1158 is created and the VCard is written into that buffer."
1159   (let* ((filename (or file org-contacts-vcard-file))
1160          (buffer (if to-buffer
1161                      (get-buffer-create to-buffer)
1162                    (find-file-noselect filename))))
1163     (message "Exporting...")
1164     (set-buffer buffer)
1165     (let ((inhibit-read-only t)) (erase-buffer))
1166     (fundamental-mode)
1167     (when (fboundp 'set-buffer-file-coding-system)
1168       (set-buffer-file-coding-system coding-system-for-write))
1169     (cl-loop for contact in (org-contacts-filter name)
1170              do (insert (org-contacts-vcard-format contact)))
1171     (if to-buffer
1172         (current-buffer)
1173       (progn (save-buffer) (kill-buffer)))))
1174
1175 (defun org-contacts-show-map (&optional name)
1176   "Show contacts on a map.
1177 Requires google-maps-el."
1178   (interactive)
1179   (unless (fboundp 'google-maps-static-show)
1180     (error "`org-contacts-show-map' requires `google-maps-el'"))
1181   (google-maps-static-show
1182    :markers
1183    (cl-loop
1184     for contact in (org-contacts-filter name)
1185     for addr = (cdr (assoc-string org-contacts-address-property (nth 2 contact)))
1186     if addr
1187     collect (cons (list addr) (list :label (string-to-char (car contact)))))))
1188
1189 (defun org-contacts-strip-link (link)
1190   "Remove brackets, description, link type and colon from an org
1191 link string and return the pure link target."
1192   (let (startpos colonpos endpos)
1193     (setq startpos (string-match (regexp-opt '("[[tel:" "[[mailto:")) link))
1194     (if startpos
1195         (progn
1196           (setq colonpos (string-match ":" link))
1197           (setq endpos (string-match "\\]" link))
1198           (if endpos (substring link (1+ colonpos) endpos) link))
1199       (progn
1200         (setq startpos (string-match "mailto:" link))
1201         (setq colonpos (string-match ":" link))
1202         (if startpos (substring link (1+ colonpos)) link)))))
1203
1204 ;; Add the link type supported by org-contacts-strip-link
1205 ;; so everything is in order for its use in Org files
1206 (org-link-set-parameters "tel")
1207
1208 (defun org-contacts-split-property (string &optional separators omit-nulls)
1209   "Custom version of `split-string'.
1210 Split a property STRING into sub-strings bounded by matches
1211 for SEPARATORS but keep Org links intact.
1212
1213 The beginning and end of STRING, and each match for SEPARATORS, are
1214 splitting points.  The substrings matching SEPARATORS are removed, and
1215 the substrings between the splitting points are collected as a list,
1216 which is returned.
1217
1218 If SEPARATORS is non-nil, it should be a regular expression
1219 matching text which separates, but is not part of, the
1220 substrings.  If nil it defaults to `org-contacts-property-values-separators',
1221 normally \"[,; \f\t\n\r\v]+\", and OMIT-NULLS is forced to t.
1222
1223 If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
1224 that for the default value of SEPARATORS leading and trailing whitespace
1225 are effectively trimmed).  If nil, all zero-length substrings are retained."
1226   (let* ((omit-nulls (if separators omit-nulls t))
1227          (rexp (or separators org-contacts-property-values-separators))
1228          (inputlist (split-string string rexp omit-nulls))
1229          (linkstring "")
1230          (bufferstring "")
1231          (proplist (list "")))
1232     (while inputlist
1233       (setq bufferstring (pop inputlist))
1234       (if (string-match "\\[\\[" bufferstring)
1235           (progn
1236             (setq linkstring (concat bufferstring " "))
1237             (while (not (string-match "\\]\\]" bufferstring))
1238               (setq bufferstring (pop inputlist))
1239               (setq linkstring (concat  linkstring bufferstring " ")))
1240             (setq proplist (cons (org-trim linkstring) proplist)))
1241         (setq proplist (cons bufferstring proplist))))
1242     (cdr (reverse proplist))))
1243
1244 ;;;###autoload
1245 ;;; Add an Org link type `org-contact:' for easy jump to or searching org-contacts headline.
1246 ;;; link spec: [[org-contact:query][desc]]
1247 (org-link-set-parameters "org-contact"
1248                          :follow #'org-contacts-link-open
1249                          :complete #'org-contacts-link-complete
1250                          :store #'org-contacts-link-store
1251                          :face 'org-contacts-link-face)
1252
1253 ;;;###autoload
1254 (defun org-contacts-link-store ()
1255   "Store the contact in `org-contacts-files' with a link."
1256   (when (and (eq major-mode 'org-mode)
1257              (member (buffer-file-name)
1258                      (mapcar #'expand-file-name org-contacts-files)))
1259     (if (bound-and-true-p org-id-link-to-org-use-id)
1260         (org-id-store-link)
1261       (let ((headline-str (substring-no-properties (org-get-heading t t t t))))
1262         (org-link-store-props
1263          :type "org-contact"
1264          :link headline-str
1265          :description headline-str)
1266         (let ((link (concat "org-contact:" headline-str)))
1267           (org-link-add-props :link link :description headline-str)
1268           link)))))
1269
1270 ;;;###autoload
1271 (defun org-contacts--all-contacts ()
1272   "Return a list of all contacts in `org-contacts-files'.
1273 Each element has the form (NAME . (FILE . POSITION))."
1274   (car (mapcar
1275         (lambda (file)
1276           (unless (buffer-live-p (get-buffer (file-name-nondirectory file)))
1277             (find-file file))
1278           (with-current-buffer (get-buffer (file-name-nondirectory file))
1279             (org-map-entries
1280              (lambda ()
1281                (let ((name (substring-no-properties (org-get-heading t t t t)))
1282                      (file (buffer-file-name))
1283                      (position (point)))
1284                  `(:name ,name :file ,file :position ,position))))))
1285         org-contacts-files)))
1286
1287 ;;;###autoload
1288 (defun org-contacts-link-open (path)
1289   "Open contacts: link type with jumping or searching."
1290   (let ((query path))
1291     (cond
1292      ;; /query/ format searching
1293      ((string-match "/.*/" query)
1294       (let* ((f (car org-contacts-files))
1295              (buf (get-buffer (file-name-nondirectory f))))
1296         (unless (buffer-live-p buf) (find-file f))
1297         (with-current-buffer buf
1298           (string-match "/\\(.*\\)/" query)
1299           (occur (match-string 1 query)))))
1300      ;; jump to contact headline directly
1301      (t
1302       (let* ((f (car org-contacts-files))
1303              (buf (get-buffer (file-name-nondirectory f))))
1304         (unless (buffer-live-p buf) (find-file f))
1305         (with-current-buffer buf
1306           (goto-char (marker-position (org-find-exact-headline-in-buffer query))))
1307         (display-buffer buf '(display-buffer-below-selected)))
1308       ;; FIXME
1309       ;; (let* ((contact-entry (plist-get (org-contacts--all-contacts) query))
1310       ;;         (contact-name (plist-get contact-entry :name))
1311       ;;         (file (plist-get contact-entry :file))
1312       ;;         (position (plist-get contact-entry :position))
1313       ;;         (buf (get-buffer (file-name-nondirectory file))))
1314       ;;    (unless (buffer-live-p buf) (find-file file))
1315       ;;    (with-current-buffer buf (goto-char position)))
1316       ))))
1317
1318 ;;;###autoload
1319 (defun org-contacts-link-complete (&optional _arg)
1320   "Create a org-contacts link using completion."
1321   (let ((name (completing-read "org-contact Name: "
1322                                (mapcar
1323                                 (lambda (plist) (plist-get plist :name))
1324                                 (org-contacts--all-contacts)))))
1325     (concat "org-contact:" name)))
1326
1327 (defun org-contacts-link-face (path)
1328   "Different face color for different org-contacts link query."
1329   (cond
1330    ((string-match "/.*/" path)
1331     '(:background "sky blue" :overline t :slant 'italic))
1332    (t '(:inherit 'org-link))))
1333
1334 (provide 'org-contacts)
1335
1336 ;;; org-contacts.el ends here