|
|
@@ -52,9 +52,7 @@
|
|
|
;;
|
|
|
;;; Code:
|
|
|
|
|
|
-(eval-when-compile
|
|
|
- (require 'cl))
|
|
|
-
|
|
|
+(require 'cl-lib)
|
|
|
(require 'org)
|
|
|
(require 'gnus-util)
|
|
|
(require 'gnus-art)
|
|
|
@@ -316,22 +314,22 @@ cell corresponding to the contact properties.
|
|
|
(null prop-match)
|
|
|
(null tags-match))
|
|
|
(org-contacts-db)
|
|
|
- (loop for contact in (org-contacts-db)
|
|
|
- if (or
|
|
|
- (and name-match
|
|
|
- (org-string-match-p name-match
|
|
|
- (first contact)))
|
|
|
- (and prop-match
|
|
|
- (org-find-if (lambda (prop)
|
|
|
- (and (string= (car prop-match) (car prop))
|
|
|
- (org-string-match-p (cdr prop-match) (cdr prop))))
|
|
|
- (caddr contact)))
|
|
|
- (and tags-match
|
|
|
- (org-find-if (lambda (tag)
|
|
|
- (org-string-match-p tags-match tag))
|
|
|
- (org-split-string
|
|
|
- (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))
|
|
|
- collect contact)))
|
|
|
+ (cl-loop for contact in (org-contacts-db)
|
|
|
+ if (or
|
|
|
+ (and name-match
|
|
|
+ (org-string-match-p name-match
|
|
|
+ (first contact)))
|
|
|
+ (and prop-match
|
|
|
+ (org-find-if (lambda (prop)
|
|
|
+ (and (string= (car prop-match) (car prop))
|
|
|
+ (org-string-match-p (cdr prop-match) (cdr prop))))
|
|
|
+ (caddr contact)))
|
|
|
+ (and tags-match
|
|
|
+ (org-find-if (lambda (tag)
|
|
|
+ (org-string-match-p tags-match tag))
|
|
|
+ (org-split-string
|
|
|
+ (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))
|
|
|
+ collect contact)))
|
|
|
|
|
|
(when (not (fboundp 'completion-table-case-fold))
|
|
|
;; That function is new in Emacs 24...
|
|
|
@@ -344,34 +342,34 @@ cell corresponding to the contact properties.
|
|
|
"Custom implementation of `try-completion'.
|
|
|
This version works only with list and alist and it looks at all
|
|
|
prefixes rather than just the beginning of the string."
|
|
|
- (loop with regexp = (concat "\\b" (regexp-quote to-match))
|
|
|
- with ret = nil
|
|
|
- with ret-start = nil
|
|
|
- with ret-end = nil
|
|
|
-
|
|
|
- for el in collection
|
|
|
- for string = (if (listp el) (car el) el)
|
|
|
-
|
|
|
- for start = (when (or (null predicate) (funcall predicate string))
|
|
|
- (string-match regexp string))
|
|
|
-
|
|
|
- if start
|
|
|
- do (let ((end (match-end 0))
|
|
|
- (len (length string)))
|
|
|
- (if (= end len)
|
|
|
- (return t)
|
|
|
- (destructuring-bind (string start end)
|
|
|
- (if (null ret)
|
|
|
- (values string start end)
|
|
|
- (org-contacts-common-substring
|
|
|
- ret ret-start ret-end
|
|
|
- string start end))
|
|
|
- (setf ret string
|
|
|
- ret-start start
|
|
|
- ret-end end))))
|
|
|
-
|
|
|
- finally (return
|
|
|
- (replace-regexp-in-string "\\`[ \t\n]*" "" ret))))
|
|
|
+ (cl-loop with regexp = (concat "\\b" (regexp-quote to-match))
|
|
|
+ with ret = nil
|
|
|
+ with ret-start = nil
|
|
|
+ with ret-end = nil
|
|
|
+
|
|
|
+ for el in collection
|
|
|
+ for string = (if (listp el) (car el) el)
|
|
|
+
|
|
|
+ for start = (when (or (null predicate) (funcall predicate string))
|
|
|
+ (string-match regexp string))
|
|
|
+
|
|
|
+ if start
|
|
|
+ do (let ((end (match-end 0))
|
|
|
+ (len (length string)))
|
|
|
+ (if (= end len)
|
|
|
+ (cl-return t)
|
|
|
+ (cl-destructuring-bind (string start end)
|
|
|
+ (if (null ret)
|
|
|
+ (values string start end)
|
|
|
+ (org-contacts-common-substring
|
|
|
+ ret ret-start ret-end
|
|
|
+ string start end))
|
|
|
+ (setf ret string
|
|
|
+ ret-start start
|
|
|
+ ret-end end))))
|
|
|
+
|
|
|
+ finally (cl-return
|
|
|
+ (replace-regexp-in-string "\\`[ \t\n]*" "" ret))))
|
|
|
|
|
|
(defun org-contacts-compare-strings (s1 start1 end1 s2 start2 end2 &optional ignore-case)
|
|
|
"Compare the contents of two strings, using `compare-strings'.
|
|
|
@@ -430,22 +428,22 @@ This function returns a list whose contains:
|
|
|
"Custom version of `all-completions'.
|
|
|
This version works only with list and alist and it looks at all
|
|
|
prefixes rather than just the beginning of the string."
|
|
|
- (loop with regexp = (concat "\\b" (regexp-quote to-match))
|
|
|
- for el in collection
|
|
|
- for string = (if (listp el) (car el) el)
|
|
|
- for match? = (when (and (or (null predicate) (funcall predicate string)))
|
|
|
- (string-match regexp string))
|
|
|
- if match?
|
|
|
- collect (progn
|
|
|
- (let ((end (match-end 0)))
|
|
|
- (org-no-properties string)
|
|
|
- (when (< end (length string))
|
|
|
- ;; Here we add a text property that will be used
|
|
|
- ;; later to highlight the character right after
|
|
|
- ;; the common part between each addresses.
|
|
|
- ;; See `org-contacts-display-sort-function'.
|
|
|
- (put-text-property end (1+ end) 'org-contacts-prefix 't string)))
|
|
|
- string)))
|
|
|
+ (cl-loop with regexp = (concat "\\b" (regexp-quote to-match))
|
|
|
+ for el in collection
|
|
|
+ for string = (if (listp el) (car el) el)
|
|
|
+ for match? = (when (and (or (null predicate) (funcall predicate string)))
|
|
|
+ (string-match regexp string))
|
|
|
+ if match?
|
|
|
+ collect (progn
|
|
|
+ (let ((end (match-end 0)))
|
|
|
+ (org-no-properties string)
|
|
|
+ (when (< end (length string))
|
|
|
+ ;; Here we add a text property that will be used
|
|
|
+ ;; later to highlight the character right after
|
|
|
+ ;; the common part between each addresses.
|
|
|
+ ;; See `org-contacts-display-sort-function'.
|
|
|
+ (put-text-property end (1+ end) 'org-contacts-prefix 't string)))
|
|
|
+ string)))
|
|
|
|
|
|
(defun org-contacts-make-collection-prefix (collection)
|
|
|
"Make a collection function from COLLECTION which will match on prefixes."
|
|
|
@@ -460,7 +458,7 @@ prefixes rather than just the beginning of the string."
|
|
|
((eq flag 'lambda)
|
|
|
(org-contacts-test-completion-prefix string collection predicate))
|
|
|
((and (listp flag) (eq (car flag) 'boundaries))
|
|
|
- (destructuring-bind (to-ignore &rest suffix)
|
|
|
+ (cl-destructuring-bind (to-ignore &rest suffix)
|
|
|
flag
|
|
|
(org-contacts-boundaries-prefix string collection predicate suffix)))
|
|
|
((eq flag 'metadata)
|
|
|
@@ -471,21 +469,21 @@ prefixes rather than just the beginning of the string."
|
|
|
(defun org-contacts-display-sort-function (completions)
|
|
|
"Sort function for contacts display."
|
|
|
(mapcar (lambda (string)
|
|
|
- (loop with len = (1- (length string))
|
|
|
- for i upfrom 0 to len
|
|
|
- if (memq 'org-contacts-prefix
|
|
|
- (text-properties-at i string))
|
|
|
- do (set-text-properties
|
|
|
- i (1+ i)
|
|
|
- (list 'font-lock-face
|
|
|
- (if (char-equal (aref string i)
|
|
|
- (string-to-char " "))
|
|
|
- ;; Spaces can't be bold.
|
|
|
- 'underline
|
|
|
- 'bold)) string)
|
|
|
- else
|
|
|
- do (set-text-properties i (1+ i) nil string)
|
|
|
- finally (return string)))
|
|
|
+ (cl-loop with len = (1- (length string))
|
|
|
+ for i upfrom 0 to len
|
|
|
+ if (memq 'org-contacts-prefix
|
|
|
+ (text-properties-at i string))
|
|
|
+ do (set-text-properties
|
|
|
+ i (1+ i)
|
|
|
+ (list 'font-lock-face
|
|
|
+ (if (char-equal (aref string i)
|
|
|
+ (string-to-char " "))
|
|
|
+ ;; Spaces can't be bold.
|
|
|
+ 'underline
|
|
|
+ 'bold)) string)
|
|
|
+ else
|
|
|
+ do (set-text-properties i (1+ i) nil string)
|
|
|
+ finally (cl-return string)))
|
|
|
completions))
|
|
|
|
|
|
(defun org-contacts-test-completion-prefix (string collection predicate)
|
|
|
@@ -520,9 +518,9 @@ A group FOO is composed of contacts with the tag FOO."
|
|
|
(propertize (concat org-contacts-group-prefix group)
|
|
|
'org-contacts-group group))
|
|
|
(org-uniquify
|
|
|
- (loop for contact in (org-contacts-filter)
|
|
|
- nconc (org-split-string
|
|
|
- (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":")))))))
|
|
|
+ (cl-loop for contact in (org-contacts-filter)
|
|
|
+ nconc (org-split-string
|
|
|
+ (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":")))))))
|
|
|
(list start end
|
|
|
(if (= (length completion-list) 1)
|
|
|
;; We've found the correct group, returns the address
|
|
|
@@ -530,21 +528,21 @@ A group FOO is composed of contacts with the tag FOO."
|
|
|
(car completion-list))))
|
|
|
(lambda (string pred &optional to-ignore)
|
|
|
(mapconcat 'identity
|
|
|
- (loop for contact in (org-contacts-filter
|
|
|
- nil
|
|
|
- tag)
|
|
|
- ;; The contact name is always the car of the assoc-list
|
|
|
- ;; returned by `org-contacts-filter'.
|
|
|
- for contact-name = (car contact)
|
|
|
- ;; Grab the first email of the contact
|
|
|
- for email = (org-contacts-strip-link
|
|
|
- (or (car (org-contacts-split-property
|
|
|
- (or
|
|
|
- (cdr (assoc-string org-contacts-email-property
|
|
|
- (caddr contact)))
|
|
|
- ""))) ""))
|
|
|
- ;; If the user has an email address, append USER <EMAIL>.
|
|
|
- if email collect (org-contacts-format-email contact-name email))
|
|
|
+ (cl-loop for contact in (org-contacts-filter
|
|
|
+ nil
|
|
|
+ tag)
|
|
|
+ ;; The contact name is always the car of the assoc-list
|
|
|
+ ;; returned by `org-contacts-filter'.
|
|
|
+ for contact-name = (car contact)
|
|
|
+ ;; Grab the first email of the contact
|
|
|
+ for email = (org-contacts-strip-link
|
|
|
+ (or (car (org-contacts-split-property
|
|
|
+ (or
|
|
|
+ (cdr (assoc-string org-contacts-email-property
|
|
|
+ (cl-caddr contact)))
|
|
|
+ ""))) ""))
|
|
|
+ ;; If the user has an email address, append USER <EMAIL>.
|
|
|
+ if email collect (org-contacts-format-email contact-name email))
|
|
|
", ")))
|
|
|
;; We haven't found the correct group
|
|
|
(completion-table-case-fold completion-list
|
|
|
@@ -565,24 +563,24 @@ description."
|
|
|
(let ((result
|
|
|
(mapconcat
|
|
|
'identity
|
|
|
- (loop for contact in (org-contacts-db)
|
|
|
- for contact-name = (car contact)
|
|
|
- for email = (org-contacts-strip-link (or (car (org-contacts-split-property
|
|
|
- (or
|
|
|
- (cdr (assoc-string org-contacts-email-property
|
|
|
- (caddr contact)))
|
|
|
- ""))) ""))
|
|
|
- for tags = (cdr (assoc "TAGS" (nth 2 contact)))
|
|
|
- for tags-list = (if tags
|
|
|
- (split-string (substring (cdr (assoc "TAGS" (nth 2 contact))) 1 -1) ":")
|
|
|
- '())
|
|
|
- for marker = (second contact)
|
|
|
- if (with-current-buffer (marker-buffer marker)
|
|
|
- (save-excursion
|
|
|
- (goto-char marker)
|
|
|
- (let (todo-only)
|
|
|
- (eval (cdr (org-make-tags-matcher (subseq string 1)))))))
|
|
|
- collect (org-contacts-format-email contact-name email))
|
|
|
+ (cl-loop for contact in (org-contacts-db)
|
|
|
+ for contact-name = (car contact)
|
|
|
+ for email = (org-contacts-strip-link (or (car (org-contacts-split-property
|
|
|
+ (or
|
|
|
+ (cdr (assoc-string org-contacts-email-property
|
|
|
+ (cl-caddr contact)))
|
|
|
+ ""))) ""))
|
|
|
+ for tags = (cdr (assoc "TAGS" (nth 2 contact)))
|
|
|
+ for tags-list = (if tags
|
|
|
+ (split-string (substring (cdr (assoc "TAGS" (nth 2 contact))) 1 -1) ":")
|
|
|
+ '())
|
|
|
+ for marker = (nth 1 contact)
|
|
|
+ if (with-current-buffer (marker-buffer marker)
|
|
|
+ (save-excursion
|
|
|
+ (goto-char marker)
|
|
|
+ (let (todo-only)
|
|
|
+ (eval (cdr (org-make-tags-matcher (cl-subseq string 1)))))))
|
|
|
+ collect (org-contacts-format-email contact-name email))
|
|
|
",")))
|
|
|
(when (not (string= "" result))
|
|
|
;; return (start end function)
|
|
|
@@ -593,37 +591,37 @@ description."
|
|
|
(defun org-contacts-remove-ignored-property-values (ignore-list list)
|
|
|
"Remove all ignore-list's elements from list and you can use
|
|
|
regular expressions in the ignore list."
|
|
|
- (cl-remove-if (lambda (el)
|
|
|
- (org-find-if (lambda (x)
|
|
|
- (string-match-p x el))
|
|
|
- ignore-list))
|
|
|
- list))
|
|
|
+ (cl-remove-if (lambda (el)
|
|
|
+ (org-find-if (lambda (x)
|
|
|
+ (string-match-p x el))
|
|
|
+ ignore-list))
|
|
|
+ list))
|
|
|
|
|
|
(defun org-contacts-complete-name (start end string)
|
|
|
"Complete text at START with a user name and email."
|
|
|
(let* ((completion-ignore-case org-contacts-completion-ignore-case)
|
|
|
(completion-list
|
|
|
- (loop for contact in (org-contacts-filter)
|
|
|
- ;; The contact name is always the car of the assoc-list
|
|
|
- ;; returned by `org-contacts-filter'.
|
|
|
- for contact-name = (car contact)
|
|
|
-
|
|
|
- ;; Build the list of the email addresses which has
|
|
|
- ;; been expired
|
|
|
- for ignore-list = (org-contacts-split-property
|
|
|
- (or (cdr (assoc-string org-contacts-ignore-property
|
|
|
- (caddr contact))) ""))
|
|
|
- ;; Build the list of the user email addresses.
|
|
|
- for email-list = (org-contacts-remove-ignored-property-values
|
|
|
- ignore-list
|
|
|
- (org-contacts-split-property
|
|
|
- (or (cdr (assoc-string org-contacts-email-property
|
|
|
- (caddr contact))) "")))
|
|
|
- ;; If the user has email addresses…
|
|
|
- if email-list
|
|
|
- ;; … append a list of USER <EMAIL>.
|
|
|
- nconc (loop for email in email-list
|
|
|
- collect (org-contacts-format-email contact-name (org-contacts-strip-link email)))))
|
|
|
+ (cl-loop for contact in (org-contacts-filter)
|
|
|
+ ;; The contact name is always the car of the assoc-list
|
|
|
+ ;; returned by `org-contacts-filter'.
|
|
|
+ for contact-name = (car contact)
|
|
|
+
|
|
|
+ ;; Build the list of the email addresses which has
|
|
|
+ ;; been expired
|
|
|
+ for ignore-list = (org-contacts-split-property
|
|
|
+ (or (cdr (assoc-string org-contacts-ignore-property
|
|
|
+ (nth 2 contact))) ""))
|
|
|
+ ;; Build the list of the user email addresses.
|
|
|
+ for email-list = (org-contacts-remove-ignored-property-values
|
|
|
+ ignore-list
|
|
|
+ (org-contacts-split-property
|
|
|
+ (or (cdr (assoc-string org-contacts-email-property
|
|
|
+ (nth 2 contact))) "")))
|
|
|
+ ;; If the user has email addresses…
|
|
|
+ if email-list
|
|
|
+ ;; … append a list of USER <EMAIL>.
|
|
|
+ nconc (cl-loop for email in email-list
|
|
|
+ collect (org-contacts-format-email contact-name (org-contacts-strip-link email)))))
|
|
|
(completion-list (org-contacts-all-completions-prefix
|
|
|
string
|
|
|
(org-uniquify completion-list))))
|
|
|
@@ -662,13 +660,13 @@ description."
|
|
|
(let* ((address (org-contacts-gnus-get-name-email))
|
|
|
(name (car address))
|
|
|
(email (cadr address)))
|
|
|
- (cadar (or (org-contacts-filter
|
|
|
- nil
|
|
|
- nil
|
|
|
- (cons org-contacts-email-property (concat "\\b" (regexp-quote email) "\\b")))
|
|
|
- (when name
|
|
|
- (org-contacts-filter
|
|
|
- (concat "^" name "$")))))))
|
|
|
+ (cl-cadar (or (org-contacts-filter
|
|
|
+ nil
|
|
|
+ nil
|
|
|
+ (cons org-contacts-email-property (concat "\\b" (regexp-quote email) "\\b")))
|
|
|
+ (when name
|
|
|
+ (org-contacts-filter
|
|
|
+ (concat "^" name "$")))))))
|
|
|
|
|
|
(defun org-contacts-gnus-article-from-goto ()
|
|
|
"Go to contact in the From address of current Gnus message."
|
|
|
@@ -698,23 +696,23 @@ Format is a string matching the following format specification:
|
|
|
(let ((calendar-date-style 'american)
|
|
|
(entry ""))
|
|
|
(unless format (setq format org-contacts-birthday-format))
|
|
|
- (loop for contact in (org-contacts-filter)
|
|
|
- for anniv = (let ((anniv (cdr (assoc-string
|
|
|
- (or field org-contacts-birthday-property)
|
|
|
- (caddr contact)))))
|
|
|
- (when anniv
|
|
|
- (calendar-gregorian-from-absolute
|
|
|
- (org-time-string-to-absolute anniv))))
|
|
|
- ;; Use `diary-anniversary' to compute anniversary.
|
|
|
- if (and anniv (apply 'diary-anniversary anniv))
|
|
|
- collect (format-spec format
|
|
|
- `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
|
|
|
- (?h . ,(car contact))
|
|
|
- (?y . ,(- (calendar-extract-year date)
|
|
|
- (calendar-extract-year anniv)))
|
|
|
- (?Y . ,(let ((years (- (calendar-extract-year date)
|
|
|
- (calendar-extract-year anniv))))
|
|
|
- (format "%d%s" years (diary-ordinal-suffix years)))))))))
|
|
|
+ (cl-loop for contact in (org-contacts-filter)
|
|
|
+ for anniv = (let ((anniv (cdr (assoc-string
|
|
|
+ (or field org-contacts-birthday-property)
|
|
|
+ (nth 2 contact)))))
|
|
|
+ (when anniv
|
|
|
+ (calendar-gregorian-from-absolute
|
|
|
+ (org-time-string-to-absolute anniv))))
|
|
|
+ ;; Use `diary-anniversary' to compute anniversary.
|
|
|
+ if (and anniv (apply 'diary-anniversary anniv))
|
|
|
+ collect (format-spec format
|
|
|
+ `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
|
|
|
+ (?h . ,(car contact))
|
|
|
+ (?y . ,(- (calendar-extract-year date)
|
|
|
+ (calendar-extract-year anniv)))
|
|
|
+ (?Y . ,(let ((years (- (calendar-extract-year date)
|
|
|
+ (calendar-extract-year anniv))))
|
|
|
+ (format "%d%s" years (diary-ordinal-suffix years)))))))))
|
|
|
|
|
|
(defun org-completing-read-date (prompt collection
|
|
|
&optional predicate require-match initial-input
|
|
|
@@ -995,7 +993,7 @@ to do our best."
|
|
|
|
|
|
(defun org-contacts-vcard-format (contact)
|
|
|
"Formats CONTACT in VCard 3.0 format."
|
|
|
- (let* ((properties (caddr contact))
|
|
|
+ (let* ((properties (nth 2 contact))
|
|
|
(name (org-contacts-vcard-escape (car contact)))
|
|
|
(n (org-contacts-vcard-encode-name name))
|
|
|
(email (cdr (assoc-string org-contacts-email-property properties)))
|
|
|
@@ -1054,15 +1052,15 @@ passed to `org-contacts-export-as-vcard-internal'."
|
|
|
(interactive "P")
|
|
|
(when (called-interactively-p 'any)
|
|
|
(cl-psetf name
|
|
|
- (when name
|
|
|
- (read-string "Contact name: "
|
|
|
- (first (org-contacts-at-point))))
|
|
|
- file
|
|
|
- (when (equal name '(16))
|
|
|
- (read-file-name "File: " nil org-contacts-vcard-file))
|
|
|
- to-buffer
|
|
|
- (when (equal name '(64))
|
|
|
- (read-buffer "Buffer: "))))
|
|
|
+ (when name
|
|
|
+ (read-string "Contact name: "
|
|
|
+ (nth 0 (org-contacts-at-point))))
|
|
|
+ file
|
|
|
+ (when (equal name '(16))
|
|
|
+ (read-file-name "File: " nil org-contacts-vcard-file))
|
|
|
+ to-buffer
|
|
|
+ (when (equal name '(64))
|
|
|
+ (read-buffer "Buffer: "))))
|
|
|
(org-contacts-export-as-vcard-internal name file to-buffer))
|
|
|
|
|
|
(defun org-contacts-export-as-vcard-internal (&optional name file to-buffer)
|
|
|
@@ -1094,9 +1092,9 @@ Requires google-maps-el."
|
|
|
(error "`org-contacts-show-map' requires `google-maps-el'"))
|
|
|
(google-maps-static-show
|
|
|
:markers
|
|
|
- (loop
|
|
|
+ (cl-loop
|
|
|
for contact in (org-contacts-filter name)
|
|
|
- for addr = (cdr (assoc-string org-contacts-address-property (caddr contact)))
|
|
|
+ for addr = (cdr (assoc-string org-contacts-address-property (nth 2 contact)))
|
|
|
if addr
|
|
|
collect (cons (list addr) (list :label (string-to-char (car contact)))))))
|
|
|
|
Aaron Ecay