aliens/org-contacts
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

contrib: move a few libraries to cl-lib in place of compile-time cl.

Browse source 
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
1 changed files with 170 additions and 172 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

58
org-contacts.el
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,7 +314,7 @@ 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
@ -344,7 +342,7 @@ 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
@ -359,8 +357,8 @@ prefixes rather than just the beginning of the string."
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
@ -370,7 +368,7 @@ prefixes rather than just the beginning of the 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)
@ -430,7 +428,7 @@ 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)))
@ -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,7 +469,7 @@ 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))
@ -485,7 +483,7 @@ prefixes rather than just the beginning of the string."
'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,7 +518,7 @@ 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
@ -530,7 +528,7 @@ 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
@ -541,7 +539,7 @@ A group FOO is composed of contacts with the tag FOO."
(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))
@ -565,23 +563,23 @@ 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))
@ -603,7 +601,7 @@ description."
"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)
@ -612,17 +610,17 @@ description."
;; 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
@ -662,7 +660,7 @@ 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")))
@ -698,10 +696,10 @@ 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))))
@ -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)))
@ -1056,7 +1054,7 @@ passed to `org-contacts-export-as-vcard-internal'."
(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))
@ -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)))))))