daniel/emacs-conf
1
2
Fork 0
Code Issues 7 Pull Requests Projects Releases Wiki Activity

update packages

Browse Source
This commit is contained in:
Daniel Weschke
2025-02-26 20:16:44 +01:00
parent 59db017445
commit 45d49daef0
291 changed files with 16240 additions and 522600 deletions
Download Patch File Download Diff File Expand all files Collapse all files
lisp/all-the-icons/all-the-icons-pkg.el
+2 -2
View File
@@ -1,6 +1,6 @@
(define-package "all-the-icons" "20230909.2053" "A library for inserting Developer icons"
(define-package "all-the-icons" "20240623.1800" "A library for inserting Developer icons"
'((emacs "24.3"))
:commit "be9d5dcda9c892e8ca1535e288620eec075eb0be" :authors
:commit "39ef44f810c34e8900978788467cc675870bcd19" :authors
'(("Dominic Charlesworth" . "dgc336@gmail.com"))
:maintainers
'(("Dominic Charlesworth" . "dgc336@gmail.com"))
lisp/all-the-icons/all-the-icons.el
+12 -3
View File
@@ -168,6 +168,12 @@
("dll" all-the-icons-faicon "cogs" :face all-the-icons-silver)
("ds_store" all-the-icons-faicon "cogs" :face all-the-icons-silver)
;; Source Codes
("ada" all-the-icons-fileicon "ada" :v-adjust 0.0 :face all-the-icons-blue)
("adb" all-the-icons-fileicon "ada" :v-adjust 0.0 :face all-the-icons-blue)
("adc" all-the-icons-fileicon "ada" :v-adjust 0.0 :face all-the-icons-blue)
("ads" all-the-icons-fileicon "ada" :v-adjust 0.0 :face all-the-icons-blue)
("gpr" all-the-icons-fileicon "ada" :v-adjust 0.0 :face all-the-icons-green)
("cgpr" all-the-icons-fileicon "ada" :v-adjust 0.0 :face all-the-icons-green)
("scpt" all-the-icons-fileicon "apple" :face all-the-icons-pink)
("aup" all-the-icons-fileicon "audacity" :face all-the-icons-yellow)
("elm" all-the-icons-fileicon "elm" :face all-the-icons-blue)
@@ -184,7 +190,6 @@
("eclass" all-the-icons-fileicon "gentoo" :face all-the-icons-blue)
("go" all-the-icons-fileicon "go" :height 1.0 :face all-the-icons-blue)
("jl" all-the-icons-fileicon "julia" :face all-the-icons-purple :v-adjust 0.0)
("magik" all-the-icons-faicon "magic" :face all-the-icons-blue)
("matlab" all-the-icons-fileicon "matlab" :face all-the-icons-orange)
("nix" all-the-icons-fileicon "nix" :face all-the-icons-blue)
("pl" all-the-icons-alltheicon "perl" :face all-the-icons-lorange)
@@ -683,6 +688,8 @@ for performance sake.")
(perl-mode all-the-icons-alltheicon "perl" :face all-the-icons-lorange)
(cperl-mode all-the-icons-alltheicon "perl" :face all-the-icons-lorange)
(php-mode all-the-icons-fileicon "php" :face all-the-icons-lsilver)
(php-ts-mode all-the-icons-fileicon "php" :face all-the-icons-lsilver)
(phps-mode all-the-icons-fileicon "php" :face all-the-icons-lsilver)
(prolog-mode all-the-icons-alltheicon "prolog" :height 1.1 :face all-the-icons-lmaroon)
(python-mode all-the-icons-alltheicon "python" :height 1.0 :face all-the-icons-dblue)
(python-ts-mode all-the-icons-alltheicon "python" :height 1.0 :face all-the-icons-dblue)
@@ -695,6 +702,10 @@ for performance sake.")
(scheme-mode all-the-icons-fileicon "scheme" :height 1.2 :face all-the-icons-red)
(swift-mode all-the-icons-alltheicon "swift" :height 1.0 :v-adjust -0.1 :face all-the-icons-green)
(svelte-mode all-the-icons-fileicon "svelte" :v-adjust 0.0 :face all-the-icons-red)
(ada-mode all-the-icons-fileicon "ada" :v-adjust 0.0 :face all-the-icons-blue)
(ada-ts-mode all-the-icons-fileicon "ada" :v-adjust 0.0 :face all-the-icons-blue)
(gpr-mode all-the-icons-fileicon "ada" :v-adjust 0.0 :face all-the-icons-green)
(gpr-ts-mode all-the-icons-fileicon "ada" :v-adjust 0.0 :face all-the-icons-green)
(c-mode all-the-icons-alltheicon "c-line" :face all-the-icons-blue)
(c-ts-mode all-the-icons-alltheicon "c-line" :face all-the-icons-blue)
(c++-mode all-the-icons-alltheicon "cplusplus-line" :v-adjust -0.2 :face all-the-icons-blue)
@@ -773,8 +784,6 @@ for performance sake.")
(emms-tag-editor-mode all-the-icons-faicon "music" :face all-the-icons-silver)
(emms-playlist-mode all-the-icons-faicon "music" :face all-the-icons-silver)
(lilypond-mode all-the-icons-faicon "music" :face all-the-icons-green)
(magik-session-mode all-the-icons-alltheicon "terminal" :face all-the-icons-blue)
(magik-cb-mode all-the-icons-faicon "book" :face all-the-icons-blue)
(meson-mode all-the-icons-fileicon "meson" :face all-the-icons-purple)
(man-common all-the-icons-fileicon "man-page" :face all-the-icons-blue)
(ess-r-mode all-the-icons-fileicon "R" :face all-the-icons-lblue)))
lisp/all-the-icons/data/data-fileicons.el
+1 -1
View File
@@ -312,7 +312,7 @@
( "objective-j" . "\xe99e" )
( "ocaml" . "\xe91a" )
( "octave" . "\xea33" )
( "odin" . "\eb36" )
( "odin" . "\xeb36" )
( "onenote" . "\xe9eb" )
( "ooc" . "\xe9cb" )
( "opa" . "\x2601" )
lisp/anaconda-mode/anaconda-mode-pkg.el
+2 -2
View File
@@ -1,10 +1,10 @@
(define-package "anaconda-mode" "20230821.2131" "Code navigation, documentation lookup and completion for Python"
(define-package "anaconda-mode" "20231123.1806" "Code navigation, documentation lookup and completion for Python"
'((emacs "25.1")
(pythonic "0.1.0")
(dash "2.6.0")
(s "1.9")
(f "0.16.2"))
:commit "9dbd65b034cef519c01f63703399ae59651f85ca" :authors
:commit "92a6295622df7fae563d6b599e2dc8640e940ddf" :authors
'(("Artem Malyshev" . "proofit404@gmail.com"))
:maintainers
'(("Artem Malyshev" . "proofit404@gmail.com"))
lisp/anaconda-mode/anaconda-mode.el
+2 -2
View File
@@ -4,7 +4,7 @@
;; Author: Artem Malyshev <proofit404@gmail.com>
;; URL: https://github.com/proofit404/anaconda-mode
;; Version: 0.1.15
;; Version: 0.1.16
;; Package-Requires: ((emacs "25.1") (pythonic "0.1.0") (dash "2.6.0") (s "1.9") (f "0.16.2"))
;; Keywords: convenience anaconda
@@ -94,7 +94,7 @@
(declare-function posframe-show "posframe")
;;; Server.
(defvar anaconda-mode-server-version "0.1.15"
(defvar anaconda-mode-server-version "0.1.16"
"Server version needed to run `anaconda-mode'.")
(defvar anaconda-mode-process-name "anaconda-mode"
lisp/anaconda-mode/anaconda-mode.py
+1 -1
View File
@@ -25,7 +25,7 @@ if IS_PY2:
jedi_dep = ('jedi', '0.17.2')
server_directory += '-py2'
else:
jedi_dep = ('jedi', '0.18.1')
jedi_dep = ('jedi', '0.19.1')
server_directory += '-py3'
service_factory_dep = ('service_factory', '0.1.6')
lisp/async/async-bytecomp.el
+51 -53
View File
@@ -22,17 +22,22 @@
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; This package provide the `async-byte-recompile-directory' function
;; which allows, as the name says to recompile a directory outside of
;; your running emacs.
;; The benefit is your files will be compiled in a clean environment without
;; the old *.el files loaded.
;; Among other things, this fix a bug in package.el which recompile
;; the new files in the current environment with the old files loaded, creating
;; errors in most packages after upgrades.
;; your running emacs. Single files can be compiled with
;; `async-byte-compile-file'. The benefit is your files will be
;; compiled in a clean environment without the old *.el files
;; loaded. A mode `async-bytecomp-package-mode' is provided to
;; automatically compile packages asynchronously when installing or
;; upgrading, among other things, this fix a bug in package.el which
;; recompile the new files in the current environment with the old
;; files loaded, creating errors in most packages after upgrades.
;;
;; NB: This package is advicing the function `package--compile'.
;; NB: This package is advising the function `package--compile' when
;; `async-bytecomp-package-mode' is enabled. This mode is useful
;; only when using a synchronous package manager (e.g. M-x
;; list-package), users of M-x helm-packages don't need this anymore.
;;; Code:
@@ -60,6 +65,33 @@ all packages are always compiled asynchronously."
(defvar async-bytecomp-load-variable-regexp "\\`load-path\\'"
"The variable used by `async-inject-variables' when (re)compiling async.")
(defun async-bytecomp--file-to-comp-buffer (file-or-dir &optional quiet type)
(let ((bn (file-name-nondirectory file-or-dir))
(action-name (pcase type
('file "File")
('directory "Directory"))))
(if (file-exists-p async-byte-compile-log-file)
(let ((buf (get-buffer-create byte-compile-log-buffer))
(n 0))
(with-current-buffer buf
(goto-char (point-max))
(let ((inhibit-read-only t))
(insert-file-contents async-byte-compile-log-file)
(compilation-mode))
(display-buffer buf)
(delete-file async-byte-compile-log-file)
(unless quiet
(save-excursion
(goto-char (point-min))
(while (re-search-forward "^.*:Error:" nil t)
(cl-incf n)))
(if (> n 0)
(message "Failed to compile %d files in directory `%s'" n bn)
(message "%s `%s' compiled asynchronously with warnings"
action-name bn)))))
(unless quiet
(message "%s `%s' compiled asynchronously with success" action-name bn)))))
;;;###autoload
(defun async-byte-recompile-directory (directory &optional quiet)
"Compile all *.el files in DIRECTORY asynchronously.
@@ -73,26 +105,7 @@ All *.elc files are systematically deleted before proceeding."
(load "async")
(let ((call-back
(lambda (&optional _ignore)
(if (file-exists-p async-byte-compile-log-file)
(let ((buf (get-buffer-create byte-compile-log-buffer))
(n 0))
(with-current-buffer buf
(goto-char (point-max))
(let ((inhibit-read-only t))
(insert-file-contents async-byte-compile-log-file)
(compilation-mode))
(display-buffer buf)
(delete-file async-byte-compile-log-file)
(unless quiet
(save-excursion
(goto-char (point-min))
(while (re-search-forward "^.*:Error:" nil t)
(cl-incf n)))
(if (> n 0)
(message "Failed to compile %d files in directory `%s'" n directory)
(message "Directory `%s' compiled asynchronously with warnings" directory)))))
(unless quiet
(message "Directory `%s' compiled asynchronously with success" directory))))))
(async-bytecomp--file-to-comp-buffer directory quiet 'directory))))
(async-start
`(lambda ()
(require 'bytecomp)
@@ -140,13 +153,10 @@ All *.elc files are systematically deleted before proceeding."
(memq cur-package (async-bytecomp--get-package-deps
async-bytecomp-allowed-packages)))
(progn
;; FIXME: Why do we use (eq cur-package 'async) once
;; and (string= cur-package "async") afterwards?
(when (eq cur-package 'async)
(fmakunbound 'async-byte-recompile-directory))
;; Add to `load-path' the latest version of async and
;; reload it when reinstalling async.
(when (string= cur-package "async")
(fmakunbound 'async-byte-recompile-directory)
;; Add to `load-path' the latest version of async and
;; reload it when reinstalling async.
(cl-pushnew pkg-dir load-path)
(load "async-bytecomp"))
;; `async-byte-recompile-directory' will add directory
@@ -158,7 +168,10 @@ All *.elc files are systematically deleted before proceeding."
(define-minor-mode async-bytecomp-package-mode
"Byte compile asynchronously packages installed with package.el.
Async compilation of packages can be controlled by
`async-bytecomp-allowed-packages'."
`async-bytecomp-allowed-packages'.
NOTE: Use this mode only if you install/upgrade etc... your packages
synchronously, if you use a package manager like helm-package.el which
by default is async you don't need this."
:group 'async
:global t
(if async-bytecomp-package-mode
@@ -173,28 +186,13 @@ Same as `byte-compile-file' but asynchronous."
(interactive "fFile: ")
(let ((call-back
(lambda (&optional _ignore)
(let ((bn (file-name-nondirectory file)))
(if (file-exists-p async-byte-compile-log-file)
(let ((buf (get-buffer-create byte-compile-log-buffer))
start)
(with-current-buffer buf
(goto-char (setq start (point-max)))
(let ((inhibit-read-only t))
(insert-file-contents async-byte-compile-log-file)
(compilation-mode))
(display-buffer buf)
(delete-file async-byte-compile-log-file)
(save-excursion
(goto-char start)
(if (re-search-forward "^.*:Error:" nil t)
(message "Failed to compile `%s'" bn)
(message "`%s' compiled asynchronously with warnings" bn)))))
(message "`%s' compiled asynchronously with success" bn))))))
(async-bytecomp--file-to-comp-buffer file nil 'file))))
(async-start
`(lambda ()
(require 'bytecomp)
,(async-inject-variables async-bytecomp-load-variable-regexp)
(let ((default-directory ,(file-name-directory file)))
(let ((default-directory ,(file-name-directory file))
error-data)
(add-to-list 'load-path default-directory)
(byte-compile-file ,file)
(when (get-buffer byte-compile-log-buffer)
lisp/async/async-package.el
+145
View File
@@ -0,0 +1,145 @@
;;; async-package.el --- Fetch packages asynchronously -*- lexical-binding: t -*-
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; Author: Thierry Volpiatto <thievol@posteo.net>
;; Keywords: dired async byte-compile package
;; X-URL: https://github.com/jwiegley/emacs-async
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Provide the function `async-package-do-action' to
;; (re)install/upgrade packages asynchronously.
;;; Code:
(eval-when-compile (require 'cl-lib))
(require 'async-bytecomp)
(require 'dired-async)
(require 'package)
(define-minor-mode async-package--modeline-mode
"Notify mode-line that an async process run."
:group 'async
:global t
:lighter (:eval (propertize (format " [%s async job Installing package(s)]"
(length (dired-async-processes
'async-pkg-install)))
'face 'async-package-message))
(unless async-package--modeline-mode
(let ((visible-bell t)) (ding))))
(defvar async-pkg-install-after-hook nil
"Hook that run after package installation.
The hook runs in the call-back once installation is done in child emacs.")
(defface async-package-message
'((t (:foreground "yellow")))
"Face used for mode-line message."
:group 'async)
(defun async-package-do-action (action packages error-file)
"Execute ACTION asynchronously on PACKAGES.
Argument ACTION can be one of \\='install, \\='upgrade, \\='reinstall.
Argument PACKAGES is a list of packages (symbols).
Argument ERROR-FILE is the file where errors are logged, if some."
(require 'async-bytecomp)
(let ((fn (pcase action
('install 'package-install)
('upgrade 'package-upgrade)
('reinstall 'package-reinstall)))
(action-string (pcase action
('install "Installing")
('upgrade "Upgrading")
('reinstall "Reinstalling"))))
(message "%s %s package(s)..." action-string (length packages))
(process-put
(async-start
`(lambda ()
(require 'bytecomp)
(setq package-archives ',package-archives
package-pinned-packages ',package-pinned-packages
package-archive-contents ',package-archive-contents
package-user-dir ,package-user-dir
package-alist ',package-alist
load-path ',load-path)
;; Ensure `async-bytecomp-package-mode' doesn't kick in
;; (issue #194) as some packages may enable it
;; inconditionally. We don't need to compile async as we are
;; already async and in a clean environment.
(require 'async-bytecomp)
(setq async-bytecomp-allowed-packages nil)
(prog1
(condition-case err
(mapc ',fn ',packages)
(error
(with-temp-file ,error-file
(insert
(format
"%S:\n Please refresh package list before %s"
err ,action-string)))))
(let (error-data)
(when (get-buffer byte-compile-log-buffer)
(setq error-data (with-current-buffer byte-compile-log-buffer
(buffer-substring-no-properties
(point-min) (point-max))))
(unless (string= error-data "")
(with-temp-file ,async-byte-compile-log-file
(erase-buffer)
(insert error-data)))))))
(lambda (result)
(if (file-exists-p error-file)
(let ((buf (find-file-noselect error-file)))
(pop-to-buffer
buf '(nil . ((window-height . fit-window-to-buffer))))
(special-mode)
(delete-file error-file)
(async-package--modeline-mode -1))
(when result
(let ((pkgs (if (listp result) result (list result))))
(when (eq action 'install)
(customize-save-variable
'package-selected-packages
(delete-dups (append pkgs package-selected-packages))))
(package-load-all-descriptors) ; refresh package-alist.
(mapc #'package-activate pkgs) ; load packages.
(async-package--modeline-mode -1)
(message "%s %s packages done" action-string (length packages))
(run-with-timer
0.1 nil
(lambda (lst str)
(dired-async-mode-line-message
"%s %d package(s) done"
'async-package-message
str (length lst)))
packages action-string)
(when (file-exists-p async-byte-compile-log-file)
(let ((buf (get-buffer-create byte-compile-log-buffer)))
(with-current-buffer buf
(goto-char (point-max))
(let ((inhibit-read-only t))
(insert-file-contents async-byte-compile-log-file)
(compilation-mode))
(display-buffer buf)
(delete-file async-byte-compile-log-file)))))))
(run-hooks 'async-pkg-install-after-hook)))
'async-pkg-install t)
(async-package--modeline-mode 1)))
(provide 'async-package)
;;; async-package.el ends here
lisp/async/async-pkg.el
+2 -2
View File
@@ -1,6 +1,6 @@
(define-package "async" "20230528.622" "Asynchronous processing in Emacs"
(define-package "async" "20241126.810" "Asynchronous processing in Emacs"
'((emacs "24.4"))
:commit "3ae74c0a4ba223ba373e0cb636c385e08d8838be" :authors
:commit "b99658e831bc7e7d20ed4bb0a85bdb5c7dd74142" :authors
'(("John Wiegley" . "jwiegley@gmail.com"))
:maintainers
'(("Thierry Volpiatto" . "thievol@posteo.net"))
lisp/async/async.el
+58 -14
View File
@@ -6,7 +6,7 @@
;; Maintainer: Thierry Volpiatto <thievol@posteo.net>
;; Created: 18 Jun 2012
;; Version: 1.9.7
;; Version: 1.9.9
;; Package-Requires: ((emacs "24.4"))
;; Keywords: async
@@ -34,6 +34,8 @@
(eval-when-compile (require 'cl-lib))
(defvar tramp-password-prompt-regexp)
(defgroup async nil
"Simple asynchronous processing in Emacs"
:group 'lisp)
@@ -42,6 +44,19 @@
"Default function to remove text properties in variables."
:type 'function)
(defcustom async-prompt-for-password t
"Prompt for password in parent Emacs if needed when non nil.
When this is nil child Emacs will hang forever when a user interaction
for password is required unless a password is stored in a \".authinfo\" file."
:type 'boolean)
(defvar async-process-noquery-on-exit nil
"Used as the :noquery argument to `make-process'.
Intended to be let-bound around a call to `async-start' or
`async-start-process'. If non-nil, the child Emacs process will
be silently killed if the user exits the parent Emacs.")
(defvar async-debug nil)
(defvar async-send-over-pipe t)
(defvar async-in-child-emacs nil)
@@ -102,14 +117,17 @@ is returned unmodified."
collect elm))
(t object)))
(defvar async-inject-variables-exclude-regexps '("-syntax-table\\'")
"A list of regexps that `async-inject-variables' should ignore.")
(defun async-inject-variables
(include-regexp &optional predicate exclude-regexp noprops)
"Return a `setq' form that replicates part of the calling environment.
It sets the value for every variable matching INCLUDE-REGEXP and
also PREDICATE. It will not perform injection for any variable
matching EXCLUDE-REGEXP (if present) or representing a `syntax-table'
i.e. ending by \"-syntax-table\".
matching EXCLUDE-REGEXP (if present) and variables matching one of
`async-inject-variables-exclude-regexps'.
When NOPROPS is non nil it tries to strip out text properties of each
variable's value with `async-variables-noprops-function'.
@@ -128,14 +146,16 @@ It is intended to be used as follows:
,@(let (bindings)
(mapatoms
(lambda (sym)
(let* ((sname (and (boundp sym) (symbol-name sym)))
(value (and sname (symbol-value sym))))
(let ((sname (and (boundp sym) (symbol-name sym)))
value)
(when (and sname
(or (null include-regexp)
(string-match include-regexp sname))
(or (null exclude-regexp)
(not (string-match exclude-regexp sname)))
(not (string-match "-syntax-table\\'" sname)))
(cl-loop for re in async-inject-variables-exclude-regexps
never (string-match-p re sname)))
(setq value (symbol-value sym))
(unless (or (stringp value)
(memq value '(nil t))
(numberp value)
@@ -207,7 +227,7 @@ It is intended to be used as follows:
(process-name proc) (process-exit-status proc))))
(set (make-local-variable 'async-callback-value-set) t))))))
(defun async-read-from-client (proc string)
(defun async-read-from-client (proc string &optional prompt-for-pwd)
"Process text from client process.
The string chunks usually arrive in maximum of 4096 bytes, so a
@@ -217,8 +237,18 @@ function.
We use a marker `async-read-marker' to track the position of the
lasts complete line. Every time we get new input, we try to look
for newline, and if found, process the entire line and bump the
marker position to the end of this next line."
marker position to the end of this next line.
Argument PROMPT-FOR-PWD allow binding lexically the value of
`async-prompt-for-password', if unspecified its global value
is used."
(with-current-buffer (process-buffer proc)
(when (and prompt-for-pwd
(boundp 'tramp-password-prompt-regexp)
tramp-password-prompt-regexp
(string-match tramp-password-prompt-regexp string))
(process-send-string
proc (concat (read-passwd (match-string 0 string)) "\n")))
(goto-char (point-max))
(save-excursion
(insert string))
@@ -350,7 +380,7 @@ its FINISH-FUNC is nil."
(plist-get value :async-message)))
(defun async-send (process-or-key &rest args)
"Send the given message to the asychronous child or parent Emacs.
"Send the given message to the asynchronous child or parent Emacs.
To send messages from the parent to a child, PROCESS-OR-KEY is
the child process object. ARGS is a plist. Example:
@@ -402,12 +432,14 @@ finished. Set DEFAULT-DIRECTORY to change PROGRAM's current
working directory."
(let* ((buf (generate-new-buffer (concat "*" name "*")))
(buf-err (generate-new-buffer (concat "*" name ":err*")))
(prt-for-pwd async-prompt-for-password)
(proc (let ((process-connection-type nil))
(make-process
:name name
:buffer buf
:stderr buf-err
:command (cons program program-args)))))
:command (cons program program-args)
:noquery async-process-noquery-on-exit))))
(set-process-sentinel
(get-buffer-process buf-err)
(lambda (proc _change)
@@ -418,9 +450,12 @@ working directory."
(set (make-local-variable 'async-read-marker)
(set-marker (make-marker) (point-min) buf))
(set-marker-insertion-type async-read-marker nil)
(set-process-sentinel proc #'async-when-done)
(set-process-filter proc #'async-read-from-client)
;; Pass the value of `async-prompt-for-password' to the process
;; filter fn through the lexical local var prt-for-pwd (Issue#182).
(set-process-filter proc (lambda (proc string)
(async-read-from-client
proc string prt-for-pwd)))
(unless (string= name "emacs")
(set (make-local-variable 'async-callback-for-process) t))
proc)))
@@ -431,11 +466,20 @@ Can be one of \"-Q\" or \"-q\".
Default is \"-Q\" but it is sometimes useful to use \"-q\" to have a
enhanced config or some more variables loaded.")
(defvar async-library nil
"Cache async library path.
It is useful only when you run multiple async processes in a loop, to
avoid calling many times `locate-library' which is costly.
This variable should be let bound around an `async-start' call and not
used globally. Should be found with `locate-library'.")
(defun async--emacs-program-args (&optional sexp)
"Return a list of arguments for invoking the child Emacs."
;; Using `locate-library' ensure we use the right file
;; when the .elc have been deleted.
(let ((args (list async-quiet-switch "-l" (locate-library "async"))))
;; when the .elc have been deleted, its result can be cached in
;; `async-library' see Issue#193.
(let ((args (list async-quiet-switch "-l" (or async-library
(locate-library "async")))))
(when async-child-init
(setq args (append args (list "-l" async-child-init))))
(append args (list "-batch" "-f" "async-batch-invoke"
lisp/async/dired-async.el
+35 -11
View File
@@ -81,6 +81,10 @@ or rename for `dired-async-skip-fast'."
:risky t
:type 'integer)
(defcustom dired-async-large-file-warning-threshold large-file-warning-threshold
"Same as `large-file-warning-threshold' but for dired-async."
:type 'integer)
(defface dired-async-message
'((t (:foreground "yellow")))
"Face used for mode-line message.")
@@ -115,9 +119,9 @@ or rename for `dired-async-skip-fast'."
(sit-for 3)
(force-mode-line-update)))
(defun dired-async-processes ()
(defun dired-async-processes (&optional propname)
(cl-loop for p in (process-list)
when (process-get p 'dired-async-process)
when (process-get p (or propname 'dired-async-process))
collect p))
(defun dired-async-kill-process ()
@@ -242,6 +246,14 @@ cases if `dired-async-skip-fast' is non-nil."
(funcall old-func file-creator operation
(nreverse quick-list) name-constructor marker-char))))
(defun dired-async--abort-if-file-too-large (size op-type filename)
"Warn when FILENAME larger than `dired-async-large-file-warning-threshold'.
Same as `abort-if-file-too-large' but without user-error."
(when (and dired-async-large-file-warning-threshold size
(> size dired-async-large-file-warning-threshold))
(files--ask-user-about-large-file
size op-type filename nil)))
(defvar overwrite-query)
(defun dired-async-create-files (file-creator operation fn-list name-constructor
&optional _marker-char)
@@ -299,14 +311,22 @@ ESC or `q' to not overwrite any of the remaining files,
(file-in-directory-p destname from)
(error "Cannot copy `%s' into its subdirectory `%s'"
from to)))
(if overwrite
(or (and dired-overwrite-confirmed
(push (cons from to) async-fn-list))
(progn
(push (dired-make-relative from) failures)
(dired-log "%s `%s' to `%s' failed\n"
operation from to)))
(push (cons from to) async-fn-list)))))
;; Skip file if it is too large.
(if (and (member operation '("Copy" "Rename"))
(eq (dired-async--abort-if-file-too-large
(file-attribute-size
(file-attributes (file-truename from)))
(downcase operation) from)
'abort))
(push from skipped)
(if overwrite
(or (and dired-overwrite-confirmed
(push (cons from to) async-fn-list))
(progn
(push (dired-make-relative from) failures)
(dired-log "%s `%s' to `%s' failed\n"
operation from to)))
(push (cons from to) async-fn-list))))))
;; Fix tramp issue #80 with emacs-26, use "-q" only when needed.
(setq async-quiet-switch
(if (and (boundp 'tramp-cache-read-persistent-data)
@@ -361,10 +381,14 @@ ESC or `q' to not overwrite any of the remaining files,
(async-start `(lambda ()
(require 'cl-lib) (require 'dired-aux) (require 'dired-x)
,(async-inject-variables dired-async-env-variables-regexp)
(advice-add #'files--ask-user-about-large-file
:override (lambda (&rest args) nil))
(let ((dired-recursive-copies (quote always))
(dired-copy-preserve-time
,dired-copy-preserve-time)
(dired-create-destination-dirs ',create-dir))
(dired-create-destination-dirs ',create-dir)
(dired-vc-rename-file ,dired-vc-rename-file)
auth-source-save-behavior)
(setq overwrite-backup-query nil)
;; Inline `backup-file' as long as it is not
;; available in emacs.
lisp/avy/avy-pkg.el
+2 -2
View File
@@ -1,7 +1,7 @@
(define-package "avy" "20230420.404" "Jump to arbitrary positions in visible text and select text quickly."
(define-package "avy" "20241101.1357" "Jump to arbitrary positions in visible text and select text quickly."
'((emacs "24.1")
(cl-lib "0.5"))
:commit "be612110cb116a38b8603df367942e2bb3d9bdbe" :authors
:commit "933d1f36cca0f71e4acb5fac707e9ae26c536264" :authors
'(("Oleh Krehel" . "ohwoeowho@gmail.com"))
:maintainers
'(("Oleh Krehel" . "ohwoeowho@gmail.com"))
lisp/avy/avy.el
+24 -24
View File
@@ -26,22 +26,22 @@
;;; Commentary:
;;
;; With Avy, you can move point to any position in Emacs – even in a
;; different window – using very few keystrokes. For this, you look at
;; different window – using very few keystrokes. For this, you look at
;; the position where you want point to be, invoke Avy, and then enter
;; the sequence of characters displayed at that position.
;;
;; If the position you want to jump to can be determined after only
;; issuing a single keystroke, point is moved to the desired position
;; immediately after that keystroke. In case this isn't possible, the
;; immediately after that keystroke. In case this isn't possible, the
;; sequence of keystrokes you need to enter is comprised of more than
;; one character. Avy uses a decision tree where each candidate position
;; one character. Avy uses a decision tree where each candidate position
;; is a leaf and each edge is described by a character which is distinct
;; per level of the tree. By entering those characters, you navigate the
;; per level of the tree. By entering those characters, you navigate the
;; tree, quickly arriving at the desired candidate position, such that
;; Avy can move point to it.
;;
;; Note that this only makes sense for positions you are able to see
;; when invoking Avy. These kinds of positions are supported:
;; when invoking Avy. These kinds of positions are supported:
;;
;; * character positions
;; * word or subword start positions
@@ -99,7 +99,7 @@ keys different than the following: a, e, i, o, u, y"
(function :tag "Other command")))
(defcustom avy-keys-alist nil
"Alist of avy-jump commands to `avy-keys' overriding the default `avy-keys'."
"Alist of `avy-jump' commands to `avy-keys' overriding the default `avy-keys'."
:type `(alist
:key-type ,avy--key-type
:value-type (repeat :tag "Keys" character)))
@@ -156,27 +156,27 @@ Use `avy-styles-alist' to customize this per-command."
(const :tag "Words" words)))
(defcustom avy-styles-alist nil
"Alist of avy-jump commands to the style for each command.
"Alist of `avy-jump' commands to the style for each command.
If the commands isn't on the list, `avy-style' is used."
:type '(alist
:key-type (choice :tag "Command"
(const avy-goto-char)
(const avy-goto-char-2)
(const avy-isearch)
(const avy-goto-line)
(const avy-goto-subword-0)
(const avy-goto-subword-1)
(const avy-goto-word-0)
(const avy-goto-word-1)
(const avy-copy-line)
(const avy-copy-region)
(const avy-move-line)
(const avy-move-region)
(const avy-kill-whole-line)
(const avy-kill-region)
(const avy-kill-ring-save-whole-line)
(const avy-kill-ring-save-region)
(function :tag "Other command"))
(const avy-goto-char)
(const avy-goto-char-2)
(const avy-isearch)
(const avy-goto-line)
(const avy-goto-subword-0)
(const avy-goto-subword-1)
(const avy-goto-word-0)
(const avy-goto-word-1)
(const avy-copy-line)
(const avy-copy-region)
(const avy-move-line)
(const avy-move-region)
(const avy-kill-whole-line)
(const avy-kill-region)
(const avy-kill-ring-save-whole-line)
(const avy-kill-ring-save-region)
(function :tag "Other command"))
:value-type (choice
(const :tag "Pre" pre)
(const :tag "At" at)
lisp/biblio/biblio-pkg.el
+5 -3
View File
@@ -1,7 +1,9 @@
(define-package "biblio" "20230202.1721" "Browse and import bibliographic references from CrossRef, arXiv, DBLP, HAL, Dissemin, and doi.org"
(define-package "biblio" "20250102.1345" "Browse and import bibliographic references and BibTeX records from CrossRef, arXiv, DBLP, HAL, IEEE Xplore, Dissemin, and doi.org"
'((emacs "24.3")
(biblio-core "0.2"))
:commit "ee52f6cda82ea6fbc3b400e7b12132595cc0374c" :authors
(biblio-core "0.3"))
:commit "b700f0f2929829b2ca971511c5ebe61c67027e9f" :authors
'(("Clément Pit-Claudel" . "clement.pitclaudel@live.com"))
:maintainers
'(("Clément Pit-Claudel" . "clement.pitclaudel@live.com"))
:maintainer
'("Clément Pit-Claudel" . "clement.pitclaudel@live.com")
lisp/bibtex-completion/bibtex-completion-pkg.el
+3 -3
View File
@@ -1,12 +1,12 @@
(define-package "bibtex-completion" "20230918.953" "A BibTeX backend for completion frameworks"
'((parsebib "1.0")
(define-package "bibtex-completion" "20241116.726" "A BibTeX backend for completion frameworks"
'((parsebib "6.0")
(s "1.9.0")
(dash "2.6.0")
(f "0.16.2")
(cl-lib "0.5")
(biblio "0.2")
(emacs "26.1"))
:commit "95551744de8210867e9d34feaf47ae639ea04114" :authors
:commit "6064e8625b2958f34d6d40312903a85c173b5261" :authors
'(("Titus von der Malsburg" . "malsburg@posteo.de")
("Justin Burkett" . "justin@burkett.cc"))
:maintainers
lisp/bibtex-completion/bibtex-completion.el
+46 -33
View File
@@ -5,7 +5,7 @@
;; Maintainer: Titus von der Malsburg <malsburg@posteo.de>
;; URL: https://github.com/tmalsburg/helm-bibtex
;; Version: 1.0.0
;; Package-Requires: ((parsebib "1.0") (s "1.9.0") (dash "2.6.0") (f "0.16.2") (cl-lib "0.5") (biblio "0.2") (emacs "26.1"))
;; Package-Requires: ((parsebib "6.0") (s "1.9.0") (dash "2.6.0") (f "0.16.2") (cl-lib "0.5") (biblio "0.2") (emacs "26.1"))
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -77,6 +77,20 @@ composed of the BibTeX-key plus a \".pdf\" suffix."
:group 'bibtex-completion
:type '(choice directory (repeat directory)))
;; From https://github.com/mwlodarczak/helm-bibtex/commit/4a421cae9b7d4cdb4a0933080633564b1774addb
(defcustom bibtex-completion-watch-bibliography t
"If non-nil (the default) the bibliography is reloaded
proactively every time any of the BibTeX files changes.
Changing the value of this variable after you load helm-bibtex
has no effect: if you load helm-bibtex with this variable
set to t and then decide you do not want to proactively reload the
bibliography, you have to restart Emacs with the new setting
(and likewise for loading helm-bibtex with the variable set to nil
and later deciding you want to proactively reload the bibliography)."
:group 'bibtex-completion
:type 'boolean)
(defcustom bibtex-completion-pdf-open-function 'find-file
"The function used for opening PDF files.
This can be an arbitrary function that takes one argument: the
@@ -114,6 +128,7 @@ This should be a single character."
(defcustom bibtex-completion-format-citation-functions
'((org-mode . bibtex-completion-format-citation-ebib)
(latex-mode . bibtex-completion-format-citation-cite)
(LaTeX-mode . bibtex-completion-format-citation-cite)
(markdown-mode . bibtex-completion-format-citation-pandoc-citeproc)
(python-mode . bibtex-completion-format-citation-sphinxcontrib-bibtex)
(rst-mode . bibtex-completion-format-citation-sphinxcontrib-bibtex)
@@ -280,6 +295,7 @@ browser in `helm-browse-url-default-browser-alist'"
"Autocite" "autocite*" "Autocite*" "citeauthor" "Citeauthor"
"citeauthor*" "Citeauthor*" "citetitle" "citetitle*" "citeyear"
"citeyear*" "citedate" "citedate*" "citeurl" "nocite" "fullcite"
"citet" "citep" "citet*" "citep*"
"footfullcite" "notecite" "Notecite" "pnotecite" "Pnotecite"
"fnotecite")
"The list of LaTeX cite commands.
@@ -414,15 +430,16 @@ Also sets `bibtex-completion-display-formats-internal'."
;; watches for automatic reloading of the bibliography when a file
;; is changed:
(mapc (lambda (file)
(if (f-file? file)
(let ((watch-descriptor
(file-notify-add-watch file
'(change)
(lambda (event) (bibtex-completion-candidates)))))
(setq bibtex-completion-file-watch-descriptors
(cons watch-descriptor bibtex-completion-file-watch-descriptors)))
(if (f-file? file)
(if bibtex-completion-watch-bibliography
(let ((watch-descriptor
(file-notify-add-watch file
'(change)
(lambda (event) (bibtex-completion-candidates)))))
(setq bibtex-completion-file-watch-descriptors
(cons watch-descriptor bibtex-completion-file-watch-descriptors))))
(user-error "Bibliography file %s could not be found" file)))
(bibtex-completion-normalize-bibliography))
(bibtex-completion-normalize-bibliography))
;; Pre-calculate minimal widths needed by the format strings for
;; various entry types:
@@ -477,9 +494,10 @@ for string replacement."
for entry-type = (parsebib-find-next-item)
while entry-type
if (string= (downcase entry-type) "string")
collect (let ((entry (parsebib-read-string (point) ht)))
collect (let ((entry (parsebib-read-string ht)))
(puthash (car entry) (cdr entry) ht)
entry))))
entry)
else do (forward-line 1))))
(-filter (lambda (x) x) strings)))
(defun bibtex-completion-update-strings-ht (ht strings)
@@ -667,8 +685,8 @@ If HT-STRINGS is provided it is assumed to be a hash table."
bibtex-completion-additional-search-fields))
for entry-type = (parsebib-find-next-item)
while entry-type
unless (member-ignore-case entry-type '("preamble" "string" "comment"))
collect (let* ((entry (parsebib-read-entry entry-type (point) ht-strings))
if (not (member-ignore-case entry-type '("preamble" "string" "comment")))
collect (let* ((entry (parsebib-read-entry nil ht-strings))
(fields (append
(list (if (assoc-string "author" entry 'case-fold)
"author"
@@ -679,7 +697,8 @@ If HT-STRINGS is provided it is assumed to be a hash table."
fields)))
(-map (lambda (it)
(cons (downcase (car it)) (cdr it)))
(bibtex-completion-prepare-entry entry fields)))))
(bibtex-completion-prepare-entry entry fields)))
else do (forward-line 1)))
(defun bibtex-completion-get-entry (entry-key)
"Given a BibTeX key this function scans all bibliographies listed in `bibtex-completion-bibliography' and returns an alist of the record with that key.
@@ -698,9 +717,10 @@ Fields from crossreferenced entries are appended to the requested entry."
"\\)[[:space:]]*[\(\{][[:space:]]*"
(regexp-quote entry-key) "[[:space:]]*,")
nil t)
(let ((entry-type (match-string 1)))
(progn
(goto-char (match-beginning 0))
(reverse (bibtex-completion-prepare-entry
(parsebib-read-entry entry-type (point) bibtex-completion-string-hash-table) nil do-not-find-pdf)))
(parsebib-read-entry nil bibtex-completion-string-hash-table) nil do-not-find-pdf)))
(progn
(display-warning :warning (concat "Bibtex-completion couldn't find entry with key \"" entry-key "\"."))
nil)))))
@@ -1185,9 +1205,6 @@ string if FIELD is not present in ENTRY and DEFAULT is nil."
("editor-abbrev"
(when-let ((value (bibtex-completion-get-value "editor" entry)))
(bibtex-completion-apa-format-editors-abbrev value)))
((or "journal" "journaltitle")
(or (bibtex-completion-get-value "journal" entry)
(bibtex-completion-get-value "journaltitle" entry)))
(_
;; Real fields:
(let ((value (bibtex-completion-get-value field entry)))
@@ -1214,16 +1231,21 @@ string if FIELD is not present in ENTRY and DEFAULT is nil."
"\\(^[^{]*{\\)\\|\\(}[^{]*{\\)\\|\\(}.*$\\)\\|\\(^[^{}]*$\\)"
(lambda (x) (downcase (s-replace "\\" "\\\\" x)))
value)))))
("booktitle" value)
("journal"
(replace-regexp-in-string "[{}]" "" value))
("booktitle"
(replace-regexp-in-string "[{}]" "" value))
;; Maintain the punctuation and capitalization that is used by
;; the journal in its title.
("pages" (s-join "–" (s-split "[^0-9]+" value t)))
("doi" (s-concat " http://dx.doi.org/" value))
("year" value)
(_ value))
;; If field does not exist, try to retrieve value from
;; alternative field (possibly a biblatex field):
(pcase field
("year" (car (split-string (bibtex-completion-get-value "date" entry "") "-"))))
))))
("year" (car (split-string (bibtex-completion-get-value "date" entry "") "-")))
("journal" (bibtex-completion-get-value "journaltitle" entry "")))))))
default ""))
(defun bibtex-completion-apa-format-authors (value &optional abbrev)
@@ -1303,18 +1325,9 @@ When ABBREV is non-nil, format in abbreviated APA style instead."
(bibtex-completion-apa-format-editors value t))
(defun bibtex-completion-get-value (field entry &optional default)
"Return the value for FIELD in ENTRY or DEFAULT if the value is not defined.
Surrounding curly braces are stripped."
"Return the value for FIELD in ENTRY or DEFAULT if the value is not defined."
(let ((value (cdr (assoc-string field entry 'case-fold))))
(if value
(replace-regexp-in-string
"\\(^[[:space:]]*[\"{][[:space:]]*\\)\\|\\([[:space:]]*[\"}][[:space:]]*$\\)"
""
;; Collapse whitespaces when the content is not a path:
(if (equal bibtex-completion-pdf-field field)
value
(s-collapse-whitespace value)))
default)))
(or value default)))
(defun bibtex-completion-insert-key (keys)
"Insert BibTeX KEYS at point."
lisp/citeproc/citeproc-biblatex.el
+3 -1
View File
@@ -26,6 +26,8 @@
;;; Code:
(require 'parse-time)
(require 'compat)
(require 'citeproc-bibtex)
(defvar citeproc-blt-to-csl-types-alist
@@ -473,7 +475,7 @@ biblatex variables in B."
(citeproc-blt--get-standard 'address b)))
(push (cons csl-place-var ~location) result)))
;; url
(-when-let (url (or (let ((u (alist-get 'url b))) (and u (citeproc-s-replace "\\" "" u)))
(-when-let (url (or (let ((u (alist-get 'url b))) (and u (string-replace "\\" "" u)))
(when-let ((~eprinttype (or (alist-get 'eprinttype b)
(alist-get 'archiveprefix b)))
(~eprint (alist-get 'eprint b))
lisp/citeproc/citeproc-bibtex.el
+2 -1
View File
@@ -32,6 +32,7 @@
(require 's)
(require 'org)
(require 'map)
(require 'compat)
;; Handle the fact that org-bibtex has been renamed to ol-bibtex -- for the time
;; being we support both feature names.
(or (require 'ol-bibtex nil t)
@@ -262,7 +263,7 @@ replacements."
(let ((wo-quotes (if (and (string= (substring s 0 1) "\"")
(string= (substring s -1) "\""))
(substring s 1 -1) s)))
(citeproc-s-replace "\\&" "&" wo-quotes)))
(string-replace "\\&" "&" wo-quotes)))
(defun citeproc-bt--to-csl (s &optional with-nocase)
"Convert a BibTeX field S to a CSL one.
lisp/citeproc/citeproc-cite.el
+39 -3
View File
@@ -1,6 +1,6 @@
;;; citeproc-cite.el --- cite and citation rendering -*- lexical-binding: t; -*-
;; Copyright (C) 2017-2021 András Simonyi
;; Copyright (C) 2017-2024 András Simonyi
;; Author: András Simonyi <andras.simonyi@gmail.com>
@@ -40,6 +40,11 @@
(require 'citeproc-formatters)
(require 'citeproc-sort)
(require 'citeproc-subbibs)
(require 'citeproc-date)
(require 'citeproc-biblatex)
(declare-function citeproc-style-category "citeproc-style" (style))
(cl-defstruct (citeproc-citation (:constructor citeproc-citation-create))
"A struct representing a citation.
@@ -77,6 +82,35 @@ Each function takes a single argument, a rich-text, and returns a
post-processed rich-text value. The functions are applied in the
order they appear in the list.")
(defun citeproc-cite--parse-locator-extra (s)
"Parse extra locator text S into locator-date and locator-extra.
Return a pair (LOCATOR-DATE . LOCATOR-EXTRA) where
- LOCATOR-DATE is a `citeproc-date' struct or nil, and
- LOCATOR-EXTRA is a string or nil."
(let (locator-date locator-extra)
(if (not (string-match-p "^[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}" s))
(setq locator-extra (and (not (s-blank-str-p s)) s))
(setq locator-date (citeproc-date-parse (citeproc-blt--to-csl-date
(substring s 0 10))))
(let ((extra (substring s 10)))
(unless (s-blank-str-p extra) (setq locator-extra extra))))
(cons locator-date locator-extra)))
(defun citeproc-cite--internalize-locator (cite)
"Internalize a CITE struct's locator by parsing it into fields.
If the \"|\" separator is present in the locator then parse it
into `locator', `locator-extra' and `locator-date', and update
CITE with these fields accordingly. Returns the possibly modified
CITE."
(when-let ((locator (alist-get 'locator cite))
(separator-pos (cl-position ?| locator)))
(setf (alist-get 'locator cite) (substring locator 0 separator-pos))
(pcase-let ((`(,locator-date . ,locator-extra) (citeproc-cite--parse-locator-extra
(substring locator (1+ separator-pos)))))
(when locator-date (push (cons 'locator-date locator-date) cite))
(when locator-extra (push (cons 'locator-extra locator-extra) cite))))
cite)
(defun citeproc-cite--varlist (cite)
"Return the varlist belonging to CITE."
(let* ((itd (alist-get 'itd cite))
@@ -87,7 +121,8 @@ order they appear in the list.")
'(label locator suppress-author suppress-date
stop-rendering-at position near-note
first-reference-note-number ignore-et-al
bib-entry locator-only use-short-title))
bib-entry locator-only use-short-title
locator-extra locator-date))
cite)))
(nconc cite-vv item-vv)))
@@ -228,7 +263,8 @@ For the optional INTERNAL-LINKS argument see
(when outer-attrs
(setq result (list outer-attrs result)))
;; Prepend author to textual citations
(when (eq (citeproc-citation-mode c) 'textual)
(when (and (eq (citeproc-citation-mode c) 'textual)
(not (member (citeproc-style-category style) '("numeric" "label"))))
(let* ((first-elt (car cites)) ;; First elt is either a cite or a cite group.
;; If the latter then we need to locate the
;; first cite as the 2nd element of the first
lisp/citeproc/citeproc-context.el
+30 -22
View File
@@ -168,16 +168,6 @@ TYPED RTS is a list of (RICH-TEXT . TYPE) pairs"
"Return the first text associated with TERM in CONTEXT."
(citeproc-term-text-from-terms term (citeproc-context-terms context)))
(defun citeproc-term-inflected-text (term form number context)
"Return the text associated with TERM having FORM and NUMBER."
(let ((matches
(--select (string= term (citeproc-term-name it))
(citeproc-context-terms context))))
(cond ((not matches) nil)
((= (length matches) 1)
(citeproc-term-text (car matches)))
(t (citeproc-term--inflected-text-1 matches form number)))))
(defconst citeproc--term-form-fallback-alist
'((verb-short . verb)
(symbol . short)
@@ -185,17 +175,21 @@ TYPED RTS is a list of (RICH-TEXT . TYPE) pairs"
(short . long))
"Alist containing the fallback form for each term form.")
(defun citeproc-term--inflected-text-1 (matches form number)
(let ((match (--first (and (eq form (citeproc-term-form it))
(or (not (citeproc-term-number it))
(eq number (citeproc-term-number it))))
matches)))
(if match
(citeproc-term-text match)
(citeproc-term--inflected-text-1
matches
(alist-get form citeproc--term-form-fallback-alist)
number))))
(defun citeproc-term-inflected-text (term form number context)
"Return the text associated with TERM having FORM and NUMBER."
(let ((matches
(--select (string= term (citeproc-term-name it))
(citeproc-context-terms context))))
(if (not matches) nil
(let (match)
(while (and (not match) form)
(setq match (--first (and (eq form (citeproc-term-form it))
(or (not (citeproc-term-number it))
(eq number (citeproc-term-number it))))
matches))
(unless match
(setq form (alist-get form citeproc--term-form-fallback-alist))))
(when match (citeproc-term-text match))))))
(defun citeproc-term-get-gender (term context)
"Return the gender of TERM or nil if none is given."
@@ -224,6 +218,20 @@ no internal links should be produced."
;; Else link each cite to the corresponding bib item.
(if (eq mode 'cite) 'cited-item-no 'bib-item-no)))))
(defun citeproc-context-maybe-stop-rendering
(trigger context result &optional var)
"Stop rendering if a (`stop-rendering-at'. TRIGGER) pair is present in CONTEXT.
In case of stopping return with RESULT. If the optional VAR
symbol is non-nil then rendering is stopped only if VAR is eq to
TRIGGER."
(if (and (eq trigger (alist-get 'stop-rendering-at (citeproc-context-vars context)))
(or (not var) (eq var trigger))
(eq (cdr result) 'present-var))
(let ((rt-result (car result)))
(push '(stopped-rendering . t) (car rt-result))
(throw 'stop-rendering (citeproc-rt-render-affixes rt-result)))
result))
(defun citeproc-render-varlist-in-rt (var-alist style mode render-mode &optional
internal-links no-external-links)
"Render an item described by VAR-ALIST with STYLE in rich-text.
@@ -263,7 +271,7 @@ external links."
(citeproc-context-int-link-attrval
style internal-links mode (alist-get 'position var-alist)))
(cite-no-attr-val (cons cite-no-attr
(alist-get 'citation-number var-alist))))
(alist-get 'citation-number var-alist))))
(cond ((consp rendered) (setf (car rendered)
(-snoc (car rendered) cite-no-attr-val)))
((stringp rendered) (setq rendered
lisp/citeproc/citeproc-date.el
+2 -1
View File
@@ -34,6 +34,7 @@
(require 'citeproc-lib)
(require 'citeproc-rt)
(require 'citeproc-context)
(require 'citeproc-number)
(cl-defstruct (citeproc-date (:constructor citeproc-date-create))
"Struct for representing dates.
@@ -94,7 +95,7 @@ Set the remaining slots to the values SEASON and CIRCA."
(cons nil 'empty-vars)))
(cons nil 'empty-vars))))
;; Handle `year' citation mode by stopping if needed
(citeproc-lib-maybe-stop-rendering 'issued context result var-sym)))
(citeproc-context-maybe-stop-rendering 'issued context result var-sym)))
(defun citeproc--date-part (attrs _context &rest _body)
"Function corresponding to the date-part CSL element."
lisp/citeproc/citeproc-formatters.el
+25 -12
View File
@@ -33,8 +33,11 @@
(require 's)
(require 'cl-lib)
(cl-defstruct (citeproc-formatter (:constructor citeproc-formatter-create))
"Output formatter struct with slots RT, CITE, BIB-ITEM and BIB.
(require 'citeproc-s)
(require 'citeproc-rt)
(cl-defstruct (citeproc-formatter (:constructor citeproc-formatter-create))
"Output formatter struct with slots RT, CITE, BIB-ITEM and BIB.
RT is a one-argument function mapping a rich-text to its
formatted version,
CITE is a one-argument function mapping the output of RT for a
@@ -48,9 +51,9 @@ BIB is a two-argument function mapping a list of formatted
bibliography,
NO-EXTERNAL-LINKS is non-nil if the formatter doesn't support
external linking."
rt (cite #'identity) (bib-item (lambda (x _) x))
(bib (lambda (x _) (mapconcat #'identity x "\n\n")))
(no-external-links nil))
rt (cite #'identity) (bib-item (lambda (x _) x))
(bib (lambda (x _) (mapconcat #'identity x "\n\n")))
(no-external-links nil))
(defun citeproc-formatter-fun-create (fmt-alist)
"Return a rich-text formatter function based on FMT-ALIST.
@@ -164,13 +167,18 @@ Performs finalization by removing unnecessary zero-width spaces."
(setq result (citeproc-s-replace-all-seq
result '((" ​" . " ") ("​ " . " ") ("​," . ",") ("​;" . ";")
("​:" . ":") ("​." . "."))))
;; Starting and ending z-w spaces are also removed, but not before an
;; asterisk to avoid creating an Org heading.
;; Starting and ending z-w spaces are also removed, but not before an asterisk
;; to avoid creating an Org heading.
(when (and (= (aref result 0) 8203)
(not (= (aref result 1) ?*)))
(setq result (substring result 1)))
(when (= (aref result (- (length result) 1)) 8203)
(setq result (substring result 0 -1))))
(setq result (substring result 0 -1)))
;; Prepend a zero width no-break space when the text starts with
;; superscript to make Org parse it correctly.
;; NOTE: This is a workaround, ideally should be fixed in Org.
(when (= (aref result 0) ?^)
(setq result (concat "" result))))
result))
;; HTML
@@ -257,11 +265,16 @@ CSL tests."
"Return the LaTeX-escaped version of string S."
(replace-regexp-in-string citeproc-fmt--latex-esc-regex "\\\\\\&" s))
(defconst citeproc-fmt--latex-uri-esc-regex
(regexp-opt '("#" "%"))
"Regular expression matching characters to be escaped in URIs for LaTeX output.")
(defun citeproc-fmt--latex-href (text uri)
(let ((escaped-uri (replace-regexp-in-string "%" "\\\\%" uri)))
(if (string-prefix-p "http" text)
(concat "\\url{" escaped-uri "}")
(concat "\\href{" escaped-uri "}{" text "}"))))
(let ((escaped-uri (replace-regexp-in-string
citeproc-fmt--latex-uri-esc-regex "\\\\\\&" uri)))
(if (string-prefix-p "http" text)
(concat "\\url{" escaped-uri "}")
(concat "\\href{" escaped-uri "}{" text "}"))))
(defconst citeproc-fmt--latex-alist
`((unformatted . ,#'citeproc-fmt--latex-escape)
lisp/citeproc/citeproc-generic-elements.el
+1 -1
View File
@@ -143,7 +143,7 @@
(setq type (cdr macro-val)))))
;; We stop if only the title had to be rendered.
(let ((result (cons (citeproc-rt-format-single attrs content context) type)))
(citeproc-lib-maybe-stop-rendering
(citeproc-context-maybe-stop-rendering
'title context result (or (and .variable (intern .variable)) t))))))
(provide 'citeproc-generic-elements)
lisp/citeproc/citeproc-lib.el
+1 -15
View File
@@ -38,7 +38,7 @@
)
(defconst citeproc--date-vars
'(accessed available-date event-date issued original-date submitted)
'(accessed available-date event-date issued original-date submitted locator-date)
"CSL date variables.")
(defconst citeproc--name-vars
@@ -145,20 +145,6 @@ numeric content."
(s-matches-p "\\`[[:alpha:]]?[[:digit:]]+[[:alpha:]]*\\(\\( *\\([,&-]\\|--\\) *\\)?[[:alpha:]]?[[:digit:]]+[[:alpha:]]*\\)?\\'"
val))))
(defun citeproc-lib-maybe-stop-rendering
(trigger context result &optional var)
"Stop rendering if a (`stop-rendering-at'. TRIGGER) pair is present in CONTEXT.
In case of stopping return with RESULT. If the optional VAR
symbol is non-nil then rendering is stopped only if VAR is eq to
TRIGGER."
(if (and (eq trigger (alist-get 'stop-rendering-at (citeproc-context-vars context)))
(or (not var) (eq var trigger))
(eq (cdr result) 'present-var))
(let ((rt-result (car result)))
(push '(stopped-rendering . t) (car rt-result))
(throw 'stop-rendering (citeproc-rt-render-affixes rt-result)))
result))
(provide 'citeproc-lib)
;;; citeproc-lib.el ends here
lisp/citeproc/citeproc-pkg.el
+4 -3
View File
@@ -1,4 +1,4 @@
(define-package "citeproc" "20230228.1414" "A CSL 1.0.2 Citation Processor"
(define-package "citeproc" "20240722.1110" "A CSL 1.0.2 Citation Processor"
'((emacs "26")
(dash "2.13.0")
(s "1.12.0")
@@ -6,8 +6,9 @@
(queue "0.2")
(string-inflection "1.0")
(org "9")
(parsebib "2.4"))
:commit "290320fc579f886255f00d7268600df7fa5cc7e8" :authors
(parsebib "2.4")
(compat "28.1"))
:commit "54184baaff555b5c7993d566d75dd04ed485b5c0" :authors
'(("András Simonyi" . "andras.simonyi@gmail.com"))
:maintainers
'(("András Simonyi" . "andras.simonyi@gmail.com"))
lisp/citeproc/citeproc-prange.el
+2
View File
@@ -25,6 +25,8 @@
;;; Code:
(require 'citeproc-s)
(defun citeproc-prange--end-significant (start end len)
"Return the significant digits of the end in page range START END.
START and END are strings of equal length containing integers. If
lisp/citeproc/citeproc-proc.el
+8
View File
@@ -230,6 +230,14 @@ Return the PROC-internal representation of REP."
(let ((filters (citeproc-proc-bib-filters proc)))
(and filters (not (equal filters '(nil))))))
(defun citeproc-proc-max-offset (itds)
"Return the maximal first field width of bibitems in ITDS.
ITDS should be the value of the itemdata field of a citeproc-proc
structure."
(cl-loop for itd being the hash-values of itds
when (listp (citeproc-itemdata-rawbibitem itd)) maximize
(length (citeproc-rt-to-plain (cadr (citeproc-itemdata-rawbibitem itd))))))
(provide 'citeproc-proc)
;;; citeproc-proc.el ends here
lisp/citeproc/citeproc-rt.el
+2 -7
View File
@@ -36,6 +36,7 @@
(require 'cl-lib)
(require 'let-alist)
(require 's)
(require 'compat)
(require 'citeproc-s)
(require 'citeproc-lib)
@@ -148,7 +149,7 @@ If optional SKIP-NOCASE is non-nil then skip spans with the
(defun citeproc-rt-strip-periods (rts)
"Remove all periods from rich-texts RTS."
(citeproc-rt-map-strings (lambda (x) (citeproc-s-replace "." "" x)) rts))
(citeproc-rt-map-strings (lambda (x) (string-replace "." "" x)) rts))
(defun citeproc-rt-length (rt)
"Return the length of rich-text RT as a string."
@@ -532,12 +533,6 @@ The values are ordered depth-first."
;;; Helpers for bibliography rendering
(defun citeproc-rt-max-offset (itemdata)
"Return the maximal first field width in rich-texts RTS."
(cl-loop for itd being the hash-values of itemdata
when (listp (citeproc-itemdata-rawbibitem itd)) maximize
(length (citeproc-rt-to-plain (cadr (citeproc-itemdata-rawbibitem itd))))))
(defun citeproc-rt-subsequent-author-substitute (bib s)
"Substitute S for subsequent author(s) in BIB.
BIB is a list of bib entries in rich-text format. Return the
lisp/citeproc/citeproc-s.el
+13 -12
View File
@@ -27,11 +27,7 @@
(require 'thingatpt)
(require 's)
;; Handle the unavailability of `string-replace' in early Emacs versions
(if (fboundp 'string-replace)
(defalias 'citeproc-s-replace #'string-replace)
(defalias 'citeproc-s-replace #'s-replace))
(require 'compat)
(defun citeproc-s-camelcase-p (s)
"Return whether string S is in camel case."
@@ -151,12 +147,12 @@ first word is not in lowercase then return S."
(buffer-string))
s))
(defun citeproc-s-sentence-case-title (s omit-nocase)
(defun citeproc-s-sentence-case-title (s &optional omit-nocase)
"Return a sentence-cased version of title string S.
If optional OMIT-NOCASE is non-nil then omit the nocase tags from the output."
(if (s-blank-p s) s
(let ((sliced (citeproc-s-slice-by-matches
s "\\(<span class=\"nocase\">\\|</span>\\|: +\\w\\)"))
s "\\(<span class=\"nocase\">\\|</span>\\|: +[\"'“‘]*[[:alpha:]]\\)"))
(protect-level 0)
(first t)
result)
@@ -165,13 +161,18 @@ If optional OMIT-NOCASE is non-nil then omit the nocase tags from the output."
(pcase slice
("<span class=\"nocase\">" (cl-incf protect-level) (if omit-nocase nil slice))
("</span>" (cl-decf protect-level) (if omit-nocase nil slice))
;; Don't touch the first letter after a colon since it is probably a subtitle.
((pred (string-match-p "^:")) slice)
;; Don't touch the first letter after a colon since it probably
;; starts a subtitle.
((pred (string-match-p "^: +[\"'“‘]*[[:alpha:]]")) (setq first nil) slice)
(_ (cond ((< 0 protect-level) (setq first nil) slice)
((not first) (downcase slice))
(t (setq first nil)
(concat (upcase (substring slice 0 1))
(downcase (substring slice 1)))))))
;; We upcase the first letter and downcase the rest.
(let ((pos (string-match "[[:alpha:]]" slice)))
(if pos (concat (substring slice 0 pos)
(upcase (substring slice pos (1+ pos)))
(downcase (substring slice (1+ pos))))
slice))))))
result))
(apply #'concat (nreverse result)))))
@@ -232,7 +233,7 @@ OQ is the opening quote, CQ is the closing quote to use."
REPLACEMENTS is an alist with (FROM . TO) elements."
(let ((result s))
(pcase-dolist (`(,from . ,to) replacements)
(setq result (citeproc-s-replace from to result)))
(setq result (string-replace from to result)))
result))
(defun citeproc-s-replace-all-sim (s regex replacements)
lisp/citeproc/citeproc-sort.el
+8 -7
View File
@@ -36,6 +36,7 @@
(require 'citeproc-macro)
(require 'citeproc-proc)
(require 'citeproc-name)
(require 'citeproc-number)
(defun citeproc--sort (_attrs _context &rest body)
"Placeholder function corresponding to the cs:sort element of CSL."
@@ -172,17 +173,17 @@ MODE is either `cite' or `bib'."
(let ((is-sorted-bib (citeproc-style-bib-sort (citeproc-proc-style proc)))
(is-filtered (citeproc-proc-filtered-bib-p proc)))
(when (or is-sorted-bib is-filtered)
(let* ((itds (hash-table-values (citeproc-proc-itemdata proc)))
(sorted (if is-sorted-bib
(let ((sort-orders (citeproc-style-bib-sort-orders
(let* ((itds (citeproc-sort-itds-on-citnum
(hash-table-values (citeproc-proc-itemdata proc)))))
(when is-sorted-bib
(let ((sort-orders (citeproc-style-bib-sort-orders
(citeproc-proc-style proc))))
(citeproc-sort-itds itds sort-orders))
(citeproc-sort-itds-on-citnum itds))))
(setq itds (citeproc-sort-itds itds sort-orders))))
;; Additionally sort according to subbibliographies if there are filters.
(when is-filtered
(setq sorted (sort sorted #'citeproc-sort-itds-on-subbib)))
(setq itds (sort itds #'citeproc-sort-itds-on-subbib)))
;; Set the CSL citation-number field according to the sort order.
(--each-indexed sorted
(--each-indexed itds
(citeproc-itd-setvar it 'citation-number
(number-to-string (1+ it-index))))))))
lisp/citeproc/citeproc-style.el
+20 -10
View File
@@ -37,6 +37,7 @@
(cl-defstruct (citeproc-style (:constructor citeproc-style--create))
"A struct representing a parsed and localized CSL style.
CATEGORY is the style's category as a string,
INFO is the style's general info (currently simply the
corresponding fragment of the parsed xml),
OPTS, BIB-OPTS, CITE-OPTS and LOCALE-OPTS are alists of general
@@ -49,7 +50,6 @@ BIB-SORT-ORDERS and CITE-SORT-ORDERS are the lists of sort orders
the n-th key should be in ascending or desending order,
CITE-LAYOUT-ATTRS contains the attributes of the citation layout
as an alist,
CITE-NOTE is non-nil iff the style's citation-format is \"note\",
DATE-TEXT and DATE-NUMERIC are the style's date formats,
LOCALE contains the locale to be used or nil if not set,
MACROS is an alist with macro names as keys and corresponding
@@ -57,8 +57,8 @@ MACROS is an alist with macro names as keys and corresponding
TERMS is the style's parsed term-list,
USES-YS-VAR is non-nil iff the style uses the YEAR-SUFFIX
CSL-variable."
info opts bib-opts bib-sort bib-sort-orders
bib-layout cite-opts cite-note cite-sort cite-sort-orders
category info opts bib-opts bib-sort bib-sort-orders
bib-layout cite-opts cite-sort cite-sort-orders
cite-layout cite-layout-attrs locale-opts macros terms
uses-ys-var date-text date-numeric locale)
@@ -98,12 +98,13 @@ in-style locale information will be loaded (if available)."
(--each (cddr parsed-style)
(pcase (car it)
('info
(let ((info-lst (cddr it)))
(setf (citeproc-style-info style) info-lst
(citeproc-style-cite-note style)
(not (not (member '(category
((citation-format . "note")))
info-lst))))))
(let* ((info-lst (cddr it))
(category-info (cl-find-if
(lambda (x) (and (eq 'category (car x))
(eq 'citation-format (caaadr x))))
info-lst))
(category (cdaadr category-info)))
(setf (citeproc-style-category style) category)))
('locale
(let ((lang (alist-get 'lang (cadr it))))
(when (and (citeproc-locale--compatible-p lang locale)
@@ -310,7 +311,16 @@ position and before the (possibly empty) body."
(cons str (cdr result)))
result)))
;; Handle `author' citation mode by stopping if needed
(citeproc-lib-maybe-stop-rendering 'names context final)))))
(citeproc-context-maybe-stop-rendering 'names context final)))))
(defun citeproc-style-cite-note (style)
"Return whether csl STYLE is a note style."
(string= (citeproc-style-category style) "note"))
(defun citeproc-style-cite-superscript-p (style)
"Return whether csl STYLE has a superscript citaton layout."
(string= (alist-get 'vertical-align (citeproc-style-cite-layout-attrs style))
"sup"))
(defun citeproc-style-global-opts (style layout)
"Return the global opts in STYLE for LAYOUT.
lisp/citeproc/citeproc-subbibs.el
+4 -1
View File
@@ -25,6 +25,8 @@
;;; Code:
(require 'subr-x)
(require 'compat)
(require 'dash)
(require 'citeproc-proc)
@@ -39,7 +41,8 @@ see the documentation of `citeproc-add-subbib-filters'."
(let* ((csl-type (alist-get 'type vv))
(type (or (alist-get 'blt-type vv) csl-type))
(keyword (alist-get 'keyword vv))
(keywords (and keyword (split-string keyword "[ ,;]" t))))
(keywords (and keyword (mapcar #'string-clean-whitespace
(split-string keyword "[,;]" t)))))
(--every-p
(pcase it
(`(type . ,key) (string= type key))
lisp/citeproc/citeproc.el
+12 -6
View File
@@ -1,12 +1,12 @@
;;; citeproc.el --- A CSL 1.0.2 Citation Processor -*- lexical-binding: t; -*-
;; Copyright (C) 2017-2023 András Simonyi
;; Copyright (C) 2017-2024 András Simonyi
;; Author: András Simonyi <andras.simonyi@gmail.com>
;; Maintainer: András Simonyi <andras.simonyi@gmail.com>
;; URL: https://github.com/andras-simonyi/citeproc-el
;; Keywords: bib
;; Package-Requires: ((emacs "26") (dash "2.13.0") (s "1.12.0") (f "0.18.0") (queue "0.2") (string-inflection "1.0") (org "9") (parsebib "2.4"))
;; Package-Requires: ((emacs "26") (dash "2.13.0") (s "1.12.0") (f "0.18.0") (queue "0.2") (string-inflection "1.0") (org "9") (parsebib "2.4")(compat "28.1"))
;; Version: 0.9.3
;; This program is free software; you can redistribute it and/or modify
@@ -87,10 +87,12 @@ CITATIONS is a list of `citeproc-citation' structures."
(new-ids (--remove (gethash it itemdata) uniq-ids)))
;; Add all new items in one pass
(citeproc-proc-put-items-by-id proc new-ids)
;; Add itemdata to the cite structs and add them to the cite queue.
;; Internalize the cites dealing with locator-extra if present, add itemdata to
;; the cite structs and add them to the cite queue.
(dolist (citation citations)
(setf (citeproc-citation-cites citation)
(--map (cons (cons 'itd (gethash (alist-get 'id it) itemdata)) it)
(--map (cons (cons 'itd (gethash (alist-get 'id it) itemdata))
(citeproc-cite--internalize-locator it))
(citeproc-citation-cites citation)))
(queue-append (citeproc-proc-citations proc) citation))
(setf (citeproc-proc-finalized proc) nil))))
@@ -239,8 +241,12 @@ formatting parameters keyed to the parameter names as symbols:
raw-bib)
raw-bib))
;; Calculate formatting params.
(max-offset (if (alist-get 'second-field-align bib-opts)
(citeproc-rt-max-offset itemdata)
;; NOTE: This is the only place where we check whether there are
;; bibliography items in the processor, even though the empty case
;; could be handled way more efficiently.
(max-offset (if (and (alist-get 'second-field-align bib-opts)
(not (hash-table-empty-p itemdata)))
(citeproc-proc-max-offset itemdata)
0))
(format-params (cons (cons 'max-offset max-offset)
(citeproc-style-bib-opts-to-formatting-params bib-opts)))
lisp/company/company-abbrev.el
+9 -7
View File
@@ -1,6 +1,6 @@
;;; company-abbrev.el --- company-mode completion backend for abbrev
;;; company-abbrev.el --- company-mode completion backend for abbrev -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2015, 2021 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2015, 2021, 2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -29,21 +29,23 @@
(require 'cl-lib)
(require 'abbrev)
(defun company-abbrev-insert (match)
(defun company-abbrev-insert (_match)
"Replace MATCH with the expanded abbrev."
(expand-abbrev))
;;;###autoload
(defun company-abbrev (command &optional arg &rest ignored)
(defun company-abbrev (command &optional arg &rest _ignored)
"`company-mode' completion backend for abbrev."
(interactive (list 'interactive))
(cl-case command
(interactive (company-begin-backend 'company-abbrev
'company-abbrev-insert))
(prefix (company-grab-symbol))
(candidates (nconc
(delete "" (all-completions arg global-abbrev-table))
(delete "" (all-completions arg local-abbrev-table))))
(candidates (apply
#'nconc
(mapcar (lambda (table)
(delete "" (all-completions arg table)))
(abbrev--active-tables))))
(kind 'snippet)
(meta (abbrev-expansion arg))
(post-completion (expand-abbrev))))
lisp/company/company-bbdb.el
+6 -6
View File
@@ -1,6 +1,6 @@
;;; company-bbdb.el --- company-mode completion backend for BBDB in message-mode
;;; company-bbdb.el --- company-mode completion backend for BBDB in message-mode -*- lexical-binding: t -*-
;; Copyright (C) 2013-2016, 2020 Free Software Foundation, Inc.
;; Copyright (C) 2013-2016, 2020, 2023 Free Software Foundation, Inc.
;; Author: Jan Tatarik <jan.tatarik@gmail.com>
@@ -23,9 +23,7 @@
(require 'cl-lib)
(declare-function bbdb-record-get-field "bbdb")
(declare-function bbdb-records "bbdb")
(declare-function bbdb-dwim-mail "bbdb-com")
(declare-function bbdb-search "bbdb-com")
(defgroup company-bbdb nil
"Completion backend for BBDB."
@@ -40,10 +38,12 @@
(cl-mapcan (lambda (record)
(mapcar (lambda (mail) (bbdb-dwim-mail record mail))
(bbdb-record-get-field record 'mail)))
(eval '(bbdb-search (bbdb-records) arg nil arg))))
(eval `(let ((arg ,arg))
(bbdb-search (bbdb-records) :all-names arg :mail arg))
t)))
;;;###autoload
(defun company-bbdb (command &optional arg &rest ignore)
(defun company-bbdb (command &optional arg &rest _ignore)
"`company-mode' completion backend for BBDB."
(interactive (list 'interactive))
(cl-case command
lisp/company/company-capf.el
+106 -89
View File
@@ -1,6 +1,6 @@
;;; company-capf.el --- company-mode completion-at-point-functions backend -*- lexical-binding: t -*-
;; Copyright (C) 2013-2022 Free Software Foundation, Inc.
;; Copyright (C) 2013-2024 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
@@ -19,7 +19,6 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; The CAPF back-end provides a bridge to the standard
@@ -32,13 +31,27 @@
(require 'company)
(require 'cl-lib)
(defgroup company-capf nil
"Completion backend as adapter for `completion-at-point-functions'."
:group 'company)
(defcustom company-capf-disabled-functions '(tags-completion-at-point-function
ispell-completion-at-point)
"List of completion functions which should be ignored in this backend.
By default it contains the functions that duplicate the built-in backends
but don't support the corresponding configuration options and/or alter the
intended priority of the default backends' configuration."
:type 'hook
:package-version '(company . "1.0.0"))
;; Amortizes several calls to a c-a-p-f from the same position.
(defvar company--capf-cache nil)
;; FIXME: Provide a way to save this info once in Company itself
;; (https://github.com/company-mode/company-mode/pull/845).
(defvar-local company-capf--current-completion-data nil
"Value last returned by `company-capf' when called with `candidates'.
"Value last returned by `company-capf' in response to `candidates'.
For most properties/actions, this is just what we need: the exact values
that accompanied the completion table that's currently is use.
@@ -46,6 +59,9 @@ that accompanied the completion table that's currently is use.
a completion session (most importantly, by `company-sort-by-occurrence'),
so we can't just use the preceding variable instead.")
(defvar-local company-capf--current-completion-metadata nil
"Metadata computed with the current prefix and data above.")
(defun company--capf-data ()
(let ((cache company--capf-cache))
(if (and (equal (current-buffer) (car cache))
@@ -57,79 +73,51 @@ so we can't just use the preceding variable instead.")
(list (current-buffer) (point) (buffer-chars-modified-tick) data))
data))))
(defun company--contains (elt lst)
(when-let ((cur (car lst)))
(cond
((symbolp cur)
(or (eq elt cur)
(company--contains elt (cdr lst))))
((listp cur)
(or (company--contains elt cur)
(company--contains elt (cdr lst)))))))
(defun company--capf-data-real ()
(cl-letf* (((default-value 'completion-at-point-functions)
(if (company--contains 'company-etags company-backends)
;; Ignore tags-completion-at-point-function because it subverts
;; company-etags in the default value of company-backends, where
;; the latter comes later.
(remove 'tags-completion-at-point-function
(default-value 'completion-at-point-functions))
(default-value 'completion-at-point-functions)))
(completion-at-point-functions (company--capf-workaround))
(data (run-hook-wrapped 'completion-at-point-functions
;; Ignore misbehaving functions.
#'company--capf-wrapper 'optimist)))
(let ((data (run-hook-wrapped 'completion-at-point-functions
;; Ignore disabled and misbehaving functions.
#'company--capf-wrapper 'optimist)))
(when (and (consp (cdr data)) (integer-or-marker-p (nth 1 data))) data)))
(defun company--capf-wrapper (fun which)
(let ((buffer-read-only t)
(inhibit-read-only nil)
(completion-in-region-function
(lambda (beg end coll pred)
(throw 'company--illegal-completion-in-region
(list fun beg end coll :predicate pred)))))
(catch 'company--illegal-completion-in-region
(condition-case nil
(completion--capf-wrapper fun which)
(buffer-read-only nil)))))
;; E.g. tags-completion-at-point-function subverts company-etags in the
;; default value of company-backends, where the latter comes later.
(unless (memq fun company-capf-disabled-functions)
(let ((buffer-read-only t)
(inhibit-read-only nil)
(completion-in-region-function
(lambda (beg end coll pred)
(throw 'company--illegal-completion-in-region
(list fun beg end coll :predicate pred)))))
(catch 'company--illegal-completion-in-region
(condition-case nil
(completion--capf-wrapper fun which)
(buffer-read-only nil))))))
(declare-function python-shell-get-process "python")
(defun company--capf-workaround ()
;; For http://debbugs.gnu.org/cgi/bugreport.cgi?bug=18067
(if (or (not (listp completion-at-point-functions))
(not (memq 'python-completion-complete-at-point completion-at-point-functions))
(python-shell-get-process))
completion-at-point-functions
(remq 'python-completion-complete-at-point completion-at-point-functions)))
(defun company-capf--save-current-data (data)
(setq company-capf--current-completion-data data)
(defun company-capf--save-current-data (data metadata)
(setq company-capf--current-completion-data data
company-capf--current-completion-metadata metadata)
(add-hook 'company-after-completion-hook
#'company-capf--clear-current-data nil t))
(defun company-capf--clear-current-data (_ignored)
(setq company-capf--current-completion-data nil))
(setq company-capf--current-completion-data nil
company-capf--current-completion-metadata nil))
(defvar-local company-capf--sorted nil)
(defvar-local company-capf--current-boundaries nil)
(defun company-capf (command &optional arg &rest _args)
(defun company-capf (command &optional arg &rest rest)
"`company-mode' backend using `completion-at-point-functions'."
(interactive (list 'interactive))
(pcase command
(`interactive (company-begin-backend 'company-capf))
(`prefix
(let ((res (company--capf-data)))
(when res
(let ((length (plist-get (nthcdr 4 res) :company-prefix-length))
(prefix (buffer-substring-no-properties (nth 1 res) (point))))
(cond
((> (nth 2 res) (point)) 'stop)
(length (cons prefix length))
(t prefix))))))
(company-capf--prefix))
(`candidates
(company-capf--candidates arg))
(company-capf--candidates arg (car rest)))
(`sorted
company-capf--sorted)
(`match
@@ -168,20 +156,35 @@ so we can't just use the preceding variable instead.")
(plist-get (nthcdr 4 (company--capf-data)) :company-require-match))
(`init nil) ;Don't bother: plenty of other ways to initialize the code.
(`post-completion
(company--capf-post-completion arg))
(company-capf--post-completion arg))
(`adjust-boundaries
(company--capf-boundaries
company-capf--current-boundaries))
(`expand-common
(company-capf--expand-common arg (car rest)))
))
(defun company-capf--prefix ()
(let ((res (company--capf-data)))
(when res
(let ((length (plist-get (nthcdr 4 res) :company-prefix-length))
(prefix (buffer-substring-no-properties (nth 1 res) (point)))
(suffix (buffer-substring-no-properties (point) (nth 2 res))))
(list prefix suffix length)))))
(defun company-capf--expand-common (prefix suffix)
(let* ((data company-capf--current-completion-data)
(table (nth 3 data))
(pred (plist-get (nthcdr 4 data) :predicate)))
(company--capf-expand-common prefix suffix table pred
company-capf--current-completion-metadata)))
(defun company-capf--annotation (arg)
(let* ((f (or (plist-get (nthcdr 4 company-capf--current-completion-data)
:annotation-function)
;; FIXME: Add a test.
(cdr (assq 'annotation-function
(completion-metadata
(buffer-substring (nth 1 company-capf--current-completion-data)
(nth 2 company-capf--current-completion-data))
(nth 3 company-capf--current-completion-data)
(plist-get (nthcdr 4 company-capf--current-completion-data)
:predicate))))))
company-capf--current-completion-metadata))))
(annotation (when f (funcall f arg))))
(if (and company-format-margin-function
(equal annotation " <f>") ; elisp-completion-at-point, pre-icons
@@ -190,40 +193,54 @@ so we can't just use the preceding variable instead.")
nil
annotation)))
(defun company-capf--candidates (input)
(let ((res (company--capf-data)))
(company-capf--save-current-data res)
(when res
(let* ((table (nth 3 res))
(pred (plist-get (nthcdr 4 res) :predicate))
(meta (completion-metadata
(buffer-substring (nth 1 res) (nth 2 res))
table pred))
(candidates (completion-all-completions input table pred
(length input)
meta))
(defun company-capf--candidates (input suffix)
(let* ((current-capf (car company-capf--current-completion-data))
(res (company--capf-data))
(table (nth 3 res))
(pred (plist-get (nthcdr 4 res) :predicate))
(meta (and res
(completion-metadata
(buffer-substring (nth 1 res) (nth 2 res))
table pred))))
(when (and res
(or (not current-capf)
(equal current-capf (car res))))
(let* ((interrupt (plist-get (nthcdr 4 res) :company-use-while-no-input))
(all-result (company-capf--candidates-1 input suffix
table pred
meta
(and non-essential
(eq interrupt t))))
(sortfun (cdr (assq 'display-sort-function meta)))
(last (last candidates))
(base-size (and (numberp (cdr last)) (cdr last))))
(when base-size
(setcdr last nil))
(candidates (assoc-default :completions all-result)))
(setq company-capf--sorted (functionp sortfun))
(when candidates
(company-capf--save-current-data res meta)
(setq company-capf--current-boundaries
(company--capf-boundaries-markers
(assoc-default :boundaries all-result)
company-capf--current-boundaries)))
(when sortfun
(setq candidates (funcall sortfun candidates)))
(if (not (zerop (or base-size 0)))
(let ((before (substring input 0 base-size)))
(mapcar (lambda (candidate)
(concat before candidate))
candidates))
candidates)))))
candidates))))
(defun company--capf-post-completion (arg)
(defun company-capf--candidates-1 (prefix suffix table pred meta interrupt-on-input)
(if (not interrupt-on-input)
(company--capf-completions prefix suffix table pred meta)
(let (res)
(and (while-no-input
(setq res
(company--capf-completions prefix suffix table pred meta))
nil)
(throw 'interrupted 'new-input))
res)))
(defun company-capf--post-completion (arg)
(let* ((res company-capf--current-completion-data)
(exit-function (plist-get (nthcdr 4 res) :exit-function))
(table (nth 3 res)))
(if exit-function
;; We can more or less know when the user is done with completion,
;; so we do something different than `completion--done'.
;; Follow the example of `completion--done'.
(funcall exit-function arg
;; FIXME: Should probably use an additional heuristic:
;; completion-at-point doesn't know when the user picked a
@@ -232,7 +249,7 @@ so we can't just use the preceding variable instead.")
;; RET (or use implicit completion with company-tng).
(if (= (car (completion-boundaries arg table nil ""))
(length arg))
'sole
'exact
'finished)))))
(provide 'company-capf)
lisp/company/company-clang.el
+2 -2
View File
@@ -335,8 +335,8 @@ or automatically through a custom `company-clang-prefix-guesser'."
(defun company-clang--prefix ()
(if company-clang-begin-after-member-access
(company-grab-symbol-cons "\\.\\|->\\|::" 2)
(company-grab-symbol)))
(company-grab-symbol-parts "\\.\\|->\\|::" 2)
(company-grab-symbol-parts)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
lisp/company/company-cmake.el
+5 -7
View File
@@ -1,6 +1,6 @@
;;; company-cmake.el --- company-mode completion backend for CMake
;;; company-cmake.el --- company-mode completion backend for CMake -*- lexical-binding: t -*-
;; Copyright (C) 2013-2015, 2017-2018, 2020 Free Software Foundation, Inc.
;; Copyright (C) 2013-2015, 2017-2018, 2020, 2023 Free Software Foundation, Inc.
;; Author: Chen Bin <chenbin DOT sh AT gmail>
;; Version: 0.2
@@ -49,7 +49,7 @@ They affect which types of symbols we get completion candidates for.")
"^\\(%s[a-zA-Z0-9_<>]%s\\)$"
"Regexp to match the candidates.")
(defvar company-cmake-modes '(cmake-mode)
(defvar company-cmake-modes '(cmake-mode cmake-ts-mode)
"Major modes in which cmake may complete.")
(defvar company-cmake--candidates-cache nil
@@ -94,12 +94,10 @@ They affect which types of symbols we get completion candidates for.")
))
(defun company-cmake--parse (prefix content cmd)
(let ((start 0)
(pattern (format company-cmake--completion-pattern
(let ((pattern (format company-cmake--completion-pattern
(regexp-quote prefix)
(if (zerop (length prefix)) "+" "*")))
(lines (split-string content "\n"))
match
rlt)
(dolist (line lines)
(when (string-match pattern line)
@@ -185,7 +183,7 @@ They affect which types of symbols we get completion candidates for.")
(and (eq (char-before (point)) ?\{)
(eq (char-before (1- (point))) ?$))))
(defun company-cmake (command &optional arg &rest ignored)
(defun company-cmake (command &optional arg &rest _ignored)
"`company-mode' completion backend for CMake.
CMake is a cross-platform, open-source make system."
(interactive (list 'interactive))
lisp/company/company-dabbrev-code.el
+75 -39
View File
@@ -1,6 +1,6 @@
;;; company-dabbrev-code.el --- dabbrev-like company-mode backend for code -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2016, 2021-2023 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2016, 2021-2024 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -48,13 +48,16 @@ complete only symbols, not text in comments or strings. In other modes
(defcustom company-dabbrev-code-other-buffers t
"Determines whether `company-dabbrev-code' should search other buffers.
If `all', search all other buffers, except the ignored ones. If t, search
buffers with the same major mode. If `code', search all buffers with major
modes in `company-dabbrev-code-modes', or derived from one of them. See
also `company-dabbrev-code-time-limit'."
buffers with the same major mode. If `code', search all
buffers with major modes in `company-dabbrev-code-modes', or derived from one of
them. This can also be a function that takes the current buffer as
parameter and returns a list of major modes to search. See also
`company-dabbrev-code-time-limit'."
:type '(choice (const :tag "Off" nil)
(const :tag "Same major mode" t)
(const :tag "Code major modes" code)
(const :tag "All" all)))
(const :tag "All" all)
(function :tag "Function to return similar major-modes" group)))
(defcustom company-dabbrev-code-time-limit .1
"Determines how long `company-dabbrev-code' should look for matches."
@@ -73,12 +76,16 @@ also `company-dabbrev-code-time-limit'."
"Non-nil to use the completion styles for fuzzy matching."
:type '(choice (const :tag "Prefix matching only" nil)
(const :tag "Matching according to `completion-styles'" t)
(list :tag "Custom list of styles" symbol)))
(list :tag "Custom list of styles" symbol))
:package-version '(company . "1.0.0"))
(defvar-local company-dabbrev--boundaries nil)
(defvar-local company-dabbrev-code--sorted nil)
(defun company-dabbrev-code--make-regexp (prefix)
(let ((prefix-re
(cond
((equal prefix "")
((string-empty-p prefix)
"\\([a-zA-Z]\\|\\s_\\)")
((not company-dabbrev-code-completion-styles)
(regexp-quote prefix))
@@ -88,13 +95,15 @@ also `company-dabbrev-code-time-limit'."
(let ((prefix (if (>= (length prefix) 2)
(substring prefix 0 2)
prefix)))
(mapconcat #'regexp-quote
(mapcar #'string prefix)
"\\(\\sw\\|\\s_\\)*"))))))
(concat
"\\(\\sw\\|\\s_\\)*"
(mapconcat #'regexp-quote
(mapcar #'string prefix)
"\\(\\sw\\|\\s_\\)*")))))))
(concat "\\_<" prefix-re "\\(\\sw\\|\\s_\\)*\\_>")))
;;;###autoload
(defun company-dabbrev-code (command &optional arg &rest _ignored)
(defun company-dabbrev-code (command &optional arg &rest rest)
"dabbrev-like `company-mode' backend for code.
The backend looks for all symbols in the current buffer that aren't in
comments or strings."
@@ -102,50 +111,77 @@ comments or strings."
(cl-case command
(interactive (company-begin-backend 'company-dabbrev-code))
(prefix (and (or (eq t company-dabbrev-code-modes)
(apply #'derived-mode-p company-dabbrev-code-modes))
(cl-some #'derived-mode-p company-dabbrev-code-modes))
(or company-dabbrev-code-everywhere
(not (company-in-string-or-comment)))
(or (company-grab-symbol) 'stop)))
(candidates
(let* ((case-fold-search company-dabbrev-code-ignore-case)
(regexp (company-dabbrev-code--make-regexp arg)))
(company-dabbrev-code--filter
arg
(company-cache-fetch
'dabbrev-code-candidates
(lambda ()
(company-dabbrev--search
regexp
company-dabbrev-code-time-limit
(pcase company-dabbrev-code-other-buffers
(`t (list major-mode))
(`code company-dabbrev-code-modes)
(`all `all))
(not company-dabbrev-code-everywhere)))
:expire t
:check-tag regexp))))
(company-grab-symbol-parts)))
(candidates (company-dabbrev--candidates arg (car rest)))
(adjust-boundaries (and company-dabbrev-code-completion-styles
(company--capf-boundaries
company-dabbrev--boundaries)))
(expand-common (company-dabbrev-code--expand-common arg (car rest)))
(kind 'text)
(sorted company-dabbrev-code--sorted)
(no-cache t)
(ignore-case company-dabbrev-code-ignore-case)
(match (when company-dabbrev-code-completion-styles
(company--match-from-capf-face arg)))
(duplicates t)))
(defun company-dabbrev-code--filter (prefix table)
(defun company-dabbrev-code--expand-common (prefix suffix)
(when company-dabbrev-code-completion-styles
(let ((completion-styles (if (listp company-dabbrev-code-completion-styles)
company-dabbrev-code-completion-styles
completion-styles)))
(company--capf-expand-common prefix suffix
(company-dabbrev-code--table prefix)))))
(defun company-dabbrev--candidates (prefix suffix)
(let* ((case-fold-search company-dabbrev-code-ignore-case))
(company-dabbrev-code--filter
prefix suffix
(company-dabbrev-code--table prefix))))
(defun company-dabbrev-code--table (prefix)
(let ((regexp (company-dabbrev-code--make-regexp prefix)))
(company-cache-fetch
'dabbrev-code-candidates
(lambda ()
(company-dabbrev--search
regexp
company-dabbrev-code-time-limit
(pcase company-dabbrev-code-other-buffers
(`t (list major-mode))
(`code company-dabbrev-code-modes)
((pred functionp) (funcall company-dabbrev-code-other-buffers (current-buffer)))
(`all `all))
(not company-dabbrev-code-everywhere)))
:expire t
:check-tag
(cons regexp company-dabbrev-code-completion-styles))))
(defun company-dabbrev-code--filter (prefix suffix table)
(let ((completion-ignore-case company-dabbrev-code-ignore-case)
(completion-styles (if (listp company-dabbrev-code-completion-styles)
company-dabbrev-code-completion-styles
completion-styles))
(metadata (completion-metadata prefix table nil))
res)
(if (not company-dabbrev-code-completion-styles)
(all-completions prefix table)
(setq res (completion-all-completions
prefix
table
nil (length prefix)))
(if (numberp (cdr (last res)))
(setcdr (last res) nil))
res)))
(setq res (company--capf-completions
prefix suffix
table nil
metadata))
(when-let* ((sort-fn (completion-metadata-get metadata 'display-sort-function)))
(setq company-dabbrev-code--sorted t)
(setf (alist-get :completions res)
(funcall sort-fn (alist-get :completions res))))
(setq company-dabbrev--boundaries
(company--capf-boundaries-markers
(assoc-default :boundaries res)
company-dabbrev--boundaries))
(assoc-default :completions res))))
(provide 'company-dabbrev-code)
;;; company-dabbrev-code.el ends here
lisp/company/company-dabbrev.el
+15 -9
View File
@@ -35,10 +35,13 @@
(defcustom company-dabbrev-other-buffers 'all
"Determines whether `company-dabbrev' should search other buffers.
If `all', search all other buffers, except the ignored ones. If t, search
buffers with the same major mode. See also `company-dabbrev-time-limit'."
buffers with the same major mode. This can also be a function that takes
the current buffer as parameter and returns a list of major modes to
search. See also `company-dabbrev-time-limit'."
:type '(choice (const :tag "Off" nil)
(const :tag "Same major mode" t)
(const :tag "All" all)))
(const :tag "All" all)
(function :tag "Function to return similar major-modes" group)))
(defcustom company-dabbrev-ignore-buffers "\\`[ *]"
"Regexp matching the names of buffers to ignore.
@@ -156,7 +159,7 @@ This variable affects both `company-dabbrev' and `company-dabbrev-code'."
(funcall company-dabbrev-ignore-buffers buffer))
(with-current-buffer buffer
(when (or (eq other-buffer-modes 'all)
(apply #'derived-mode-p other-buffer-modes))
(cl-some #'derived-mode-p other-buffer-modes))
(setq symbols
(company-dabbrev--search-buffer regexp nil symbols start
limit ignore-comments)))))
@@ -166,12 +169,13 @@ This variable affects both `company-dabbrev' and `company-dabbrev-code'."
symbols))
(defun company-dabbrev--prefix ()
;; Not in the middle of a word.
(unless (looking-at company-dabbrev-char-regexp)
;; Emacs can't do greedy backward-search.
(company-grab-line (format "\\(?:^\\| \\)[^ ]*?\\(\\(?:%s\\)*\\)"
company-dabbrev-char-regexp)
1)))
;; Emacs can't do greedy backward-search.
(list
(company-grab-line (format "\\(?:^\\| \\)[^ ]*?\\(\\(?:%s\\)*\\)"
company-dabbrev-char-regexp)
1)
(and (looking-at (format "\\(?:%s\\)*" company-dabbrev-char-regexp))
(match-string 0))))
(defun company-dabbrev--filter (prefix candidates)
(let* ((completion-ignore-case company-dabbrev-ignore-case)
@@ -195,6 +199,7 @@ This variable affects both `company-dabbrev' and `company-dabbrev-code'."
company-dabbrev-time-limit
(pcase company-dabbrev-other-buffers
(`t (list major-mode))
((pred functionp) (funcall company-dabbrev-other-buffers (current-buffer)))
(`all `all))))
;;;###autoload
@@ -207,6 +212,7 @@ This variable affects both `company-dabbrev' and `company-dabbrev-code'."
(candidates
(company-dabbrev--filter
arg
;; FIXME: Only cache the result of non-interrupted scans?
(company-cache-fetch 'dabbrev-candidates #'company-dabbrev--fetch
:expire t)))
(kind 'text)
lisp/company/company-elisp.el
-226
View File
@@ -1,226 +0,0 @@
;;; company-elisp.el --- company-mode completion backend for Emacs Lisp -*- lexical-binding: t -*-
;; Copyright (C) 2009-2015, 2017, 2020 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; In newer versions of Emacs, company-capf is used instead.
;;; Code:
(require 'company)
(require 'cl-lib)
(require 'help-mode)
(require 'find-func)
(defgroup company-elisp nil
"Completion backend for Emacs Lisp."
:group 'company)
(defcustom company-elisp-detect-function-context t
"If enabled, offer Lisp functions only in appropriate contexts.
Functions are offered for completion only after \\=' and \(."
:type '(choice (const :tag "Off" nil)
(const :tag "On" t)))
(defcustom company-elisp-show-locals-first t
"If enabled, locally bound variables and functions are displayed
first in the candidates list."
:type '(choice (const :tag "Off" nil)
(const :tag "On" t)))
(defun company-elisp--prefix ()
(let ((prefix (company-grab-symbol)))
(if prefix
(when (if (company-in-string-or-comment)
(= (char-before (- (point) (length prefix))) ?`)
(company-elisp--should-complete))
prefix)
'stop)))
(defun company-elisp--predicate (symbol)
(or (boundp symbol)
(fboundp symbol)
(facep symbol)
(featurep symbol)))
(defun company-elisp--fns-regexp (&rest names)
(concat "\\_<\\(?:cl-\\)?" (regexp-opt names) "\\*?\\_>"))
(defvar company-elisp-parse-limit 30)
(defvar company-elisp-parse-depth 100)
(defvar company-elisp-defun-names '("defun" "defmacro" "defsubst"))
(defvar company-elisp-var-binding-regexp
(apply #'company-elisp--fns-regexp "let" "lambda" "lexical-let"
company-elisp-defun-names)
"Regular expression matching head of a multiple variable bindings form.")
(defvar company-elisp-var-binding-regexp-1
(company-elisp--fns-regexp "dolist" "dotimes")
"Regular expression matching head of a form with one variable binding.")
(defvar company-elisp-fun-binding-regexp
(company-elisp--fns-regexp "flet" "labels")
"Regular expression matching head of a function bindings form.")
(defvar company-elisp-defuns-regexp
(concat "([ \t\n]*"
(apply #'company-elisp--fns-regexp company-elisp-defun-names)))
(defun company-elisp--should-complete ()
(let ((start (point))
(depth (car (syntax-ppss))))
(not
(when (> depth 0)
(save-excursion
(up-list (- depth))
(when (looking-at company-elisp-defuns-regexp)
(forward-char)
(forward-sexp 1)
(unless (= (point) start)
(condition-case nil
(let ((args-end (scan-sexps (point) 2)))
(or (null args-end)
(> args-end start)))
(scan-error
t)))))))))
(defun company-elisp--locals (prefix functions-p)
(let ((regexp (concat "[ \t\n]*\\(\\_<" (regexp-quote prefix)
"\\(?:\\sw\\|\\s_\\)*\\_>\\)"))
(pos (point))
res)
(condition-case nil
(save-excursion
(dotimes (_ company-elisp-parse-depth)
(up-list -1)
(save-excursion
(when (eq (char-after) ?\()
(forward-char 1)
(when (ignore-errors
(save-excursion (forward-list)
(<= (point) pos)))
(skip-chars-forward " \t\n")
(cond
((looking-at (if functions-p
company-elisp-fun-binding-regexp
company-elisp-var-binding-regexp))
(down-list 1)
(condition-case nil
(dotimes (_ company-elisp-parse-limit)
(save-excursion
(when (looking-at "[ \t\n]*(")
(down-list 1))
(when (looking-at regexp)
(cl-pushnew (match-string-no-properties 1) res)))
(forward-sexp))
(scan-error nil)))
((unless functions-p
(looking-at company-elisp-var-binding-regexp-1))
(down-list 1)
(when (looking-at regexp)
(cl-pushnew (match-string-no-properties 1) res)))))))))
(scan-error nil))
res))
(defun company-elisp-candidates (prefix)
(let* ((predicate (company-elisp--candidates-predicate prefix))
(locals (company-elisp--locals prefix (eq predicate 'fboundp)))
(globals (company-elisp--globals prefix predicate))
(locals (cl-loop for local in locals
when (not (member local globals))
collect local)))
(if company-elisp-show-locals-first
(append (sort locals 'string<)
(sort globals 'string<))
(append locals globals))))
(defun company-elisp--globals (prefix predicate)
(all-completions prefix obarray predicate))
(defun company-elisp--candidates-predicate (prefix)
(let* ((completion-ignore-case nil)
(beg (- (point) (length prefix)))
(before (char-before beg)))
(if (and company-elisp-detect-function-context
(not (memq before '(?' ?`))))
(if (and (eq before ?\()
(not
(save-excursion
(ignore-errors
(goto-char (1- beg))
(or (company-elisp--before-binding-varlist-p)
(progn
(up-list -1)
(company-elisp--before-binding-varlist-p)))))))
'fboundp
'boundp)
'company-elisp--predicate)))
(defun company-elisp--before-binding-varlist-p ()
(save-excursion
(and (prog1 (search-backward "(")
(forward-char 1))
(looking-at company-elisp-var-binding-regexp))))
(defun company-elisp--doc (symbol)
(let* ((symbol (intern symbol))
(doc (if (fboundp symbol)
(documentation symbol t)
(documentation-property symbol 'variable-documentation t))))
(and (stringp doc)
(string-match ".*$" doc)
(match-string 0 doc))))
;;;###autoload
(defun company-elisp (command &optional arg &rest _ignored)
"`company-mode' completion backend for Emacs Lisp."
(interactive (list 'interactive))
(cl-case command
(interactive (company-begin-backend 'company-elisp))
(prefix (and (derived-mode-p 'emacs-lisp-mode 'inferior-emacs-lisp-mode)
(company-elisp--prefix)))
(candidates (company-elisp-candidates arg))
(sorted company-elisp-show-locals-first)
(meta (company-elisp--doc arg))
(doc-buffer (let ((symbol (intern arg)))
(save-window-excursion
(ignore-errors
(cond
((fboundp symbol) (describe-function symbol))
((boundp symbol) (describe-variable symbol))
((featurep symbol) (describe-package symbol))
((facep symbol) (describe-face symbol))
(t (signal 'user-error nil)))
(help-buffer)))))
(location (let ((sym (intern arg)))
(cond
((fboundp sym) (find-definition-noselect sym nil))
((boundp sym) (find-definition-noselect sym 'defvar))
((featurep sym) (cons (find-file-noselect (find-library-name
(symbol-name sym)))
0))
((facep sym) (find-definition-noselect sym 'defface)))))))
(provide 'company-elisp)
;;; company-elisp.el ends here
lisp/company/company-etags.el
+49 -11
View File
@@ -1,6 +1,6 @@
;;; company-etags.el --- company-mode completion backend for etags
;;; company-etags.el --- company-mode completion backend for etags -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2015, 2018-2019 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2015, 2018-2019, 2023-2024 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -54,10 +54,18 @@ Set it to t or to a list of major modes."
(symbol :tag "Major mode")))
:package-version '(company . "0.9.0"))
(defcustom company-etags-completion-styles nil
"Non-nil to use the completion styles for fuzzy matching."
:type '(choice (const :tag "Prefix matching only" nil)
(const :tag "Matching according to `completion-styles'" t)
(list :tag "Custom list of styles" symbol))
:package-version '(company . "1.0.0"))
(defvar company-etags-modes '(prog-mode c-mode objc-mode c++-mode java-mode
jde-mode pascal-mode perl-mode python-mode))
(defvar-local company-etags-buffer-table 'unknown)
(defvar-local company-etags--boundaries nil)
(defun company-etags-find-table ()
(let ((file (expand-file-name
@@ -74,34 +82,64 @@ Set it to t or to a list of major modes."
(setq company-etags-buffer-table (company-etags-find-table))
company-etags-buffer-table)))
(defun company-etags--candidates (prefix)
(defun company-etags--candidates (prefix suffix)
(let ((completion-ignore-case company-etags-ignore-case)
(completion-styles (if (listp company-etags-completion-styles)
company-etags-completion-styles
completion-styles))
(table (company-etags--table)))
(and table
(if company-etags-completion-styles
(let ((res (company--capf-completions prefix suffix table)))
(setq company-etags--boundaries
(company--capf-boundaries-markers
(assoc-default :boundaries res)
company-etags--boundaries))
(assoc-default :completions res))
(all-completions prefix table)))))
(defun company-etags--table ()
(let ((tags-table-list (company-etags-buffer-table))
(tags-file-name tags-file-name)
(completion-ignore-case company-etags-ignore-case))
(tags-file-name tags-file-name))
(and (or tags-file-name tags-table-list)
(fboundp 'tags-completion-table)
(save-excursion
(visit-tags-table-buffer)
(all-completions prefix (tags-completion-table))))))
(tags-completion-table)))))
(defun company-etags--expand-common (prefix suffix)
(when company-etags-completion-styles
(let ((completion-styles (if (listp company-etags-completion-styles)
company-etags-completion-styles
completion-styles)))
(company--capf-expand-common prefix suffix
(company-etags--table)))))
;;;###autoload
(defun company-etags (command &optional arg &rest ignored)
(defun company-etags (command &optional arg &rest rest)
"`company-mode' completion backend for etags."
(interactive (list 'interactive))
(cl-case command
(interactive (company-begin-backend 'company-etags))
(prefix (and (apply #'derived-mode-p company-etags-modes)
(prefix (and (cl-some #'derived-mode-p company-etags-modes)
(or (eq t company-etags-everywhere)
(apply #'derived-mode-p company-etags-everywhere)
(cl-some #'derived-mode-p company-etags-everywhere)
(not (company-in-string-or-comment)))
(company-etags-buffer-table)
(or (company-grab-symbol) 'stop)))
(candidates (company-etags--candidates arg))
(company-grab-symbol-parts)))
(candidates (company-etags--candidates arg (car rest)))
(adjust-boundaries (and company-etags-completion-styles
(company--capf-boundaries
company-etags--boundaries)))
(expand-common (company-etags--expand-common arg (car rest)))
(no-cache company-etags-completion-styles)
(location (let ((tags-table-list (company-etags-buffer-table)))
(when (fboundp 'find-tag-noselect)
(save-excursion
(let ((buffer (find-tag-noselect arg)))
(cons buffer (with-current-buffer buffer (point))))))))
(match (when company-etags-completion-styles
(company--match-from-capf-face arg)))
(ignore-case company-etags-ignore-case)))
(provide 'company-etags)
lisp/company/company-files.el
+29 -33
View File
@@ -1,6 +1,6 @@
;;; company-files.el --- company-mode completion backend for file names
;;; company-files.el --- company-mode completion backend for file names -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2021 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2024 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -38,22 +38,14 @@ The values should use the same format as `completion-ignored-extensions'."
:type '(repeat (string :tag "File extension or directory name"))
:package-version '(company . "0.9.1"))
(defcustom company-files-chop-trailing-slash t
"Non-nil to remove the trailing slash after inserting directory name.
This way it's easy to continue completion by typing `/' again.
Set this to nil to disable that behavior."
:type 'boolean)
(defun company-files--directory-files (dir prefix)
;; Don't use directory-files. It produces directories without trailing /.
(condition-case err
(condition-case _err
(let ((comp (sort (file-name-all-completions prefix dir)
(lambda (s1 s2) (string-lessp (downcase s1) (downcase s2))))))
(when company-files-exclusions
(setq comp (company-files--exclusions-filtered comp)))
(if (equal prefix "")
(if (string-empty-p prefix)
(delete "../" (delete "./" comp))
comp))
(file-error nil)))
@@ -105,54 +97,58 @@ Set this to nil to disable that behavior."
(defvar company-files--completion-cache nil)
(defun company-files--complete (prefix)
(let* ((dir (file-name-directory prefix))
(file (file-name-nondirectory prefix))
(defun company-files--complete (_prefix)
(let* ((full-prefix (company-files--grab-existing-name))
(dir (file-name-directory full-prefix))
(file (file-name-nondirectory full-prefix))
(key (list file
(expand-file-name dir)
(nth 5 (file-attributes dir))))
(completion-ignore-case read-file-name-completion-ignore-case))
(unless (company-file--keys-match-p key (car company-files--completion-cache))
(let* ((candidates (mapcar (lambda (f) (concat dir f))
(company-files--directory-files dir file)))
(unless (or (company-file--keys-match-p key (car company-files--completion-cache))
(not (company-files--connected-p dir)))
(let* ((candidates (company-files--directory-files dir file))
(directories (unless (file-remote-p dir)
(cl-remove-if-not (lambda (f)
(and (company-files--trailing-slash-p f)
(not (file-remote-p f))
(company-files--connected-p f)))
(company-files--trailing-slash-p f))
candidates)))
(children (and directories
(cl-mapcan (lambda (d)
(mapcar (lambda (c) (concat d c))
(company-files--directory-files d "")))
(company-files--directory-files d ""))
directories))))
(setq company-files--completion-cache
(cons key (append candidates children)))))
(all-completions prefix
(cdr company-files--completion-cache))))
(all-completions file (cdr company-files--completion-cache))))
(defun company-files--prefix ()
(let ((existing (company-files--grab-existing-name)))
(when existing
(list existing (company-grab-suffix "[^ '\"\t\n\r/]*/?")))))
(defun company-file--keys-match-p (new old)
(and (equal (cdr old) (cdr new))
(string-prefix-p (car old) (car new))))
(defun company-files--post-completion (arg)
(when (and company-files-chop-trailing-slash
(company-files--trailing-slash-p arg))
(delete-char -1)))
(defun company-files--adjust-boundaries (_file prefix suffix)
(cons
(file-name-nondirectory prefix)
suffix))
;;;###autoload
(defun company-files (command &optional arg &rest ignored)
(defun company-files (command &optional arg &rest rest)
"`company-mode' completion backend existing file names.
Completions works for proper absolute and relative files paths.
File paths with spaces are only supported inside strings."
(interactive (list 'interactive))
(cl-case command
(interactive (company-begin-backend 'company-files))
(prefix (company-files--grab-existing-name))
(candidates (company-files--complete arg))
(prefix (company-files--prefix))
(candidates
(company-files--complete arg))
(adjust-boundaries
(company-files--adjust-boundaries arg (nth 0 rest) (nth 1 rest)))
(location (cons (dired-noselect
(file-name-directory (directory-file-name arg))) 1))
(post-completion (company-files--post-completion arg))
(kind (if (string-suffix-p "/" arg) 'folder 'file))
(sorted t)
(no-cache t)))
lisp/company/company-gtags.el
+5 -6
View File
@@ -1,6 +1,6 @@
;;; company-gtags.el --- company-mode completion backend for GNU Global
;;; company-gtags.el --- company-mode completion backend for GNU Global -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2021 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2021, 2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -97,7 +97,6 @@ completion."
(defun company-gtags--fetch-tags (prefix)
(with-temp-buffer
(let (tags)
;; For some reason Global v 6.6.3 is prone to returning exit status 1
;; even on successful searches when '-T' is used.
(when (/= 3 (process-file (company-gtags--executable) nil
@@ -118,7 +117,7 @@ completion."
'meta (match-string 4)
'location (cons (expand-file-name (match-string 3))
(string-to-number (match-string 2)))
))))))
)))))
(defun company-gtags--annotation (arg)
(let ((meta (get-text-property 0 'meta arg)))
@@ -135,14 +134,14 @@ completion."
start (point)))))))
;;;###autoload
(defun company-gtags (command &optional arg &rest ignored)
(defun company-gtags (command &optional arg &rest _ignored)
"`company-mode' completion backend for GNU Global."
(interactive (list 'interactive))
(cl-case command
(interactive (company-begin-backend 'company-gtags))
(prefix (and (company-gtags--executable)
buffer-file-name
(apply #'derived-mode-p company-gtags-modes)
(cl-some #'derived-mode-p company-gtags-modes)
(not (company-in-string-or-comment))
(company-gtags--tags-available-p)
(or (company-grab-symbol) 'stop)))
lisp/company/company-ispell.el
+14 -8
View File
@@ -1,4 +1,4 @@
;;; company-ispell.el --- company-mode completion backend using Ispell
;;; company-ispell.el --- company-mode completion backend using Ispell -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2016, 2018, 2021, 2023 Free Software Foundation, Inc.
@@ -39,7 +39,8 @@
(defcustom company-ispell-dictionary nil
"Dictionary to use for `company-ispell'.
If nil, use `ispell-complete-word-dict'."
If nil, use `ispell-complete-word-dict' or `ispell-alternate-dictionary'."
:type '(choice (const :tag "default (nil)" nil)
(file :tag "dictionary" t))
:set #'company--set-dictionary)
@@ -58,18 +59,23 @@ If nil, use `ispell-complete-word-dict'."
company-ispell-available)
(defun company--ispell-dict ()
(or company-ispell-dictionary
ispell-complete-word-dict
ispell-alternate-dictionary))
"Determine which dictionary to use."
(let ((dict (or company-ispell-dictionary
ispell-complete-word-dict
ispell-alternate-dictionary)))
(when dict
(expand-file-name dict))))
;;;###autoload
(defun company-ispell (command &optional arg &rest ignored)
(defun company-ispell (command &optional arg &rest _ignored)
"`company-mode' completion backend using Ispell."
(interactive (list 'interactive))
(cl-case command
(interactive (company-begin-backend 'company-ispell))
(prefix (when (company-ispell-available)
(company-grab-word)))
(list
(company-grab-word)
(company-grab-word-suffix))))
(candidates
(let* ((dict (company--ispell-dict))
(all-words
@@ -77,7 +83,7 @@ If nil, use `ispell-complete-word-dict'."
(lambda () (ispell-lookup-words "" dict))
:check-tag dict))
(completion-ignore-case t))
(if (string= arg "")
(if (string-empty-p arg)
;; Small optimization.
all-words
(company-substitute-prefix
lisp/company/company-keywords.el
+18 -3
View File
@@ -1,6 +1,6 @@
;;; company-keywords.el --- A company backend for programming language keywords
;;; company-keywords.el --- A company backend for programming language keywords -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2018, 2020-2022 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2018, 2020-2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -403,7 +403,21 @@
"i16" "i32" "i64" "include" "list" "map" "oneway" "optional" "required"
"service" "set" "string" "struct" "throws" "typedef" "void"
)
(tuareg-mode
;; ocaml, from https://v2.ocaml.org/manual/lex.html#sss:keywords
"and" "as" "asr" "assert" "begin" "class"
"constraint" "do" "done" "downto" "else" "end"
"exception" "external" "false" "for" "fun" "function"
"functor" "if" "in" "include" "inherit" "initializer"
"land" "lazy" "let" "lor" "lsl" "lsr"
"lxor" "match" "method" "mod" "module" "mutable"
"new" "nonrec" "object" "of" "open" "or"
"private" "rec" "sig" "struct" "then" "to"
"true" "try" "type" "val" "virtual" "when"
"while" "with"
)
;; aliases
(caml-mode . tuareg-mode)
(js2-mode . javascript-mode)
(js2-jsx-mode . javascript-mode)
(espresso-mode . javascript-mode)
@@ -413,6 +427,7 @@
(cperl-mode . perl-mode)
(jde-mode . java-mode)
(ess-julia-mode . julia-mode)
(php-ts-mode . php-mode)
(phps-mode . php-mode)
(enh-ruby-mode . ruby-mode))
"Alist mapping major-modes to sorted keywords for `company-keywords'.")
@@ -439,7 +454,7 @@
(makefile-mode . makefile-statements))))
;;;###autoload
(defun company-keywords (command &optional arg &rest ignored)
(defun company-keywords (command &optional arg &rest _ignored)
"`company-mode' backend for programming language keywords."
(interactive (list 'interactive))
(cl-case command
lisp/company/company-nxml.el
+7 -8
View File
@@ -1,6 +1,6 @@
;;; company-nxml.el --- company-mode completion backend for nxml-mode
;;; company-nxml.el --- company-mode completion backend for nxml-mode -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2015, 2017-2018 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2015, 2017-2018, 2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -71,12 +71,11 @@
(defmacro company-nxml-prepared (&rest body)
(declare (indent 0) (debug t))
`(let ((lt-pos (save-excursion (search-backward "<" nil t)))
xmltok-dtd)
`(let ((lt-pos (save-excursion (search-backward "<" nil t))))
(when (and lt-pos (= (rng-set-state-after lt-pos) lt-pos))
,@body)))
(defun company-nxml-tag (command &optional arg &rest ignored)
(defun company-nxml-tag (command &optional arg &rest _ignored)
(cl-case command
(prefix (and (derived-mode-p 'nxml-mode)
rng-validate-mode
@@ -86,7 +85,7 @@
arg (rng-match-possible-start-tag-names))))
(sorted t)))
(defun company-nxml-attribute (command &optional arg &rest ignored)
(defun company-nxml-attribute (command &optional arg &rest _ignored)
(cl-case command
(prefix (and (derived-mode-p 'nxml-mode)
rng-validate-mode
@@ -99,7 +98,7 @@
arg (rng-match-possible-attribute-names)))))
(sorted t)))
(defun company-nxml-attribute-value (command &optional arg &rest ignored)
(defun company-nxml-attribute-value (command &optional arg &rest _ignored)
(cl-case command
(prefix (and (derived-mode-p 'nxml-mode)
rng-validate-mode
@@ -121,7 +120,7 @@
arg (rng-match-possible-value-strings))))))))
;;;###autoload
(defun company-nxml (command &optional arg &rest ignored)
(defun company-nxml (command &optional arg &rest _ignored)
"`company-mode' completion backend for `nxml-mode'."
(interactive (list 'interactive))
(cl-case command
lisp/company/company-oddmuse.el
+3 -3
View File
@@ -1,6 +1,6 @@
;;; company-oddmuse.el --- company-mode completion backend for oddmuse-mode
;;; company-oddmuse.el --- company-mode completion backend for oddmuse-mode -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2016, 2022 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2016, 2022, 2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -41,7 +41,7 @@
(oddmuse-make-completion-table oddmuse-wiki)))))
;;;###autoload
(defun company-oddmuse (command &optional arg &rest ignored)
(defun company-oddmuse (command &optional arg &rest _ignored)
"`company-mode' completion backend for `oddmuse-mode'."
(interactive (list 'interactive))
(cl-case command
lisp/company/company-pkg.el
+3 -3
View File
@@ -1,6 +1,6 @@
(define-package "company" "20231023.1033" "Modular text completion framework"
'((emacs "25.1"))
:commit "66201465a962ac003f320a1df612641b2b276ab5" :maintainers
(define-package "company" "20250223.352" "Modular text completion framework"
'((emacs "26.1"))
:commit "5bb6f6d3d44ed919378e6968a06feed442165545" :maintainers
'(("Dmitry Gutov" . "dmitry@gutov.dev"))
:maintainer
'("Dmitry Gutov" . "dmitry@gutov.dev")
lisp/company/company-semantic.el
+7 -7
View File
@@ -1,6 +1,6 @@
;;; company-semantic.el --- company-mode completion backend using Semantic
;;; company-semantic.el --- company-mode completion backend using Semantic -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2018 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2018, 2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -126,11 +126,11 @@ and `c-electric-colon', for automatic completion right after \">\" and
(defun company-semantic--prefix ()
(if company-semantic-begin-after-member-access
(company-grab-symbol-cons "\\.\\|->\\|::" 2)
(company-grab-symbol)))
(company-grab-symbol-parts "\\.\\|->\\|::" 2)
(company-grab-symbol-parts)))
;;;###autoload
(defun company-semantic (command &optional arg &rest ignored)
(defun company-semantic (command &optional arg &rest _ignored)
"`company-mode' completion backend using CEDET Semantic."
(interactive (list 'interactive))
(cl-case command
@@ -140,7 +140,7 @@ and `c-electric-colon', for automatic completion right after \">\" and
(memq major-mode company-semantic-modes)
(not (company-in-string-or-comment))
(or (company-semantic--prefix) 'stop)))
(candidates (if (and (equal arg "")
(candidates (if (and (string-empty-p arg)
(not (looking-back "->\\|\\.\\|::" (- (point) 2))))
(company-semantic-completions-raw arg)
(company-semantic-completions arg)))
@@ -151,7 +151,7 @@ and `c-electric-colon', for automatic completion right after \">\" and
(doc-buffer (company-semantic-doc-buffer
(assoc arg company-semantic--current-tags)))
;; Because "" is an empty context and doesn't return local variables.
(no-cache (equal arg ""))
(no-cache (string-empty-p arg))
(duplicates t)
(location (let ((tag (assoc arg company-semantic--current-tags)))
(when (buffer-live-p (semantic-tag-buffer tag))
lisp/company/company-template.el
+3 -2
View File
@@ -1,6 +1,6 @@
;;; company-template.el --- utility library for template expansion
;;; company-template.el --- utility library for template expansion -*- lexical-binding: t -*-
;; Copyright (C) 2009-2010, 2013-2017, 2019 Free Software Foundation, Inc.
;; Copyright (C) 2009-2010, 2013-2017, 2019, 2023-2024 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -205,6 +205,7 @@ after deleting a field in `company-template-remove-field'."
(let* ((end (point-marker))
(beg (- (point) (length call)))
(templ (company-template-declare-template beg end))
forward-sexp-function
paren-open paren-close)
(with-syntax-table (make-syntax-table (syntax-table))
(modify-syntax-entry ?< "(")
lisp/company/company-tempo.el
+3 -3
View File
@@ -1,6 +1,6 @@
;;; company-tempo.el --- company-mode completion backend for tempo
;;; company-tempo.el --- company-mode completion backend for tempo -*- lexical-binding: t -*-
;; Copyright (C) 2009-2011, 2013-2016 Free Software Foundation, Inc.
;; Copyright (C) 2009-2011, 2013-2016, 2023 Free Software Foundation, Inc.
;; Author: Nikolaj Schumacher
@@ -56,7 +56,7 @@
(car (split-string doc "\n" t)))))
;;;###autoload
(defun company-tempo (command &optional arg &rest ignored)
(defun company-tempo (command &optional arg &rest _ignored)
"`company-mode' completion backend for tempo."
(interactive (list 'interactive))
(cl-case command
lisp/company/company-tng.el
+3 -3
View File
@@ -1,6 +1,6 @@
;;; company-tng.el --- company-mode configuration for single-button interaction
;;; company-tng.el --- company-mode configuration for single-button interaction -*- lexical-binding: t -*-
;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
;; Copyright (C) 2017-2024 Free Software Foundation, Inc.
;; Author: Nikita Leshenko
@@ -111,7 +111,7 @@ confirm the selection and finish the completion."
(let* ((ov company-tng--overlay)
(selected (and company-selection
(nth company-selection company-candidates)))
(prefix (length company-prefix)))
(prefix (length (car (company--boundaries)))))
(move-overlay ov (- (point) prefix) (point))
(overlay-put ov
(if (= prefix 0) 'after-string 'display)
lisp/company/company-yasnippet.el
+21 -7
View File
@@ -1,6 +1,6 @@
;;; company-yasnippet.el --- company-mode completion backend for Yasnippet
;;; company-yasnippet.el --- company-mode completion backend for Yasnippet -*- lexical-binding: t -*-
;; Copyright (C) 2014-2015, 2020-2022 Free Software Foundation, Inc.
;; Copyright (C) 2014-2015, 2020-2023 Free Software Foundation, Inc.
;; Author: Dmitry Gutov
@@ -72,7 +72,7 @@ It has to accept one argument: the snippet's name.")
(let ((prefix (buffer-substring-no-properties (point) original)))
(unless (equal prefix (car prefixes))
(push prefix prefixes))))
prefixes)))
(nreverse prefixes))))
(defun company-yasnippet--candidates (prefix)
;; Process the prefixes in reverse: unlike Yasnippet, we look for prefix
@@ -135,8 +135,24 @@ It has to accept one argument: the snippet's name.")
(ignore-errors (font-lock-ensure))))
(current-buffer))))
(defun company-yasnippet--prefix ()
;; We can avoid the prefix length manipulations after GH#426 is fixed.
(let* ((prefix (company-grab-symbol))
(tables (yas--get-snippet-tables))
(key-prefixes (company-yasnippet--key-prefixes))
key-prefix)
(while (and key-prefixes
(setq key-prefix (pop key-prefixes)))
(when (company-yasnippet--completions-for-prefix
prefix key-prefix tables)
;; Stop iteration.
(setq key-prefixes nil)))
(if (equal key-prefix prefix)
prefix
(cons prefix (length key-prefix)))))
;;;###autoload
(defun company-yasnippet (command &optional arg &rest ignore)
(defun company-yasnippet (command &optional arg &rest _ignore)
"`company-mode' backend for `yasnippet'.
This backend should be used with care, because as long as there are
@@ -163,10 +179,8 @@ shadow backends that come after it. Recommended usages:
(cl-case command
(interactive (company-begin-backend 'company-yasnippet))
(prefix
;; Should probably use `yas--current-key', but that's bound to be slower.
;; How many trigger keys start with non-symbol characters anyway?
(and (bound-and-true-p yas-minor-mode)
(company-grab-symbol)))
(company-yasnippet--prefix)))
(annotation
(funcall company-yasnippet-annotation-fn
(get-text-property 0 'yas-annotation arg)))
lisp/company/company.el
+931 -311
View File
File diff suppressed because it is too large Load Diff
lisp/company/company.info
+323 -207
View File
@@ -1,9 +1,10 @@
This is company.info, produced by makeinfo version 6.8 from
company.texi.
This user manual is for Company version 0.10.0 (16 April 2023).
This user manual is for Company version 1.0.3-snapshot
(7 December 2024).
Copyright © 2021-2023 Free Software Foundation, Inc.
Copyright © 2021-2024 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License,
@@ -26,9 +27,10 @@ The goal of this document is to lay out the foundational knowledge of
the package, so that the readers of the manual could competently start
adapting Company to their needs and preferences.
This user manual is for Company version 0.10.0 (16 April 2023).
This user manual is for Company version 1.0.3-snapshot
(7 December 2024).
Copyright © 2021-2023 Free Software Foundation, Inc.
Copyright © 2021-2024 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License,
@@ -104,7 +106,7 @@ File: company.info, Node: Terminology, Next: Structure, Up: Overview
1.1 Terminology
===============
“Completion” is an act of intelligibly guessing possible variants of
“Completion” is an act of intelligently guessing possible variants of
words based on already typed characters. To “complete” a word means to
insert a correctly guessed variant into the buffer.
@@ -112,20 +114,19 @@ Consequently, the “candidates” are the aforementioned guessed variants
of words. Each of the candidates has the potential to be chosen for
successful completion. And each of the candidates contains the
initially typed characters: either only at the beginning (so-called
“prefix matches”), or also inside (“non-prefix matches”) of a candidate
(1).
“prefix matches”), or also inside of a candidate (“non-prefix matches”).
Which matching method is used, depends on the current _backend_ (*note
Structure::). ‘company-capf’ is an example of a backend that supports a
number of particular non-prefix matching algorithms which are
configurable through the user option ‘completion-styles’, which see.
For illustrations on how Company visualizes the matches, *note
Frontends::.
The package’s name “Company” is based on the combination of the two
The package’s name ‘Company’ is based on the combination of the two
words: ‘Complete’ and ‘Anything’. These words reflect the package’s
commitment to handling completion candidates and its extensible nature
allowing it to cover a wide range of usage scenarios.
---------- Footnotes ----------
(1) A good starting point to learn about types of matches is to play
with the Emacs’s user option ‘completion-styles’. For illustrations on
how Company visualizes the matches, *note Frontends::.

File: company.info, Node: Structure, Prev: Terminology, Up: Overview
@@ -137,11 +138,11 @@ are pluggable modules: backends (*note Backends::) and frontends (*note
Frontends::).
The “backends” are responsible for retrieving completion candidates;
which are then outputted by the “frontends”. For an easy and quick
which are then displayed by the “frontends”. For an easy and quick
initial setup, Company is supplied with the preconfigured sets of the
backends and frontends. The default behavior of the modules can be
adjusted per particular needs, goals, and preferences. It is also
typical to utilize backends from a variety of third-party libraries
adjusted for particular needs, and preferences. It is also typical to
utilize backends from a variety of third-party libraries
(https://github.com/company-mode/company-mode/wiki/Third-Party-Packages),
developed to be pluggable with Company.
@@ -149,7 +150,7 @@ But Company consists not only of the backends and frontends.
A core of the package plays the role of a controller, connecting the
modules, making them work together; and exposing configurations and
commands for a user to operate with. For more details, *note
commands for the user to operate with. For more details, *note
Customization:: and *note Commands::.
Also, Company is bundled with an alternative workflow configuration
@@ -202,7 +203,7 @@ indicator ‘company’.
After _company-mode_ had been enabled, the package auto-starts
suggesting completion candidates. The candidates are retrieved and
shown according to the typed characters and the default (until a user
shown according to the typed characters and the default (until the user
specifies otherwise) configurations.
To have Company always enabled for the following sessions, add the line
@@ -216,7 +217,7 @@ File: company.info, Node: Usage Basics, Next: Commands, Prev: Initial Setup,
================
By default — having _company-mode_ enabled (*note Initial Setup::) — a
tooltip with completion candidates is shown when a user types in a few
tooltip with completion candidates is shown when the user types a few
characters.
To initiate completion manually, use the command ‘M-x company-complete’.
@@ -226,8 +227,11 @@ respectively key bindings ‘C-n’ and ‘C-p’, then do one of the following:
• Hit <RET> to choose a selected candidate for completion.
• Hit <TAB> to complete with the “common part”: characters present at
the beginning of all the candidates.
• Hit <TAB> to expand the “common part” of all completions. Exactly
what that means, can vary by backend. In the simplest case it’s
the longest string that all completion start with, but when a
backend returns _non-prefix matches_, it can implement the same
kind of expansion logic for the input string.
• Hit ‘C-g’ to stop activity of Company.
@@ -253,11 +257,15 @@ commands of the out-of-the-box Company.
‘RET’
‘<return>’
Insert the selected candidate (‘company-complete-selection’).
Restart completion if a new field is entered.
‘TAB’
‘<tab>’
Insert the common part of all the candidates
(‘company-complete-common’).
Insert the _common part_ of all completion candidates or — if no
_common part_ is present — select the next candidate
(‘company-complete-common-or-cycle’). In the latter case,
wraparound is implicitly enabled (*note
company-selection-wrap-around::).
‘C-g’
‘<ESC ESC ESC>’
@@ -285,17 +293,8 @@ illustrate how to assign key bindings to such commands.
(global-set-key (kbd "<tab>") #'company-indent-or-complete-common)
(with-eval-after-load 'company
(define-key company-active-map (kbd "M-/") #'company-complete))
(with-eval-after-load 'company
(define-key company-active-map
(kbd "TAB")
#'company-complete-common-or-cycle)
(define-key company-active-map
(kbd "<backtab>")
(lambda ()
(interactive)
(company-complete-common-or-cycle -1))))
(define-key company-active-map (kbd "M-/") #'company-complete)
(define-key company-active-map (kbd "C-M-/") #'company-complete-common))
In the same manner, an additional key can be assigned to a command or a
command can be unbound from a key. For instance:
@@ -350,7 +349,7 @@ File: company.info, Node: Configuration File, Prev: Customization Interface,
======================
Company is a customization-rich package. This section lists some of the
core settings that influence the overall behavior of the _company-mode_.
core settings that influence its overall behavior.
-- User Option: company-minimum-prefix-length
This is one of the values (together with ‘company-idle-delay’),
@@ -374,6 +373,10 @@ core settings that influence the overall behavior of the _company-mode_.
(setq company-idle-delay
(lambda () (if (company-in-string-or-comment) nil 0.3)))
-- User Option: company-inhibit-inside-symbols
You can set this option to ‘t’ to disable the auto-start behavior
when in the middle of a symbol.
-- User Option: company-global-modes
This option allows to specify in which major modes _company-mode_
can be enabled by ‘(global-company-mode)’. *Note Initial Setup::.
@@ -398,8 +401,8 @@ core settings that influence the overall behavior of the _company-mode_.
To allow typing in characters that don’t match the candidates, set
the value of this option to ‘nil’. For an opposite behavior (that
is, to disallow non-matching input), set it to ‘t’. By default,
Company is configured to require a matching input only if a user
manually enables completion or selects a candidate; by having the
Company is configured to require a matching input only if the user
invokes completion manually or selects a candidate; by having the
option configured to call the function ‘company-explicit-action-p’.
-- User Option: company-lighter-base
@@ -575,12 +578,11 @@ user options.
[image src="./images/small/tooltip-minimum-above.png"]
-- User Option: company-tooltip-flip-when-above
This is one of the fancy features Company has to suggest. When
this setting is enabled, no matter if a tooltip is shown above or
below point, the candidates are always listed starting near point.
(Putting it differently, the candidates are mirrored horizontally
if a tooltip changes its position, instead of being commonly listed
top-to-bottom.)
When this setting is enabled, no matter if a tooltip is shown above
or below point, the candidates are always listed starting near
point. (Putting it differently, the candidates are mirrored
vertically if a tooltip changes its position, instead of being
commonly listed top-to-bottom.)
(setq company-tooltip-flip-when-above t)
@@ -588,7 +590,7 @@ user options.
-- User Option: company-tooltip-minimum-width
Sets the minimum width of a tooltip, excluding the margins and the
scroll bar. Changing this value especially makes sense if a user
scroll bar. Changing this value especially makes sense if the user
navigates between tooltip pages. Keeping this value at the default
‘0’ allows Company to always adapt the width of the tooltip to the
longest shown candidate. Enlarging ‘company-tooltip-minimum-width’
@@ -630,7 +632,7 @@ the variable ‘company-vscode-icons-mapping’.)
-- User Option: company-format-margin-function
Allows setting a function to format the left margin of a tooltip
inner area; namely, to output candidate’s _icons_. The predefined
formatting functions are listed below. A user may also set this
formatting functions are listed below. The user may also set this
option to a custom function. To disable left margin formatting,
set the value of the option to ‘nil’ (this way control over the
size of the left margin returns to the user option
@@ -694,14 +696,14 @@ Faces
Out-of-the-box Company defines and configures distinguished faces (*note
(emacs)Faces::) for light and dark themes. Moreover, some of the
built-in and third-party themes fine-tune Company to fit their palettes.
That is why there’s often no real need to make such adjustments on a
user side. However, this chapter presents some hints on where to start
customizing Company interface.
That is why there’s often no real need to make such adjustments on the
user’s side. However, this chapter presents some hints on where to
start customizing Company interface.
Namely, the look of a tooltip is controlled by the ‘company-tooltip*’
named faces.
The following example hints how a user may approach tooltip faces
The following example suggests how users may approach tooltip faces
customization:
(custom-set-faces
@@ -730,7 +732,7 @@ File: company.info, Node: Preview Frontends, Next: Echo Frontends, Prev: Tool
=====================
Frontends in this group output a completion candidate or a common part
of the candidates temporarily inline, as if a word had already been
of the candidates temporarily inline, as if the word had already been
completed (1).
-- Function: company-preview-if-just-one-frontend
@@ -910,19 +912,18 @@ File: company.info, Node: Backends, Next: Troubleshooting, Prev: Frontends,
**********
We can metaphorically say that each backend is like an engine. (The
reality is even better since backends are just functions.) Fueling such
reality is even better since backends are just functions.) Firing such
an engine with a command causes the production of material for Company
to move further on. Typically, moving on means outputting that material
to a user via one or several configured frontends, *note Frontends::.
to work on. Typically, that means showing that output to the user via
one or several configured frontends, *note Frontends::.
Just like Company provides a preconfigured list of the enabled
frontends, it also defines a list of the backends to rely on by default.
This list is stored in the user option ‘company-backends’. The
docstring of this variable has been a source of valuable information for
years. That’s why we’re going to stick to a tradition and suggest
reading the output of ‘C-h v company-backends’ for insightful details
about backends. Nevertheless, the fundamental concepts are described in
this user manual too.
docstring of this variable has the full description of what a backend is
and how to implement one. So we suggest reading the output of ‘C-h v
company-backends’ for more details. Nevertheless, the fundamental
concepts are described in this user manual too.
* Menu:
@@ -940,16 +941,18 @@ File: company.info, Node: Backends Usage Basics, Next: Grouped Backends, Up:
One of the significant concepts to understand about Company is that the
package relies on one backend at a time (1). The backends are invoked
one by one, in the sequential order of the items on the
‘company-backends’ list.
‘company-backends’ list. The first one that reports itself applicable
in the current context (usually based on the value of ‘major-mode’ and
the text around point), is used for completion.
The name of the currently active backend is shown in the mode line and
in the output of the command ‘M-x company-diag’.
In most cases (mainly to exclude false-positive results), the next
backend is not invoked automatically. For the purpose of invoking the
next backend, use the command ‘company-other-backend’: either by calling
it with ‘M-x’ or by binding the command to the keys of your choice, such
as:
In most cases (mainly to exclude false-positive results), if the current
applicable backend returned no completions, the ones after it in the
list are not invoked. If you do want to query the next one, use the
command ‘company-other-backend’: either by calling it with ‘M-x’ or by
binding the command to the keys of your choice, like:
(global-set-key (kbd "C-c C-/") #'company-other-backend)
@@ -977,9 +980,7 @@ backends”: a sub-list of backends in the ‘company-backends’ list, that
is handled specifically by Company.
The most important part of this handling is the merge of the completion
candidates from the grouped backends. (But only from the backends that
return the same _prefix_ value, see ‘C-h v company-backends’ for more
details.)
candidates from the grouped backends.
To keep the candidates organized in accordance with the grouped backends
order, add the keyword ‘:separate’ to the list of the grouped backends.
@@ -1040,13 +1041,14 @@ File: company.info, Node: Code Completion, Next: Text Completion, Up: Package
---------------------
-- Function: company-capf
In the Emacs’s world, the current tendency is to have the
completion logic provided by ‘completion-at-point-functions’ (CAPF)
implementations. [Among the other things, this is what the popular
packages that support language server protocol (LSP) also rely on.]
The current trend in the Emacs’s world is to delegate completion
logic to the hook ‘completion-at-point-functions’ (CAPF) assigned
to by the major or minor modes. It supports a common subset of
features which is well-supported across different completion UIs.
[Among other things, this is what the most popular Emacs clients
for the language server protocol (LSP) also rely on.]
Since _company-capf_ works as a bridge to the standard CAPF
facility, it is probably the most often used and recommended
For that reason, it is probably the most used and recommended
backend nowadays, including for Emacs Lisp coding.
Just to illustrate, the following minimal backends setup
@@ -1058,11 +1060,46 @@ File: company.info, Node: Code Completion, Next: Text Completion, Up: Package
For more details on CAPF, *note (elisp)Completion in Buffers::.
-- User Option: company-capf-disabled-functions
List of completion functions which should be ignored by this
backend. By default it contains the functions that duplicate the
built-in backends but don’t support the corresponding configuration
options and/or alter the intended priority of the default backends’
configuration.
-- Function: company-dabbrev-code
This backend works similarly to the built-in Emacs package
_dabbrev_, searching for completion candidates inside the contents
of the open buffer(s). Internally, its based on the backend
_company-dabbrev_ (*note Text Completion::).
of the open buffer(s). Internally, it reuses code from the other
backend, ‘company-dabbrev’ (*note Text Completion::).
-- User Option: company-dabbrev-code-modes
This variable lists the modes that use ‘company-dabbrev-code’. The
backend will only perform completion in these major modes and their
derivatives. Otherwise it passes control to other backends. Value
t means complete in all modes.
-- User Option: company-dabbrev-code-other-buffers
This variable determined whether ‘company-dabbrev-code’ will search
other buffers for completions. If ‘all’, it will search all other
buffers except the ignored ones (names starting with a space). If
‘t’, it will search buffers with the same major mode. If ‘code’,
it will search buffers with major modes in
‘company-dabbrev-code-modes’ or derived from one of them. This can
also be a function that takes the current buffer as parameter and
returns a list of major modes to search.
-- User Option: company-dabbrev-code-everywhere
This is a boolean option which determines whether this backend will
perform completion in strings and comments as well. The default
value ‘nil’ means it will pass on control to other backends in such
contexts.
-- User Option: company-dabbrev-code-completion-styles
Non-nil to use ‘completion-styles’ for matching completions in this
backend. It can be set to ‘t’ to use the global value of
‘completion-styles’, or to a list of symbols to use specific
completion styles with this backend. The default value is nil.
-- Function: company-keywords
This backend provides completions for many of the widely spread
@@ -1072,21 +1109,45 @@ File: company.info, Node: Code Completion, Next: Text Completion, Up: Package
-- Function: company-clang
As the name suggests, use this backend to get completions from
_Clang_ compiler; that is, for the languages in the _C_ language
family: _C_, _C++_, _Objective-C_.
family: _C_, _C++_, _Objective-C_. It uses the command-line
interface of the program ‘clang’, but without any advanced caching
across calls, or automatic detection of the project structure.
Which makes it more suitable for small to medium projects,
especially if you’re willing to customize
‘company-clang-arguments’. Otherwise we recommend using one of the
LSP clients available for Emacs, together with the backend
‘company-capf’.
-- User Option: company-clang-arguments
This option can be set to a list of strings which will be passed to
_clang_ during completion. These can include elements like ‘"-I"
"path/to/includes/dir"’ to indicate the header directories and
other compiler options.
-- Function: company-semantic
This backend relies on a built-in Emacs package that provides
language-aware editing commands based on source code parsers, *note
(emacs)Semantic::. Having enabled _semantic-mode_ makes it to be
used by the CAPF mechanism (*note (emacs)Symbol Completion::),
hence a user may consider enabling _company-capf_ backend instead.
hence the user may consider enabling _company-capf_ backend
instead.
-- Function: company-etags
This backend works on top of a built-in Emacs package _etags_,
*note (emacs)Tags Tables::. Similarly to aforementioned _Semantic_
usage, tags-based completions now are a part of the Emacs’ CAPF
facility, therefore a user may consider switching to _company-capf_
backend.
This backend uses tags tables as produced by the built-in Emacs
program _etags_, *note (emacs)Tags Tables::.
-- User Option: company-etags-ignore-case
Non-nil to ignore case in this backend’s completions.
-- User Option: company-etags-everywhere
Non-nil to offer completions in comments and strings. It can also
be set to ‘t’ or a list of major modes in which this would happen.
-- User Option: company-etags-completion-styles
Non-nil to use ‘completion-styles’ for matching completions in this
backend. It can be set to ‘t’ to use the global value of
‘completion-styles’, or to a list of symbols to use specific
completion styles with this backend. The default value is nil.

File: company.info, Node: Text Completion, Next: File Name Completion, Prev: Code Completion, Up: Package Backends
@@ -1235,16 +1296,42 @@ File: company.info, Node: Candidates Post-Processing, Prev: Package Backends,
5.4 Candidates Post-Processing
==============================
A list of completion candidates, supplied by a backend, can be
additionally manipulated (reorganized, reduced, sorted, etc) before its
output. This is done by adding a processing function name to the user
option ‘company-transformers’ list, for example:
A list of completion candidates supplied by backends can be manipulated
before output: reorganized, reduced, sorted, etc. To apply adjustments,
add a processing function name to the user option ‘company-transformers’
list.
The transformer functions are called in a sequence, each with the return
value of the previous one. The first function receives a sorted list of
distinct completion candidates. Note that the default sorting behavior
may be overridden by backends and influenced by the use of the keyword
‘:separate’ in the grouped backends list (*note Grouped Backends::).
Since Company does not treat candidates with differing annotations as
duplicates, it may sometimes be desirable to condense completion lists
containing such entries. In the example below, post-processing begins
with their removal. Then, the weighted ordering of the candidates is
performed.
;; Set grouped backends.
(setq company-backends '((company-capf company-dabbrev-code)))
;; Apply post-processing.
(setq company-transformers '(delete-consecutive-dups
company-sort-by-occurrence))
Company is bundled with several such transformer functions. They are
listed below.
If a grouped backend contains the keyword ‘:separate’, you can use the
‘delete-dups’ function instead.
;; Set grouped backends.
(setq company-backends
'((:separate company-capf company-dabbrev-code)))
;; Apply post-processing.
(setq company-transformers '(delete-dups
company-sort-by-occurrence))
Company is bundled with several transformer functions.
-- Function: company-sort-by-occurrence
Sorts candidates using ‘company-occurrence-weight-function’
@@ -1329,11 +1416,11 @@ Key Index
[index]
* Menu:
* C-g: Usage Basics. (line 20)
* C-g <1>: Commands. (line 30)
* C-g: Usage Basics. (line 23)
* C-g <1>: Commands. (line 34)
* C-g <2>: Candidates Search. (line 11)
* C-g <3>: Filter Candidates. (line 14)
* C-h: Commands. (line 34)
* C-h: Commands. (line 38)
* C-M-s: Filter Candidates. (line 6)
* C-n: Usage Basics. (line 12)
* C-n <1>: Commands. (line 11)
@@ -1341,13 +1428,13 @@ Key Index
* C-p: Usage Basics. (line 12)
* C-p <1>: Commands. (line 16)
* C-s: Candidates Search. (line 6)
* C-w: Commands. (line 41)
* C-w: Commands. (line 45)
* M-<digit>: Quick Access a Candidate.
(line 6)
* RET: Usage Basics. (line 15)
* RET <1>: Commands. (line 21)
* TAB: Usage Basics. (line 17)
* TAB <1>: Commands. (line 25)
* TAB <1>: Commands. (line 26)

File: company.info, Node: Variable Index, Next: Function Index, Prev: Key Index, Up: Index
@@ -1358,59 +1445,69 @@ Variable Index
[index]
* Menu:
* company-after-completion-hook: Configuration File. (line 94)
* company-after-completion-hook: Configuration File. (line 98)
* company-backends: Backends. (line 12)
* company-backends <1>: Backends Usage Basics.
(line 6)
* company-backends <2>: Grouped Backends. (line 6)
* company-completion-cancelled-hook: Configuration File. (line 90)
* company-completion-finished-hook: Configuration File. (line 92)
* company-completion-started-hook: Configuration File. (line 88)
* company-capf-disabled-functions: Code Completion. (line 26)
* company-clang-arguments: Code Completion. (line 84)
* company-completion-cancelled-hook: Configuration File. (line 94)
* company-completion-finished-hook: Configuration File. (line 96)
* company-completion-started-hook: Configuration File. (line 92)
* company-dabbrev-code-completion-styles: Code Completion. (line 61)
* company-dabbrev-code-everywhere: Code Completion. (line 55)
* company-dabbrev-code-modes: Code Completion. (line 39)
* company-dabbrev-code-other-buffers: Code Completion. (line 45)
* company-dabbrev-downcase: Text Completion. (line 64)
* company-dabbrev-ignore-buffers: Text Completion. (line 32)
* company-dabbrev-ignore-case: Text Completion. (line 47)
* company-dabbrev-minimum-length: Text Completion. (line 13)
* company-dabbrev-other-buffers: Text Completion. (line 23)
* company-dot-icons-format: Tooltip Frontends. (line 184)
* company-dot-icons-format: Tooltip Frontends. (line 183)
* company-echo-truncate-lines: Echo Frontends. (line 33)
* company-etags-completion-styles: Code Completion. (line 109)
* company-etags-everywhere: Code Completion. (line 105)
* company-etags-ignore-case: Code Completion. (line 102)
* company-files-chop-trailing-slash: File Name Completion.
(line 19)
* company-files-exclusions: File Name Completion.
(line 12)
* company-format-margin-function: Tooltip Frontends. (line 159)
* company-format-margin-function: Tooltip Frontends. (line 158)
* company-frontends: Frontends. (line 6)
* company-global-modes: Configuration File. (line 31)
* company-icon-margin: Tooltip Frontends. (line 170)
* company-icon-size: Tooltip Frontends. (line 170)
* company-global-modes: Configuration File. (line 35)
* company-icon-margin: Tooltip Frontends. (line 169)
* company-icon-size: Tooltip Frontends. (line 169)
* company-idle-delay: Configuration File. (line 17)
* company-insertion-on-trigger: Configuration File. (line 64)
* company-insertion-triggers: Configuration File. (line 72)
* company-inhibit-inside-symbols: Configuration File. (line 31)
* company-insertion-on-trigger: Configuration File. (line 68)
* company-insertion-triggers: Configuration File. (line 76)
* company-ispell-dictionary: Text Completion. (line 84)
* company-lighter-base: Configuration File. (line 59)
* company-lighter-base: Configuration File. (line 63)
* company-minimum-prefix-length: Configuration File. (line 9)
* company-mode: Initial Setup. (line 6)
* company-occurrence-weight-function: Candidates Post-Processing.
(line 21)
* company-require-match: Configuration File. (line 51)
(line 47)
* company-require-match: Configuration File. (line 55)
* company-search-regexp-function: Candidates Search. (line 13)
* company-selection-wrap-around: Configuration File. (line 43)
* company-selection-wrap-around: Configuration File. (line 47)
* company-show-quick-access: Quick Access a Candidate.
(line 12)
* company-text-face-extra-attributes: Tooltip Frontends. (line 197)
* company-text-icons-add-background: Tooltip Frontends. (line 205)
* company-text-icons-format: Tooltip Frontends. (line 177)
* company-text-icons-mapping: Tooltip Frontends. (line 193)
* company-text-face-extra-attributes: Tooltip Frontends. (line 196)
* company-text-icons-add-background: Tooltip Frontends. (line 204)
* company-text-icons-format: Tooltip Frontends. (line 176)
* company-text-icons-mapping: Tooltip Frontends. (line 192)
* company-tooltip-align-annotations: Tooltip Frontends. (line 51)
* company-tooltip-annotation-padding: Tooltip Frontends. (line 63)
* company-tooltip-flip-when-above: Tooltip Frontends. (line 106)
* company-tooltip-idle-delay: Tooltip Frontends. (line 21)
* company-tooltip-limit: Tooltip Frontends. (line 71)
* company-tooltip-margin: Tooltip Frontends. (line 140)
* company-tooltip-maximum-width: Tooltip Frontends. (line 133)
* company-tooltip-margin: Tooltip Frontends. (line 139)
* company-tooltip-maximum-width: Tooltip Frontends. (line 132)
* company-tooltip-minimum: Tooltip Frontends. (line 91)
* company-tooltip-minimum-width: Tooltip Frontends. (line 118)
* company-tooltip-minimum-width: Tooltip Frontends. (line 117)
* company-tooltip-offset-display: Tooltip Frontends. (line 81)
* company-tooltip-width-grow-only: Tooltip Frontends. (line 128)
* company-tooltip-width-grow-only: Tooltip Frontends. (line 127)
* company-transformers: Candidates Post-Processing.
(line 6)
@@ -1424,32 +1521,35 @@ Function Index
* Menu:
* company-abbrev: Template Expansion. (line 6)
* company-abort: Commands. (line 30)
* company-abort: Commands. (line 34)
* company-begin-backend: Backends Usage Basics.
(line 22)
(line 24)
* company-capf: Code Completion. (line 6)
* company-clang: Code Completion. (line 36)
* company-clang: Code Completion. (line 72)
* company-complete: Usage Basics. (line 10)
* company-complete-common: Commands. (line 25)
* company-complete <1>: Commands. (line 51)
* company-complete-common: Commands. (line 51)
* company-complete-common-or-cycle: Commands. (line 26)
* company-complete-selection: Commands. (line 21)
* company-dabbrev: Text Completion. (line 6)
* company-dabbrev-code: Code Completion. (line 25)
* company-detect-icons-margin: Tooltip Frontends. (line 214)
* company-dabbrev-code: Code Completion. (line 33)
* company-detect-icons-margin: Tooltip Frontends. (line 213)
* company-diag: Backends Usage Basics.
(line 11)
(line 13)
* company-diag <1>: Troubleshooting. (line 6)
* company-dot-icons-margin: Tooltip Frontends. (line 183)
* company-dot-icons-margin: Tooltip Frontends. (line 182)
* company-echo-frontend: Echo Frontends. (line 21)
* company-echo-metadata-frontend: Echo Frontends. (line 9)
* company-echo-strip-common-frontend: Echo Frontends. (line 27)
* company-etags: Code Completion. (line 48)
* company-etags: Code Completion. (line 98)
* company-files: File Name Completion.
(line 6)
* company-indent-or-complete-common: Commands. (line 51)
* company-ispell: Text Completion. (line 75)
* company-keywords: Code Completion. (line 31)
* company-keywords: Code Completion. (line 67)
* company-mode: Initial Setup. (line 6)
* company-other-backend: Backends Usage Basics.
(line 14)
(line 16)
* company-preview-common-frontend: Preview Frontends. (line 21)
* company-preview-frontend: Preview Frontends. (line 17)
* company-preview-if-just-one-frontend: Preview Frontends. (line 10)
@@ -1466,21 +1566,21 @@ Function Index
* company-select-next-or-abort: Commands. (line 11)
* company-select-previous: Commands. (line 16)
* company-select-previous-or-abort: Commands. (line 16)
* company-semantic: Code Completion. (line 41)
* company-show-doc-buffer: Commands. (line 34)
* company-show-location: Commands. (line 41)
* company-semantic: Code Completion. (line 90)
* company-show-doc-buffer: Commands. (line 38)
* company-show-location: Commands. (line 45)
* company-sort-by-backend-importance: Candidates Post-Processing.
(line 27)
(line 53)
* company-sort-by-occurrence: Candidates Post-Processing.
(line 17)
(line 43)
* company-sort-prefer-same-case-prefix: Candidates Post-Processing.
(line 33)
(line 59)
* company-tempo: Template Expansion. (line 11)
* company-text-icons-margin: Tooltip Frontends. (line 176)
* company-text-icons-margin: Tooltip Frontends. (line 175)
* company-tng-frontend: Structure. (line 26)
* company-tng-mode: Structure. (line 26)
* company-vscode-dark-icons-margin: Tooltip Frontends. (line 168)
* company-vscode-light-icons-margin: Tooltip Frontends. (line 169)
* company-vscode-dark-icons-margin: Tooltip Frontends. (line 167)
* company-vscode-light-icons-margin: Tooltip Frontends. (line 168)
* company-yasnippet: Template Expansion. (line 16)
* global-company-mode: Initial Setup. (line 18)
@@ -1493,47 +1593,57 @@ Concept Index
[index]
* Menu:
* :separate: Grouped Backends. (line 14)
* :separate <1>: Candidates Post-Processing.
(line 11)
* :separate <2>: Candidates Post-Processing.
(line 30)
* :with: Grouped Backends. (line 25)
* abbrev: Template Expansion. (line 6)
* abort: Usage Basics. (line 20)
* abort <1>: Commands. (line 30)
* abort: Usage Basics. (line 23)
* abort <1>: Commands. (line 34)
* activate: Initial Setup. (line 8)
* active backend: Backends Usage Basics.
(line 11)
(line 13)
* active backend <1>: Troubleshooting. (line 14)
* annotation: Tooltip Frontends. (line 52)
* annotation <1>: Candidates Post-Processing.
(line 17)
* auto-start: Initial Setup. (line 13)
* backend: Structure. (line 6)
* backend <1>: Structure. (line 10)
* backend <2>: Backends Usage Basics.
(line 11)
(line 13)
* backend <3>: Backends Usage Basics.
(line 14)
(line 16)
* backend <4>: Troubleshooting. (line 14)
* backends: Backends. (line 6)
* backends <1>: Backends Usage Basics.
(line 6)
* backends <2>: Grouped Backends. (line 6)
* backends <3>: Package Backends. (line 6)
* backends <4>: Candidates Post-Processing.
(line 11)
* basics: Usage Basics. (line 6)
* bug: Troubleshooting. (line 6)
* bug <1>: Troubleshooting. (line 25)
* bundled backends: Package Backends. (line 6)
* cancel: Usage Basics. (line 20)
* cancel <1>: Commands. (line 30)
* cancel: Usage Basics. (line 23)
* cancel <1>: Commands. (line 34)
* candidate: Terminology. (line 10)
* candidate <1>: Usage Basics. (line 12)
* candidate <2>: Usage Basics. (line 15)
* candidate <3>: Preview Frontends. (line 6)
* color: Tooltip Frontends. (line 223)
* color: Tooltip Frontends. (line 222)
* color <1>: Quick Access a Candidate.
(line 34)
* common part: Usage Basics. (line 17)
* common part <1>: Commands. (line 25)
* common part <1>: Commands. (line 26)
* common part <2>: Preview Frontends. (line 6)
* company-echo: Echo Frontends. (line 6)
* company-preview: Preview Frontends. (line 6)
* company-tng: Structure. (line 26)
* company-tooltip: Tooltip Frontends. (line 223)
* company-tooltip: Tooltip Frontends. (line 222)
* company-tooltip-search: Candidates Search. (line 6)
* complete: Terminology. (line 6)
* complete <1>: Usage Basics. (line 12)
@@ -1550,7 +1660,7 @@ Concept Index
(line 6)
* configure <2>: Configuration File. (line 6)
* configure <3>: Tooltip Frontends. (line 48)
* configure <4>: Tooltip Frontends. (line 223)
* configure <4>: Tooltip Frontends. (line 222)
* configure <5>: Preview Frontends. (line 25)
* configure <6>: Echo Frontends. (line 38)
* configure <7>: Candidates Search. (line 30)
@@ -1563,7 +1673,7 @@ Concept Index
(line 6)
* custom <2>: Configuration File. (line 6)
* custom <3>: Tooltip Frontends. (line 48)
* custom <4>: Tooltip Frontends. (line 223)
* custom <4>: Tooltip Frontends. (line 222)
* custom <5>: Preview Frontends. (line 25)
* custom <6>: Echo Frontends. (line 38)
* custom <7>: Candidates Search. (line 30)
@@ -1571,18 +1681,20 @@ Concept Index
(line 25)
* custom <9>: Quick Access a Candidate.
(line 34)
* definition: Commands. (line 41)
* definition: Commands. (line 45)
* distribution: Installation. (line 6)
* doc: Commands. (line 34)
* duplicate: Candidates Post-Processing.
(line 6)
* doc: Commands. (line 38)
* duplicates: Candidates Post-Processing.
(line 17)
* duplicates <1>: Candidates Post-Processing.
(line 30)
* echo: Echo Frontends. (line 6)
* enable: Initial Setup. (line 8)
* error: Troubleshooting. (line 6)
* error <1>: Troubleshooting. (line 25)
* expansion: Template Expansion. (line 6)
* extensible: Structure. (line 6)
* face: Tooltip Frontends. (line 223)
* face: Tooltip Frontends. (line 222)
* face <1>: Preview Frontends. (line 6)
* face <2>: Preview Frontends. (line 25)
* face <3>: Echo Frontends. (line 6)
@@ -1593,19 +1705,21 @@ Concept Index
* face <8>: Quick Access a Candidate.
(line 34)
* filter: Filter Candidates. (line 6)
* finish: Usage Basics. (line 20)
* finish <1>: Commands. (line 30)
* font: Tooltip Frontends. (line 223)
* finish: Usage Basics. (line 23)
* finish <1>: Commands. (line 34)
* font: Tooltip Frontends. (line 222)
* font <1>: Quick Access a Candidate.
(line 34)
* frontend: Structure. (line 6)
* frontend <1>: Structure. (line 10)
* frontends: Frontends. (line 6)
* grouped backends: Grouped Backends. (line 6)
* icon: Tooltip Frontends. (line 152)
* grouped backends <1>: Candidates Post-Processing.
(line 11)
* icon: Tooltip Frontends. (line 151)
* install: Installation. (line 6)
* interface: Tooltip Frontends. (line 48)
* interface <1>: Tooltip Frontends. (line 223)
* interface <1>: Tooltip Frontends. (line 222)
* interface <2>: Preview Frontends. (line 25)
* interface <3>: Echo Frontends. (line 38)
* interface <4>: Candidates Search. (line 30)
@@ -1614,30 +1728,32 @@ Concept Index
* intro: Initial Setup. (line 6)
* issue: Troubleshooting. (line 6)
* issue tracker: Troubleshooting. (line 25)
* kind: Tooltip Frontends. (line 152)
* location: Commands. (line 41)
* kind: Tooltip Frontends. (line 151)
* location: Commands. (line 45)
* manual: Initial Setup. (line 8)
* manual <1>: Usage Basics. (line 10)
* margin: Tooltip Frontends. (line 141)
* margin <1>: Tooltip Frontends. (line 160)
* margin: Tooltip Frontends. (line 140)
* margin <1>: Tooltip Frontends. (line 159)
* minor-mode: Initial Setup. (line 6)
* module: Structure. (line 6)
* module <1>: Structure. (line 10)
* navigate: Usage Basics. (line 12)
* next backend: Backends Usage Basics.
(line 14)
(line 16)
* non-prefix matches: Terminology. (line 10)
* package: Installation. (line 6)
* package backends: Package Backends. (line 6)
* pluggable: Structure. (line 6)
* pop-up: Tooltip Frontends. (line 6)
* post-processing: Candidates Post-Processing.
(line 6)
* prefix matches: Terminology. (line 10)
* preview: Preview Frontends. (line 6)
* quick start: Initial Setup. (line 6)
* quick-access: Quick Access a Candidate.
(line 6)
* quit: Usage Basics. (line 20)
* quit <1>: Commands. (line 30)
* quit: Usage Basics. (line 23)
* quit <1>: Commands. (line 34)
* search: Candidates Search. (line 6)
* select: Usage Basics. (line 12)
* select <1>: Commands. (line 11)
@@ -1645,8 +1761,8 @@ Concept Index
* snippet: Template Expansion. (line 6)
* sort: Candidates Post-Processing.
(line 6)
* stop: Usage Basics. (line 20)
* stop <1>: Commands. (line 30)
* stop: Usage Basics. (line 23)
* stop <1>: Commands. (line 34)
* TAB: Structure. (line 26)
* Tab and Go: Structure. (line 26)
* template: Template Expansion. (line 6)
@@ -1659,45 +1775,45 @@ Concept Index

Tag Table:
Node: Top563
Node: Overview1982
Node: Terminology2390
Ref: Terminology-Footnote-13377
Node: Structure3583
Node: Getting Started5079
Node: Installation5357
Node: Initial Setup5740
Node: Usage Basics6586
Node: Commands7349
Ref: Commands-Footnote-19784
Node: Customization9951
Node: Customization Interface10423
Node: Configuration File10956
Node: Frontends15622
Node: Tooltip Frontends16591
Ref: Tooltip Frontends-Footnote-127358
Node: Preview Frontends27595
Ref: Preview Frontends-Footnote-128851
Node: Echo Frontends28978
Node: Candidates Search30511
Node: Filter Candidates31845
Node: Quick Access a Candidate32625
Node: Backends34243
Node: Backends Usage Basics35341
Ref: Backends Usage Basics-Footnote-136556
Node: Grouped Backends36640
Node: Package Backends38269
Node: Code Completion39198
Node: Text Completion41567
Node: File Name Completion46001
Node: Template Expansion47549
Node: Candidates Post-Processing48268
Node: Troubleshooting49745
Node: Index51418
Node: Key Index51581
Node: Variable Index53080
Node: Function Index57203
Node: Concept Index61684
Node: Top573
Node: Overview2002
Node: Terminology2410
Node: Structure3717
Node: Getting Started5208
Node: Installation5486
Node: Initial Setup5869
Node: Usage Basics6717
Node: Commands7695
Ref: Commands-Footnote-110093
Node: Customization10260
Node: Customization Interface10732
Node: Configuration File11265
Ref: company-selection-wrap-around13579
Node: Frontends16072
Node: Tooltip Frontends17041
Ref: Tooltip Frontends-Footnote-127755
Node: Preview Frontends27992
Ref: Preview Frontends-Footnote-129250
Node: Echo Frontends29377
Node: Candidates Search30910
Node: Filter Candidates32244
Node: Quick Access a Candidate33024
Node: Backends34642
Node: Backends Usage Basics35672
Ref: Backends Usage Basics-Footnote-137104
Node: Grouped Backends37188
Node: Package Backends38699
Node: Code Completion39628
Node: Text Completion45155
Node: File Name Completion49589
Node: Template Expansion51137
Node: Candidates Post-Processing51856
Node: Troubleshooting54433
Node: Index56106
Node: Key Index56269
Node: Variable Index57768
Node: Function Index62621
Node: Concept Index67321

End Tag Table
lisp/counsel/counsel-pkg.el
+6 -6
View File
@@ -1,13 +1,13 @@
(define-package "counsel" "20231025.2311" "Various completion functions using Ivy"
(define-package "counsel" "20250224.2125" "Various completion functions using Ivy"
'((emacs "24.5")
(ivy "0.14.2")
(swiper "0.14.2"))
:commit "8c30f4cab5948aa8d942a3b2bbf5fb6a94d9441d" :authors
(ivy "0.15.0")
(swiper "0.15.0"))
:commit "7a0d554aaf4ebbb2c45f2451d77747df4f7e2742" :authors
'(("Oleh Krehel" . "ohwoeowho@gmail.com"))
:maintainers
'(("Basil L. Contovounesios" . "contovob@tcd.ie"))
'(("Basil L. Contovounesios" . "basil@contovou.net"))
:maintainer
'("Basil L. Contovounesios" . "contovob@tcd.ie")
'("Basil L. Contovounesios" . "basil@contovou.net")
:keywords
'("convenience" "matching" "tools")
:url "https://github.com/abo-abo/swiper")
lisp/counsel/counsel.el
+220 -141
View File
@@ -1,12 +1,12 @@
;;; counsel.el --- Various completion functions using Ivy -*- lexical-binding: t -*-
;; Copyright (C) 2015-2023 Free Software Foundation, Inc.
;; Copyright (C) 2015-2025 Free Software Foundation, Inc.
;; Author: Oleh Krehel <ohwoeowho@gmail.com>
;; Maintainer: Basil L. Contovounesios <contovob@tcd.ie>
;; Maintainer: Basil L. Contovounesios <basil@contovou.net>
;; URL: https://github.com/abo-abo/swiper
;; Version: 0.14.2
;; Package-Requires: ((emacs "24.5") (ivy "0.14.2") (swiper "0.14.2"))
;; Version: 0.15.0
;; Package-Requires: ((emacs "24.5") (ivy "0.15.0") (swiper "0.15.0"))
;; Keywords: convenience, matching, tools
;; This file is part of GNU Emacs.
@@ -80,7 +80,7 @@ complex regexes."
(mapconcat
(lambda (pair)
(let ((subexp (counsel--elisp-to-pcre (car pair))))
(if (string-match-p "|" subexp)
(if (ivy--string-search "|" subexp)
(format "(?:%s)" subexp)
subexp)))
(cl-remove-if-not #'cdr regex)
@@ -179,6 +179,10 @@ Return a list or string depending on input."
formatter)))
(t (apply #'format formatter args))))
(defalias 'counsel--null-device
(if (fboundp 'null-device) #'null-device (lambda () null-device))
"Compatibility shim for Emacs 28 function `null-device'.")
;;* Async Utility
(defvar counsel--async-time nil
"Store the time when a new process was started.
@@ -318,13 +322,20 @@ caused by spawning too many subprocesses too quickly."
"The amount of microseconds to wait until updating `counsel--async-filter'."
:type 'integer)
(defalias 'counsel--async-filter-update-time
(if (fboundp 'time-convert)
;; Preferred (TICKS . HZ) format since Emacs 27.1.
(lambda () (cons counsel-async-filter-update-time 1000000))
(lambda () (list 0 0 counsel-async-filter-update-time)))
"Return `counsel-async-filter-update-time' as a time value.")
(defun counsel--async-filter (process str)
"Receive from PROCESS the output STR.
Update the minibuffer with the amount of lines collected every
`counsel-async-filter-update-time' microseconds since the last update."
(with-current-buffer (process-buffer process)
(insert str))
(when (time-less-p (list 0 0 counsel-async-filter-update-time)
(when (time-less-p (counsel--async-filter-update-time)
(time-since counsel--async-time))
(let (numlines)
(with-current-buffer (process-buffer process)
@@ -333,7 +344,7 @@ Update the minibuffer with the amount of lines collected every
(let ((lines (counsel--split-string))
(ignore-re (ivy-alist-setting counsel-async-ignore-re-alist)))
(if (stringp ignore-re)
(cl-remove-if (lambda (line)
(cl-delete-if (lambda (line)
(string-match-p ignore-re line))
lines)
lines))))
@@ -348,10 +359,14 @@ Update the minibuffer with the amount of lines collected every
(delete-process process))))
;;* Completion at point
(define-obsolete-function-alias 'counsel-el #'complete-symbol "<2020-05-20 Wed>")
(define-obsolete-function-alias 'counsel-cl #'complete-symbol "<2020-05-20 Wed>")
(define-obsolete-function-alias 'counsel-jedi #'complete-symbol "<2020-05-20 Wed>")
(define-obsolete-function-alias 'counsel-clj #'complete-symbol "<2020-05-20 Wed>")
(define-obsolete-function-alias 'counsel-el
#'complete-symbol "0.13.2 (2020-05-20)")
(define-obsolete-function-alias 'counsel-cl
#'complete-symbol "0.13.2 (2020-05-20)")
(define-obsolete-function-alias 'counsel-jedi
#'complete-symbol "0.13.2 (2020-05-20)")
(define-obsolete-function-alias 'counsel-clj
#'complete-symbol "0.13.2 (2020-05-20)")
;;** `counsel-company'
(defvar company-candidates)
@@ -1326,7 +1341,8 @@ INITIAL-INPUT can be given as the initial minibuffer input."
(counsel-cmd-to-dired
(counsel--expand-ls
(format "%s | %s | xargs ls"
(replace-regexp-in-string "\\(-0\\)\\|\\(-z\\)" "" counsel-git-cmd)
(replace-regexp-in-string
"\\(-0\\)\\|\\(-z\\)" "" counsel-git-cmd t t)
(counsel--file-name-filter)))))
(defvar counsel-dired-listing-switches "-alh"
@@ -1399,8 +1415,7 @@ This function should set `ivy--old-re'."
(format counsel-git-grep-cmd
(setq ivy--old-re
(if (eq ivy--regex-function #'ivy--regex-fuzzy)
(replace-regexp-in-string
"\n" "" (ivy--regex-fuzzy str))
(ivy--string-replace "\n" "" (ivy--regex-fuzzy str))
(ivy--regex str t)))))
(defun counsel-git-grep-cmd-function-ignore-order (str)
@@ -1414,23 +1429,36 @@ This function should set `ivy--old-re'."
"Grep in the current Git repository for STRING."
(or
(ivy-more-chars)
(progn
(counsel--async-command
(concat
(funcall counsel-git-grep-cmd-function string)
(if (ivy--case-fold-p string) " -i" "")))
nil)))
(ignore
(counsel--async-command
(concat
(funcall counsel-git-grep-cmd-function string)
(and (ivy--case-fold-p string) " -i"))))))
(defun counsel-git-grep-action (x)
"Go to occurrence X in current Git repository."
(when (string-match "\\`\\(.*?\\):\\([0-9]+\\):\\(.*\\)\\'" x)
(let ((file-name (match-string-no-properties 1 x))
(line-number (match-string-no-properties 2 x)))
(find-file (expand-file-name
file-name
(ivy-state-directory ivy-last)))
(counsel--git-grep-visit x))
(defun counsel-git-grep-action-other-window (x)
"Go to occurrence X in current Git repository in another window."
(counsel--git-grep-visit x t))
(defun counsel--git-grep-file-and-line (x)
"Extract file name and line number from `counsel-git-grep' line X.
Return a pair (FILE . LINE) on success; nil otherwise."
(and (string-match "\\`\\(.*?\\):\\([0-9]+\\):\\(.*\\)\\'" x)
(cons (match-string-no-properties 1 x)
(string-to-number (match-string-no-properties 2 x)))))
(defun counsel--git-grep-visit (cand &optional other-window)
"Visit `counsel-git-grep' CAND, optionally in OTHER-WINDOW."
(let ((file-and-line (counsel--git-grep-file-and-line cand)))
(when file-and-line
(funcall (if other-window #'find-file-other-window #'find-file)
(expand-file-name (car file-and-line)
(ivy-state-directory ivy-last)))
(goto-char (point-min))
(forward-line (1- (string-to-number line-number)))
(forward-line (1- (cdr file-and-line)))
(when (re-search-forward (ivy--regex ivy-text t) (line-end-position) t)
(when swiper-goto-start-of-match
(goto-char (match-beginning 0))))
@@ -1440,6 +1468,10 @@ This function should set `ivy--old-re'."
(swiper--cleanup)
(swiper--add-overlays (ivy--regex ivy-text))))))
(ivy-set-actions
'counsel-git-grep
'(("j" counsel-git-grep-action-other-window "other window")))
(defun counsel-git-grep-transformer (str)
"Highlight file and line number in STR."
(when (string-match "\\`\\([^:]+\\):\\([^:]+\\):" str)
@@ -1463,7 +1495,7 @@ files in a project.")
(if (setq proj
(cl-find-if
(lambda (x)
(string-match (car x) dd))
(string-match-p (car x) dd))
counsel-git-grep-projects-alist))
(setq cmd (cdr proj))
(setq cmd
@@ -1621,10 +1653,8 @@ When CMD is non-nil, prompt for a specific \"git grep\" command."
(defun counsel--git-grep-occur-cmd (input)
(let* ((regex ivy--old-re)
(positive-pattern (replace-regexp-in-string
;; git-grep can't handle .*?
"\\.\\*\\?" ".*"
(ivy-re-to-str regex)))
(positive-pattern ;; git-grep can't handle .*?
(ivy--string-replace ".*?" ".*" (ivy-re-to-str regex)))
(negative-patterns
(if (stringp regex) ""
(mapconcat (lambda (x)
@@ -1702,8 +1732,7 @@ done") "\n" t)))
;; "git log --grep" likes to have groups quoted e.g. \(foo\).
;; But it doesn't like the non-greedy ".*?".
(format counsel-git-log-cmd
(replace-regexp-in-string "\\.\\*\\?" ".*"
(ivy-re-to-str ivy--old-re))))
(ivy--string-replace ".*?" ".*" (ivy-re-to-str ivy--old-re))))
nil)))
(defun counsel-git-log-action (x)
@@ -1739,7 +1768,7 @@ TREE is the selected candidate."
(defun counsel-git-worktree-parse-root (tree)
"Return worktree from candidate TREE."
(substring tree 0 (string-match-p " " tree)))
(substring tree 0 (ivy--string-search " " tree)))
(defun counsel-git-close-worktree-files-action (root-dir)
"Close all buffers from the worktree located at ROOT-DIR."
@@ -1779,7 +1808,7 @@ character (#x20), or the string's end if it lacks a space."
(shell-command
(format "git checkout %s"
(shell-quote-argument
(substring branch 0 (string-match-p " " branch))))))
(substring branch 0 (ivy--string-search " " branch))))))
(defun counsel-git-branch-list ()
"Return list of branches in the current Git repository.
@@ -2111,8 +2140,8 @@ If USE-IGNORE is non-nil, try to generate a command that respects
(cons ignore-re regex)))))
(setq cmd (format (car filter-cmd)
(counsel--elisp-to-pcre regex (cdr filter-cmd))))
(if (string-match-p "csh\\'" shell-file-name)
(replace-regexp-in-string "\\?!" "?\\\\!" cmd)
(if (string-suffix-p "csh" shell-file-name)
(ivy--string-replace "?!" "?\\!" cmd)
cmd)))))
(defun counsel--occur-cmd-find ()
@@ -2126,10 +2155,9 @@ If USE-IGNORE is non-nil, try to generate a command that respects
(defun counsel--cmd-to-dired-by-type (type cmd)
(let ((exclude-dots
(if (string-match "^\\." ivy-text)
""
" | grep -v '/\\\\.'")))
(replace-regexp-in-string
(unless (string-prefix-p "." ivy-text)
" | grep -v '/\\.'")))
(ivy--string-replace
" | grep"
(concat " -type " type exclude-dots " | grep") cmd)))
@@ -2143,7 +2171,7 @@ If USE-IGNORE is non-nil, try to generate a command that respects
(counsel-cmd-to-dired
(counsel--expand-ls
(format counsel-find-file-occur-cmd
(if (string-match-p "grep" counsel-find-file-occur-cmd)
(if (ivy--string-search "grep" counsel-find-file-occur-cmd)
;; for backwards compatibility
(counsel--elisp-to-pcre ivy--old-re)
(counsel--file-name-filter t)))))))
@@ -2204,9 +2232,10 @@ See variable `counsel-up-directory-level'."
(defun counsel-at-git-issue-p ()
"When point is at an issue in a Git-versioned file, return the issue string."
(and (looking-at "#[0-9]+")
(or (eq (vc-backend buffer-file-name) 'Git)
(memq major-mode '(magit-commit-mode vc-git-log-view-mode))
(bound-and-true-p magit-commit-mode))
(save-match-data
(or (eq (vc-backend buffer-file-name) 'Git)
(memq major-mode '(magit-commit-mode vc-git-log-view-mode))
(bound-and-true-p magit-commit-mode)))
(match-string-no-properties 0)))
(defun counsel-github-url-p ()
@@ -2407,13 +2436,8 @@ This function uses the `dom' library from Emacs 25.1 or later."
"Return candidates for `counsel-buffer-or-recentf'."
(require 'recentf)
(recentf-mode)
(let ((buffers
(delq nil
(mapcar (lambda (b)
(when (buffer-file-name b)
(buffer-file-name b)))
(buffer-list)))))
(append
(let ((buffers (delq nil (mapcar #'buffer-file-name (buffer-list)))))
(nconc
buffers
(cl-remove-if (lambda (f) (member f buffers))
(counsel-recentf-candidates)))))
@@ -2500,7 +2524,7 @@ By default `counsel-bookmark' opens a dired buffer for directories."
(defun counsel-bookmarked-directory--candidates ()
"Get a list of bookmarked directories sorted by file path."
(bookmark-maybe-load-default-file)
(sort (cl-remove-if-not
(sort (cl-delete-if-not
#'ivy--dirname-p
(delq nil (mapcar #'bookmark-get-filename bookmark-alist)))
#'string<))
@@ -2640,7 +2664,9 @@ library, which see."
(defun counsel-locate-cmd-mdfind (input)
"Return a `mdfind' shell command based on INPUT."
(counsel-require-program "mdfind")
(format "mdfind -name %s" (shell-quote-argument input)))
(format "mdfind -name %s 2>%s"
(shell-quote-argument input)
(shell-quote-argument (counsel--null-device))))
(defun counsel-locate-cmd-es (input)
"Return a `es' shell command based on INPUT."
@@ -2673,7 +2699,7 @@ library, which see."
(defun counsel-file-stale-p (fname seconds)
"Return non-nil if FNAME was modified more than SECONDS ago."
(> (float-time (time-subtract nil (nth 5 (file-attributes fname))))
(> (float-time (time-since (nth 5 (file-attributes fname))))
seconds))
(defun counsel--locate-updatedb ()
@@ -2745,7 +2771,7 @@ INITIAL-INPUT can be given as the initial minibuffer input."
(defvar counsel--fzf-dir nil
"Store the base fzf directory.")
(defvar counsel-fzf-dir-function 'counsel-fzf-dir-function-projectile
(defvar counsel-fzf-dir-function #'counsel-fzf-dir-function-projectile
"Function that returns a directory for fzf to use.")
(defun counsel-fzf-dir-function-projectile ()
@@ -3130,7 +3156,7 @@ Works for `counsel-git-grep', `counsel-ag', etc."
(if (ivy--case-fold-p ivy-text)
"-i"
(if (and (stringp counsel-ag-base-command)
(string-match-p "\\`pt" counsel-ag-base-command))
(string-prefix-p "pt" counsel-ag-base-command))
"-S"
"-s")))
@@ -3139,9 +3165,10 @@ Works for `counsel-git-grep', `counsel-ag', etc."
(ivy-occur-grep-mode)
(setq default-directory (ivy-state-directory ivy-last)))
(ivy-set-text
(if (string-match "\"\\(.*\\)\"" (buffer-name))
(match-string 1 (buffer-name))
(ivy-state-text ivy-occur-last)))
(let ((name (buffer-name)))
(if (string-match "\"\\(.*\\)\"" name)
(match-string 1 name)
(ivy-state-text ivy-occur-last))))
(let* ((cmd
(if (functionp cmd-template)
(funcall cmd-template ivy-text)
@@ -3241,7 +3268,7 @@ Note: don't use single quotes for the regexp."
(let ((files
(dired-get-marked-files 'no-dir nil nil t)))
(when (or (cdr files)
(when (string-match-p "\\*ivy-occur" (buffer-name))
(when (ivy--string-search "*ivy-occur" (buffer-name))
(dired-toggle-marks)
(setq files (dired-get-marked-files 'no-dir))
(dired-toggle-marks)
@@ -3357,14 +3384,12 @@ relative to the last position stored here.")
(swiper--add-overlays (ivy--regex ivy-text))))))))
(defun counsel-grep-occur (&optional _cands)
"Generate a custom occur buffer for `counsel-grep'."
(counsel-grep-like-occur
(format
"grep -niE %%s %s /dev/null"
(shell-quote-argument
(file-name-nondirectory
(buffer-file-name
(ivy-state-buffer ivy-last)))))))
"Generate a custom Occur buffer for `counsel-grep'."
(let ((file (buffer-file-name (ivy-state-buffer ivy-last))))
(counsel-grep-like-occur
(format "grep -niE %%s %s %s"
(if file (shell-quote-argument (file-name-nondirectory file)) "")
(shell-quote-argument (counsel--null-device))))))
(defvar counsel-grep-history nil
"History for `counsel-grep'.")
@@ -4040,21 +4065,16 @@ This variable has no effect unless
(text (nth 4 components))
(tags (and counsel-org-headline-display-tags
(nth 5 components))))
(list
(mapconcat
#'identity
(cl-remove-if #'null
(list
level
todo
(and priority (format "[#%c]" priority))
(mapconcat #'identity
(append path (list text))
counsel-outline-path-separator)
tags))
" ")
buffer-file-name
(point))))
(list (string-join
(delq nil (list level
todo
(and priority (format "[#%c]" priority))
(string-join (append path (list text))
counsel-outline-path-separator)
tags))
" ")
buffer-file-name
(point))))
nil
'agenda))
@@ -4169,13 +4189,13 @@ point to indicarte where the candidate mark is."
marks))))))
(defun counsel-mark--ivy-read (prompt candidates caller)
"call `ivy-read' with sane defaults for traversing marks.
"Call `ivy-read' with sane defaults for traversing marks.
CANDIDATES should be an alist with the `car' of the list being
the string displayed by ivy and the `cdr' being the point that
the completion candidate string and the `cdr' being the point that
mark should take you to.
NOTE This has been abstracted out into it's own method so it can
be used by both `counsel-mark-ring' and `counsel-evil-marks'"
This subroutine is intended to be used by both `counsel-mark-ring' and
`counsel-evil-marks'."
(ivy-read prompt candidates
:require-match t
:update-fn #'counsel--mark-ring-update-fn
@@ -4225,8 +4245,8 @@ register tied to a mark in the message string."
;; with prefix, ignore register exclusion list.
(if all-markers-p
all-markers
(cl-remove-if-not
(lambda (x) (not (member (car x) counsel-evil-marks-exclude-registers)))
(cl-remove-if
(lambda (x) (member (car x) counsel-evil-marks-exclude-registers))
all-markers)))
;; separate the markers from the evil registers
;; for call to `counsel-mark--get-candidates'
@@ -4448,19 +4468,29 @@ Additional actions:\\<ivy-minibuffer-map>
cand-pairs
(propertize counsel-yank-pop-separator 'face 'ivy-separator)))
;; Macro to leverage `compiler-macro' of `cl-member' in Emacs >= 24.
(defmacro counsel--idx-of (elt list test)
"Return index of ELT in LIST, comparing with TEST.
Typically faster than `cl-position' using `equal' on large LIST."
;; No `macroexp-let2*' before Emacs 25.
(macroexp-let2 nil elt elt
(macroexp-let2 nil list list
(macroexp-let2 nil tail `(cl-member ,elt ,list :test ,test)
`(and ,tail (- (length ,list) (length ,tail)))))))
(defun counsel--yank-pop-position (s)
"Return position of S in `kill-ring' relative to last yank."
(or (cl-position s kill-ring-yank-pointer :test #'equal-including-properties)
(cl-position s kill-ring-yank-pointer :test #'equal)
(+ (or (cl-position s kill-ring :test #'equal-including-properties)
(cl-position s kill-ring :test #'equal))
(or (counsel--idx-of s kill-ring-yank-pointer #'equal-including-properties)
(counsel--idx-of s kill-ring-yank-pointer #'equal)
(+ (or (counsel--idx-of s kill-ring #'equal-including-properties)
(counsel--idx-of s kill-ring #'equal))
(- (length kill-ring-yank-pointer)
(length kill-ring)))))
(defun counsel-string-non-blank-p (s)
"Return non-nil if S includes non-blank characters.
Newlines and carriage returns are considered blank."
(not (string-match-p "\\`[\n\r[:blank:]]*\\'" s)))
(string-match-p "[^\n\r[:blank:]]" s))
(defcustom counsel-yank-pop-filter #'counsel-string-non-blank-p
"Unary filter function applied to `counsel-yank-pop' candidates.
@@ -4469,9 +4499,53 @@ will be destructively removed from `kill-ring' before completion.
All blank strings are deleted from `kill-ring' by default."
:type '(radio
(function-item counsel-string-non-blank-p)
(function-item identity)
(function-item identity) ;; Faster than the newer `always'.
(function :tag "Other")))
(defun counsel--equal-w-props ()
"Return a `hash-table-test' using `equal-including-properties'.
If not available, return nil."
;; Added in Emacs 28.
(when (fboundp 'sxhash-equal-including-properties)
(let ((name 'counsel--equal-w-props))
;; Define the test only once.
(unless (get name 'hash-table-test)
(define-hash-table-test name #'equal-including-properties
#'sxhash-equal-including-properties))
name)))
(defun counsel--yank-pop-filter (kills)
"Apply `counsel-yank-pop-filter' to and deduplicate KILLS.
Equality is defined by `equal-including-properties' for some consistency
with `kill-do-not-save-duplicates' (which is otherwise ignored). This
function tries to be faster than `cl-delete-duplicates' when possible."
(let* ((pred counsel-yank-pop-filter)
(len (length kills))
;; Same threshold as `delete-dups'.
(test (and (> len 100) (counsel--equal-w-props))))
(if (not test) ;; Slow fallback.
(cl-delete-duplicates (cl-delete-if-not pred kills)
:test #'equal-including-properties
:from-end t)
;; The rest is `delete-dups' combined with `delete' in a single pass.
;; Find first (or no) element that passes through filter.
(while (unless (funcall pred (car kills))
(cl-decf len)
(setq kills (cdr kills))))
(let ((ht (make-hash-table :test test :size len))
(tail kills)
retail)
;; Mark it and continue with the rest.
(puthash (car tail) t ht)
(while (setq retail (cdr tail))
(let ((elt (car retail)))
(if (or (gethash elt ht)
(not (funcall pred elt)))
(setcdr tail (cdr retail))
(puthash elt t ht)
(setq tail retail)))))
kills)))
(defun counsel--yank-pop-kills ()
"Return filtered `kill-ring' for `counsel-yank-pop' completion.
Both `kill-ring' and `kill-ring-yank-pointer' may be
@@ -4482,11 +4556,9 @@ and incorporate `interprogram-paste-function'."
;; `interprogram-paste-function' both being nil
(ignore-errors (current-kill 0))
;; Keep things consistent with the rest of Emacs
(dolist (sym '(kill-ring kill-ring-yank-pointer))
(set sym (cl-delete-duplicates
(cl-delete-if-not counsel-yank-pop-filter (symbol-value sym))
:test #'equal-including-properties :from-end t)))
kill-ring)
(prog1 (setq kill-ring (counsel--yank-pop-filter kill-ring))
(setq kill-ring-yank-pointer
(counsel--yank-pop-filter kill-ring-yank-pointer))))
(defcustom counsel-yank-pop-after-point nil
"Whether `counsel-yank-pop' yanks after point.
@@ -4524,9 +4596,10 @@ buffer position."
(defun counsel-yank-pop-action-remove (s)
"Remove all occurrences of S from the kill ring."
(dolist (sym '(kill-ring kill-ring-yank-pointer))
(set sym (cl-delete s (symbol-value sym)
:test #'equal-including-properties)))
(setq kill-ring
(cl-delete s kill-ring :test #'equal-including-properties))
(setq kill-ring-yank-pointer
(cl-delete s kill-ring-yank-pointer :test #'equal-including-properties))
;; Update collection and preselect for next `ivy-call'
(setf (ivy-state-collection ivy-last) kill-ring)
(setf (ivy-state-preselect ivy-last)
@@ -4563,9 +4636,6 @@ preselected. Otherwise, the prefix argument defaults to 0, which
results in the most recent kill being preselected."
:type 'boolean)
;; Moved to subr.el in Emacs 27.1.
(autoload 'xor "array")
;;;###autoload
(defun counsel-yank-pop (&optional arg)
"Ivy replacement for `yank-pop'.
@@ -4693,7 +4763,7 @@ matching the register's value description against a regexp in
S will be of the form \"[register]: content\"."
(with-ivy-window
(insert
(replace-regexp-in-string "\\`\\[.*?\\]: " "" s))))
(replace-regexp-in-string "\\`\\[.*?]: " "" s t t))))
;;** `counsel-imenu'
(defvar imenu-auto-rescan)
@@ -4750,8 +4820,8 @@ PREFIX is used to create the key."
"Categorize all the functions of imenu."
(let ((fns (cl-remove-if #'listp items :key #'cdr)))
(if fns
(nconc (cl-remove-if #'nlistp items :key #'cdr)
`(("Functions" ,@fns)))
(append (cl-remove-if #'nlistp items :key #'cdr)
`(("Functions" ,@fns)))
items)))
(defun counsel-imenu-action (x)
@@ -5114,7 +5184,8 @@ buffers."
(cond (counsel-org-headline-display-statistics
heading)
(heading
(org-trim (replace-regexp-in-string statistics-re " " heading))))))
(org-trim (replace-regexp-in-string
statistics-re " " heading t t))))))
(defun counsel-outline-title-markdown ()
"Return title of current outline heading.
@@ -6076,7 +6147,7 @@ the command to launch it."
(format "% -45s: %s%s"
(propertize
(ivy--truncate-string
(replace-regexp-in-string "env +[^ ]+ +" "" exec)
(replace-regexp-in-string "env +[^ ]+ +" "" exec t t)
45)
'face 'counsel-application-name)
name
@@ -6288,11 +6359,10 @@ When ARG is non-nil, ignore NoDisplay property in *.desktop files."
"Clear temporary file buffers and restore `buffer-list'.
The buffers are those opened during a session of `counsel-switch-buffer'."
(mapc #'kill-buffer counsel--switch-buffer-temporary-buffers)
(mapc #'bury-buffer (cl-remove-if-not
#'buffer-live-p
counsel--switch-buffer-previous-buffers))
(setq counsel--switch-buffer-temporary-buffers nil
counsel--switch-buffer-previous-buffers nil))
(dolist (buf counsel--switch-buffer-previous-buffers)
(when (buffer-live-p buf) (bury-buffer buf)))
(setq counsel--switch-buffer-temporary-buffers ())
(setq counsel--switch-buffer-previous-buffers ()))
(defcustom counsel-switch-buffer-preview-virtual-buffers t
"When non-nil, `counsel-switch-buffer' will preview virtual buffers."
@@ -6417,8 +6487,13 @@ Use `projectile-project-root' to determine the root."
(defun counsel--project-current ()
"Return root of current project or nil on failure.
Use `project-current' to determine the root."
(and (fboundp 'project-current)
(cdr (project-current))))
(let ((proj (and (fboundp 'project-current)
(project-current))))
(cond ((not proj) nil)
((fboundp 'project-root)
(project-root proj))
((fboundp 'project-roots)
(car (project-roots proj))))))
(defun counsel--configure-root ()
"Return root of current project or nil on failure.
@@ -6595,10 +6670,16 @@ If there are non-directory files in BLDDIR, include BLDDIR in the
list as it may also be a build directory."
(let* ((files (directory-files-and-attributes
blddir t directory-files-no-dot-files-regexp t))
(dirs (cl-remove-if-not #'cl-second files)))
(total (length files))
(dirs (cl-delete-if-not
(lambda (entry)
(let ((dir (nth 1 entry)))
(and dir (or (eq dir t)
;; Symlink.
(file-directory-p (nth 0 entry))))))
files)))
;; Any non-dir files?
(when (< (length dirs)
(length files))
(when (< (length dirs) total)
(push (cons blddir (file-attributes blddir)) dirs))
(mapcar #'car (sort dirs (lambda (x y)
(time-less-p (nth 6 y) (nth 6 x)))))))
@@ -6792,22 +6873,19 @@ Additional actions:
The alist element is cons of minor mode string with its lighter
and minor mode symbol."
(delq nil
(mapcar
(lambda (mode)
(when (and (boundp mode) (commandp mode))
(let ((lighter (cdr (assq mode minor-mode-alist))))
(cons (concat
(if (symbol-value mode) "-" "+")
(symbol-name mode)
(propertize
(if lighter
(format " \"%s\""
(format-mode-line (cons t lighter)))
"")
'face font-lock-string-face))
mode))))
minor-mode-list)))
(cl-mapcan
(let ((suffix (propertize " \"%s\"" 'face 'font-lock-string-face)))
(lambda (mode)
(when (and (boundp mode) (commandp mode))
(let ((lighter (cdr (assq mode minor-mode-alist))))
(list (cons (concat
(if (symbol-value mode) "-" "+")
(symbol-name mode)
(and lighter
(format suffix
(format-mode-line (cons t lighter)))))
mode))))))
minor-mode-list))
;;;###autoload
(defun counsel-minor ()
@@ -6845,7 +6923,8 @@ Additional actions:\\<ivy-minibuffer-map>
(interactive)
(ivy-read "Major modes: " obarray
:predicate (lambda (f)
(and (commandp f) (string-match "-mode$" (symbol-name f))
(and (commandp f)
(string-suffix-p "-mode" (symbol-name f))
(or (and (autoloadp (symbol-function f))
(let ((doc-split (help-split-fundoc (documentation f) f)))
;; major mode starters have no arguments
@@ -6919,7 +6998,7 @@ We update it in the callback with `ivy-update-candidates'."
:caller 'counsel-search))
(define-obsolete-function-alias 'counsel-google
#'counsel-search "<2019-10-17 Thu>")
#'counsel-search "0.13.2 (2019-10-17)")
;;** `counsel-compilation-errors'
(defun counsel--compilation-errors-buffer (buf)
lisp/dash/dash-pkg.el
+2 -2
View File
@@ -1,6 +1,6 @@
(define-package "dash" "20230714.723" "A modern list library for Emacs"
(define-package "dash" "20240510.1327" "A modern list library for Emacs"
'((emacs "24"))
:commit "f46268c75cb7c18361d3cee942cd4dc14a03aef4" :authors
:commit "1de9dcb83eacfb162b6d9a118a4770b1281bcd84" :authors
'(("Magnar Sveen" . "magnars@gmail.com"))
:maintainers
'(("Magnar Sveen" . "magnars@gmail.com"))
lisp/dash/dash.el
+4 -2
View File
@@ -1,6 +1,6 @@
;;; dash.el --- A modern list library for Emacs -*- lexical-binding: t -*-
;; Copyright (C) 2012-2023 Free Software Foundation, Inc.
;; Copyright (C) 2012-2024 Free Software Foundation, Inc.
;; Author: Magnar Sveen <magnars@gmail.com>
;; Version: 2.19.1
@@ -2108,7 +2108,7 @@ last item in second form, etc."
Insert X at the position signified by the symbol `it' in the first
form. If there are more forms, insert the first form at the position
signified by `it' in in second form, etc."
signified by `it' in the second form, etc."
(declare (debug (form body)))
`(-as-> ,x it ,@forms))
@@ -3298,6 +3298,8 @@ Return the sorted list. LIST is NOT modified by side effects.
COMPARATOR is called with two elements of LIST, and should return non-nil
if the first element should sort before the second."
(declare (important-return-value t))
;; Not yet worth changing to (sort list :lessp comparator);
;; still seems as fast or slightly faster.
(sort (copy-sequence list) comparator))
(defmacro --sort (form list)
lisp/dash/dash.info
+50 -50
View File
@@ -2,7 +2,7 @@ This is dash.info, produced by makeinfo version 6.8 from dash.texi.
This manual is for Dash version 2.19.1.
Copyright © 2012–2023 Free Software Foundation, Inc.
Copyright © 2012–2024 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License,
@@ -24,7 +24,7 @@ Dash
This manual is for Dash version 2.19.1.
Copyright © 2012–2023 Free Software Foundation, Inc.
Copyright © 2012–2024 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License,
@@ -2427,7 +2427,7 @@ readability.
Insert X at the position signified by the symbol ‘it’ in the first
form. If there are more forms, insert the first form at the
position signified by ‘it’ in in second form, etc.
position signified by ‘it’ in the second form, etc.
(--> "def" (concat "abc" it "ghi"))
⇒ "abcdefghi"
@@ -4892,53 +4892,53 @@ Node: Threading macros84441
Ref: ->84666
Ref: ->>85154
Ref: -->85657
Ref: -as->86213
Ref: -some->86667
Ref: -some->>87052
Ref: -some-->87499
Ref: -doto88066
Node: Binding88619
Ref: -when-let88826
Ref: -when-let*89287
Ref: -if-let89816
Ref: -if-let*90182
Ref: -let90805
Ref: -let*96895
Ref: -lambda97832
Ref: -setq98638
Node: Side effects99439
Ref: -each99633
Ref: -each-while100160
Ref: -each-indexed100780
Ref: -each-r101372
Ref: -each-r-while101814
Ref: -dotimes102458
Node: Destructive operations103011
Ref: !cons103229
Ref: !cdr103433
Node: Function combinators103626
Ref: -partial103830
Ref: -rpartial104348
Ref: -juxt104996
Ref: -compose105448
Ref: -applify106055
Ref: -on106485
Ref: -flip107257
Ref: -rotate-args107781
Ref: -const108410
Ref: -cut108752
Ref: -not109232
Ref: -orfn109776
Ref: -andfn110569
Ref: -iteratefn111356
Ref: -fixfn112058
Ref: -prodfn113632
Node: Development114783
Node: Contribute115072
Node: Contributors116084
Node: FDL118177
Node: GPL143497
Node: Index181246
Ref: -as->86214
Ref: -some->86668
Ref: -some->>87053
Ref: -some-->87500
Ref: -doto88067
Node: Binding88620
Ref: -when-let88827
Ref: -when-let*89288
Ref: -if-let89817
Ref: -if-let*90183
Ref: -let90806
Ref: -let*96896
Ref: -lambda97833
Ref: -setq98639
Node: Side effects99440
Ref: -each99634
Ref: -each-while100161
Ref: -each-indexed100781
Ref: -each-r101373
Ref: -each-r-while101815
Ref: -dotimes102459
Node: Destructive operations103012
Ref: !cons103230
Ref: !cdr103434
Node: Function combinators103627
Ref: -partial103831
Ref: -rpartial104349
Ref: -juxt104997
Ref: -compose105449
Ref: -applify106056
Ref: -on106486
Ref: -flip107258
Ref: -rotate-args107782
Ref: -const108411
Ref: -cut108753
Ref: -not109233
Ref: -orfn109777
Ref: -andfn110570
Ref: -iteratefn111357
Ref: -fixfn112059
Ref: -prodfn113633
Node: Development114784
Node: Contribute115073
Node: Contributors116085
Node: FDL118178
Node: GPL143498
Node: Index181247

End Tag Table
lisp/dashboard/dashboard-pkg.el
+6 -6
View File
@@ -1,12 +1,12 @@
(define-package "dashboard" "20231031.359" "A startup screen extracted from Spacemacs"
'((emacs "26.1"))
:commit "22786237e16cfeae33f07ae9c5eeaf061408579a" :authors
(define-package "dashboard" "20250212.1925" "A startup screen extracted from Spacemacs"
'((emacs "27.1"))
:commit "9adf24569d76e428fb98a562f1f1e087dc9d608d" :authors
'(("Rakan Al-Hneiti" . "rakan.alhneiti@gmail.com"))
:maintainers
'(("Jesús Martínez" . "jesusmartinez93@gmail.com")
("Jen-Chieh" . "jcs090218@gmail.com"))
'(("Jen-Chieh" . "jcs090218@gmail.com")
("Ricardo Arredondo" . "ricardo.richo@gmail.com"))
:maintainer
'("Jesús Martínez" . "jesusmartinez93@gmail.com")
'("Jen-Chieh" . "jcs090218@gmail.com")
:keywords
'("startup" "screen" "tools" "dashboard")
:url "https://github.com/emacs-dashboard/emacs-dashboard")
lisp/dashboard/dashboard-widgets.el
+289 -146
View File
@@ -1,6 +1,6 @@
;;; dashboard-widgets.el --- A startup screen extracted from Spacemacs -*- lexical-binding: t -*-
;; Copyright (c) 2016-2023 emacs-dashboard maintainers
;; Copyright (c) 2016-2025 emacs-dashboard maintainers
;; This file is not part of GNU Emacs.
;;
@@ -15,8 +15,13 @@
(require 'cl-lib)
(require 'image)
(require 'mule-util)
(require 'rect)
(require 'subr-x)
;;
;;; Externals
;; Compiler pacifier
(declare-function all-the-icons-icon-for-dir "ext:all-the-icons.el")
(declare-function all-the-icons-icon-for-file "ext:all-the-icons.el")
@@ -50,13 +55,13 @@
(declare-function org-get-todo-face "ext:org.el")
(declare-function org-get-todo-state "ext:org.el")
(declare-function org-in-archived-heading-p "ext:org.el")
(declare-function org-link-display-format "ext:org.el")
(declare-function org-map-entries "ext:org.el")
(declare-function org-outline-level "ext:org.el")
(declare-function org-release-buffers "ext:org.el")
(declare-function org-time-string-to-time "ext:org.el")
(declare-function org-today "ext:org.el")
(declare-function recentf-cleanup "ext:recentf.el")
(defalias 'org-time-less-p 'time-less-p)
(defvar org-level-faces)
(defvar org-agenda-new-buffers)
(defvar org-agenda-prefix-format)
@@ -68,9 +73,21 @@
(declare-function string-pixel-width "subr-x.el") ; TODO: remove this after 29.1
(declare-function shr-string-pixel-width "shr.el") ; TODO: remove this after 29.1
(defcustom dashboard-page-separator "\n\n"
(defvar truncate-string-ellipsis)
(declare-function truncate-string-ellipsis "mule-util.el") ; TODO: remove this after 28.1
(defvar recentf-list nil)
(defvar dashboard-buffer-name)
;;
;;; Customization
(defcustom dashboard-page-separator "\n"
"Separator to use between the different pages."
:type 'string
:type '(choice
(const :tag "Default" "\n")
(const :tag "Use Page indicator (requires page-break-lines)"
"\n\f\n")
(string :tag "Use Custom String"))
:group 'dashboard)
(defcustom dashboard-image-banner-max-height 0
@@ -93,6 +110,14 @@ preserved."
:type 'integer
:group 'dashboard)
(defcustom dashboard-image-extra-props nil
"Additional image attributes to assign to the image.
This could be useful for displaying images with transparency,
for example, by setting the `:mask' property to `heuristic'.
See `create-image' and Info node `(elisp)Image Descriptors'."
:type 'plist
:group 'dashboard)
(defcustom dashboard-set-heading-icons nil
"When non nil, heading sections will have icons."
:type 'boolean
@@ -107,16 +132,22 @@ preserved."
"When non nil, a navigator will be displayed under the banner."
:type 'boolean
:group 'dashboard)
(make-obsolete-variable 'dashboard-set-navigator
'dashboard-startupify-list "1.9.0")
(defcustom dashboard-set-init-info t
"When non nil, init info will be displayed under the banner."
:type 'boolean
:group 'dashboard)
(make-obsolete-variable 'dashboard-set-init-info
'dashboard-startupify-list "1.9.0")
(defcustom dashboard-set-footer t
"When non nil, a footer will be displayed at the bottom."
:type 'boolean
:group 'dashboard)
(make-obsolete-variable 'dashboard-set-footer
'dashboard-startupify-list "1.9.0")
(defcustom dashboard-footer-messages
'("The one true editor, Emacs!"
@@ -128,7 +159,7 @@ preserved."
"While any text editor can save your files, only Emacs can save your soul"
"I showed you my source code, pls respond")
"A list of messages, one of which dashboard chooses to display."
:type 'list
:type '(list string)
:group 'dashboard)
(defcustom dashboard-icon-type (and (or dashboard-set-heading-icons
@@ -166,7 +197,7 @@ The value can be one of: `all-the-icons', `nerd-icons'."
Will be of the form `(list-type . icon-name-string)`.
If nil it is disabled. Possible values for list-type are:
`recents' `bookmarks' `projects' `agenda' `registers'"
:type '(repeat (alist :key-type symbol :value-type string))
:type '(alist :key-type symbol :value-type string)
:group 'dashboard)
(defcustom dashboard-heading-icon-height 1.2
@@ -179,6 +210,16 @@ If nil it is disabled. Possible values for list-type are:
:type 'float
:group 'dashboard)
(defcustom dashboard-icon-file-height 1.0
"The height of the file icons."
:type 'float
:group 'dashboard)
(defcustom dashboard-icon-file-v-adjust -0.05
"The v-adjust of the file icons."
:type 'float
:group 'dashboard)
(defcustom dashboard-agenda-item-icon
(pcase dashboard-icon-type
('all-the-icons (all-the-icons-octicon "primitive-dot" :height 1.0 :v-adjust 0.01))
@@ -187,6 +228,11 @@ If nil it is disabled. Possible values for list-type are:
:type 'string
:group 'dashboard)
(defcustom dashboard-agenda-action 'dashboard-agenda--visit-file-other-window
"Function to call when dashboard make an action over agenda item."
:type 'function
:group 'dashboard)
(defcustom dashboard-remote-path-icon
(pcase dashboard-icon-type
('all-the-icons (all-the-icons-octicon "radio-tower" :height 1.0 :v-adjust 0.01))
@@ -230,7 +276,16 @@ The format is: `icon title help action face prefix suffix`.
Example:
`((\"☆\" \"Star\" \"Show stars\" (lambda (&rest _)
(show-stars)) warning \"[\" \"]\"))"
:type '(repeat (repeat (list string string string function symbol string string)))
:type '(repeat (repeat (list string
string
string
function
(choice face
(repeat :tag "Anonymous face" sexp))
(choice string
(const nil))
(choice string
(const nil)))))
:group 'dashboard)
(defcustom dashboard-init-info
@@ -320,26 +375,43 @@ ARGS should be a plist containing `:height', `:v-adjust', or `:face' properties.
:v-adjust -0.05
:face 'dashboard-footer-icon-face)))
(propertize ">" 'face 'dashboard-footer-icon-face))
"Footer's icon."
"Footer's icon.
It can be a string or a string list for display random icons."
:type '(choice string
(repeat string))
:group 'dashboard)
(defcustom dashboard-heading-shorcut-format " (%s)"
"String for display key used in headings."
:type 'string
:group 'dashboard)
(defcustom dashboard-startup-banner 'official
"Specify the startup banner.
Default value is `official', it displays the Emacs logo. `logo' displays Emacs
alternative logo. If set to `ascii', the value of `dashboard-banner-ascii'
will be used as the banner. An integer value is the index of text banner.
A string value must be a path to a .PNG or .TXT file. If the value is
nil then no banner is displayed."
:type '(choice (const :tag "no banner" nil)
(const :tag "offical" official)
"Specify the banner type to use.
Value can be
- \\='official displays the official Emacs logo.
- \\='logo displays an alternative Emacs logo.
- an integer which displays one of the text banners.
- a string that specifies the path of an custom banner
supported files types are gif/image/text/xbm.
- a cons of 2 strings which specifies the path of an image to use
and other path of a text file to use if image isn't supported.
- a list that can display an random banner, supported values are:
string (filepath), \\='official, \\='logo and integers."
:type '(choice (const :tag "official" official)
(const :tag "logo" logo)
(const :tag "ascii" ascii)
(integer :tag "index of a text banner")
(string :tag "a path to an image or text banner")
(cons :tag "an image and text banner"
(string :tag "path to an image or text banner")
(cons :tag "image and text banner"
(string :tag "image banner path")
(string :tag "text banner path")))
(string :tag "text banner path"))
(repeat :tag "random banners"
(choice (string :tag "a path to an image or text banner")
(const :tag "official" official)
(const :tag "logo" logo)
(const :tag "ascii" ascii)
(integer :tag "index of a text banner"))))
:group 'dashboard)
(defcustom dashboard-item-generators
@@ -352,10 +424,10 @@ nil then no banner is displayed."
Will be of the form `(list-type . list-function)'.
Possible values for list-type are: `recents', `bookmarks', `projects',
`agenda' ,`registers'."
:type '(repeat (alist :key-type symbol :value-type function))
:type '(alist :key-type symbol :value-type function)
:group 'dashboard)
(defcustom dashboard-projects-backend 'projectile
(defcustom dashboard-projects-backend 'project-el
"The package that supplies the list of recent projects.
With the value `projectile', the projects widget uses the package
projectile (available in MELPA). With the value `project-el',
@@ -381,7 +453,9 @@ installed."
Will be of the form `(list-type . list-size)'.
If nil it is disabled. Possible values for list-type are:
`recents' `bookmarks' `projects' `agenda' `registers'."
:type '(repeat (alist :key-type symbol :value-type integer))
:type '(repeat (choice
symbol
(cons symbol integer)))
:group 'dashboard)
(defcustom dashboard-item-shortcuts
@@ -393,8 +467,8 @@ If nil it is disabled. Possible values for list-type are:
"Association list of items and their corresponding shortcuts.
Will be of the form `(list-type . keys)' as understood by `(kbd keys)'.
If nil, shortcuts are disabled. If an entry's value is nil, that item's
shortcut is disbaled. See `dashboard-items' for possible values of list-type.'"
:type '(repeat (alist :key-type symbol :value-type string))
shortcut is disabled. See `dashboard-items' for possible values of list-type.'"
:type '(alist :key-type symbol :value-type string)
:group 'dashboard)
(defcustom dashboard-item-names nil
@@ -402,8 +476,12 @@ shortcut is disbaled. See `dashboard-items' for possible values of list-type.'"
When an item is nil or not present, the default name is used.
Will be of the form `(default-name . new-name)'."
:type '(alist :key-type string :value-type string)
:options '("Recent Files:" "Bookmarks:" "Agenda for today:"
"Agenda for the coming week:" "Registers:" "Projects:")
:options '("Recent Files:"
"Bookmarks:"
"Agenda for today:"
"Agenda for the coming week:"
"Registers:"
"Projects:")
:group 'dashboard)
(defcustom dashboard-items-default-length 20
@@ -426,18 +504,9 @@ Set to nil for unbounded."
:type 'integer
:group 'dashboard)
(defcustom dashboard-path-shorten-string "..."
"String the that displays in the center of the path."
:type 'string
:group 'dashboard)
(defvar recentf-list nil)
(defvar dashboard-buffer-name)
;;
;; Faces
;;
;;; Faces
(defface dashboard-text-banner
'((t (:inherit font-lock-keyword-face)))
"Face used for text banners."
@@ -486,8 +555,8 @@ Set to nil for unbounded."
'dashboard-heading-face 'dashboard-heading "1.2.6")
;;
;; Util
;;
;;; Util
(defmacro dashboard-mute-apply (&rest body)
"Execute BODY without message."
(declare (indent 0) (debug t))
@@ -515,8 +584,8 @@ Set to nil for unbounded."
(if (zerop (% len width)) 0 1)))) ; add one if exceeed
;;
;; Generic widget helpers
;;
;;; Widget helpers
(defun dashboard-subseq (seq end)
"Return the subsequence of SEQ from 0 to END."
(let ((len (length seq))) (butlast seq (- len (min len end)))))
@@ -548,7 +617,8 @@ Optionally, provide NO-NEXT-LINE to move the cursor forward a line."
`(progn
(eval-when-compile (defvar dashboard-mode-map))
(defun ,sym nil
,(concat "Jump to " name ". This code is dynamically generated in `dashboard-insert-shortcut'.")
,(concat "Jump to " name ".
This code is dynamically generated in `dashboard-insert-shortcut'.")
(interactive)
(unless (search-forward ,search-label (point-max) t)
(search-backward ,search-label (point-min) t))
@@ -573,6 +643,14 @@ If MESSAGEBUF is not nil then MSG is also written in message buffer."
"Insert a page break line in dashboard buffer."
(dashboard-append dashboard-page-separator))
(defun dashboard-insert-newline (&optional times)
"When called without an argument, insert a newline.
When called with TIMES return a function that insert TIMES number of newlines."
(if times
(lambda ()
(insert (make-string times (string-to-char "\n") t)))
(insert "\n")))
(defun dashboard-insert-heading (heading &optional shortcut icon)
"Insert a widget HEADING in dashboard buffer, adding SHORTCUT, ICON if provided."
(when (and (dashboard-display-icons-p) dashboard-set-heading-icons)
@@ -611,10 +689,10 @@ If MESSAGEBUF is not nil then MSG is also written in message buffer."
(let ((ov (make-overlay (- (point) (length heading)) (point) nil t)))
(overlay-put ov 'display (or (cdr (assoc heading dashboard-item-names)) heading))
(overlay-put ov 'face 'dashboard-heading))
(when shortcut (insert (format " (%s)" shortcut))))
(when shortcut (insert (format dashboard-heading-shorcut-format shortcut))))
(defun dashboard-center-text (start end)
"Center the text between START and END."
(defun dashboard--find-max-width (start end)
"Return the max width within the region START and END."
(save-excursion
(goto-char start)
(let ((width 0))
@@ -623,8 +701,13 @@ If MESSAGEBUF is not nil then MSG is also written in message buffer."
(line-length (dashboard-str-len line-str)))
(setq width (max width line-length)))
(forward-line 1))
(let ((prefix (propertize " " 'display `(space . (:align-to (- center ,(/ width 2)))))))
(add-text-properties start end `(line-prefix ,prefix indent-prefix ,prefix))))))
width)))
(defun dashboard-center-text (start end)
"Center the text between START and END."
(let* ((width (dashboard--find-max-width start end))
(prefix (propertize " " 'display `(space . (:align-to (- center ,(/ (float width) 2)))))))
(add-text-properties start end `(line-prefix ,prefix indent-prefix ,prefix))))
(defun dashboard-insert-center (&rest strings)
"Insert STRINGS in the center of the buffer."
@@ -633,8 +716,7 @@ If MESSAGEBUF is not nil then MSG is also written in message buffer."
(dashboard-center-text start (point))))
;;
;; BANNER
;;
;;; Banner
(defun dashboard-get-banner-path (index)
"Return the full path to banner with index INDEX."
@@ -647,10 +729,9 @@ If MESSAGEBUF is not nil then MSG is also written in message buffer."
;; - That function will only look at filenames, this one will inspect the file data itself.
(and (file-exists-p img) (ignore-errors (image-type-available-p (image-type img)))))
(defun dashboard-choose-banner ()
"Return a plist specifying the chosen banner based on `dashboard-startup-banner'."
(pcase dashboard-startup-banner
('nil nil)
(defun dashboard-choose-banner (banner)
"Return a plist specifying the chosen banner based on BANNER."
(pcase banner
('official
(append (when (image-type-available-p 'png)
(list :image dashboard-banner-official-png))
@@ -662,24 +743,29 @@ If MESSAGEBUF is not nil then MSG is also written in message buffer."
('ascii
(append (list :text dashboard-banner-ascii)))
((pred integerp)
(list :text (dashboard-get-banner-path dashboard-startup-banner)))
(list :text (dashboard-get-banner-path banner)))
((pred stringp)
(pcase dashboard-startup-banner
(pcase banner
((pred (lambda (f) (not (file-exists-p f))))
(message "could not find banner %s, use default instead" dashboard-startup-banner)
(message "could not find banner %s, use default instead" banner)
(list :text (dashboard-get-banner-path 1)))
((pred (string-suffix-p ".txt"))
(list :text (if (file-exists-p dashboard-startup-banner)
dashboard-startup-banner
(message "could not find banner %s, use default instead" dashboard-startup-banner)
(list :text (if (file-exists-p banner)
banner
(message "could not find banner %s, use default instead" banner)
(dashboard-get-banner-path 1))))
((pred dashboard--image-supported-p)
(list :image dashboard-startup-banner
(list :image banner
:text (dashboard-get-banner-path 1)))
(_
(message "unsupported file type %s" (file-name-nondirectory dashboard-startup-banner))
(message "unsupported file type %s" (file-name-nondirectory banner))
(list :text (dashboard-get-banner-path 1)))))
(`(,img . ,txt)
((and
(pred listp)
(pred (lambda (c)
(and (not (proper-list-p c))
(not (null c)))))
`(,img . ,txt))
(list :image (if (dashboard--image-supported-p img)
img
(message "could not find banner %s, use default instead" img)
@@ -688,57 +774,77 @@ If MESSAGEBUF is not nil then MSG is also written in message buffer."
txt
(message "could not find banner %s, use default instead" txt)
(dashboard-get-banner-path 1))))
(_
(message "unsupported banner config %s" dashboard-startup-banner))))
((and
(pred proper-list-p)
(pred (lambda (l) (not (null l)))))
(defun dashboard--type-is-gif-p (image-path)
"Return if image is a gif.
(let* ((max (length banner))
(choose (nth (random max) banner)))
(dashboard-choose-banner choose)))
(_
(user-error "Unsupported banner type: `%s'" banner)
nil)))
(defun dashboard--image-animated-p (image-path)
"Return if image is a gif or webp.
String -> bool.
Argument IMAGE-PATH path to the image."
(eq 'gif (image-type image-path)))
(memq (image-type image-path) '(gif webp)))
(defun dashboard--type-is-xbm-p (image-path)
"Return if image is a xbm.
String -> bool.
Argument IMAGE-PATH path to the image."
(eq 'xbm (image-type image-path)))
(defun dashboard-insert-banner ()
"Insert the banner at the top of the dashboard."
(goto-char (point-max))
(when-let (banner (dashboard-choose-banner))
(when-let* ((banner (dashboard-choose-banner dashboard-startup-banner)))
(insert "\n")
(let ((start (point))
buffer-read-only
text-width
image-spec)
(when (display-graphic-p) (insert "\n"))
image-spec
(graphic-mode (display-graphic-p)))
(when graphic-mode (insert "\n"))
;; If specified, insert a text banner.
(when-let (txt (plist-get banner :text))
(if (eq dashboard-startup-banner 'ascii)
(save-excursion (insert txt))
(insert-file-contents txt))
(put-text-property (point) (point-max) 'face 'dashboard-text-banner)
(when-let* ((txt (plist-get banner :text)))
(if (file-exists-p txt)
(insert-file-contents txt)
(save-excursion (insert txt)))
(unless (text-properties-at 0 txt)
(put-text-property (point) (point-max) 'face 'dashboard-text-banner))
(setq text-width 0)
(while (not (eobp))
(let ((line-length (- (line-end-position) (line-beginning-position))))
(if (< text-width line-length)
(setq text-width line-length)))
(when (< text-width line-length)
(setq text-width line-length)))
(forward-line 1)))
;; If specified, insert an image banner. When displayed in a graphical frame, this will
;; replace the text banner.
(when-let (img (plist-get banner :image))
(let ((size-props
(when-let* ((img (plist-get banner :image)))
(let ((img-props
(append (when (> dashboard-image-banner-max-width 0)
(list :max-width dashboard-image-banner-max-width))
(when (> dashboard-image-banner-max-height 0)
(list :max-height dashboard-image-banner-max-height)))))
(list :max-height dashboard-image-banner-max-height))
dashboard-image-extra-props)))
(setq image-spec
(cond ((dashboard--type-is-gif-p img)
(cond ((dashboard--image-animated-p img)
(create-image img))
((dashboard--type-is-xbm-p img)
(create-image img))
((image-type-available-p 'imagemagick)
(apply 'create-image img 'imagemagick nil size-props))
(apply 'create-image img 'imagemagick nil img-props))
(t
(apply 'create-image img nil nil
(when (and (fboundp 'image-transforms-p)
(memq 'scale (funcall 'image-transforms-p)))
size-props))))))
img-props))))))
(add-text-properties start (point) `(display ,image-spec))
(when (dashboard--type-is-gif-p img) (image-animate image-spec 0 t)))
(when (ignore-errors (image-multi-frame-p image-spec)) (image-animate image-spec 0 t)))
;; Finally, center the banner (if any).
(when-let* ((text-align-spec `(space . (:align-to (- center ,(/ text-width 2)))))
(image-align-spec `(space . (:align-to (- center (0.5 . ,image-spec)))))
@@ -757,28 +863,27 @@ Argument IMAGE-PATH path to the image."
(t nil)))
(prefix (propertize " " 'display prop)))
(add-text-properties start (point) `(line-prefix ,prefix wrap-prefix ,prefix)))
(insert "\n\n")
(add-text-properties start (point) '(cursor-intangible t inhibit-isearch t))))
(insert "\n")
(add-text-properties start (point) '(cursor-intangible t inhibit-isearch t)))))
(defun dashboard-insert-banner-title ()
"Insert `dashboard-banner-logo-title' if it's non-nil."
(when dashboard-banner-logo-title
(dashboard-insert-center (propertize dashboard-banner-logo-title 'face 'dashboard-banner-logo-title))
(insert "\n\n"))
(dashboard-insert-navigator)
(dashboard-insert-init-info))
(insert "\n")))
;;
;; INIT INFO
;;
;;; Initialize info
(defun dashboard-insert-init-info ()
"Insert init info when `dashboard-set-init-info' is t."
(when dashboard-set-init-info
(let ((init-info (if (functionp dashboard-init-info)
(funcall dashboard-init-info)
dashboard-init-info)))
(dashboard-insert-center (propertize init-info 'face 'font-lock-comment-face)))))
"Insert init info."
(let ((init-info (if (functionp dashboard-init-info)
(funcall dashboard-init-info)
dashboard-init-info)))
(dashboard-insert-center (propertize init-info 'face 'font-lock-comment-face))))
(defun dashboard-insert-navigator ()
"Insert Navigator of the dashboard."
(when (and dashboard-set-navigator dashboard-navigator-buttons)
(when dashboard-navigator-buttons
(dolist (line dashboard-navigator-buttons)
(dolist (btn line)
(let* ((icon (car btn))
@@ -799,7 +904,8 @@ Argument IMAGE-PATH path to the image."
(when (and icon title
(not (string-equal icon ""))
(not (string-equal title "")))
(propertize " " 'face 'variable-pitch))
(propertize " " 'face `(:inherit (variable-pitch
,face))))
(when title (propertize title 'face face)))
:help-echo help
:action action
@@ -810,8 +916,7 @@ Argument IMAGE-PATH path to the image."
:format "%[%t%]")
(insert " ")))
(dashboard-center-text (line-beginning-position) (line-end-position))
(insert "\n"))
(insert "\n")))
(insert "\n"))))
(defmacro dashboard-insert-section (section-name list list-size shortcut-id shortcut-char action &rest widget-params)
"Add a section with SECTION-NAME and LIST of LIST-SIZE items to the dashboard.
@@ -822,7 +927,10 @@ ACTION is theaction taken when the user activates the widget button.
WIDGET-PARAMS are passed to the \"widget-create\" function."
`(progn
(dashboard-insert-heading ,section-name
(if (and ,list ,shortcut-char dashboard-show-shortcuts) ,shortcut-char))
(when (and ,list
,shortcut-char
dashboard-show-shortcuts)
,shortcut-char))
(if ,list
(when (and (dashboard-insert-section-list
,section-name
@@ -834,8 +942,8 @@ WIDGET-PARAMS are passed to the \"widget-create\" function."
(insert (propertize "\n --- No items ---" 'face 'dashboard-no-items-face)))))
;;
;; Section list
;;
;;; Section list
(defmacro dashboard-insert-section-list (section-name list action &rest rest)
"Insert into SECTION-NAME a LIST of items, expanding ACTION and passing REST
to widget creation."
@@ -843,14 +951,17 @@ to widget creation."
(mapc
(lambda (el)
(let ((tag ,@rest))
(insert "\n ")
(insert "\n")
(insert (spaces-string (or standard-indent tab-width 4)))
(when (and (dashboard-display-icons-p)
dashboard-set-file-icons)
(let* ((path (car (last (split-string ,@rest " - "))))
(icon (if (and (not (file-remote-p path))
(file-directory-p path))
(dashboard-icon-for-dir path nil "")
(dashboard-icon-for-dir path
:height dashboard-icon-file-height
:v-adjust dashboard-icon-file-v-adjust)
(cond
((or (string-equal ,section-name "Agenda for today:")
(string-equal ,section-name "Agenda for the coming week:"))
@@ -858,7 +969,8 @@ to widget creation."
((file-remote-p path)
dashboard-remote-path-icon)
(t (dashboard-icon-for-file (file-name-nondirectory path)
:v-adjust -0.05))))))
:height dashboard-icon-file-height
:v-adjust dashboard-icon-file-v-adjust))))))
(setq tag (concat icon " " ,@rest))))
(widget-create 'item
@@ -871,16 +983,26 @@ to widget creation."
:format "%[%t%]")))
,list)))
;; Footer
;;
;;; Footer
(defun dashboard-random-footer ()
"Return a random footer from `dashboard-footer-messages'."
(nth (random (length dashboard-footer-messages)) dashboard-footer-messages))
(defun dashboard-footer-icon ()
"Return footer icon or a random icon if `dashboard-footer-messages' is a list."
(if (and (not (null dashboard-footer-icon))
(listp dashboard-footer-icon))
(dashboard-replace-displayable
(nth (random (length dashboard-footer-icon))
dashboard-footer-icon))
(dashboard-replace-displayable dashboard-footer-icon)))
(defun dashboard-insert-footer ()
"Insert footer of dashboard."
(when-let ((footer (and dashboard-set-footer (dashboard-random-footer)))
(footer-icon (dashboard-replace-displayable dashboard-footer-icon)))
(insert "\n")
(when-let* ((footer (dashboard-random-footer))
(footer-icon (dashboard-footer-icon)))
(dashboard-insert-center
(if (string-empty-p footer-icon) footer-icon
(concat footer-icon " "))
@@ -888,8 +1010,8 @@ to widget creation."
"\n")))
;;
;; Truncate
;;
;;; Truncate
(defcustom dashboard-shorten-by-window-width nil
"Shorten path by window edges."
:type 'boolean
@@ -908,22 +1030,29 @@ to widget creation."
"Return directory name from PATH."
(file-name-nondirectory (directory-file-name (file-name-directory path))))
(defun dashboard-truncate-string-ellipsis ()
"Return the string used to indicate truncation."
(if (fboundp 'truncate-string-ellipsis)
(truncate-string-ellipsis)
(or truncate-string-ellipsis
"...")))
(defun dashboard-shorten-path-beginning (path)
"Shorten PATH from beginning if exceeding maximum length."
(let* ((len-path (length path))
(slen-path (dashboard-str-len path))
(len-rep (dashboard-str-len dashboard-path-shorten-string))
(len-rep (dashboard-str-len (dashboard-truncate-string-ellipsis)))
(len-total (- dashboard-path-max-length len-rep))
front)
(if (<= slen-path dashboard-path-max-length) path
(setq front (ignore-errors (substring path (- slen-path len-total) len-path)))
(if front (concat dashboard-path-shorten-string front) ""))))
(if front (concat (dashboard-truncate-string-ellipsis) front) ""))))
(defun dashboard-shorten-path-middle (path)
"Shorten PATH from middle if exceeding maximum length."
(let* ((len-path (length path))
(slen-path (dashboard-str-len path))
(len-rep (dashboard-str-len dashboard-path-shorten-string))
(len-rep (dashboard-str-len (dashboard-truncate-string-ellipsis)))
(len-total (- dashboard-path-max-length len-rep))
(center (/ len-total 2))
(end-back center)
@@ -932,20 +1061,20 @@ to widget creation."
(if (<= slen-path dashboard-path-max-length) path
(setq back (substring path 0 end-back)
front (ignore-errors (substring path start-front len-path)))
(if front (concat back dashboard-path-shorten-string front) ""))))
(if front (concat back (dashboard-truncate-string-ellipsis) front) ""))))
(defun dashboard-shorten-path-end (path)
"Shorten PATH from end if exceeding maximum length."
(let* ((len-path (length path))
(slen-path (dashboard-str-len path))
(len-rep (dashboard-str-len dashboard-path-shorten-string))
(len-rep (dashboard-str-len (dashboard-truncate-string-ellipsis)))
(diff (- slen-path len-path))
(len-total (- dashboard-path-max-length len-rep diff))
back)
(if (<= slen-path dashboard-path-max-length) path
(setq back (ignore-errors (substring path 0 len-total)))
(if (and back (< 0 dashboard-path-max-length))
(concat back dashboard-path-shorten-string) ""))))
(concat back (dashboard-truncate-string-ellipsis)) ""))))
(defun dashboard--get-base-length (path type)
"Return the length of the base from the PATH by TYPE."
@@ -1038,8 +1167,8 @@ to widget creation."
align-length))
;;
;; Recentf
;;
;;; Recentf
(defcustom dashboard-recentf-show-base nil
"Show the base file name infront of it's path."
:type '(choice
@@ -1089,8 +1218,8 @@ to widget creation."
(t (format dashboard-recentf-item-format filename path))))))
;;
;; Bookmarks
;;
;;; Bookmarks
(defcustom dashboard-bookmarks-show-base t
"Show the base file name infront of it's path."
:type '(choice
@@ -1133,8 +1262,8 @@ to widget creation."
el)))
;;
;; Projects
;;
;;; Projects
(defcustom dashboard-projects-switch-function
nil
"Custom function to switch to projects from dashboard.
@@ -1230,8 +1359,8 @@ over custom backends."
:error)))))
;;
;; Org Agenda
;;
;;; Org Agenda
(defcustom dashboard-week-agenda t
"Show agenda weekly if its not nil."
:type 'boolean
@@ -1289,7 +1418,9 @@ Any custom function would receives the tags from `org-get-tags'"
(defun dashboard-agenda-entry-format ()
"Format agenda entry to show it on dashboard.
Also,it set text properties that latter are used to sort entries and perform different actions."
Also,it set text properties that latter are used to sort entries and perform
different actions."
(let* ((scheduled-time (org-get-scheduled-time (point)))
(deadline-time (org-get-deadline-time (point)))
(entry-timestamp (dashboard-agenda--entry-timestamp (point)))
@@ -1301,7 +1432,7 @@ Also,it set text properties that latter are used to sort entries and perform dif
(org-get-category)
(dashboard-agenda--formatted-tags)))
(todo-state (org-get-todo-state))
(item-priority (org-get-priority (org-get-heading t t t t)))
(item-priority (org-get-priority (org-get-heading t t nil t)))
(todo-index (and todo-state
(length (member todo-state org-todo-keywords-1))))
(entry-data (list 'dashboard-agenda-file (buffer-file-name)
@@ -1314,12 +1445,12 @@ Also,it set text properties that latter are used to sort entries and perform dif
(defun dashboard-agenda--entry-timestamp (point)
"Get the timestamp from an entry at POINT."
(when-let ((timestamp (org-entry-get point "TIMESTAMP")))
(when-let* ((timestamp (org-entry-get point "TIMESTAMP")))
(org-time-string-to-time timestamp)))
(defun dashboard-agenda--formatted-headline ()
"Set agenda faces to `HEADLINE' when face text property is nil."
(let* ((headline (org-get-heading t t t t))
(let* ((headline (org-link-display-format (org-get-heading t t t t)))
(todo (or (org-get-todo-state) ""))
(org-level-face (nth (- (org-outline-level) 1) org-level-faces))
(todo-state (format org-agenda-todo-keyword-format todo)))
@@ -1335,8 +1466,8 @@ If not height is found on FACE or `dashboard-items-face' use `default'."
(defun dashboard-agenda--formatted-time ()
"Get the scheduled or dead time of an entry. If no time is found return nil."
(when-let ((time (or (org-get-scheduled-time (point)) (org-get-deadline-time (point))
(dashboard-agenda--entry-timestamp (point)))))
(when-let* ((time (or (org-get-scheduled-time (point)) (org-get-deadline-time (point))
(dashboard-agenda--entry-timestamp (point)))))
(format-time-string dashboard-agenda-time-string-format time)))
(defun dashboard-agenda--formatted-tags ()
@@ -1362,12 +1493,12 @@ point."
(unless (and (not (org-entry-is-done-p))
(not (org-in-archived-heading-p))
(or (and scheduled-time
(org-time-less-p scheduled-time due-date))
(time-less-p scheduled-time due-date))
(and deadline-time
(org-time-less-p deadline-time due-date))
(time-less-p deadline-time due-date))
(and entry-timestamp
(org-time-less-p now entry-timestamp)
(org-time-less-p entry-timestamp due-date))))
(time-less-p now entry-timestamp)
(time-less-p entry-timestamp due-date))))
(point))))
(defun dashboard-filter-agenda-by-todo ()
@@ -1385,7 +1516,7 @@ if returns a point."
(defun dashboard-get-agenda ()
"Get agenda items for today or for a week from now."
(if-let ((prefix-format (assoc 'dashboard-agenda org-agenda-prefix-format)))
(if-let* ((prefix-format (assoc 'dashboard-agenda org-agenda-prefix-format)))
(setcdr prefix-format dashboard-agenda-prefix-format)
(push (cons 'dashboard-agenda dashboard-agenda-prefix-format) org-agenda-prefix-format))
(org-compile-prefix-format 'dashboard-agenda)
@@ -1440,8 +1571,8 @@ found for the strategy it uses nil predicate."
(cl-case strategy
(`priority-up '>)
(`priority-down '<)
(`time-up 'org-time-less-p)
(`time-down (lambda (a b) (org-time-less-p b a)))
(`time-up 'time-less-p)
(`time-down (lambda (a b) (time-less-p b a)))
(`todo-state-up '>)
(`todo-state-down '<)))
@@ -1466,6 +1597,19 @@ to compare."
((null arg2) t)
(t (apply predicate (list arg1 arg2))))))
(defun dashboard-agenda--visit-file (file point)
"Action on agenda-entry that visit a FILE at POINT."
(let ((buffer (find-file-noselect file)))
(with-current-buffer buffer
(goto-char point)
(switch-to-buffer buffer)
(recenter-top-bottom))))
(defun dashboard-agenda--visit-file-other-window (file point)
"Visit FILE at POINT of an agenda item in other window."
(let ((buffer (find-file-other-window file)))
(with-current-buffer buffer (goto-char point) (recenter-top-bottom))))
(defun dashboard-insert-agenda (list-size)
"Add the list of LIST-SIZE items of agenda."
(require 'org-agenda)
@@ -1478,15 +1622,14 @@ to compare."
'agenda
(dashboard-get-shortcut 'agenda)
`(lambda (&rest _)
(let ((buffer (find-file-other-window (get-text-property 0 'dashboard-agenda-file ,el))))
(with-current-buffer buffer
(goto-char (get-text-property 0 'dashboard-agenda-loc ,el))
(switch-to-buffer buffer))))
(let ((file (get-text-property 0 'dashboard-agenda-file ,el))
(point (get-text-property 0 'dashboard-agenda-loc ,el)))
(funcall dashboard-agenda-action file point)))
(format "%s" el)))
;;
;; Registers
;;
;;; Registers
(defun dashboard-insert-registers (list-size)
"Add the list of LIST-SIZE items of registers."
(require 'register)
lisp/dashboard/dashboard.el
+234 -117
View File
@@ -1,10 +1,10 @@
;;; dashboard.el --- A startup screen extracted from Spacemacs -*- lexical-binding: t -*-
;; Copyright (c) 2016-2023 emacs-dashboard maintainers
;; Copyright (c) 2016-2025 emacs-dashboard maintainers
;;
;; Author : Rakan Al-Hneiti <rakan.alhneiti@gmail.com>
;; Maintainer : Jesús Martínez <jesusmartinez93@gmail.com>
;; Shen, Jen-Chieh <jcs090218@gmail.com>
;; Maintainer : Shen, Jen-Chieh <jcs090218@gmail.com>
;; Ricardo Arredondo <ricardo.richo@gmail.com>
;; URL : https://github.com/emacs-dashboard/emacs-dashboard
;;
;; This file is not part of GNU Emacs.
@@ -14,7 +14,8 @@
;; Created: October 05, 2016
;; Package-Version: 1.9.0-SNAPSHOT
;; Keywords: startup, screen, tools, dashboard
;; Package-Requires: ((emacs "26.1"))
;; Package-Requires: ((emacs "27.1"))
;;; Commentary:
;; An extensible Emacs dashboard, with sections for
@@ -27,6 +28,9 @@
(require 'dashboard-widgets)
;;
;;; Externals
(declare-function bookmark-get-filename "ext:bookmark.el")
(declare-function bookmark-all-names "ext:bookmark.el")
(declare-function dashboard-ls--dirs "ext:dashboard-ls.el")
@@ -38,6 +42,9 @@
(declare-function dashboard-refresh-buffer "dashboard.el")
;;
;;; Customization
(defgroup dashboard nil
"Extensible startup screen."
:group 'applications)
@@ -45,17 +52,17 @@
;; Custom splash screen
(defvar dashboard-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-p") 'dashboard-previous-line)
(define-key map (kbd "C-n") 'dashboard-next-line)
(define-key map (kbd "<up>") 'dashboard-previous-line)
(define-key map (kbd "<down>") 'dashboard-next-line)
(define-key map (kbd "k") 'dashboard-previous-line)
(define-key map (kbd "j") 'dashboard-next-line)
(define-key map [tab] 'widget-forward)
(define-key map (kbd "C-i") 'widget-forward)
(define-key map [backtab] 'widget-backward)
(define-key map (kbd "RET") 'dashboard-return)
(define-key map [mouse-1] 'dashboard-mouse-1)
(define-key map (kbd "C-p") #'dashboard-previous-line)
(define-key map (kbd "C-n") #'dashboard-next-line)
(define-key map (kbd "<up>") #'dashboard-previous-line)
(define-key map (kbd "<down>") #'dashboard-next-line)
(define-key map (kbd "k") #'dashboard-previous-line)
(define-key map (kbd "j") #'dashboard-next-line)
(define-key map [tab] #'widget-forward)
(define-key map (kbd "C-i") #'widget-forward)
(define-key map [backtab] #'widget-backward)
(define-key map (kbd "RET") #'dashboard-return)
(define-key map [mouse-1] #'dashboard-mouse-1)
(define-key map (kbd "}") #'dashboard-next-section)
(define-key map (kbd "{") #'dashboard-previous-section)
@@ -75,11 +82,21 @@
map)
"Keymap for dashboard mode.")
(defcustom dashboard-before-initialize-hook nil
"Hook that is run before dashboard buffer is initialized."
:group 'dashboard
:type 'hook)
(defcustom dashboard-after-initialize-hook nil
"Hook that is run after dashboard buffer is initialized."
:group 'dashboard
:type 'hook)
(defcustom dashboard-hide-cursor nil
"Whether to hide the cursor in the dashboard."
:type 'boolean
:group 'dashboard)
(define-derived-mode dashboard-mode special-mode "Dashboard"
"Dashboard major mode for startup screen."
:group 'dashboard
@@ -91,6 +108,8 @@
(when (featurep 'display-line-numbers) (display-line-numbers-mode -1))
(when (featurep 'page-break-lines) (page-break-lines-mode 1))
(setq-local revert-buffer-function #'dashboard-refresh-buffer)
(when dashboard-hide-cursor
(setq-local cursor-type nil))
(setq inhibit-startup-screen t
buffer-read-only t
truncate-lines t))
@@ -100,18 +119,58 @@
:type 'boolean
:group 'dashboard)
(defconst dashboard-buffer-name "*dashboard*"
"Dashboard's buffer name.")
(defcustom dashboard-vertically-center-content nil
"Whether to vertically center content within the window."
:type 'boolean
:group 'dashboard)
(defvar dashboard-force-refresh nil
"If non-nil, force refresh dashboard buffer.")
(defcustom dashboard-startupify-list
'(dashboard-insert-banner
dashboard-insert-newline
dashboard-insert-banner-title
dashboard-insert-newline
dashboard-insert-init-info
dashboard-insert-items
dashboard-insert-newline
dashboard-insert-footer)
"List of dashboard widgets (in order) to insert in dashboard buffer.
Avalaible functions:
`dashboard-insert-newline'
`dashboard-insert-page-break'
`dashboard-insert-banner'
`dashboard-insert-banner-title'
`dashboard-insert-navigator'
`dashboard-insert-init-info'
`dashboard-insert-items'
`dashboard-insert-footer'
It must be a function or a cons cell where specify function and
its arg.
Also you can add your custom function or a lambda to the list.
example:
(lambda () (delete-char -1))"
:type '(repeat (choice
function
(cons function sexp)))
:group 'dashboard)
(defcustom dashboard-navigation-cycle nil
"Non-nil cycle the section navigation."
:type 'boolean
:group 'dashboard)
(defcustom dashboard-buffer-name "*dashboard*"
"Dashboard's buffer name."
:type 'string
:group 'dashboard)
(defvar dashboard--section-starts nil
"List of section starting positions.")
;;
;; Util
;;
;;; Util
(defun dashboard--goto-line (line)
"Goto LINE."
(goto-char (point-min)) (forward-line (1- line)))
@@ -126,58 +185,75 @@
(move-to-column column)))
;;
;; Core
;;
;;; Core
(defun dashboard--separator ()
"Return separator used to search."
(concat "\n" dashboard-page-separator))
(defun dashboard--current-section ()
"Return section symbol in dashboard."
(save-excursion
(if (and (search-backward dashboard-page-separator nil t)
(search-forward dashboard-page-separator nil t))
(let ((ln (thing-at-point 'line)))
(cond ((string-match-p "Recent Files:" ln) 'recents)
((string-match-p "Bookmarks:" ln) 'bookmarks)
((string-match-p "Projects:" ln) 'projects)
((string-match-p "Agenda for " ln) 'agenda)
((string-match-p "Registers:" ln) 'registers)
((string-match-p "List Directories:" ln) 'ls-directories)
((string-match-p "List Files:" ln) 'ls-files)
(t (user-error "Unknown section from dashboard"))))
(if-let* ((sep (dashboard--separator))
((and (search-backward sep nil t)
(search-forward sep nil t)))
(ln (thing-at-point 'line t)))
(cond ((string-match-p "Recent Files:" ln) 'recents)
((string-match-p "Bookmarks:" ln) 'bookmarks)
((string-match-p "Projects:" ln) 'projects)
((string-match-p "Agenda for " ln) 'agenda)
((string-match-p "Registers:" ln) 'registers)
((string-match-p "List Directories:" ln) 'ls-directories)
((string-match-p "List Files:" ln) 'ls-files)
(t (user-error "Unknown section from dashboard")))
(user-error "Failed searching dashboard section"))))
;;
;; Navigation
;;
;;; Navigation
(defun dashboard-previous-section ()
"Navigate back to previous section."
"Navigate backwards to previous section."
(interactive)
(let ((current-position (point)) current-section-start previous-section-start)
(dolist (elt dashboard--section-starts)
(when (and current-section-start (not previous-section-start))
(setq previous-section-start elt))
(when (and (not current-section-start) (< elt current-position))
(setq current-section-start elt)))
(goto-char (if (eq current-position current-section-start)
previous-section-start
current-section-start))))
(let* ((items-len (1- (length dashboard-items)))
(first-item (car (nth 0 dashboard-items)))
(current (or (ignore-errors (dashboard--current-section))
first-item))
(items (mapcar #'car dashboard-items))
(find (cl-position current items :test #'equal))
(prev-index (1- find))
(prev (cond (dashboard-navigation-cycle
(if (< prev-index 0) (nth items-len items)
(nth prev-index items)))
(t
(if (< prev-index 0) (nth 0 items)
(nth prev-index items))))))
(dashboard--goto-section prev)))
(defun dashboard-next-section ()
"Navigate forward to next section."
(interactive)
(let ((current-position (point)) next-section-start
(section-starts (reverse dashboard--section-starts)))
(dolist (elt section-starts)
(when (and (not next-section-start)
(> elt current-position))
(setq next-section-start elt)))
(when next-section-start
(goto-char next-section-start))))
(let* ((items-len (1- (length dashboard-items)))
(last-item (car (nth items-len dashboard-items)))
(current (or (ignore-errors (dashboard--current-section))
last-item))
(items (mapcar #'car dashboard-items))
(find (cl-position current items :test #'equal))
(next-index (1+ find))
(next (cond (dashboard-navigation-cycle
(or (nth next-index items)
(nth 0 items)))
(t
(if (< items-len next-index)
(nth (min items-len next-index) items)
(nth next-index items))))))
(dashboard--goto-section next)))
(defun dashboard--section-lines ()
"Return a list of integer represent the starting line number of each section."
(let (pb-lst)
(save-excursion
(goto-char (point-min))
(while (search-forward dashboard-page-separator nil t)
(while (search-forward (dashboard--separator) nil t)
(when (ignore-errors (dashboard--current-section))
(push (line-number-at-pos) pb-lst))))
(setq pb-lst (reverse pb-lst))
@@ -192,6 +268,36 @@
(when (and items-pg (< items-id items-len))
(dashboard--goto-line items-pg))))
(defun dashboard-cycle-section-forward (&optional section)
"Cycle forward through the entries in SECTION.
If SECTION is nil, cycle in the current section."
(let ((target-section (or section (dashboard--current-section))))
(if target-section
(condition-case nil
(progn
(widget-forward 1)
(unless (eq target-section (dashboard--current-section))
(dashboard--goto-section target-section)))
(widget-forward 1))
(widget-forward 1))))
(defun dashboard-cycle-section-backward (&optional section)
"Cycle backward through the entries in SECTION.
If SECTION is nil, cycle in the current section."
(let ((target-section (or section (dashboard--current-section))))
(if target-section
(condition-case nil
(progn
(widget-backward 1)
(unless (eq target-section (dashboard--current-section))
(progn
(dashboard--goto-section target-section)
(while (eq target-section (dashboard--current-section))
(widget-forward 1))
(widget-backward 1))))
(widget-backward 1))
(widget-backward 1))))
(defun dashboard-section-1 ()
"Navigate to section 1." (interactive) (dashboard--goto-section-by-index 1))
(defun dashboard-section-2 ()
@@ -232,8 +338,8 @@ Optional prefix ARG says how many lines to move; default is one line."
(beginning-of-line-text))
;;
;; ffap
;;
;;; ffap
(defun dashboard--goto-section (section)
"Move to SECTION declares in variable `dashboard-item-shortcuts'."
(let ((fnc (intern (format "dashboard-jump-to-%s" section))))
@@ -290,8 +396,8 @@ Optional argument ARGS adviced function arguments."
(advice-add 'ffap-guesser :around #'dashboard--ffap-guesser--adv)
;;
;; Removal
;;
;;; Removal
(defun dashboard-remove-item-under ()
"Remove a item from the current item section."
(interactive)
@@ -337,8 +443,8 @@ Optional argument ARGS adviced function arguments."
(interactive)) ; TODO: ..
;;
;; Confirmation
;;
;;; Confirmation
(defun dashboard-return ()
"Hit return key in dashboard buffer."
(interactive)
@@ -368,8 +474,8 @@ Optional argument ARGS adviced function arguments."
(setq track-mouse old-track-mouse))))
;;
;; Insertion
;;
;;; Insertion
(defmacro dashboard--with-buffer (&rest body)
"Execute BODY in dashboard buffer."
(declare (indent 0))
@@ -377,79 +483,90 @@ Optional argument ARGS adviced function arguments."
(let ((inhibit-read-only t)) ,@body)
(current-buffer)))
(defun dashboard-maximum-section-length ()
"For the just-inserted section, calculate the length of the longest line."
(let ((max-line-length 0))
(save-excursion
(dashboard-previous-section)
(while (not (eobp))
(setq max-line-length
(max max-line-length
(- (line-end-position) (line-beginning-position))))
(forward-line 1)))
max-line-length))
(defun dashboard-insert-items ()
"Function to insert dashboard items.
See `dashboard-item-generators' for all items available."
(let ((recentf-is-on (recentf-enabled-p))
(origial-recentf-list recentf-list))
(mapc (lambda (els)
(let* ((el (or (car-safe els) els))
(list-size
(or (cdr-safe els)
dashboard-items-default-length))
(item-generator
(cdr-safe (assoc el dashboard-item-generators))))
(defun dashboard-insert-startupify-lists ()
"Insert the list of widgets into the buffer."
(insert "\n")
(push (point) dashboard--section-starts)
(funcall item-generator list-size)
(goto-char (point-max))
(when recentf-is-on
(setq recentf-list origial-recentf-list))))
dashboard-items)
(when dashboard-center-content
(dashboard-center-text
(if dashboard--section-starts
(car (last dashboard--section-starts))
(point))
(point-max)))
(save-excursion
(dolist (start dashboard--section-starts)
(goto-char start)
(insert dashboard-page-separator)))
(insert "\n")
(insert dashboard-page-separator)))
(defun dashboard-insert-startupify-lists (&optional force-refresh)
"Insert the list of widgets into the buffer, FORCE-REFRESH is optional."
(interactive)
(let ((inhibit-redisplay t)
(recentf-is-on (recentf-enabled-p))
(origial-recentf-list recentf-list)
(dashboard-num-recents (or (cdr (assoc 'recents dashboard-items)) 0))
(max-line-length 0))
(dashboard-num-recents (or (cdr (assoc 'recents dashboard-items)) 0)))
(when recentf-is-on
(setq recentf-list (dashboard-subseq recentf-list dashboard-num-recents)))
(dashboard--with-buffer
(when (or dashboard-force-refresh (not (eq major-mode 'dashboard-mode)))
(when (or force-refresh (not (eq major-mode 'dashboard-mode)))
(run-hooks 'dashboard-before-initialize-hook)
(erase-buffer)
(dashboard-insert-banner)
(insert "\n")
(setq dashboard--section-starts nil)
(mapc (lambda (els)
(let* ((el (or (car-safe els) els))
(list-size
(or (cdr-safe els)
dashboard-items-default-length))
(item-generator
(cdr-safe (assoc el dashboard-item-generators))))
(push (point) dashboard--section-starts)
(funcall item-generator list-size)
(goto-char (point-max))
;; add a newline so the next section-name doesn't get include
;; on the same line.
(insert "\n")
(when recentf-is-on
(setq recentf-list origial-recentf-list))
(setq max-line-length
(max max-line-length (dashboard-maximum-section-length)))))
dashboard-items)
(when dashboard-center-content
(dashboard-center-text
(if dashboard--section-starts
(car (last dashboard--section-starts))
(point))
(point-max)))
(save-excursion
(dolist (start dashboard--section-starts)
(goto-char start)
(delete-char -1) ; delete the newline we added previously
(insert dashboard-page-separator)))
(progn
(delete-char -1)
(insert dashboard-page-separator))
(dashboard-insert-footer)
(goto-char (point-min))
(mapc (lambda (entry)
(if (and (listp entry)
(not (functionp entry)))
(apply (car entry) `(,(cdr entry)))
(funcall entry)))
dashboard-startupify-list)
(dashboard-vertically-center)
(dashboard-mode)))
(when recentf-is-on
(setq recentf-list origial-recentf-list))))
(defun dashboard-vertically-center ()
"Center vertically the content of dashboard. Always go to point-min char."
(when-let* (dashboard-vertically-center-content
(start-height (cdr (window-absolute-pixel-position (point-min))))
(end-height (cdr (window-absolute-pixel-position (point-max))))
(content-height (- end-height start-height))
(vertical-padding (floor (/ (- (window-pixel-height) content-height) 2)))
((> vertical-padding 0))
(vertical-lines (1- (floor (/ vertical-padding (line-pixel-height)))))
((> vertical-lines 0)))
(goto-char (point-min))
(insert (make-string vertical-lines ?\n)))
(goto-char (point-min)))
;;;###autoload
(defun dashboard-open (&rest _)
"Open (or refresh) the *dashboard* buffer."
(interactive)
(let ((dashboard-force-refresh t)) (dashboard-insert-startupify-lists))
(switch-to-buffer dashboard-buffer-name))
(dashboard--with-buffer
(switch-to-buffer (current-buffer))
(dashboard-insert-startupify-lists t)))
(defalias #'dashboard-refresh-buffer #'dashboard-open)
lisp/deft/deft-pkg.el
+1 -1
View File
@@ -1,4 +1,4 @@
(define-package "deft" "20210707.1633" "quickly browse, filter, and edit plain text notes" 'nil :commit "28be94d89bff2e1c7edef7244d7c5ba0636b1296" :authors
(define-package "deft" "20240524.1524" "quickly browse, filter, and edit plain text notes" 'nil :commit "b369d7225d86551882568788a23c5497b232509c" :authors
'(("Jason R. Blevins" . "jrblevin@xbeta.org"))
:maintainers
'(("Jason R. Blevins" . "jrblevin@xbeta.org"))
lisp/deft/deft.el
+24 -18
View File
@@ -673,7 +673,7 @@ recursively, that is, when `deft-recursive' is non-nil."
"Regular expression to remove from file titles.
Presently, it removes leading LaTeX comment delimiters, leading
and trailing hash marks from Markdown ATX headings, leading
astersisks from Org Mode headings, and Emacs mode lines of the
asterisks from Org Mode headings, and Emacs mode lines of the
form -*-mode-*-."
:type 'regexp
:safe 'stringp
@@ -707,38 +707,38 @@ slash characters in the file name. The default behavior is to
replace slashes with hyphens in the file name. To change the
replacement charcter to an underscore, one could use:
(setq deft-file-naming-rules '((noslash . \"_\")))
(setq deft-file-naming-rules \\='((noslash . \"_\")))
Value of `nospace' is a string which should replace the space
characters in the file name. Below example replaces spaces with
underscores in the file names:
(setq deft-file-naming-rules '((nospace . \"_\")))
(setq deft-file-naming-rules \\='((nospace . \"_\")))
Value of `case-fn' is a function name that takes a string as
input that has to be applied on the file name. Below example
makes the file name all lower case:
(setq deft-file-naming-rules '((case-fn . downcase)))
(setq deft-file-naming-rules \\='((case-fn . downcase)))
It is also possible to use a combination of the above cons cells
to get file name in various case styles like,
snake_case:
(setq deft-file-naming-rules '((noslash . \"_\")
(setq deft-file-naming-rules \\='((noslash . \"_\")
(nospace . \"_\")
(case-fn . downcase)))
or CamelCase
(setq deft-file-naming-rules '((noslash . \"\")
(setq deft-file-naming-rules \\='((noslash . \"\")
(nospace . \"\")
(case-fn . capitalize)))
or kebab-case
(setq deft-file-naming-rules '((noslash . \"-\")
(setq deft-file-naming-rules \\='((noslash . \"-\")
(nospace . \"-\")
(case-fn . downcase)))"
:type '(alist :key-type symbol :value-type sexp)
@@ -849,7 +849,7 @@ regexp.")
(defvar deft-current-sort-method 'mtime
"Current file soft method.
Available methods are 'mtime and 'title.")
Available methods are \\='mtime and \\='title.")
(defvar deft-all-files nil
"List of all files in `deft-directory'.")
@@ -1450,11 +1450,15 @@ the newly created FILE."
"\n\n")
nil file nil)))
(defun deft-new-file-named (slug)
(defun deft-new-file-named (slug &optional arg)
"Create a new file named SLUG.
SLUG is the short file name, without a path or a file extension."
(interactive "sNew filename (without extension): ")
(let ((file (deft-absolute-filename slug)))
SLUG is the short file name, without a path or a file extension.
With prefix ARG, ask for a file extension."
(interactive "sNew filename (without extension): \nP")
(let* ((extension (and arg
(completing-read "Extension: " deft-extensions
nil t nil nil deft-default-extension)))
(file (deft-absolute-filename slug extension)))
(if (file-exists-p file)
(message "Aborting, file already exists: %s" file)
(deft-auto-populate-title-maybe file)
@@ -1465,12 +1469,14 @@ SLUG is the short file name, without a path or a file extension."
(goto-char (point-max))))))
;;;###autoload
(defun deft-new-file ()
(defun deft-new-file (&optional arg)
"Create a new file quickly.
Use either an automatically generated filename or the filter string if non-nil
and `deft-use-filter-string-for-filename' is set. If the filter string is
non-nil and title is not from filename, use it as the title."
(interactive)
Use either an automatically generated filename or the filter
string if non-nil and `deft-use-filter-string-for-filename' is
set. If the filter string is non-nil and title is not from
filename, use it as the title. The prefix ARG is passed to
`deft-new-file-named'."
(interactive "P")
(let (slug)
(if (and deft-filter-regexp deft-use-filter-string-for-filename)
;; If the filter string is non-emtpy and titles are taken from
@@ -1479,7 +1485,7 @@ non-nil and title is not from filename, use it as the title."
;; If the filter string is empty, or titles are taken from file
;; contents, then use an automatically generated unique filename.
(setq slug (deft-unused-slug)))
(deft-new-file-named slug)))
(deft-new-file-named slug arg)))
(defun deft-filename-at-point ()
"Return the name of the file represented by the button at the point.
lisp/diff-hl/diff-hl-amend.el
+2 -2
View File
@@ -1,6 +1,6 @@
;; Copyright (C) 2012-2013, 2020 Free Software Foundation, Inc. -*- lexical-binding: t -*-
;; Copyright (C) 2012-2013, 2020-2024 Free Software Foundation, Inc. -*- lexical-binding: t -*-
;; Author: Dmitry Gutov <dgutov@yandex.ru>
;; Author: Dmitry Gutov <dmitry@gutov.dev>
;; URL: https://github.com/dgutov/diff-hl
;; This file is part of GNU Emacs.
lisp/diff-hl/diff-hl-inline-popup.el
+8 -4
View File
@@ -53,7 +53,8 @@
(- (length list) length offset)))
(defun diff-hl-inline-popup--ensure-enough-lines (pos content-height)
"Ensure there is enough lines below POS to show the inline popup with CONTENT-HEIGHT height."
"Ensure there is enough lines below POS to show the inline popup.
CONTENT-HEIGHT specifies the height of the popup."
(let* ((line (line-number-at-pos pos))
(end (line-number-at-pos (window-end nil t)))
(height (+ 6 content-height))
@@ -69,14 +70,16 @@ Default for CONTENT-SIZE is the size of the current lines"
(min content-size max-size)))
(defun diff-hl-inline-popup--compute-content-lines (lines index window-size)
"Compute the lines to show in the popup, from LINES starting at INDEX with a WINDOW-SIZE."
"Compute the lines to show in the popup.
Compute it from LINES starting at INDEX with a WINDOW-SIZE."
(let* ((len (length lines))
(window-size (min window-size len))
(index (min index (- len window-size))))
(diff-hl-inline-popup--splice lines index window-size)))
(defun diff-hl-inline-popup--compute-header (width &optional header)
"Compute the header of the popup, with some WIDTH, and some optional HEADER text."
"Compute the header of the popup.
Compute it from some WIDTH, and some optional HEADER text."
(let* ((scroll-indicator (if (eq diff-hl-inline-popup--current-index 0) " " " ⬆ "))
(header (or header ""))
(new-width (- width (length header) (length scroll-indicator)))
@@ -88,7 +91,8 @@ Default for CONTENT-SIZE is the size of the current lines"
(concat line "\n") ))
(defun diff-hl-inline-popup--compute-footer (width &optional footer)
"Compute the header of the popup, with some WIDTH, and some optional FOOTER text."
"Compute the header of the popup.
Compute it from some WIDTH, and some optional FOOTER text."
(let* ((scroll-indicator (if (>= diff-hl-inline-popup--current-index
(- (length diff-hl-inline-popup--current-lines)
diff-hl-inline-popup--height))
lisp/diff-hl/diff-hl-pkg.el
+5 -5
View File
@@ -1,12 +1,12 @@
(define-package "diff-hl" "20230807.1516" "Highlight uncommitted changes using VC"
(define-package "diff-hl" "20250223.2320" "Highlight uncommitted changes using VC"
'((cl-lib "0.2")
(emacs "25.1"))
:commit "b5651f1c57b42e0f38e01a8fc8c7df9bc76d5d38" :authors
'(("Dmitry Gutov" . "dgutov@yandex.ru"))
:commit "685e99135001da13caecdff71acea1ee20bed373" :authors
'(("Dmitry Gutov" . "dmitry@gutov.dev"))
:maintainers
'(("Dmitry Gutov" . "dgutov@yandex.ru"))
'(("Dmitry Gutov" . "dmitry@gutov.dev"))
:maintainer
'("Dmitry Gutov" . "dgutov@yandex.ru")
'("Dmitry Gutov" . "dmitry@gutov.dev")
:keywords
'("vc" "diff")
:url "https://github.com/dgutov/diff-hl")
lisp/diff-hl/diff-hl-show-hunk.el
+1 -1
View File
@@ -400,7 +400,7 @@ The backend is determined by `diff-hl-show-hunk-function'."
;;;###autoload
(define-minor-mode diff-hl-show-hunk-mouse-mode
"Enables the margin and fringe to show a posframe/popup with vc diffs when clicked.
"Enable margin and fringe to show a posframe/popup with vc diffs when clicked.
By default, the popup shows only the current hunk, and
the line of the hunk that matches the current position is
highlighted. The face, border and other visual preferences are
lisp/diff-hl/diff-hl.el
+199 -64
View File
@@ -1,11 +1,11 @@
;;; diff-hl.el --- Highlight uncommitted changes using VC -*- lexical-binding: t -*-
;; Copyright (C) 2012-2023 Free Software Foundation, Inc.
;; Copyright (C) 2012-2024 Free Software Foundation, Inc.
;; Author: Dmitry Gutov <dgutov@yandex.ru>
;; Author: Dmitry Gutov <dmitry@gutov.dev>
;; URL: https://github.com/dgutov/diff-hl
;; Keywords: vc, diff
;; Version: 1.9.2
;; Version: 1.10.0
;; Package-Requires: ((cl-lib "0.2") (emacs "25.1"))
;; This file is part of GNU Emacs.
@@ -194,8 +194,30 @@ the NEW revision is not specified (meaning, the diff is against
the current version of the file)."
:type 'boolean)
(defcustom diff-hl-update-async nil
"When non-nil, `diff-hl-update' will run asynchronously.
This can help prevent Emacs from freezing, especially by a slow version
control (VC) backend. It's disabled in remote buffers, though, since it
didn't work reliably in such during testing."
:type 'boolean)
;; Threads are not reliable with remote files, yet.
(defcustom diff-hl-async-inhibit-functions (list #'diff-hl-with-editor-p
#'file-remote-p)
"Functions to call to check whether asychronous method should be disabled.
When `diff-hl-update-async' is non-nil, these functions are called in turn
and passed the value `default-directory'.
If any returns non-nil, `diff-hl-update' will run synchronously anyway."
:type '(repeat :tag "Predicate" function))
(defvar diff-hl-reference-revision nil
"Revision to diff against. nil means the most recent one.")
"Revision to diff against. nil means the most recent one.
It can be a relative expression as well, such as \"HEAD^\" with Git, or
\"-2\" with Mercurial.")
(defun diff-hl-define-bitmaps ()
(let* ((scale (if (and (boundp 'text-scale-mode-amount)
@@ -309,6 +331,8 @@ the current version of the file)."
diff-hl-reference-revision))))
(declare-function vc-git-command "vc-git")
(declare-function vc-git--rev-parse "vc-git")
(declare-function vc-hg-command "vc-hg")
(defun diff-hl-changes-buffer (file backend)
(diff-hl-with-diff-switches
@@ -384,6 +408,28 @@ the current version of the file)."
(nreverse res))))
(defun diff-hl-update ()
"Updates the diff-hl overlay."
(if (and diff-hl-update-async
(not
(run-hook-with-args-until-success 'diff-hl-async-inhibit-functions
default-directory)))
;; TODO: debounce if a thread is already running.
(make-thread 'diff-hl--update-safe "diff-hl--update-safe")
(diff-hl--update)))
(defun diff-hl-with-editor-p (_dir)
(bound-and-true-p with-editor-mode))
(defun diff-hl--update-safe ()
"Updates the diff-hl overlay. It handles and logs when an error is signaled."
(condition-case err
(diff-hl--update)
(error
(message "An error occurred in diff-hl--update: %S" err)
nil)))
(defun diff-hl--update ()
"Updates the diff-hl overlay."
(let ((changes (diff-hl-changes))
(current-line 1))
(diff-hl-remove-overlays)
@@ -460,13 +506,13 @@ the current version of the file)."
(run-with-idle-timer 0.01 nil #'diff-hl-after-undo (current-buffer)))))
(defun diff-hl-after-undo (buffer)
(with-current-buffer buffer
(unless (buffer-modified-p)
(diff-hl-update))))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(unless (buffer-modified-p)
(diff-hl-update)))))
(defun diff-hl-after-revert ()
(defvar revert-buffer-preserve-modes)
(when revert-buffer-preserve-modes
(when (bound-and-true-p revert-buffer-preserve-modes)
(diff-hl-update)))
(defun diff-hl-diff-goto-hunk-1 (historic)
@@ -708,6 +754,21 @@ its end position."
(unless (eq backend 'Git)
(user-error "Only Git supports staging; this file is controlled by %s" backend))))
(defun diff-hl-stage-diff (orig-buffer)
(let ((patchfile (make-temp-file "diff-hl-stage-patch"))
success)
(write-region (point-min) (point-max) patchfile
nil 'silent)
(unwind-protect
(with-current-buffer orig-buffer
(with-output-to-string
(vc-git-command standard-output 0
patchfile
"apply" "--cached" )
(setq success t)))
(delete-file patchfile))
success))
(defun diff-hl-stage-current-hunk ()
"Stage the hunk at or near point.
@@ -741,17 +802,7 @@ Only supported with Git."
(insert (format "diff a/%s b/%s\n" file-base file-base))
(insert (format "--- a/%s\n" file-base))
(insert (format "+++ b/%s\n" file-base)))
(let ((patchfile (make-temp-file "diff-hl-stage-patch")))
(write-region (point-min) (point-max) patchfile
nil 'silent)
(unwind-protect
(with-current-buffer orig-buffer
(with-output-to-string
(vc-git-command standard-output 0
patchfile
"apply" "--cached" ))
(setq success t))
(delete-file patchfile))))
(setq success (diff-hl-stage-diff orig-buffer)))
(when success
(if diff-hl-show-staged-changes
(message (concat "Hunk staged; customize `diff-hl-show-staged-changes'"
@@ -773,6 +824,85 @@ Only supported with Git."
(unless diff-hl-show-staged-changes
(diff-hl-update)))
(defun diff-hl-stage-dwim (&optional with-edit)
"Stage the current hunk or choose the hunks to stage.
When called with the prefix argument, invokes `diff-hl-stage-some'."
(interactive "P")
(if (or with-edit (region-active-p))
(call-interactively #'diff-hl-stage-some)
(call-interactively #'diff-hl-stage-current-hunk)))
(defvar diff-hl-stage--orig nil)
(define-derived-mode diff-hl-stage-diff-mode diff-mode "Stage Diff"
"Major mode for editing a diff buffer before staging.
\\[diff-hl-stage-commit]"
(setq revert-buffer-function #'ignore))
(define-key diff-hl-stage-diff-mode-map (kbd "C-c C-c") #'diff-hl-stage-finish)
(defun diff-hl-stage-some (&optional beg end)
"Stage some or all of the current changes, interactively.
Pops up a diff buffer that can be edited to choose the changes to stage."
(interactive "r")
(diff-hl--ensure-staging-supported)
(let* ((line-beg (and beg (line-number-at-pos beg t)))
(line-end (and end (line-number-at-pos end t)))
(file buffer-file-name)
(dest-buffer (get-buffer-create "*diff-hl-stage-some*"))
(orig-buffer (current-buffer))
;; FIXME: If the file name has double quotes, these need to be quoted.
(file-base (file-name-nondirectory file)))
(with-current-buffer dest-buffer
(let ((inhibit-read-only t))
(erase-buffer)))
(diff-hl-diff-buffer-with-reference file dest-buffer nil 3)
(with-current-buffer dest-buffer
(let ((inhibit-read-only t))
(when end
(with-no-warnings
(let (diff-auto-refine-mode)
(diff-hl-diff-skip-to line-end)
(diff-hl-split-away-changes 3)
(diff-end-of-hunk)))
(delete-region (point) (point-max)))
(if beg
(with-no-warnings
(let (diff-auto-refine-mode)
(diff-hl-diff-skip-to line-beg)
(diff-hl-split-away-changes 3)
(diff-beginning-of-hunk)))
(goto-char (point-min))
(forward-line 3))
(delete-region (point-min) (point))
;; diff-no-select creates a very ugly header; Git rejects it
(insert (format "diff a/%s b/%s\n" file-base file-base))
(insert (format "--- a/%s\n" file-base))
(insert (format "+++ b/%s\n" file-base)))
(let ((diff-default-read-only t))
(diff-hl-stage-diff-mode))
(setq-local diff-hl-stage--orig orig-buffer))
(pop-to-buffer dest-buffer)
(message "Press %s and %s to navigate, %s to split, %s to kill hunk, %s to undo, and %s to stage the diff after editing"
(substitute-command-keys "\\`n'")
(substitute-command-keys "\\`p'")
(substitute-command-keys "\\[diff-split-hunk]")
(substitute-command-keys "\\[diff-hunk-kill]")
(substitute-command-keys "\\[diff-undo]")
(substitute-command-keys "\\[diff-hl-stage-finish]"))))
(defun diff-hl-stage-finish ()
(interactive)
(let ((count 0))
(when (diff-hl-stage-diff diff-hl-stage--orig)
(save-excursion
(goto-char (point-min))
(while (re-search-forward diff-hunk-header-re-unified nil t)
(cl-incf count)))
(message "Staged %d hunks" count)
(bury-buffer))))
(defvar diff-hl-command-map
(let ((map (make-sparse-keymap)))
(define-key map "n" 'diff-hl-revert-hunk)
@@ -781,7 +911,7 @@ Only supported with Git."
(define-key map "*" 'diff-hl-show-hunk)
(define-key map "{" 'diff-hl-show-hunk-previous)
(define-key map "}" 'diff-hl-show-hunk-next)
(define-key map "S" 'diff-hl-stage-current-hunk)
(define-key map "S" 'diff-hl-stage-dwim)
map))
(fset 'diff-hl-command-map diff-hl-command-map)
@@ -827,7 +957,7 @@ The value of this variable is a mode line template as in
(remove-hook 'after-save-hook 'diff-hl-update t)
(remove-hook 'after-change-functions 'diff-hl-edit t)
(remove-hook 'find-file-hook 'diff-hl-update t)
(remove-hook 'after-revert-hook 'diff-hl-update t)
(remove-hook 'after-revert-hook 'diff-hl-after-revert t)
(remove-hook 'magit-revert-buffer-hook 'diff-hl-update t)
(remove-hook 'magit-not-reverted-hook 'diff-hl-update t)
(remove-hook 'text-scale-mode-hook 'diff-hl-maybe-redefine-bitmaps t)
@@ -871,49 +1001,38 @@ The value of this variable is a mode line template as in
diff-hl-command-map)
(declare-function magit-toplevel "magit-git")
(declare-function magit-unstaged-files "magit-git")
(declare-function magit-git-items "magit-git")
(defvar diff-hl--magit-unstaged-files nil)
(defun diff-hl-magit-pre-refresh ()
(unless (and diff-hl-disable-on-remote
(file-remote-p default-directory))
(setq diff-hl--magit-unstaged-files (magit-unstaged-files t))))
(define-obsolete-function-alias 'diff-hl-magit-pre-refresh 'ignore "1.11.0")
(defun diff-hl-magit-post-refresh ()
(unless (and diff-hl-disable-on-remote
(file-remote-p default-directory))
(let* ((topdir (magit-toplevel))
(modified-files
(mapcar (lambda (file) (expand-file-name file topdir))
(delete-consecutive-dups
(sort
(nconc (magit-unstaged-files t)
diff-hl--magit-unstaged-files)
#'string<))))
(unmodified-states '(up-to-date ignored unregistered)))
(setq diff-hl--magit-unstaged-files nil)
(dolist (buf (buffer-list))
(when (and (buffer-local-value 'diff-hl-mode buf)
(not (buffer-modified-p buf))
;; Solve the "cloned indirect buffer" problem
;; (diff-hl-mode could be non-nil there, even if
;; buffer-file-name is nil):
(buffer-file-name buf)
(file-in-directory-p (buffer-file-name buf) topdir)
(file-exists-p (buffer-file-name buf)))
(with-current-buffer buf
(let* ((file buffer-file-name)
(backend (vc-backend file)))
(when backend
(cond
((member file modified-files)
(when (memq (vc-state file) unmodified-states)
(vc-state-refresh file backend))
(diff-hl-update))
((not (memq (vc-state file backend) unmodified-states))
(vc-state-refresh file backend)
(diff-hl-update)))))))))))
(let* ((topdir (magit-toplevel))
(modified-files
(magit-git-items "diff-tree" "-z" "--name-only" "-r" "HEAD~" "HEAD"))
(unmodified-states '(up-to-date ignored unregistered)))
(dolist (buf (buffer-list))
(when (and (buffer-local-value 'diff-hl-mode buf)
(not (buffer-modified-p buf))
;; Solve the "cloned indirect buffer" problem
;; (diff-hl-mode could be non-nil there, even if
;; buffer-file-name is nil):
(buffer-file-name buf)
(file-in-directory-p (buffer-file-name buf) topdir)
(file-exists-p (buffer-file-name buf)))
(with-current-buffer buf
(let* ((file buffer-file-name)
(backend (vc-backend file)))
(when backend
(cond
((member file modified-files)
(when (memq (vc-state file) unmodified-states)
(vc-state-refresh file backend))
(diff-hl-update))
((not (memq (vc-state file backend) unmodified-states))
(vc-state-refresh file backend)
(diff-hl-update)))))))))))
(defun diff-hl-dir-update ()
(dolist (pair (if (vc-dir-marked-files)
@@ -988,7 +1107,7 @@ CONTEXT-LINES is the size of the unified diff context, defaults to 0."
(let* ((dest-buffer (or dest-buffer "*diff-hl-diff-buffer-with-reference*"))
(backend (or backend (vc-backend file)))
(temporary-file-directory
(if (file-directory-p "/dev/shm/")
(if (and (eq system-type 'gnu/linux) (file-directory-p "/dev/shm/"))
"/dev/shm/"
temporary-file-directory))
(rev
@@ -1000,7 +1119,7 @@ CONTEXT-LINES is the size of the unified diff context, defaults to 0."
(diff-hl-git-index-object-name file))
(diff-hl-create-revision
file
(or diff-hl-reference-revision
(or (diff-hl-resolved-reference-revision backend)
(diff-hl-working-revision file backend)))))
(switches (format "-U %d --strip-trailing-cr" (or context-lines 0))))
(diff-no-select rev (current-buffer) switches 'noasync
@@ -1011,18 +1130,34 @@ CONTEXT-LINES is the size of the unified diff context, defaults to 0."
(delete-matching-lines "^Diff finished.*")))
(get-buffer-create dest-buffer))))
(defun diff-hl-resolved-reference-revision (backend)
(cond
((null diff-hl-reference-revision)
nil)
((eq backend 'Git)
(vc-git--rev-parse diff-hl-reference-revision))
((eq backend 'Hg)
(with-temp-buffer
(vc-hg-command (current-buffer) 0 nil
"identify" "-r" diff-hl-reference-revision
"-i")
(goto-char (point-min))
(buffer-substring-no-properties (point) (line-end-position))))
(t
diff-hl-reference-revision)))
;; TODO: Cache based on .git/index's mtime, maybe.
(defun diff-hl-git-index-object-name (file)
(with-temp-buffer
(vc-git-command (current-buffer) 0 file "ls-files" "-s")
(and
(goto-char (point-min))
(re-search-forward "^[0-9]+ \\([0-9a-f]+\\)")
(re-search-forward "^[0-9]+ \\([0-9a-f]+\\)" nil t)
(match-string-no-properties 1))))
(defun diff-hl-git-index-revision (file object-name)
(let ((filename (diff-hl-make-temp-file-name file
(concat ":" object-name)
(concat ";" object-name)
'manual))
(filebuf (get-file-buffer file)))
(unless (file-exists-p filename)
lisp/emacsql-sqlite-builtin/emacsql-sqlite-builtin-pkg.el
+4 -8
View File
@@ -1,13 +1,9 @@
(define-package "emacsql-sqlite-builtin" "20230409.1847" "EmacSQL back-end for SQLite using builtin support"
'((emacs "29")
(emacsql "20230220"))
:commit "f25de357fee74aae7a538e8eae3d9be5eb55c20e" :authors
'(("Jonas Bernoulli" . "jonas@bernoul.li"))
(define-package "emacsql-sqlite-builtin" "20250220.1155" "EmacSQL back-end for SQLite using builtin support" 'nil :commit "b868ee6bda90022379730432610f040c62882064" :authors
'(("Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev"))
:maintainers
'(("Jonas Bernoulli" . "jonas@bernoul.li"))
'(("Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev"))
:maintainer
'("Jonas Bernoulli" . "jonas@bernoul.li")
:url "https://github.com/magit/emacsql")
'("Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev"))
;; Local Variables:
;; no-byte-compile: t
;; End:
lisp/emacsql-sqlite-builtin/emacsql-sqlite-builtin.el
+18 -19
View File
@@ -2,11 +2,9 @@
;; This is free and unencumbered software released into the public domain.
;; Author: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/emacsql
;; Author: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Package-Version: 3.1.1.50-git
;; Package-Requires: ((emacs "29") (emacsql "20230220"))
;; SPDX-License-Identifier: Unlicense
;;; Commentary:
@@ -16,8 +14,7 @@
;;; Code:
(require 'emacsql)
(require 'emacsql-sqlite-common)
(require 'emacsql-sqlite)
(require 'sqlite nil t)
(declare-function sqlite-open "sqlite")
@@ -33,10 +30,8 @@
((connection emacsql-sqlite-builtin-connection) &rest _)
(require (quote sqlite))
(oset connection handle
(sqlite-open (slot-value connection 'file)))
(when emacsql-global-timeout
(emacsql connection [:pragma (= busy-timeout $s1)]
(/ (* emacsql-global-timeout 1000) 2)))
(sqlite-open (oref connection file)))
(emacsql-sqlite-set-busy-timeout connection)
(emacsql connection [:pragma (= foreign-keys on)])
(emacsql-register connection))
@@ -45,7 +40,7 @@
If FILE is nil use an in-memory database.
:debug LOG -- When non-nil, log all SQLite commands to a log
buffer. This is for debugging purposes."
buffer. This is for debugging purposes."
(let ((connection (make-instance #'emacsql-sqlite-builtin-connection
:file file)))
(when debug
@@ -62,14 +57,18 @@ buffer. This is for debugging purposes."
(cl-defmethod emacsql-send-message
((connection emacsql-sqlite-builtin-connection) message)
(condition-case err
(mapcar (lambda (row)
(mapcar (lambda (col)
(cond ((null col) nil)
((equal col "") "")
((numberp col) col)
(t (read col))))
row))
(sqlite-select (oref connection handle) message nil nil))
(let ((headerp emacsql-include-header))
(mapcar (lambda (row)
(cond
(headerp (setq headerp nil) row)
((mapcan (lambda (col)
(cond ((null col) (list nil))
((equal col "") (list ""))
((numberp col) (list col))
((emacsql-sqlite-read-column col))))
row))))
(sqlite-select (oref connection handle) message nil
(and emacsql-include-header 'full))))
((sqlite-error sqlite-locked-error)
(if (stringp (cdr err))
(signal 'emacsql-error (list (cdr err)))
lisp/emacsql-sqlite/emacsql-sqlite-pkg.el
+4 -8
View File
@@ -1,13 +1,9 @@
(define-package "emacsql-sqlite" "20230225.2205" "EmacSQL back-end for SQLite"
'((emacs "25.1")
(emacsql "20230220"))
:commit "b436adf09ebe058c28e0f473bed90ccd7084f6aa" :authors
'(("Christopher Wellons" . "wellons@nullprogram.com"))
(define-package "emacsql-sqlite" "20250223.1743" "Code used by multiple SQLite back-ends" 'nil :commit "e4f1dcae91f91c5fa6dc1b0097a6c524e98fdf2b" :authors
'(("Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev"))
:maintainers
'(("Jonas Bernoulli" . "jonas@bernoul.li"))
'(("Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev"))
:maintainer
'("Jonas Bernoulli" . "jonas@bernoul.li")
:url "https://github.com/magit/emacsql")
'("Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev"))
;; Local Variables:
;; no-byte-compile: t
;; End:
lisp/emacsql-sqlite/emacsql-sqlite.el
+257 -144
View File
@@ -1,182 +1,295 @@
;;; emacsql-sqlite.el --- EmacSQL back-end for SQLite -*- lexical-binding:t -*-
;;; emacsql-sqlite.el --- Code used by multiple SQLite back-ends -*- lexical-binding:t -*-
;; This is free and unencumbered software released into the public domain.
;; Author: Christopher Wellons <wellons@nullprogram.com>
;; Maintainer: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/emacsql
;; Author: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Package-Version: 3.1.1.50-git
;; Package-Requires: ((emacs "25.1") (emacsql "20230220"))
;; SPDX-License-Identifier: Unlicense
;;; Commentary:
;; This library provides the original EmacSQL back-end for SQLite,
;; which uses a custom binary for communicating with a SQLite database.
;; During package installation an attempt is made to compile the binary.
;; This library contains code that is used by multiple SQLite back-ends.
;;; Code:
(require 'emacsql)
(require 'emacsql-sqlite-common)
(emacsql-register-reserved emacsql-sqlite-reserved)
;;; Base class
;;; SQLite connection
(defclass emacsql--sqlite-base (emacsql-connection)
((file :initarg :file
:initform nil
:type (or null string)
:documentation "Database file name.")
(types :allocation :class
:reader emacsql-types
:initform '((integer "INTEGER")
(float "REAL")
(object "TEXT")
(nil nil))))
:abstract t)
(defvar emacsql-sqlite-data-root
(file-name-directory (or load-file-name buffer-file-name))
"Directory where EmacSQL is installed.")
;;; Constants
(defvar emacsql-sqlite-executable-path
(if (memq system-type '(windows-nt cygwin ms-dos))
"sqlite/emacsql-sqlite.exe"
"sqlite/emacsql-sqlite")
"Relative path to emacsql executable.")
(defconst emacsql-sqlite-reserved
'( ABORT ACTION ADD AFTER ALL ALTER ANALYZE AND AS ASC ATTACH
AUTOINCREMENT BEFORE BEGIN BETWEEN BY CASCADE CASE CAST CHECK
COLLATE COLUMN COMMIT CONFLICT CONSTRAINT CREATE CROSS
CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP DATABASE DEFAULT
DEFERRABLE DEFERRED DELETE DESC DETACH DISTINCT DROP EACH ELSE END
ESCAPE EXCEPT EXCLUSIVE EXISTS EXPLAIN FAIL FOR FOREIGN FROM FULL
GLOB GROUP HAVING IF IGNORE IMMEDIATE IN INDEX INDEXED INITIALLY
INNER INSERT INSTEAD INTERSECT INTO IS ISNULL JOIN KEY LEFT LIKE
LIMIT MATCH NATURAL NO NOT NOTNULL NULL OF OFFSET ON OR ORDER
OUTER PLAN PRAGMA PRIMARY QUERY RAISE RECURSIVE REFERENCES REGEXP
REINDEX RELEASE RENAME REPLACE RESTRICT RIGHT ROLLBACK ROW
SAVEPOINT SELECT SET TABLE TEMP TEMPORARY THEN TO TRANSACTION
TRIGGER UNION UNIQUE UPDATE USING VACUUM VALUES VIEW VIRTUAL WHEN
WHERE WITH WITHOUT)
"List of all of SQLite's reserved words.
Also see http://www.sqlite.org/lang_keywords.html.")
(defvar emacsql-sqlite-executable
(expand-file-name emacsql-sqlite-executable-path
(if (or (file-writable-p emacsql-sqlite-data-root)
(file-exists-p (expand-file-name
emacsql-sqlite-executable-path
emacsql-sqlite-data-root)))
emacsql-sqlite-data-root
(expand-file-name
(concat "emacsql/" emacsql-version)
user-emacs-directory)))
"Path to the EmacSQL backend (this is not the sqlite3 shell).")
(defconst emacsql-sqlite-error-codes
'((1 SQLITE_ERROR emacsql-error "SQL logic error")
(2 SQLITE_INTERNAL emacsql-internal nil)
(3 SQLITE_PERM emacsql-access "access permission denied")
(4 SQLITE_ABORT emacsql-error "query aborted")
(5 SQLITE_BUSY emacsql-locked "database is locked")
(6 SQLITE_LOCKED emacsql-locked "database table is locked")
(7 SQLITE_NOMEM emacsql-memory "out of memory")
(8 SQLITE_READONLY emacsql-access "attempt to write a readonly database")
(9 SQLITE_INTERRUPT emacsql-error "interrupted")
(10 SQLITE_IOERR emacsql-access "disk I/O error")
(11 SQLITE_CORRUPT emacsql-corruption "database disk image is malformed")
(12 SQLITE_NOTFOUND emacsql-error "unknown operation")
(13 SQLITE_FULL emacsql-access "database or disk is full")
(14 SQLITE_CANTOPEN emacsql-access "unable to open database file")
(15 SQLITE_PROTOCOL emacsql-access "locking protocol")
(16 SQLITE_EMPTY emacsql-corruption nil)
(17 SQLITE_SCHEMA emacsql-error "database schema has changed")
(18 SQLITE_TOOBIG emacsql-error "string or blob too big")
(19 SQLITE_CONSTRAINT emacsql-constraint "constraint failed")
(20 SQLITE_MISMATCH emacsql-error "datatype mismatch")
(21 SQLITE_MISUSE emacsql-error "bad parameter or other API misuse")
(22 SQLITE_NOLFS emacsql-error "large file support is disabled")
(23 SQLITE_AUTH emacsql-access "authorization denied")
(24 SQLITE_FORMAT emacsql-corruption nil)
(25 SQLITE_RANGE emacsql-error "column index out of range")
(26 SQLITE_NOTADB emacsql-corruption "file is not a database")
(27 SQLITE_NOTICE emacsql-warning "notification message")
(28 SQLITE_WARNING emacsql-warning "warning message"))
"Alist mapping SQLite error codes to EmacSQL conditions.
Elements have the form (ERRCODE SYMBOLIC-NAME EMACSQL-ERROR
ERRSTR). Also see https://www.sqlite.org/rescode.html.")
(defvar emacsql-sqlite-c-compilers '("cc" "gcc" "clang")
"List of names to try when searching for a C compiler.
;;; Variables
Each is queried using `executable-find', so full paths are
allowed. Only the first compiler which is successfully found will
used.")
(defvar emacsql-include-header nil
"Whether to include names of columns as an additional row.
Never enable this globally, only let-bind it around calls to `emacsql'.
Currently only supported by `emacsql-sqlite-builtin-connection' and
`emacsql-sqlite-module-connection'.")
(defclass emacsql-sqlite-connection
(emacsql--sqlite-base emacsql-protocol-mixin) ()
"A connection to a SQLite database.")
(defvar emacsql-sqlite-busy-timeout 20
"Seconds to wait when trying to access a table blocked by another process.
See https://www.sqlite.org/c3ref/busy_timeout.html.")
(cl-defmethod initialize-instance :after
((connection emacsql-sqlite-connection) &rest _rest)
(emacsql-sqlite-ensure-binary)
(let* ((process-connection-type nil) ; use a pipe
;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=60872#11.
(coding-system-for-write 'utf-8)
(coding-system-for-read 'utf-8)
(file (slot-value connection 'file))
(buffer (generate-new-buffer " *emacsql-sqlite*"))
(fullfile (if file (expand-file-name file) ":memory:"))
(process (start-process
"emacsql-sqlite" buffer emacsql-sqlite-executable fullfile)))
(oset connection handle process)
(set-process-sentinel process
(lambda (proc _) (kill-buffer (process-buffer proc))))
(when (memq (process-status process) '(exit signal))
(error "%s has failed immediately" emacsql-sqlite-executable))
(emacsql-wait connection)
(emacsql connection [:pragma (= busy-timeout $s1)]
(/ (* emacsql-global-timeout 1000) 2))
(emacsql-register connection)))
;;; Utilities
(cl-defun emacsql-sqlite (file &key debug)
"Open a connected to database stored in FILE.
If FILE is nil use an in-memory database.
(defun emacsql-sqlite-connection (variable file &optional setup use-module)
"Return the connection stored in VARIABLE to the database in FILE.
:debug LOG -- When non-nil, log all SQLite commands to a log
buffer. This is for debugging purposes."
(let ((connection (make-instance 'emacsql-sqlite-connection :file file)))
(set-process-query-on-exit-flag (oref connection handle) nil)
If the value of VARIABLE is a live database connection, return that.
Otherwise open a new connection to the database in FILE and store the
connection in VARIABLE, before returning it. If FILE is nil, use an
in-memory database. Always enable support for foreign key constrains.
If optional SETUP is non-nil, it must be a function, which takes the
connection as only argument. This function can be used to initialize
tables, for example.
If optional USE-MODULE is non-nil, then use the external module even
when Emacs was built with SQLite support. This is intended for testing
purposes."
(or (let ((connection (symbol-value variable)))
(and connection (emacsql-live-p connection) connection))
(set variable (emacsql-sqlite-open file nil setup use-module))))
(defun emacsql-sqlite-open (file &optional debug setup use-module)
"Open a connection to the database stored in FILE using an SQLite back-end.
Automatically use the best available back-end, as returned by
`emacsql-sqlite-default-connection'.
If FILE is nil, use an in-memory database. If optional DEBUG is
non-nil, log all SQLite commands to a log buffer, for debugging
purposes. Always enable support for foreign key constrains.
If optional SETUP is non-nil, it must be a function, which takes the
connection as only argument. This function can be used to initialize
tables, for example.
If optional USE-MODULE is non-nil, then use the external module even
when Emacs was built with SQLite support. This is intended for testing
purposes."
(when file
(make-directory (file-name-directory file) t))
(let* ((class (emacsql-sqlite-default-connection use-module))
(connection (make-instance class :file file)))
(when debug
(emacsql-enable-debugging connection))
(emacsql connection [:pragma (= foreign-keys on)])
(when setup
(funcall setup connection))
connection))
(cl-defmethod emacsql-close ((connection emacsql-sqlite-connection))
"Gracefully exits the SQLite subprocess."
(let ((process (oref connection handle)))
(when (process-live-p process)
(process-send-eof process))))
(defun emacsql-sqlite-default-connection (&optional use-module)
"Determine and return the best SQLite connection class.
(cl-defmethod emacsql-send-message ((connection emacsql-sqlite-connection) message)
(let ((process (oref connection handle)))
(process-send-string process (format "%d " (string-bytes message)))
(process-send-string process message)
(process-send-string process "\n")))
Signal an error if none of the connection classes can be used.
(cl-defmethod emacsql-handle ((_ emacsql-sqlite-connection) errcode errmsg)
"Get condition for ERRCODE and ERRMSG provided from SQLite."
(pcase-let ((`(,_ ,_ ,signal ,errstr)
(assq errcode emacsql-sqlite-error-codes)))
(signal (or signal 'emacsql-error)
(list errmsg errcode nil errstr))))
If optional USE-MODULE is non-nil, then use the external module even
when Emacs was built with SQLite support. This is intended for testing
purposes."
(or (and (not use-module)
(fboundp 'sqlite-available-p)
(sqlite-available-p)
(require 'emacsql-sqlite-builtin)
'emacsql-sqlite-builtin-connection)
(and (boundp 'module-file-suffix)
module-file-suffix
(condition-case nil
;; Failure modes:
;; 1. `libsqlite' shared library isn't available.
;; 2. User chooses to not compile `libsqlite'.
;; 3. `libsqlite' compilation fails.
(and (require 'sqlite3)
(require 'emacsql-sqlite-module)
'emacsql-sqlite-module-connection)
(error
(display-warning 'emacsql "\
Since your Emacs does not come with
built-in SQLite support [1], but does support C modules, we can
use an EmacSQL backend that relies on the third-party `sqlite3'
package [2].
;;; SQLite compilation
Please install the `sqlite3' Elisp package using your preferred
Emacs package manager, and install the SQLite shared library
using your distribution's package manager. That package should
be named something like `libsqlite3' [3] and NOT just `sqlite3'.
(defun emacsql-sqlite-compile-switches ()
"Return the compilation switches from the Makefile under sqlite/."
(let ((makefile (expand-file-name "sqlite/Makefile" emacsql-sqlite-data-root))
(case-fold-search nil))
(with-temp-buffer
(insert-file-contents makefile)
(goto-char (point-min))
(cl-loop while (re-search-forward "-D[A-Z0-9_=]+" nil :no-error)
collect (match-string 0)))))
The legacy backend, which uses a custom SQLite executable, has
been remove, so we can no longer fall back to that.
(defun emacsql-sqlite-compile (&optional o-level async error)
"Compile the SQLite back-end for EmacSQL, returning non-nil on success.
If called with non-nil ASYNC, the return value is meaningless.
If called with non-nil ERROR, signal an error on failure."
(let* ((cc (cl-loop for option in emacsql-sqlite-c-compilers
for path = (executable-find option)
if path return it))
(src (expand-file-name "sqlite" emacsql-sqlite-data-root))
(files (mapcar (lambda (f) (expand-file-name f src))
'("sqlite3.c" "emacsql.c")))
(cflags (list (format "-I%s" src) (format "-O%d" (or o-level 2))))
(ldlibs (cl-case system-type
(windows-nt (list))
(berkeley-unix (list "-lm"))
(otherwise (list "-lm" "-ldl"))))
(options (emacsql-sqlite-compile-switches))
(output (list "-o" emacsql-sqlite-executable))
(arguments (nconc cflags options files ldlibs output)))
[1]: Supported since Emacs 29.1, provided it was not disabled
with `--without-sqlite3'.
[2]: https://github.com/pekingduck/emacs-sqlite3-api
[3]: On Debian https://packages.debian.org/buster/libsqlite3-0")
;; The buffer displaying the warning might immediately
;; be replaced by another buffer, before the user gets
;; a chance to see it. We cannot have that.
(let (fn)
(setq fn (lambda ()
(remove-hook 'post-command-hook fn)
(pop-to-buffer (get-buffer "*Warnings*"))))
(add-hook 'post-command-hook fn))
nil)))
(error "EmacSQL could not find or compile a back-end")))
(defun emacsql-sqlite-set-busy-timeout (connection)
(when emacsql-sqlite-busy-timeout
(emacsql connection [:pragma (= busy-timeout $s1)]
(* emacsql-sqlite-busy-timeout 1000))))
(defun emacsql-sqlite-read-column (string)
(let ((value nil)
(beg 0)
(end (length string)))
(while (< beg end)
(let ((v (read-from-string string beg)))
(push (car v) value)
(setq beg (cdr v))))
(nreverse value)))
(defun emacsql-sqlite-list-tables (connection)
"Return a list of symbols identifying tables in CONNECTION.
Tables whose names begin with \"sqlite_\", are not included
in the returned value."
(mapcar #'car
(emacsql connection
[:select name
;; The new name is `sqlite-schema', but this name
;; is supported by old and new SQLite versions.
;; See https://www.sqlite.org/schematab.html.
:from sqlite-master
:where (and (= type 'table)
(not-like name "sqlite_%"))
:order-by [(asc name)]])))
(defun emacsql-sqlite-dump-database (connection &optional versionp)
"Dump the database specified by CONNECTION to a file.
The dump file is placed in the same directory as the database
file and its name derives from the name of the database file.
The suffix is replaced with \".sql\" and if optional VERSIONP is
non-nil, then the database version (the `user_version' pragma)
and a timestamp are appended to the file name.
Dumping is done using the official `sqlite3' binary. If that is
not available and VERSIONP is non-nil, then the database file is
copied instead."
(let* ((version (caar (emacsql connection [:pragma user-version])))
(db (oref connection file))
(db (if (symbolp db) (symbol-value db) db))
(name (file-name-nondirectory db))
(output (concat (file-name-sans-extension db)
(and versionp
(concat (format "-v%s" version)
(format-time-string "-%Y%m%d-%H%M")))
".sql")))
(cond
((not cc)
(funcall (if error #'error #'message)
"Could not find C compiler, skipping SQLite build")
nil)
(t
(message "Compiling EmacSQL SQLite binary...")
(mkdir (file-name-directory emacsql-sqlite-executable) t)
(let ((log (get-buffer-create byte-compile-log-buffer)))
(with-current-buffer log
(let ((inhibit-read-only t))
(insert (mapconcat #'identity (cons cc arguments) " ") "\n")
(let ((pos (point))
(ret (apply #'call-process cc nil (if async 0 t) t
arguments)))
(cond
((zerop ret)
(message "Compiling EmacSQL SQLite binary...done")
t)
((and error (not async))
(error "Cannot compile EmacSQL SQLite binary: %S"
(replace-regexp-in-string
"\n" " "
(buffer-substring-no-properties
pos (point-max))))))))))))))
((locate-file "sqlite3" exec-path)
(when (and (file-exists-p output) versionp)
(error "Cannot dump database; %s already exists" output))
(with-temp-file output
(message "Dumping %s database to %s..." name output)
(unless (zerop (save-excursion
(call-process "sqlite3" nil t nil db ".dump")))
(error "Failed to dump %s" db))
(when version
(insert (format "PRAGMA user_version=%s;\n" version)))
;; The output contains "PRAGMA foreign_keys=OFF;".
;; Change that to avoid alarming attentive users.
(when (re-search-forward "^PRAGMA foreign_keys=\\(OFF\\);" 1000 t)
(replace-match "ON" t t nil 1))
(message "Dumping %s database to %s...done" name output)))
(versionp
(setq output (concat (file-name-sans-extension output) ".db"))
(message "Cannot dump database because sqlite3 binary cannot be found")
(when (and (file-exists-p output) versionp)
(error "Cannot copy database; %s already exists" output))
(message "Copying %s database to %s..." name output)
(copy-file db output)
(message "Copying %s database to %s...done" name output))
((error "Cannot dump database; sqlite3 binary isn't available")))))
;;; Ensure the SQLite binary is available
(defun emacsql-sqlite-restore-database (db dump)
"Restore database DB from DUMP.
(defun emacsql-sqlite-ensure-binary ()
"Ensure the EmacSQL SQLite binary is available, signaling an error if not."
(unless (file-exists-p emacsql-sqlite-executable)
;; Try compiling at the last minute.
(condition-case err
(emacsql-sqlite-compile 2 nil t)
(error (error "No EmacSQL SQLite binary available: %s" (cdr err))))))
DUMP is a file containing SQL statements. DB can be the file
in which the database is to be stored, or it can be a database
connection. In the latter case the current database is first
dumped to a new file and the connection is closed. Then the
database is restored from DUMP. No connection to the new
database is created."
(unless (stringp db)
(emacsql-sqlite-dump-database db t)
(emacsql-close (prog1 db (setq db (oref db file)))))
(with-temp-buffer
(unless (zerop (call-process "sqlite3" nil t nil db
(format ".read %s" dump)))
(error "Failed to read %s: %s" dump (buffer-string)))))
(provide 'emacsql-sqlite)
lisp/emacsql-sqlite/sqlite/Makefile
-19
View File
@@ -1,19 +0,0 @@
-include ../.config.mk
.POSIX:
LDLIBS = -ldl -lm
CFLAGS = -O2 -Wall -Wextra -Wno-implicit-fallthrough \
-DSQLITE_THREADSAFE=0 \
-DSQLITE_DEFAULT_FOREIGN_KEYS=1 \
-DSQLITE_ENABLE_FTS5 \
-DSQLITE_ENABLE_FTS4 \
-DSQLITE_ENABLE_FTS3_PARENTHESIS \
-DSQLITE_ENABLE_RTREE \
-DSQLITE_ENABLE_JSON1 \
-DSQLITE_SOUNDEX
emacsql-sqlite: emacsql.c sqlite3.c
$(CC) $(CFLAGS) $(LDFLAGS) -o $@ emacsql.c sqlite3.c $(LDLIBS)
clean:
rm -f emacsql-sqlite
lisp/emacsql-sqlite/sqlite/emacsql.c
-183
View File
@@ -1,183 +0,0 @@
/* This is free and unencumbered software released into the public domain. */
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "sqlite3.h"
#define TRUE 1
#define FALSE 0
char* escape(const char *message) {
int i, count = 0, length_orig = strlen(message);
for (i = 0; i < length_orig; i++) {
if (strchr("\"\\", message[i])) {
count++;
}
}
char *copy = malloc(length_orig + count + 1);
char *p = copy;
while (*message) {
if (strchr("\"\\", *message)) {
*p = '\\';
p++;
}
*p = *message;
message++;
p++;
}
*p = '\0';
return copy;
}
void send_error(int code, const char *message) {
char *escaped = escape(message);
printf("error %d \"%s\"\n", code, escaped);
free(escaped);
}
typedef struct {
char *buffer;
size_t size;
} buffer;
buffer* buffer_create() {
buffer *buffer = malloc(sizeof(*buffer));
buffer->size = 4096;
buffer->buffer = malloc(buffer->size * sizeof(char));
return buffer;
}
int buffer_grow(buffer *buffer) {
unsigned factor = 2;
char *newbuffer = realloc(buffer->buffer, buffer->size * factor);
if (newbuffer == NULL) {
return FALSE;
}
buffer->buffer = newbuffer;
buffer->size *= factor;
return TRUE;
}
int buffer_read(buffer *buffer, size_t count) {
while (buffer->size < count + 1) {
if (buffer_grow(buffer) == FALSE) {
return FALSE;
}
}
size_t in = fread((void *) buffer->buffer, 1, count, stdin);
buffer->buffer[count] = '\0';
return in == count;
}
void buffer_free(buffer *buffer) {
free(buffer->buffer);
free(buffer);
}
int main(int argc, char **argv) {
char *file = NULL;
if (argc != 2) {
fprintf(stderr,
"error: require exactly one argument, the DB filename\n");
exit(EXIT_FAILURE);
} else {
file = argv[1];
}
/* On Windows stderr is not always unbuffered. */
#if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__)
setvbuf(stderr, NULL, _IONBF, 0);
#endif
sqlite3* db = NULL;
if (sqlite3_initialize() != SQLITE_OK) {
fprintf(stderr, "error: failed to initialize sqlite\n");
exit(EXIT_FAILURE);
}
int flags = SQLITE_OPEN_READWRITE | SQLITE_OPEN_CREATE;
if (sqlite3_open_v2(file, &db, flags, NULL) != SQLITE_OK) {
fprintf(stderr, "error: failed to open %s\n", file);
exit(EXIT_FAILURE);
}
buffer *input = buffer_create();
while (TRUE) {
printf("#\n");
fflush(stdout);
/* Gather input from Emacs. */
unsigned length;
int result = scanf("%u ", &length);
if (result == EOF) {
break;
} else if (result != 1) {
send_error(SQLITE_ERROR, "middleware parsing error");
break; /* stream out of sync: quit program */
}
if (!buffer_read(input, length)) {
send_error(SQLITE_NOMEM, "middleware out of memory");
continue;
}
/* Parse SQL statement. */
sqlite3_stmt *stmt = NULL;
result = sqlite3_prepare_v2(db, input->buffer, length, &stmt, NULL);
if (result != SQLITE_OK) {
send_error(sqlite3_errcode(db), sqlite3_errmsg(db));
continue;
}
/* Print out rows. */
int first = TRUE, ncolumns = sqlite3_column_count(stmt);
printf("(");
while (sqlite3_step(stmt) == SQLITE_ROW) {
if (first) {
printf("(");
first = FALSE;
} else {
printf("\n (");
}
int i;
for (i = 0; i < ncolumns; i++) {
if (i > 0) {
printf(" ");
}
int type = sqlite3_column_type(stmt, i);
switch (type) {
case SQLITE_INTEGER:
printf("%lld", sqlite3_column_int64(stmt, i));
break;
case SQLITE_FLOAT:
printf("%f", sqlite3_column_double(stmt, i));
break;
case SQLITE_NULL:
printf("nil");
break;
case SQLITE_TEXT:
fwrite(sqlite3_column_text(stmt, i), 1,
sqlite3_column_bytes(stmt, i), stdout);
break;
case SQLITE_BLOB:
printf("nil");
break;
}
}
printf(")");
}
printf(")\n");
if (sqlite3_finalize(stmt) != SQLITE_OK) {
/* Despite any error code, the statement is still freed.
* http://stackoverflow.com/a/8391872
*/
send_error(sqlite3_errcode(db), sqlite3_errmsg(db));
} else {
printf("success\n");
}
}
buffer_free(input);
sqlite3_close(db);
sqlite3_shutdown();
return EXIT_SUCCESS;
}
lisp/emacsql-sqlite/sqlite/sqlite3.c
-241687
View File
File diff suppressed because it is too large Load Diff
lisp/emacsql-sqlite/sqlite/sqlite3.h
-12836
View File
File diff suppressed because it is too large Load Diff
lisp/emacsql/emacsql-compiler.el
+59 -55
View File
@@ -1,17 +1,22 @@
;;; emacsql-compile.el --- S-expression SQL compiler -*- lexical-binding:t -*-
;;; emacsql-compiler.el --- S-expression SQL compiler -*- lexical-binding:t -*-
;; This is free and unencumbered software released into the public domain.
;; Author: Christopher Wellons <wellons@nullprogram.com>
;; Maintainer: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/emacsql
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; SPDX-License-Identifier: Unlicense
;;; Commentary:
;; This library provides support for compiling S-expressions to SQL.
;;; Code:
(require 'cl-lib)
(eval-when-compile (require 'subr-x))
;;; Error symbols
(defmacro emacsql-deferror (symbol parents message)
@@ -20,8 +25,8 @@
(let ((conditions (cl-remove-duplicates
(append parents (list symbol 'emacsql-error 'error)))))
`(prog1 ',symbol
(setf (get ',symbol 'error-conditions) ',conditions
(get ',symbol 'error-message) ,message))))
(put ',symbol 'error-conditions ',conditions)
(put ',symbol 'error-message ,message))))
(emacsql-deferror emacsql-error () ;; parent condition for all others
"EmacSQL had an unhandled condition")
@@ -121,7 +126,7 @@
(defun emacsql-escape-vector (vector)
"Encode VECTOR into a SQL vector scalar."
(cl-typecase vector
(null (emacsql-error "Empty SQL vector expression."))
(null (emacsql-error "Empty SQL vector expression"))
(list (mapconcat #'emacsql-escape-vector vector ", "))
(vector (concat "(" (mapconcat #'emacsql-escape-scalar vector ", ") ")"))
(otherwise (emacsql-error "Invalid vector %S" vector))))
@@ -145,7 +150,7 @@
(upcase (replace-regexp-in-string "-" " " name))))
(defun emacsql--prepare-constraints (constraints)
"Compile CONSTRAINTS into a partial SQL expresson."
"Compile CONSTRAINTS into a partial SQL expression."
(mapconcat
#'identity
(cl-loop for constraint in constraints collect
@@ -210,21 +215,21 @@
A parameter is a symbol that looks like $i1, $s2, $v3, etc. The
letter refers to the type: identifier (i), scalar (s),
vector (v), raw string (r), schema (S)."
(when (symbolp thing)
(let ((name (symbol-name thing)))
(when (string-match-p "^\\$[isvrS][0-9]+$" name)
(cons (1- (read (substring name 2)))
(cl-ecase (aref name 1)
(?i :identifier)
(?s :scalar)
(?v :vector)
(?r :raw)
(?S :schema)))))))
(and (symbolp thing)
(let ((name (symbol-name thing)))
(and (string-match-p "^\\$[isvrS][0-9]+$" name)
(cons (1- (read (substring name 2)))
(cl-ecase (aref name 1)
(?i :identifier)
(?s :scalar)
(?v :vector)
(?r :raw)
(?S :schema)))))))
(defmacro emacsql-with-params (prefix &rest body)
"Evaluate BODY, collecting parameters.
Provided local functions: `param', `identifier', `scalar', `raw',
`svector', `expr', `subsql', and `combine'. BODY should return a
`svector', `expr', `subsql', and `combine'. BODY should return a
string, which will be combined with variable definitions."
(declare (indent 1))
`(let ((emacsql--vars ()))
@@ -236,7 +241,7 @@ string, which will be combined with variable definitions."
(svector (thing) (combine (emacsql--*vector thing)))
(expr (thing) (combine (emacsql--*expr thing)))
(subsql (thing)
(format "(%s)" (combine (emacsql-prepare thing)))))
(format "(%s)" (combine (emacsql-prepare thing)))))
(cons (concat ,prefix (progn ,@body)) emacsql--vars))))
(defun emacsql--!param (thing &optional kind)
@@ -244,9 +249,9 @@ string, which will be combined with variable definitions."
If optional KIND is not specified, then try to guess it.
Only use within `emacsql-with-params'!"
(cl-flet ((check (param)
(when (and kind (not (eq kind (cdr param))))
(emacsql-error
"Invalid parameter type %s, expecting %s" thing kind))))
(when (and kind (not (eq kind (cdr param))))
(emacsql-error
"Invalid parameter type %s, expecting %s" thing kind))))
(let ((param (emacsql-param thing)))
(if (null param)
(emacsql-escape-format
@@ -264,7 +269,7 @@ Only use within `emacsql-with-params'!"
(emacsql-escape-scalar thing))))
(prog1 (if (eq (cdr param) :schema) "(%s)" "%s")
(check param)
(setf emacsql--vars (nconc emacsql--vars (list param))))))))
(setq emacsql--vars (nconc emacsql--vars (list param))))))))
(defun emacsql--*vector (vector)
"Prepare VECTOR."
@@ -275,23 +280,22 @@ Only use within `emacsql-with-params'!"
(vector (format "(%s)" (mapconcat #'scalar vector ", ")))
(otherwise (emacsql-error "Invalid vector: %S" vector)))))
(defmacro emacsql--generate-op-lookup-defun (name
operator-precedence-groups)
(defmacro emacsql--generate-op-lookup-defun (name operator-precedence-groups)
"Generate function to look up predefined SQL operator metadata.
The generated function is bound to NAME and accepts two
arguments, OPERATOR-NAME and OPERATOR-ARGUMENT-COUNT.
OPERATOR-PRECEDENCE-GROUPS should be a number of lists containing
operators grouped by operator precedence (in order of precedence
from highest to lowest). A single operator is represented by a
from highest to lowest). A single operator is represented by a
list of at least two elements: operator name (symbol) and
operator arity (:unary or :binary). Optionally a custom
operator arity (:unary or :binary). Optionally a custom
expression can be included, which defines how the operator is
expanded into an SQL expression (there are two defaults, one for
:unary and one for :binary operators).
An example for OPERATOR-PRECEDENCE-GROUPS:
(((+ :unary (\"+\" :operand)) (- :unary (\"-\" :operand)))
\(((+ :unary (\"+\" :operand)) (- :unary (\"-\" :operand)))
((+ :binary) (- :binary)))"
`(defun ,name (operator-name operator-argument-count)
"Look up predefined SQL operator metadata.
@@ -349,34 +353,34 @@ See `emacsql--generate-op-lookup-defun' for details."
"Create format-string for an SQL operator.
The format-string returned is intended to be used with `format'
to create an SQL expression."
(when expr
(cl-labels ((replace-operand (x) (if (eq x :operand)
"%s"
x))
(to-format-string (e) (mapconcat #'replace-operand e "")))
(cond
((and (eq arity :unary) (eql argument-count 1))
(to-format-string expr))
((and (eq arity :binary) (>= argument-count 2))
(let ((result (reverse expr)))
(dotimes (_ (- argument-count 2))
(setf result (nconc (reverse expr) (cdr result))))
(to-format-string (nreverse result))))
(t (emacsql-error "Wrong number of operands for %s" op))))))
(and expr
(cl-labels ((replace-operand (x) (if (eq x :operand) "%s" x))
(to-format-string (e) (mapconcat #'replace-operand e "")))
(cond
((and (eq arity :unary) (eql argument-count 1))
(to-format-string expr))
((and (eq arity :binary) (>= argument-count 2))
(let ((result (reverse expr)))
(dotimes (_ (- argument-count 2))
(setq result (nconc (reverse expr) (cdr result))))
(to-format-string (nreverse result))))
(t (emacsql-error "Wrong number of operands for %s" op))))))
(defun emacsql--get-op-info (op argument-count parent-precedence-value)
"Lookup SQL operator information for generating an SQL expression.
Returns the following multiple values when an operator can be
identified: a format string (see `emacsql--expand-format-string')
and a precedence value. If PARENT-PRECEDENCE-VALUE is greater or
and a precedence value. If PARENT-PRECEDENCE-VALUE is greater or
equal to the identified operator's precedence, then the format
string returned is wrapped with parentheses."
(cl-destructuring-bind (format-string arity precedence-value)
(emacsql--get-op op argument-count)
(let ((expanded-format-string (emacsql--expand-format-string op
format-string
arity
argument-count)))
(let ((expanded-format-string
(emacsql--expand-format-string
op
format-string
arity
argument-count)))
(cl-values (cond
((null format-string) nil)
((>= parent-precedence-value
@@ -397,10 +401,11 @@ string returned is wrapped with parentheses."
(emacsql--get-op-info op
(length args)
(or parent-precedence-value 0))
(cl-flet ((recur (n) (combine (emacsql--*expr (nth n args)
(or precedence-value 0))))
(cl-flet ((recur (n)
(combine (emacsql--*expr (nth n args)
(or precedence-value 0))))
(nops (op)
(emacsql-error "Wrong number of operands for %s" op)))
(emacsql-error "Wrong number of operands for %s" op)))
(cl-case op
;; Special cases <= >=
((<= >=)
@@ -466,7 +471,7 @@ string returned is wrapped with parentheses."
"Append parameters from PREPARED to `emacsql--vars', return the string.
Only use within `emacsql-with-params'!"
(cl-destructuring-bind (string . vars) prepared
(setf emacsql--vars (nconc emacsql--vars vars))
(setq emacsql--vars (nconc emacsql--vars vars))
string))
(defun emacsql-prepare--string (string)
@@ -506,9 +511,8 @@ Only use within `emacsql-with-params'!"
(emacsql-escape-format
(emacsql-escape-scalar item))))
into parts
do (setf last item)
finally (cl-return
(mapconcat #'identity parts " ")))))
do (setq last item)
finally (cl-return (string-join parts " ")))))
(defun emacsql-prepare (sql)
"Expand SQL (string or sexp) into a prepared statement."
@@ -539,4 +543,4 @@ Only use within `emacsql-with-params'!"
(provide 'emacsql-compiler)
;;; emacsql-compile.el ends here
;;; emacsql-compiler.el ends here
lisp/emacsql/emacsql-mysql.el
+2 -5
View File
@@ -3,11 +3,8 @@
;; This is free and unencumbered software released into the public domain.
;; Author: Christopher Wellons <wellons@nullprogram.com>
;; Maintainer: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/emacsql
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Package-Version: 3.1.1.50-git
;; Package-Requires: ((emacs "25.1") (emacsql "20230220"))
;; SPDX-License-Identifier: Unlicense
;;; Commentary:
@@ -126,7 +123,7 @@ http://dev.mysql.com/doc/refman/5.5/en/reserved-words.html")
collect (read) into row
when (looking-at "\n")
collect row into rows
and do (setf row ())
and do (setq row ())
and do (forward-char)
finally (cl-return rows)))))
lisp/emacsql/emacsql-pg.el
+6 -6
View File
@@ -3,17 +3,15 @@
;; This is free and unencumbered software released into the public domain.
;; Author: Christopher Wellons <wellons@nullprogram.com>
;; Maintainer: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/emacsql
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Package-Version: 3.1.1.50-git
;; Package-Requires: ((emacs "25.1") (emacsql "20230220") (pg "0.16"))
;; SPDX-License-Identifier: Unlicense
;;; Commentary:
;; This library provides an EmacSQL back-end for PostgreSQL, which
;; uses the `pg' package to directly speak to the database.
;; uses the `pg' package to directly speak to the database. This
;; library requires at least Emacs 28.1.
;; (For an alternative back-end for PostgreSQL, see `emacsql-psql'.)
@@ -21,7 +19,9 @@
(require 'emacsql)
(require 'pg nil t)
(if (>= emacs-major-version 28)
(require 'pg nil t)
(message "emacsql-pg.el requires Emacs 28.1 or later"))
(declare-function pg-connect "pg"
( dbname user &optional
(password "") (host "localhost") (port 5432) (tls nil)))
lisp/emacsql/emacsql-pkg.el
+5 -5
View File
@@ -1,11 +1,11 @@
(define-package "emacsql" "20230417.1448" "High-level SQL database front-end"
'((emacs "25.1"))
:commit "64012261f65fcdd7ea137d1973ef051af1dced42" :authors
(define-package "emacsql" "20250223.1743" "High-level SQL database front-end"
'((emacs "26.1"))
:commit "e4f1dcae91f91c5fa6dc1b0097a6c524e98fdf2b" :authors
'(("Christopher Wellons" . "wellons@nullprogram.com"))
:maintainers
'(("Jonas Bernoulli" . "jonas@bernoul.li"))
'(("Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev"))
:maintainer
'("Jonas Bernoulli" . "jonas@bernoul.li")
'("Jonas Bernoulli" . "emacs.emacsql@jonas.bernoulli.dev")
:url "https://github.com/magit/emacsql")
;; Local Variables:
;; no-byte-compile: t
lisp/emacsql/emacsql-psql.el
+7 -9
View File
@@ -3,10 +3,8 @@
;; This is free and unencumbered software released into the public domain.
;; Author: Christopher Wellons <wellons@nullprogram.com>
;; Maintainer: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/emacsql
;; Package-Version: 3.1.1.50-git
;; Package-Requires: ((emacs "25.1") (emacsql "20230220"))
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; SPDX-License-Identifier: Unlicense
;;; Commentary:
@@ -77,7 +75,7 @@ http://www.postgresql.org/docs/7.3/static/sql-keywords-appendix.html")
(when hostname
(push "-h" args)
(push hostname args))
(setf args (nreverse args))
(setq args (nreverse args))
(let* ((buffer (generate-new-buffer " *emacsql-psql*"))
(psql emacsql-psql-executable)
(command (mapconcat #'shell-quote-argument (cons psql args) " "))
@@ -117,9 +115,9 @@ http://www.postgresql.org/docs/7.3/static/sql-keywords-appendix.html")
(cl-defmethod emacsql-waiting-p ((connection emacsql-psql-connection))
(with-current-buffer (emacsql-buffer connection)
(cond ((= (buffer-size) 1) (string= "]" (buffer-string)))
((> (buffer-size) 1) (string= "\n]"
(buffer-substring
(- (point-max) 2) (point-max)))))))
((> (buffer-size) 1) (string= "\n]" (buffer-substring
(- (point-max) 2)
(point-max)))))))
(cl-defmethod emacsql-check-error ((connection emacsql-psql-connection))
(with-current-buffer (emacsql-buffer connection)
@@ -139,7 +137,7 @@ http://www.postgresql.org/docs/7.3/static/sql-keywords-appendix.html")
collect (read) into row
when (looking-at "\n")
collect row into rows
and do (progn (forward-char 1) (setf row ()))
and do (progn (forward-char 1) (setq row ()))
finally (cl-return rows)))))
(provide 'emacsql-psql)
lisp/emacsql/emacsql-sqlite-builtin.el
+18 -19
View File
@@ -2,11 +2,9 @@
;; This is free and unencumbered software released into the public domain.
;; Author: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/emacsql
;; Author: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Package-Version: 3.1.1.50-git
;; Package-Requires: ((emacs "29") (emacsql "20230220"))
;; SPDX-License-Identifier: Unlicense
;;; Commentary:
@@ -16,8 +14,7 @@
;;; Code:
(require 'emacsql)
(require 'emacsql-sqlite-common)
(require 'emacsql-sqlite)
(require 'sqlite nil t)
(declare-function sqlite-open "sqlite")
@@ -33,10 +30,8 @@
((connection emacsql-sqlite-builtin-connection) &rest _)
(require (quote sqlite))
(oset connection handle
(sqlite-open (slot-value connection 'file)))
(when emacsql-global-timeout
(emacsql connection [:pragma (= busy-timeout $s1)]
(/ (* emacsql-global-timeout 1000) 2)))
(sqlite-open (oref connection file)))
(emacsql-sqlite-set-busy-timeout connection)
(emacsql connection [:pragma (= foreign-keys on)])
(emacsql-register connection))
@@ -45,7 +40,7 @@
If FILE is nil use an in-memory database.
:debug LOG -- When non-nil, log all SQLite commands to a log
buffer. This is for debugging purposes."
buffer. This is for debugging purposes."
(let ((connection (make-instance #'emacsql-sqlite-builtin-connection
:file file)))
(when debug
@@ -62,14 +57,18 @@ buffer. This is for debugging purposes."
(cl-defmethod emacsql-send-message
((connection emacsql-sqlite-builtin-connection) message)
(condition-case err
(mapcar (lambda (row)
(mapcar (lambda (col)
(cond ((null col) nil)
((equal col "") "")
((numberp col) col)
(t (read col))))
row))
(sqlite-select (oref connection handle) message nil nil))
(let ((headerp emacsql-include-header))
(mapcar (lambda (row)
(cond
(headerp (setq headerp nil) row)
((mapcan (lambda (col)
(cond ((null col) (list nil))
((equal col "") (list ""))
((numberp col) (list col))
((emacsql-sqlite-read-column col))))
row))))
(sqlite-select (oref connection handle) message nil
(and emacsql-include-header 'full))))
((sqlite-error sqlite-locked-error)
(if (stringp (cdr err))
(signal 'emacsql-error (list (cdr err)))
lisp/emacsql/emacsql-sqlite-common.el
+7 -230
View File
@@ -1,245 +1,22 @@
;;; emacsql-sqlite-common.el --- Code used by multiple SQLite back-ends -*- lexical-binding:t -*-
;;; emacsql-sqlite-common.el --- Transitional library that should not be loaded -*- lexical-binding:t -*-
;; This is free and unencumbered software released into the public domain.
;; Author: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/emacsql
;; Author: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; SPDX-License-Identifier: Unlicense
;;; Commentary:
;; This library contains code that is used by multiple SQLite back-ends.
;; Transitional library that should not be loaded. If your package still
;; requires this library, change it to require `emacsql-sqlite' instead.
;;; Code:
(require 'emacsql)
;;; Base class
(defclass emacsql--sqlite-base (emacsql-connection)
((file :initarg :file
:initform nil
:type (or null string)
:documentation "Database file name.")
(types :allocation :class
:reader emacsql-types
:initform '((integer "INTEGER")
(float "REAL")
(object "TEXT")
(nil nil))))
:abstract t)
;;; Constants
(defconst emacsql-sqlite-reserved
'( ABORT ACTION ADD AFTER ALL ALTER ANALYZE AND AS ASC ATTACH
AUTOINCREMENT BEFORE BEGIN BETWEEN BY CASCADE CASE CAST CHECK
COLLATE COLUMN COMMIT CONFLICT CONSTRAINT CREATE CROSS
CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP DATABASE DEFAULT
DEFERRABLE DEFERRED DELETE DESC DETACH DISTINCT DROP EACH ELSE END
ESCAPE EXCEPT EXCLUSIVE EXISTS EXPLAIN FAIL FOR FOREIGN FROM FULL
GLOB GROUP HAVING IF IGNORE IMMEDIATE IN INDEX INDEXED INITIALLY
INNER INSERT INSTEAD INTERSECT INTO IS ISNULL JOIN KEY LEFT LIKE
LIMIT MATCH NATURAL NO NOT NOTNULL NULL OF OFFSET ON OR ORDER
OUTER PLAN PRAGMA PRIMARY QUERY RAISE RECURSIVE REFERENCES REGEXP
REINDEX RELEASE RENAME REPLACE RESTRICT RIGHT ROLLBACK ROW
SAVEPOINT SELECT SET TABLE TEMP TEMPORARY THEN TO TRANSACTION
TRIGGER UNION UNIQUE UPDATE USING VACUUM VALUES VIEW VIRTUAL WHEN
WHERE WITH WITHOUT)
"List of all of SQLite's reserved words.
Also see http://www.sqlite.org/lang_keywords.html.")
(defconst emacsql-sqlite-error-codes
'((1 SQLITE_ERROR emacsql-error "SQL logic error")
(2 SQLITE_INTERNAL emacsql-internal nil)
(3 SQLITE_PERM emacsql-access "access permission denied")
(4 SQLITE_ABORT emacsql-error "query aborted")
(5 SQLITE_BUSY emacsql-locked "database is locked")
(6 SQLITE_LOCKED emacsql-locked "database table is locked")
(7 SQLITE_NOMEM emacsql-memory "out of memory")
(8 SQLITE_READONLY emacsql-access "attempt to write a readonly database")
(9 SQLITE_INTERRUPT emacsql-error "interrupted")
(10 SQLITE_IOERR emacsql-access "disk I/O error")
(11 SQLITE_CORRUPT emacsql-corruption "database disk image is malformed")
(12 SQLITE_NOTFOUND emacsql-error "unknown operation")
(13 SQLITE_FULL emacsql-access "database or disk is full")
(14 SQLITE_CANTOPEN emacsql-access "unable to open database file")
(15 SQLITE_PROTOCOL emacsql-access "locking protocol")
(16 SQLITE_EMPTY emacsql-corruption nil)
(17 SQLITE_SCHEMA emacsql-error "database schema has changed")
(18 SQLITE_TOOBIG emacsql-error "string or blob too big")
(19 SQLITE_CONSTRAINT emacsql-constraint "constraint failed")
(20 SQLITE_MISMATCH emacsql-error "datatype mismatch")
(21 SQLITE_MISUSE emacsql-error "bad parameter or other API misuse")
(22 SQLITE_NOLFS emacsql-error "large file support is disabled")
(23 SQLITE_AUTH emacsql-access "authorization denied")
(24 SQLITE_FORMAT emacsql-corruption nil)
(25 SQLITE_RANGE emacsql-error "column index out of range")
(26 SQLITE_NOTADB emacsql-corruption "file is not a database")
(27 SQLITE_NOTICE emacsql-warning "notification message")
(28 SQLITE_WARNING emacsql-warning "warning message"))
"Alist mapping SQLite error codes to EmacSQL conditions.
Elements have the form (ERRCODE SYMBOLIC-NAME EMACSQL-ERROR
ERRSTR). Also see https://www.sqlite.org/rescode.html.")
;;; Utilities
(defun emacsql-sqlite-open (file &optional debug)
"Open a connected to the database stored in FILE using an SQLite back-end.
Automatically use the best available back-end, as returned by
`emacsql-sqlite-default-connection'.
If FILE is nil, use an in-memory database. If optional DEBUG is
non-nil, log all SQLite commands to a log buffer, for debugging
purposes."
(let* ((class (emacsql-sqlite-default-connection))
(connection (make-instance class :file file)))
(when (eq class 'emacsql-sqlite-connection)
(set-process-query-on-exit-flag (oref connection handle) nil))
(when debug
(emacsql-enable-debugging connection))
connection))
(defun emacsql-sqlite-default-connection ()
"Determine and return the best SQLite connection class.
If a module or binary is required and that doesn't exist yet,
then try to compile it. Signal an error if no connection class
can be used."
(or (and (fboundp 'sqlite-available-p)
(sqlite-available-p)
(require 'emacsql-sqlite-builtin)
'emacsql-sqlite-builtin-connection)
(and (boundp 'module-file-suffix)
module-file-suffix
(condition-case nil
;; Failure modes:
;; 1. `sqlite3' elisp library isn't available.
;; 2. `libsqlite' shared library isn't available.
;; 3. `libsqlite' compilation fails.
;; 4. User chooses to not compile `libsqlite'.
(and (require 'sqlite3)
(require 'emacsql-sqlite-module)
'emacsql-sqlite-module-connection)
(error
(display-warning 'emacsql "\
Since your Emacs does not come with
built-in SQLite support [1], but does support C modules, the best
EmacSQL backend is provided by the third-party `sqlite3' package
[2].
Please install the `sqlite3' Elisp package using your preferred
Emacs package manager, and install the SQLite shared library
using your distribution's package manager. That package should
be named something like `libsqlite3' [3] and NOT just `sqlite3'.
In the current Emacs instance the legacy backend is used, which
uses a custom SQLite executable. Using an external process like
that is less reliable and less performant, and in a few releases
support for that might be removed.
[1]: Supported since Emacs 29.1, provided it was not disabled
with `--without-sqlite3'.
[2]: https://github.com/pekingduck/emacs-sqlite3-api
[3]: On Debian https://packages.debian.org/buster/libsqlite3-0")
;; The buffer displaying the warning might immediately
;; be replaced by another buffer, before the user gets
;; a chance to see it. We cannot have that.
(let (fn)
(setq fn (lambda ()
(remove-hook 'post-command-hook fn)
(pop-to-buffer (get-buffer "*Warnings*"))))
(add-hook 'post-command-hook fn))
nil)))
(and (require 'emacsql-sqlite)
(boundp 'emacsql-sqlite-executable)
(or (file-exists-p emacsql-sqlite-executable)
(with-demoted-errors
"Cannot use `emacsql-sqlite-connection': %S"
(and (fboundp 'emacsql-sqlite-compile)
(emacsql-sqlite-compile 2))))
'emacsql-sqlite-connection)
(error "EmacSQL could not find or compile a back-end")))
(defun emacsql-sqlite-list-tables (connection)
"Return a list of the names of all tables in CONNECTION.
Tables whose names begin with \"sqlite_\", are not included
in the returned value."
(emacsql connection
[:select name
;; The new name is `sqlite-schema', but this name
;; is supported by old and new SQLite versions.
;; See https://www.sqlite.org/schematab.html.
:from sqlite-master
:where (and (= type 'table)
(not-like name "sqlite_%"))
:order-by [(asc name)]]))
(defun emacsql-sqlite-dump-database (connection &optional versionp)
"Dump the database specified by CONNECTION to a file.
The dump file is placed in the same directory as the database
file and its name derives from the name of the database file.
The suffix is replaced with \".sql\" and if optional VERSIONP is
non-nil, then the database version (the `user_version' pragma)
and a timestamp are appended to the file name.
Dumping is done using the official `sqlite3' binary. If that is
not available and VERSIONP is non-nil, then the database file is
copied instead."
(let* ((version (caar (emacsql connection [:pragma user-version])))
(db (oref connection file))
(db (if (symbolp db) (symbol-value db) db))
(name (file-name-nondirectory db))
(output (concat (file-name-sans-extension db)
(and versionp
(concat (format "-v%s" version)
(format-time-string "-%Y%m%d-%H%M")))
".sql")))
(cond
((locate-file "sqlite3" exec-path)
(when (and (file-exists-p output) versionp)
(error "Cannot dump database; %s already exists" output))
(with-temp-file output
(message "Dumping %s database to %s..." name output)
(unless (zerop (save-excursion
(call-process "sqlite3" nil t nil db ".dump")))
(error "Failed to dump %s" db))
(when version
(insert (format "PRAGMA user_version=%s;\n" version)))
;; The output contains "PRAGMA foreign_keys=OFF;".
;; Change that to avoid alarming attentive users.
(when (re-search-forward "^PRAGMA foreign_keys=\\(OFF\\);" 1000 t)
(replace-match "ON" t t nil 1))
(message "Dumping %s database to %s...done" name output)))
(versionp
(setq output (concat (file-name-sans-extension output) ".db"))
(message "Cannot dump database because sqlite3 binary cannot be found")
(when (and (file-exists-p output) versionp)
(error "Cannot copy database; %s already exists" output))
(message "Copying %s database to %s..." name output)
(copy-file db output)
(message "Copying %s database to %s...done" name output))
((error "Cannot dump database; sqlite3 binary isn't available")))))
(defun emacsql-sqlite-restore-database (db dump)
"Restore database DB from DUMP.
DUMP is a file containing SQL statements. DB can be the file
in which the database is to be stored, or it can be a database
connection. In the latter case the current database is first
dumped to a new file and the connection is closed. Then the
database is restored from DUMP. No connection to the new
database is created."
(unless (stringp db)
(emacsql-sqlite-dump-database db t)
(emacsql-close (prog1 db (setq db (oref db file)))))
(with-temp-buffer
(unless (zerop (call-process "sqlite3" nil t nil db
(format ".read %s" dump)))
(error "Failed to read %s: %s" dump (buffer-string)))))
(require 'emacsql-sqlite)
(provide 'emacsql-sqlite-common)
;;; emacsql-sqlite-common.el ends here
lisp/emacsql/emacsql-sqlite-module.el
+20 -20
View File
@@ -2,11 +2,9 @@
;; This is free and unencumbered software released into the public domain.
;; Author: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/emacsql
;; Author: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Package-Version: 3.1.1.50-git
;; Package-Requires: ((emacs "25") (emacsql "20230220") (sqlite3 "0.16"))
;; SPDX-License-Identifier: Unlicense
;;; Commentary:
@@ -16,13 +14,12 @@
;;; Code:
(require 'emacsql)
(require 'emacsql-sqlite-common)
(require 'emacsql-sqlite)
(require 'sqlite3 nil t)
(declare-function sqlite3-open "sqlite3-api")
(declare-function sqlite3-exec "sqlite3-api")
(declare-function sqlite3-close "sqlite3-api")
(declare-function sqlite3-open "ext:sqlite3-api")
(declare-function sqlite3-exec "ext:sqlite3-api")
(declare-function sqlite3-close "ext:sqlite3-api")
(defvar sqlite-open-readwrite)
(defvar sqlite-open-create)
@@ -35,12 +32,10 @@
((connection emacsql-sqlite-module-connection) &rest _)
(require (quote sqlite3))
(oset connection handle
(sqlite3-open (or (slot-value connection 'file) ":memory:")
(sqlite3-open (or (oref connection file) ":memory:")
sqlite-open-readwrite
sqlite-open-create))
(when emacsql-global-timeout
(emacsql connection [:pragma (= busy-timeout $s1)]
(/ (* emacsql-global-timeout 1000) 2)))
(emacsql-sqlite-set-busy-timeout connection)
(emacsql connection [:pragma (= foreign-keys on)])
(emacsql-register connection))
@@ -49,7 +44,7 @@
If FILE is nil use an in-memory database.
:debug LOG -- When non-nil, log all SQLite commands to a log
buffer. This is for debugging purposes."
buffer. This is for debugging purposes."
(let ((connection (make-instance #'emacsql-sqlite-module-connection
:file file)))
(when debug
@@ -66,14 +61,19 @@ buffer. This is for debugging purposes."
(cl-defmethod emacsql-send-message
((connection emacsql-sqlite-module-connection) message)
(condition-case err
(let (rows)
(let ((include-header emacsql-include-header)
(rows ()))
(sqlite3-exec (oref connection handle)
message
(lambda (_ row __)
(push (mapcar (lambda (col)
(cond ((null col) nil)
((equal col "") "")
(t (read col))))
(lambda (_ row header)
(when include-header
(push header rows)
(setq include-header nil))
(push (mapcan (lambda (col)
(cond
((null col) (list nil))
((equal col "") (list ""))
((emacsql-sqlite-read-column col))))
row)
rows)))
(nreverse rows))
lisp/emacsql/emacsql-sqlite.el
+257 -144
View File
@@ -1,182 +1,295 @@
;;; emacsql-sqlite.el --- EmacSQL back-end for SQLite -*- lexical-binding:t -*-
;;; emacsql-sqlite.el --- Code used by multiple SQLite back-ends -*- lexical-binding:t -*-
;; This is free and unencumbered software released into the public domain.
;; Author: Christopher Wellons <wellons@nullprogram.com>
;; Maintainer: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/emacsql
;; Author: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Package-Version: 3.1.1.50-git
;; Package-Requires: ((emacs "25.1") (emacsql "20230220"))
;; SPDX-License-Identifier: Unlicense
;;; Commentary:
;; This library provides the original EmacSQL back-end for SQLite,
;; which uses a custom binary for communicating with a SQLite database.
;; During package installation an attempt is made to compile the binary.
;; This library contains code that is used by multiple SQLite back-ends.
;;; Code:
(require 'emacsql)
(require 'emacsql-sqlite-common)
(emacsql-register-reserved emacsql-sqlite-reserved)
;;; Base class
;;; SQLite connection
(defclass emacsql--sqlite-base (emacsql-connection)
((file :initarg :file
:initform nil
:type (or null string)
:documentation "Database file name.")
(types :allocation :class
:reader emacsql-types
:initform '((integer "INTEGER")
(float "REAL")
(object "TEXT")
(nil nil))))
:abstract t)
(defvar emacsql-sqlite-data-root
(file-name-directory (or load-file-name buffer-file-name))
"Directory where EmacSQL is installed.")
;;; Constants
(defvar emacsql-sqlite-executable-path
(if (memq system-type '(windows-nt cygwin ms-dos))
"sqlite/emacsql-sqlite.exe"
"sqlite/emacsql-sqlite")
"Relative path to emacsql executable.")
(defconst emacsql-sqlite-reserved
'( ABORT ACTION ADD AFTER ALL ALTER ANALYZE AND AS ASC ATTACH
AUTOINCREMENT BEFORE BEGIN BETWEEN BY CASCADE CASE CAST CHECK
COLLATE COLUMN COMMIT CONFLICT CONSTRAINT CREATE CROSS
CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP DATABASE DEFAULT
DEFERRABLE DEFERRED DELETE DESC DETACH DISTINCT DROP EACH ELSE END
ESCAPE EXCEPT EXCLUSIVE EXISTS EXPLAIN FAIL FOR FOREIGN FROM FULL
GLOB GROUP HAVING IF IGNORE IMMEDIATE IN INDEX INDEXED INITIALLY
INNER INSERT INSTEAD INTERSECT INTO IS ISNULL JOIN KEY LEFT LIKE
LIMIT MATCH NATURAL NO NOT NOTNULL NULL OF OFFSET ON OR ORDER
OUTER PLAN PRAGMA PRIMARY QUERY RAISE RECURSIVE REFERENCES REGEXP
REINDEX RELEASE RENAME REPLACE RESTRICT RIGHT ROLLBACK ROW
SAVEPOINT SELECT SET TABLE TEMP TEMPORARY THEN TO TRANSACTION
TRIGGER UNION UNIQUE UPDATE USING VACUUM VALUES VIEW VIRTUAL WHEN
WHERE WITH WITHOUT)
"List of all of SQLite's reserved words.
Also see http://www.sqlite.org/lang_keywords.html.")
(defvar emacsql-sqlite-executable
(expand-file-name emacsql-sqlite-executable-path
(if (or (file-writable-p emacsql-sqlite-data-root)
(file-exists-p (expand-file-name
emacsql-sqlite-executable-path
emacsql-sqlite-data-root)))
emacsql-sqlite-data-root
(expand-file-name
(concat "emacsql/" emacsql-version)
user-emacs-directory)))
"Path to the EmacSQL backend (this is not the sqlite3 shell).")
(defconst emacsql-sqlite-error-codes
'((1 SQLITE_ERROR emacsql-error "SQL logic error")
(2 SQLITE_INTERNAL emacsql-internal nil)
(3 SQLITE_PERM emacsql-access "access permission denied")
(4 SQLITE_ABORT emacsql-error "query aborted")
(5 SQLITE_BUSY emacsql-locked "database is locked")
(6 SQLITE_LOCKED emacsql-locked "database table is locked")
(7 SQLITE_NOMEM emacsql-memory "out of memory")
(8 SQLITE_READONLY emacsql-access "attempt to write a readonly database")
(9 SQLITE_INTERRUPT emacsql-error "interrupted")
(10 SQLITE_IOERR emacsql-access "disk I/O error")
(11 SQLITE_CORRUPT emacsql-corruption "database disk image is malformed")
(12 SQLITE_NOTFOUND emacsql-error "unknown operation")
(13 SQLITE_FULL emacsql-access "database or disk is full")
(14 SQLITE_CANTOPEN emacsql-access "unable to open database file")
(15 SQLITE_PROTOCOL emacsql-access "locking protocol")
(16 SQLITE_EMPTY emacsql-corruption nil)
(17 SQLITE_SCHEMA emacsql-error "database schema has changed")
(18 SQLITE_TOOBIG emacsql-error "string or blob too big")
(19 SQLITE_CONSTRAINT emacsql-constraint "constraint failed")
(20 SQLITE_MISMATCH emacsql-error "datatype mismatch")
(21 SQLITE_MISUSE emacsql-error "bad parameter or other API misuse")
(22 SQLITE_NOLFS emacsql-error "large file support is disabled")
(23 SQLITE_AUTH emacsql-access "authorization denied")
(24 SQLITE_FORMAT emacsql-corruption nil)
(25 SQLITE_RANGE emacsql-error "column index out of range")
(26 SQLITE_NOTADB emacsql-corruption "file is not a database")
(27 SQLITE_NOTICE emacsql-warning "notification message")
(28 SQLITE_WARNING emacsql-warning "warning message"))
"Alist mapping SQLite error codes to EmacSQL conditions.
Elements have the form (ERRCODE SYMBOLIC-NAME EMACSQL-ERROR
ERRSTR). Also see https://www.sqlite.org/rescode.html.")
(defvar emacsql-sqlite-c-compilers '("cc" "gcc" "clang")
"List of names to try when searching for a C compiler.
;;; Variables
Each is queried using `executable-find', so full paths are
allowed. Only the first compiler which is successfully found will
used.")
(defvar emacsql-include-header nil
"Whether to include names of columns as an additional row.
Never enable this globally, only let-bind it around calls to `emacsql'.
Currently only supported by `emacsql-sqlite-builtin-connection' and
`emacsql-sqlite-module-connection'.")
(defclass emacsql-sqlite-connection
(emacsql--sqlite-base emacsql-protocol-mixin) ()
"A connection to a SQLite database.")
(defvar emacsql-sqlite-busy-timeout 20
"Seconds to wait when trying to access a table blocked by another process.
See https://www.sqlite.org/c3ref/busy_timeout.html.")
(cl-defmethod initialize-instance :after
((connection emacsql-sqlite-connection) &rest _rest)
(emacsql-sqlite-ensure-binary)
(let* ((process-connection-type nil) ; use a pipe
;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=60872#11.
(coding-system-for-write 'utf-8)
(coding-system-for-read 'utf-8)
(file (slot-value connection 'file))
(buffer (generate-new-buffer " *emacsql-sqlite*"))
(fullfile (if file (expand-file-name file) ":memory:"))
(process (start-process
"emacsql-sqlite" buffer emacsql-sqlite-executable fullfile)))
(oset connection handle process)
(set-process-sentinel process
(lambda (proc _) (kill-buffer (process-buffer proc))))
(when (memq (process-status process) '(exit signal))
(error "%s has failed immediately" emacsql-sqlite-executable))
(emacsql-wait connection)
(emacsql connection [:pragma (= busy-timeout $s1)]
(/ (* emacsql-global-timeout 1000) 2))
(emacsql-register connection)))
;;; Utilities
(cl-defun emacsql-sqlite (file &key debug)
"Open a connected to database stored in FILE.
If FILE is nil use an in-memory database.
(defun emacsql-sqlite-connection (variable file &optional setup use-module)
"Return the connection stored in VARIABLE to the database in FILE.
:debug LOG -- When non-nil, log all SQLite commands to a log
buffer. This is for debugging purposes."
(let ((connection (make-instance 'emacsql-sqlite-connection :file file)))
(set-process-query-on-exit-flag (oref connection handle) nil)
If the value of VARIABLE is a live database connection, return that.
Otherwise open a new connection to the database in FILE and store the
connection in VARIABLE, before returning it. If FILE is nil, use an
in-memory database. Always enable support for foreign key constrains.
If optional SETUP is non-nil, it must be a function, which takes the
connection as only argument. This function can be used to initialize
tables, for example.
If optional USE-MODULE is non-nil, then use the external module even
when Emacs was built with SQLite support. This is intended for testing
purposes."
(or (let ((connection (symbol-value variable)))
(and connection (emacsql-live-p connection) connection))
(set variable (emacsql-sqlite-open file nil setup use-module))))
(defun emacsql-sqlite-open (file &optional debug setup use-module)
"Open a connection to the database stored in FILE using an SQLite back-end.
Automatically use the best available back-end, as returned by
`emacsql-sqlite-default-connection'.
If FILE is nil, use an in-memory database. If optional DEBUG is
non-nil, log all SQLite commands to a log buffer, for debugging
purposes. Always enable support for foreign key constrains.
If optional SETUP is non-nil, it must be a function, which takes the
connection as only argument. This function can be used to initialize
tables, for example.
If optional USE-MODULE is non-nil, then use the external module even
when Emacs was built with SQLite support. This is intended for testing
purposes."
(when file
(make-directory (file-name-directory file) t))
(let* ((class (emacsql-sqlite-default-connection use-module))
(connection (make-instance class :file file)))
(when debug
(emacsql-enable-debugging connection))
(emacsql connection [:pragma (= foreign-keys on)])
(when setup
(funcall setup connection))
connection))
(cl-defmethod emacsql-close ((connection emacsql-sqlite-connection))
"Gracefully exits the SQLite subprocess."
(let ((process (oref connection handle)))
(when (process-live-p process)
(process-send-eof process))))
(defun emacsql-sqlite-default-connection (&optional use-module)
"Determine and return the best SQLite connection class.
(cl-defmethod emacsql-send-message ((connection emacsql-sqlite-connection) message)
(let ((process (oref connection handle)))
(process-send-string process (format "%d " (string-bytes message)))
(process-send-string process message)
(process-send-string process "\n")))
Signal an error if none of the connection classes can be used.
(cl-defmethod emacsql-handle ((_ emacsql-sqlite-connection) errcode errmsg)
"Get condition for ERRCODE and ERRMSG provided from SQLite."
(pcase-let ((`(,_ ,_ ,signal ,errstr)
(assq errcode emacsql-sqlite-error-codes)))
(signal (or signal 'emacsql-error)
(list errmsg errcode nil errstr))))
If optional USE-MODULE is non-nil, then use the external module even
when Emacs was built with SQLite support. This is intended for testing
purposes."
(or (and (not use-module)
(fboundp 'sqlite-available-p)
(sqlite-available-p)
(require 'emacsql-sqlite-builtin)
'emacsql-sqlite-builtin-connection)
(and (boundp 'module-file-suffix)
module-file-suffix
(condition-case nil
;; Failure modes:
;; 1. `libsqlite' shared library isn't available.
;; 2. User chooses to not compile `libsqlite'.
;; 3. `libsqlite' compilation fails.
(and (require 'sqlite3)
(require 'emacsql-sqlite-module)
'emacsql-sqlite-module-connection)
(error
(display-warning 'emacsql "\
Since your Emacs does not come with
built-in SQLite support [1], but does support C modules, we can
use an EmacSQL backend that relies on the third-party `sqlite3'
package [2].
;;; SQLite compilation
Please install the `sqlite3' Elisp package using your preferred
Emacs package manager, and install the SQLite shared library
using your distribution's package manager. That package should
be named something like `libsqlite3' [3] and NOT just `sqlite3'.
(defun emacsql-sqlite-compile-switches ()
"Return the compilation switches from the Makefile under sqlite/."
(let ((makefile (expand-file-name "sqlite/Makefile" emacsql-sqlite-data-root))
(case-fold-search nil))
(with-temp-buffer
(insert-file-contents makefile)
(goto-char (point-min))
(cl-loop while (re-search-forward "-D[A-Z0-9_=]+" nil :no-error)
collect (match-string 0)))))
The legacy backend, which uses a custom SQLite executable, has
been remove, so we can no longer fall back to that.
(defun emacsql-sqlite-compile (&optional o-level async error)
"Compile the SQLite back-end for EmacSQL, returning non-nil on success.
If called with non-nil ASYNC, the return value is meaningless.
If called with non-nil ERROR, signal an error on failure."
(let* ((cc (cl-loop for option in emacsql-sqlite-c-compilers
for path = (executable-find option)
if path return it))
(src (expand-file-name "sqlite" emacsql-sqlite-data-root))
(files (mapcar (lambda (f) (expand-file-name f src))
'("sqlite3.c" "emacsql.c")))
(cflags (list (format "-I%s" src) (format "-O%d" (or o-level 2))))
(ldlibs (cl-case system-type
(windows-nt (list))
(berkeley-unix (list "-lm"))
(otherwise (list "-lm" "-ldl"))))
(options (emacsql-sqlite-compile-switches))
(output (list "-o" emacsql-sqlite-executable))
(arguments (nconc cflags options files ldlibs output)))
[1]: Supported since Emacs 29.1, provided it was not disabled
with `--without-sqlite3'.
[2]: https://github.com/pekingduck/emacs-sqlite3-api
[3]: On Debian https://packages.debian.org/buster/libsqlite3-0")
;; The buffer displaying the warning might immediately
;; be replaced by another buffer, before the user gets
;; a chance to see it. We cannot have that.
(let (fn)
(setq fn (lambda ()
(remove-hook 'post-command-hook fn)
(pop-to-buffer (get-buffer "*Warnings*"))))
(add-hook 'post-command-hook fn))
nil)))
(error "EmacSQL could not find or compile a back-end")))
(defun emacsql-sqlite-set-busy-timeout (connection)
(when emacsql-sqlite-busy-timeout
(emacsql connection [:pragma (= busy-timeout $s1)]
(* emacsql-sqlite-busy-timeout 1000))))
(defun emacsql-sqlite-read-column (string)
(let ((value nil)
(beg 0)
(end (length string)))
(while (< beg end)
(let ((v (read-from-string string beg)))
(push (car v) value)
(setq beg (cdr v))))
(nreverse value)))
(defun emacsql-sqlite-list-tables (connection)
"Return a list of symbols identifying tables in CONNECTION.
Tables whose names begin with \"sqlite_\", are not included
in the returned value."
(mapcar #'car
(emacsql connection
[:select name
;; The new name is `sqlite-schema', but this name
;; is supported by old and new SQLite versions.
;; See https://www.sqlite.org/schematab.html.
:from sqlite-master
:where (and (= type 'table)
(not-like name "sqlite_%"))
:order-by [(asc name)]])))
(defun emacsql-sqlite-dump-database (connection &optional versionp)
"Dump the database specified by CONNECTION to a file.
The dump file is placed in the same directory as the database
file and its name derives from the name of the database file.
The suffix is replaced with \".sql\" and if optional VERSIONP is
non-nil, then the database version (the `user_version' pragma)
and a timestamp are appended to the file name.
Dumping is done using the official `sqlite3' binary. If that is
not available and VERSIONP is non-nil, then the database file is
copied instead."
(let* ((version (caar (emacsql connection [:pragma user-version])))
(db (oref connection file))
(db (if (symbolp db) (symbol-value db) db))
(name (file-name-nondirectory db))
(output (concat (file-name-sans-extension db)
(and versionp
(concat (format "-v%s" version)
(format-time-string "-%Y%m%d-%H%M")))
".sql")))
(cond
((not cc)
(funcall (if error #'error #'message)
"Could not find C compiler, skipping SQLite build")
nil)
(t
(message "Compiling EmacSQL SQLite binary...")
(mkdir (file-name-directory emacsql-sqlite-executable) t)
(let ((log (get-buffer-create byte-compile-log-buffer)))
(with-current-buffer log
(let ((inhibit-read-only t))
(insert (mapconcat #'identity (cons cc arguments) " ") "\n")
(let ((pos (point))
(ret (apply #'call-process cc nil (if async 0 t) t
arguments)))
(cond
((zerop ret)
(message "Compiling EmacSQL SQLite binary...done")
t)
((and error (not async))
(error "Cannot compile EmacSQL SQLite binary: %S"
(replace-regexp-in-string
"\n" " "
(buffer-substring-no-properties
pos (point-max))))))))))))))
((locate-file "sqlite3" exec-path)
(when (and (file-exists-p output) versionp)
(error "Cannot dump database; %s already exists" output))
(with-temp-file output
(message "Dumping %s database to %s..." name output)
(unless (zerop (save-excursion
(call-process "sqlite3" nil t nil db ".dump")))
(error "Failed to dump %s" db))
(when version
(insert (format "PRAGMA user_version=%s;\n" version)))
;; The output contains "PRAGMA foreign_keys=OFF;".
;; Change that to avoid alarming attentive users.
(when (re-search-forward "^PRAGMA foreign_keys=\\(OFF\\);" 1000 t)
(replace-match "ON" t t nil 1))
(message "Dumping %s database to %s...done" name output)))
(versionp
(setq output (concat (file-name-sans-extension output) ".db"))
(message "Cannot dump database because sqlite3 binary cannot be found")
(when (and (file-exists-p output) versionp)
(error "Cannot copy database; %s already exists" output))
(message "Copying %s database to %s..." name output)
(copy-file db output)
(message "Copying %s database to %s...done" name output))
((error "Cannot dump database; sqlite3 binary isn't available")))))
;;; Ensure the SQLite binary is available
(defun emacsql-sqlite-restore-database (db dump)
"Restore database DB from DUMP.
(defun emacsql-sqlite-ensure-binary ()
"Ensure the EmacSQL SQLite binary is available, signaling an error if not."
(unless (file-exists-p emacsql-sqlite-executable)
;; Try compiling at the last minute.
(condition-case err
(emacsql-sqlite-compile 2 nil t)
(error (error "No EmacSQL SQLite binary available: %s" (cdr err))))))
DUMP is a file containing SQL statements. DB can be the file
in which the database is to be stored, or it can be a database
connection. In the latter case the current database is first
dumped to a new file and the connection is closed. Then the
database is restored from DUMP. No connection to the new
database is created."
(unless (stringp db)
(emacsql-sqlite-dump-database db t)
(emacsql-close (prog1 db (setq db (oref db file)))))
(with-temp-buffer
(unless (zerop (call-process "sqlite3" nil t nil db
(format ".read %s" dump)))
(error "Failed to read %s: %s" dump (buffer-string)))))
(provide 'emacsql-sqlite)
lisp/emacsql/emacsql.el
+40 -88
View File
@@ -3,61 +3,20 @@
;; This is free and unencumbered software released into the public domain.
;; Author: Christopher Wellons <wellons@nullprogram.com>
;; Maintainer: Jonas Bernoulli <jonas@bernoul.li>
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
;; Homepage: https://github.com/magit/emacsql
;; Package-Version: 3.1.1.50-git
;; Package-Requires: ((emacs "25.1"))
;; Package-Version: 4.1.0
;; Package-Requires: ((emacs "26.1"))
;; SPDX-License-Identifier: Unlicense
;;; Commentary:
;; EmacSQL is a high-level Emacs Lisp front-end for SQLite
;; (primarily), PostgreSQL, MySQL, and potentially other SQL
;; databases. On MELPA, each of the backends is provided through
;; separate packages: emacsql-sqlite, emacsql-psql, emacsql-mysql.
;; EmacSQL is a high-level Emacs Lisp front-end for SQLite.
;; Most EmacSQL functions operate on a database connection. For
;; example, a connection to SQLite is established with
;; `emacsql-sqlite'. For each such connection a sqlite3 inferior
;; process is kept alive in the background. Connections are closed
;; with `emacsql-close'.
;; (defvar db (emacsql-sqlite "company.db"))
;; Use `emacsql' to send an s-expression SQL statements to a connected
;; database. Identifiers for tables and columns are symbols. SQL
;; keywords are lisp keywords. Anything else is data.
;; (emacsql db [:create-table people ([name id salary])])
;; Column constraints can optionally be provided in the schema.
;; (emacsql db [:create-table people ([name (id integer :unique) salary])])
;; Insert some values.
;; (emacsql db [:insert :into people
;; :values (["Jeff" 1000 60000.0] ["Susan" 1001 64000.0])])
;; Currently all actions are synchronous and Emacs will block until
;; SQLite has indicated it is finished processing the last command.
;; Query the database for results:
;; (emacsql db [:select [name id] :from employees :where (> salary 60000)])
;; ;; => (("Susan" 1001))
;; Queries can be templates -- $i1, $s2, etc. -- so they don't need to
;; be built up dynamically:
;; (emacsql db
;; [:select [name id] :from employees :where (> salary $s1)]
;; 50000)
;; ;; => (("Jeff" 1000) ("Susan" 1001))
;; The letter declares the type (identifier, scalar, vector, Schema)
;; and the number declares the argument position.
;; PostgreSQL and MySQL are also supported, but use of these connectors
;; is not recommended.
;; See README.md for much more complete documentation.
@@ -73,11 +32,13 @@
"The EmacSQL SQL database front-end."
:group 'comm)
(defconst emacsql-version "3.1.1.50-git")
(defconst emacsql-version "4.1.0")
(defvar emacsql-global-timeout 30
"Maximum number of seconds to wait before bailing out on a SQL command.
If nil, wait forever.")
If nil, wait forever. This is used by the `mysql', `pg', `psql' and
`sqlite' back-ends. It is not being used by the `sqlite-builtin' and
`sqlite-module' back-ends, which only use `emacsql-sqlite-busy-timeout'.")
(defvar emacsql-data-root
(file-name-directory (or load-file-name buffer-file-name))
@@ -94,7 +55,6 @@ may return `process', `user-ptr' or `sqlite' for this value.")
(log-buffer :type (or null buffer)
:initarg :log-buffer
:initform nil
:accessor emacsql-log-buffer
:documentation "Output log (debug).")
(finalizer :documentation "Object returned from `make-finalizer'.")
(types :allocation :class
@@ -112,14 +72,14 @@ may return `process', `user-ptr' or `sqlite' for this value.")
(cl-defmethod emacsql-live-p ((connection emacsql-connection))
"Return non-nil if CONNECTION is still alive and ready."
(not (null (process-live-p (oref connection handle)))))
(and (process-live-p (oref connection handle)) t))
(cl-defgeneric emacsql-types (connection)
"Return an alist mapping EmacSQL types to database types.
This will mask `emacsql-type-map' during expression compilation.
This alist should have four key symbols: integer, float, object,
nil (default type). The values are strings to be inserted into a
SQL expression.")
nil (default type). The values are strings to be inserted into
a SQL expression.")
(cl-defmethod emacsql-buffer ((connection emacsql-connection))
"Get process buffer for CONNECTION."
@@ -127,14 +87,13 @@ SQL expression.")
(cl-defmethod emacsql-enable-debugging ((connection emacsql-connection))
"Enable debugging on CONNECTION."
(unless (buffer-live-p (emacsql-log-buffer connection))
(setf (emacsql-log-buffer connection)
(generate-new-buffer " *emacsql-log*"))))
(unless (buffer-live-p (oref connection log-buffer))
(oset connection log-buffer (generate-new-buffer " *emacsql-log*"))))
(cl-defmethod emacsql-log ((connection emacsql-connection) message)
"Log MESSAGE into CONNECTION's log.
MESSAGE should not have a newline on the end."
(let ((buffer (emacsql-log-buffer connection)))
(let ((buffer (oref connection log-buffer)))
(when buffer
(unless (buffer-live-p buffer)
(setq buffer (emacsql-enable-debugging connection)))
@@ -147,11 +106,11 @@ MESSAGE should not have a newline on the end."
Using this function to do it anyway, means additionally using a
misnamed and obsolete accessor function."
(and (slot-boundp this 'handle)
(eieio-oref this 'handle)))
(oref this handle)))
(cl-defmethod (setf emacsql-process) (value (this emacsql-connection))
(eieio-oset this 'handle value))
(oset this handle value))
(make-obsolete 'emacsql-process "underlying slot is for internal use only."
"Emacsql 4.0.0")
"EmacSQL 4.0.0")
(cl-defmethod slot-missing ((connection emacsql-connection)
slot-name operation &optional new-value)
@@ -187,7 +146,7 @@ misnamed and obsolete accessor function."
(cl-defmethod emacsql-wait ((connection emacsql-connection) &optional timeout)
"Block until CONNECTION is waiting for further input."
(let* ((real-timeout (or timeout emacsql-global-timeout))
(end (when real-timeout (+ (float-time) real-timeout))))
(end (and real-timeout (+ (float-time) real-timeout))))
(while (and (or (null real-timeout) (< (float-time) end))
(not (emacsql-waiting-p connection)))
(save-match-data
@@ -200,7 +159,7 @@ misnamed and obsolete accessor function."
(defun emacsql-compile (connection sql &rest args)
"Compile s-expression SQL for CONNECTION into a string."
(let* ((mask (when connection (emacsql-types connection)))
(let* ((mask (and connection (emacsql-types connection)))
(emacsql-type-map (or mask emacsql-type-map)))
(concat (apply #'emacsql-format (emacsql-prepare sql) args) ";")))
@@ -218,9 +177,9 @@ misnamed and obsolete accessor function."
(defclass emacsql-protocol-mixin () ()
"A mixin for back-ends following the EmacSQL protocol.
The back-end prompt must be a single \"]\" character. This prompt
value was chosen because it is unreadable. Output must have
exactly one row per line, fields separated by whitespace. NULL
The back-end prompt must be a single \"]\" character. This prompt
value was chosen because it is unreadable. Output must have
exactly one row per line, fields separated by whitespace. NULL
must display as \"nil\"."
:abstract t)
@@ -258,9 +217,9 @@ specific error conditions."
(defun emacsql-register (connection)
"Register CONNECTION for automatic cleanup and return CONNECTION."
(let ((finalizer (make-finalizer (lambda () (emacsql-close connection)))))
(prog1 connection
(setf (slot-value connection 'finalizer) finalizer))))
(prog1 connection
(oset connection finalizer
(make-finalizer (lambda () (emacsql-close connection))))))
;;; Useful macros
@@ -287,7 +246,7 @@ This macro can be nested indefinitely, wrapping everything in a
single transaction at the lowest level.
Warning: BODY should *not* have any side effects besides making
changes to the database behind CONNECTION. Body may be evaluated
changes to the database behind CONNECTION. Body may be evaluated
multiple times before the changes are committed."
(declare (indent 1))
`(let ((emacsql--connection ,connection)
@@ -301,10 +260,10 @@ multiple times before the changes are committed."
(when (= 1 emacsql--transaction-level)
(emacsql emacsql--connection [:begin]))
(let ((result (progn ,@body)))
(setf emacsql--result result)
(setq emacsql--result result)
(when (= 1 emacsql--transaction-level)
(emacsql emacsql--connection [:commit]))
(setf emacsql--completed t)))
(setq emacsql--completed t)))
(emacsql-locked (emacsql emacsql--connection [:rollback])
(sleep-for 0.05))))
(when (and (= 1 emacsql--transaction-level)
@@ -329,8 +288,8 @@ A statement can be a list, containing a statement with its arguments."
Returns the result of the last evaluated BODY.
All column names must be provided in the query ($ and * are not
allowed). Hint: all of the bound identifiers must be known at
compile time. For example, in the expression below the variables
allowed). Hint: all of the bound identifiers must be known at
compile time. For example, in the expression below the variables
`name' and `phone' will be bound for the body.
(emacsql-with-bind db [:select [name phone] :from people]
@@ -344,16 +303,16 @@ compile time. For example, in the expression below the variables
Each column must be a plain symbol, no expressions allowed here."
(declare (indent 2))
(let ((sql (if (vectorp sql-and-args) sql-and-args (car sql-and-args)))
(args (unless (vectorp sql-and-args) (cdr sql-and-args))))
(args (and (not (vectorp sql-and-args)) (cdr sql-and-args))))
(cl-assert (eq :select (elt sql 0)))
(let ((vars (elt sql 1)))
(when (eq '* vars)
(error "Must explicitly list columns in `emacsql-with-bind'."))
(error "Must explicitly list columns in `emacsql-with-bind'"))
(cl-assert (cl-every #'symbolp vars))
`(let ((emacsql--results (emacsql ,connection ,sql ,@args))
(emacsql--final nil))
(dolist (emacsql--result emacsql--results emacsql--final)
(setf emacsql--final
(setq emacsql--final
(cl-destructuring-bind ,(cl-coerce vars 'list) emacsql--result
,@body)))))))
@@ -380,14 +339,7 @@ Each column must be a plain symbol, no expressions allowed here."
(sql-mode)
(with-no-warnings ;; autoloaded by previous line
(sql-highlight-sqlite-keywords))
(if (and (fboundp 'font-lock-flush)
(fboundp 'font-lock-ensure))
(save-restriction
(widen)
(font-lock-flush)
(font-lock-ensure))
(with-no-warnings
(font-lock-fontify-buffer)))
(font-lock-ensure)
(emacsql--indent)
(buffer-string))))
(with-current-buffer (get-buffer-create emacsql-show-buffer-name)
@@ -432,9 +384,9 @@ A prefix argument causes the SQL to be printed into the current buffer."
(save-excursion
(beginning-of-defun)
(let ((containing-sexp (elt (parse-partial-sexp (point) start) 1)))
(when containing-sexp
(goto-char containing-sexp)
(looking-at "\\["))))))
(and containing-sexp
(progn (goto-char containing-sexp)
(looking-at "\\[")))))))
(defun emacsql--calculate-vector-indent (fn &optional parse-start)
"Don't indent vectors in `emacs-lisp-mode' like lists."
lisp/emacsql/sqlite/Makefile
-19
View File
@@ -1,19 +0,0 @@
-include ../.config.mk
.POSIX:
LDLIBS = -ldl -lm
CFLAGS = -O2 -Wall -Wextra -Wno-implicit-fallthrough \
-DSQLITE_THREADSAFE=0 \
-DSQLITE_DEFAULT_FOREIGN_KEYS=1 \
-DSQLITE_ENABLE_FTS5 \
-DSQLITE_ENABLE_FTS4 \
-DSQLITE_ENABLE_FTS3_PARENTHESIS \
-DSQLITE_ENABLE_RTREE \
-DSQLITE_ENABLE_JSON1 \
-DSQLITE_SOUNDEX
emacsql-sqlite: emacsql.c sqlite3.c
$(CC) $(CFLAGS) $(LDFLAGS) -o $@ emacsql.c sqlite3.c $(LDLIBS)
clean:
rm -f emacsql-sqlite
lisp/emacsql/sqlite/emacsql.c
-183
View File
@@ -1,183 +0,0 @@
/* This is free and unencumbered software released into the public domain. */
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "sqlite3.h"
#define TRUE 1
#define FALSE 0
char* escape(const char *message) {
int i, count = 0, length_orig = strlen(message);
for (i = 0; i < length_orig; i++) {
if (strchr("\"\\", message[i])) {
count++;
}
}
char *copy = malloc(length_orig + count + 1);
char *p = copy;
while (*message) {
if (strchr("\"\\", *message)) {
*p = '\\';
p++;
}
*p = *message;
message++;
p++;
}
*p = '\0';
return copy;
}
void send_error(int code, const char *message) {
char *escaped = escape(message);
printf("error %d \"%s\"\n", code, escaped);
free(escaped);
}
typedef struct {
char *buffer;
size_t size;
} buffer;
buffer* buffer_create() {
buffer *buffer = malloc(sizeof(*buffer));
buffer->size = 4096;
buffer->buffer = malloc(buffer->size * sizeof(char));
return buffer;
}
int buffer_grow(buffer *buffer) {
unsigned factor = 2;
char *newbuffer = realloc(buffer->buffer, buffer->size * factor);
if (newbuffer == NULL) {
return FALSE;
}
buffer->buffer = newbuffer;
buffer->size *= factor;
return TRUE;
}
int buffer_read(buffer *buffer, size_t count) {
while (buffer->size < count + 1) {
if (buffer_grow(buffer) == FALSE) {
return FALSE;
}
}
size_t in = fread((void *) buffer->buffer, 1, count, stdin);
buffer->buffer[count] = '\0';
return in == count;
}
void buffer_free(buffer *buffer) {
free(buffer->buffer);
free(buffer);
}
int main(int argc, char **argv) {
char *file = NULL;
if (argc != 2) {
fprintf(stderr,
"error: require exactly one argument, the DB filename\n");
exit(EXIT_FAILURE);
} else {
file = argv[1];
}
/* On Windows stderr is not always unbuffered. */
#if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__)
setvbuf(stderr, NULL, _IONBF, 0);
#endif
sqlite3* db = NULL;
if (sqlite3_initialize() != SQLITE_OK) {
fprintf(stderr, "error: failed to initialize sqlite\n");
exit(EXIT_FAILURE);
}
int flags = SQLITE_OPEN_READWRITE | SQLITE_OPEN_CREATE;
if (sqlite3_open_v2(file, &db, flags, NULL) != SQLITE_OK) {
fprintf(stderr, "error: failed to open %s\n", file);
exit(EXIT_FAILURE);
}
buffer *input = buffer_create();
while (TRUE) {
printf("#\n");
fflush(stdout);
/* Gather input from Emacs. */
unsigned length;
int result = scanf("%u ", &length);
if (result == EOF) {
break;
} else if (result != 1) {
send_error(SQLITE_ERROR, "middleware parsing error");
break; /* stream out of sync: quit program */
}
if (!buffer_read(input, length)) {
send_error(SQLITE_NOMEM, "middleware out of memory");
continue;
}
/* Parse SQL statement. */
sqlite3_stmt *stmt = NULL;
result = sqlite3_prepare_v2(db, input->buffer, length, &stmt, NULL);
if (result != SQLITE_OK) {
send_error(sqlite3_errcode(db), sqlite3_errmsg(db));
continue;
}
/* Print out rows. */
int first = TRUE, ncolumns = sqlite3_column_count(stmt);
printf("(");
while (sqlite3_step(stmt) == SQLITE_ROW) {
if (first) {
printf("(");
first = FALSE;
} else {
printf("\n (");
}
int i;
for (i = 0; i < ncolumns; i++) {
if (i > 0) {
printf(" ");
}
int type = sqlite3_column_type(stmt, i);
switch (type) {
case SQLITE_INTEGER:
printf("%lld", sqlite3_column_int64(stmt, i));
break;
case SQLITE_FLOAT:
printf("%f", sqlite3_column_double(stmt, i));
break;
case SQLITE_NULL:
printf("nil");
break;
case SQLITE_TEXT:
fwrite(sqlite3_column_text(stmt, i), 1,
sqlite3_column_bytes(stmt, i), stdout);
break;
case SQLITE_BLOB:
printf("nil");
break;
}
}
printf(")");
}
printf(")\n");
if (sqlite3_finalize(stmt) != SQLITE_OK) {
/* Despite any error code, the statement is still freed.
* http://stackoverflow.com/a/8391872
*/
send_error(sqlite3_errcode(db), sqlite3_errmsg(db));
} else {
printf("success\n");
}
}
buffer_free(input);
sqlite3_close(db);
sqlite3_shutdown();
return EXIT_SUCCESS;
}
lisp/emacsql/sqlite/sqlite3.c
-241687
View File
File diff suppressed because it is too large Load Diff
lisp/emacsql/sqlite/sqlite3.h
-12836
View File
File diff suppressed because it is too large Load Diff
lisp/ess/ess-custom.el
+35 -23
View File
@@ -1,6 +1,6 @@
;;; ess-custom.el --- Customize variables for ESS -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2020 Free Software Foundation, Inc.
;; Copyright (C) 1997-2025 Free Software Foundation, Inc.
;; Author: Rodney Sparapani
;; Maintainer: ESS-help <ess-help@r-project.org>
@@ -141,7 +141,7 @@
"Directory containing ess-site.el(c) and other ESS Lisp files."
:group 'ess
:type 'directory
:package-version '(ess . "19.04"))
:package-version '(ess . "25.01.1"))
(defcustom ess-etc-directory
;; Try to detect the `etc' folder only if not already set up by distribution
@@ -156,7 +156,7 @@ The ESS etc directory stores various auxiliary files that are useful
for ESS, such as icons."
:group 'ess
:type 'directory
:package-version '(ess . "19.04"))
:package-version '(ess . "25.01.1"))
;; Depending on how ESS is loaded the `load-path' might not contain
;; the `lisp' directory. For this reason we need to add it before we
@@ -192,7 +192,7 @@ See `ess-auto-width'. Be warned that ESS can set the width a
lot."
:group 'ess
:type 'boolean
:package-version '(ess . "19.04"))
:package-version '(ess . "25.01.1"))
(defcustom ess-auto-width nil
"When non-nil, set the width option when the window configuration changes.
@@ -206,7 +206,7 @@ window's width minus that number. Anything else is treated as
(const :tag "Frame width" :value frame)
(const :tag "Window width" :value window)
(integer :tag "Integer value"))
:package-version '(ess . "19.04"))
:package-version '(ess . "25.01.1"))
(defcustom ess-handy-commands '(("change-directory" . ess-change-directory)
("install.packages" . ess-install-library)
@@ -329,7 +329,7 @@ process. If a symbol, the symbol's value should be a directory.
For example, the following setting would always start the process
in the directory of the current file:
(setq ess-startup-directory 'default-directory)
(setq ess-startup-directory ''default-directory)
If `ess-startup-directory' is nil (the default) and
`ess-startup-directory-function' is non-nil, the value returned
@@ -380,7 +380,7 @@ processes buffers are always numbered (e.g. R:2:foo."
'ess-use-inferior-program-name-in-buffer-name
'ess-use-inferior-program-in-buffer-name "ESS 18.10")
(defcustom ess-use-inferior-program-in-buffer-name nil
"For R, use e.g., 'R-2.1.0' or 'R-devel' (the program name) for buffer name.
"For R, use e.g., `R-2.1.0' or `R-devel' (the program name) for buffer name.
Avoids the plain dialect name."
:group 'ess
:type 'boolean)
@@ -478,7 +478,7 @@ If \\='process, only check if the buffer has an inferior process."
:type '(choice (const :tag "Always" t)
(const :tag "With running inferior process" process)
(const :tag "Never" nil))
:package-version '(ess . "18.10"))
:package-version '(ess . "25.01.1"))
(defcustom ess-use-auto-complete t
"If non-nil, activate auto-complete support.
@@ -562,7 +562,7 @@ contain spaces on either side."
;; them.
:type '(repeat string)
:group 'ess
:package-version '(ess "18.10"))
:package-version '(ess . "25.01.1"))
(defvar ess-S-assign)
(make-obsolete-variable 'ess-S-assign 'ess-assign-list "ESS 18.10")
@@ -584,7 +584,7 @@ This gets appended to `prettify-symbols-alist', so set it to nil
if you want to disable R specific prettification."
:group 'ess-R
:type '(alist :key-type string :value-type symbol)
:package-version '(ess . "18.10"))
:package-version '(ess . "25.01.1"))
;;*;; Variables concerning editing behavior
@@ -751,7 +751,7 @@ is non-nil. Affects `ess-save-file'."
(const :tag "Use compilation-ask-about-save and auto-save-visited-mode."
:value auto)
(const :tag "Save without asking." :value t))
:package-version '(ess . "19.04"))
:package-version '(ess . "25.01.1"))
;;*;; Variables controlling editing
@@ -1317,7 +1317,7 @@ the same KEY before adding the new one."
(defcustom ess-own-style-list (cdr (assoc 'RRR ess-style-alist))
"Indentation variables for your own style.
Set `ess-style' to 'OWN to use these values. To change
Set `ess-style' to \='OWN to use these values. To change
these values, use the customize interface. See the documentation
of each variable for its meaning."
:group 'ess-edit
@@ -1371,7 +1371,7 @@ This always dumps to a sub-directory (\".Src\") of the current ess
working directory (i.e. first elt of search list)."
:group 'ess-edit
:type 'directory
:package-version '(ess . "18.10"))
:package-version '(ess . "25.01.1"))
(defvar ess-dump-filename-template nil
"Internal. Initialized by dialects.")
@@ -1404,7 +1404,7 @@ Currently this should not be used to interact with the inferior
process because this hook runs too early, before the inferior
mode had a chance to properly start up the process. To interact
with the process, you must use a mode-specific hook like
'ess-r-post-run-hook'."
`ess-r-post-run-hook'."
:group 'ess-hooks
:type 'hook)
@@ -1427,19 +1427,21 @@ Used to decide highlighting and tag completion."
:type '(repeat string))
(defcustom ess-roxy-tags-param '("author" "aliases" "concept" "details"
"examples" "format" "keywords"
"example" "examples" "examplesIf"
"format" "keywords"
"method" "exportMethod"
"name" "note" "param"
"include" "references" "return"
"include" "references" "return" "returns"
"seealso" "source" "docType"
"title" "TODO" "usage" "import"
"exportClass" "exportPattern" "S3method"
"exportClass" "exportPattern"
"exportS3Method" "S3method"
"inherit" "inheritParams" "inheritSection"
"importFrom" "importClassesFrom"
"importMethodsFrom" "useDynLib"
"rawNamespace"
"rdname" "section" "slot" "description"
"md" "eval" "family")
"md" "eval" "evalNamespace" "family")
"The tags used in roxygen fields that require a parameter.
Used to decide highlighting and tag completion."
:group 'ess-roxy
@@ -1531,7 +1533,7 @@ there is no project root in the current directory."
(const :tag "*proc:project-root* or *proc*" ess-gen-proc-buffer-name:project-or-simple)
(const :tag "*proc:project-root* or *proc:dir*" ess-gen-proc-buffer-name:project-or-directory)
function)
:package-version '(ess . "19.04"))
:package-version '(ess . "25.01.1"))
(defcustom ess-kermit-command "gkermit -T"
@@ -1858,7 +1860,7 @@ This variable also affect the evaluation of input code in
iESS. The effect is similar to the above. If t then ess waits for
the process output, otherwise not."
:group 'ess-proc
:package-version '(ess . "19.04")
:package-version '(ess . "25.01.1")
:type '(choice (const t) (const nowait) (const nil)))
(defcustom ess-eval-deactivate-mark (fboundp 'deactivate-mark); was nil till 2010-03-22
@@ -2052,6 +2054,15 @@ See also function `ess-create-object-name-db'.")
"recover" "browser")
"Reserved words or special functions in the R language.")
(defvar ess-r--keystrings
'("\\" "\?")
"Reserved non-word strings or special functions whose names
include special characters in the R language.
Similar font-locking usage as `ess-R-keywords', but dedicated to
strings that should not be treated as `words’ by `regexp-opt' in
`ess-r--find-fl-keyword'.")
(defvar ess-S-keywords
(append ess-R-keywords '("terminate")))
@@ -2088,7 +2099,8 @@ See also function `ess-create-object-name-db'.")
(defvar ess-R-function-name-regexp
(concat "\\(" "\\sw+" "\\)"
"[ \t]*" "\\(<-\\)"
"[ \t\n]*" "function\\b"))
"[ \t\n]*" "\\(function\\b\\|\\(\\\\[ \t\n(]+\\)\\)"))
;; "[ \t\n(]+" after "\\\\" since cannot use "\\b" to bound a non-word
(defvar ess-S-function-name-regexp
ess-R-function-name-regexp)
@@ -2317,7 +2329,7 @@ This defaults to `default-frame-alist' and is used only when
the variable `ess-help-own-frame' is non-nil."
:group 'ess-help
:type 'alist
:package-version '(ess . "18.10"))
:package-version '(ess . "25.01.1"))
; Faces
;;;=====================================================
@@ -2463,7 +2475,7 @@ Created for each process."
See also `ess-verbose'."
:group 'ess-proc
:type 'boolean
:package-version '(ess . "18.10"))
:package-version '(ess . "25.01.1"))
(defcustom ess-verbose nil
"Non-nil means write more information to `ess-dribble-buffer' than usual."
lisp/ess/ess-inf.el
+6 -1
View File
@@ -605,6 +605,11 @@ process-less buffer because it was created with
(nconc
(list "STATATERM=emacs"
(format "PAGER=%s" inferior-ess-pager))
;; This lets R code know whether Emacs was running with a
;; light or dark background at startup time
(let ((bg-mode (frame-parameter nil 'background-mode)))
(when (memq bg-mode '(light dark))
(list (format "ESS_BACKGROUND_MODE=%s" (symbol-name bg-mode)))))
process-environment))
(tramp-remote-process-environment
(nconc ;; it contains a pager already, so append
@@ -820,7 +825,7 @@ to `ess-completing-read'."
(delete-dups (list "R" "S+" (or (bound-and-true-p S+-dialect-name) "S+")
"stata" (or (bound-and-true-p STA-dialect-name) "stata")
"julia" "SAS")))))
(pname-list (delq nil ;; keep only those matching dialect
(pname-list (delq nil ;; keep only those matching dialect and `ess-gen-proc-buffer-name-function'
(append
(mapcar (lambda (lproc)
(and (equal ess-dialect
lisp/ess/ess-julia.el
+6 -9
View File
@@ -42,7 +42,8 @@
;; Don't require `julia-mode' to compile this file.
(when t (require 'julia-mode))
(declare-function julia-mode "julia-mode" ())
(declare-function julia-latexsub "julia-mode" ())
(declare-function julia-mode-latexsub-completion-at-point-before "julia-mode" ())
(declare-function julia-mode-latexsub-completion-at-point-around "julia-mode" ())
(defvar julia-mode-syntax-table)
(defvar ac-prefix)
@@ -117,12 +118,6 @@ See `comint-input-sender'."
;;; COMPLETION
(defun ess-julia-latexsub-completion ()
"Complete latex input in format required by `completion-at-point-functions'."
(if (julia-latexsub) ; julia-latexsub returns nil if it performed a completion, the point otherwise
nil
(lambda () t) ;; bypass other completion methods
))
(defun ess-julia-object-completion ()
"Return completions in format required by `completion-at-point-functions'."
@@ -369,7 +364,8 @@ It makes underscores and dots word constituent chars.")
(remove-hook 'completion-at-point-functions #'ess-filename-completion 'local) ;; should be first
(add-hook 'completion-at-point-functions #'ess-julia-object-completion nil 'local)
(add-hook 'completion-at-point-functions #'ess-filename-completion nil 'local)
(add-hook 'completion-at-point-functions #'ess-julia-latexsub-completion nil 'local)
(add-hook 'completion-at-point-functions #'julia-mode-latexsub-completion-at-point-before nil 'local)
(add-hook 'completion-at-point-functions #'julia-mode-latexsub-completion-at-point-around nil 'local)
(if (fboundp 'ess-add-toolbar) (ess-add-toolbar)))
;; Inferior mode
@@ -393,7 +389,8 @@ It makes underscores and dots word constituent chars.")
(remove-hook 'completion-at-point-functions #'ess-filename-completion 'local) ;; should be first
(add-hook 'completion-at-point-functions #'ess-julia-object-completion nil 'local)
(add-hook 'completion-at-point-functions #'ess-filename-completion nil 'local)
(add-hook 'completion-at-point-functions #'ess-julia-latexsub-completion nil 'local)
(add-hook 'completion-at-point-functions #'julia-mode-latexsub-completion-at-point-before nil 'local)
(add-hook 'completion-at-point-functions #'julia-mode-latexsub-completion-at-point-around nil 'local)
(setq comint-input-sender #'ess-julia-input-sender))
(defvar ess-julia-mode-hook nil)
lisp/ess/ess-pkg.el
+2 -2
View File
@@ -1,6 +1,6 @@
(define-package "ess" "20230807.1422" "Emacs Speaks Statistics"
(define-package "ess" "20250110.1437" "Emacs Speaks Statistics"
'((emacs "25.1"))
:commit "d8914196ceb2061d850cc899aed79342519972ff" :authors
:commit "0eb240bcb6d0e933615f6cfaa9761b629ddbabdd" :authors
'(("David Smith" . "dsmith@stats.adelaide.edu.au")
("A.J. Rossini" . "blindglobe@gmail.com")
("Richard M. Heiberger" . "rmh@temple.edu")
lisp/ess/ess-r-flymake.el
+1 -1
View File
@@ -90,7 +90,7 @@ each element is passed as argument to `lintr::with_defaults'."
} else {
tryCatch(lintr::lint(commandArgs(TRUE), ...),
error = function(e) {
cat('@@warning: @@', e)
cat('@@warning: @@', conditionMessage(e))
})
}
}
lisp/ess/ess-r-mode.el
+25 -4
View File
@@ -372,7 +372,7 @@ namespace.")
(ess-goto-char string-end)
(ess-looking-at "<-")
(ess-goto-char (match-end 0))
(ess-looking-at "function\\b" t)))
(ess-looking-at "function\\b\\|\\\\" t)))
font-lock-function-name-face)
((save-excursion
(and (cdr (assq 'ess-fl-keyword:fun-calls ess-R-font-lock-keywords))
@@ -394,23 +394,44 @@ namespace.")
font-lock-comment-face))
(defvar ess-r--non-fn-kwds
'("in" "else" "break" "next" "repeat"))
'("in" "else" "break" "next" "repeat")
"Reserved words that should not be treated as names of special
functions by `ess-r--find-fl-keyword'; such reserved words do
not need to be followed by an open parenthesis to trigger
font-locking.
See also `ess-r--non-fn-kstrs'.")
(defvar ess-r--non-fn-kstrs
'("\?")
"Reserved non-word strings that should not be treated as names of
special functions by `ess-r--find-fl-keyword'; such reserved
strings do not need to be followed by an open parenthesis to
trigger font-locking.
See also `ess-r--non-fn-kwds'.")
(defvar-local ess-r--keyword-regexp nil)
(defun ess-r--find-fl-keyword (limit)
"Search for R keyword and set the match data.
"Search for R keyword or keystring and set the match data.
To be used as part of `font-lock-defaults' keywords."
(unless ess-r--keyword-regexp
(let (fn-kwds non-fn-kwds)
(let (fn-kwds non-fn-kwds fn-kstrs non-fn-kstrs)
(dolist (kw ess-R-keywords)
(if (member kw ess-r--non-fn-kwds)
(push kw non-fn-kwds)
(push kw fn-kwds)))
(dolist (kw ess-r--keystrings)
(if (member kw ess-r--non-fn-kstrs)
(push kw non-fn-kstrs)
(push kw fn-kstrs)))
(setq ess-r--keyword-regexp
(concat "\\("
(regexp-opt non-fn-kwds 'words)
"\\|"
(regexp-opt non-fn-kstrs t)
"\\)\\|\\("
(regexp-opt fn-kwds 'words)
"\\|"
(regexp-opt fn-kstrs t)
"\\)"))))
(let (out)
(while (and (not out)
lisp/ess/ess-rd.el
+3 -2
View File
@@ -129,8 +129,9 @@ All Rd mode abbrevs start with a grave accent (`)."
;; "Alpha" "Gamma" "alpha" "beta" "epsilon" "lambda" "mu" "pi" "sigma"
;; "ge" "le" "left" "right"
;;
"RdOpts" "R" "S3method" "S4method" "Sexpr" "acronym"
"bold" "cite" "code" "command" "cr" "dQuote" "deqn" "dfn" "dontrun"
"RdOpts" "R" "S3method" "S4method" "Sexpr"
"abbr" "acronym"
"bold" "cite" "code" "command" "cr" "dQuote" "deqn" "dfn" "dontdiff" "dontrun"
"dontshow" "donttest" "dots" "email" "emph" "enc" "env" "eqn" "figure" "file"
"href"
"ifelse" "if"

Some files were not shown because too many files have changed in this diff Show More