procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge remote-tracking branch 'origin/master' into feature/pgtk

Browse source
This commit is contained in:
Po Lu 2021-12-13 13:32:53 +08:00
commit da2c0e8f7d
8 changed files with 177 additions and 88 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
doc/lispref/text.texi
View file

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

4
etc/NEWS
View file

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

144
lisp/char-fold.el
View file

@ -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))))
(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)
;; 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."

6
lisp/pixel-scroll.el
View file

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

41
lisp/startup.el
View file

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

25
src/sqlite.c
View file

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

2
src/xfns.c
View file

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

28
src/xterm.c
View file

@ -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)))
x_focus_changed ((xi_event->evtype == XI_Enter
|| xi_event->evtype == XI_FocusIn
#ifdef USE_GTK
if (xi_event->evtype == XI_FocusIn
|| xi_event->evtype == XI_FocusOut)
x_focus_changed ((xi_event->evtype == XI_FocusIn
? FocusIn : FocusOut),
(xi_event->evtype == XI_Enter
|| xi_event->evtype == XI_Leave
? FOCUS_IMPLICIT : FOCUS_EXPLICIT),
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
? FocusIn : FocusOut),
FOCUS_IMPLICIT,
dpyinfo, frame, bufp);
break;
}