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:
Aaron Ecay 2015-11-06 12:11:36 +00:00
parent 3fa42fb53f
commit 33c5e0582c

View file

@ -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)))))))