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 e4cd3dd22b
commit ea238b78f8
4 changed files with 178 additions and 180 deletions

View File

@ -30,7 +30,7 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(require 'cl-lib)
(declare-function orgtbl-to-csv "org-table" (table params))
(declare-function julia "ext:ess-julia" (&optional start-args))
@ -228,7 +228,7 @@ current code buffer."
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
(case result-type
(cl-case result-type
(value
(let ((tmp-file (org-babel-temp-file "julia-")))
(org-babel-eval org-babel-julia-command
@ -250,7 +250,7 @@ last statement in BODY, as elisp."
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
(case result-type
(cl-case result-type
(value
(with-temp-buffer
(insert (org-babel-chomp body))

View File

@ -42,7 +42,7 @@
;;; Code:
(require 'ob)
(eval-when-compile (require 'cl))
(require 'cl-lib)
(declare-function orgtbl-to-csv "org-table" (table params))
(declare-function stata "ext:ess-stata" (&optional start-args))
@ -239,7 +239,7 @@ current code buffer."
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
(case result-type
(cl-case result-type
(value
(let ((tmp-file (org-babel-temp-file "stata-")))
(org-babel-eval org-babel-stata-command
@ -261,7 +261,7 @@ last statement in BODY, as elisp."
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
(case result-type
(cl-case result-type
(value
(with-temp-buffer
(insert (org-babel-chomp body))

View File

@ -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
(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 el in collection
for string = (if (listp el) (car el) el)
for start = (when (or (null predicate) (funcall predicate string))
(string-match regexp string))
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))))
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 (return
(replace-regexp-in-string "\\`[ \t\n]*" "" ret))))
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)
(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
(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)))))
;; 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)))))))

View File

@ -92,7 +92,7 @@
;; Initialization
(eval-when-compile (require 'cl))
(require 'cl-lib)
;;; Internal Functions
@ -136,7 +136,7 @@ contains a list of strings to be passed as options to
(defun org-bibtex-citation-p (object)
"Non-nil when OBJECT is a citation."
(case (org-element-type object)
(cl-case (org-element-type object)
(link (equal (org-element-property :type object) "cite"))
(latex-fragment
(string-match "\\`\\\\cite{" (org-element-property :value object)))))