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