[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/pgtk da2c0e8: Merge remote-tracking branch 'origin/master' into
|
From: |
Po Lu |
|
Subject: |
feature/pgtk da2c0e8: Merge remote-tracking branch 'origin/master' into feature/pgtk |
|
Date: |
Mon, 13 Dec 2021 00:33:05 -0500 (EST) |
branch: feature/pgtk
commit da2c0e8f7d7ce7a7a45a5b1425821426dc291d9f
Merge: 13edadb 9ce0fe5
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>
Merge remote-tracking branch 'origin/master' into feature/pgtk
---
doc/lispref/text.texi | 15 ++++++
etc/NEWS | 4 ++
lisp/char-fold.el | 146 +++++++++++++++++++++++++++++---------------------
lisp/pixel-scroll.el | 6 +++
lisp/startup.el | 41 +++++++++-----
src/sqlite.c | 25 ++++++++-
src/xfns.c | 2 +
src/xterm.c | 26 +++++----
8 files changed, 177 insertions(+), 88 deletions(-)
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index b8d92f7..5ab5e57 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -5286,6 +5286,21 @@ Like @code{progn} (@pxref{Sequencing}), but executes
@var{body} with a
transaction held, and commits the transaction at the end.
@end defmac
+@defun sqlite-pragma db pragma
+Execute @var{pragma} in @var{db}. A @dfn{pragma} is usually a command
+that affects the database overall, instead of any particular table.
+For instance, to make SQLite automatically garbage collect data that's
+no longer needed, you can say:
+
+@lisp
+(sqlite-pragma db "auto_vacuum = FULL")
+@end lisp
+
+This function returns non-@code{nil} on success and @code{nil} if the
+pragma failed. Many pragmas can only be issued when the database is
+brand new and empty.
+@end defun
+
@defun sqlite-load-extension db module
Load the named extension @var{module} into the database @var{db}.
Extensions are usually shared-library files; on GNU and Unix systems,
diff --git a/etc/NEWS b/etc/NEWS
index 807751a..b55b306 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -331,6 +331,10 @@ received.
* Changes in Specialized Modes and Packages in Emacs 29.1
+** Isearch and Replace
+
+*** New user option 'char-fold-override' omits the default character-folding.
+
** New minor mode 'glyphless-display-mode'.
This allows an easy way to toggle seeing all glyphless characters in
the current buffer.
diff --git a/lisp/char-fold.el b/lisp/char-fold.el
index e3ab7d5..b8e3d2f 100644
--- a/lisp/char-fold.el
+++ b/lisp/char-fold.el
@@ -26,6 +26,7 @@
(eval-and-compile
(put 'char-fold-table 'char-table-extra-slots 1)
+ (defconst char-fold--default-override nil)
(defconst char-fold--default-include
'((?\" "＂" "“" "”" "”" "„" "⹂" "〞" "‟" "‟" "❞" "❝" "❠" "“" "„" "〝" "〟" "🙷"
"🙶" "🙸" "«" "»")
(?' "❟" "❛" "❜" "‘" "’" "‚" "‛" "‚" "" "❮" "❯" "‹" "›")
@@ -40,7 +41,8 @@
))
(defconst char-fold--default-symmetric nil)
(defvar char-fold--previous
- (list char-fold--default-include
+ (list char-fold--default-override
+ char-fold--default-include
char-fold--default-exclude
char-fold--default-symmetric)))
@@ -67,48 +69,50 @@
;; - A single char of the decomp might be allowed to match the
;; character.
;; Some examples in the comments below.
- (map-char-table
- (lambda (char decomp)
- (when (consp decomp)
- ;; Skip trivial cases like ?a decomposing to (?a).
- (unless (and (not (cdr decomp))
- (eq char (car decomp)))
- (if (symbolp (car decomp))
- ;; Discard a possible formatting tag.
- (setq decomp (cdr decomp))
- ;; If there's no formatting tag, ensure that char matches
- ;; its decomp exactly. This is because we want 'ä' to
- ;; match 'ä', but we don't want '¹' to match '1'.
- (aset equiv char
- (cons (apply #'string decomp)
- (aref equiv char))))
-
- ;; Allow the entire decomp to match char. If decomp has
- ;; multiple characters, this is done by adding an entry
- ;; to the alist of the first character in decomp. This
- ;; allows 'ff' to match 'ff', 'ä' to match 'ä', and '1' to
- ;; match '¹'.
- (let ((make-decomp-match-char
- (lambda (decomp char)
- (if (cdr decomp)
- (aset equiv-multi (car decomp)
- (cons (cons (apply #'string (cdr decomp))
- (regexp-quote (string char)))
- (aref equiv-multi (car decomp))))
- (aset equiv (car decomp)
- (cons (char-to-string char)
- (aref equiv (car decomp))))))))
- (funcall make-decomp-match-char decomp char)
- ;; Check to see if the first char of the decomposition
- ;; has a further decomposition. If so, add a mapping
- ;; back from that second decomposition to the original
- ;; character. This allows e.g. 'ι' (GREEK SMALL LETTER
- ;; IOTA) to match both the Basic Greek block and
- ;; Extended Greek block variants of IOTA +
- ;; diacritical(s). Repeat until there are no more
- ;; decompositions.
- (let ((dec decomp)
- next-decomp)
+ (unless (or (bound-and-true-p char-fold-override)
+ char-fold--default-override)
+ (map-char-table
+ (lambda (char decomp)
+ (when (consp decomp)
+ ;; Skip trivial cases like ?a decomposing to (?a).
+ (unless (and (not (cdr decomp))
+ (eq char (car decomp)))
+ (if (symbolp (car decomp))
+ ;; Discard a possible formatting tag.
+ (setq decomp (cdr decomp))
+ ;; If there's no formatting tag, ensure that char matches
+ ;; its decomp exactly. This is because we want 'ä' to
+ ;; match 'ä', but we don't want '¹' to match '1'.
+ (aset equiv char
+ (cons (apply #'string decomp)
+ (aref equiv char))))
+
+ ;; Allow the entire decomp to match char. If decomp has
+ ;; multiple characters, this is done by adding an entry
+ ;; to the alist of the first character in decomp. This
+ ;; allows 'ff' to match 'ff', 'ä' to match 'ä', and '1' to
+ ;; match '¹'.
+ (let ((make-decomp-match-char
+ (lambda (decomp char)
+ (if (cdr decomp)
+ (aset equiv-multi (car decomp)
+ (cons (cons (apply #'string (cdr decomp))
+ (regexp-quote (string char)))
+ (aref equiv-multi (car decomp))))
+ (aset equiv (car decomp)
+ (cons (char-to-string char)
+ (aref equiv (car decomp))))))))
+ (funcall make-decomp-match-char decomp char)
+ ;; Check to see if the first char of the decomposition
+ ;; has a further decomposition. If so, add a mapping
+ ;; back from that second decomposition to the original
+ ;; character. This allows e.g. 'ι' (GREEK SMALL LETTER
+ ;; IOTA) to match both the Basic Greek block and
+ ;; Extended Greek block variants of IOTA +
+ ;; diacritical(s). Repeat until there are no more
+ ;; decompositions.
+ (let ((dec decomp)
+ next-decomp)
(while dec
(setq next-decomp (char-table-range table (car dec)))
(when (consp next-decomp)
@@ -118,24 +122,24 @@
(car next-decomp)))
(funcall make-decomp-match-char (list (car
next-decomp)) char)))
(setq dec next-decomp)))
- ;; Do it again, without the non-spacing characters.
- ;; This allows 'a' to match 'ä'.
- (let ((simpler-decomp nil)
- (found-one nil))
- (dolist (c decomp)
- (if (> (get-char-code-property c
'canonical-combining-class) 0)
- (setq found-one t)
- (push c simpler-decomp)))
- (when (and simpler-decomp found-one)
- (funcall make-decomp-match-char simpler-decomp char)
- ;; Finally, if the decomp only had one spacing
- ;; character, we allow this character to match the
- ;; decomp. This is to let 'a' match 'ä'.
- (unless (cdr simpler-decomp)
- (aset equiv (car simpler-decomp)
- (cons (apply #'string decomp)
- (aref equiv (car simpler-decomp)))))))))))
- table)
+ ;; Do it again, without the non-spacing characters.
+ ;; This allows 'a' to match 'ä'.
+ (let ((simpler-decomp nil)
+ (found-one nil))
+ (dolist (c decomp)
+ (if (> (get-char-code-property c
'canonical-combining-class) 0)
+ (setq found-one t)
+ (push c simpler-decomp)))
+ (when (and simpler-decomp found-one)
+ (funcall make-decomp-match-char simpler-decomp char)
+ ;; Finally, if the decomp only had one spacing
+ ;; character, we allow this character to match the
+ ;; decomp. This is to let 'a' match 'ä'.
+ (unless (cdr simpler-decomp)
+ (aset equiv (car simpler-decomp)
+ (cons (apply #'string decomp)
+ (aref equiv (car simpler-decomp)))))))))))
+ table))
;; Add some entries to default decomposition
(dolist (it (or (bound-and-true-p char-fold-include)
@@ -232,7 +236,9 @@ Exceptionally for the space character (32), ALIST is
ignored.")
(defun char-fold-update-table ()
"Update char-fold-table only when one of the options changes its value."
- (let ((new (list (or (bound-and-true-p char-fold-include)
+ (let ((new (list (or (bound-and-true-p char-fold-override)
+ char-fold--default-override)
+ (or (bound-and-true-p char-fold-include)
char-fold--default-include)
(or (bound-and-true-p char-fold-exclude)
char-fold--default-exclude)
@@ -242,6 +248,22 @@ Exceptionally for the space character (32), ALIST is
ignored.")
(setq char-fold-table (char-fold--make-table)
char-fold--previous new))))
+(defcustom char-fold-override char-fold--default-override
+ "Non-nil means to override the default definitions of equivalent characters.
+When nil (the default), the table of character equivalences used
+for character-folding is populated with the default set of equivalent
+characters; customize `char-fold-exclude' to remove unneeded equivalences,
+and `char-fold-include' to add your own.
+When this variable is non-nil, the table of equivalences starts empty,
+and you can add your own equivalences by customizing `char-fold-include'."
+ :type 'boolean
+ :initialize #'custom-initialize-default
+ :set (lambda (sym val)
+ (custom-set-default sym val)
+ (char-fold-update-table))
+ :group 'isearch
+ :version "29.1")
+
(defcustom char-fold-include char-fold--default-include
"Additional character foldings to include.
Each entry is a list of a character and the strings that fold into it."
diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el
index 0e22ef2..142ebf9 100644
--- a/lisp/pixel-scroll.el
+++ b/lisp/pixel-scroll.el
@@ -416,6 +416,12 @@ window, and the pixel height of that line."
;; restore initial position
(set-window-start nil pos0 t)
(set-window-vscroll nil vscroll0 t)
+ (when (and line-height
+ (> (car (posn-x-y (posn-at-point pos0))) 0))
+ (setq line-height (- line-height
+ (save-excursion
+ (goto-char pos0)
+ (line-pixel-height)))))
(cons pos line-height)))
(defun pixel-point-at-unseen-line ()
diff --git a/lisp/startup.el b/lisp/startup.el
index 88708f0..b794673 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -1570,17 +1570,22 @@ If this is nil, no message will be displayed."
`((:face (variable-pitch font-lock-comment-face)
"Welcome to "
:link ("GNU Emacs"
- ,(lambda (_button) (browse-url
"https://www.gnu.org/software/emacs/";))
+ ,(lambda (_button)
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/software/emacs/";)))
"Browse https://www.gnu.org/software/emacs/";)
", one component of the "
:link
,(lambda ()
(if (eq system-type 'gnu/linux)
`("GNU/Linux"
- ,(lambda (_button) (browse-url
"https://www.gnu.org/gnu/linux-and-gnu.html";))
+ ,(lambda (_button)
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html";)))
"Browse https://www.gnu.org/gnu/linux-and-gnu.html";)
`("GNU" ,(lambda (_button)
- (browse-url "https://www.gnu.org/gnu/thegnuproject.html";))
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url
"https://www.gnu.org/gnu/thegnuproject.html";)))
"Browse https://www.gnu.org/gnu/thegnuproject.html";)))
" operating system.\n\n"
:face variable-pitch
@@ -1613,7 +1618,8 @@ If this is nil, no message will be displayed."
"\n"
:link ("Emacs Guided Tour"
,(lambda (_button)
- (browse-url "https://www.gnu.org/software/emacs/tour/";))
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/software/emacs/tour/";)))
"Browse https://www.gnu.org/software/emacs/tour/";)
"\tOverview of Emacs features at gnu.org\n"
:link ("View Emacs Manual" ,(lambda (_button) (info-emacs-manual)))
@@ -1637,7 +1643,8 @@ Each element in the list should be a list of strings or
pairs
"This is "
:link ("GNU Emacs"
,(lambda (_button)
- (browse-url "https://www.gnu.org/software/emacs/";))
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/software/emacs/";)))
"Browse https://www.gnu.org/software/emacs/";)
", a text editor and more.\nIt's a component of the "
:link
@@ -1645,9 +1652,12 @@ Each element in the list should be a list of strings or
pairs
(if (eq system-type 'gnu/linux)
`("GNU/Linux"
,(lambda (_button)
- (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html";))
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html";)))
"Browse https://www.gnu.org/gnu/linux-and-gnu.html";)
- `("GNU" ,(lambda (_button) (describe-gnu-project))
+ `("GNU" ,(lambda (_button)
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (describe-gnu-project)))
"Display info on the GNU project.")))
" operating system.\n"
:face (variable-pitch font-lock-builtin-face)
@@ -1671,7 +1681,9 @@ Each element in the list should be a list of strings or
pairs
,(lambda (_button) (info "(emacs)Contributing")))
"\tHow to report bugs and contribute improvements to Emacs\n"
"\n"
- :link ("GNU and Freedom" ,(lambda (_button) (describe-gnu-project)))
+ :link ("GNU and Freedom" ,(lambda (_button)
+ (let ((browse-url-browser-function
'eww-browse-url))
+ (describe-gnu-project))))
"\tWhy we developed GNU Emacs, and the GNU operating system\n"
:link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty)))
"\tGNU Emacs comes with "
@@ -1709,7 +1721,8 @@ Each element in the list should be a list of strings or
pairs
"\n"
:link ("Emacs Guided Tour"
,(lambda (_button)
- (browse-url "https://www.gnu.org/software/emacs/tour/";))
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (browse-url "https://www.gnu.org/software/emacs/tour/";)))
"Browse https://www.gnu.org/software/emacs/tour/";)
"\tSee an overview of Emacs features at gnu.org\n"
:link ("Emacs Manual" ,(lambda (_button) (info-emacs-manual)))
@@ -1831,7 +1844,9 @@ a face or button specification."
(make-button (prog1 (point) (insert-image img)) (point)
'face 'default
'help-echo "mouse-2, RET: Browse https://www.gnu.org/";
- 'action (lambda (_button) (browse-url
"https://www.gnu.org/";))
+ 'action (lambda (_button)
+ (let ((browse-url-browser-function
'eww-browse-url))
+ (browse-url "https://www.gnu.org/";)))
'follow-link t)
(insert "\n\n")))))
@@ -1952,7 +1967,6 @@ splash screen in another window."
(insert "\n")
(fancy-startup-tail concise))
(use-local-map splash-screen-keymap)
- (setq-local browse-url-browser-function 'eww-browse-url)
(setq tab-width 22
buffer-read-only t)
(set-buffer-modified-p nil)
@@ -1990,7 +2004,6 @@ splash screen in another window."
(goto-char (point-min))
(force-mode-line-update))
(use-local-map splash-screen-keymap)
- (setq-local browse-url-browser-function 'eww-browse-url)
(setq tab-width 22)
(setq buffer-read-only t)
;; Place point somewhere it doesn't cover a character.
@@ -2278,7 +2291,9 @@ Type \\[describe-distribution] for information on "))
(insert "\tHow to report bugs and contribute improvements to Emacs\n\n")
(insert-button "GNU and Freedom"
- 'action (lambda (_button) (describe-gnu-project))
+ 'action (lambda (_button)
+ (let ((browse-url-browser-function 'eww-browse-url))
+ (describe-gnu-project)))
'follow-link t)
(insert "\t\tWhy we developed GNU Emacs and the GNU system\n")
diff --git a/src/sqlite.c b/src/sqlite.c
index d92dcf7..4968ce3 100644
--- a/src/sqlite.c
+++ b/src/sqlite.c
@@ -400,7 +400,9 @@ Value is the number of affected rows. */)
exit:
if (errmsg != NULL)
- xsignal1 (Qerror, build_string (errmsg));
+ xsignal1 (ret == SQLITE_LOCKED || ret == SQLITE_BUSY?
+ Qsqlite_locked_error: Qerror,
+ build_string (errmsg));
return retval;
}
@@ -572,6 +574,17 @@ DEFUN ("sqlite-rollback", Fsqlite_rollback,
Ssqlite_rollback, 1, 1, 0,
return sqlite_exec (XSQLITE (db)->db, "rollback");
}
+DEFUN ("sqlite-pragma", Fsqlite_pragma, Ssqlite_pragma, 2, 2, 0,
+ doc: /* Execute PRAGMA in DB. */)
+ (Lisp_Object db, Lisp_Object pragma)
+{
+ check_sqlite (db, false);
+ CHECK_STRING (pragma);
+
+ return sqlite_exec (XSQLITE (db)->db,
+ SSDATA (concat2 (build_string ("PRAGMA "), pragma)));
+}
+
#ifdef HAVE_SQLITE3_LOAD_EXTENSION
DEFUN ("sqlite-load-extension", Fsqlite_load_extension,
Ssqlite_load_extension, 2, 2, 0,
@@ -687,6 +700,7 @@ syms_of_sqlite (void)
defsubr (&Ssqlite_transaction);
defsubr (&Ssqlite_commit);
defsubr (&Ssqlite_rollback);
+ defsubr (&Ssqlite_pragma);
#ifdef HAVE_SQLITE3_LOAD_EXTENSION
defsubr (&Ssqlite_load_extension);
#endif
@@ -698,8 +712,15 @@ syms_of_sqlite (void)
DEFSYM (Qfull, "full");
#endif
defsubr (&Ssqlitep);
- DEFSYM (Qsqlitep, "sqlitep");
defsubr (&Ssqlite_available_p);
+
+ DEFSYM (Qsqlite_locked_error, "sqlite-locked-error");
+ Fput (Qsqlite_locked_error, Qerror_conditions,
+ Fpurecopy (list2 (Qsqlite_locked_error, Qerror)));
+ Fput (Qsqlite_locked_error, Qerror_message,
+ build_pure_c_string ("Database locked"));
+
+ DEFSYM (Qsqlitep, "sqlitep");
DEFSYM (Qfalse, "false");
DEFSYM (Qsqlite, "sqlite");
DEFSYM (Qsqlite3, "sqlite3");
diff --git a/src/xfns.c b/src/xfns.c
index 5eff9f5..b569482 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -2936,8 +2936,10 @@ setup_xi_event_mask (struct frame *f)
XISetMask (m, XI_Motion);
XISetMask (m, XI_Enter);
XISetMask (m, XI_Leave);
+#if 0
XISetMask (m, XI_FocusIn);
XISetMask (m, XI_FocusOut);
+#endif
XISelectEvents (FRAME_X_DISPLAY (f),
FRAME_X_WINDOW (f),
&mask, 1);
diff --git a/src/xterm.c b/src/xterm.c
index 9d60292..1f377f8 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -5144,19 +5144,23 @@ x_detect_focus_change (struct x_display_info *dpyinfo,
struct frame *frame,
int focus_state
= focus_frame ? focus_frame->output_data.x->focus_state : 0;
- if (((((xi_event->evtype == XI_Enter
- || xi_event->evtype == XI_Leave)
- && (((XIEnterEvent *) xi_event)->detail
- != XINotifyInferior)
- && !(focus_state & FOCUS_EXPLICIT))
- || xi_event->evtype == XI_FocusIn
- || xi_event->evtype == XI_FocusOut)))
+#ifdef USE_GTK
+ if (xi_event->evtype == XI_FocusIn
+ || xi_event->evtype == XI_FocusOut)
+ x_focus_changed ((xi_event->evtype == XI_FocusIn
+ ? FocusIn : FocusOut),
+ FOCUS_EXPLICIT,
+ dpyinfo, frame, bufp);
+ else
+#endif
+ if ((xi_event->evtype == XI_Enter
+ || xi_event->evtype == XI_Leave)
+ && (((XIEnterEvent *) xi_event)->detail
+ != XINotifyInferior)
+ && !(focus_state & FOCUS_EXPLICIT))
x_focus_changed ((xi_event->evtype == XI_Enter
- || xi_event->evtype == XI_FocusIn
? FocusIn : FocusOut),
- (xi_event->evtype == XI_Enter
- || xi_event->evtype == XI_Leave
- ? FOCUS_IMPLICIT : FOCUS_EXPLICIT),
+ FOCUS_IMPLICIT,
dpyinfo, frame, bufp);
break;
}