diff --git a/ChangeLog.3 b/ChangeLog.3 index 18b7b7c11aa..be1a9bfe26a 100644 --- a/ChangeLog.3 +++ b/ChangeLog.3 @@ -1,3 +1,916 @@ +2022-04-13 Tassilo Horn + + dired: implement feature from 7b50ed553f differently + + * lisp/dired.el (dired-buffers-for-dir): Restore to emacs-27 version. + (dired-buffers-for-dir-or-subdir): New function. + (dired-clean-up-after-deletion): Use dired-buffers-for-dir-or-subdir + instead dired-buffers-for-dir. + +2022-04-13 Eli Zaretskii + + Fix regression in 'dired-buffers-for-dir' + + * lisp/dired.el (dired-buffers-for-dir): Fix inadvertently swapped + arguments. (Bug#54636) + +2022-04-13 Eli Zaretskii + + * lisp/desktop.el (desktop-read): Clarify warning text. + +2022-04-13 Po Lu + + * doc/emacs/anti.texi (Antinews): Unannounce removal of Motif. + +2022-04-13 Lars Ingebrigtsen + + Fix eshell-explicit-command-char doc string typo + + * lisp/eshell/esh-ext.el (eshell-explicit-command-char): Fix typo + in doc string (bug#54567). + +2022-04-13 Eli Zaretskii + + Clarify the description of "selected tags table" + + * doc/emacs/maintaining.texi (Select Tags Table): Clarify the + distinction between the "selected tags table" and the "current + list of tags tables". (Bug#54543) + +2022-04-13 Lars Ingebrigtsen + + Add notes about command modes and nativecomp interaction + + * doc/lispref/commands.texi (Command Modes): Note interaction with + native-compile (bug#54437). + + * src/data.c: Add comment about not being supported. + + Do not merge to master. + +2022-04-13 Kyle Meyer + + Update to Org 9.5.2-25-gaf6f12 + +2022-04-13 Eli Zaretskii + + Improve doc strings of read-char-from-minibuffer-insert-* commands + + * lisp/subr.el (read-char-from-minibuffer-insert-char) + (read-char-from-minibuffer-insert-other): Clarify the doc strings. + (Bug#54479) + +2022-04-13 Eli Zaretskii + + Fix region highlight in non-selected windows + + * src/xdisp.c (prepare_menu_bars): Include in the windows passed + to pre-redisplay-functions windows whose point was moved from the + last recorded position. (Bug#54450) + +2022-04-13 Eli Zaretskii + + Fix a regression in 'decipher-digram-list' + + * lisp/play/decipher.el (decipher-stats-buffer): Don't assume the + statistics buffer always exists. (Bug#54443) + +2022-04-13 Karl Fogel + + Improve documentation of bookmark default sorting + + * lisp/bookmark.el (bookmark-alist, bookmark-store, + bookmark-maybe-sort-alist): Update doc strings and comments. + +2022-04-13 Juri Linkov + + * doc/misc/transient.texi: Fix @dircategory to "Emacs misc features" for dir. + +2022-04-13 Jim Porter + + Fix evaluation of negated argument predicates in Eshell + + * lisp/eshell/em-pred.el (eshell-add-pred-func): Let-bind 'pred' so + the lambdas see the original value (bug#54369). + + Committed on the wrong branch. + + Do not merge to master. + +2022-04-13 Eli Zaretskii + + Emacs pretest 28.0.92 + + * README: + * configure.ac: + * nt/README.W32: + * msdos/sed2v2.inp: Bump Emacs version to 28.0.92. + + * etc/AUTHORS: + * lisp/ldefs-boot.el: Update for pretest 28.0.92. + + * ChangeLog.3: Regenerate. + +2022-04-13 Eli Zaretskii + + Fix regression in 'custom-prompt-customize-unsaved-options' + + * lisp/cus-edit.el (custom-prompt-customize-unsaved-options): + Don't depend on the value returned by 'customize-unsaved'. Fix + the doc string. Patch by Sebastian Miele . + (Bug#54329) + +2022-04-13 Eli Zaretskii + + Improve documentation of 'map-charset-chars' + + * doc/lispref/nonascii.texi (Character Sets): + * src/charset.c (Fmap_charset_chars): Clarify the codepoint issue + in using 'map-charset-chars'. + +2022-04-13 Eli Zaretskii + + Avoid assertion violations in 'bidi_resolve_brackets' + + * src/bidi.c (bidi_resolve_brackets): Move assertion to where it + really matters. (Bug#54295) + +2022-04-13 Lars Ingebrigtsen + + Fix which-func-update doc string + + * lisp/progmodes/which-func.el (which-func-update): Make the doc + string match the code (bug#54288). + +2022-04-13 Eli Zaretskii + + Improve wording of 'dired-jump's description + + * doc/emacs/dired.texi (Dired Enter): Clarify wording. Reported + by Natalie . + +2022-04-13 Lars Ingebrigtsen + + Add a comment for previous browse-url-of-dired-file change + + * lisp/net/browse-url.el (browse-url-of-dired-file): Add a comment + for previous change. + +2022-04-13 Lars Ingebrigtsen + + Restore documented Emacs 27.2 behaviour of browse-url-of-dired-file + + * lisp/net/browse-url.el (browse-url-of-dired-file): Restore the + documented behaviour -- open a web browser instead of passing to + the various handlers. + +2022-04-13 Kyle Meyer + + Update to Org 9.5.2-24-g668205 + +2022-04-13 Andreas Schwab + + * lib-src/seccomp-filter.c (main): Use faccessat2 only if defined. + +2022-04-13 Lars Ingebrigtsen + + Fix regression in derived-mode-init-mode-variables + + * lisp/emacs-lisp/derived.el (derived-mode-init-mode-variables): + Fix regression caused by lexical-binding derived.el (bug#54240). + +2022-04-13 Eli Zaretskii + + Avoid crashes when fringe bitmaps are defined in daemon mode + + * src/dispextern.h (gui_define_fringe_bitmap): Add prototype. + (max_used_fringe_bitmap): Add declaration. + * src/fringe.c (gui_define_fringe_bitmap): New function. + * src/w32term.c (w32_draw_fringe_bitmap): + * src/xterm.c (x_draw_fringe_bitmap) [USE_CAIRO]: Call + 'gui_define_fringe_bitmap' if the terminal-specific bitmap data is + not available when a fringe bitmap is about to be drawn. Don't + try to draw a bitmap that is not known to fringe.c. (Bug#54183) + +2022-04-13 Eli Zaretskii + + One more fix of the BPA implementation + + * src/bidi.c (bidi_find_bracket_pairs): Disable BPA optimization + when there are no strong directional characters inside the + bracketed pair. (Bug#54219) + +2022-04-13 Eli Zaretskii + + Fix handling of brackets in BPA + + * src/bidi.c (bidi_resolve_brackets): Fix implementation of UBA's + N0 rule when there are no strong directional characters inside the + bracketed pair. (Bug#54219) + +2022-04-13 Po Lu + + Correct etc/NEWS entry about bitmapped fonts + + * etc/NEWS: Don't say that bitmap font issues are due to Pango, that's + not accurate. + +2022-04-13 Jim Porter + + Improve/correct documentation about Eshell variable expansion + + * lisp/eshell/esh-var.el: Correct documentation comment. + (eshell-parse-variable-ref): Correct docstring. + + * doc/misc/eshell.texi (Dollars Expansion): Add documentation for + $"var"/$'var' and $ syntaxes. + +2022-04-13 Jim Porter + + Partially revert b03f74e0f2a578b1580e8b1c368665850ee7f808 + + That commit regressed '$' forms in Eshell, due to a + limitation/bug in how 'eshell-do-eval' works. This fixes + bug#54190. + + * lisp/eshell/esh-var.el (eshell-parse-variable-ref): Quote a lambda. + + * test/lisp/eshell/eshell-tests.el (eshell-test/interp-temp-cmd): + New test. + +2022-04-13 Paul Eggert + + Backport: Port pre-commit hook to Git 2.35.0 + + * build-aux/git-hooks/pre-commit: Use LC_ALL=C grep -E instead of + sane_egrep (removed in Git 2.35.0). + + (cherry picked from commit b8a96f055624f86fe965a0d1b7b2495b2db80e63) + +2022-04-13 Lars Ingebrigtsen + + Fix :tag for eol in tab-first-completion + + * lisp/indent.el (tab-first-completion): Fix the :tag description + (bug#54179). + +2022-04-13 Kyle Meyer + + Update to Org 9.5.2-22-g33543d + +2022-04-13 Dmitry Gutov + + Add explicit '--no-heading' for ripgrep + + * lisp/progmodes/xref.el (xref-search-program-alist): + Add explicit '--no-heading' for ripgrep (bug#54177). + +2022-04-13 Michael Albinus + + Follow OpenSSH changes in Tramp + + * lisp/net/tramp-sh.el (tramp-ssh-controlmaster-options): + Reimplement. OpenSSH has changed its diagnostics messages. + +2022-04-13 Eli Zaretskii + + Document better how to reset attributes of faces for new frames + + * doc/lispref/display.texi (Attribute Functions): + * lisp/faces.el (set-face-attribute): Explain how to reset an + attribute's value for future frames. (Bug#54156) + +2022-04-13 Michael Albinus + + * lisp/net/tramp-sh.el (tramp-ssh-controlmaster-options): Adapt test. + +2022-04-13 Lars Ingebrigtsen + + Mention flyspell-prog-mode in flyspell-mode doc string + + * lisp/textmodes/flyspell.el (flyspell-mode): Mention + flyspell-prog-mode (bug#54131). + +2022-04-13 Lars Ingebrigtsen + + Reword face-remap-add-relative manual entry + + * doc/lispref/display.texi (Face Remapping): Clarify the + face-remap-add-relative (bug#54114). + +2022-04-13 Philipp Stephani + + Fix indexing of module functions that return enumeration types. + + Return types that consist of more than one word need to be enclosed in + braces, see Info node `(texinfo) Typed Functions'. Otherwise they are + indexed incorrectly. + + * doc/lispref/internals.texi (Module Misc, Module Nonlocal): Enclose + multi-word return types in braces. + +2022-04-13 Eli Zaretskii + + * doc/misc/transient.texi (Other Options): Fix a @ref. (Bug#54108) + +2022-04-13 Glenn Morris + + tramp.texi texinfo 4.13 compatibility + + * doc/misc/tramp.texi (Frequently Asked Questions): + Restore compatibility with Texinfo < 5. + +2022-04-13 Michael Albinus + + Explain "Tramp" spelling in its manual + + * doc/misc/tramp.texi (Frequently Asked Questions): + Explain "Tramp" spelling. + +2022-04-13 Eli Zaretskii + + Fix 'display-line-numbers-mode' in hide-show buffers + + * src/xdisp.c (redisplay_internal): Disable redisplay + optimizations that consider just the current line, when + 'display-line-numbers-mode' is turned on in the buffer. + (Bug#54091) + +2022-04-13 Martin Rudalics + + Don't check whether a deleted window is deletable (Bug#54028) + + * lisp/window.el (window-state-put): Make sure window is live + before calling 'window-deletable-p' on it (Bug#54028). + +2022-04-13 Eli Zaretskii + + A friendlier error message from image-mode in an empty buffer + + * lisp/image-mode.el (image-mode): Handle the case where the empty + buffer doesn't visit a file (Bug#54084) + +2022-04-13 Kyle Meyer + + Update to Org 9.5.2-17-gea6b74 + +2022-04-13 Eli Zaretskii + + Improve documentation of filling and justification commands + + * doc/lispref/text.texi (Filling): + * lisp/textmodes/fill.el (fill-region-as-paragraph) + (default-justification, set-justification, justify-current-line): + Clarify "canonicalization" of spaces and the meaning of + justification styles. (Bug#54047) + (set-justification-left, set-justification-right) + (set-justification-full): Improve wording of doc strings. + +2022-04-13 Eli Zaretskii + + * lisp/progmodes/subword.el (superword-mode): Doc fix. (Bug#54045) + +2022-04-13 Philipp Stephani + + Fix indexing of module functions that return complex types. + + Return types that consist of more than one word need to be enclosed in + braces, see Info node `(texinfo) Typed Functions'. Otherwise they are + indexed incorrectly. + + * doc/lispref/internals.texi (Module Values): Enclose multi-word + return types in braces. + +2022-04-13 Po Lu + + Prevent crashes caused by invalid locale coding systems + + * src/xterm.c (handle_one_xevent): Prevent a signal inside + `setup_coding_system' which crashes recent versions of GLib if + the locale coding system is invalid. + + Do not merge to master. + +2022-04-13 Michael Albinus + + Fix problem with popd for in remote shell buffers + + * lisp/shell.el (shell-prefixed-directory-name): + Use `file-local-name' for DIR. (Bug#53927) + +2022-04-13 Jonas Bernoulli + + Import texi source file for transient manual + + * doc/misc/Makefile.in: Add transient to INFO_COMMON. + * doc/misc/transient.texi: New file. + +2022-04-13 Kyle Meyer + + Update to Org 9.5.2-15-gc5ceb6 + +2022-04-13 Eli Zaretskii + + Fix 'exchange-point-and-mark' in 'transient-mark-mode' + + * lisp/simple.el (exchange-point-and-mark): Don't deactivate mark + when 'transient-mark-mode' is ON. (Bug#53150) + + (cherry picked from commit 415ed4b42515ff2e6dd9b94e964b479e50c6392e) + +2022-04-13 Eli Zaretskii + + Fix "C-SPC C-SPC" after "C-x C-x" + + * lisp/simple.el (exchange-point-and-mark): Fix what the command + does when 'transient-mark-mode' is OFF. (Bug#52896) + + (cherry picked from commit 19c6cad1821eb896b2ddd0f6eab030f0880ea254) + +2022-04-13 Eli Zaretskii + + Fix a typo in fontset.el + + * lisp/international/fontset.el (xlfd-regexp-spacing-subnum): Fix + a typo. Reported by Greg A. Woods . + +2022-04-13 Eli Zaretskii + + Note in ELisp manual that too-wide images are truncated + + * doc/lispref/display.texi (Showing Images): Note that images are + truncated at the window's edge. (Bug#53952) + +2022-04-13 Andrea Corallo + + * lisp/mail/emacsbug.el (report-emacs-bug): Report libgccjit status. + + * lisp/startup.el (normal-top-level): Small code move, improve 202d3be873. + +2022-04-13 Andrea Corallo + + * lisp/startup.el (normal-top-level): Disable native-comp if not available + +2022-04-13 Andrea Corallo + + Fix integer arithmetic miss-compilation (bug#53451) + + * lisp/emacs-lisp/comp-cstr.el (comp-cstr-set-range-for-arithm): + When one of the two sources is negated revert to set dst as + number. + * test/src/comp-tests.el (comp-tests-type-spec-tests): Add test to + verify this is effective. + +2022-04-13 Robert Pluim + + Mark flymake as compatible with emacs-26.1 + + * lisp/progmodes/flymake.el: Bump package version and set + emacs version in Package-Requires to 26.1 (Bug#53853). + +2022-04-13 Brian Leung + + flymake: Ensure compatibility with older Emacsen + + * lisp/progmodes/flymake.el (flymake--log-1): Use + replace-regexp-in-string instead of Emacs 28's + string-replace (bug#53853). + +2022-04-13 Eric Abrahamsen + + Don't remove dummy.group from gnus-newsrc-alist on Gnus save + + bug#53352 + + * lisp/gnus/gnus-start.el (gnus-gnus-to-quick-newsrc-format): This + function was removing dummy.group from the global value of + `gnus-newsrc-alist' on save; we only wanted to remove it temporarily. + +2022-04-13 Bob Rogers + + Fix ietf-drums-get-comment doc string + + * lisp/mail/ietf-drums.el (ietf-drums-get-comment): We really return + the last comment (bug#53810). + +2022-04-13 Daniel Martín + + Fix typo in display.texi + + * doc/lispref/display.texi (Making Buttons): Fix typo. (Bug#53807) + +2022-04-13 Michael Albinus + + Revert an erroneous change in tramp-cache.el + + * lisp/net/tramp-cache.el (tramp-get-hash-table): + Use `string-match-p' instead of `string-search'. The latter one + was introduced by accident. Reported by Kai Tetzlaff . + +2022-04-13 Eli Zaretskii + + Improve documentation of 'emacs-version' + + * doc/emacs/trouble.texi (Checklist): Mention the possibility of + invoking 'emacs-version' with a prefix argument. + + * lisp/version.el (emacs-version): Improve doc string. (Bug#53720) + +2022-04-13 Michael Albinus + + * etc/NEWS: Apply final fixes after proofreading. + +2022-04-13 Eli Zaretskii + + Clarify documentation of a "face's font" + + * doc/lispref/display.texi (Attribute Functions) + (Face Attributes): Clarify that the :font attribute of a face and + the font returned by 'face-font' are by default for ASCII + characters. (Bug#53664) + +2022-04-13 Alan Mackenzie + + Bind Qdebugger to Qdebug in signal_or_quit. + + * src/eval.c (signal_or_quit): Bind the correct variable, Qdebugger (not + Vdebugger) to Qdebug in the section for errors in batch jobs. + (syms_of_eval): New DEFSYM for Qdebugger. + +2022-04-13 Kyle Meyer + + Update to Org 9.5.2-13-gdd6486 + +2022-04-13 Eli Zaretskii + + Fix regression in Occur Edit mode + + * lisp/replace.el (occur-after-change-function): Fix the algorithm + to find the smallest change in some corner cases. (Bug#53598) + +2022-04-13 Eli Zaretskii + + Fix last change of Malayalam composition rules + + * lisp/language/indian.el (malayalam-composable-pattern): + Reinstate. Instead of removing it, add any sequence of + Malayalam characters to the existing patterns, so as not + to lose the patterns that use ZWJ and ZWNJ. (Bug#53625) + +2022-04-13 Eli Zaretskii + + Fix rendering of Malayalam script + + * lisp/language/indian.el (malayalam-composable-pattern): Remove. + (script-regexp-alist): Remove 'malayalam-composable-pattern'. + Instead, pass any sequence of Malayalam codepoints to the shaping + engine. (Bug#53625) + +2022-04-13 Eli Zaretskii + + Improve documentation of Occur mode + + * doc/emacs/search.texi (Other Repeating Search): Improve wording + and document Occur Edit mode better. + +2022-04-13 Alan Third + + Remove debug logging + + * src/nsterm.m ([EmacsView copyRect:to:]): Remove logging as it's no + longer required. + +2022-04-13 Michael Albinus + + Fix error in filelock.c + + * src/filelock.c (lock_file): Move call of file name handler to + `Flock_file'. Determine lock_filename only in case + create_lockfiles is non-nil. Adapt the rest of the function accordingly. + (Flock_file): Do not check for create_lockfiles. Call file name + handler if appropriate. (Bug#53207) + +2022-04-13 Juri Linkov + + * lisp/frame.el (clone-frame): Filter out 'parent-id' (bug#51883). + +2022-04-13 Lars Ingebrigtsen + + Partially revert a fill-region-as-paragraph regression + + * lisp/textmodes/fill.el (fill-region-as-paragraph): Revert + e186af261 (bug#53537), because it leads to regressions. (But + leave tests in place.) + +2022-04-13 Eli Zaretskii + + Fix 'make_lispy_position' when there's an image at EOB + + * src/xdisp.c (move_it_to): Don't compare IT_CHARPOS with an + invalid TO_CHARPOS. (Bug#53546) + +2022-04-13 Lars Ingebrigtsen + + Fix copyright-find-copyright when searching from the end + + * lisp/emacs-lisp/copyright.el (copyright-find-copyright): Make + the double check also work when searching from the end (bug#7179). + + Do not merge to master. + +2022-04-13 Lars Ingebrigtsen + + Fix copyright.el comment and add a test + + * lisp/emacs-lisp/copyright.el (copyright-find-copyright): Fix + comment (bug#7179). + + Do not merge to master. + +2022-04-13 Philipp Stephani + + * configure.ac (LIBSECCOMP): Bump minimum version for faccessat2. + +2022-04-13 Lars Ingebrigtsen + + Make the `f' command work in image-mode again + + * lisp/image.el (image-show-frame): Protect against not having + computed the animation data yed (bug#53489). + +2022-04-13 Philipp Stephani + + Seccomp: improve support for newer versions of glibc (Bug#51073) + + * lib-src/seccomp-filter.c (main): Allow 'pread64' and 'faccessat2' + system calls. Newer versions of glibc use these system call (starting + with commits 95c1056962a3f2297c94ce47f0eaf0c5b6563231 and + 3d3ab573a5f3071992cbc4f57d50d1d29d55bde2, respectively). + +2022-04-13 Thomas Fitzsimmons + + EUDC: Fix a quoting bug in the BBDB backend + + * lisp/net/eudcb-bbdb.el (eudc-bbdb-query-internal): Fix a quoting + bug introduced during lexical-binding conversion. + +2022-04-13 Sergey Vinokurov + + Fix memory-report-object-size to initialize memory-report--type-size + + * lisp/emacs-lisp/memory-report.el (memory-report-object-size): + Allow using function directly (bug#53310). + + Do not merge to master. + +2022-04-13 Stefan Monnier + + Fix menu-bar mouse clicks in "C-h c" and "C-h k" (bug#53322) + + * lisp/subr.el (event-start, event-end): Handle '(menu-bar)' + events. + * lisp/net/browse-url.el (browse-url-interactive-arg): Simplify + accordingly. + + (cherry picked from commit 9ceb3070e34ad8a54184fd0deda477bf5ff77000) + +2022-04-13 Eli Zaretskii (tiny change) + + Fix UB in ebrowse + + * lib-src/ebrowse.c (matching_regexp): Avoid writing beyond the + limits of 'matching_regexp_buffer'. Patch by Jan Stranik + . (Bug#53333) + +2022-04-13 Lars Ingebrigtsen + + Fix execute-extended-command-for-buffer in fundamental-mode + + * lisp/simple.el (execute-extended-command-for-buffer): Protect + against the current local map being nil (bug#52907). + +2022-04-13 Martin Rudalics + + Add workaround to handle a problem with Enlightenment WM (Bug#53298) + + * src/xterm.c (handle_one_xevent): Handle setting of variable + 'x_set_frame_visibility_more_laxly' when receiving an Expose or + FocusIn event (Bug#53298). + (Qexpose): Define symbol. + (x_set_frame_visibility_more_laxly): New Lisp variable. + * etc/PROBLEMS: Mention frame redraw problem with the + Enlightenment WM and 'x-set-frame-visibility-more-laxly' + workaround. + +2022-04-13 Po Lu + + Fix regression leading to flickering tooltips when the mouse is moved + + * lisp/tooltip.el (tooltip-show-help): Compare string with + previous tooltip string ignoring properties. + +2022-04-13 Andrea Corallo + + * Fix native comp for non trivial function names (bug#52833) + + * lisp/emacs-lisp/comp.el (comp-c-func-name): Fix native compilation + for functions with function names containing non trivial + characters (bug#52833). + + This commit is the backport of e7699bf290. + + Do not merge to master + +2022-04-13 Kyle Meyer + + Update to Org 9.5.2-9-g7ba24c + +2022-04-13 Juri Linkov + + * lisp/net/dictionary.el (dictionary-context-menu): Use package prefix. + +2022-04-13 Philipp Stephani + + Mark a few more map tests as unstable on Emacs 28 (Bug#46722). + + At least for me, these tests still occasionally fail. + + Do not merge to master. + + * test/lisp/emacs-lisp/map-tests.el (test-map-into-hash-test) + (test-map-merge, test-map-merge-with, test-map-merge-empty): Mark as + unstable. + +2022-04-13 Philipp Stephani + + * lisp/indent.el (tab-first-completion): Fix incorrect choices. + +2022-04-13 Philipp Stephani + + * lisp/simple.el (undo-no-redo): Fix customization group + + * lisp/progmodes/xref.el (xref-file-name-display): Fix docstring. + +2022-04-13 Eli Zaretskii + + Avoid another segfault in 'face_at_buffer_position' + + * src/xfaces.c (face_at_buffer_position): Make really sure the + default face is usable. (Bug#53254) + +2022-04-13 Lars Ingebrigtsen + + Mark test-map-into as unstable + + * test/lisp/emacs-lisp/map-tests.el (test-map-into): Mark as + unstable (bug#46722). + + Do not merge to master. + +2022-04-13 Philipp Stephani + + Fix Edebug specification for inline functions (Bug#53068). + + * lisp/emacs-lisp/inline.el (inline-quote): Fix Edebug specification. + + * test/lisp/emacs-lisp/edebug-tests.el (edebug-tests-inline): New unit + test. + +2022-04-13 N. Jackson + + Remove mention of removed `gnus-treat-play-sounds' variable from manual + + * info/gnus.info: Remove `gnus-treat-play-sounds' from + manual. According to lisp/gnus/ChangeLog.3 this variable was + removed in 2010 (bug#53192). + +2022-04-13 Mattias Engdegård + + Revert "Fix closure-conversion of shadowed captured lambda-lifted vars" + + This reverts commit 3ec8c8b3ae2359ceb8135b672e86526969c16b7e. + + It was committed to a stable branch without prior discussion; + see bug#53071. + +2022-04-13 Juri Linkov + + * doc/lispref/windows.texi (Textual Scrolling): Remove obsolete text. + + Remove text about scrolling the minibuffer from the buffer, + obsolete since Emacs 27 (bug#51210). + +2022-04-13 Glenn Morris + + * lisp/files.el (lock-file-name-transforms): Doc tweaks. + +2022-04-13 Mattias Engdegård + + Fix closure-conversion of shadowed captured lambda-lifted vars + + Lambda-lifted variables (ones passed explicitly to lambda-lifted + functions) that are also captured in an outer closure and shadowed + were renamed incorrectly (bug#51982). + + Reported by Paul Pogonyshev. + + * lisp/emacs-lisp/cconv.el (cconv--lifted-arg): New. + (cconv-convert): Provide correct definiens for the closed-over + variable. + * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--test-cases): + * test/lisp/emacs-lisp/cconv-tests.el (cconv-tests--intern-all) + (cconv-closure-convert-remap-var): Add tests. + + (cherry picked from commit 45252ad8f932c98a373ef0ab7f3363a3e27ccbe4) + +2022-04-13 Philipp Stephani + + Fix test lisp/cedet/semantic/bovine/gcc-tests on macOS (Bug#52431) + + * test/lisp/cedet/semantic/bovine/gcc-tests.el + (semantic-gcc-test-output-parser-this-machine): Also detect Apple + clang on macOS Monterey. + + (cherry picked from commit 6e52becfbe2a33c025b8c4838b3c8f06ba5a6fb8) + +2022-04-13 Mattias Engdegård + + Don't fail flymake-tests if `gcc` actually is Clang + + * test/lisp/progmodes/flymake-tests.el (flymake-tests--gcc-is-clang) + (different-diagnostic-types, included-c-header-files): Skip tests that + depend on the `gcc` command really being GCC and not Clang. + + (cherry picked from commit b2167d98432a78442522b7564e22f47d75a98b6f) + +2022-04-13 Eli Zaretskii + + Revert "Remove the filename argument from the command line after an ELC+ELN build" + + This reverts commit ffc047c896413b6e00032518fc934f08768671fa. + + Please don't install anything non-trivial on the release branch + without asking first. + +2022-04-13 Alan Mackenzie + + Remove the filename argument from the command line after an ELC+ELN build + + This fixes bug #53164. Without this fix, bootstrap-emacs loads the source + file uselessly into a buffer after completing the compilation. + +2022-04-13 Stefan Monnier + + (save-some-buffers): Simplify the fix for bug#46374 + + * lisp/files.el (save-some-buffers): Only check the + `save-some-buffers-function` property on functions from + `save-some-buffers-default-predicate` since callers which provide + a `pred` argument can arrange to compute `pred` themselves if needed. + + * test/lisp/files-tests.el (files-tests-buffer-offer-save): Don't test + with `pred` set to `save-some-buffers-root` since it's not an + appropriate function for that any more. + +2022-04-13 Stefan Kangas + + Improve docstring of edit-abbrevs + + * lisp/abbrev.el (edit-abbrevs): Doc fix; don't use obsolete name. + Improve docstring formatting. + +2022-04-13 Eli Zaretskii + + Revert "Fix alignment on font size change in tabulated-list-mode" + + This reverts commit 2767c89db729a6106146d0aeff76678c64d4fc53. + + That change caused a regression in a much more important use + case, see bug#53133. + +2022-04-13 Stefan Kangas + + Clarify docstring of package-native-compile + + * lisp/emacs-lisp/package.el (package-native-compile): Clarify + docstring. + +2022-04-13 Eli Zaretskii + + Fix Subject "simplification" in Rmail + + * lisp/mail/rmail.el (rmail-simplified-subject): Match against + "[external]" _after_ decoding the Subject by RFC-2047. + +2022-04-13 Stefan Kangas + + Bump Emacs version to 28.0.91 + + * README: + * configure.ac: + * msdos/sed2v2.inp: + * nt/README.W32: Bump Emacs version to 28.0.91. + 2022-01-05 Dmitry Gutov Fix vc-git with old Git over Tramp and cygwin-mount.el @@ -234065,6 +234978,7 @@ This file records repository revisions from commit 9d56a21e6a696ad19ac65c4b405aeca44785884a (exclusive) to +2022-04-13e39829812098d8269eafbc0fcb98959ee5bb7 (inclusive). commit e7aa3ece52d26cc7e4d3f3990aff56127389779f (inclusive). See ChangeLog.2 for earlier changes. diff --git a/INSTALL b/INSTALL index b1e3c72c4bf..95d2dbda80c 100644 --- a/INSTALL +++ b/INSTALL @@ -243,6 +243,11 @@ This build is only supported with GTK+ version 3, and it is an error to specify any other X-specific configuration option when PGTK is enabled. +If you use exclusively X, do not use the PGTK port. There are a +number of respects in which the regular --with-x-toolkit=gtk build +works better. The PGTK port should not be considered a simple upgrade +from --with-x-toolkit=gtk. + With the PGTK build, you will be able to switch between running Emacs on X, Wayland and Broadway using the 'GDK_BACKEND' environment variable. GTK+ should automatically detect and use the correct value @@ -353,9 +358,9 @@ Use --without-toolkit-scroll-bars to disable Motif or Xaw3d scroll bars. Use --without-xim to inhibit the default use of X Input Methods. In this case, the X resource useXIM can be used to turn on use of XIM. -Use --with-xinput2 to enable the use of version 2 of the X Input -Extension. This enables support for touchscreens, pinch gestures, and -scroll wheels that report scroll deltas at pixel-level precision. +Use --without-xinput2 to disable the use of version 2 of the X Input +Extension. This disables support for touchscreens, pinch gestures, +and scroll wheels that report scroll deltas at pixel-level precision. Use --disable-largefile to omit support for files larger than 2GB, and --disable-year2038 to omit support for timestamps past the year 2038, diff --git a/admin/CPP-DEFINES b/admin/CPP-DEFINES index 620ab0bed05..06986ec8f48 100644 --- a/admin/CPP-DEFINES +++ b/admin/CPP-DEFINES @@ -24,6 +24,7 @@ DARWIN_OS Compiling on macOS or pure Darwin (and using s/darwin.h). SOLARIS2 USG USG5_4 +HAIKU Compiling on Haiku. ** Distinguishing GUIs ** @@ -32,16 +33,38 @@ HAVE_NS Use the NeXT/OpenStep/Cocoa UI under macOS or GNUstep. NS_IMPL_GNUSTEP Compile support for GNUstep implementation of NS GUI API. NS_IMPL_COCOA Compile support for Cocoa (Apple) implementation of NS GUI API. HAVE_X11 Compile support for the X11 GUI. +HAVE_PGTK Compile support for using GTK itself without directly using X Windows APIs. +HAVE_HAIKU Compile support for the Haiku window system. HAVE_X_WINDOWS Compile support for X Window system (It looks like, nowadays, if HAVE_X11 is set, HAVE_X_WINDOWS must be, and vice versa. At least, this is true for configure, and msdos; not sure about nt.) -HAVE_X11R6 -HAVE_X11R6_XIM -HAVE_X11XTR6 + +** X Windows features ** +HAVE_X11R6 Whether or not the system has X11R6. (Always defined.) +HAVE_X11R6_XIM Whether or not the system supports XIM features introduced in R6. +HAVE_X11XTR6 Whether or not the Xt is from X11R6 or newer. + USE_LUCID Use the Lucid toolkit for menus&scrollbars. Requires HAVE_X11. USE_MOTIF Use the Motif toolkit for menus&scrollbars. Requires HAVE_X11. -USE_GTK Use the Gtk toolkit for menus&scrollbars. Requires HAVE_X11. +USE_GTK Use the Gtk toolkit for menus&scrollbars. Requires HAVE_X11 or HAVE_PGTK. +HAVE_GTK3 Use GTK version 3 or later. Requires HAVE_X11. + +HAVE_XCB_SHAPE Whether or not XCB supports the Nonrectangular Window Shape extension. +HAVE_XCOMPOSITE Whether or not the XCOMPOSITE extension library is present. +HAVE_XDBE Whether or not to use the Xdbe extension for double buffering. +HAVE_XFIXES Whether or not the Xfixes extension library is present. +HAVE_XINERAMA Whether or not the Xinerama extension library is present. +HAVE_XINPUT2 Whether or not to use version 2 of the X Input Extension for input. +HAVE_XINPUT2_1 Whether or not version 2.1 of the X Input Extension is supported. +HAVE_XINPUT2_2 Whether or not version 2.2 of the X Input Extension is supported. +HAVE_XINPUT2_3 Whether or not version 2.3 of the X Input Extension is supported. +HAVE_XINPUT2_4 Whether or not version 2.4 of the X Input Extension is supported. +HAVE_XKB Whether or not the XKB extension library is present. +HAVE_XRANDR Whether or not the RandR extension library is present. +HAVE_XSHAPE Whether or not the Nonrectangular Window Shape extension library is present. +HAVE_XSYNC Whether or not the X Synchronization Extension library is present. +USE_XCB Whether or not the XCB library is used to optimize some X requests. ** Frame types ** diff --git a/admin/admin.el b/admin/admin.el index 5f02ea8ce45..8c68b181831 100644 --- a/admin/admin.el +++ b/admin/admin.el @@ -602,76 +602,81 @@ style=\"text-align:left\">") (forward-line 1) (setq done t))))) (let (done open-td tag desc) - ;; Convert the list that Makeinfo made into a table. - (or (search-forward "
    " nil t) - ;; FIXME? The following search seems dangerously lax. - (search-forward "
      ")) - (replace-match "") - (forward-line 1) - (while (not done) - (cond - ((or (looking-at "
    • \\(\\):[ \t]+\\(.*\\)$") - (looking-at "
    • \\(\\)$")) - (setq tag (match-string 1)) - (setq desc (match-string 2)) - (replace-match "" t t) - (when open-td - (save-excursion - (forward-char -1) - (skip-chars-backward " ") - (delete-region (point) (line-end-position)) - (insert "\n "))) - (insert "
      • \n ") - (if table-workaround - ;; This works around a Firefox bug in the mono file. - (insert "\n
      ") - (insert "")) - (insert tag "" (or desc "")) - (setq open-td t)) - ((eq (char-after) ?\n) - (delete-char 1) - ;; Negate the following `forward-line'. - (forward-line -1)) - ((looking-at "")) - ((looking-at "

      [- ]*The Detailed Node Listing[- \n]*") - (replace-match "

      \n + ;; Texinfo 6.8 and later doesn't produce
        lists + ;; for the TOC menu, and the "description" part of each menu + ;; item is not there anymore. So for HTML manuals produced by + ;; those newer versions of Texinfo we punt and leave the menu in + ;; its original form. + (when (or (search-forward "
          " nil t) + ;; FIXME? The following search seems dangerously lax. + (search-forward "
            ")) + ;; Convert the list that Makeinfo made into a table. + (replace-match "") + (forward-line 1) + (while (not done) + (cond + ((or (looking-at "
          • \\(\\):[ \t]+\\(.*\\)$") + (looking-at "
          • \\(\\)$")) + (setq tag (match-string 1)) + (setq desc (match-string 2)) + (replace-match "" t t) + (when open-td + (save-excursion + (forward-char -1) + (skip-chars-backward " ") + (delete-region (point) (line-end-position)) + (insert "\n "))) + (insert "
            • \n ") + (if table-workaround + ;; This works around a Firefox bug in the mono file. + (insert "\n
            ") + (insert "")) + (insert tag "" (or desc "")) + (setq open-td t)) + ((eq (char-after) ?\n) + (delete-char 1) + ;; Negate the following `forward-line'. + (forward-line -1)) + ((looking-at "")) + ((looking-at "

            [- ]*The Detailed Node Listing[- \n]*") + (replace-match "

            \n

            Detailed Node Listing

            \n\n" t t) - (search-forward "

            ") - ;; FIXME Fragile! - ;; The Emacs and Elisp manual have some text at the - ;; start of the detailed menu that is not part of the menu. - ;; Other manuals do not. - (if (looking-at "Here are some other nodes") - (search-forward "

            ")) - (goto-char (match-beginning 0)) - (skip-chars-backward "\n ") - (setq open-td nil) - (insert "

            \n\n")) - ((looking-at "") - (replace-match "" t t)) - ((looking-at "

            ") - (replace-match "" t t) - (when open-td - (insert " ") - (setq open-td nil)) - (insert "

            + (search-forward "

            ") + ;; FIXME Fragile! + ;; The Emacs and Elisp manual have some text at the + ;; start of the detailed menu that is not part of the menu. + ;; Other manuals do not. + (if (looking-at "Here are some other nodes") + (search-forward "

            ")) + (goto-char (match-beginning 0)) + (skip-chars-backward "\n ") + (setq open-td nil) + (insert "

            \n\n
            ")) + ((looking-at "") + (replace-match "" t t)) + ((looking-at "

            ") + (replace-match "" t t) + (when open-td + (insert " ") + (setq open-td nil)) + (insert "

            "))) - ((looking-at "[ \t]*[ \t]*$") - (replace-match - (if open-td - " \n
            ") - (if (re-search-forward "

            [ \t\n]*
              " nil t) - (replace-match "
            " - "") t t) - (setq done t)) - (t - (if (eobp) - (error "Parse error in %s" - (file-name-nondirectory buffer-file-name))) - (unless open-td - (setq done t)))) - (forward-line 1))))) + (if (re-search-forward "

            [ \t\n]*
              " nil t) + (replace-match " "))) + ((looking-at "[ \t]*
            [ \t]*$") + (replace-match + (if open-td + " \n" + "") t t) + (setq done t)) + (t + (if (eobp) + (error "Parse error in %s" + (file-name-nondirectory buffer-file-name))) + (unless open-td + (setq done t)))) + (forward-line 1)))))) (defconst make-manuals-dist-output-variables diff --git a/admin/authors.el b/admin/authors.el index 342f2718c84..8a62520d6c5 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -68,6 +68,7 @@ files.") (nil "castor@my-dejanews") (nil "chengang31@gmail.com") (nil "chuntaro") + ("Clément Pit-Claudel" "Clément Pit--Claudel") ("David Abrahams" "Dave Abrahams") ("David J. Biesack" "David Biesack") ("David De La Harpe Golden" "David Golden") @@ -242,10 +243,14 @@ files.") ("Vinicius Jose Latorre" "viniciusjl") ("Gaby Launay" "galaunay") ("Dick R. Chiang" "dickmao") + ("Lin Zhou" "georgealbert@qq.com") + (nil "yan@metatem.net") + (nil "gnu_lists@halloleo.hailmail.net") ) "Alist of author aliases. -Each entry is of the form (REALNAME REGEXP...). If an author's name +Each entry is of the form (REALNAME REGEXP...). +If an author's full name, as in \"J.R.Hacker \", matches one of the REGEXPs, use REALNAME instead. If REALNAME is nil, ignore that author.") @@ -498,6 +503,7 @@ Changes to files matching one of the regexps in this list are not listed.") "nextstep/WISHLIST" ;; Removed, replaced by gitmerge.el "admin/bzrmerge.el" + "bzrmerge.el" ;; Removed in commit f5090b91299 "lib/fdatasync.c" ;; Removed as obsolete @@ -512,8 +518,11 @@ Changes to files matching one of the regexps in this list are not listed.") "MORE.STUFF" "notes/font-backend" "src/ftxfont.c" + "ftxfont.c" "src/ptr-bounds.h" "obsolete/options.el" + "obsolete/old-whitespace.el" + "obsolete/lucid.el" ;; ada-mode has been deleted, now in GNU ELPA "ada-mode.texi" "doc/misc/ada-mode.texi" @@ -874,11 +883,9 @@ Changes to files in this list are not listed.") "gnus-compat.el" "pgg-parse.el" "pgg-pgp.el" "pgg-pgp5.el" "pgg.el" "dns-mode.el" "run-at-time.el" "gnus-encrypt.el" "sha1-el.el" "gnus-gl.el" "gnus.sum.el" "proto-stream.el" "color.el" "color-lab.el" - "eww.el" "shr-color.el" "shr.el" "earcon.el" "gnus-audio.el" "encrypt.el" - "format-spec.el" "gnus-move.el" "gnus-sync.el" - "auth-source.el" "ecomplete.el" "gravatar.el" "mailcap.el" "plstore.el" - "pop3.el" "qp.el" "registry.el" "rfc2231.el" "rtree.el" - "sieve.el" "sieve-mode.el" "gnus-ems.el" + "earcon.el" "gnus-audio.el" "encrypt.el" + "gnus-move.el" "gnus-sync.el" + "gnus-ems.el" ;; doc "getopt.c" "texindex.c" "news.texi" "vc.texi" "vc2-xtra.texi" "back.texi" "vol1.texi" "vol2.texi" "elisp-covers.texi" "two.el" @@ -959,6 +966,43 @@ in the repository.") ;; NB So only add a directory if needed to disambiguate. ;; FIXME? ;; Although perhaps we could let authors-disambiguate-file-name do that? +;; +;; WARNING: The semantics of these entries is tricky to grasp without +;; reading the code! +;; The rule is: for every file that was renamed or moved to another +;; directory, add an entry (OLD-NAME . NEW-BASENAME), where OLD-NAME +;; is the old name of the file as it appears in the ChangeLog files, +;; and NEW-BASENAME is the _basename_ of its new name. Yes, this +;; means that a file which was moved to another directory but kept its +;; basename will have a seemingly-silly entry ("foo" . "foo"). (Told +;; you: this is tricky!) If the moved/renamed file was mentioned in +;; several ChangeLog files with different leading directories, you +;; need to provide an entry for each such instance. For example, if +;; some ChangeLog mentioned a moved file as lisp/gnus/something.el and +;; another ChangeLog mentioned it as gnus/something.el, you need to +;; have two entries: +;; +;; ("gnus/something.el" . "something.el") +;; ("lisp/gnus/something.el" . "something.el") +;; +;; The important part is that the car of the entry should be identical +;; to how a file was mentioned in the respective ChangeLog. It is +;; advisable to run a Grep command such as +;; +;; fgrep -R BASENAME . --include='ChangeLog*' +;; +;; where BASENAME is the old basename of the renamed file. This will +;; show all the different reference forms of the file in the various +;; ChangeLog* files, and you can then prepare a separate entry for +;; each reference form. +;; +;; The cdr of the entry should generally be only the basename of the +;; file's current name, because that's how AUTHORS references files. +;; It _can_ have leading directories, but that is only +;; needed/advisable if there are several files in the tree that have +;; the same basename, and you want to disambiguate them, so that +;; people who actually contributed to different files aren't mentioned +;; as if they contributed to the same single file. (defconst authors-renamed-files-alist '(("nt.c" . "w32.c") ("nt.h" . "w32.h") ("ntheap.c" . "w32heap.c") ("ntheap.h" . "w32heap.h") @@ -966,8 +1010,9 @@ in the repository.") ("ntproc.c" . "w32proc.c") ("w32console.c" . "w32term.c") ("unexnt.c" . "unexw32.c") - ("s/windowsnt.h" . "s/ms-w32.h") - ("s/ms-w32.h" . "inc/ms-w32.h") + ("m/windowsnt.h" . "ms-w32.h") + ("s/windowsnt.h" . "ms-w32.h") + ("s/ms-w32.h" . "ms-w32.h") ("src/config.h" . "config.h") ("winnt.el" . "w32-fns.el") ("linux.h" . "gnu-linux.h") @@ -990,6 +1035,10 @@ in the repository.") ("INSTALL.MSYS" . "INSTALL") ("server.c" . "emacsserver.c") ("lib-src/etags.c" . "etags.c") + ;; gnulib + ("lib/strftime.c" . "nstrftime.c") + ("src/mini-gmp.c" . "mini-gmp.c") + ("src/mini-gmp.h" . "mini-gmp.h") ;; msdos/ ("is-exec.c" . "is_exec.c") ("enriched.doc" . "enriched.txt") @@ -1073,8 +1122,10 @@ in the repository.") ("nxml/test.invalid.xml" . "test-invalid.xml") ("nxml/test.valid.xml" . "test-valid.xml") ("automated/Makefile.in" . "test/Makefile.in") - ("test/rmailmm.el" . "test/manual/rmailmm.el") - ("rmailmm.el" . "test/manual/rmailmm.el") + ;; rmailmm tests wandered from test/ to test/manual to test/lisp/mail/ + ("rmailmm.el" . "rmailmm-tests.el") + ("test/rmailmm.el" . "rmailmm-tests.el") + ("test/manual/rmailmm.el" . "rmailmm-tests.el") ;; The one in lisp is eshell/eshell.el. ("eshell.el" . "eshell-tests.el") ("automated/eshell.el" . "eshell-tests.el") @@ -1106,22 +1157,79 @@ in the repository.") ("major.texi" . "modes.texi") ("msdog-xtra.texi" . "msdos-xtra.texi") ("msdog.texi" . "msdos.texi") + ;; Moved from lisp/gnus/ to lisp/ + ("auth-source.el" . "auth-source.el") + ("lisp/gnus/auth-source.el" . "auth-source.el") + ("ecomplete.el" . "ecomplete.el") + ("format-spec.el" . "format-spec.el") + ("gnus/format-spec.el" . "format-spec.el") + ("lisp/gnus/ecomplete.el" . "ecomplete.el") + ("plstore.el" . "plstore.el") + ("lisp/gnus/plstore.el" . "plstore.el") + ("registry.el" . "registry.el") + ("lisp/gnus/registry.el" . "registry.el") + ("rtree.el" . "rtree.el") ;; Moved from lisp/gnus/ to lisp/calendar/ - ("time-date.el" . "calendar/time-date.el") + ("time-date.el" . "time-date.el") ;; Moved from lisp/gnus/ to lisp/mail/ - ("binhex.el" . "mail/binhex.el") - ("uudecode.el" . "mail/uudecode.el") - ("mail-parse.el" . "mail/mail-parse.el") - ("yenc.el" . "mail/yenc.el") - ("flow-fill.el" . "mail/flow-fill.el") - ("ietf-drums.el" . "mail/ietf-drums.el") - ("sieve-manage.el" . "mail/sieve-manage.el") + ("binhex.el" . "binhex.el") + ("gnus/binhex.el" . "binhex.el") + ("uudecode.el" . "uudecode.el") + ("gnus/uudecode.el" . "uudecode.el") + ("mail-parse.el" . "mail-parse.el") + ("gnus/mail-parse.el" . "mail-parse.el") + ("mail-prsvr.el" . "mail-prsvr.el") + ("gnus/mail-prsvr.el" . "mail-prsvr.el") + ("yenc.el" . "yenc.el") + ("flow-fill.el" . "flow-fill.el") + ("gnus/flow-fill.el" . "flow-fill.el") + ("ietf-drums.el" . "ietf-drums.el") + ("gnus/ietf-drums.el" . "ietf-drums.el") + ("pop3.el" . "pop3.el") + ("mail/pop3.el" . "pop3.el") + ("gnus/pop3.el" . "pop3.el") + ("lisp/gnus/pop3.el" . "pop3.el") + ("qp.el" . "qp.el") + ("gnus/qp.el" . "qp.el") + ("lisp/gnus/qp.el" . "qp.el") + ("rfc2045.el" . "rfc2045.el") + ("gnus/rfc2045.el" . "rfc2045.el") + ("rfc2047.el" . "rfc2047.el") + ("gnus/rfc2047.el" . "rfc2047.el") + ("rfc2231.el" . "rfc2231.el") + ("gnus/rfc2231.el" . "rfc2231.el") + ("lisp/gnus/rfc2231.el" . "rfc2231.el") ;; Moved from lisp/gnus/ to lisp/image/ - ("compface.el" . "image/compface.el") + ("compface.el" . "compface.el") + ("gravatar.el" . "gravatar.el") + ("lisp/gnus/gravatar.el" . "gravatar.el") ;; Moved from lisp/gnus/ to lisp/net/ + ("eww.el" . "eww.el") + ("net/eww.el" . "eww.el") + ("lisp/new/eww.el" . "eww.el") ; an actual typo in ChangeLog.3 + ("gssapi.el" . "gssapi.el") + ("lisp/gnus/gssapi.el" . "gssapi.el") ("imap.el" . "net/imap.el") + ("mailcap.el" . "mailcap.el") + ("gnus/mailcap.el" . "mailcap.el") + ("lisp/gnus/mailcap.el" . "mailcap.el") ("rfc2104.el" . "net/rfc2104.el") - ("starttls.el" . "net/starttls.el") + ("starttls.el" . "starttls.el") + ("lisp/net/starttls.el" . "starttls.el") ; moved to obsolete/ + ("shr.el" . "shr.el") + ("net/shr.el" . "shr.el") + ("shr-color.el" . "shr-color.el") + ("sieve-manage.el" . "sieve-manage.el") + ("sieve-mode.el" . "sieve-mode.el") + ("sieve.el" . "sieve.el") + ("lisp/gnus/sieve-manage.el" . "sieve-manage.el") + ("lisp/gnus/sieve-mode.el" . "sieve-mode.el") + ("lisp/gnus/sieve.el" . "sieve.el") + ;; Moved from lisp/gnus/ to lisp/international + ("rfc1843.el" . "rfc1843.el") + ("gnus/rfc1843.el" . "rfc1843.el") + ("utf7.el" . "utf7.el") + ("gnus/utf7.el" . "utf7.el") ;; And from emacs/ to misc/ and back again. ("ns-emacs.texi" . "macos.texi") ("overrides.texi" . "gnus-overrides.texi") @@ -1136,7 +1244,7 @@ in the repository.") ("ED.WORSHIP" . "JOKES") ("GNU.JOKES" . "JOKES") ("CHARACTERS" . "TODO") - ("lisp/character-fold.el" . "lisp/char-fold.el") + ("lisp/character-fold.el" . "char-fold.el") ("test/automated/character-fold-tests.el" . "char-fold-tests.el") ("test/automated/char-fold-tests.el" . "char-fold-tests.el") ("test/lisp/character-fold-tests.el" . "char-fold-tests.el") @@ -1178,7 +1286,8 @@ in the repository.") ("grammars" . "grammars") ;; Moved from lisp/emacs-lisp/ to admin/. ("emacs-lisp/authors.el" . "authors.el") - ("emacs-lisp/find-gc.el" . "admin/find-gc.el") + ("find-gc.el" . "find-gc.el") + ("emacs-lisp/find-gc.el" . "find-gc.el") ;; From etc to lisp/cedet/semantic/. ("grammars/bovine-grammar.el" . "bovine/grammar.el") ("grammars/wisent-grammar.el" . "wisent/grammar.el") @@ -1186,28 +1295,41 @@ in the repository.") ("nt/README.W32" . "README.W32") ("notes/BRANCH" . "notes/repo") ("notes/bzr" . "notes/repo") - ;; moved from lisp/ to lisp/net/ - ("lisp/pinentry.el" . "lisp/net/pinentry.el") + ;; moved from lisp/ to lisp/net/, then removed + ("pinentry.el" . "pinentry.el") + ("lisp/pinentry.el" . "pinentry.el") + ("lisp/net/pinentry.el" . "pinentry.el") ;; module.* moved to emacs-module.* - ("src/module.h" . "src/emacs-module.h") - ("src/module.c" . "src/emacs-module.c") - ;; gnulib - ("lib/strftime.c" . "lib/nstrftime.c") - ("test/src/regex-tests.el" . "test/src/regex-emacs-tests.el") - ("test/lisp/emacs-lisp/cl-tests.el" . "test/lisp/obsolete/cl-tests.el") - ("lisp/net/starttls.el" . "lisp/obsolete/starttls.el") - ("url-ns.el" . "lisp/obsolete/url-ns.el") - ("gnus-news.texi" . "doc/misc/gnus.texi") - ("lisp/multifile.el" . "lisp/fileloop.el") - ("lisp/emacs-lisp/thread.el" . "lisp/thread.el") - ("lisp/emacs-lisp/cl.el" . "lisp/emacs-lisp/cl-lib.el") - ("lisp/progmodes/mantemp.el" . "lisp/obsolete/mantemp.el") - ("src/mini-gmp.c" . "lib/mini-gmp.c") - ("src/mini-gmp.h" . "lib/mini-gmp.h") + ("src/module.h" . "emacs-module.h") + ("src/module.c" . "emacs-module.c") + ("test/src/regex-tests.el" . "regex-emacs-tests.el") + ("test/lisp/emacs-lisp/cl-tests.el" . "cl-tests.el") + ("url-ns.el" . "url-ns.el") + ("gnus-news.texi" . "gnus.texi") + ("doc/misc/gnus-news.texi" . "gnus.texi") + ("lisp/multifile.el" . "fileloop.el") + ("lisp/emacs-lisp/thread.el" . "thread.el") + ;; cl.el was retired, replaced by cl-lib.el, and we want to + ;; pretend they are the same file... + ("emacs-lisp/cl.el" . "cl-lib.el") + ("lisp/emacs-lisp/cl.el" . "cl-lib.el") + ("lisp/obsolete/cl.el" . "cl-lib.el") + ("mantemp.el" . "mantemp.el") + ("lisp/progmodes/mantemp.el" . "mantemp.el") + ("progmodes/mantemp.el" . "mantemp.el") ("sysdep.c" . "src/sysdep.c") + ;; nnir.el started in lisp/gnus/ChangeLog.*, then was + ;; lisp/gnus/nnir.el in ChangeLog.[123], and is now + ;; lisp/obsolete/nnir.el. + ("nnir.el" . "nnir.el") ("lisp/gnus/nnir.el" . "nnir.el") - ("src/regex.c" . "emacs-regex.c") - ("src/regex.h" . "emacs-regex.h") + ;; regex.[ch] are mentioned as src/regex.[ch] in ChangeLog.[123], + ;; but as just regex.[ch] in src/ChangeLog.*, so we need 2 entries + ;; for each one of them. + ("regex.c" . "regex-emacs.c") + ("regex.h" . "regex-emacs.h") + ("src/regex.c" . "regex-emacs.c") + ("src/regex.h" . "regex-emacs.h") ("test/manual/rmailmm.el" . "rmailmm-tests.el") ("test/lisp/cedet/semantic-utest-fmt.el" . "format-tests.el") ("test/lisp/emacs-lisp/tabulated-list-test.el" . "tabulated-list-tests.el") @@ -1368,10 +1490,14 @@ Additionally, for these logs we apply the `lax' elements of (defun authors-canonical-file-name (file log-file pos author) "Return canonical file name for FILE found in LOG-FILE. +FILE is the file name as it appears in LOG-FILE, including any +leading directories mentioned there. +LOG-FILE is an absolute file name of the log file we are scanning. Checks whether FILE is a valid (existing) file name, has been renamed, or is on the list of removed files. Returns the non-directory part of -the file name. Only uses the LOG-FILE position POS and associated AUTHOR -to print a message if FILE is not found." +the file name to use for FILE in the \"AUTHORS\" file. +Only uses the LOG-FILE position POS and associated AUTHOR to print a +message if FILE is not found." ;; FILE should be re-checked in every different directory associated ;; with a LOG-FILE. Eg configure.ac from src/ChangeLog is not the ;; same as that from top-level/ChangeLog. @@ -1381,6 +1507,8 @@ to print a message if FILE is not found." (if entry (cdr entry) (setq relname (file-name-nondirectory file)) + ;; File names in `authors-valid-file-names' are OK by + ;; definition, so no need to check those. (if (or (member file authors-valid-file-names) (member relname authors-valid-file-names) (file-exists-p file) diff --git a/admin/cus-test.el b/admin/cus-test.el index 8f0914ff691..5894abed3df 100644 --- a/admin/cus-test.el +++ b/admin/cus-test.el @@ -156,7 +156,7 @@ Names should be as they appear in loaddefs.el.") "Set by `cus-test-apropos' to a list of options with :get property.") (defvar cus-test-vars-with-changed-state nil - "Set by `cus-test-apropos' to a list of options with state 'changed.") + "Set by `cus-test-apropos' to a list of options with state \\='changed.") (defvar cus-test-deps-errors nil "List of require/load problems found by `cus-test-deps'.") diff --git a/admin/make-tarball.txt b/admin/make-tarball.txt index 872cb00ca28..c8ee3349cdb 100644 --- a/admin/make-tarball.txt +++ b/admin/make-tarball.txt @@ -43,18 +43,42 @@ General steps (for each step, check for possible errors): because some of the commands below run Make, so they need Makefiles to be present. - For Emacs 28, and as long as --with-native-compilation is not the - default, the tree needs to be configured with native-compilation - enabled, to ensure all the pertinent *.elc files will end up in - the tarball. Otherwise, the *.eln files might not build correctly - on the user's system. + For Emacs 28 and later, as long as --with-native-compilation is + not the default, the tree needs to be configured with + native-compilation enabled, to ensure all the pertinent *.elc + files will end up in the tarball. Otherwise, the *.eln files + might not build correctly on the user's system. + + For a release (as opposed to pretest), delete any left-over "---" + and "+++" markers from etc/NEWS, as well as the "Temporary note" + section at the beginning of that file, and commit etc/NEWS if it + was modified. + +2. Regenerate the versioned ChangeLog.N and etc/AUTHORS files. + + The "M-x authors" command below will first update the current + versioned ChangeLog.N file. For this to work correctly, make sure + the top-level Makefile says + + PREFERRED_BRANCH = emacs-NN + + where NN is the version on the release branch from which you are + producing the tarball. If NN is incorrect, update Makefile.in and + re-run 'configure' to update Makefile. + + If the versioned ChangeLog.N file is too large, start a new one + by bumping N, and also update the line in top-level Makefile.in + which says + + CHANGELOG_HISTORY_INDEX_MAX = N + + by incrementing the value of N by 1; then regenerate Makefile. + + Now: -2. Regenerate the etc/AUTHORS file: M-: (require 'authors) RET M-x authors RET - (This first updates the current versioned ChangeLog.N) - If this says "Problem updating ChangeLog", find the reason for the failure of the command it runs, viz.: @@ -232,7 +256,9 @@ General steps (for each step, check for possible errors): FILE.gz FILE.xz ... You only need the --user part if you have multiple GPG keys and do - not want to use the default. + not want to use the default. Instead of "your@gpg.key.email" you + could also use the fingerprint of the key, a 40-digit hex number. + (Alternatively, define default-key in your ~/.gnupg/gpg.conf file.) Obviously, if you do not have a fast uplink, be prepared for the upload to take a while. @@ -308,17 +334,74 @@ looks like this: -Regenerate the various manuals in manual/. -The scripts admin/make-manuals and admin/upload-manuals summarize the process. +The file download.html may need to be updated, for example if the +MS-Windows binaries will be signed by a different person/key than +those mentioned there. -If you have Texinfo installed locally, make-manuals might fail if it -cannot find epsf.tex. In that case define in the environment +Next, regenerate the various manuals in HTML, PDF, and PS formats: - TEXINPUTS=:/path/to/texinfo-tree/doc + Invoke ./admin/make-manuals from the top-level directory of the + Emacs source tree that contains the manuals for which you want to + produce HTML docs. This creates the 'manual' directory and + populates it with the necessary files. -where /path/to/texinfo-tree is the absolute file name of the top-level -directory where you have the Texinfo source tree. Then re-run -make-manuals. + If you have Texinfo installed locally, make-manuals might fail if it + cannot find epsf.tex. In that case define in the environment + + TEXINPUTS=:/path/to/texinfo-tree/doc + + where /path/to/texinfo-tree is the absolute file name of the + top-level directory where you have the Texinfo source tree. Then + re-run make-manuals. + + make-manuals can also fail if the HTML manuals produced by Texinfo + violate some of the assumptions admin/admin.el makes about the + format of the produced HTML. Debug these problems and resolve them, + then re-run make-manuals. (Each time you run make-manuals, it + empties the manuals/ directory and regenerates the files there, but + if the files in manuals/ can be used without regeneration, i.e. if + the problem you solved doesn't affect the produced HTML, you can + invoke make-manuals with the -c switch, which will make the process + much faster.) + +Now change to the 'manual' directory and invoke upload-manuals: + + ../admin/updload-manuals /path/to/webpages/cvs/checkout + + where /path/to/webpages/cvs/checkout is the place where you have the + CVS checkout of the Emacs Web pages, with subdirectories 'manual' + and 'refcards'. This moves the produced manuals to directories in + the Web pages CVS checkout tree, and also invokes CVS commands to + commit changed files, add new files, and remove stale files that are + no longer part of the manuals. + + If upload-manuals fails, resolve the problems and re-invoke it. + This requires running make-manuals again, since upload-manuals + destructively modifies the 'manual' directory where you invoke it. + Also, upload-manuals invokes "cvs commit -f", so if you run it + several times, some files will be committed more than once even + though they were not changed in-between. Suck it up. + + All the added and removed files need to be committed, so next fire + up Emacs, type "C-x v d" to invoke vc-dir on the Web pages checkout, + and use "C-x v v" and other VC commands to commit all the files that + upload-manuals didn't automatically commit. (You can also do that + with manual CVS commands, of course, but this is not recommended.) + + Next, make sure that manual/index.html file is consistent with the + info/dir file in the branch for which you are producing the manuals, + in that it mentions all the manuals. It could be outdated if + manuals were added or removed since the last release. + + For each new manual, a file manual/MANUAL.html (where MANUAL is the + name of the manual) should be created from the template in + manual/eww.html, after editing the title and the Copyright years, + and the links in it changed to point to the appropriate files in the + manual/html_node/ and manual/html_mono/ subdirectories. + + In addition, the file refcards/index.html should be audited to make + sure it includes the up-to-date list of refcards actually produced + and put under that subdirectory. Browsing is one way to check for any files that still need updating. diff --git a/admin/notes/emba b/admin/notes/emba index 99237ea5f63..4c8c27dfeaa 100644 --- a/admin/notes/emba +++ b/admin/notes/emba @@ -8,7 +8,8 @@ NOTES FOR EMACS CONTINUOUS BUILD ON EMBA A continuous build for Emacs can be found at , a Gitlab instance. It watches the Emacs git repository and starts a pipeline (jobset) if there are new -changes. This happens for all Emacs branches. +changes. This happens for all Emacs branches which belong to the +defined workflow (see below). * Mail notifications @@ -32,7 +33,11 @@ The Emacs jobset is defined in the Emacs source tree, file 'test/infra'. They could be adapted for every Emacs branch, see . -A jobset on Gitlab is called pipeline. Emacs pipelines run through +Only branches whose name starts with 'master', 'emacs', 'feature', or +'fix' are considered. This is declared in the workflow rules of file +'test/infra/gitlab-ci.yml'. + +A jobset on Gitlab is called a pipeline. Emacs pipelines run through the stages 'build-images', 'platform-images' and 'native-comp-images' (create an Emacs instance by 'make bootstrap' with different configuration parameters) as well as 'normal', 'platforms' and @@ -41,11 +46,11 @@ configuration parameters) as well as 'normal', 'platforms' and The jobs for stage 'normal' are contained in the file 'test/infra/test-jobs.yml'. This file is generated by calling 'make -C test generate-test-jobs' in the Emacs source tree, and the -resulting file shall be pushed to the Emacs git repository afterwards. +resulting file should be pushed to the Emacs git repository afterwards. Every job runs in a Debian docker container. It uses the local clone of the Emacs git repository to perform a bootstrap and test of Emacs. -This could happen for several jobs with changed configuration, compile +This could happen for several jobs with changed configuration, compile, and test parameters. The 'build-image-*' jobs of the different '*-images' stages run only diff --git a/admin/notes/unicode b/admin/notes/unicode index 41661995000..f699f4fb1c0 100644 --- a/admin/notes/unicode +++ b/admin/notes/unicode @@ -36,6 +36,12 @@ copyright.html in admin/unidata (some of them might need trailing whitespace removed before they can be committed to the Emacs repository). +Next, review the assignment of default values of the Bidi Class +property to blocks in the file extracted/DerivedBidiClass.txt from the +UCD (search for "unassigned" in that file). Any changes should be +reflected in the unidata-gen.el file, where it sets up the default +values around line 210. + Then Emacs should be rebuilt for them to take effect. Rebuilding Emacs updates several derived files elsewhere in the Emacs source tree, mainly in lisp/international/. diff --git a/admin/unidata/unidata-gen.el b/admin/unidata/unidata-gen.el index ad72eed9955..149f7535588 100644 --- a/admin/unidata/unidata-gen.el +++ b/admin/unidata/unidata-gen.el @@ -209,9 +209,15 @@ Property value is one of the following symbols: ;; The assignment of default values to blocks of code points ;; follows the file DerivedBidiClass.txt from the Unicode ;; Character Database (UCD). - (L (#x0600 #x06FF AL) (#xFB50 #xFDFF AL) (#xFE70 #xFEFF AL) - (#x0590 #x05FF R) (#x07C0 #x08FF R) - (#xFB1D #xFB4F R) (#x10800 #x10FFF R) (#x1E800 #x1EFFF R)) + (L (#x0600 #x07BF AL) (#x0860 #x08FF AL) (#xFB50 #xFDCF AL) + (#xFDF0 #xFDFF AL) (#xFE70 #xFEFF AL) (#x10D00 #x10D3F AL) + (#x10F30 #x10F6F AL) (#x1EC70 #x1ECBF AL) (#x1ED00 #x1ED4F AL) + (#x1EE00 #x1EEFF AL) + (#x0590 #x05FF R) (#x07C0 #x085F R) (#xFB1D #xFB4F R) + (#x10800 #x10CFF R) (#x10D40 #x10F2F R) (#x10F70 #x10FFF R) + (#x1E800 #x1EC6F R) (#x1ECC0 #x1ECFF R) (#x1ED50 #x1EDFF R) + (#x1EF00 #x1EFFF R) + (#x20A0 #x20CF ET)) ;; The order of elements must be in sync with bidi_type_t in ;; src/dispextern.h. (L R EN AN BN B AL LRE LRO RLE RLO PDF LRI RLI FSI PDI diff --git a/admin/upload-manuals b/admin/upload-manuals index 1fa9865e657..1b7950ede80 100755 --- a/admin/upload-manuals +++ b/admin/upload-manuals @@ -334,7 +334,10 @@ for d in html_node/*; do [ -e $webdir/manual/$d ] || { echo "New directory: $d" mkdir $webdir/manual/$d - $cvs add $webdir/manual/$d || die "add error" + ( + cd $webdir/manual + $cvs add $d || die "add error" + ) } new= diff --git a/configure.ac b/configure.ac index 0c174c6a7b5..bf97dd017c5 100644 --- a/configure.ac +++ b/configure.ac @@ -491,7 +491,7 @@ OPTION_DEFAULT_ON([modules],[don't compile with dynamic modules support]) OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) OPTION_DEFAULT_OFF([native-compilation],[compile with Emacs Lisp native compiler support]) OPTION_DEFAULT_OFF([cygwin32-native-compilation],[use native compilation on 32-bit Cygwin]) -OPTION_DEFAULT_OFF([xinput2],[use version 2 of the X Input Extension for input]) +OPTION_DEFAULT_ON([xinput2],[don't use version 2 of the X Input Extension for input]) AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB], [use a file notification library (LIB one of: yes, inotify, kqueue, gfile, w32, no)])], @@ -966,6 +966,17 @@ AC_DEFUN([gl_GCC_VERSION_IFELSE], ] ) +# clang is unduly picky about some things. +AC_CACHE_CHECK([whether the compiler is clang], [emacs_cv_clang], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[ + #ifndef __clang__ + error "not clang"; + #endif + ]])], + [emacs_cv_clang=yes], + [emacs_cv_clang=no])]) + AC_ARG_ENABLE([gcc-warnings], [AS_HELP_STRING([--enable-gcc-warnings@<:@=TYPE@:>@], [control generation of GCC warnings. The TYPE 'yes' @@ -985,7 +996,11 @@ AC_ARG_ENABLE([gcc-warnings], # just a release imported into Git for patch management. gl_gcc_warnings=no if test -e "$srcdir"/.git && test ! -f "$srcdir"/.tarball-version; then - gl_GCC_VERSION_IFELSE([5], [3], [gl_gcc_warnings=warn-only]) + # Clang typically identifies itself as GCC 4.2 or something similar + # even if it is recent enough to accept the warnings we enable. + AS_IF([test "$emacs_cv_clang" = yes], + [gl_gcc_warnings=warn-only], + [gl_GCC_VERSION_IFELSE([5], [3], [gl_gcc_warnings=warn-only])]) fi]) AC_ARG_ENABLE([check-lisp-object-type], @@ -997,17 +1012,6 @@ if test "$enable_check_lisp_object_type" = yes; then [Define to enable compile-time checks for the Lisp_Object data type.]) fi -# clang is unduly picky about some things. -AC_CACHE_CHECK([whether the compiler is clang], [emacs_cv_clang], - [AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM([[ - #ifndef __clang__ - error "not clang"; - #endif - ]])], - [emacs_cv_clang=yes], - [emacs_cv_clang=no])]) - WERROR_CFLAGS= # When compiling with GCC, prefer -isystem to -I when including system # include files, to avoid generating useless diagnostics for the files. @@ -1102,6 +1106,8 @@ AS_IF([test $gl_gcc_warnings = no], if test "$emacs_cv_clang" = yes; then gl_WARN_ADD([-Wno-missing-braces]) gl_WARN_ADD([-Wno-null-pointer-arithmetic]) + gl_WARN_ADD([-Wno-implicit-const-int-float-conversion]) + gl_WARN_ADD([-Wno-int-in-bool-context]) fi # This causes too much noise in the MinGW build @@ -2692,6 +2698,9 @@ if test "${with_webp}" != "no"; then WEBP_MODULE="libwebp >= $WEBP_REQUIRED" EMACS_CHECK_MODULES([WEBP], [$WEBP_MODULE]) + if test "$HAVE_WEBP" = "yes"; then + WEBP_LIBS="-lwebp -lwebpdemux" + fi AC_SUBST(WEBP_CFLAGS) AC_SUBST(WEBP_LIBS) fi @@ -2791,7 +2800,11 @@ gtk3_pkg_errors= if test "${opsys}" != "mingw32"; then if test "${with_gtk3}" = "yes" || test "${with_gtk}" = "yes" || test "$USE_X_TOOLKIT" = "maybe"; then GLIB_REQUIRED=2.37.5 - GTK_REQUIRED=3.10 + if test "${window_system}" = "x11"; then + GTK_REQUIRED=3.10 + else + GTK_REQUIRED=3.20 + fi GTK_MODULES="gtk+-3.0 >= $GTK_REQUIRED glib-2.0 >= $GLIB_REQUIRED" dnl Checks for libraries. @@ -2927,6 +2940,8 @@ fi AC_SUBST(PGTK_OBJ) AC_SUBST(PGTK_LIBS) +AC_CHECK_FUNCS(malloc_trim) + dnl D-Bus has been tested under GNU/Linux only. Must be adapted for dnl other platforms. HAVE_DBUS=no @@ -3379,6 +3394,8 @@ if test "${with_toolkit_scroll_bars}" != "no"; then AC_DEFINE(USE_TOOLKIT_SCROLL_BARS) USE_TOOLKIT_SCROLL_BARS=yes fi +elif test "${window_system}" != "x11" && "${window_system}" != "none"; then + AC_MSG_ERROR(Non-toolkit scroll bars are not implemented for your system) fi dnl See if XIM is available. @@ -3769,6 +3786,14 @@ if test "${HAVE_X11}" = "yes"; then [Define to 1 if you have the XCB library and X11-XCB library for mixed X11/XCB programming.]) XCB_LIBS="-lX11-xcb -lxcb -lxcb-util" + else + AC_CHECK_LIB(xcb-aux, xcb_aux_sync, HAVE_XCB_AUX=yes) + if test "${HAVE_XCB_AUX}" = "yes"; then + AC_DEFINE(USE_XCB, 1, +[Define to 1 if you have the XCB library and X11-XCB library for mixed + X11/XCB programming.]) + XCB_LIBS="-lX11-xcb -lxcb -lxcb-aux" + fi fi fi fi @@ -3973,6 +3998,16 @@ MODULES_OBJ= NEED_DYNLIB=no MODULES_SUFFIX="${DYNAMIC_LIB_SUFFIX}" MODULES_SECONDARY_SUFFIX="${DYNAMIC_LIB_SECONDARY_SUFFIX}" + +# pgtkterm.c uses dlsym +if test $window_system = pgtk; then + case $opsys in + gnu|gnu-linux) + LIBMODULES="-ldl" + ;; + esac +fi + if test "${with_modules}" != "no"; then case $opsys in gnu|gnu-linux) @@ -4126,7 +4161,7 @@ if test "${with_native_compilation}" != "no"; then MAC_CFLAGS="-I$(dirname $($BREW ls -v libgccjit | \ grep libgccjit.h))" MAC_LIBS="-L$(dirname $($BREW ls -v libgccjit| \ - grep libgccjit.so\$))" + grep -E 'libgccjit\.(so|dylib)$'))" fi fi @@ -4305,7 +4340,8 @@ if test "${opsys}" = "mingw32"; then fi elif test "${HAVE_X11}" = "yes" && test "${with_gif}" != "no" \ || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes" \ - || test "${HAVE_BE_APP}" = "yes" || test "$window_system" = "pgtk"; then + || test "${HAVE_BE_APP}" = "yes" || test "$window_system" = "pgtk" \ + && test "${with_gif}" != "no"; then AC_CHECK_HEADER(gif_lib.h, # EGifPutExtensionLast only exists from version libungif-4.1.0b1. # Earlier versions can crash Emacs, but version 5.0 removes EGifPutExtensionLast. @@ -4567,6 +4603,51 @@ fi AC_SUBST(XDBE_CFLAGS) AC_SUBST(XDBE_LIBS) +### Use the Nonrectangular Window Shape extension if available. +HAVE_XSHAPE=no +HAVE_XCB_SHAPE=no +if test "${HAVE_X11}" = "yes"; then + AC_CHECK_HEADER(X11/extensions/shape.h, + [AC_CHECK_LIB(Xext, XShapeQueryVersion, HAVE_XSHAPE=yes)], + [], + [#include + ]) + if test $HAVE_XSHAPE = yes; then + XSHAPE_LIBS=-lXext + AC_CHECK_HEADER(xcb/shape.h, + [AC_CHECK_LIB(xcb-shape, xcb_shape_combine, HAVE_XCB_SHAPE=yes)], [], + [#include ]) + + if test $HAVE_XCB_SHAPE = yes && test "$XCB_LIBS" != ""; then + XSHAPE_LIBS="$XSHAPE_LIBS -lxcb-shape" + AC_DEFINE(HAVE_XCB_SHAPE, 1, [Define to 1 if XCB supports the Nonrectangular Window Shape extension.]) + fi + fi + if test $HAVE_XSHAPE = yes; then + AC_DEFINE(HAVE_XSHAPE, 1, [Define to 1 if you have the Nonrectangular Window Shape extension.]) + fi +fi +AC_SUBST(XSHAPE_CFLAGS) +AC_SUBST(XSHAPE_LIBS) + +### Use Xcomposite (-lXcomposite) if available +HAVE_XCOMPOSITE=no +if test "${HAVE_X11}" = "yes"; then + AC_CHECK_HEADER(X11/extensions/Xcomposite.h, + [AC_CHECK_LIB(Xcomposite, XCompositeRedirectWindow, HAVE_XCOMPOSITE=yes)], + [], + [#include + ]) + if test $HAVE_XCOMPOSITE = yes; then + XCOMPOSITE_LIBS=-lXcomposite + fi + if test $HAVE_XCOMPOSITE = yes; then + AC_DEFINE(HAVE_XCOMPOSITE, 1, [Define to 1 if you have the XCOMPOSITE extension.]) + fi +fi +AC_SUBST(XCOMPOSITE_CFLAGS) +AC_SUBST(XCOMPOSITE_LIBS) + ### Use libxml (-lxml2) if available ### mingw32 doesn't use -lxml2, since it loads the library dynamically. HAVE_LIBXML2=no diff --git a/doc/emacs/anti.texi b/doc/emacs/anti.texi index bb88fddc04f..b86037f2a63 100644 --- a/doc/emacs/anti.texi +++ b/doc/emacs/anti.texi @@ -30,10 +30,6 @@ Fancy text shaping and display is becoming less important as you move back in time. The @code{ftx} font backend is again part of Emacs, for the same reasons. -@item -As Motif becomes more and more important with moving farther into the -past, we've reinstated the code which supports Motif in Emacs. - @item Emacs once again supports versions 5.3 and older OpenBSD systems, which will be needed as you move back in time. diff --git a/doc/emacs/building.texi b/doc/emacs/building.texi index 5b68b1ef9fa..994ad460333 100644 --- a/doc/emacs/building.texi +++ b/doc/emacs/building.texi @@ -138,6 +138,14 @@ of environment variable settings; each element should be a string of the form @code{"@var{envvarname}=@var{value}"}. These environment variable settings override the usual ones. +@vindex compilation-max-output-line-length + Displaying extremely long lines in compilation output can slow Emacs +down. Lines that are longer than +@code{compilation-max-output-line-length} will have the portion that's +exceeds that limit hidden behind a button that can be clicked on to +reveal the hidden portion. Set this variable to @code{nil} to never +hide anything. + @node Compilation Mode @section Compilation Mode @@ -1734,6 +1742,10 @@ which is provided for evaluating Emacs Lisp expressions interactively. Its major mode is Lisp Interaction mode. You can also enable Lisp Interaction mode by typing @kbd{M-x lisp-interaction-mode}. +@findex scratch-buffer + If you kill the @file{*scratch*} buffer, you can recreate it with +the @kbd{M-x scratch-buffer} command. + @findex eval-print-last-sexp @kindex C-j @r{(Lisp Interaction mode)} In the @file{*scratch*} buffer, and other Lisp Interaction mode diff --git a/doc/emacs/cmdargs.texi b/doc/emacs/cmdargs.texi index de1d5e0b2c3..946afb6fc14 100644 --- a/doc/emacs/cmdargs.texi +++ b/doc/emacs/cmdargs.texi @@ -294,6 +294,22 @@ which will invoke Emacs with @samp{--script} and supply the name of the script file as @var{file}. Emacs Lisp then treats the @samp{#!} on this first line as a comment delimiter. +@item -x +@opindex -x +This option can only be used in executable script files, and should be +invoked like this: + +@example +#!/usr/bin/emacs -x +@end example + +This is like @samp{--script}, but suppresses loading the init files +(like @code{--quick}), and can't be used on a normal command line +(since it doesn't specify the script to load). In addition, when it +reaches the end of the script, it exits Emacs and uses the value of +the final form as the exit value from the script (if the final value +is numerical). Otherwise, it will always exit with a zero value. + @item --no-build-details @opindex --no-build-details @cindex build details diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index a3c9c7c206a..46a2291b74d 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -1232,6 +1232,28 @@ Manual}. These four keywords are not really variables; setting them in any other context has no special meaning. + If you're editing a file across Emacs versions, and a new mode has +been introduced to handle a file in a newer Emacs version, you can use +several @code{mode} entries to use the new mode (called +@code{my-new-mode}) in the new Emacs, and fall back to the old mode +(called @code{my-old-mode}) in older Emacs versions. If you're +enabling the modes in the first line of the file, can say: + +@example +-*- mode: my-old; mode: my-new -*- +@end example + + Emacs will use the final defined mode it finds, so in older Emacs +versions it will ignore @code{my-new-mode}, while in Emacs versions +where @code{my-new-mode} is defined, it'll ignore @code{my-old-mode}. +Similarly, in a local variable block at the end of the file: + +@example +Local variables: +mode: my-old +mode: my-new +@end example + Do not use the @code{mode} keyword for minor modes. To enable or disable a minor mode in a local variables list, use the @code{eval} keyword with a Lisp expression that runs the mode command diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi index 3112ac332b3..92106ae1ed3 100644 --- a/doc/emacs/dired.texi +++ b/doc/emacs/dired.texi @@ -776,6 +776,11 @@ symbolic links as links or after dereferencing (like @samp{cp -L}). The default is @code{nil}, which means that the symbolic links are copied by creating new ones. +@vindex dired-keep-marker-copy +The @code{dired-keep-marker-copy} user option controls how this +command handles file marking. The default is to mark all new copies +of files with a @samp{C} mark. + @item D @findex dired-do-delete @kindex D @r{(Dired)} @@ -1007,6 +1012,7 @@ subdirectories whose names match @code{grep-find-ignored-directories}. @findex dired-do-shell-command @kindex ! @r{(Dired)} @kindex X @r{(Dired)} +@vindex dired-confirm-shell-command The Dired command @kbd{!} (@code{dired-do-shell-command}) reads a shell command string in the minibuffer, and runs that shell command on one or more files. The files that the shell command operates on are @@ -1043,7 +1049,8 @@ list of file names, putting them into one tar file @file{foo.tar}. If you want to use @samp{*} as a shell wildcard with whitespace around it, write @samp{*""}. In the shell, this is equivalent to @samp{*}; but since the @samp{*} is not surrounded by whitespace, Dired does not -treat it specially. +treat it specially. Emacs will prompt for confirmation if you do +this, unless @code{dired-confirm-shell-command} is @code{nil}. @item Otherwise, if the command string contains @samp{?} surrounded by @@ -1695,9 +1702,15 @@ directory than in this one. It also marks files with no counterpart, in both directories, as always. @cindex drag and drop, Dired - On the X Window System, Emacs supports the drag and drop -protocol. You can drag a file object from another program, and drop -it onto a Dired buffer; this either moves, copies, or creates a link -to the file in that directory. Precisely which action is taken is -determined by the originating program. Dragging files out of a Dired -buffer is currently not supported. +@vindex dired-mouse-drag-files + On the X Window System, Emacs supports the drag and drop protocol. +You can drag a file object from another program, and drop it onto a +Dired buffer; this either moves, copies, or creates a link to the file +in that directory. Precisely which action is taken is determined by +the originating program. Dragging files out of a Dired buffer is also +supported, by enabling the user option @code{dired-mouse-drag-files}, +the mouse can be used to drag files onto other programs. When set to +@code{link}, it will make the other program (typically a file manager) +create a symbolic link to the file, and setting it to any other +non-@code{nil} value will make the other program open or create a copy +of the file. diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index 4fcd2a3f7de..7a6c7f391b9 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -1011,10 +1011,15 @@ in C comments, use this: @end example @findex font-lock-remove-keywords +@vindex font-lock-ignore @noindent To remove keywords from the font-lock highlighting patterns, use the function @code{font-lock-remove-keywords}. @xref{Search-based Fontification,,, elisp, The Emacs Lisp Reference Manual}. +Alternatively, you can selectively disable highlighting due to some +keywords by customizing the @code{font-lock-ignore} option, +@pxref{Customizing Keywords,,, elisp, The Emacs Lisp Reference +Manual}. @cindex just-in-time (JIT) font-lock @cindex background syntax highlighting @@ -1894,12 +1899,22 @@ logical lines, so having a fringe indicator for each wrapped line would be visually distracting. You can change this by customizing the variable @code{visual-line-fringe-indicators}. +@vindex word-wrap-whitespace-mode + By default, Emacs only breaks lines after whitespace characters like +@key{SPC} and @key{TAB}, but does not break after whitespace +characters like @key{EN QUAD}. Emacs provides a minor mode called +@code{word-wrap-whitespace-mode} that switches on word wrapping in the +current mode, and sets up which characters to wrap lines on based on +the @code{word-wrap-whitespace-characters} user option. There's also +a globalized version of that mode called +@code{global-word-wrap-whitespace-mode}. + @vindex word-wrap-by-category @findex modify-category-entry @findex char-category-set @findex category-set-mnemonics - By default, Emacs only breaks lines after whitespace characters. -That produces incorrect results when CJK and Latin text are mixed + Only breaking after whitespace character produces incorrect +results when CJK and Latin text are mixed together (because CJK characters don't use whitespace to separate words). You can customize the option @code{word-wrap-by-category} to allow Emacs to break lines after any character with @samp{|} category @@ -2082,3 +2097,14 @@ argument to suppress the effect of bold-face in this case. byte with a decimal value of 128 is displayed as @code{\200}. To change display to the hexadecimal format of @code{\x80}, set the variable @code{display-raw-bytes-as-hex} to @code{t}. +Care may be needed when interpreting a raw byte when copying +text from a terminal containing an Emacs session, or when a terminal's +@code{escape-glyph} face looks like the default face. For example, by +default Emacs displays the four characters @samp{\}, @samp{2}, +@samp{0}, @samp{0} with the same characters it displays a byte with +decimal value 128. The problem can be worse with hex displays, where +the raw byte 128 followed by the character @samp{7} is displayed as +@code{\x807}, which Emacs Lisp reads as the single character U+0807 +SAMARITAN LETTER IT; this confusion does not occur with the +corresponding octal display @code{\2007} because octal escapes contain +at most three digits. diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi index e3cfe5f8441..7c564a87763 100644 --- a/doc/emacs/frames.texi +++ b/doc/emacs/frames.texi @@ -1196,6 +1196,18 @@ the variable @code{dnd-open-file-other-window}. The XDND and Motif drag and drop protocols, and the old KDE 1.x protocol, are currently supported. +@vindex dnd-indicate-insertion-point +@vindex dnd-scroll-margin + + It can be difficult to scroll a window or determine where dropped +text will be inserted while dragging text onto an Emacs window. +Setting the option @code{dnd-indicate-insertion-point} to a +non-@code{nil} value makes point move to the location any dropped text +will be inserted when the mouse moves in a window during drag, and +setting @code{dnd-scroll-margin} to an integer value causes a window +to be scrolled if the mouse moves within that many lines of the top +or bottom of the window during drag. + @vindex mouse-drag-and-drop-region Emacs can also optionally drag the region with the mouse into another portion of this or another buffer. To enable that, customize @@ -1220,6 +1232,10 @@ cursor during dragging. To suppress such behavior, set the options @code{mouse-drag-and-drop-region-show-tooltip} and/or @code{mouse-drag-and-drop-region-show-cursor} to @code{nil}. +@vindex mouse-drag-and-drop-region-cross-program +To drag text from Emacs to other programs, set the option +@code{mouse-drag-and-drop-region-cross-program} to a non-@code{nil} +value. @node Menu Bars @section Menu Bars diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi index 1f743ccd88f..11ee9dc2b2f 100644 --- a/doc/emacs/help.texi +++ b/doc/emacs/help.texi @@ -20,10 +20,28 @@ commands (@code{help-for-help}). You can scroll the list with @key{SPC} and @key{DEL}, then type the help command you want. To cancel, type @kbd{C-g}. +@cindex help buffer Many help commands display their information in a special @dfn{help buffer}. In this buffer, you can type @key{SPC} and @key{DEL} to scroll and type @key{RET} to follow hyperlinks. @xref{Help Mode}. +@vindex help-window-select + By default, help commands display the help buffer in a separate +window without selecting that window. The variable +@code{help-window-select} controls this: its default value is +@code{nil}; if it's customized to the value @code{t}, the help window +is unconditionally selected by help commands, and if its value is +@code{other}, the help window is selected only if there are more than +two windows on the selected frame. + +@vindex help-window-keep-selected + Conversely, many commands in the @samp{*Help*} buffer will pop up a +new window to display the results. For instance, clicking on the link +to show the source code, or using the @key{i} command to display the +manual entry, will (by default) pop up a new window. If +@code{help-window-keep-selected} is changed to non-@code{nil}, the +window displaying the @samp{*Help*} buffer will be reused instead. + @cindex searching documentation efficiently @cindex looking for a subject in documentation If you are looking for a certain feature, but don't know what it is @@ -182,7 +200,10 @@ programming language you are editing (@code{info-lookup-symbol}). @item C-h . Display the help message for a special text area, if point is in one (@code{display-local-help}). (These include, for example, links in -@file{*Help*} buffers.) @xref{Help Echo}. +@file{*Help*} buffers.) @xref{Help Echo}. If you invoke +this command with a prefix argument, @kbd{C-u C-h .}, and point is on +a button or a widget, this command will pop a new buffer that +describes that button/widget. @end table @node Key Help @@ -332,9 +353,9 @@ are included varies depending on the command used. @cindex apropos The @dfn{apropos} commands answer questions like, ``What are the -commands for working with files?'' More precisely, you specify an -@dfn{apropos pattern}, which means either a word, a list of words, or -a regular expression. +commands for working with files?'' More precisely, you specify your +query as an @dfn{apropos pattern}, which is either a word, a list of +words, or a regular expression. Each of the following apropos commands reads an apropos pattern in the minibuffer, searches for items that match the pattern, and @@ -393,6 +414,12 @@ comes with a brief description and a list of keys you can currently invoke it with. In our example, it would say that you can invoke @code{find-file} by typing @kbd{C-x C-f}. +@vindex help-window-select@r{, and apropos commands} + By default, the window showing the apropos buffer with the results +of the query is not selected, but you can cause it to be selected by +customizing the variable @code{help-window-select} to any +non-@code{nil} value. + For more information about a function definition, variable or symbol property listed in an apropos buffer, you can click on it with @kbd{mouse-1} or @kbd{mouse-2}, or move there and type @key{RET}. diff --git a/doc/emacs/killing.texi b/doc/emacs/killing.texi index e3de2bc2faf..2fd2d21dd35 100644 --- a/doc/emacs/killing.texi +++ b/doc/emacs/killing.texi @@ -540,11 +540,11 @@ clipboard. clipboard contents are normally lost. Optionally, Emacs can save the existing clipboard contents to the kill ring, preventing you from losing the old clipboard data. If -@code{save-interprogram-paste-before-kill} changed to a number, then -this data is copied over if it's smaller (in characters) than this -number. If this variable is any other non-@code{nil} value, it's -always copied over---at the risk of high memory consumption if that -data turns out to be large. +@code{save-interprogram-paste-before-kill} has been set to a number, +then the data is copied over if it's smaller (in characters) than +this number. If this variable is any other non-@code{nil} value, the +data is always copied over---at the risk of high memory consumption if +that data turns out to be large. Yank commands, such as @kbd{C-y} (@code{yank}), also use the clipboard. If another application ``owns'' the clipboard---i.e., if @@ -567,8 +567,8 @@ change the variable @code{select-enable-clipboard} to @code{nil}. instance, a web browser will usually let you choose ``Copy Image'' on images, and this image will be put on the clipboard. On capable platforms, Emacs can yank these objects with the @code{yank-media} -command---but only in modes that have support for it (@pxref{Yanking -Media,,, elisp, The Emacs Lisp Reference Manual}). +command---but only in modes that have support for it (@w{@pxref{Yanking +Media,,, elisp, The Emacs Lisp Reference Manual}}). @cindex clipboard manager @vindex x-select-enable-clipboard-manager @@ -698,6 +698,9 @@ lines, much like @kbd{mouse-1}. If @code{mouse-yank-at-point} is non-@code{nil}, @kbd{M-mouse-2} yanks at point. Then it does not matter precisely where you click, or even which of the frame's windows you click on. @xref{Mouse Commands}. +This user option also effects interactive search: if it is +non-@code{nil}, yanking with the mouse anywhere in the frame will add +the text to the search string. @node Accumulating Text @section Accumulating Text diff --git a/doc/emacs/macos.texi b/doc/emacs/macos.texi index ab143707fdd..37f48619d12 100644 --- a/doc/emacs/macos.texi +++ b/doc/emacs/macos.texi @@ -273,14 +273,6 @@ application is overriding the default behavior. The modifier keys listed above are defined by macOS and are unaffected by user changes to the modifiers in Emacs. -@item ns-change-font -This event occurs when the user selects a font in a Nextstep font -panel (which can be opened with @kbd{Cmd-t}). The default behavior is -to adjust the font of the selected frame -(@code{ns-respond-to-changefont}). The name and size of the selected -font are stored in the variables @code{ns-input-font} and -@code{ns-input-fontsize}, respectively. - @item ns-power-off This event occurs when the user logs out and Emacs is still running, or when ``Quit Emacs'' is chosen from the application menu. diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index edcc6075f75..cca8441daa5 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -1055,15 +1055,6 @@ prefix argument is a repeat count. Move to the next revision entry. A numeric prefix argument is a repeat count. -@item P -Move to the log of the previous file, if showing logs for a multi-file -VC fileset. Otherwise, just move to the beginning of the log. A -numeric prefix argument is a repeat count. - -@item N -Move to the log of the next file, if showing logs for a multi-file VC -fileset. A numeric prefix argument is a repeat count. - @item a Annotate the revision on the current line (@pxref{Old Revisions}). @@ -1728,6 +1719,7 @@ doesn't seem to belong to a recognizable project, these commands prompt you for the project directory. @findex project-find-file +@vindex vc-directory-exclusion-list The command @kbd{C-x p f} (@code{project-find-file}) is a convenient way of visiting files (@pxref{Visiting}) that belong to the current project. Unlike @kbd{C-x C-f}, this command doesn't require to type @@ -1736,7 +1728,9 @@ base name (i.e., omit the leading directories). In addition, the completion candidates considered by the command include only the files belonging to the current project, and nothing else. If there's a file name at point, this command offers that file as the first element of -the ``future history''. +the ``future history''. If given a prefix, include all files under +the project root, except for @acronym{VCS} directories listed in +@code{vc-directory-exclusion-list}. @findex project-find-regexp The command @kbd{C-x p g} (@code{project-find-regexp}) is similar to @@ -1831,11 +1825,14 @@ buffers as candidates for completion. @findex project-kill-buffers @vindex project-kill-buffer-conditions +@vindex project-kill-buffers-display-buffer-list When you finish working on the project, you may wish to kill all the buffers that belong to the project, to keep your Emacs session smaller. The command @kbd{C-x p k} (@code{project-kill-buffers}) accomplishes that: it kills all the buffers that belong to the current -project that satisfy any of @code{project-kill-buffer-conditions}. +project that satisfy any of @code{project-kill-buffer-conditions}. If +@code{project-kill-buffers-display-buffer-list} is non-@code{nil}, the +buffers to be killed will be displayed first. @node Switching Projects @subsection Switching Projects @@ -2992,11 +2989,12 @@ etags --language=none \ @findex visit-tags-table Emacs has at any time at most one @dfn{selected} tags table. All -the commands for working with tags tables use the selected one. To -select a tags table, type @kbd{M-x visit-tags-table}, which reads the -tags table file name as an argument, with @file{TAGS} defaulting to -the first directory that contains a file named @file{TAGS} encountered -when recursively searching upward from the default directory. +the commands for working with tags tables use the selected one first. +To select a tags table, type @kbd{M-x visit-tags-table}, which reads +the tags table file name as an argument, with @file{TAGS} defaulting +to the first directory that contains a file named @file{TAGS} +encountered when recursively searching upward from the default +directory. @vindex tags-file-name Emacs does not actually read in the tags table contents until you @@ -3006,16 +3004,25 @@ variable's initial value is @code{nil}; that value tells all the commands for working with tags tables that they must ask for a tags table file name to use. - Using @code{visit-tags-table} when a tags table is already loaded -gives you a choice: you can add the new tags table to the current list -of tags tables, or start a new list. The tags commands use all the tags -tables in the current list. If you start a new list, the new tags table -is used @emph{instead} of others. If you add the new table to the -current list, it is used @emph{as well as} the others. + In addition to the selected tags table, Emacs maintains the list of +several tags tables that you use together. For example, if you are +working on a program that uses a library, you may wish to have the +tags tables of both the program and the library available, so that +Emacs could easily find identifiers from both. If the selected tags +table doesn't have the identifier or doesn't mention the source file a +tags command needs, the command will try using all the other tags +tables in the current list of tags tables. + + Using @code{visit-tags-table} to load a new tags table when another +tags table is already loaded gives you a choice: you can add the new +tags table to the current list of tags tables, or discard the current +list and start a new list. If you start a new list, the new tags +table is used @emph{instead} of others. If you add the new table to +the current list, it is used @emph{as well as} the others. @vindex tags-table-list You can specify a precise list of tags tables by setting the variable -@code{tags-table-list} to a list of strings, like this: +@code{tags-table-list} to a list of directory names, like this: @c keep this on two lines for formatting in smallbook @example diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index 13d9269c68e..a899fea7e39 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -378,6 +378,20 @@ window. You can display the same list with @kbd{?} used with the completion list: @table @kbd +@vindex minibuffer-completion-auto-choose +@item M-@key{DOWN} +@itemx M-@key{UP} +These keys will navigate through the completions displayed in the +completions buffer. When @code{minibuffer-completion-auto-choose} is +non-@code{nil} (which is the default), using these commands will +automatically insert the current completion candidate in the +minibuffer. If this user option is @code{nil}, the keys will navigate +the same way as before, but won't automatically insert the candidate +in the minibuffer. Instead you have to use the @kbd{M-@key{RET}} command to +do that. With a prefix argument, @kbd{C-u M-@key{RET}} inserts the +currently active candidate to the minibuffer, but doesn't exit the +minibuffer. + @findex switch-to-completions @item M-v @itemx @key{PageUp} @@ -624,11 +638,34 @@ completion alternatives in the completion list. @vindex completion-auto-help If @code{completion-auto-help} is set to @code{nil}, the completion commands never display the completion list buffer; you must type -@kbd{?} to display the list. If the value is @code{lazy}, Emacs only +@kbd{?} to display the list. If the value is @code{lazy}, Emacs only shows the completion list buffer on the second attempt to complete. In other words, if there is nothing to complete, the first @key{TAB} echoes @samp{Next char not unique}; the second @key{TAB} shows the -completion list buffer. +completion list buffer. If the value is @code{always}, the completion +list buffer is always shown when completion is attempted. + +The display of the completion list buffer after it is shown for the +first time is also controlled by @code{completion-auto-help}. If the +value is @code{t} or @code{lazy}, the window showing the completions +pops down when Emacs is able to complete (and may pop up again if +Emacs is again unable to complete after you type some more text); if +the value is @code{always}, the window pops down only when you exit +the completion. The value @code{visible} is a hybrid: it behaves like +@code{t} when it decides whether to pop up the window showing the +completion list buffer, and like @code{always} when it decides whether +to pop it down. + +@vindex completion-auto-select + Emacs can optionally select the window showing the completions when +it shows that window. To enable this behavior, customize the user +option @code{completion-auto-select} to @code{t}, which changes the +behavior of @key{TAB} when Emacs pops up the completions: pressing +@kbd{@key{TAB}} will switch to the completion list buffer, and you can +then move to a candidate by cursor motion commands and select it with +@kbd{@key{RET}}. If the value of @code{completion-auto-select} is +@code{second-tab}, then the first @kbd{@key{TAB}} will pop up the +completions list buffer, and the second one will switch to it. @vindex completion-cycle-threshold If @code{completion-cycle-threshold} is non-@code{nil}, completion @@ -651,6 +688,42 @@ changed by changing the @code{completions-format} user option. If @code{vertical}, sort the completions vertically in columns instead, and if @code{one-column}, just use a single column. +@vindex completions-sort + This user option controls how completions are sorted in the +@samp{*Completions*} buffer. The default is @code{alphabetical}, but +it can also be a function which will be called with the list of +completions, and should return the list in the desired order. + +@vindex completions-max-height + When @code{completions-max-height} is non-@code{nil}, it limits the +size of the completions window. It is specified in lines and include +mode, header line and a bottom divider, if any. For a more complex +control of the Completion window display properties, you can use +@code{display-buffer-alist} (@pxref{Buffer Display Action +Alists,,Action Alists for Buffer Display, elisp, The Emacs Lisp +Reference Manual}). + +@vindex completions-header-format +The variable @code{completions-header-format} is a format spec string to +control the informative line shown before the completions list of +candidates. If it contains a @samp{%s} construct, that get replaced +by the number of completions shown in the completion list buffer. To +suppress the display of the heading line, customize this variable to +@code{nil}. The string that is the value of this variable can have +text properties to change the visual appearance of the heading line; +some useful properties @code{face} or @code{cursor-intangible} +(@pxref{Special Properties,,Properties with Special Meanings, elisp, +The Emacs Lisp Reference Manual}). + +@vindex completions-highlight-face +When @code{completions-highlight-face} names a face, the current +completion candidate, the one that will be selected by typing +@kbd{@key{RET}} or clicking the mouse, will be highlighted using that +face. The default value of this variable is +@code{completions-highlight}; the value is @code{nil} disables this +highlighting. This feature uses the special text property +@code{cursor-face}. + @node Minibuffer History @section Minibuffer History @cindex minibuffer history diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 4710c05b620..9709c6ddc1f 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -896,6 +896,19 @@ also rename the @file{*shell*} buffer using @kbd{M-x rename-uniquely}, then create a new @file{*shell*} buffer using plain @kbd{M-x shell}. Subshells in different buffers run independently and in parallel. + Emacs attempts to keep track of what the current directory is by +looking at the commands you enter, looking for @samp{cd} commands and +the like. This is an error-prone solution, since there are many ways +to change the current directory, so Emacs also looks for special +@acronym{OSC} (Operating System Commands) escape codes that are +designed to convey this information in a more reliable fashion. You +should arrange for your shell to print the appropriate escape sequence +at each prompt, for instance with the following command: + +@example +printf "\e]7;file://%s%s\e\\" "$HOSTNAME" "$PWD" +@end example + @vindex explicit-shell-file-name @cindex environment variables for subshells @cindex @env{ESHELL} environment variable @@ -2770,7 +2783,12 @@ will by default ask you whether to use the locked desktop file. You can avoid the question by customizing the variable @code{desktop-load-locked-desktop} to either @code{nil}, which means never load the desktop in this case, or @code{t}, which means load the -desktop without asking. +desktop without asking. Finally, the @code{check-pid} value means to +load the file if the Emacs process that has locked the desktop is not +running on the local machine. This should not be used in +circumstances where the locking Emacs might still be running on +another machine. This could be the case in multi-user environments +where your home directory is mounted remotely using NFS or similar. @cindex desktop restore in daemon mode When Emacs starts in daemon mode, it cannot ask you any questions, diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index caa65bf33b6..bd3ae2aa6ad 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -320,10 +320,13 @@ version of the package, a newer version is also installed. @section Package Installation @findex package-install +@findex package-update Packages are most conveniently installed using the package menu (@pxref{Package Menu}), but you can also use the command @kbd{M-x package-install}. This prompts for the name of a package with the -@samp{available} status, then downloads and installs it. +@samp{available} status, then downloads and installs it. Similarly, +if you want to update a package, you can use the @kbd{M-x +package-update} command. @cindex package requirements A package may @dfn{require} certain other packages to be installed, diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi index ff4405f1fbc..45bc4c79b4f 100644 --- a/doc/emacs/programs.texi +++ b/doc/emacs/programs.texi @@ -250,8 +250,8 @@ where it treats each chapter, section, etc., as a definition. together.) @findex imenu - If you type @kbd{M-x imenu}, it reads the name of a definition using -the minibuffer, then moves point to that definition. You can use + If you type @kbd{M-g i}, it reads the name of a definition using the +minibuffer, then moves point to that definition. You can use completion to specify the name; the command always displays the whole list of valid names. diff --git a/doc/emacs/search.texi b/doc/emacs/search.texi index f2d82324e94..c990f5d766a 100644 --- a/doc/emacs/search.texi +++ b/doc/emacs/search.texi @@ -899,11 +899,13 @@ character folding during incremental regexp search with @kbd{M-s '}, the search becomes a non-regexp search and the search pattern you typed is interpreted as a literal string.) +@cindex pending, in incremental search In some cases, adding characters to the regexp in an incremental regexp search can make the cursor move back and start again. For example, if you have searched for @samp{foo} and you add @samp{\|bar}, the cursor backs up in case the first @samp{bar} precedes the first -@samp{foo}. @xref{Regexps}. +@samp{foo}. (The prompt will change to say ``Pending'' to notify the +user that this recalculation has happened.) @xref{Regexps}. Forward and backward regexp search are not symmetrical, because regexp matching in Emacs always operates forward, starting with the diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi index 9f152f1cc14..fa8eaf09245 100644 --- a/doc/emacs/text.texi +++ b/doc/emacs/text.texi @@ -1259,6 +1259,17 @@ and related functions treat hidden text, @pxref{Query Replace}.) You can also automatically make text visible as you navigate in it by using Reveal mode (@kbd{M-x reveal-mode}), a buffer-local minor mode. +@vindex outline-default-state + The @code{outline-default-state} variable controls what headings +will be visible after Outline mode is turned on. If non-@code{nil}, +some headings are initially outlined. If equal to a number, show only +headings up to and including the corresponding level. If equal to +@code{outline-show-all}, all text of buffer is shown. If equal to +@code{outline-show-only-headings}, show only headings, whatever their +level is. If equal to a lambda function or function name, this +function is expected to toggle headings visibility, and will be called +without arguments after the mode is enabled. + @node Outline Views @subsection Viewing One Outline in Multiple Views diff --git a/doc/emacs/trouble.texi b/doc/emacs/trouble.texi index 93f9c779dbf..8da96de1cb4 100644 --- a/doc/emacs/trouble.texi +++ b/doc/emacs/trouble.texi @@ -296,6 +296,31 @@ editing in the same Emacs session. out of memory, because the Buffer Menu needs a fair amount of memory itself, and the reserve supply may not be enough. +@cindex out of memory killer, GNU/Linux +@cindex OOM killer + On GNU/Linux systems, Emacs does not normally get notified about +out-of-memory situations; instead, the OS can kill the Emacs process +when it runs out of memory. This feature is known as the +@dfn{out-of-memory killer}, or @dfn{@acronym{OOM} killer}. When this +behavior is in effect, Emacs is unable to detect the out-of-memory +situation in time, and won't be able to let you save your buffer as +described above. However, it is possible to turn off this behavior of +the OS, and thus allow Emacs a chance to handle the out-of-memory +situation in a more useful manner, before it is killed. To do that, +become the super user, edit the file @code{/etc/sysctl.conf} to +contain the lines shown below, and then invoke the command +@w{@kbd{sysctl -p}} from the shell prompt: + +@example +vm.overcommit_memory=2 +vm.overcommit_ratio=0 +@end example + +@noindent +Please note that the above setting affects all the processes on the +system, and in general the behavior of the system under memory +pressure, not just the Emacs process alone. + @node Crashing @subsection When Emacs Crashes diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi index 466d7f0e604..049c8a65a8f 100644 --- a/doc/lispintro/emacs-lisp-intro.texi +++ b/doc/lispintro/emacs-lisp-intro.texi @@ -15345,7 +15345,10 @@ nil @group (20615 27034 579989 697000) (17905 55681 0 0) -(20615 26327 734791 805000) +(20615 26327 734791 805000)@footnote{If @code{current-time-list} is +@code{nil} the three timestamps are @code{(1351051674579989697 +. 1000000000)}, @code{(1173477761000000000 . 1000000000)}, and +@code{(1351050967734791805 . 1000000000)}, respectively.} 13188 "-rw-r--r--" @end group diff --git a/doc/lispref/buffers.texi b/doc/lispref/buffers.texi index 1fe5a60b356..d8cf3d7919b 100644 --- a/doc/lispref/buffers.texi +++ b/doc/lispref/buffers.texi @@ -953,15 +953,59 @@ with a @code{nil} @var{norecord} argument since this may lead to infinite recursion. @end defvar +@defun buffer-match-p condition buffer-or-name &optional arg +This function checks if a buffer designated by @code{buffer-or-name} +satisfies a @code{condition}. Optional third argument @var{arg} is +passed to the predicate function in @var{condition}. A condition can +be one of the following: +@itemize @bullet{} +@item +A string, interpreted as a regular expression. The buffer +satisfies the condition if the regular expression matches the buffer +name. +@item +A predicate function, which should return non-@code{nil} if the buffer +matches. If the function expects one argument, it is called with +@var{buffer-or-name} as the argument; if it expects 2 arguments, the +first argument is @var{buffer-or-name} and the second is @var{arg} +(or @code{nil} if @var{arg} is omitted). +@item +A cons-cell @code{(@var{oper} . @var{expr})} where @var{oper} is one +of +@table @code +@item not +Satisfied if @var{expr} doesn't satisfy @code{buffer-match-p} with +the same buffer and @code{arg}. +@item or +Satisfied if @var{oper} is a list and @emph{any} condition if +@var{expr} satisfies @code{buffer-match-p}, with the same buffer and +@code{arg}. +@item and +Satisfied if @var{oper} is a list and @emph{all} condition if +@var{expr} satisfies @code{buffer-match-p}, with the same buffer and +@code{arg}. +@end table +@end itemize +@end defun + +@defun match-buffers condition &optional buffer-list arg +This function returns a list of all buffers that satisfy a +@code{condition}, as defined for @code{buffer-match-p}. By default +all buffers are considered, but this can be restricted via the second +optional @code{buffer-list} argument. Optional third argument +@var{arg} will be used by @var{condition} in the same way as +@code{buffer-match-p} does. +@end defun + @node Creating Buffers @section Creating Buffers @cindex creating buffers @cindex buffers, creating This section describes the two primitives for creating buffers. -@code{get-buffer-create} creates a buffer if it finds no existing buffer -with the specified name; @code{generate-new-buffer} always creates a new -buffer and gives it a unique name. +@code{get-buffer-create} creates a buffer if it finds no existing +buffer with the specified name; @code{generate-new-buffer} always +creates a new buffer and gives it a unique name. Both functions accept an optional argument @var{inhibit-buffer-hooks}. If it is non-@code{nil}, the buffer they create does not run the hooks diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index a4ae68af5b2..6c60216796c 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -312,6 +312,25 @@ If @var{function} is an interactively callable function specifies how to compute its arguments. Otherwise, the value is @code{nil}. If @var{function} is a symbol, its function definition is used. +When called on an OClosure, the work is delegated to the generic +function @code{oclosure-interactive-form}. +@end defun + +@defun oclosure-interactive-form function +Just like @code{interactive-form}, this function takes a command and +returns its interactive form. The difference is that it is a generic +function and it is only called when @var{function} is an OClosure. +The purpose is to make it possible for some OClosure types to compute +their interactive forms dynamically instead of carrying it in one of +their slots. + +This is used for example for @code{kmacro} functions in order to +reduce their memory size, since they all share the same interactive +form. It is also used for @code{advice} functions, where the +interactive form is computed from the interactive forms of its +components, so as to make this computation more lazily and to +correctly adjust the interactive form when one of its component's +is redefined. @end defun @node Interactive Codes @@ -1127,6 +1146,96 @@ frame, the value is the frame to which the event was redirected. If the last event came from a keyboard macro, the value is @code{macro}. @end defvar +@cindex input devices +@cindex device names +Input events must come from somewhere; sometimes, that is a keyboard +macro, a signal, or `unread-command-events', but it is usually a +physical input device connected to a computer that is controlled by +the user. Those devices are referred to as @dfn{input devices}, and +Emacs associates each input event with the input device from which it +originated. They are identified by a name that is unique to each +input device. + +The ability to determine the precise input device used depends on the +details of each system. When that information is unavailable, Emacs +reports keyboard events as originating from the @samp{"Virtual core +keyboard"}, and other events as originating from the @samp{"Virtual +core pointer"}. (These values are used on every platform because the +X server reports them when detailed device information is not known.) + +@defvar last-event-device +This variable records the name of the input device from which the last +input event read was generated. It is @code{nil} if no such device +exists, i.e., the last input event was read from +@code{unread-command-events}, or it came from a keyboard macro. + +When the X Input Extension is being used on X Windows, the device name +is a string that is unique to each physical keyboard, pointing device +and touchscreen attached to the X server. Otherwise, it is either the +string @samp{"Virtual core pointer"} or @samp{"Virtual core +keyboard"}, depending on whether the event was generated by a pointing +device (such as a mouse) or a keyboard. +@end defvar + +@defun device-class frame name +There are various different types of devices, which can be determined +from their names. This function can be used to determined the correct +type of the device @var{name} for an event originating from +@var{frame}. + +The return value is one of the following symbols (``device classes''): + +@table @code +@item core-keyboard +The core keyboard; this is means the device is a keyboard-like device, +but no other characteristics are unknown. + +@item core-pointer +The core pointer; this means the device is a pointing device, but no +other characteristics are known. + +@item mouse +A computer mouse. + +@item trackpoint +A trackpoint or joystick (or other similar control.) + +@item eraser +The other end of a stylus on a graphics tablet, or a standalone +eraser. + +@item pen +The pointed end of a pen on a graphics tablet, a stylus, or some other +similar device. + +@item puck +A device that looks like a computer mouse, but reports absolute +coordinates relative to some other surface. + +@item power-button +A power button or volume button (or other similar control.) + +@item keyboard +A computer keyboard. + +@item touchscreen +A computer touchpad. + +@item pad +A collection of sensitive buttons, rings, and strips commonly found +around a drawing tablet. + +@item touchpad +An indirect touch device such as a touchpad. + +@item piano +A musical instrument such as an electronic keyboard. + +@item test +A device used by the XTEST extension to report input. +@end table +@end defun + @node Adjusting Point @section Adjusting Point After Commands @cindex adjusting point diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi index 469ff2d943d..058c9319544 100644 --- a/doc/lispref/debugging.texi +++ b/doc/lispref/debugging.texi @@ -194,6 +194,17 @@ If you set @code{debug-on-message} to a regular expression, Emacs will enter the debugger if it displays a matching message in the echo area. For example, this can be useful when trying to find the cause of a particular message. +@end defvar + +@defvar debug-allow-recursive-debug +You can evaluate forms in the current stack frame in the +@samp{*Backtrace*} buffer with the @key{e} command, and while +edebugging you can use the @key{e} and @key{C-x C-e} commands to do +something similar. By default, the debugger is inhibited by these +commands (because (re-)entering the debugger at this point will +usually take you out of the debugging context you're in). Set +@code{debug-allow-recursive-debug} to a non-@code{nil} value to allow +these commands to enter the debugger recursively. @end defvar To debug an error that happens during loading of the init @@ -387,11 +398,9 @@ possibilities.) variable is temporarily set according to @code{eval-expression-debug-on-error}. If the latter variable is non-@code{nil}, @code{debug-on-error} will temporarily be set to -@code{t}. This means that any further errors that occur while doing a -debugging session will (by default) trigger another backtrace. If -this is not what you want, you can either set -@code{eval-expression-debug-on-error} to @code{nil}, or set -@code{debug-on-error} to @code{nil} in @code{debugger-mode-hook}. +@code{t}. However, further errors that occur while debugging won't +(by default) trigger another debugger, because @code{inhibit-debugger} +will also be bound to non-@code{nil}. The debugger itself must be run byte-compiled, since it makes assumptions about the state of the Lisp interpreter. These @@ -522,6 +531,7 @@ Flag the current frame like @kbd{b}. Then continue execution like @kbd{c}, but temporarily disable break-on-entry for all functions that are set up to do so by @code{debug-on-entry}. +@vindex debug-allow-recursive-debug @item e Read a Lisp expression in the minibuffer, evaluate it (with the relevant lexical environment, if applicable), and print the @@ -530,7 +540,11 @@ variables, and the current buffer, as part of its operation; @kbd{e} temporarily restores their values from outside the debugger, so you can examine and change them. This makes the debugger more transparent. By contrast, @kbd{M-:} does nothing special in the debugger; it shows you -the variable values within the debugger. +the variable values within the debugger. By default, this command +suppresses the debugger during evaluation, so that an error in the +evaluated expression won't add a new error on top of the existing one. +Set the @code{debug-allow-recursive-debug} user option to a +non-@code{nil} value to override this. @item R Like @kbd{e}, but also save the result of evaluation in the diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 95e00e140da..9650d227909 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -336,7 +336,10 @@ functions call it with no arguments when their argument message is Usually this function is called when the next input event arrives after displaying an echo-area message. The function is expected to clear the message displayed by its counterpart function specified by -@code{set-message-function}. +@code{set-message-function}, but doesn't have to. If the function +wants the echo area to remain uncleared, it should return the symbol +@code{dont-clear-message}; any other value will result in the echo +area being cleared. The default value is the function that clears the message displayed in an active minibuffer. @@ -2142,7 +2145,7 @@ the buffer might contain long lines that will be truncated anyway. The optional argument @var{y-limit}, if non-@code{nil}, specifies the maximum Y coordinate beyond which text is to be ignored; it is therefore also the maximum pixel-height that the function can return. -If @var{y-limit} is nil or omitted, it means to considers all the +If @var{y-limit} is @code{nil} or omitted, it means to consider all the lines of text till the buffer position specified by @var{to}. Since calculating the pixel-height of a large buffer can take some time, it makes sense to specify this argument; in particular, if the caller @@ -2249,6 +2252,20 @@ This is a convenience function that uses @code{window-text-pixel-size} to compute the width of @var{string} (in pixels). @end defun +@defun window-char-pixel-width &optional window face +Return the average character width for the font used by @var{face} in +@var{window}. If @var{face} is @code{nil} or omitted, the +@code{default} face is used. If @var{windows} is @code{nil} or +omitted, the currently selected window is used. +@end defun + +@defun window-char-pixel-height &optional window face +Return the average character height for the font used by @var{face} in +@var{window}. If @var{face} is @code{nil} or omitted, the +@code{default} face is used. If @var{windows} is @code{nil} or +omitted, the currently selected window is used. +@end defun + @defun line-pixel-height This function returns the height in pixels of the line at point in the selected window. The value includes the line spacing of the line @@ -2924,7 +2941,8 @@ modifying the attributes of a named face. @defun face-attribute face attribute &optional frame inherit This function returns the value of the @var{attribute} attribute for -@var{face} on @var{frame}. +@var{face} on @var{frame}. @xref{Face Attributes}, for the supported +attributes. If @var{frame} is omitted or @code{nil}, that means the selected frame (@pxref{Input Focus}). If @var{frame} is @code{t}, this function @@ -3007,7 +3025,8 @@ for all frames. This function is mostly intended for internal usage. @defun set-face-attribute face frame &rest arguments This function sets one or more attributes of @var{face} for @var{frame}. The attributes specified in this way override the face -spec(s) belonging to @var{face}. +spec(s) belonging to @var{face}. @xref{Face Attributes}, for the +supported attributes. The extra arguments @var{arguments} specify the attributes to set, and the values for them. They should consist of alternating attribute @@ -3807,57 +3826,62 @@ Then, the font specifications for all but Chinese GB2312 characters have Chinese GB2312 characters has a wild card @samp{*} in the @var{family} field. -@defun set-fontset-font name character font-spec &optional frame add -This function modifies the existing fontset @var{name} to use the font -matching with @var{font-spec} for the specified @var{character}. +@defun set-fontset-font fontset characters font-spec &optional frame add +This function modifies the existing @var{fontset} to use the font +specified by @var{font-spec} for displaying the specified +@var{characters}. -If @var{name} is @code{nil}, this function modifies the fontset of the -selected frame or that of @var{frame} if @var{frame} is not +If @var{fontset} is @code{nil}, this function modifies the fontset of +the selected frame or that of @var{frame} if @var{frame} is not @code{nil}. -If @var{name} is @code{t}, this function modifies the default -fontset, whose short name is @samp{fontset-default}. +If @var{fontset} is @code{t}, this function modifies the default +fontset, whose short name as a string is @samp{fontset-default}. -In addition to specifying a single codepoint, @var{character} may be a -cons @code{(@var{from} . @var{to})}, where @var{from} and @var{to} are -character codepoints. In that case, use @var{font-spec} for all the -characters in the range @var{from} and @var{to} (inclusive). +The @var{characters} argument can be a single character which should +be displayed using @var{font-spec}. It can also be a cons cell +@w{@code{(@var{from} . @var{to})}}, where @var{from} and @var{to} are +characters. In that case, use @var{font-spec} for all the characters +in the range @var{from} and @var{to} (inclusive). -@var{character} may be a charset (@pxref{Character Sets}). In that -case, use @var{font-spec} for all the characters in the charset. +@var{characters} may be a charset symbol (@pxref{Character Sets}). In +that case, use @var{font-spec} for all the characters in the charset. -@var{character} may be a script name (@pxref{Character Properties, +@var{characters} may be a script symbol (@pxref{Character Properties, char-script-table}). In that case, use @var{font-spec} for all the characters belonging to the script. -@var{character} may be @code{nil}, which means to use @var{font-spec} -for any character which no font-spec is specified. +@var{characters} may be @code{nil}, which means to use @var{font-spec} +for any character in @var{fontset} for which no font-spec is +specified. @var{font-spec} may be a font-spec object created by the function @code{font-spec} (@pxref{Low-Level Font}). -@var{font-spec} may be a cons; @code{(@var{family} . @var{registry})}, -where @var{family} is a family name of a font (possibly including a -foundry name at the head), @var{registry} is a registry name of a font -(possibly including an encoding name at the tail). +@var{font-spec} may be a cons cell @w{@code{(@var{family} +. @var{registry})}}, where @var{family} is a family name of a font +(possibly including a foundry name at the head), and @var{registry} is +a registry name of a font (possibly including an encoding name at the +tail). @var{font-spec} may be a font name, a string. @var{font-spec} may be @code{nil}, which explicitly specifies that -there's no font for the specified @var{character}. This is useful, +there's no font for the specified @var{characters}. This is useful, for example, to avoid expensive system-wide search for fonts for characters that have no glyphs, like those from the Unicode Private Use Area (PUA). The optional argument @var{add}, if non-@code{nil}, specifies how to -add @var{font-spec} to the font specifications previously set. If it -is @code{prepend}, @var{font-spec} is prepended. If it is -@code{append}, @var{font-spec} is appended. By default, -@var{font-spec} overrides the previous settings. +add @var{font-spec} to the font specifications previously set for +@var{characters}. If it is @code{prepend}, @var{font-spec} is +prepended to the existing specs. If it is @code{append}, +@var{font-spec} is appended. By default, @var{font-spec} overwrites +the previously set font specs. -For instance, this changes the default fontset to use a font of which +For instance, this changes the default fontset to use a font whose family name is @samp{Kochi Gothic} for all characters belonging to -the charset @code{japanese-jisx0208}. +the charset @code{japanese-jisx0208}: @smallexample (set-fontset-font t 'japanese-jisx0208 @@ -3997,13 +4021,26 @@ required; and @code{gpos} is a list of OpenType GPOS feature tag symbols, or @code{nil} if none is required. If @code{gsub} or @code{gpos} is a list, a @code{nil} element in that list means that the font must not match any of the remaining tag symbols. The -@code{gpos} element may be omitted. +@code{gpos} element may be omitted. For the list of OpenType script, +language, and feature tags, see +@uref{https://docs.microsoft.com/en-us/typography/opentype/spec/ttoreg, +the list of registered OTF tags}. + +@item :type +@cindex font backend +The symbol that specifies the @dfn{font backend} used to draw the +characters. The possible values depend on the platform and on how +Emacs was configured at build time. Typical values include +@code{ftcrhb} and @code{xfthb} on X, @code{harfbuzz} on MS-Windows, +@code{ns} on GNUstep, etc. It can also be @code{nil} if left +unspecified, typically in a font-spec. @end table @end defun @defun font-put font-spec property value Set the font property @var{property} in the font-spec @var{font-spec} -to @var{value}. +to @var{value}. The @var{property} can any of the ones described +above. @end defun @cindex font entity @@ -4047,12 +4084,28 @@ object, a font entity, or a font spec. @defun font-get font property This function returns the value of the font property @var{property} -for @var{font}. +for @var{font}. The @var{property} can any of the ones that +@code{font-spec} supports. If @var{font} is a font spec and the font spec does not specify @var{property}, the return value is @code{nil}. If @var{font} is a font object or font entity, the value for the @var{:script} property -may be a list of scripts supported by the font. +may be a list of scripts supported by the font, and the value of the +@code{:otf} property is a cons of the form @w{@code{(@var{gsub} +. @var{gpos})}}, where @var{gsub} and @var{gpos} are lists +representing OpenType features supported by the font, of the form + +@smallexample +((@var{script-tag} (@var{langsys-tag} @var{feature}@dots{}) @dots{}) @dots{}) +@end smallexample + +@noindent where @var{script-tag}, @var{langsys-tag}, and @var{feature} +are symbols representing OpenType layout tags. + +If @var{font} is a font object, the special property +@code{:combining-capability} is non-@code{nil} if the font backend of +@var{font} supports rendering of combining characters for non-OpenType +fonts. @end defun @defun font-face-attributes font &optional frame @@ -4642,14 +4695,15 @@ about to be executed. This feature has nothing to do with @defvar overlay-arrow-string This variable holds the string to display to call attention to a particular line, or @code{nil} if the arrow feature is not in use. -On a graphical display the contents of the string are ignored; instead a -glyph is displayed in the fringe area to the left of the display area. +On a graphical display the contents of the string are ignored if the +left fringe is shown; instead a glyph is displayed in the fringe area +to the left of the display area. @end defvar @defvar overlay-arrow-position This variable holds a marker that indicates where to display the overlay arrow. It should point at the beginning of a line. On a non-graphical -display the arrow text +display, or when the left fringe is not shown, the arrow text appears at the beginning of that line, overlaying any text that would otherwise appear. Since the arrow is usually short, and the line usually begins with indentation, normally nothing significant is @@ -4681,11 +4735,12 @@ this list. Each variable on this list can have properties @code{overlay-arrow-string} and @code{overlay-arrow-bitmap} that -specify an overlay arrow string (for text terminals) or fringe bitmap -(for graphical terminals) to display at the corresponding overlay -arrow position. If either property is not set, the default -@code{overlay-arrow-string} or @code{overlay-arrow} fringe indicator -is used. +specify an overlay arrow string (for text terminals or graphical +terminals without the left fringe shown) or fringe bitmap +(for graphical terminals with a left fringe) to display at the +corresponding overlay arrow position. If either property is not set, +the default @code{overlay-arrow-string} or @code{overlay-arrow} fringe +indicator is used. @node Scroll Bars @@ -5505,6 +5560,12 @@ symbol}. The symbols for the above formats are, respectively, @code{pbm}, @code{xbm}, @code{xpm}, @code{gif}, @code{jpeg}, @code{tiff}, @code{png}, @code{svg}, and @code{webp}. + On some platforms, the built-in image support that doesn't require +any optional libraries includes BMP images.@footnote{ +On MS-Windows, this requires @code{w32-use-native-image-API} to be set +non-@code{nil}. +} + Furthermore, if you build Emacs with ImageMagick (@code{libMagickWand}) support, Emacs can display any image format that ImageMagick can. @xref{ImageMagick Images}. All images @@ -7509,7 +7570,7 @@ end of the buffer continues from the other end. If @var{display-message} is non-@code{nil}, the button's help-echo string is displayed. Any button with a non-@code{nil} @code{skip} property is skipped over. Returns the button found, and signals an error if no -buttons can be found. If @var{no-error} is non-@code{nil}, return nil +buttons can be found. If @var{no-error} is non-@code{nil}, return @code{nil} instead of signaling the error. @end deffn @@ -7521,7 +7582,7 @@ end of the buffer continues from the other end. If @var{display-message} is non-@code{nil}, the button's help-echo string is displayed. Any button with a non-@code{nil} @code{skip} property is skipped over. Returns the button found, and signals an error if no -buttons can be found. If @var{no-error} is non-@code{nil}, return nil +buttons can be found. If @var{no-error} is non-@code{nil}, return @code{nil} instead of signaling the error. @end deffn @@ -8273,7 +8334,7 @@ there is no available font (on a graphical display), and characters which cannot be encoded by the terminal's coding system (on a text terminal). -@vindex glyphless-display-mode +@findex glyphless-display-mode The @code{glyphless-display-mode} minor mode can be used to toggle displaying glyphless characters in a convenient manner in the current buffer. If this mode is enabled, all the glyphless characters are diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index eff9621628e..0fc5271d5ad 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -700,8 +700,12 @@ on this process. @table @kbd @item e @var{exp} @key{RET} Evaluate expression @var{exp} in the context outside of Edebug -(@code{edebug-eval-expression}). That is, Edebug tries to minimize its -interference with the evaluation. +(@code{edebug-eval-expression}). That is, Edebug tries to minimize +its interference with the evaluation. By default, this command +suppresses the debugger during evaluation, so that an error in the +evaluated expression won't add a new error on top of the existing one. +Set the @code{debug-allow-recursive-debug} user option to a +non-@code{nil} value to override this. @item M-: @var{exp} @key{RET} Evaluate expression @var{exp} in the context of Edebug itself diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index 6e59e87d286..75905658e64 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -1450,13 +1450,19 @@ is owned by the user with name @samp{lh}. is in the group with name @samp{users}. @item (20614 64019 50040 152000) -was last accessed on October 23, 2012, at 20:12:03.050040152 UTC. +was last accessed on October 23, 2012, at 20:12:03.050040152 UTC@. +(This timestamp is @code{(1351023123050040152 . 1000000000)} +if @code{current-time-list} is @code{nil}.) @item (20000 23 0 0) -was last modified on July 15, 2001, at 08:53:43 UTC. +was last modified on July 15, 2001, at 08:53:43.000000000 UTC@. +(This timestamp is @code{(1310720023000000000 . 1000000000)} +if @code{current-time-list} is @code{nil}.) @item (20614 64555 902289 872000) -last had its status changed on October 23, 2012, at 20:20:59.902289872 UTC. +last had its status changed on October 23, 2012, at 20:20:59.902289872 UTC@. +(This timestamp is @code{(1351023659902289872 . 1000000000)} +if @code{current-time-list} is @code{nil}.) @item 122295 is 122295 bytes long. (It may not contain 122295 characters, though, @@ -3344,6 +3350,7 @@ first, before handlers for jobs such as remote file access. @code{get-file-buffer}, @code{insert-directory}, @code{insert-file-contents},@* +@code{list-system-processes}, @code{load}, @code{lock-file}, @code{make-auto-save-file-name}, @code{make-directory}, @@ -3352,7 +3359,7 @@ first, before handlers for jobs such as remote file access. @code{make-nearby-temp-file}, @code{make-process}, @code{make-symbolic-link},@* -@code{process-file}, +@code{process-attributes}, @code{process-file}, @code{rename-file}, @code{set-file-acl}, @code{set-file-modes}, @code{set-file-selinux-context}, @code{set-file-times}, @code{set-visited-file-modtime}, @code{shell-command}, @@ -3405,6 +3412,7 @@ first, before handlers for jobs such as remote file access. @code{get-file-buffer}, @code{insert-directory}, @code{insert-file-contents}, +@code{list-system-processes}, @code{load}, @code{lock-file}, @code{make-auto-save-file-name}, @code{make-direc@discretionary{}{}{}tory}, @@ -3413,7 +3421,7 @@ first, before handlers for jobs such as remote file access. @code{make-nearby-temp-file}, @code{make-process}, @code{make-symbolic-link}, -@code{process-file}, +@code{process-attributes}, @code{process-file}, @code{rename-file}, @code{set-file-acl}, @code{set-file-modes}, @code{set-file-selinux-context}, @code{set-file-times}, @code{set-visited-file-modtime}, @code{shell-command}, diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index bae8eb3c703..05c6e4b719b 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -3512,10 +3512,18 @@ enabled. Typically, @var{body} would use @code{read-event} to read the motion events and modify the display accordingly. @xref{Motion Events}, for the format of mouse motion events. -The value of @code{track-mouse} is that of the last form in @var{body}. -You should design @var{body} to return when it sees the up-event that -indicates the release of the button, or whatever kind of event means -it is time to stop tracking. +The value of @code{track-mouse} is that of the last form in +@var{body}. You should design @var{body} to return when it sees the +up-event that indicates the release of the button, or whatever kind of +event means it is time to stop tracking. Its value also controls how +mouse events are reported while a mouse button is held down: if it is +@code{dropping} or @code{drag-source}, the motion events are reported +relative to the frame underneath the pointer. If there is no such +frame, the events will be reported relative to the frame the mouse +buttons were first pressed on. In addition, the @code{posn-window} of +the mouse position list will be @code{nil} if the value is +@code{drag-source}. This is useful to determine if a frame is not +directly visible underneath the mouse pointer. The @code{track-mouse} form causes Emacs to generate mouse motion events by binding the variable @code{track-mouse} to a @@ -3918,11 +3926,11 @@ upper-case names, in accord with X Window System conventions. If @var{type} is @code{nil}, that stands for @code{PRIMARY}. If @var{data} is @code{nil}, it means to clear out the selection. -Otherwise, @var{data} may be a string, a symbol, an integer (or a cons -of two integers or list of two integers), an overlay, or a cons of two -markers pointing to the same buffer. An overlay or a pair of markers -stands for text in the overlay or between the markers. The argument -@var{data} may also be a vector of valid non-vector selection values. +Otherwise, @var{data} may be a string, a symbol, an integer, an +overlay, or a cons of two markers pointing to the same buffer. An +overlay or a pair of markers stands for text in the overlay or between +the markers. The argument @var{data} may also be a vector of valid +non-vector selection values. This function returns @var{data}. @end deffn @@ -4038,6 +4046,55 @@ there is no match there, Emacs looks for a match in still no match has been found, the text for the URL is inserted. If you want to alter Emacs behavior, you can customize these variables. +@cindex initiating drag-and-drop + On capable window systems, Emacs also supports dragging contents +from its frames to windows of other applications. + +@defun x-begin-drag targets &optional action frame return-frame allow-current-frame +This function begins a drag from @var{frame}, and returns when the +drag-and-drop operation ends, either because the drop was successful, +or because the drop was rejected. The drop occurs when all mouse +buttons are released on top of an X window other than @var{frame} (the +@dfn{drop target}), or any X window if @var{allow-current-frame} is +non-@code{nil}. + +@var{targets} is a list of strings describing selection targets, much +like the @var{data-type} argument to @code{gui-get-selection}, that +the drop target can request from Emacs (@pxref{Window System +Selections}). + +@var{action} is a symbol describing the action recommended to the +target. It can either be @code{XdndActionCopy}, which +means to copy the contents of the selection @code{XdndSelection} to +the drop target; or @code{XdndActionMove}, which means copy as with +@code{XdndActionCopy}, and in addition the caller should delete +whatever was stored in that selection after copying it. + +@var{action} may also be an alist which associates between symbols +describing the available actions, and strings that the drop target is +expected to present to the user to choose between the available +actions. + +If @var{return-frame} is non-@code{nil} and the mouse moves over an +Emacs frame after first moving out of @var{frame}, then the frame to +which the mouse moves will be returned immediately. If +@var{return-frame} is the symbol @code{now}, then any frame underneath +the mouse pointer will be returned without waiting for the mouse to +first move out of @var{frame}. @var{return-frame} is useful when you +want to treat dragging content from one frame to another specially, +while also being able to drag content to other programs, but it is not +guaranteed to work on all systems and with all window managers. + +If the drop was rejected or no drop target was found, this function +returns @code{nil}. Otherwise, it returns a symbol describing the +action the target chose to perform, which can differ from @var{action} +if that isn't supported by the drop target. @code{XdndActionPrivate} +is also a valid return value in addition to @code{XdndActionCopy} and +@code{XdndActionMove}; it means that the drop target chose to perform +an unspecified action, and no further processing is required by the +caller. +@end defun + @node Color Names @section Color Names diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index 207919ea645..2f386eaa47e 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -22,6 +22,7 @@ define them. * Function Cells:: Accessing or setting the function definition of a symbol. * Closures:: Functions that enclose a lexical environment. +* OClosures:: Function objects * Advising Functions:: Adding to the definition of a function. * Obsolete Functions:: Declaring functions obsolete. * Inline Functions:: Functions that the compiler will expand inline. @@ -1509,6 +1510,116 @@ exposed to the rest of the Lisp world is considered an internal implementation detail. For this reason, we recommend against directly examining or altering the structure of closure objects. +@node OClosures +@section Open Closures + +Traditionally, functions are opaque objects which offer no other +functionality but to call them. Emacs Lisp functions aren't fully +opaque since you can extract some info out of them such as their +docstring, their arglist, or their interactive spec, but they are +mostly opaque. This is usually what we want, but occasionally we need +functions to expose a bit more information about themselves. + +OClosures are functions which carry additional type information, +and expose some information in the form of slots which you can access +via accessor functions. + +They are defined in two steps: first @code{oclosure-define} is used to +define new OClosure types by specifying the slots carried by those +OClosures, and then @code{oclosure-lambda} is used to create an +OClosure object of a given type. + +Say we want to define keyboard macros, i.e. interactive functions +which re-execute a sequence of key events. You could do it with +a plain function as follows: +@example +(defun kbd-macro (key-sequence) + (lambda (&optional arg) + (interactive "P") + (execute-kbd-macro key-sequence arg))) +@end example +But with such a definition there is no easy way to extract the +@var{key-sequence} from that function, for example to print it. + +We can solve this problem using OClosures as follows. First we define +the type of our keyboard macros (to which we decided to add +a @code{counter} slot while at it): +@example +(oclosure-define kbd-macro + "Keyboard macro." + keys (counter :mutable t)) +@end example +After which we can rewrite our @code{kbd-macro} function: +@example +(defun kbd-macro (key-sequence) + (oclosure-lambda (kbd-macro (keys key-sequence) (counter 0)) + (&optional arg) + (interactive "p") + (execute-kbd-macro keys arg) + (setq counter (1+ counter)))) +@end example +As you can see, the @code{keys} and @code{counter} slots of the +OClosure can be accessed as local variables from within the body +of the OClosure. But we can now also access them from outside of the +body of the OClosure, for example to describe a keyboard macro: +@example +(defun describe-kbd-macro (km) + (if (not (eq 'kbd-macro (oclosure-type km))) + (message "Not a keyboard macro") + (let ((keys (kbd-macro--keys km)) + (counter (kbd-macro--counter km))) + (message "Keys=%S, called %d times" keys counter)))) +@end example +Where @code{kbd-macro--keys} and @code{kbd-macro--counter} are +accessor functions generated by the @code{oclosure-define} macro. + +@defmac oclosure-define name &optional docstring &rest slots +This macro defines a new OClosure type along with accessor functions +for its slots. @var{name} can be a symbol (the name of +the new type), or a list of the form @code{(@var{name} . @var{type-props})} in +which case @var{type-props} is a list of additional properties. +@var{slots} is a list of slot descriptions where each slot can be +either a symbol (the name of the slot) or it can be of the form +@code{(@var{slot-name} . @var{slot-props})} where @var{slot-props} is +a property list. + +For each slot, the macro creates an accessor function named +@code{@var{name}--@var{slot-name}}. By default slots are immutable. +If you need a slot to be mutable, you need to specify it with the +@code{:mutable} slot property, after which it can be mutated for +example with @code{setf}. + +Beside slot accessors, the macro can create a predicate and +functional update functions according to @var{type-props}: +a @code{(:predicate @var{pred-name})} in the @var{type-props} causes +the definition of a predicate function under the name @var{pred-name}, +and @code{(:copier @var{copier-name} @var{copier-arglist})} causes the +definition of a functional update function which takes an OClosure of +type @var{name} as first argument and returns a copy of it with the +slots named in @var{copier-arglist} modified to the value passed in the +corresponding argument. +@end defmac + +@defmac oclosure-lambda (type . slots) arglist &rest body +This macro creates an anonymous OClosure of type @var{type}. +@var{slots} should be a list of elements of the form @code{(@var{slot-name} +@var{exp})}. +At run time, each @var{exp} is evaluated, in order, after which +the OClosure is created with its slots initialized with the +resulting values. + +When called as a function, the OClosure will accept arguments +according to @var{arglist} and will execute the code in @var{body}. +@var{body} can refer to the value of any of its slot directly as if it +were a local variable that had been captured by static scoping. +@end defmac + +@defun oclosure-type object +This function returns the OClosure type (a symbol) of @var{object} if it is an +OClosure, and @code{nil} otherwise. +@end defun + + @node Advising Functions @section Advising Emacs Lisp Functions @cindex advising functions diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi index 10a12940a15..d53bfad8e9e 100644 --- a/doc/lispref/help.texi +++ b/doc/lispref/help.texi @@ -158,6 +158,13 @@ the function definition has no documentation string. In that case, @code{documentation} returns @code{nil}. @end defun +@defun function-documentation function +Generic function used by @code{documentation} to extract the raw +docstring from a function object. You can specify how to get the +docstring of a specific function type by adding a corresponding method +to it. +@end defun + @defun face-documentation face This function returns the documentation string of @var{face} as a face. diff --git a/doc/lispref/intro.texi b/doc/lispref/intro.texi index 5afd2f4ecf2..975215d6976 100644 --- a/doc/lispref/intro.texi +++ b/doc/lispref/intro.texi @@ -503,9 +503,11 @@ if the information is not available. @example @group emacs-build-time - @result{} (20614 63694 515336 438000) + @result{} (25194 55894 8547 617000) @end group @end example +(This timestamp is @code{(1651169878008547617 . 1000000000)} +if @code{current-time-list} was @code{nil} when Emacs was built.) @end defvar @defvar emacs-version diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index 9d3dc8fe420..a037c228f13 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi @@ -1643,7 +1643,7 @@ non-@code{nil}, the definition will be removed. This is almost the same as setting the definition to @code{nil}, but makes a difference if the @var{keymap} has a parent, and @var{key} is shadowing the same binding in the parent. With @var{remove}, subsequent lookups will -return the binding in the parent, and with a nil @var{def}, the +return the binding in the parent, whereas with a @code{nil} definition the lookups will return @code{nil}. @end defun diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi index f05f087ba70..be81b5b3fbb 100644 --- a/doc/lispref/minibuf.texi +++ b/doc/lispref/minibuf.texi @@ -244,6 +244,13 @@ This function works by calling the value)) @end group @end smallexample + +@findex read-string-from-buffer +If you have a long string (for instance, one that is several lines +long) that you wish to edit, using @code{read-string} may not be +ideal. In that case, popping to a new, normal buffer where the user +can edit the string may be more convenient, and you can use the +@code{read-string-from-buffer} function to do that. @end defun @defun read-regexp prompt &optional defaults history @@ -1936,6 +1943,7 @@ completion function is trying to complete. If the symbol matches one of the keys in @code{completion-category-overrides}, the usual completion behavior is overridden. @xref{Completion Variables}. +@cindex @code{annotation-function}, in completion @item annotation-function The value should be a function for @dfn{annotating} completions. The function should take one argument, @var{string}, which is a possible @@ -1945,6 +1953,7 @@ Unless this function puts own face on the annotation suffix string, the @code{completions-annotations} face is added by default to that string. +@cindex @code{affixation-function}, in completion @item affixation-function The value should be a function for adding prefixes and suffixes to completions. The function should take one argument, @@ -1955,6 +1964,7 @@ the completion string in the @file{*Completions*} buffer, and a suffix displayed after the completion string. This function takes priority over @code{annotation-function}. +@cindex @code{group-function}, in completion @item group-function The value should be a function for grouping the completion candidates. The function must take two arguments, @var{completion}, which is a @@ -1965,12 +1975,14 @@ can also be @code{nil}. Otherwise the function must return the transformed candidate. The transformation can for example remove a redundant prefix, which is displayed in the group title. +@cindex @code{display-sort-function}, in completion @item display-sort-function The value should be a function for sorting completions. The function should take one argument, a list of completion strings, and return a sorted list of completion strings. It is allowed to alter the input list destructively. +@cindex @code{cycle-sort-function}, in completion @item cycle-sort-function The value should be a function for sorting completions, when @code{completion-cycle-threshold} is non-@code{nil} and the user is diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index 905b21c0d48..c6ea74324bc 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -1912,6 +1912,16 @@ This means ``use in modes derived from @code{text-mode}, but nowhere else''. (There's an implicit @code{nil} element at the end.) @end defmac +@findex buffer-local-restore-state +@defmac buffer-local-set-state variable value... +Minor modes often set buffer-local variables that affect some features +in Emacs. When a minor mode is switched off, the mode is expected to +restore the previous state of these variables. This convenience macro +helps with doing that: It works much like @code{setq-local}, but +returns an object that can be used to restore these values back to +their previous values/states (using the companion function +@code{buffer-local-restore-state}). +@end defmac @node Mode Line Format @section Mode Line Format @@ -3207,7 +3217,9 @@ Non-@code{nil} means that regular expression matching for the sake of You can use @code{font-lock-add-keywords} to add additional search-based fontification rules to a major mode, and -@code{font-lock-remove-keywords} to remove rules. +@code{font-lock-remove-keywords} to remove rules. You can also +customize the @code{font-lock-ignore} option to selectively disable +fontification rules for keywords that match certain criteria. @defun font-lock-add-keywords mode keywords &optional how This function adds highlighting @var{keywords}, for the current buffer @@ -3277,6 +3289,99 @@ mode @emph{and} all modes derived from it, do this instead: font-lock-keyword-face))))) @end smallexample +@defopt font-lock-ignore +@cindex selectively disabling font-lock fontifications +This option defines conditions for selectively disabling +fontifications due to certain Font Lock keywords. If non-@code{nil}, +its value is a list of elements of the following form: + +@example +(@var{symbol} @var{condition} @dots{}) +@end example + +Here, @var{symbol} is a symbol, usually a major or minor mode. The +subsequent @var{condition}s of a @var{symbol}'s list element will be in +effect if @var{symbol} is bound and its value is non-@code{nil}. For +a mode's symbol, it means that the current major mode is derived from +that mode, or that minor mode is enabled in the buffer. When a +@var{condition} is in effect, any fontifications caused by +@code{font-lock-keywords} elements that match the @var{condition} will +be disabled. + +Each @var{condition} can be one of the following: + +@table @asis +@item a symbol +This condition matches any element of Font Lock keywords that +references the symbol. This is usually a face, but can be any symbol +referenced by an element of the @code{font-lock-keywords} list. The +symbol can contain wildcards: @code{*} matches any string in the +symbol'ss name, @code{?} matches a single character, and +@code{[@var{char-set}]}, where @var{char-set} is a string of one or +more characters, matches a single character from the set. + +@item a string +This condition matches any element of Font Lock keywords whose +@var{matcher} is a regexp which matches the string. In other words, +this condition matches a Font Lock rule which highlights the string. +Thus, the string could be a specific program keyword whose +highlighting you want to disable. + +@item @code{(pred @var{function})} +This condition matches any element of Font Lock keywords for which +@var{function}, when called with the element as the argument, returns +non-@code{nil}. + +@item @code{(not @var{condition})} +This matches if @var{condition} doesn’t. + +@item @code{(and @var{condition} @dots{})} +This matches if each of the @var{condition}s matches. + +@item @code{(or @var{condition} @dots{})} +This matches if at least one of the @var{condition}s matches. + +@item @code{(except @var{condition})} +This condition can only be used at top level or inside an +@code{or} clause. It undoes the effect of a previously matching +condition on the same level. +@end table +@end defopt + +As an example, consider the following setting: + +@smallexample +(setq font-lock-ignore + '((prog-mode font-lock-*-face + (except help-echo)) + (emacs-lisp-mode (except ";;;###autoload)") + (whitespace-mode whitespace-empty-at-bob-regexp) + (makefile-mode (except *)))) +@end smallexample + +Line by line, this does the following: + +@enumerate +@item +In all programming modes, disable fontifications due to all font-lock +keywords that apply one of the standard font-lock faces (excluding +strings and comments, which are covered by syntactic Font Lock). + +@item +However, keep any keywords that add a @code{help-echo} text property. + +@item +In Emacs Lisp mode, also keep the highlighting of autoload cookies, +which would have been excluded by the first condition. + +@item +When @code{whitespace-mode} (a minor mode) is enabled, also don't +highlight an empty line at beginning of buffer. + +@item +Finally, in Makefile mode, don't apply any conditions. +@end enumerate + @node Other Font Lock Variables @subsection Other Font Lock Variables diff --git a/doc/lispref/nonascii.texi b/doc/lispref/nonascii.texi index f495910fcd6..d7d25dc36af 100644 --- a/doc/lispref/nonascii.texi +++ b/doc/lispref/nonascii.texi @@ -855,15 +855,24 @@ function to all or part of the characters in a charset: Call @var{function} for characters in @var{charset}. @var{function} is called with two arguments. The first one is a cons cell @code{(@var{from} . @var{to})}, where @var{from} and @var{to} -indicate a range of characters contained in charset. The second -argument passed to @var{function} is @var{arg}. +indicate a range of characters contained in @var{charset}. The second +argument passed to @var{function} is @var{arg}, or @code{nil} if +@var{arg} is omitted. By default, the range of codepoints passed to @var{function} includes all the characters in @var{charset}, but optional arguments @var{from-code} and @var{to-code} limit that to the range of characters between these two codepoints of @var{charset}. If either of them is @code{nil}, it defaults to the first or last codepoint of -@var{charset}, respectively. +@var{charset}, respectively. Note that @var{from-code} and +@var{to-code} are @var{charset}'s codepoints, not the Emacs codes of +characters; by contrast, the values @var{from} and @var{to} in the +cons cell passed to @var{function} @emph{are} Emacs character codes. +Those Emacs character codes are either Unicode code points, or Emacs +internal code points that extend Unicode and are beyond the Unicode +range of characters @code{0..#x10FFFF} (@pxref{Text Representations}). +The latter happens rarely, with legacy CJK charsets for codepoints of +@var{charset} which specify characters not yet unified with Unicode. @end defun @node Scanning Charsets diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 9cb9bc75d04..9df708532d8 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -699,7 +699,7 @@ If you started Emacs from a terminal, the parent process normally resumes control. The low-level primitive for killing Emacs is @code{kill-emacs}. -@deffn Command kill-emacs &optional exit-data +@deffn Command kill-emacs &optional exit-data restart This command calls the hook @code{kill-emacs-hook}, then exits the Emacs process and kills it. @@ -714,6 +714,10 @@ input) can read them. If @var{exit-data} is neither an integer nor a string, or is omitted, that means to use the (system-specific) exit status which indicates successful program termination. + +If @var{restart} is non-@code{nil}, instead of just exiting at the +end, start a new Emacs process, using the same command line arguments +as the currently running Emacs process. @end deffn @cindex SIGTERM @@ -756,6 +760,13 @@ the remaining functions in this hook. Calling @code{kill-emacs} directly does not run this hook. @end defopt +@deffn Command restart-emacs +This command does the same as @code{save-buffers-kill-emacs}, but +instead of just killing the current Emacs process at the end, it'll +restart a new Emacs process, using the same command line arguments as +the currently running Emacs process. +@end deffn + @node Suspending Emacs @subsection Suspending Emacs @cindex suspending Emacs @@ -1303,10 +1314,16 @@ zone. @cindex Lisp timestamp @cindex timestamp, Lisp +@cindex Coordinated Universal Time +@cindex Universal Time +@cindex UTC +@cindex leap seconds Many functions like @code{current-time} and @code{file-attributes} return @dfn{Lisp timestamp} values that count seconds, and that can represent absolute time by counting seconds since the @dfn{epoch} of -1970-01-01 00:00:00 UTC. +1970-01-01 00:00:00 UTC (Coordinated Universal Time). Typically these +counts ignore leap seconds; however, GNU and some other operating +systems can be configured to count leap seconds. Although traditionally Lisp timestamps were integer pairs, their form has evolved and programs ordinarily should not depend on the @@ -1328,11 +1345,7 @@ A pair of integers @code{(@var{ticks} . @var{hz})}, where @var{hz} is positive. This represents @var{ticks}/@var{hz} seconds, which is the same time as plain @var{ticks} if @var{hz} is 1. A common value for @var{hz} is 1000000000, for a nanosecond-resolution -clock.@footnote{Currently @var{hz} should be at least 65536 to avoid -compatibility warnings when the timestamp is passed to standard -functions, as previous versions of Emacs would interpret such a -timestamps differently due to backward-compatibility concerns. These -warnings are intended to be removed in a future Emacs version.} +clock. @item A list of four integers @code{(@var{high} @var{low} @var{micro} @@ -1346,7 +1359,8 @@ This represents the number of seconds using the formula: @tex $high \times 2^{16} + low + micro \times 10^{-6} + pico \times 10^{-12}$. @end tex -In some cases, functions may default to returning two- or +If @code{current-time-list} is @code{t}, +some functions may default to returning two- or three-element lists, with omitted @var{micro} and @var{pico} components defaulting to zero. On all current machines @var{pico} is a multiple of 1000, but this @@ -1357,7 +1371,7 @@ may change as higher-resolution clocks become available. Function arguments, e.g., the @var{time} argument to @code{format-time-string}, accept a more-general @dfn{time value} format, which can be a Lisp timestamp, @code{nil} for the current -time, a single floating-point number for seconds, or a list +time, a finite floating-point number for seconds, or a list @code{(@var{high} @var{low} @var{micro})} or @code{(@var{high} @var{low})} that is a truncated list timestamp with missing elements taken to be zero. @@ -1367,8 +1381,8 @@ Time values can be converted to and from calendrical and other forms. Some of these conversions rely on operating system functions that limit the range of possible time values, and signal an error such as @samp{"Specified time is not representable"} if the -limits are exceeded. For instance, a system may not support years -before 1970, or years before 1901, or years far in the future. +limits are exceeded. For instance, a system might not support +timestamps before the epoch, or years far in the future. You can convert a time value into a human-readable string using @code{format-time-string}, into a Lisp timestamp using @code{time-convert}, and into other forms using @@ -1400,13 +1414,28 @@ The operating system limits the range of time and zone values. @end example @end defun +@defvar current-time-list +This boolean variable is a transition aid. If @code{t}, +@code{current-time} and related functions return timestamps in list +form, typically @code{(@var{high} @var{low} @var{micro} @var{pico})}; +otherwise, they use @code{(@var{ticks} . @var{hz})} form. Currently +this variable defaults to @code{t}, for behavior compatible with +previous Emacs versions. Developers are encouraged to test +timestamp-related code with this variable set to @code{nil}, as it +will default to @code{nil} in a future Emacs version, and will be +removed in some version after that. +@end defvar + @defun current-time This function returns the current time as a Lisp timestamp. -Although the timestamp takes the form @code{(@var{high} @var{low} -@var{micro} @var{pico})} in the current Emacs release, this is -planned to change in a future Emacs version. You can use the -@code{time-convert} function to convert a timestamp to some other -form. @xref{Time Conversion}. +If @code{current-time-list} is @code{nil}, +the timestamp has the form @code{(@var{ticks} . @var{hz})} where +@var{ticks} counts clock ticks and @var{hz} is the clock ticks per second. +Otherwise, the timestamp has the list form +@code{(@var{high} @var{low} @var{usec} @var{psec})}. +You can use @code{(time-convert nil t)} or @code{(time-convert nil 'list)} +to obtain a particular form regardless of the value of +@code{current-time-list}. @xref{Time Conversion}. @end defun @defun float-time &optional time @@ -1422,6 +1451,13 @@ as @samp{0.1} but is slightly greater than 1/10. @code{time-to-seconds} is an alias for this function. @end defun +@defun current-cpu-time +Return the current @acronym{CPU} time along with its resolution. The +return value is a pair @code{(CPU-TICKS . TICKS-PER-SEC)}. The +@var{CPU-TICKS} counter can wrap around, so values cannot be +meaningfully compared if too much time has passed between them. +@end defun + @node Time Zone Rules @section Time Zone Rules @cindex time zone rules @@ -1434,11 +1470,11 @@ to default to Universal Time with @code{(setenv "TZ" "UTC0")}. If which is a platform-dependent default time zone. The set of supported @env{TZ} strings is system-dependent. GNU and -many other systems support the tzdata database, e.g., +many other systems support TZDB timezones, e.g., @samp{"America/New_York"} specifies the time zone and daylight saving time history for locations near New York City. GNU and most other systems support POSIX-style @env{TZ} strings, e.g., -@samp{"EST+5EDT,M4.1.0/2,M10.5.0/2"} specifies the rules used in New +@samp{"EST5EDT,M4.1.0,M10.5.0"} specifies the rules used in New York from 1987 through 2006. All systems support the string @samp{"UTC0"} meaning Universal Time. @@ -1490,18 +1526,20 @@ The operating system limits the range of time and zone values. These functions convert time values (@pxref{Time of Day}) to Lisp timestamps, or into calendrical information and vice versa. - Many 32-bit operating systems are limited to system times containing -32 bits of information in their seconds component; these systems -typically handle only the times from 1901-12-13 20:45:52 through -2038-01-19 03:14:07 Universal Time. However, 64-bit and some 32-bit operating -systems have larger seconds components, and can represent times far in -the past or future. + Many operating systems use 64-bit signed integers to count seconds, +and can represent times far in the past or future. However, some are +more limited. For example, old-fashioned operating systems that use +32-bit signed integers typically handle only times from 1901-12-13 +20:45:52 through 2038-01-19 03:14:07 Universal Time. - Calendrical conversion functions always use the Gregorian calendar, even -for dates before the Gregorian calendar was introduced. Year numbers -count the number of years since the year 1 BC, and do not skip zero + Calendrical conversion functions use the Gregorian calendar even for +dates before the Gregorian calendar was introduced, and for dates in +the far distant past or future for which the Gregorian calendar +is wildly inaccurate and disagrees with common practice in scientific fields +like astronomy and paleontology, which use Julian-calendar year lengths. +Year numbers count since the year 1 BCE, and do not skip zero as traditional Gregorian years do; for example, the year number -@minus{}37 represents the Gregorian year 38 BC@. +@minus{}37 represents the Gregorian year 38 BCE@. @defun time-convert time &optional form This function converts a time value into a Lisp timestamp. @@ -1513,20 +1551,20 @@ integer, it specifies a clock frequency and this function returns an integer-pair timestamp @code{(@var{ticks} . @var{form})}. If @var{form} is @code{t}, this function treats it as a positive integer suitable for representing the timestamp; for example, it is treated as 1000000000 -if @var{time} is nil and the platform timestamp has nanosecond +if @var{time} is @code{nil} and the platform timestamp has nanosecond resolution. If @var{form} is @code{list}, this function returns an integer list @code{(@var{high} @var{low} @var{micro} @var{pico})}. Although an omitted or @code{nil} @var{form} currently acts like @code{list}, this is planned to change in a future Emacs version, so callers requiring list timestamps should pass @code{list} explicitly. -If @var{time} is infinite or a NaN, this function signals an error. +If @var{time} is not a time value, this function signals an error. Otherwise, if @var{time} cannot be represented exactly, conversion truncates it toward minus infinity. When @var{form} is @code{t}, conversion is always exact so no truncation occurs, and the returned clock resolution is no less than that of @var{time}. By way of -contrast, @code{float-time} can convert any Lisp time value without -signaling an error, although the result might not be exact. +contrast, although @code{float-time} can also convert any time value +without signaling an error, the result might not be exact. @xref{Time of Day}. For efficiency this function might return a value that is @code{eq} to @@ -1614,59 +1652,12 @@ a particular form should specify @var{form}. @var{dow} and @var{utcoff}, and its @var{second} is an integer between 0 and 59 inclusive. -To access (or alter) the elements in the time value, the +To access (or alter) the elements in the calendrical information, the @code{decoded-time-second}, @code{decoded-time-minute}, @code{decoded-time-hour}, @code{decoded-time-day}, @code{decoded-time-month}, @code{decoded-time-year}, @code{decoded-time-weekday}, @code{decoded-time-dst} and @code{decoded-time-zone} accessors can be used. - -For instance, to increase the year in a decoded time, you could say: - -@lisp -(setf (decoded-time-year decoded-time) - (+ (decoded-time-year decoded-time) 4)) -@end lisp - -Also see the following function. - -@end defun - -@defun decoded-time-add time delta -This function takes a decoded time structure and adds @var{delta} -(also a decoded time structure) to it. Elements in @var{delta} that -are @code{nil} are ignored. - -For instance, if you want ``same time next month'', you -could say: - -@lisp -(let ((time (decode-time nil nil t)) - (delta (make-decoded-time :month 2))) - (encode-time (decoded-time-add time delta))) -@end lisp - -If this date doesn't exist (if you're running this on January 31st, -for instance), then the date will be shifted back until you get a -valid date (which will be February 28th or 29th, depending). - -Fields are added in a most to least significant order, so if the -adjustment described above happens, it happens before adding days, -hours, minutes or seconds. - -The values in @var{delta} can be negative to subtract values instead. - -The return value is a decoded time structure. -@end defun - -@defun make-decoded-time &key second minute hour day month year dst zone -Return a decoded time structure with only the given keywords filled -out, leaving the rest @code{nil}. For instance, to get a structure -that represents ``two months'', you could say: - -@lisp -(make-decoded-time :month 2) -@end lisp @end defun @defun encode-time time &rest obsolescent-arguments @@ -1676,9 +1667,26 @@ It can act as the inverse of @code{decode-time}. Ordinarily the first argument is a list @code{(@var{second} @var{minute} @var{hour} @var{day} @var{month} @var{year} @var{ignored} @var{dst} @var{zone})} that specifies a -decoded time in the style of @code{decode-time}, so that -@code{(encode-time (decode-time ...))} works. For the meanings of -these list members, see the table under @code{decode-time}. +decoded time in the style of @code{decode-time}. For the meanings of +these list elements, see the table under @code{decode-time}. +In particular, @var{dst} says how to interpret timestamps during a +daylight saving fallback when timestamps are repeated. +If @var{dst} is @minus{}1, the DST value is guessed; if it +is @code{t} or @code{nil} the timestamp with that DST value +is returned, with an error signaled if no such timestamp exists. +Unfortunately a @var{dst} value of @code{t} or @code{nil} does not +disambiguate timestamps duplicated when a TZDB-based timezone moves +further west of Greenwich, such as disambiguating the two +standard-time timestamps 2020-12-27 01:30 when @var{zone} is +@samp{"Europe/Volgograd"}, which at 02:00 that day changed +standard time from 4 to 3 hours east of Greenwich; if you need to +handle situations like this you can use a numeric @var{zone} to +disambiguate instead. + +The first argument can also be a list @code{(@var{second} @var{minute} +@var{hour} @var{day} @var{month} @var{year})}, which is treated like +the list @code{(@var{second} @var{minute} @var{hour} @var{day} +@var{month} @var{year} nil -1 nil)}. As an obsolescent calling convention, this function can be given six or more arguments. The first six arguments @var{second}, @@ -1687,14 +1695,18 @@ specify most of the components of a decoded time. If there are more than six arguments the @emph{last} argument is used as @var{zone} and any other extra arguments are ignored, so that @code{(apply #'encode-time (decode-time ...))} works. In this obsolescent -convention, @var{zone} defaults to the current time zone rule -(@pxref{Time Zone Rules}), and @var{dst} is treated as if it was -@minus{}1. +convention, @var{dst} is @minus{}1 and @var{zone} defaults to the +current time zone rule (@pxref{Time Zone Rules}). +When modernizing an obsolescent caller, ensure that the more-modern +list equivalent contains 9 elements with a @code{dst} element that +is @minus{}1, not @code{nil}. Year numbers less than 100 are not treated specially. If you want them to stand for years above 1900, or years above 2000, you must alter them yourself before you call @code{encode-time}. The operating system limits the range of time and zone values. +However, timestamps ranging from the epoch to the near future are +always supported. The @code{encode-time} function acts as a rough inverse to @code{decode-time}. For example, you can pass the output of @@ -1707,6 +1719,33 @@ the latter to the former as follows: You can perform simple date arithmetic by using out-of-range values for @var{seconds}, @var{minutes}, @var{hour}, @var{day}, and @var{month}; for example, day 0 means the day preceding the given month. +Take care when doing so, as it is common for this to fail in some cases. +For example: + +@lisp +;; Try to compute the time one month from now. +;; Watch out; this might not work as expected. +(let ((time (decode-time))) + (setf (decoded-time-month time) + (+ (decoded-time-month time) 1)) + time) +@end lisp + +@noindent +Unfortunately, this code might not work as expected if the resulting +time is invalid due to month length differences, +daylight saving transitions, time zone changes, +or missing leap days or leap seconds. For example, if executed on +January 30 this code yields a nonexistent date February 30, +which @code{encode-time} would adjust to early March. +Similarly, adding four years to February 29, 2096 would yield the +nonexistent date February 29, 2100; and adding one hour to 01:30 on +March 13, 2022 in New York would yield a timestamp 02:30 that does not +exist because clocks sprang forward from 02:00 to 03:00 that day. +To avoid some (though not all) of the problem, you +can base calculations on the middle of the affected unit, e.g., start +at the 15th of the month when adding months. Alternatively, you can use the +@file{calendar} and @file{time-date} libraries. @end defun @node Time Parsing @@ -1716,7 +1755,7 @@ for example, day 0 means the day preceding the given month. @cindex formatting time values These functions convert time values to text in a string, and vice versa. -Time values include @code{nil}, numbers, and Lisp timestamps +Time values include @code{nil}, finite numbers, and Lisp timestamps (@pxref{Time of Day}). @defun date-to-time string @@ -1961,6 +2000,10 @@ encountered. For example, the default format used by @w{@code{"%Y, %D, %H, %M, %z%S"}} means that the number of seconds will always be produced, but years, days, hours, and minutes will only be shown if they are non-zero. +@item %x +Non-printing control flag that works along the same lines as +@samp{%z}, but instead suppresses printing of trailing zero-value time +elements. @item %% Produces a literal @samp{%}. @end table @@ -2024,25 +2067,23 @@ interactively, it prints the duration in the echo area. These functions perform calendrical computations using time values (@pxref{Time of Day}). As with any time value, a value of @code{nil} for any of their -time-value arguments stands for the current system time, and a single +time-value arguments stands for the current system time, and a finite number stands for the number of seconds since the epoch. @defun time-less-p t1 t2 -This returns @code{t} if time value @var{t1} is less than time value +This returns @code{t} if the time value @var{t1} is less than the time value @var{t2}. -The result is @code{nil} if either argument is a NaN. @end defun @defun time-equal-p t1 t2 -This returns @code{t} if @var{t1} and @var{t2} are equal time values. -The result is @code{nil} if either argument is a NaN. +This returns @code{t} if the two time values @var{t1} and @var{t2} are +equal. @end defun @defun time-subtract t1 t2 This returns the time difference @var{t1} @minus{} @var{t2} between -two time values, as a Lisp time value. The result is exact and its clock +two time values, as a Lisp timestamp. The result is exact and its clock resolution is no worse than the worse of its two arguments' resolutions. -The result is floating-point only if it is infinite or a NaN@. If you need the difference in units of elapsed seconds, you can convert it with @code{time-convert} or @code{float-time}. @xref{Time Conversion}. @@ -2294,7 +2335,8 @@ can use in calling @code{cancel-timer} (@pxref{Timers}). @end deffn @cindex idleness - Emacs becomes @dfn{idle} when it starts waiting for user input, and + Emacs becomes @dfn{idle} when it starts waiting for user input +(unless it waits for input with a timeout, @pxref{Reading One Event}), and it remains idle until the user provides some input. If a timer is set for five seconds of idleness, it runs approximately five seconds after Emacs first becomes idle. Even if @var{repeat} is non-@code{nil}, @@ -3097,21 +3139,21 @@ This function removes the tray notification given by its unique @cindex watch, for filesystem events Several operating systems support watching of filesystems for changes -of files. If configured properly, Emacs links a respective library -like @file{inotify}, @file{kqueue}, @file{gfilenotify}, or -@file{w32notify} statically. These libraries enable watching of -filesystems on the local machine. +to files or their attributes. If configured properly, Emacs links a +respective library like @file{inotify}, @file{kqueue}, +@file{gfilenotify}, or @file{w32notify} statically. These libraries +enable watching of filesystems on the local machine. It is also possible to watch filesystems on remote machines, -@pxref{Remote Files,, Remote Files, emacs, The GNU Emacs Manual} +@pxref{Remote Files,, Remote Files, emacs, The GNU Emacs Manual}. This does not depend on one of the libraries linked to Emacs. -Since all these libraries emit different events on notified file -changes, there is the Emacs library @code{filenotify} which provides a -unified interface. Lisp programs that want to receive file -notifications should always use this library in preference to the -native ones. - +Since all these libraries emit different events upon notified file +changes, Emacs provides a special library @code{filenotify} which +presents a unified interface to applications. Lisp programs that want +to receive file notifications should always use this library in +preference to the native ones. This section documents the +@code{filenotify} library functions and variables. @defun file-notify-add-watch file flags callback Add a watch for filesystem events pertaining to @var{file}. This @@ -3119,31 +3161,33 @@ arranges for filesystem events pertaining to @var{file} to be reported to Emacs. The returned value is a descriptor for the added watch. Its type -depends on the underlying library, it cannot be assumed to be an -integer as in the example below. It should be used for comparison by -@code{equal} only. +depends on the underlying library, and in general cannot be assumed to +be an integer as in the example below. It should be used for +comparison by @code{equal} only. If the @var{file} cannot be watched for some reason, this function signals a @code{file-notify-error} error. Sometimes, mounted filesystems cannot be watched for file changes. -This is not detected by this function, a non-@code{nil} return value -does not guarantee that changes on @var{file} will be notified. +This is not detected by this function, and so a non-@code{nil} return +value does not guarantee that changes on @var{file} will be actually +notified. @var{flags} is a list of conditions to set what will be watched for. It can include the following symbols: @table @code @item change -watch for file changes +watch for changes in file's contents @item attribute-change -watch for file attribute changes, like permissions or modification +watch for changes in file attributes, like permissions or modification time @end table If @var{file} is a directory, @code{change} watches for file creation -or deletion in that directory. Some of the file notification backends -report also file changes. This does not work recursively. +and deletion in that directory. Some of the native file notification +libraries also report file changes in that case. This does not work +recursively. When any event happens, Emacs will call the @var{callback} function passing it a single argument @var{event}, which is of the form @@ -3169,19 +3213,20 @@ reports attribute changes as well @item attribute-changed a @var{file} attribute was changed @item stopped -watching @var{file} has been stopped +watching @var{file} has stopped @end table Note that the @file{w32notify} library does not report @code{attribute-changed} events. When some file's attribute, like permissions or modification time, has changed, this library reports a @code{changed} event. Likewise, the @file{kqueue} library does not -report reliably file attribute changes when watching a directory. +reliably report file attribute changes when watching a directory. -The @code{stopped} event reports, that watching the file has been -stopped. This could be because @code{file-notify-rm-watch} was called -(see below), or because the file being watched was deleted, or due to -another error reported from the underlying library. +The @code{stopped} event means that watching the file has been +discontinued. This could be because @code{file-notify-rm-watch} was +called (see below), or because the file being watched was deleted, or +due to another error reported from the underlying library which makes +further watching impossible. @var{file} and @var{file1} are the name of the file(s) whose event is being reported. For example: @@ -3225,7 +3270,7 @@ being reported. For example: @end group @end example -Whether the action @code{renamed} is returned, depends on the used +Whether the action @code{renamed} is returned depends on the used watch library. Otherwise, the actions @code{deleted} and @code{created} could be returned in a random order. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index ed07c1cbf70..18f446735bb 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -197,7 +197,7 @@ gives special treatment to certain characters, and if these characters occur in the file name, they will confuse the shell. To handle these characters, use the function @code{shell-quote-argument}: -@defun shell-quote-argument argument +@defun shell-quote-argument argument &optional posix This function returns a string that represents, in shell syntax, an argument whose actual contents are @var{argument}. It should work reliably to concatenate the return value into a shell command @@ -227,6 +227,15 @@ a shell command: " " (shell-quote-argument newfile)) @end example + +If the optional @var{posix} argument is non-@code{nil}, @var{argument} +is quoted according to POSIX shell quoting rules, regardless of the +system’s shell. This is useful when your shell could run on a remote +host, which requires a POSIX shell in general. + +@example +(shell-quote-argument "foo > bar" (file-remote-p default-directory)) +@end example @end defun @cindex quoting and unquoting command-line arguments @@ -1463,7 +1472,7 @@ incoming data from the connection. For serial connections, data that arrived during the time the process was stopped might be lost. @end defun -@deffn Command signal-process process signal +@deffn Command signal-process process signal &optional remote This function sends a signal to process @var{process}. The argument @var{signal} specifies which signal to send; it should be an integer, or a symbol whose name is a signal. @@ -1471,12 +1480,18 @@ or a symbol whose name is a signal. The @var{process} argument can be a system process @acronym{ID} (an integer); that allows you to send signals to processes that are not children of Emacs. @xref{System Processes}. + +If @var{process} is a process object which contains the property +@code{remote-pid}, or @var{process} is a number and @var{remote} is a +remote file name, @var{process} is interpreted as process on the +respective remote host, which will be the process to signal. @end deffn Sometimes, it is necessary to send a signal to a non-local asynchronous process. This is possible by writing an own -@code{interrupt-process} implementation. This function must be added -then to @code{interrupt-process-functions}. +@code{interrupt-process} or @code{signal-process} implementation. +This function must be added then to @code{interrupt-process-functions} +or @code{signal-process-functions}, respectively. @defvar interrupt-process-functions This variable is a list of functions to be called for @@ -1489,6 +1504,17 @@ default function, which shall always be the last in this list, is This is the mechanism, how Tramp implements @code{interrupt-process}. @end defvar +@defvar signal-process-functions +This variable is a list of functions to be called for +@code{signal-process}. The arguments of the functions are the same as +for @code{signal-process}. These functions are called in the order of +the list, until one of them returns non-@code{nil}. The default +function, which shall always be the last in this list, is +@code{signal-default-interrupt-process}. + +This is the mechanism, how Tramp implements @code{signal-process}. +@end defvar + @node Output from Processes @section Receiving Output from Processes @cindex process output @@ -2232,9 +2258,8 @@ query flag of all processes is ignored. In addition to accessing and manipulating processes that are subprocesses of the current Emacs session, Emacs Lisp programs can -also access other processes running on the same machine. We call -these @dfn{system processes}, to distinguish them from Emacs -subprocesses. +also access other processes. We call these @dfn{system processes}, to +distinguish them from Emacs subprocesses. Emacs provides several primitives for accessing system processes. Not all platforms support these primitives; on those which don't, @@ -2246,6 +2271,9 @@ system. Each process is identified by its @acronym{PID}, a numerical process ID that is assigned by the OS and distinguishes the process from all the other processes running on the same machine at the same time. + +If @code{default-directory} points to a remote host, processes of that +host are returned. @end defun @defun process-attributes pid @@ -2257,6 +2285,9 @@ attribute @var{key}s that this function can return are listed below. Not all platforms support all of these attributes; if an attribute is not supported, its association will not appear in the returned alist. +If @code{default-directory} points to a remote host, @var{pid} is +regarded as process of that host. + @table @code @item euid The effective user ID of the user who invoked the process. The diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi index 8f8562cadc8..781a50f5c49 100644 --- a/doc/lispref/streams.texi +++ b/doc/lispref/streams.texi @@ -685,6 +685,15 @@ This function outputs @var{character} to @var{stream}. It returns @var{character}. @end defun +@defun flush-standard-output +If you have Emacs-based batch scripts that send output to the +terminal, Emacs will automatically display the output whenever you +write a newline characters to @code{standard-output}. This function +allows you to flush to @code{standard-output} without sending a +newline character first, which enables you to display incomplete +lines. +@end defun + @defun prin1-to-string object &optional noescape @cindex object to string This function returns a string containing the text that @code{prin1} diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index d31807ad2aa..5e41f8d57bf 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -434,9 +434,12 @@ display purposes; use @code{truncate-string-to-width} or (@pxref{Size of Displayed Text}). @end defun -@defun string-lines string &optional omit-nulls +@defun string-lines string &optional omit-nulls keep-newlines Split @var{string} into a list of strings on newline boundaries. If -@var{omit-nulls}, remove empty lines from the results. +the optional argument @var{omit-nulls} is non-@code{nil}, remove empty +lines from the results. If the optional argument @var{keep-newlines} +is non-@code{nil}, don't remove the trailing newlines from the result +strings. @end defun @defun string-pad string length &optional padding start diff --git a/doc/lispref/symbols.texi b/doc/lispref/symbols.texi index 9e44348b671..336fa9c9182 100644 --- a/doc/lispref/symbols.texi +++ b/doc/lispref/symbols.texi @@ -775,7 +775,7 @@ For most purposes, when the flag variable @code{symbols-with-pos-enabled} is non-@code{nil}, symbols with positions behave just as bare symbols do. For example, @samp{(eq # foo)} has a value @code{t} when that variable -is set (but nil when it isn't set). Most of the time in Emacs this +is set (but @code{nil} when it isn't set). Most of the time in Emacs this variable is @code{nil}, but the byte compiler binds it to @code{t} when it runs. diff --git a/doc/lispref/syntax.texi b/doc/lispref/syntax.texi index 9120e637274..e84b901eaa9 100644 --- a/doc/lispref/syntax.texi +++ b/doc/lispref/syntax.texi @@ -770,7 +770,7 @@ This function returns the parser state that the parser would reach at position @var{pos} starting from the beginning of the visible portion of the buffer. @iftex -See the next section for +See the next section @end iftex @ifnottex @xref{Parser State}, diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 7897adeb053..a1db715db6e 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -2969,6 +2969,12 @@ character after position @var{pos} in @var{object} (a buffer or string). The argument @var{object} is optional and defaults to the current buffer. +If @var{position} is at the end of @var{object}, the value is +@code{nil}, but note that buffer narrowing does not affect the value. +That is, if @var{object} is a buffer or @code{nil}, and the buffer is +narrowed and @var{position} is at the end of the narrowed buffer, the +result may be non-@code{nil}. + If there is no @var{prop} property strictly speaking, but the character has a property category that is a symbol, then @code{get-text-property} returns the @var{prop} property of that symbol. @@ -3021,6 +3027,12 @@ properties take precedence over this variable. This function returns the entire property list of the character at @var{position} in the string or buffer @var{object}. If @var{object} is @code{nil}, it defaults to the current buffer. + +If @var{position} is at the end of @var{object}, the value is +@code{nil}, but note that buffer narrowing does not affect the value. +That is, if @var{object} is a buffer or @code{nil}, and the buffer is +narrowed and @var{position} is at the end of the narrowed buffer, the +result may be non-@code{nil}. @end defun @defvar default-text-properties @@ -3541,16 +3553,30 @@ special modes that implement their own highlighting. @item mouse-face @kindex mouse-face @r{(text property)} -This property is used instead of @code{face} when the mouse is on or -near the character. For this purpose, ``near'' means that all text -between the character and where the mouse is have the same -@code{mouse-face} property value. +This property is used instead of @code{face} when the mouse pointer +hovers over the text which has this property. When this happens, the +entire stretch of text that has the same @code{mouse-face} property +value, not just the character under the mouse, is highlighted. Emacs ignores all face attributes from the @code{mouse-face} property that alter the text size (e.g., @code{:height}, @code{:weight}, and @code{:slant}). Those attributes are always the same as for the unhighlighted text. +@item cursor-face +@kindex cursor-face @r{(text property)} +@findex cursor-face-highlight-mode +@vindex cursor-face-highlight-nonselected-window +This property is similar to @code{mouse-face}, but it is used when +point (not the mouse) is inside text that has this property. The +highlighting happens only if the mode +@code{cursor-face-highlight-mode} is enabled. When the variable +@code{cursor-face-highlight-nonselected-window} is non-@code{nil}, the +text with this face is highlighted even if the window is not selected, +similarly to what @code{highlight-nonselected-windows} does for the +region (@pxref{Mark,, The Mark and the Region, emacs, The GNU Emacs +Manual}). + @item fontified @kindex fontified @r{(text property)} This property says whether the text is ready for display. If @@ -5283,6 +5309,24 @@ interpolation). @code{sqlite-execute} returns the number of affected rows. For instance, an @samp{insert} statement will return @samp{1}, whereas an @samp{update} statement may return zero or a higher number. + +Strings in SQLite are, by default, stored as @code{utf-8}, and +selecting a text column will decode the string using that charset. +Selecting a blob column will return the raw data without any decoding +(i.e., it will return a unibyte string containing the bytes as stored +in the database). Inserting binary data into blob columns, however, +requires some care, as @code{sqlite-execute} will, by default, +interpret all strings as @code{utf-8}. + +So if you have, for instance, @acronym{GIF} data in a unibyte string +called @var{gif}, you have to mark it specially to let +@code{sqlite-execute} know this: + +@lisp +(put-text-property 0 1 'coding-system 'binary gif) +(sqlite-execute db "insert into foo values (?, ?)" (list gif 2)) +@end lisp + @end defun @defun sqlite-select db query &optional values result-type @@ -5394,6 +5438,12 @@ Extensions are usually shared-library files; on GNU and Unix systems, they have the @file{.so} file-name extension. @end defun +@findex sqlite-mode-open-file +If you wish to list the contents of an SQLite file, you can use the +@code{sqlite-mode-open-file} command. This will pop to a buffer using +@code{sqlite-mode}, which allows you to examine (and alter) the +contents of an SQLite database. + @node Parsing HTML/XML @section Parsing HTML and XML @cindex parsing html diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index d991ae9e277..f0e3f337a69 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -2295,6 +2295,21 @@ list in @var{variables} is an alist of the form '((null-device . "/dev/null"))) @end group @end example + +@findex connection-local-get-profile-variables +If you want to append variable settings to an existing profile, you +could use the function @code{connection-local-get-profile-variables} +in order to retrieve the existing settings, like + +@example +@group +(connection-local-set-profile-variables + 'remote-bash + (append + (connection-local-get-profile-variables 'remote-bash) + '((shell-command-dont-erase-buffer . t)))) +@end group +@end example @end defun @deffn {User Option} connection-local-profile-alist @@ -2418,6 +2433,37 @@ are unwound. Example: @end example @end defmac +@defvar connection-local-default-application +The default application, a symbol, to be applied in +@code{with-connection-local-variables}. It defaults to @code{tramp}, +but in case you want to overwrite Tramp's settings temporarily, you +could let-bind it like + +@example +@group +(connection-local-set-profile-variables + 'my-remote-perl + '((perl-command-name . "/usr/local/bin/perl5") + (perl-command-switch . "-e %s"))) +@end group + +@group +(connection-local-set-profiles + '(:application 'my-app :protocol "ssh" :machine "remotehost") + 'my-remote-perl) +@end group + +@group +(let ((default-directory "/ssh:remotehost:/working/dir/") + (connection-local-default-application 'my-app)) + (with-connection-local-variables + do something useful)) +@end group +@end example + +This variable must not be changed globally. +@end defvar + @defvar enable-connection-local-variables If @code{nil}, connection-local variables are ignored. This variable shall be changed temporarily only in special modes. @@ -2743,13 +2789,13 @@ implemented this way: (gv-define-expander substring (lambda (do place from &optional to) (gv-letplace (getter setter) place - (macroexp-let2* nil ((start from) (end to)) - (funcall do `(substring ,getter ,start ,end) + (macroexp-let2* (from to) + (funcall do `(substring ,getter ,from ,to) (lambda (v) - (macroexp-let2 nil v v + (macroexp-let2* (v) `(progn ,(funcall setter `(cl--set-substring - ,getter ,start ,end ,v)) + ,getter ,from ,to ,v)) ,v)))))))) @end example @end defmac @@ -2762,7 +2808,7 @@ of Common Lisp could be implemented this way: @example (defmacro incf (place &optional n) (gv-letplace (getter setter) place - (macroexp-let2 nil v (or n 1) + (macroexp-let2* ((v (or n 1))) (funcall setter `(+ ,v ,getter))))) @end example diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index 43f222d57ff..97908bea001 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -759,6 +759,15 @@ column and total width (@pxref{Coordinates and Windows}). The optional argument @var{round} behaves as it does for @code{window-total-height}. @end defun +@defun window-max-characters-per-line &optional window face +The maximum width of a line that can be displayed in a window (without +breaking the line) depends on many things, like the font used on the +line, and whether there are fringes around the window. This +convenience function can be used to calculate that number. If +@var{window} isn't given, this defaults to the currently selected +window. if @var{var} isn't given, the @code{default} face is used. +@end defun + @defun window-total-size &optional window horizontal round This function returns either the total height in lines or the total width in columns of the window @var{window}. If @var{horizontal} is @@ -2596,13 +2605,11 @@ default value is an empty display action, i.e., @w{@code{(nil . nil)}}. @defopt display-buffer-alist The value of this option is an alist mapping conditions to display -actions. Each condition may be either a regular expression matching a -buffer name or a function that takes two arguments: a buffer name and -the @var{action} argument passed to @code{display-buffer}. If either -the name of the buffer passed to @code{display-buffer} matches a -regular expression in this alist, or the function specified by a -condition returns non-@code{nil}, then @code{display-buffer} uses the -corresponding display action to display the buffer. +actions. Each condition is passed to @code{buffer-match-p}, along +with the buffer name and the @var{action} argument passed to +@code{display-buffer}. If it returns a non-nil value, then +@code{display-buffer} uses the corresponding display action to display +the buffer. @end defopt @defopt display-buffer-base-action @@ -2968,13 +2975,14 @@ follows: @code{nil} means consider only windows on the selected frame. (Actually, the last frame used that is not a minibuffer-only frame.) @item -@code{t} means consider windows on all frames. -@item @code{visible} means consider windows on all visible frames. @item 0 means consider windows on all visible or iconified frames. @item A frame means consider windows on that frame only. +@item +@code{t} means consider windows on all frames. (Note that this value +is rarely the right thing to use---it might also return a tooltip frame.) @end itemize Note that the meaning of @code{nil} differs slightly from that of the diff --git a/doc/misc/auth.texi b/doc/misc/auth.texi index c2a9aa44371..829d7f4fa03 100644 --- a/doc/misc/auth.texi +++ b/doc/misc/auth.texi @@ -191,7 +191,7 @@ get fancy, the default and simplest configuration is: (setq auth-sources '("secrets:Login")) ;;; use pass (@file{~/.password-store}) ;;; (@pxref{The Unix password store}) -(setq auth-sources '(password-store)) +(auth-source-pass-enable) ;;; JSON data in format [@{ "machine": "SERVER", ;;; "login": "USER", "password": "PASSWORD" @}...] (setq auth-sources '("~/.authinfo.json.gpg")) diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi index d83edc15f30..9bda6af1c5b 100644 --- a/doc/misc/calc.texi +++ b/doc/misc/calc.texi @@ -29877,6 +29877,12 @@ with no argument copies only the number itself into the kill ring, whereas @kbd{C-k} with a prefix argument of 1 copies the number with its trailing newline. +You can customize @code{calc-kill-line-numbering} to nil to exclude +line numbering from kills and copies made by @code{calc-kill} and +@code{calc-copy-as-kill}. This option does not affect calc kill and +copy commands which operate on the region, as that would not make +sense. + @node Yanking Into Stack @section Yanking into the Stack diff --git a/doc/misc/cc-mode.texi b/doc/misc/cc-mode.texi index 8b36d1afd7a..1f12c30b1f8 100644 --- a/doc/misc/cc-mode.texi +++ b/doc/misc/cc-mode.texi @@ -6278,6 +6278,32 @@ expressions for the operands. @comment ------------------------------------------------------------ +@defun c-lineup-argcont-+ +@findex lineup-argcont-+ (c-) +Indent a continued argument @code{c-basic-offset} spaces from the +start of the first argument at the current level of nesting on a +previous line. + +@example +@group +foo (xyz, uvw, aaa + bbb + ccc + + ddd + eee + fff); <- c-lineup-argcont-+ + <--> c-basic-offset +@end group +@end example + +Only continuation lines like this are touched, @code{nil} being +returned on lines which are the start of an argument. + +Within a gcc @code{asm} block, @code{:} is recognized as an argument +separator, but of course only between operand specifications, not in the +expressions for the operands. + +@workswith @code{arglist-cont}, @code{arglist-cont-nonempty}. +@end defun + +@comment ------------------------------------------------------------ + @defun c-lineup-arglist-operators @findex lineup-arglist-operators @r{(c-)} Line up lines starting with an infix operator under the open paren. diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index a6fe29e1026..6134b977517 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -444,7 +444,7 @@ the ``rest'' argument is bound to the keyword list as it appears in the call. For example: @example -(cl-defun find-thing (thing &rest rest &key need &allow-other-keys) +(cl-defun find-thing (thing thing-list &rest rest &key need &allow-other-keys) (or (apply 'cl-member thing thing-list :allow-other-keys t rest) (if need (error "Thing not found")))) @end example @@ -843,6 +843,7 @@ constructs. * Iteration:: @code{cl-do}, @code{cl-dotimes}, @code{cl-dolist}, @code{cl-do-symbols}. * Loop Facility:: The Common Lisp @code{loop} macro. * Multiple Values:: @code{cl-values}, @code{cl-multiple-value-bind}, etc. +* Macro-Writing Macros:: @code{cl-with-gensyms}, @code{cl-once-only}. @end menu @node Assignment @@ -2513,6 +2514,86 @@ in @code{cl-multiple-value-bind}. Since a perfect emulation is not feasible in Emacs Lisp, this package opts to keep it as simple and predictable as possible. +@node Macro-Writing Macros +@section Macro-Writing Macros + +@noindent +This package includes two classic Common Lisp macro-writing macros to +help render complex macrology easier to read. + +@defmac cl-with-gensyms names@dots{} body +This macro expands to code that executes @var{body} with each of the +variables in @var{names} bound to a fresh uninterned symbol, or +@dfn{gensym}, in Common Lisp parlance. For macros requiring more than +one gensym, use of @code{cl-with-gensyms} shortens the code and +renders one's intentions clearer. Compare: + +@example +(defmacro my-macro (foo) + (let ((bar (gensym "bar")) + (baz (gensym "baz")) + (quux (gensym "quux"))) + `(let ((,bar (+ @dots{}))) + @dots{}))) + +(defmacro my-macro (foo) + (cl-with-gensyms (bar baz quux) + `(let ((,bar (+ @dots{}))) + @dots{}))) +@end example +@end defmac + +@defmac cl-once-only ((variable form)@dots{}) body +This macro is primarily to help the macro programmer ensure that forms +supplied by the user of the macro are evaluated just once by its +expansion even though the result of evaluating the form is to occur +more than once. Less often, this macro is used to ensure that forms +supplied by the macro programmer are evaluated just once. + +Each @var{variable} may be used to refer to the result of evaluating +@var{form} in @var{body}. @code{cl-once-only} binds each +@var{variable} to a fresh uninterned symbol during the evaluation of +@var{body}. Then, @code{cl-once-only} wraps the final expansion in +code to evaluate each @var{form} and bind the result to the +corresponding uninterned symbol. Thus, when the macro writer +substitutes the value for @var{variable} into the expansion they are +effectively referring to the result of evaluating @var{form}, rather +than @var{form} itself. Another way to put this is that each +@var{variable} is bound to an expression for the (singular) result of +evaluating @var{form}. + +The most common case is where @var{variable} is one of the arguments +to the macro being written, so @code{(variable variable)} may be +abbreviated to just @code{variable}. + +For example, consider this macro: + +@example +(defmacro my-list (x y &rest forms) + (let ((x-result (gensym)) + (y-result (gensym))) + `(let ((,x-result ,x) + (,y-result ,y)) + (list ,x-result ,y-result ,x-result ,y-result + (progn ,@@forms)))) +@end example + +In a call like @w{@code{(my-list (pop foo) @dots{})}} the intermediate +binding to @code{x-result} ensures that the @code{pop} is not done +twice. But as a result the code is rather complex: the reader must +keep track of how @code{x-result} really just means the first +parameter of the call to the macro, and the required use of multiple +gensyms to avoid variable capture by @code{(progn ,@@forms)} obscures +things further. @code{cl-once-only} takes care of these details: + +@example +(defmacro my-list (x y &rest forms) + (cl-once-only (x y) + `(list ,x ,y ,x ,y + (progn ,@@forms)))) +@end example +@end defmac + @node Macros @chapter Macros @@ -2868,6 +2949,7 @@ out the property and value cells. @node Creating Symbols @section Creating Symbols +@cindex gensym @noindent These functions create unique symbols, typically for use as @@ -5028,13 +5110,13 @@ The above @code{incf} example could be written using @example (defmacro incf (place &optional n) (gv-letplace (getter setter) place - (macroexp-let2 nil v (or n 1) + (cl-once-only ((v (or n 1))) (funcall setter `(+ ,v ,getter))))) @end example @ignore (defmacro concatf (place &rest args) (gv-letplace (getter setter) place - (macroexp-let2 nil v (mapconcat 'identity args) + (cl-once-only ((v `(mapconcat 'identity ',args))) (funcall setter `(concat ,getter ,v))))) @end ignore @end defmac diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi index 372e4c3ffbd..d35a642b62d 100644 --- a/doc/misc/eshell.texi +++ b/doc/misc/eshell.texi @@ -228,15 +228,39 @@ other background process in Emacs. @node Arguments @section Arguments -Command arguments are passed to the functions as either strings or -numbers, depending on what the parser thinks they look like. If you -need to use a function that takes some other data type, you will need to -call it in an Elisp expression (which can also be used with -@ref{Expansion, expansions}). As with other shells, you can -escape special characters and spaces with the backslash (@code{\}) and -apostrophes (@code{''}) and double quotes (@code{""}). This is needed -especially for file names with special characters like pipe -(@code{|}), which could be part of remote file names. +Ordinarily, command arguments are parsed by Eshell as either strings +or numbers, depending on what the parser thinks they look like. To +specify an argument of some other data type, you can use an +@ref{Dollars Expansion, Elisp expression}: + +@example +~ $ echo (list 1 2 3) +(1 2 3) +@end example + +Additionally, many built-in Eshell commands (@pxref{Built-ins, Eshell +commands}) will flatten the arguments they receive, so passing a list +as an argument will ``spread'' the elements into multiple arguments: + +@example +~ $ printnl (list 1 2) 3 +1 +2 +3 +@end example + +@subsection Quoting and escaping + +As with other shells, you can escape special characters and spaces +with by prefixing the character with a backslash (@code{\}), or by +surrounding the string with apostrophes (@code{''}) or double quotes +(@code{""}). This is needed especially for file names with special +characters like pipe (@code{|}), which could be part of remote file +names. + +When using expansions (@pxref{Expansion}) in an Eshell command, the +result may potentially be of any data type. To ensure that the result +is always a string, the expansion can be surrounded by double quotes. @node Built-ins @section Built-in commands @@ -993,15 +1017,42 @@ parsers (such as @command{cpp} and @command{m4}), but in a command shell, they are less often used for constants, and usually for using variables and string manipulation.@footnote{Eshell has no string-manipulation expansions because the Elisp library already -provides many functions for this.} For example, @code{$var} on a line -expands to the value of the variable @code{var} when the line is +provides many functions for this.} For example, @code{$@var{var}} on +a line expands to the value of the variable @var{var} when the line is executed. Expansions are usually passed as arguments, but may also be -used as commands.@footnote{E.g., entering just @samp{$var} at the prompt -is equivalent to entering the value of @code{var} at the prompt.} +used as commands.@footnote{E.g., entering just @samp{$@var{var}} at +the prompt is equivalent to entering the value of @var{var} at the +prompt.} + +You can concatenate expansions with regular string arguments or even +other expansions. In the simplest case, when the expansion returns a +string value, this is equivalent to ordinary string concatenation; for +example, @samp{$@{echo "foo"@}bar} returns @samp{foobar}. The exact +behavior depends on the types of each value being concatenated: + +@table @asis + +@item both strings +Concatenate both values together. + +@item one or both numbers +Concatenate the string representation of each value, converting back to +a number if possible. + +@item one or both (non-@code{nil}) lists +Concatenate ``adjacent'' elements of each value (possibly converting +back to a number as above). For example, @samp{$list("a" "b")c} +returns @samp{("a" "bc")}. + +@item anything else +Concatenate the string represenation of each value. + +@end table @menu * Dollars Expansion:: * Globbing:: +* Argument Predication and Modification:: @end menu @node Dollars Expansion @@ -1025,11 +1076,22 @@ value, such as @samp{$"@var{var}"-suffix}. @item $(@var{lisp}) Expands to the result of evaluating the S-expression @code{(@var{lisp})}. On its own, this is identical to just @code{(@var{lisp})}, but with the @code{$}, -it can be used in a string, such as @samp{/some/path/$(@var{lisp}).txt}. +it can be used inside double quotes or within a longer string, such as +@samp{/some/path/$(@var{lisp}).txt}. @item $@{@var{command}@} -Returns the output of @command{@var{command}}, which can be any valid Eshell -command invocation, and may even contain expansions. +Returns the output of @command{@var{command}}, which can be any valid +Eshell command invocation, and may even contain expansions. Similar +to @code{$(@var{lisp})}, this is identical to @code{@{@var{command}@}} +when on its own, but the @code{$} allows it to be used inside double +quotes or as part of a string. + +Normally, the output is split line-by-line, returning a list (or the +first element if there's only one line of output); if +@code{eshell-convert-numeric-arguments} is non-@code{nil} and every +line of output looks like a number, convert each line to a number. +However, when this expansion is surrounded by double quotes, it +returns the output as a single string instead. @item $<@var{command}> As with @samp{$@{@var{command}@}}, evaluates the Eshell command invocation @@ -1089,15 +1151,345 @@ the result of @var{expr} is not a string or a sequence. @node Globbing @section Globbing -Eshell's globbing syntax is very similar to that of Zsh. Users coming -from Bash can still use Bash-style globbing, as there are no -incompatibilities. Most globbing is pattern-based expansion, but there -is also predicate-based expansion. @xref{Filename Generation, , , -zsh, The Z Shell Manual}, -for full syntax. To customize the syntax and behavior of globbing in -Eshell see the Customize@footnote{@xref{Easy Customization, , , emacs, -The GNU Emacs Manual}.} -groups ``eshell-glob'' and ``eshell-pred''. +@vindex eshell-glob-case-insensitive +Eshell's globbing syntax is very similar to that of Zsh +(@pxref{Filename Generation, , , zsh, The Z Shell Manual}). Users +coming from Bash can still use Bash-style globbing, as there are no +incompatibilities. + +By default, globs are case sensitive, except on MS-DOS/MS-Windows +systems. You can control this behavior via the +@code{eshell-glob-case-insensitive} option. You can further customize +the syntax and behavior of globbing in Eshell via the Customize group +``eshell-glob'' (@pxref{Easy Customization, , , emacs, The GNU Emacs +Manual}). + +@table @samp + +@item * +Matches any string (including the empty string). For example, +@samp{*.el} matches any file with the @file{.el} extension. + +@item ? +Matches any single character. For example, @samp{?at} matches +@file{cat} and @file{bat}, but not @file{goat}. + +@item **/ +Matches zero or more subdirectories in a file name. For example, +@samp{**/foo.el} matches @file{foo.el}, @file{bar/foo.el}, +@file{bar/baz/foo.el}, etc. Note that this cannot be combined with +any other patterns in the same file name segment, so while +@samp{foo/**/bar.el} is allowed, @samp{foo**/bar.el} is not. + +@item ***/ +Like @samp{**/}, but follows symlinks as well. + +@cindex character sets, in Eshell glob patterns +@cindex character classes, in Eshell glob patterns +@item [ @dots{} ] +Defines a @dfn{character set} (@pxref{Regexps, , , emacs, The GNU +Emacs Manual}). A character set matches characters between the two +brackets; for example, @samp{[ad]} matches @file{a} and @file{d}. You +can also include ranges of characters in the set by separating the +start and end with @samp{-}. Thus, @samp{[a-z]} matches any +lower-case @acronym{ASCII} letter. Note that, unlike in Zsh, +character ranges are interpreted in the Unicode codepoint order, not +in the locale-dependent collation order. + +Additionally, you can include @dfn{character classes} in a character +set. A @samp{[:} and balancing @samp{:]} enclose a character class +inside a character set. For instance, @samp{[[:alnum:]]} +matches any letter or digit. @xref{Char Classes, , , elisp, The Emacs +Lisp Reference Manual}, for a list of character classes. + +@cindex complemented character sets, in Eshell glob patterns +@item [^ @dots{} ] +Defines a @dfn{complemented character set}. This behaves just like a +character set, but matches any character @emph{except} the ones +specified. + +@cindex groups, in Eshell glob patterns +@item ( @dots{} ) +Defines a @dfn{group}. A group matches the pattern between @samp{(} +and @samp{)}. Note that a group can only match a single file name +component, so a @samp{/} inside a group will signal an error. + +@item @var{x}|@var{y} +Inside of a group, matches either @var{x} or @var{y}. For example, +@samp{e(m|sh)-*} matches any file beginning with @file{em-} or +@file{esh-}. + +@item @var{x}# +Matches zero or more copies of the glob pattern @var{x}. For example, +@samp{fo#.el} matches @file{f.el}, @file{fo.el}, @file{foo.el}, etc. + +@item @var{x}## +Matches one or more copies of the glob pattern @var{x}. Thus, +@samp{fo#.el} matches @file{fo.el}, @file{foo.el}, @file{fooo.el}, +etc. + +@item @var{x}~@var{y} +Matches anything that matches the pattern @var{x} but not @var{y}. For +example, @samp{[[:digit:]]#~4?} matches @file{1} and @file{12}, but +not @file{42}. Note that unlike in Zsh, only a single @samp{~} +operator can be used in a pattern, and it cannot be inside of a group +like @samp{(@var{x}~@var{y})}. + +@end table + +@node Argument Predication and Modification +@section Argument Predication and Modification +@cindex argument predication +@cindex argument modification +Eshell supports @dfn{argument predication}, to filter elements of a +glob, and @dfn{argument modification}, to manipulate argument values. +These are similar to glob qualifiers in Zsh (@pxref{Glob Qualifiers, , +, zsh, The Z Shell Manual}). + +Predicates and modifiers are introduced with @samp{(@var{filters})} +after any list argument, where @var{filters} is a list of predicates +or modifiers. For example, @samp{*(.)} expands to all regular files +in the current directory and @samp{*(^@@:U^u0)} expands to all +non-symlinks not owned by @code{root}, upper-cased. + +Some predicates and modifiers accept string parameters, such as +@samp{*(u'@var{user}')}, which matches all files owned by @var{user}. +These parameters must be surrounded by delimiters; you can use any of +the following pairs of delimiters: @code{"@dots{}"}, @code{'@dots{}'}, +@code{/@dots{}/}, @code{|@dots{}|}, @code{(@dots{})}, +@code{[@dots{}]}, @code{<@dots{}>}, or @code{@{@dots{}@}}. + +You can customize the syntax and behavior of predicates and modifiers +in Eshell via the Customize group ``eshell-pred'' (@pxref{Easy +Customization, , , emacs, The GNU Emacs Manual}). + +@menu +* Argument Predicates:: +* Argument Modifiers:: +@end menu + +@node Argument Predicates +@subsection Argument Predicates +You can use argument predicates to filter lists of file names based on +various properties of those files. This is most useful when combined +with globbing, but can be used on any list of files names. Eshell +supports the following argument predicates: + +@table @asis + +@item @samp{/} +Matches directories. + +@item @samp{.} @r{(Period)} +Matches regular files. + +@item @samp{@@} +Matches symbolic links. + +@item @samp{=} +Matches sockets. + +@item @samp{p} +Matches named pipes. + +@item @samp{%} +Matches block or character devices. + +@item @samp{%b} +Matches block devices. + +@item @samp{%c} +Matches character devices. + +@item @samp{*} +Matches regular files that can be executed by the current user. + +@item @samp{r} +@item @samp{A} +@item @samp{R} +Matches files that are readable by their owners (@samp{r}), their +groups (@samp{A}), or the world (@samp{R}). + +@item @samp{w} +@item @samp{I} +@item @samp{W} +Matches files that are writable by their owners (@samp{w}), their +groups (@samp{I}), or the world (@samp{W}). + +@item @samp{x} +@item @samp{E} +@item @samp{X} +Matches files that are executable by their owners (@samp{x}), their +groups (@samp{E}), or the world (@samp{X}). + +@item @samp{s} +Matches files with the setuid flag set. + +@item @samp{S} +Matches files with the setgid flag set. + +@item @samp{t} +Matches files with the sticky bit set. + +@item @samp{U} +Matches files owned by the current effective user ID. + +@item @samp{G} +Matches files owned by the current effective group ID. + +@item @samp{l@option{[+-]}@var{n}} +Matches files with @var{n} links. With @option{+} (or @option{-}), +matches files with more than (or less than) @var{n} links, +respectively. + +@item @samp{u@var{uid}} +@item @samp{u'@var{user-name}'} +Matches files owned by user ID @var{uid} or user name @var{user-name}. + +@item @samp{g@var{gid}} +@item @samp{g'@var{group-name}'} +Matches files owned by group ID @var{gid} or group name +@var{group-name}. + +@item @samp{a@option{[@var{unit}]}@option{[+-]}@var{n}} +@item @samp{a@option{[+-]}'@var{file}'} +Matches files last accessed exactly @var{n} days ago. With @option{+} +(or @option{-}), matches files accessed more than (or less than) +@var{n} days ago, respectively. + +With @var{unit}, @var{n} is a quantity in that unit of time, so +@samp{aw-1} matches files last accessed within one week. @var{unit} +can be @samp{M} (30-day months), @samp{w} (weeks), @samp{h} (hours), +@samp{m} (minutes), or @samp{s} (seconds). + +If @var{file} is specified instead, compare against the modification +time of @file{file}. Thus, @samp{a-'hello.txt'} matches all files +accessed after @file{hello.txt} was last accessed. + +@item @samp{m@option{[@var{unit}]}@option{[+-]}@var{n}} +@item @samp{m@option{[+-]}'@var{file}'} +Like @samp{a}, but examines modification time. + +@item @samp{c@option{[@var{unit}]}@option{[+-]}@var{n}} +@item @samp{c@option{[+-]}'@var{file}'} +Like @samp{a}, but examines status change time. + +@item @samp{L@option{[@var{unit}]}@option{[+-]}@var{n}} +Matches files exactly @var{n} bytes in size. With @option{+} (or +@option{-}), matches files larger than (or smaller than) @var{n} +bytes, respectively. + +With @var{unit}, @var{n} is a quantity in that unit of size, so +@samp{Lm+5} matches files larger than 5 MiB in size. @var{unit} can +be one of the following (case-insensitive) characters: @samp{m} +(megabytes), @samp{k} (kilobytes), or @samp{p} (512-byte blocks). + +@end table + +The @samp{^} and @samp{-} operators are not argument predicates +themselves, but they modify the behavior of all subsequent predicates. +@samp{^} inverts the meaning of subsequent predicates, so +@samp{*(^RWX)} expands to all files whose permissions disallow the +world from accessing them in any way (i.e., reading, writing to, or +modifying them). When examining a symbolic link, @samp{-} applies the +subsequent predicates to the link's target instead of the link itself. + +@node Argument Modifiers +@subsection Argument Modifiers +You can use argument modifiers to manipulate argument values. For +example, you can sort lists, remove duplicate values, capitalize +words, etc. All argument modifiers are prefixed by @samp{:}, so +@samp{$exec-path(:h:u:x/^\/home/)} lists all of the unique parent +directories of the elements in @code{exec-path}, excluding those in +@file{/home}. + +@table @samp + +@item E +Re-evaluates the value as an Eshell argument. For example, if +@var{foo} is @code{"$@{echo hi@}"}, then the result of @samp{$foo(:E)} +is @code{hi}. + +@item L +Converts the value to lower case. + +@item U +Converts the value to upper case. + +@item C +Capitalizes the value. + +@item h +Treating the value as a file name, gets the directory name (the +``head''). For example, @samp{foo/bar/baz.el(:h)} expands to +@samp{foo/bar/}. + +@item t +Treating the value as a file name, gets the base name (the ``tail''). +For example, @samp{foo/bar/baz.el(:h)} expands to @samp{baz.el}. + +@item e +Treating the value as a file name, gets the final extension of the +file, excluding the dot. For example, @samp{foo.tar.gz(:e)} +expands to @code{gz}. + +@item r +Treating the value as a file name, gets the file name excluding the +final extension. For example, @samp{foo/bar/baz.tar.gz(:r)} expands +to @samp{foo/bar/baz.tar}. + +@item q +Marks that the value should be interpreted by Eshell literally, so +that any special characters like @samp{$} no longer have any special +meaning. + +@item s/@var{pattern}/@var{replace}/ +Replaces the first instance of the regular expression @var{pattern} +with @var{replace}. Signals an error if no match is found. + +As with other modifiers taking string parameters, you can use +different delimiters to separate @var{pattern} and @var{replace}, such +as @samp{s'@dots{}'@dots{}'}, @samp{s[@dots{}][@dots{}]}, or even +@samp{s[@dots{}]/@dots{}/}. + +@item gs/@var{pattern}/@var{replace}/ +Replaces all instances of the regular expression @var{pattern} with +@var{replace}. + +@item i/@var{pattern}/ +Filters a list of values to include only the elements matching the +regular expression @var{pattern}. + +@item x/@var{pattern}/ +Filters a list of values to exclude all the elements matching the +regular expression @var{pattern}. + +@item S +@item S/@var{pattern}/ +Splits the value using the regular expression @var{pattern} as a +delimiter. If @var{pattern} is omitted, split on spaces. + +@item j +@item j/@var{delim}/ +Joins a list of values, inserting the string @var{delim} between each +value. If @var{delim} is omitted, use a single space as the +delimiter. + +@item o +Sorts a list of strings in ascending lexicographic order, comparing +pairs of characters according to their character codes (@pxref{Text +Comparison, , , elisp, The Emacs Lisp Reference Manual}). + +@item O +Sorts a list of strings in descending lexicographic order. + +@item u +Removes any duplicate elements from a list of values. + +@item R +Reverses the order of a list of values. + +@end table @node Input/Output @chapter Input/Output @@ -1241,6 +1633,7 @@ Eshell module.} You also need to load the following as shown: * Key rebinding:: * Smart scrolling:: * Terminal emulation:: +* Electric forward slash:: @end menu @node Writing a module @@ -1273,6 +1666,61 @@ This section is not yet written. This section is not yet written. +@node Electric forward slash +@section Electric forward slash + +To help with supplying absolute file name arguments to remote +commands, you can add the @code{eshell-elecslash} module to +@code{eshell-modules-list}. Then, typing @kbd{/} as the first +character of a command line argument will automatically insert the +Tramp prefix @file{/method:host:}. If this is not what you want +(e.g.@: because you want to refer to a local file), you can type +another @kbd{/} to undo the automatic insertion. Typing @kbd{~/} also +inserts the Tramp prefix. The automatic insertion applies only when +@code{default-directory} is remote and the command is a Lisp function. +In particular, typing arguments to external commands doesn't insert +the prefix. + +The result is that in most cases of supplying absolute file name +arguments to commands you should see the Tramp prefix inserted +automatically only when that's what you'd reasonably expect. This +frees you from having to keep track of whether commands are Lisp +functions or external when typing command line arguments. For +example, suppose you execute + +@example + cd /ssh:root@@example.com: + find /etc -name "*gnu*" +@end example + +@noindent and in reviewing the output of the command, you identify a +file @file{/etc/gnugnu} that should be moved somewhere else. So you +type + +@example + mv /etc/gnugnu /tmp +@end example + +@noindent But since @command{mv} refers to the local Lisp function +@code{eshell/mv}, not a remote shell command, to say this is to +request that the local file @file{/etc/gnugnu} be moved into the local +@file{/tmp} directory. After you add @code{eshell-elecslash} to +@code{eshell-modules-list}, then when you type the above @command{mv} +invocation you will get the following input, which is what you +intended: + +@example + mv /ssh:root@@example.com:/etc/gnugnu /ssh:root@@example.com:/tmp +@end example + +The code that determines whether or not the Tramp prefix should be +inserted uses simple heuristics. A limitation of the current +implementation is that it inspects whether only the command at the +very beginning of input is a Lisp function or external program. Thus +when chaining commands with the operators @code{&&}, @code{||}, +@code{|} and @code{;}, the electric forward slash is active only +within the first command. + @node Bugs and ideas @chapter Bugs and ideas @cindex reporting bugs and ideas @@ -1676,11 +2124,12 @@ only. That way, it could be listed as a login shell. @item The first keypress after @kbd{M-x watson} triggers @code{eshell-send-input} -@item Make @kbd{/} electric +@item Make @kbd{/} more electric -So that it automatically expands and corrects pathnames. Or make -pathname completion for Pcomplete auto-expand @samp{/u/i/std@key{TAB}} to -@samp{/usr/include/std@key{TAB}}. +@noindent so that it automatically expands and corrects file names, +beyond what the @code{em-elecslash} module is able to do. Or make +file name completion for Pcomplete auto-expand +@samp{/u/i/std@key{TAB}} to @samp{/usr/include/std@key{TAB}}. @item Write the @command{pushd} stack to disk along with @code{last-dir-ring} diff --git a/doc/misc/eudc.texi b/doc/misc/eudc.texi index 7c37ae55055..d2850282fea 100644 --- a/doc/misc/eudc.texi +++ b/doc/misc/eudc.texi @@ -192,9 +192,9 @@ email composition buffers (@pxref{Inline Query Expansion}) @lisp (with-eval-after-load "message" - (define-key message-mode-map [(control ?c) (tab)] 'eudc-expand-inline)) + (define-key message-mode-map [(control ?c) (tab)] 'eudc-expand-try-all)) (with-eval-after-load "sendmail" - (define-key mail-mode-map [(control ?c) (tab)] 'eudc-expand-inline)) + (define-key mail-mode-map [(control ?c) (tab)] 'eudc-expand-try-all)) @end lisp @menu @@ -254,7 +254,9 @@ To: * Smith @noindent will return all LDAP entries with surnames that begin with @code{Smith}. In every LDAP query it makes, EUDC implicitly appends -the wildcard character to the end of the last word. +the wildcard character to the end of the last word, except if the word +corresponds to an attribute which is a member of +`eudc-ldap-no-wildcard-attributes'. @menu * Emacs-only Configuration:: Configure with @file{.emacs} @@ -281,11 +283,12 @@ LDAP: @vindex message-mode-map @findex eudc-expand-inline +@findex eudc-expand-try-all @vindex eudc-server-hotlist @vindex ldap-host-parameters-alist @lisp (with-eval-after-load "message" - (define-key message-mode-map (kbd "TAB") 'eudc-expand-inline)) + (define-key message-mode-map (kbd "TAB") 'eudc-expand-try-all)) (setopt eudc-server-hotlist '(("" . bbdb) ("ldaps://ldap.gnu.org" . ldap))) @@ -337,11 +340,12 @@ configure EUDC for LDAP: @vindex message-mode-map @findex eudc-expand-inline +@findex eudc-expand-try-all @vindex eudc-server-hotlist @vindex ldap-host-parameters-alist @lisp (with-eval-after-load "message" - (define-key message-mode-map (kbd "TAB") 'eudc-expand-inline)) + (define-key message-mode-map (kbd "TAB") 'eudc-expand-try-all)) (setopt 'eudc-server-hotlist '(("" . bbdb) ("ldaps://ldap.gnu.org" . ldap))) @@ -366,11 +370,12 @@ and the @file{.emacs} expressions become: @vindex message-mode-map @findex eudc-expand-inline +@findex eudc-expand-try-all @vindex eudc-server-hotlist @vindex ldap-host-parameters-alist @lisp (with-eval-after-load "message" - (define-key message-mode-map (kbd "TAB") 'eudc-expand-inline)) + (define-key message-mode-map (kbd "TAB") 'eudc-expand-try-all)) (setopt 'eudc-server-hotlist '(("" . bbdb) ("" . ldap))) (setopt 'ldap-host-parameters-alist @@ -709,31 +714,47 @@ be passed to the program. @node Inline Query Expansion @section Inline Query Expansion -Inline query expansion is a powerful method to get completion from your -directory server. The most common usage is for expanding names to email -addresses in mail message buffers. The expansion is performed by the -command @kbd{M-x eudc-expand-inline} which is available from the -@samp{Expand Inline Query} menu item but can also be conveniently -bound to a key shortcut (@pxref{Installation}). The operation is -controlled by the variables @code{eudc-inline-expansion-format}, -@code{eudc-inline-query-format}, +Inline query expansion is a powerful method to get completion from +your directory servers. The most common usage is for expanding names +to email addresses in mail message buffers. The expansion is +performed by the command @kbd{M-x eudc-expand-try-all} which is +available from the @samp{Expand Inline Query Trying All Servers} menu +item but can also be conveniently bound to a key shortcut +(@pxref{Installation}). The operation is controlled by the variables +@code{eudc-inline-expansion-format}, @code{eudc-inline-query-format}, @code{eudc-expanding-overwrites-query} and @code{eudc-multiple-match-handling-method}. -If the query fails for a server, other servers may be tried successively -until one of them finds a match (@pxref{Multi-server Queries}). +If the query fails for a server, other servers may be tried +successively until one of them finds a match (@pxref{Multi-server +Queries}), or all servers can be tried and all matches returned. -@deffn Command eudc-expand-inline replace-p +@deffn Command eudc-expand-try-all try-all-servers-p +Query some or all servers and expand the query string before point. +The query string consists of the buffer substring from the point back +to the preceding comma, colon or beginning of line. +@code{eudc-inline-query-format} controls how individual words are +mapped onto directory attribute names. After querying the server or +servers for the given string, the expansion specified by +@code{eudc-inline-expansion-format} is inserted in the buffer at +point. If multiple matches are available, a selection window is +displayed. If @var{try-all-servers-p} is non-@code{nil} then all +servers are queried. +@end deffn + +@deffn Command eudc-expand-inline save-query-as-kill-p Query the server and expand the query string before point. The query string consists of the buffer substring from the point back to the -preceding comma, colon or beginning of -line. @code{eudc-inline-query-format} controls how individual words -are mapped onto directory attribute names. After querying the server -for the given string, the expansion specified by +preceding comma, colon or beginning of line. +@code{eudc-inline-query-format} controls how individual words are +mapped onto directory attribute names. After querying the server for +the given string, the expansion specified by @code{eudc-inline-expansion-format} is inserted in the buffer at -point. If @var{replace-p} is @code{t} then this expansion replaces the -query string in the buffer. If @code{eudc-expanding-overwrites-query} -is non-@code{nil} then the meaning of @var{replace-p} is negated. +point. If multiple matches are available, a selection window is +displayed. If @var{save-query-as-kill-p} is @code{t} then the query +string is saved to the kill ring. If +@code{eudc-expansion-save-query-as-kill} is non-@code{nil} then the +meaning of @var{save-query-as-kill-p} is negated. @end deffn @defvar eudc-inline-query-format @@ -776,12 +797,73 @@ against the @code{cn} attribute of LDAP servers: @end defvar @defvar eudc-inline-expansion-format -This variable lets you control exactly what is inserted into the buffer -upon an inline expansion request. It is a list whose first element is a -string passed to @code{format}. Remaining elements are symbols -corresponding to directory attribute names. The corresponding attribute -values are passed as additional arguments to @code{format}. Default is -@code{("%s %s <%s>" firstname name email)}. +This variable lets you control exactly what is inserted into the +buffer upon an inline expansion request. It can be set to @code{nil}, +to a function, or to a list. Default is @code{nil}. + +When the value is a list, the first element is a string passed to +@code{format}. Remaining elements are symbols corresponding to +directory attribute names. The corresponding attribute values are +passed as additional arguments to @code{format}. + +When the value is @code{nil}, the expansion result will be formatted +according to @url{https://datatracker.ietf.org/doc/html/rfc5322, RFC +5322}. The @var{phrase} part will be formatted as ``firstname name'', +quoting the result if necessary. No @var{comment} part will be added +in this case. This will produce any of the default formats +@center @var{address} +@center @var{first} @code{<}@var{address}@code{>} +@center @var{last} @code{<}@var{address}@code{>} +@center @var{first} @var{last} @code{<}@var{address}@code{>} +depending on whether a first and/or last name are returned by the +query, or not. + +When the value is a function, the expansion result will be formatted +according to @url{https://datatracker.ietf.org/doc/html/rfc5322, RFC +5322}, and the referenced function is called to format the +@var{phrase}, and @var{comment} parts, respectively. The formatted +@var{phrase} part will be quoted if necessary. Thus one can produce +any of the formats: +@center @var{address} +@center @var{phrase} @code{<}@var{address}@code{>} +@center @var{address} @code{(}@var{comment}@code{)} +@center @var{phrase} @code{<}@var{address}@code{>} @code{(}@var{comment}@code{)} + +Email address specifications, as are generated by inline expansion, +need to comply with RFC 5322 in order to be useful in email +messages. When an invalid address specification is present in an email +message header, the message is likely to be rejected by a receiving +MTA. It is hence recommended to switch old configurations, which use +a list value, to the new @code{nil}, or function value type since it +ensures that the inserted address specifications will be in line with +@url{https://datatracker.ietf.org/doc/html/rfc5322, RFC 5322}. At +minimum, and to achieve the same semantics as with the old list +default value, this variable should now be set to @code{nil}: +@lisp +(customize-set-variable 'eudc-inline-expansion-format nil) +@end lisp + +A function value can for example be used to get @emph{``last, first +
            ''} instead of the default @emph{``first last
            ''}: +@lisp +(defun my-phrase-last-comma-first (search-res-alist) + (let* (phrase + (my-attrs (eudc-translate-attribute-list '(firstname name))) + (first-name (cdr (assq (nth 0 my-attrs) search-res-alist))) + (last-name (cdr (assq (nth 1 my-attrs) search-res-alist))) + (comment nil)) + (setq phrase (concat last-name ", " first-name)) + (cons phrase comment))) + +(customize-set-variable 'eudc-inline-expansion-format + #'my-phrase-last-comma-first) +@end lisp +To set the @var{comment} part, too, instead of @code{nil} as in this +example, also provide a string as the @code{cdr} of the @code{cons} +being returned. Do not include any double quotes in the @var{phrase} +part, as they are added automatically if needed. Neither include +parentheses in the @var{comment} part as they, too, are added +automatically. @end defvar @defvar eudc-multiple-match-handling-method diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi index 6d1ba3962f3..f23180c1d4e 100644 --- a/doc/misc/eww.texi +++ b/doc/misc/eww.texi @@ -311,11 +311,9 @@ state the directionality. size or content. By customizing @code{shr-max-image-proportion} you can set the maximal image proportion in relation to the window they are displayed in. E.g., 0.7 means an image is allowed to take up 70% -of the width and height. If Emacs supports image scaling (ImageMagick -support required) then larger images are scaled down. You can block -specific images completely by customizing @code{shr-blocked-images}, -or, if you want to only allow some specific images, customize -@code{shr-allowed-images}. +of the width and height. If Emacs supports image scaling, then larger +images are scaled down. You can block specific images completely by +customizing @code{shr-blocked-images}. @vindex shr-inhibit-images You can control image display by customizing diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi index 0db02608dd2..953e4605e98 100644 --- a/doc/misc/flymake.texi +++ b/doc/misc/flymake.texi @@ -265,6 +265,9 @@ This section summarizes customization variables used for the configuration of the Flymake user interface. @vtable @code +@item flymake-mode-line-lighter +The name of the mode. Defaults to @samp{Flymake}. + @item flymake-mode-line-format Format to use for the Flymake mode line indicator. diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index f87eab7e513..e51ae7d424d 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -18078,6 +18078,17 @@ parameter of @code{nnselect-rescan} will allow automatic refreshing. A refresh can always be invoked manually through @code{gnus-group-get-new-news-this-group}. +By default a compressed version of the selection is stored (for +permanent groups) along with other group information in the newsrc. +For cases where this might be undesirable (for example if the +selection is a very long list that doesn't compress well) a +non-@code{nil} group parameter of @code{nnselect-always-regenerate} +will prevent the list from being stored, and instead regenerate the +list each time it is needed. If more flexibility is desired, +@code{nnselect-get-artlist-override-function} and +@code{nnselect-store-artlist-override-function} may be set to +functions that get and store the list of articles. + Gnus includes engines for searching a variety of backends. While the details of each search engine vary, the result of a search is always a vector of the sort used by the nnselect method, and the results of @@ -21640,6 +21651,9 @@ are: @item @code{gnus-search-namazu} + +@item +@code{gnus-search-mu} @end itemize If you need more granularity, you can specify a search engine in the @@ -21654,7 +21668,7 @@ buffer. That might look like: (config-file "/home/user/.mail/.notmuch_config"))) @end example -Search engines like notmuch, namazu and mairix are similar in +Search engines like notmuch, namazu, mairix and mu are similar in behavior: they use a local executable to create an index of a message store, and run command line search queries against those messages, and return a list of absolute file names of matching messages. @@ -21693,8 +21707,8 @@ The customization options are formed on the pattern non-standard notmuch program, you might set @code{gnus-search-notmuch-program} to @file{/usr/local/bin/notmuch}. This would apply to all notmuch engines. The engines that use these -options are: ``notmuch'', ``namazu'', ``mairix'', ``swish-e'' and -``swish++''. +options are: ``notmuch'', ``namazu'', ``mairix'', ``mu'', ``swish-e'' +and ``swish++''. Alternately, the options can be set directly on your Gnus server definitions, for instance, in the @code{nnmaildir} example above. @@ -24154,15 +24168,12 @@ If you want to see them in the Cc and To fields, set: @item gnus-group-tool-bar @vindex gnus-group-tool-bar Specifies the tool bar in the group buffer. It can be either a list -or a symbol referring to a list. Pre-defined symbols include -@code{gnus-group-tool-bar-gnome} and @code{gnus-group-tool-bar-retro}. +or a symbol referring to a list. @item gnus-summary-tool-bar @vindex gnus-summary-tool-bar Specifies the tool bar in the summary buffer. It can be either a list -or a symbol referring to a list. Pre-defined symbols include -@code{gnus-summary-tool-bar-gnome} and -@code{gnus-summary-tool-bar-retro}. +or a symbol referring to a list. @end table diff --git a/doc/misc/info.texi b/doc/misc/info.texi index 6ebf60ce360..4db35ebf0fc 100644 --- a/doc/misc/info.texi +++ b/doc/misc/info.texi @@ -1083,7 +1083,9 @@ If you aren't sure which manual documents the topic you are looking for, try the @kbd{M-x info-apropos} command in Emacs, or the @kbd{M-x index-apropos} command in the stand-alone reader. It prompts for a string and then looks up that string in all the indices of all the -Info documents installed on your system. +Info documents installed on your system. In Emacs, giving a prefix +argument to the command will try to search for a regular expression +instead of a string. @node Go to node @section @kbd{g} goes to a node by name diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org index 70f1e8bd1de..42ad3ee35fe 100644 --- a/doc/misc/modus-themes.org +++ b/doc/misc/modus-themes.org @@ -5,9 +5,9 @@ #+options: ':t toc:nil author:t email:t num:t #+startup: content -#+macro: stable-version 2.2.0 -#+macro: release-date 2022-02-23 -#+macro: development-version 2.3.0-dev +#+macro: stable-version 2.3.0 +#+macro: release-date 2022-04-01 +#+macro: development-version 2.4.0-dev #+macro: file @@texinfo:@file{@@$1@@texinfo:}@@ #+macro: space @@texinfo:@: @@ #+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@ @@ -15,7 +15,7 @@ #+texinfo_filename: modus-themes.info #+texinfo_dir_category: Emacs misc features #+texinfo_dir_title: Modus Themes: (modus-themes) -#+texinfo_dir_desc: Highly accessible themes (WCAG AAA) +#+texinfo_dir_desc: Elegant, highly legible and customizable themes #+texinfo_header: @set MAINTAINERSITE @uref{https://protesilaos.com,maintainer webpage} #+texinfo_header: @set MAINTAINER Protesilaos Stavrou #+texinfo_header: @set MAINTAINEREMAIL @email{info@protesilaos.com} @@ -222,16 +222,16 @@ They are now ready to be used: [[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable #+cindex: Essential configuration #+vindex: modus-themes-after-load-theme-hook -Users of the built-in themes can load and automatically enable the theme -of their preference by adding either form to their init file: +Users of the built-in themes cannot ~require~ the package as usual +because there is no package to speak of. Instead, things are simpler as +all one needs is to load the theme of their preference by adding either +form to their init file: #+begin_src emacs-lisp (load-theme 'modus-operandi) ; Light theme (load-theme 'modus-vivendi) ; Dark theme #+end_src -This is all one needs. - Users of packaged variants of the themes must add a few more lines to ensure that everything works as intended. First, one has to require the main library before loading either theme: @@ -260,24 +260,39 @@ a theme with either of the following expressions: Changes to the available customization options must always be evaluated before loading a theme ([[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization Options]]). An exception to this norm is when using the various Custom interfaces or with commands like -{{{kbd(M-x customize-set-variable)}}}, which can automatically reload -the theme ([[#h:9001527a-4e2c-43e0-98e8-3ef72d770639][Option for inhibiting theme reload]]). This is how a basic -setup could look like: +{{{kbd(M-x customize-set-variable)}}}, which can optionally +automatically reload the theme ([[#h:9001527a-4e2c-43e0-98e8-3ef72d770639][Option for inhibiting theme reload]]). + +This is how a basic setup could look like: #+begin_src emacs-lisp +;;; For the built-in themes which cannot use `require': +;; Add all your customizations prior to loading the themes +(setq modus-themes-italic-constructs t + modus-themes-bold-constructs nil + modus-themes-region '(bg-only no-extend)) + +;; Load the theme of your choice: +(load-theme 'modus-operandi) ;; OR (load-theme 'modus-vivendi) + +(define-key global-map (kbd "") #'modus-themes-toggle) + + + +;;; For packaged versions which must use `require': (require 'modus-themes) -;; Your customisations here. For example: -(setq modus-themes-bold-constructs t - modus-themes-mode-line '3d) +;; Add all your customizations prior to loading the themes +(setq modus-themes-italic-constructs t + modus-themes-bold-constructs nil + modus-themes-region '(bg-only no-extend)) -;; Load the theme files before enabling a theme (else you get an error). +;; Load the theme files before enabling a theme (modus-themes-load-themes) -;; Enable the theme of your preference: -(modus-themes-load-operandi) +;; Load the theme of your choice: +(modus-themes-load-operandi) ;; OR (modus-themes-load-vivendi) -;; Optionally add a key binding for the toggle between the themes: (define-key global-map (kbd "") #'modus-themes-toggle) #+end_src @@ -307,15 +322,30 @@ It is common for Emacs users to rely on ~use-package~ for declaring package configurations in their setup. We use this as an example: #+begin_src emacs-lisp +;;; For the built-in themes which cannot use `require': +(use-package emacs + :init + ;; Add all your customizations prior to loading the themes + (setq modus-themes-italic-constructs t + modus-themes-bold-constructs nil + modus-themes-region '(bg-only no-extend)) + :config + ;; Load the theme of your choice: + (load-theme 'modus-operandi) ;; OR (load-theme 'modus-vivendi) + :bind ("" . modus-themes-toggle) + + + +;;; For packaged versions which must use `require': (use-package modus-themes - :ensure ; omit this to use the built-in themes + :ensure :init ;; Add all your customizations prior to loading the themes (setq modus-themes-italic-constructs t modus-themes-bold-constructs nil modus-themes-region '(bg-only no-extend)) - ;; Load the theme files before enabling a theme (else you get an error). + ;; Load the theme files before enabling a theme (modus-themes-load-themes) :config ;; Load the theme of your choice: @@ -326,6 +356,20 @@ package configurations in their setup. We use this as an example: The same without ~use-package~: #+begin_src emacs-lisp +;;; For the built-in themes which cannot use `require': +;; Add all your customizations prior to loading the themes +(setq modus-themes-italic-constructs t + modus-themes-bold-constructs nil + modus-themes-region '(bg-only no-extend)) + +;; Load the theme of your choice: +(load-theme 'modus-operandi) ;; OR (load-theme 'modus-vivendi) + +(define-key global-map (kbd "") #'modus-themes-toggle) + + + +;;; For packaged versions which must use `require': (require 'modus-themes) ;; Add all your customizations prior to loading the themes @@ -418,6 +462,7 @@ this manual. modus-themes-bold-constructs nil modus-themes-mixed-fonts nil modus-themes-subtle-line-numbers nil + modus-themes-intense-mouseovers nil modus-themes-deuteranopia t modus-themes-tabs-accented t modus-themes-variable-pitch-ui nil @@ -433,8 +478,14 @@ this manual. ;; Options for `modus-themes-mode-line' are either nil, or a list ;; that can combine any of `3d' OR `moody', `borderless', - ;; `accented', and a natural number for extra padding - modus-themes-mode-line '(4 accented borderless) + ;; `accented', a natural number for extra padding (or a cons cell + ;; of padding and NATNUM), and a floating point for the height of + ;; the text relative to the base font size (or a cons cell of + ;; height and FLOAT) + modus-themes-mode-line '(accented borderless (padding . 4) (height . 0.9)) + + ;; Same as above: + ;; modus-themes-mode-line '(accented borderless 4 0.9) ;; Options for `modus-themes-markup' are either nil, or a list ;; that can combine any of `bold', `italic', `background', @@ -464,9 +515,10 @@ this manual. ;; Options for `modus-themes-box-buttons' are either nil (the ;; default), or a list that can combine any of `flat', `accented', - ;; `faint', `variable-pitch', `underline', the symbol of any font - ;; weight as listed in `modus-themes-weights', and a floating - ;; point number (e.g. 0.9) for the height of the button's text. + ;; `faint', `variable-pitch', `underline', `all-buttons', the + ;; symbol of any font weight as listed in `modus-themes-weights', + ;; and a floating point number (e.g. 0.9) for the height of the + ;; button's text. modus-themes-box-buttons '(variable-pitch flat faint 0.9) ;; Options for `modus-themes-prompts' are either nil (the @@ -479,8 +531,8 @@ this manual. ;; value (or empty list) or a list of properties that can include ;; any of the following (for WEIGHT read further below): ;; - ;; `key' - `background', `intense', `underline', `italic', WEIGHT - ;; `selection' - `accented', `intense', `underline', `italic', WEIGHT + ;; `matches' - `background', `intense', `underline', `italic', WEIGHT + ;; `selection' - `accented', `intense', `underline', `italic', `text-also' WEIGHT ;; `popup' - same as `selected' ;; `t' - applies to any key not explicitly referenced (check docs) ;; @@ -841,7 +893,9 @@ an empty list). The list can include any of the following symbols: - ~heavy~ - ~extrabold~ - ~ultrabold~ -+ A floating point as a height multiple of the default (e.g. =0.9=) ++ A floating point as a height multiple of the default or a cons cell in + the form of =(height . FLOAT)= ++ ~all-buttons~ The default (a nil value or an empty list) is a gray background combined with a pseudo three-dimensional effect. @@ -873,6 +927,14 @@ defined in the variable ~modus-themes-weights~. A number, expressed as a floating point (e.g. =0.9=), adjusts the height of the button's text to that many times the base font size. The default height is the same as =1.0=, though it need not be explicitly stated. +Instead of a floating point, an acceptable value can be in the form of a +cons cell like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT is +the given number. + +The ~all-buttons~ property extends the box button effect (or the +aforementioned properties) to the faces of the generic widget library. +By default, those do not look like the buttons of the Custom UI as they +are ordinary text wrapped in square brackets. Combinations of any of those properties are expressed as a list, like in these examples: @@ -880,7 +942,9 @@ like in these examples: #+begin_src emacs-lisp (flat) (variable-pitch flat) -(variable-pitch flat 0.9 semibold) +(variable-pitch flat semibold 0.9) +(variable-pitch flat semibold (height 0.9)) ; same as above +(variable-pitch flat semibold (height . 0.9)) ; same as above #+end_src The order in which the properties are set is not significant. @@ -970,7 +1034,10 @@ effect, color, and border visibility: - ~moody~ + ~accented~ + ~borderless~ -+ A natural number > 1 for extra padding ++ A natural number > 1 for extra padding or a cons cell in the form of + ~(padding . NATNUM)~. ++ A floating point to set the height of the mode line's text. It can + also be a cons cell in the form of ~(height . FLOAT)~. The default (a nil value or an empty list) is a two-dimensional rectangle with a border around it. The active and the inactive mode @@ -1006,6 +1073,17 @@ bottom of the mode line, set ~x-underline-at-descent-line~ to non-nil users on Emacs 29, the ~x-use-underline-position-properties~ variable must also be set to nil. +The padding can also be expressed as a cons cell in the form of +=(padding . NATNUM)= or =(padding NATNUM)= where the key is constant and +NATNUM is the desired natural number. + +A floating point applies an adjusted height to the mode line's text as a +multiple of the main font size. The default rate is 1.0 and does not +need to be specified. Apart from a floating point, the height may also +be expressed as a cons cell in the form of =(height . FLOAT)= or +=(height FLOAT)= where the key is constant and the FLOAT is the desired +number. + Combinations of any of those properties are expressed as a list, like in these examples: @@ -1015,6 +1093,15 @@ these examples: (moody accented borderless) #+end_src +Same as above, using the padding and height as an example (these +all yield the same result): + +#+begin_src emacs-lisp +(accented borderless 4 0.9) +(accented borderless (padding . 4) (height . 0.9)) +(accented borderless (padding 4) (height 0.9)) +#+end_src + The order in which the properties are set is not significant. In user configuration files the form may look like this: @@ -1117,12 +1204,14 @@ appear in: The ~selection~ key applies to the current line or currently matched candidate, depending on the specifics of the User Interface. By default -(nil or an empty list), it has a subtle gray background and a bold -weight. The list of properties it accepts is as follows (order is not -significant): +(nil or an empty list), it has a subtle gray background, a bold weight, +and the base foreground value for the text. The list of properties it +accepts is as follows (order is not significant): - ~accented~ to make the background colorful instead of gray; +- ~text-also~ to apply extra color to the text of the selected line; + - ~intense~ to increase the overall coloration; - ~underline~ to draw a line below the characters; @@ -1154,8 +1243,9 @@ Is the same as: #+end_src In the case of the fallback, any property that does not apply to the -corresponding key is simply ignored (~matches~ does not have ~accented~, -~selection~ and ~popup~ do not have ~background~). +corresponding key is simply ignored (~matches~ does not have ~accented~ +and ~text-also~, while ~selection~ and ~popup~ do not have +~background~). A concise expression of those associations can be written as follows, where the ~car~ is always the key and the ~cdr~ is the list of @@ -1389,6 +1479,29 @@ Instead they retain the primary background of the theme, blending with the rest of the buffer. Foreground values for all relevant faces are updated to accommodate this aesthetic. +** Option for mouseover effects +:properties: +:alt_title: Mouse hover effects +:description: Toggle intense style for mouseover highlights +:custom_id: h:9b869620-fcc5-4b5f-9ab8-225d73b7f22f +:end: +#+vindex: modus-themes-intense-mouseovers + +Brief: Toggle intense mouse hover effects. + +Symbol: ~modus-themes-intense-mouseovers~ (=boolean= type) + +Possible value: + +1. ~nil~ (default) +2. ~t~ + +By default all mouseover effects apply a highlight with a subtle colored +background. When non-nil, these have a more pronounced effect. + +Note that this affects the generic ~highlight~ which, strictly speaking, +is not limited to mouse usage. + ** Option for markup style in Org and others :properties: :alt_title: Markup @@ -1674,12 +1787,18 @@ come in the form of a list that can include either or both of those properties: - ~variable-pitch~ to use a proportionately spaced typeface; + - A number as a floating point (e.g. 1.5) to set the height of the text to that many times the default font height. A float of 1.0 or the - symbol ~no-scale~ have the same effect of making the font to the same - height as the rest of the buffer. When neither a number nor ~no-scale~ - are present, the default is a small increase in height (a value of - 1.15). + symbol ~no-scale~ have the same effect of making the font the same + height as the rest of the buffer. When neither a number nor + `no-scale' are present, the default is a small increase in height (a + value of 1.15). + + Instead of a floating point, an acceptable value can be in the form of + a cons cell like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT + is the given number. + - The symbol of a weight attribute adjusts the font of the heading accordingly, such as ~light~, ~semibold~, etc. Valid symbols are defined in the variable ~modus-themes-weights~. The absence of a @@ -1709,16 +1828,24 @@ the following properties: - ~grayscale~ to make weekdays use the main foreground color and weekends a more subtle gray; + - ~workaholic~ to make weekdays and weekends look the same in terms of color; + - ~bold-today~ to apply a bold typographic weight to the current date; + - ~bold-all~ to render all date headings in a bold weight; + - ~underline-today~ applies an underline to the current date while removing the background it has by default; + - A number as a floating point (e.g. 1.2) to set the height of the text to that many times the default font height. The default is the same - as the base font height (the equivalent of 1.0). + as the base font height (the equivalent of 1.0). Instead of a + floating point, an acceptable value can be in the form of a cons cell + like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT is the given + number. For example: @@ -1805,7 +1932,7 @@ passed as a symbol. Those are: attenuated by painting both of them using shades of green. This option thus highlights the alert and overdue states. - When ~modus-themes-deuteranopia~ is non-nil the exact style of the habit - graph adapts to the needs of users with red-green colour deficiency by + graph adapts to the needs of users with red-green color deficiency by substituting every instance of green with blue or cyan (depending on the specifics). @@ -1884,7 +2011,8 @@ Properties: - ~extrabold~ - ~ultrabold~ + ~no-bold~ (deprecated alias of a ~regular~ weight) -+ A floating point as a height multiple of the default (e.g. =1.1=) ++ A floating point as a height multiple of the default or a cons cell in + the form of =(height . FLOAT)=. By default (a ~nil~ value for this variable), all headings have a bold typographic weight and use a desaturated text color. @@ -1916,6 +2044,9 @@ users are encouraged to specify a ~regular~ weight instead. A number, expressed as a floating point (e.g. 1.5), adjusts the height of the heading to that many times the base font size. The default height is the same as 1.0, though it need not be explicitly stated. +Instead of a floating point, an acceptable value can be in the form of a +cons cell like =(height . FLOAT)= or =(height FLOAT)=, where FLOAT is +the given number. Combinations of any of those properties are expressed as a list, like in these examples: @@ -1924,6 +2055,8 @@ these examples: (semibold) (rainbow background) (overline monochrome semibold 1.3) +(overline monochrome semibold (height 1.3)) ; same as above +(overline monochrome semibold (height . 1.3)) ; same as above #+end_src The order in which the properties are set is not significant. @@ -2032,6 +2165,77 @@ Another example that can be bound to a key: : TERM=xterm-direct uxterm -e emacsclient -nw +** Range of color with terminal emulators +:PROPERTIES: +:CUSTOM_ID: h:6b8211b0-d11b-4c00-9543-4685ec3b742f +:END: +#+cindex: Pure white and pure black in terminal emulators + +[ This is based on partial information. Please help verify and/or + expand these findings. ] + +When Emacs runs in a non-windowed session its color reproduction +capacity is framed or determined by the underlying terminal emulator +([[#h:fbb5e254-afd6-4313-bb05-93b3b4f67358][More accurate colors in terminal emulators]]). Emacs cannot produce a +color that lies outside the range of what the terminal's color palette +renders possible. + +This is immediately noticeable when the terminal's first 16 codes do not +include a pure black value for the =termcol0= entry and a pure white for +=termcol15=. Emacs cannot set the correct background (white for +~modus-operandi~; black for ~modus-vivendi~) or foreground (inverse of +the background). It thus falls back to the closest approximation, which +seldom is appropriate for the purposes of the Modus themes. + +In such a case, the user is expected to update their terminal's color +palette such as by adapting these resources: + +#+begin_src emacs-lisp +! Theme: modus-operandi +! Description: XTerm port of modus-operandi (Modus themes for GNU Emacs) +! Author: Protesilaos Stavrou, +xterm*background: #ffffff +xterm*foreground: #000000 +xterm*color0: #000000 +xterm*color1: #a60000 +xterm*color2: #005e00 +xterm*color3: #813e00 +xterm*color4: #0031a9 +xterm*color5: #721045 +xterm*color6: #00538b +xterm*color7: #bfbfbf +xterm*color8: #595959 +xterm*color9: #972500 +xterm*color10: #315b00 +xterm*color11: #70480f +xterm*color12: #2544bb +xterm*color13: #5317ac +xterm*color14: #005a5f +xterm*color15: #ffffff + +! Theme: modus-vivendi +! Description: XTerm port of modus-vivendi (Modus themes for GNU Emacs) +! Author: Protesilaos Stavrou, +xterm*background: #000000 +xterm*foreground: #ffffff +xterm*color0: #000000 +xterm*color1: #ff8059 +xterm*color2: #44bc44 +xterm*color3: #d0bc00 +xterm*color4: #2fafff +xterm*color5: #feacd0 +xterm*color6: #00d3d0 +xterm*color7: #bfbfbf +xterm*color8: #595959 +xterm*color9: #ef8b50 +xterm*color10: #70b900 +xterm*color11: #c0c530 +xterm*color12: #79a8ff +xterm*color13: #b6a0ff +xterm*color14: #6ae4b9 +xterm*color15: #ffffff +#+end_src + ** Visualize the active Modus theme's palette :properties: :custom_id: h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d @@ -2553,7 +2757,7 @@ The themes provide a mechanism for overriding their color values. This is controlled by the variables ~modus-themes-operandi-color-overrides~ and ~modus-themes-vivendi-color-overrides~, which are alists that should mirror a subset of the associations in ~modus-themes-operandi-colors~ and -~modus-themes-vivendi-colors~ respectively. As with all customisations, +~modus-themes-vivendi-colors~ respectively. As with all customizations, overriding must be done before loading the affected theme. [[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Visualize the active Modus theme's palette]]. @@ -2659,7 +2863,7 @@ Operandi and night sky blue shades for Modus Vivendi. Switching between the two themes, such as with {{{kbd(M-x modus-themes-toggle)}}} will also use the overrides. -Given that this is a user-level customisation, one is free to implement +Given that this is a user-level customization, one is free to implement whatever color values they desire, even if the possible combinations fall below the minimum 7:1 contrast ratio that governs the design of the themes (the WCAG AAA legibility standard). Alternatively, this can also @@ -3720,6 +3924,135 @@ coloration. [[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Visualize the active Modus theme's palette]]. +** Near-monochrome syntax highlighting +:properties: +:custom_id: h:c1f3fa8e-7a63-4a6f-baf3-a7febc0661f0 +:end: +#+cindex: Monochrome code syntax + +While the Modus themes do provide a user option to control the overall +style of syntax highlighting in programming major modes, they do not +cover the possibility of a monochromatic or near-monochromatic design +([[#h:c119d7b2-fcd4-4e44-890e-5e25733d5e52][Option for syntax highlighting]]). This is due to the multitude of +preferences involved: one may like comments to be styled with an accent +value, another may want certain constructs to be bold, a third may apply +italics to doc strings but not comments... The possibilities are +virtually endless. As such, this sort of design is best handled at the +user level in accordance with the information furnished elsewhere in +this manual. + +[[#h:1487c631-f4fe-490d-8d58-d72ffa3bd474][Case-by-case face specs using the themes' palette]]. + +[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]]. + +The gist is that we want to override the font-lock faces. For our +changes to persist while switching between ~modus-operandi~ and +~modus-vivendi~ we wrap our face overrides in a function that we hook to +~modus-themes-after-load-theme-hook~. + +Users who want to replicate the structure of the themes' source code are +advised to use the examples with ~custom-set-faces~. Those who prefer a +different approach can use the snippets which call ~set-face-attribute~. +Below are the code blocks. + +The following uses a yellow accent value for comments and green hues for +strings. Regexp grouping constructs have color values that work in the +context of a green string. All other elements use the main foreground +color, except warnings such as the ~user-error~ function in Elisp +buffers which gets a subtle red tint (not to be confused with the +~warning~ face which is used for genuine warnings). Furthermore, notice +the ~modus-themes-bold~ and ~modus-themes-slant~ which apply the +preference set in the user options ~modus-themes-bold-constructs~ and +~modus-themes-italic-constructs~, respectively. Users who do not want +this conditionally must replace these faces with ~bold~ and ~italic~ +respectively (or ~unspecified~ to disable the effect altogether). + +#+begin_src emacs-lisp +;; This is the hook. It will not be replicated across all code samples. +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-subtle-syntax) + +(defun my-modus-themes-subtle-syntax () + (modus-themes-with-colors + (custom-set-faces + `(font-lock-builtin-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-comment-delimiter-face ((,class :inherit font-lock-comment-face))) + `(font-lock-comment-face ((,class :inherit unspecified :foreground ,fg-comment-yellow))) + `(font-lock-constant-face ((,class :foreground unspecified))) + `(font-lock-doc-face ((,class :inherit modus-themes-slant :foreground ,fg-special-mild))) + `(font-lock-function-name-face ((,class :foreground unspecified))) + `(font-lock-keyword-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-negation-char-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-preprocessor-face ((,class :foreground unspecified))) + `(font-lock-regexp-grouping-backslash ((,class :inherit bold :foreground ,yellow))) + `(font-lock-regexp-grouping-construct ((,class :inherit bold :foreground ,blue-alt-other))) + `(font-lock-string-face ((,class :foreground ,green-alt-other))) + `(font-lock-type-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-variable-name-face ((,class :foreground unspecified))) + `(font-lock-warning-face ((,class :inherit modus-themes-bold :foreground ,red-nuanced-fg)))))) + +;; Same as above with `set-face-attribute' instead of `custom-set-faces' +(defun my-modus-themes-subtle-syntax () + (modus-themes-with-colors + (set-face-attribute 'font-lock-builtin-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-comment-delimiter-face nil :inherit 'font-lock-comment-face) + (set-face-attribute 'font-lock-comment-face nil :inherit 'unspecified :foreground fg-comment-yellow) + (set-face-attribute 'font-lock-constant-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-doc-face nil :inherit 'modus-themes-slant :foreground fg-special-mild) + (set-face-attribute 'font-lock-function-name-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-keyword-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-negation-char-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-preprocessor-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-regexp-grouping-backslash nil :inherit 'bold :foreground yellow) + (set-face-attribute 'font-lock-regexp-grouping-construct nil :inherit 'bold :foreground blue-alt-other) + (set-face-attribute 'font-lock-string-face nil :foreground green-alt-other) + (set-face-attribute 'font-lock-type-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-variable-name-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-warning-face nil :inherit 'modus-themes-bold :foreground red-nuanced-fg))) +#+end_src + +The following sample is the same as above, except strings are blue and +comments are gray. Regexp constructs are adapted accordingly. + +#+begin_src emacs-lisp +(defun my-modus-themes-subtle-syntax () + (modus-themes-with-colors + (custom-set-faces + `(font-lock-builtin-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-comment-delimiter-face ((,class :inherit font-lock-comment-face))) + `(font-lock-comment-face ((,class :inherit unspecified :foreground ,fg-alt))) + `(font-lock-constant-face ((,class :foreground unspecified))) + `(font-lock-doc-face ((,class :inherit modus-themes-slant :foreground ,fg-docstring))) + `(font-lock-function-name-face ((,class :foreground unspecified))) + `(font-lock-keyword-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-negation-char-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-preprocessor-face ((,class :foreground unspecified))) + `(font-lock-regexp-grouping-backslash ((,class :inherit bold :foreground ,fg-escape-char-backslash))) + `(font-lock-regexp-grouping-construct ((,class :inherit bold :foreground ,fg-escape-char-construct))) + `(font-lock-string-face ((,class :foreground ,blue-alt))) + `(font-lock-type-face ((,class :inherit modus-themes-bold :foreground unspecified))) + `(font-lock-variable-name-face ((,class :foreground unspecified))) + `(font-lock-warning-face ((,class :inherit modus-themes-bold :foreground ,red-nuanced-fg)))))) + +;; Same as above with `set-face-attribute' instead of `custom-set-faces' +(defun my-modus-themes-subtle-syntax () + (modus-themes-with-colors + (set-face-attribute 'font-lock-builtin-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-comment-delimiter-face nil :inherit 'font-lock-comment-face) + (set-face-attribute 'font-lock-comment-face nil :inherit 'unspecified :foreground fg-alt) + (set-face-attribute 'font-lock-constant-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-doc-face nil :inherit 'modus-themes-slant :foreground fg-docstring) + (set-face-attribute 'font-lock-function-name-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-keyword-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-negation-char-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-preprocessor-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-regexp-grouping-backslash nil :inherit 'bold :foreground fg-escape-char-backslash) + (set-face-attribute 'font-lock-regexp-grouping-construct nil :inherit 'bold :foreground fg-escape-char-construct) + (set-face-attribute 'font-lock-string-face nil :foreground blue-alt) + (set-face-attribute 'font-lock-type-face nil :inherit 'modus-themes-bold :foreground 'unspecified) + (set-face-attribute 'font-lock-variable-name-face nil :foreground 'unspecified) + (set-face-attribute 'font-lock-warning-face nil :inherit 'modus-themes-bold :foreground red-nuanced-fg))) +#+end_src + * Face coverage :properties: :custom_id: h:a9c8f29d-7f72-4b54-b74b-ddefe15d6a19 @@ -3793,6 +4126,7 @@ have lots of extensions, so the "full support" may not be 100% true… + deadgrep + debbugs + deft ++ devdocs + dictionary + diff-hl + diff-mode @@ -3914,6 +4248,7 @@ have lots of extensions, so the "full support" may not be 100% true… + mct + mentor + messages ++ mini-modeline + minimap + mmm-mode + mode-line @@ -4063,6 +4398,7 @@ supported by the themes. + dtache + easy-kill + edit-indirect ++ elfeed-summary + evil-owl + flyspell-correct + fortran-mode @@ -4083,6 +4419,7 @@ supported by the themes. + swift-mode + tab-bar-echo-area + tide ++ undo-hl + vdiff + vertico-indexed + vertico-mouse @@ -4239,29 +4576,20 @@ package: it draws too much attention to unfocused windows. :custom_id: h:2a602816-bc1b-45bf-9675-4cbbd7bf6cab :end: -While designing the style for ~display-fill-column-indicator-mode~, we -stayed close to the mode's defaults: to apply a subtle foreground color -to the ~fill-column-indicator~ face, which blends well with the rest of -theme and is consistent with the role of that mode. This is to not -upset the expectations of users. +The ~display-fill-column-indicator-mode~ uses a typographic character to +draw its line. This has the downside of creating a dashed line. The +dashes are further apart depending on how tall the font's glyph height +is and what integer the ~line-spacing~ is set to. -Nevertheless, ~display-fill-column-indicator-mode~ has some known -limitations pertaining to its choice of using typographic characters to -draw its indicator. What should be a continuous vertical line might -appear as a series of dashes in certain contexts or under specific -conditions: a non-default value for ~line-spacing~, scaled and/or -variable-pitch headings have been observed to cause this effect. - -Given that we cannot control such factors, it may be better for affected -users to deviate from the default style of the ~fill-column-indicator~ -face. Instead of setting a foreground color, one could use a background -and have the foreground be indistinguishable from it. For example: +At the theme level we eliminate this effect by making the character one +pixel tall: the line is contiguous. Users who prefer the dashed line +are advised to change the ~fill-column-indicator~ face, as explained +elsewhere in this document. For example: #+begin_src emacs-lisp (modus-themes-with-colors (custom-set-faces - `(fill-column-indicator ((,class :background ,bg-inactive - :foreground ,bg-inactive))))) + `(fill-column-indicator ((,class :foreground ,bg-active))))) #+end_src [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]]. @@ -4456,7 +4784,7 @@ implements an alternative to the typical coloration of code. Instead of highlighting the syntactic constructs, it applies color to different levels of depth in the code structure. -As {{{file(prism.el)}}} offers a broad range of customisations, we cannot +As {{{file(prism.el)}}} offers a broad range of customizations, we cannot style it directly at the theme level: that would run contrary to the spirit of the package. Instead, we may offer preset color schemes. Those should offer a starting point for users to adapt to their needs. @@ -4644,7 +4972,7 @@ Emacs' HTML rendering library ({{{file(shr.el)}}}) may need explicit configuration to respect the theme's colors instead of whatever specifications the webpage provides. -Consult {{{kbd(C-h v shr-use-colors)}}}. +Consult the doc string of ~shr-use-colors~. ** Note on SHR fonts :properties: @@ -4806,6 +5134,20 @@ you've customized any faces. "-draw" "text %X,%Y '%c'")))) #+end_src +** Note on the Notmuch logo +:properties: +:custom_id: h:636af312-54a5-4918-84a6-0698e85a3c6d +:end: + +By default, the "hello" buffer of Notmuch includes a header with the +programs' logo and a couple of buttons. The logo has the effect of +enlarging the height of the line, which negatively impacts the shape of +those buttons. Disabling the logo fixes the problem: + +#+begin_src emacs-lisp +(setq notmuch-show-logo nil) +#+end_src + * Frequently Asked Questions :properties: :custom_id: h:b3384767-30d3-4484-ba7f-081729f03a47 @@ -5124,8 +5466,8 @@ themes remains consistent. The former criterion should be crystal clear as it pertains to the scientific foundations of the themes: high legibility and taking care of -the needs of users with red-green colour deficiency (deuteranopia) by -avoiding red+green colour coding paradigms and/or by providing red+blue +the needs of users with red-green color deficiency (deuteranopia) by +avoiding red+green color coding paradigms and/or by providing red+blue variants. The latter criterion is the "je ne sais quoi" of the artistic aspect of @@ -5143,7 +5485,7 @@ but try to understand its spirit. For a trivial example: the curly underline that Emacs draws for spelling errors is thinner than, e.g., what a graphical web browser has, so if I was to design for an editor than has a thicker curly underline I would -make the applicable colours less intense to counterbalance the +make the applicable colors less intense to counterbalance the typographic intensity of the added thickness. With those granted, if anyone is willing to develop a port of the @@ -5166,8 +5508,8 @@ in which you can contribute to their ongoing development. The ~modus-operandi~ and ~modus-vivendi~ themes are built into Emacs 28. -The source code of the themes is [[https://gitlab.com/protesilaos/modus-themes/][available on Gitlab]], for the time -being. A [[https://github.com/protesilaos/modus-themes/][mirror on Github]] is also on offer. +The source code of the themes is [[https://gitlab.com/protesilaos/modus-themes/][available on GitLab]], for the time +being. A [[https://github.com/protesilaos/modus-themes/][mirror on GitHub]] is also on offer. An HTML version of this manual is provided as an extension of the [[https://protesilaos.com/emacs/modus-themes/][author's personal website]] (does not rely on any non-free code). @@ -5274,37 +5616,39 @@ The Modus themes are a collective effort. Every bit of work matters. + Author/maintainer :: Protesilaos Stavrou. + Contributions to code or documentation :: Alex Griffin, Anders - Johansson, Basil L.{{{space()}}} Contovounesios, Björn Lindström, Carlo - Zancanaro, Christian Tietze, Daniel Mendler, Eli Zaretskii, Fritz - Grabo, Illia Ostapyshyn, Kévin Le Gouguec, Kostadin Ninev, Madhavan - Krishnan, Markus Beppler, Matthew Stevenson, Mauro Aranda, Nicolas De - Jaeghere, Philip Kaludercic, Rudolf Adamkovič, Stephen Gildea, Shreyas - Ragavan, Stefan Kangas, Utkarsh Singh, Vincent Murphy, Xinglu Chen, - Yuanchen Xie. + Johansson, Basil L.{{{space()}}} Contovounesios, Björn Lindström, + Carlo Zancanaro, Christian Tietze, Daniel Mendler, Eli Zaretskii, + Fritz Grabo, Illia Ostapyshyn, Kévin Le Gouguec, Kostadin Ninev, + Madhavan Krishnan, Markus Beppler, Matthew Stevenson, Mauro Aranda, + Nicolas De Jaeghere, Philip Kaludercic, Pierre Téchoueyres, Rudolf + Adamkovič, Stephen Gildea, Shreyas Ragavan, Stefan Kangas, Utkarsh + Singh, Vincent Murphy, Xinglu Chen, Yuanchen Xie. + Ideas and user feedback :: Aaron Jensen, Adam Porter, Adam Spiers, Adrian Manea, Alex Griffin, Alex Koen, Alex Peitsinis, Alexey Shmalko, - Alok Singh, Anders Johansson, André Alexandre Gomes, Arif Rezai, Basil - L.{{{space()}}} Contovounesios, Burgess Chang, Christian Tietze, - Christopher Dimech, Damien Cassou, Daniel Mendler, Dario Gjorgjevski, - David Edmondson, Davor Rotim, Divan Santana, Eliraz Kedmi, Emanuele - Michele Alberto Monterosso, Farasha Euker, Feng Shu, Gautier Ponsinet, - Gerry Agbobada, Gianluca Recchia, Guilherme Semente, Gustavo Barros, - Hörmetjan Yiltiz, Ilja Kocken, Iris Garcia, Jeremy Friesen, Jerry - Zhang, Johannes Grødem, John Haman, Joshua O'Connor, Kenta Usami, - Kevin Fleming, Kévin Le Gouguec, Kostadin Ninev, Len Trigg, Magne Hov, - Manuel Uberti, Mark Bestley, Mark Burton, Markus Beppler, Mauro - Aranda, Michael Goldenberg, Morgan Smith, Murilo Pereira, Nicky van + Alok Singh, Anders Johansson, André Alexandre Gomes, Antonio Hernández + Blas, Arif Rezai, Augusto Stoffel, Basil L.{{{space()}}} + Contovounesios, Burgess Chang, Christian Tietze, Christopher Dimech, + Damien Cassou, Daniel Mendler, Dario Gjorgjevski, David Edmondson, + Davor Rotim, Divan Santana, Eliraz Kedmi, Emanuele Michele Alberto + Monterosso, Farasha Euker, Feng Shu, Gautier Ponsinet, Gerry Agbobada, + Gianluca Recchia, Guilherme Semente, Gustavo Barros, Hörmetjan Yiltiz, + Ilja Kocken, Iris Garcia, Jeremy Friesen, Jerry Zhang, Johannes + Grødem, John Haman, Jorge Morais, Joshua O'Connor, Julio + C. Villasante, Kenta Usami, Kevin Fleming, Kévin Le Gouguec, Kostadin + Ninev, Len Trigg, Lennart C. Karssen, Magne Hov, Manuel Uberti, Mark + Bestley, Mark Burton, Markus Beppler, Mauro Aranda, Michael + Goldenberg, Morgan Smith, Morgan Willcock, Murilo Pereira, Nicky van Foreest, Nicolas De Jaeghere, Paul Poloskov, Pengji Zhang, Pete - Kazmier, Peter Wu, Philip Kaludercic, Pierre Téchoueyres, Roman - Rudakov, Ryan Phillips, Rudolf Adamkovič, Sam Kleinman, Samuel - Culpepper, Saša Janiška, Shreyas Ragavan, Simon Pugnet, Tassilo Horn, - Thibaut Verron, Thomas Heartman, Togan Muftuoglu, Trey Merkley, Tomasz - Hołubowicz, Toon Claes, Uri Sharf, Utkarsh Singh, Vincent Foley. As - well as users: Ben, CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, - Fredrik, Moesasji, Nick, TheBlob42, Trey, bepolymathe, bit9tream, - derek-upham, doolio, fleimgruber, gitrj95, iSeeU, jixiuf, okamsn, - pRot0ta1p. + Kazmier, Peter Wu, Philip Kaludercic, Pierre Téchoueyres, Robert + Hepple, Roman Rudakov, Ryan Phillips, Rytis Paškauskas, Rudolf + Adamkovič, Sam Kleinman, Samuel Culpepper, Saša Janiška, Shreyas + Ragavan, Simon Pugnet, Tassilo Horn, Thibaut Verron, Thomas Heartman, + Togan Muftuoglu, Tony Zorman, Trey Merkley, Tomasz Hołubowicz, Toon + Claes, Uri Sharf, Utkarsh Singh, Vincent Foley. As well as users: + Ben, CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, Fredrik, + Moesasji, Nick, TheBlob42, Trey, bepolymathe, bit9tream, derek-upham, + doolio, fleimgruber, gitrj95, iSeeU, jixiuf, okamsn, pRot0ta1p. + Packaging :: Basil L.{{{space()}}} Contovounesios, Eli Zaretskii, Glenn Morris, Mauro Aranda, Richard Stallman, Stefan Kangas (core Emacs), diff --git a/doc/misc/org.org b/doc/misc/org.org index 60af81ea2cf..3dce83c936b 100644 --- a/doc/misc/org.org +++ b/doc/misc/org.org @@ -6405,7 +6405,7 @@ special repeaters =++= and =.+=. For example: Marking this DONE shifts the date to one month after today. ,** TODO Wash my hands - DEADLINE: <2019-04-05 08:00 Sun .+1h> + DEADLINE: <2019-04-05 08:00 Fri .+1h> Marking this DONE shifts the date to exactly one hour from now. #+end_example diff --git a/doc/misc/rcirc.texi b/doc/misc/rcirc.texi index b18ab2a6b29..8253e404084 100644 --- a/doc/misc/rcirc.texi +++ b/doc/misc/rcirc.texi @@ -154,8 +154,11 @@ deego: fsbot rules! @cindex nick completion @cindex completion of nicks +@vindex rcirc-cycle-completion-flag @kindex TAB Since this is so common, you can use @key{TAB} to do nick completion. +By default rcirc will use the default completion system, but you can +enable @code{rcirc-cycle-completion-flag} to cycle nicks in place. @node Getting started with rcirc @section Getting started with rcirc diff --git a/doc/misc/ses.texi b/doc/misc/ses.texi index 0acb7bf3f15..6d0415cdbbb 100644 --- a/doc/misc/ses.texi +++ b/doc/misc/ses.texi @@ -220,7 +220,14 @@ You move around with the regular Emacs movement commands. @table @kbd @item j -Moves point to cell, specified by identifier (@code{ses-jump}). +Moves point to cell, specified by identifier (@code{ses-jump}). Unless +the cell is a renamed cell, the identifier is case-insensitive. A +prefix argument @math{n} move to cell with coordinates @math{(n\div R, +n \% C)} for a spreadsheet of @math{R} rows and @math{C} columns, and +A1 being of coordinates @math{(0,0)}. The way the identifier or the +command prefix argument are interpreted can be customized through +variables @code{ses-jump-cell-name-function} and +@code{ses-jump-prefix-function}. @end table Point is always at the left edge of a cell, or at the empty endline. @@ -726,10 +733,6 @@ yank. This doesn't make any difference? @section Customizing @acronym{SES} @cindex customizing @vindex enable-local-eval -@vindex ses-mode-hook -@vindex safe-functions -@vindex enable-local-eval - By default, a newly-created spreadsheet has 1 row and 1 column. The column width is 7 and the default printer is @samp{"%.7g"}. Each of these @@ -740,9 +743,34 @@ cell. You can customize @code{ses-after-entry-functions} to move left or up or down. For diagonal movement, select two functions from the list. +@vindex ses-jump-cell-name-function +@code{ses-jump-cell-name-function} is a customizable variable by +default set to the @code{upcase} function. This function is called +when you pass a cell name to the @command{ses-jump} command (@kbd{j}), +it changes the entered cell name to that where to jump. The default +setting @code{upcase} allows you to enter the cell name in low +case. Another use of @code{ses-jump-cell-name-function} could be some +internationalisation to convert non latin characters into latin +equivalents to name the cell. Instead of a cell name, the function may +return cell coordinates in the form of a cons, for instance @code{(0 +. 0)} for cell @code{A1}, @code{(1 . 0)} for cell @code{A2}, etc. + +@vindex ses-jump-prefix-function +@code{ses-jump-prefix-function} is a customisable variable by default +set to the @code{ses-jump-prefix} function. This function is called +when you give a prefix argument to the @command{ses-jump} command +(@kbd{j}). It returns a cell name or cell coordinates corresponding to +the prefix argument. Cell coordinates are in the form of a cons, for +instance @code{(1 . 0)} for cell @code{A2}. The default setting +@code{ses-jump-prefix} will number cells left to right and then top +down, so assuming a 4x3 spreadsheet prefix argument 0 jumps to cell +A1, prefix argument 2 jumps to C1, prefix argument 3 jumps to A2, etc. + +@vindex ses-mode-hook @code{ses-mode-hook} is a normal mode hook (list of functions to execute when starting @acronym{SES} mode for a buffer). +@vindex safe-functions The variable @code{safe-functions} is a list of possibly-unsafe functions to be treated as safe when analyzing formulas and printers. @xref{Virus protection}. Before customizing @code{safe-functions}, diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex index 58b6abee78c..8872e5e055f 100644 --- a/doc/misc/texinfo.tex +++ b/doc/misc/texinfo.tex @@ -3,9 +3,9 @@ % Load plain if necessary, i.e., if running under initex. \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi % -\def\texinfoversion{2022-01-02.12} +\def\texinfoversion{2022-04-09.08} % -% Copyright 1985, 1986, 1988, 1990-2021 Free Software Foundation, Inc. +% Copyright 1985, 1986, 1988, 1990-2022 Free Software Foundation, Inc. % % This texinfo.tex file is free software: you can redistribute it and/or % modify it under the terms of the GNU General Public License as @@ -3171,16 +3171,8 @@ % Default is `distinct'. \kbdinputstyle distinct -% @kbd is like @code, except that if the argument is just one @key command, -% then @kbd has no effect. -\def\kbd#1{{\def\look{#1}\expandafter\kbdsub\look??\par}} - -\def\xkey{\key} -\def\kbdsub#1#2#3\par{% - \def\one{#1}\def\three{#3}\def\threex{??}% - \ifx\one\xkey\ifx\threex\three \key{#2}% - \else{\tclose{\kbdfont\setcodequotes\look}}\fi - \else{\tclose{\kbdfont\setcodequotes\look}}\fi +\def\kbd#1{% + \tclose{\kbdfont\setcodequotes#1}% } % definition of @key that produces a lozenge. Doesn't adjust to text size. @@ -4417,7 +4409,7 @@ % Find the correct column width \hsize=\expandafter\csname col\the\colcount\endcsname % - \rightskip=0pt + \advance\rightskip by -1\rightskip % Zero leaving only any stretch \ifnum\colcount=1 \advance\hsize by\leftskip % Add indent of surrounding text \else @@ -5961,7 +5953,7 @@ % Chapters, sections, etc. % Let's start with @part. -\outer\parseargdef\part{\partzzz{#1}} +\parseargdef\part{\partzzz{#1}} \def\partzzz#1{% \chapoddpage \null @@ -8680,9 +8672,11 @@ } \def\wordTop{Top} -% Until the next @node or @bye command, divert output to a box that is not -% output. -\def\ignorenode{\setbox\dummybox\vbox\bgroup\def\node{\egroup\node}% +% Until the next @node, @part or @bye command, divert output to a box that +% is not output. +\def\ignorenode{\setbox\dummybox\vbox\bgroup +\def\part{\egroup\part}% +\def\node{\egroup\node}% \ignorenodebye } @@ -9391,13 +9385,12 @@ \catcode`\^^M = 5 % in case we're inside an example \normalturnoffactive % allow _ et al. in names \makevalueexpandable - % If the image is by itself, center it. \ifvmode \imagevmodetrue \else \ifx\centersub\centerV % for @center @image, we need a vbox so we can have our vertical space \imagevmodetrue - \vbox\bgroup % vbox has better behavior than vtop herev + \vbox\bgroup % vbox has better behavior than vtop here \fi\fi % \ifimagevmode @@ -9405,11 +9398,14 @@ % Usually we'll have text after the image which will insert % \parskip glue, so insert it here too to equalize the space % above and below. - \nobreak\vskip\parskip - \nobreak + \vskip\parskip + % + % Place image in a \vtop for a top page margin that is (close to) correct, + % as \topskip glue is relative to the first baseline. + \vtop\bgroup\hrule height 0pt\vskip-\parskip \fi % - % Leave vertical mode so that indentation from an enclosing + % Enter horizontal mode so that indentation from an enclosing % environment such as @quotation is respected. % However, if we're at the top level, we don't want the % normal paragraph indentation. @@ -9438,6 +9434,7 @@ \fi % \ifimagevmode + \egroup \medskip % space after a standalone image \fi \ifx\centersub\centerV \egroup \fi @@ -10898,6 +10895,9 @@ \DeclareUnicodeCharacter{1EF8}{\~Y}% \DeclareUnicodeCharacter{1EF9}{\~y}% % + % Exotic spaces + \DeclareUnicodeCharacter{2007}{\hphantom{0}}% + % % Punctuation \DeclareUnicodeCharacter{2013}{--}% \DeclareUnicodeCharacter{2014}{---}% diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 62bcf9c73b3..bb91aec0cc0 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -1881,29 +1881,25 @@ Example: The following predefined functions parsing configuration files exist: -@table @asis +@ftable @asis @item @code{tramp-parse-rhosts} -@findex tramp-parse-rhosts This function parses files which are syntactical equivalent to @file{~/.rhosts}. It returns both host names and user names, if specified. @item @code{tramp-parse-shosts} -@findex tramp-parse-shosts This function parses files which are syntactical equivalent to @file{~/.ssh/known_hosts}. Since there are no user names specified in such files, it can return host names only. @item @code{tramp-parse-sconfig} -@findex tramp-parse-sconfig This function returns the host nicknames defined by @option{Host} entries in @file{~/.ssh/config} style files. @item @code{tramp-parse-shostkeys} -@findex tramp-parse-shostkeys SSH2 parsing of directories @file{/etc/ssh2/hostkeys/*} and @file{~/ssh2/hostkeys/*}. Hosts are coded in file names @@ -1911,7 +1907,6 @@ SSH2 parsing of directories @file{/etc/ssh2/hostkeys/*} and are always @code{nil}. @item @code{tramp-parse-sknownhosts} -@findex tramp-parse-sknownhosts Another SSH2 style parsing of directories like @file{/etc/ssh2/knownhosts/*} and @file{~/ssh2/knownhosts/*}. This @@ -1919,26 +1914,22 @@ case, hosts names are coded in file names @file{@var{host-name}.@var{algorithm}.pub}. User names are always @code{nil}. @item @code{tramp-parse-hosts} -@findex tramp-parse-hosts A function dedicated to @file{/etc/hosts} for host names. @item @code{tramp-parse-passwd} -@findex tramp-parse-passwd A function which parses @file{/etc/passwd} for user names. @item @code{tramp-parse-etc-group} -@findex tramp-parse-etc-group A function which parses @file{/etc/group} for group names. @item @code{tramp-parse-netrc} -@findex tramp-parse-netrc A function which parses @file{~/.netrc} and @file{~/.authinfo}-style files. -@end table +@end ftable To keep a custom file with custom data in a custom structure, a custom function has to be provided. This function must meet the following @@ -2658,6 +2649,41 @@ The most common @value{tramp} connection family is based on either configuration recommendations are given. +@subsection Using ssh config include for host name completion + +@vindex Include@r{, ssh option} +@findex tramp-set-completion-function +@findex tramp-get-completion-function +OpenSSH configuration files can use an @option{Include} option for +further configuration files. Default @value{tramp} host name +completion ignores this option. However, you can configure this +yourself. + +Given, your @file{~/.ssh/config} file contains the following option: + +@example +Include ~/.ssh/conf.d/* +@end example + +The following code snippet in your @file{.emacs} uses all files in +that directory for host name completion: + +@lisp +@group +(tramp-set-completion-function + "ssh" (append (tramp-get-completion-function "ssh") + (mapcar (lambda (file) `(tramp-parse-sconfig ,file)) + (directory-files + "~/.ssh/conf.d/" + 'full directory-files-no-dot-files-regexp)))) +@end group +@end lisp + +This code snippet does it for the @option{ssh} method. If you replace +@t{"ssh"} by @t{"scp"}, it does it also for that method (or any other +method you like). + + @subsection Detection of session hangouts @vindex ServerAliveInterval@r{, ssh option} @@ -2913,6 +2939,7 @@ Additionally, it declares also the arguments for running remote processes, using the @command{ssh} command. These don't need to be changed. + @node Android shell setup @section Android shell setup hints @cindex android shell setup for ssh @@ -4019,6 +4046,127 @@ using the @code{:connection-type} keyword. If this keyword is not used, the value of @code{process-connection-type} is applied instead. +@subsection Process properties of asynchronous remote processes +@cindex Asynchronous remote processes + +When available, @value{tramp} adds process properties to process +objects of asynchronous properties. However, it is not guaranteed +that all these properties are set. + +@itemize +@item @code{remote-tty} + +This is the name of the terminal a @var{process} uses on the remote +host, i.e., it reads and writes on. + +@item @code{remote-pid} + +The process id of the command executed on the remote host. This is +used when sending signals remotely. + +@item @code{remote-command} + +The remote command which has been invoked via @code{make-process} or +@code{start-file-process}, a list of strings (program and its +arguments). This does not show the additional shell sugar +@value{tramp} makes around the commands, in order to see this you must +inspect @value{tramp} @ref{Traces and Profiles, traces}. +@end itemize + +@findex list-system-processes +@findex process-attributes +The functions @code{list-system-processes} and +@code{process-attributes} return information about system processes on +the respective remote host. In order to retrieve this information, +they use the command @command{ps}, driven by the following constants: + +@defvr Constant tramp-process-attributes-ps-args +This is a list of arguments (strings) @command{ps} is called with. +The default value is appropriate for GNU/Linux remote hosts. +@end defvr + +@defvr Constant tramp-process-attributes-ps-format +This is a list of cons cells @code{(@var{key} . @var{type})} for +interpretation of the @command{ps} output. @var{key} is a key used in +the @code{process-attributes} output plus the key @code{pid}, and +@var{type} is the respective value returned by @command{ps}. It can +be + + +@multitable {@bullet{} @code{numberp}} {--- a string of @var{number} width, could contain spaces} +@item @bullet{} @code{numberp} @tab --- a number +@item @bullet{} @code{stringp} @tab --- a string without spaces +@item @bullet{} @var{number} +@tab --- a string of @var{number} width, could contain spaces +@item @bullet{} @code{nil} @tab --- a string until end of line +@end multitable + +The default value is appropriate for GNU/Linux remote hosts. +@end defvr + +If, for example, @code{tramp-process-attributes-ps-args} is declared +as @code{("-eww" "-o" "pid,euid,euser,egid,egroup,comm:40,state")}, +the output of the respective @command{ps} command would look like + +@smallexample +@group + PID EUID EUSER EGID EGROUP COMMAND S + 1 0 root 0 root systemd S + 1610 0 root 0 root NFSv4 callback S + @dots{} +@end group +@end smallexample + +The corresponding @code{tramp-process-attributes-ps-format} has the value + +@smallexample +@group +@code{((pid . numberp) (euid . numberp) (user . stringp) + (egid . numberp) (group . stringp) (comm . 40) (state . stringp))} +@end group +@end smallexample + +@vindex tramp-adb-connection-local-default-ps-profile +@vindex tramp-adb-connection-local-default-ps-variables +@vindex tramp-connection-local-bsd-ps-profile +@vindex tramp-connection-local-bsd-ps-variables +@vindex tramp-connection-local-busybox-ps-profile +@vindex tramp-connection-local-busybox-ps-variables +@vindex tramp-connection-local-darwin-ps-profile +@vindex tramp-connection-local-darwin-ps-variables +The default values for @code{tramp-process-attributes-ps-args} and +@code{tramp-process-attributes-ps-format} can be overwritten by +connection-local variables. +@ifinfo +@xref{Connection Variables, , , emacs}. +@end ifinfo +This is already done by @value{tramp} for the @option{adb} method, see +@code{tramp-adb-connection-local-default-ps-profile} and +@code{tramp-adb-connection-local-default-ps-variables}. + +There are three further predefined sets of connection-local variables +for remote BSD systems, for remote macOS systems, and for a remote +@command{ps} command implemented with @command{busybox}. These are +called @code{tramp-connection-local-*-ps-profile} and +@code{tramp-connection-local-*-ps-variables}. Use them like + +@lisp +@group +(connection-local-set-profiles + '(:application tramp :machine "mybsdhost") + 'tramp-connection-local-bsd-ps-profile) +@end group +@end lisp + +@cindex proced +@vindex proced-show-remote-processes +If you want to see a listing of remote system processes when calling +@code{proced}, set user option @code{proced-show-remote-processes} to +non-@code{nil}, or invoke that command with a negative argument like +@kbd{C-u - M-x proced @key{RET}} when your buffer has a remote +@code{default-directory}. + + @anchor{Improving performance of asynchronous remote processes} @subsection Improving performance of asynchronous remote processes @cindex Asynchronous remote processes @@ -5000,6 +5148,26 @@ be restored by moving them manually from @file{$@{XDG_DATA_HOME@}/Trash/files/}, if needed. +@item +How to identify temporary files produced by @value{tramp}? + +@vindex tramp-temp-name-prefix +Temporary files are kept in your @code{temporary-file-directory} +directory, which is often @file{/tmp/}. By default, they have the +file name prefix @t{"tramp."}. If you want to change this prefix, for +example because you want to identify temporary files produced by +@code{file-local-copy} in your package, you can bind the variable +@code{tramp-temp-name-prefix} temporarily: + +@example +@group +(let ((tramp-temp-name-prefix "my-prefix.")) + (file-local-copy "@trampfn{ssh,,.emacs}")) +@result{} "/tmp/my-prefix.HDfgDZ" +@end group +@end example + + @item How to shorten long file names when typing in @value{tramp}? diff --git a/doc/misc/transient.texi b/doc/misc/transient.texi index f91d0e5c10a..191fe8cd853 100644 --- a/doc/misc/transient.texi +++ b/doc/misc/transient.texi @@ -23,9 +23,9 @@ General Public License for more details. @end quotation @end copying -@dircategory Emacs +@dircategory Emacs misc features @direntry -* Transient: (transient). Transient Commands. +* Transient: (transient). Transient Commands. @end direntry @finalout diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 472dee70ec0..296dc520a1b 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -88,9 +88,9 @@ Here's just about the simplest vtable that can be created: ("Gazonk" 45))) @end lisp -By default, vtable uses the @code{variable-pitch} font, and -right-aligns columns that have only numerical data (and left-aligns -the rest). +By default, vtable uses the @code{vtable} face (which inherits from +the @code{variable-pitch} face), and right-aligns columns that have +only numerical data (and left-aligns the rest). You'd normally want to name the columns: @@ -383,9 +383,27 @@ there are several tables in the same buffer, then this should be @code{nil}. @item :face -The face to be used. This defaults to @code{variable-pitch}. This -face doesn't override the faces in the data, or the faces supplied by -the getter and formatter functions. +The face to be used. This defaults to @code{vtable}. This face +doesn't override the faces in the data, or the faces supplied by the +getter and formatter functions. + +@item :row-colors +If present, this should be a list of color names to be used as the +background color on the rows. If there are fewer colors here than +there are rows, the rows will be repeated. The most common use +case here is to have alternating background colors on the rows, so +this would usually be a list of two colors. This can also be a list +of faces to be used. + +@item :column-colors +If present, this should be a list of color names to be used as the +background color on the columns. If there are fewer colors here than +there are columns, the colors will be repeated. The most common use +case here is to have alternating background colors on the columns, so +this would usually be a list of two colors. This can also be a list +of faces to be used. If both @code{:row-colors} and +@code{:column-colors} is present, the colors will be ``blended'' to +produce the final colors in the table. @item :actions This uses the same syntax as @code{define-keymap}, but doesn't refer @@ -402,6 +420,13 @@ current line, they can use the @code{vtable-current-object} function @item :separator-width The width of the blank space between columns. +@item :divider-width +@itemx :divider +You can have a divider inserted between the columns. This can either +be specified by using @code{:divider}, which should be a string to be +displayed between the columns, or @code{:divider-width}, which +specifies the width of the space to be used as the divider. + @item :sort-by This should be a list of tuples, and specifies how the table is to be sorted. Each tuple should consist of an integer (the column index) diff --git a/etc/AUTHORS b/etc/AUTHORS index 0029a4b97f2..f961852cee6 100644 --- a/etc/AUTHORS +++ b/etc/AUTHORS @@ -1574,8 +1574,8 @@ Eli Zaretskii: wrote [bidirectional display in xdisp.c] and co-wrote help-tests.el and changed xdisp.c display.texi w32.c msdos.c w32fns.c simple.el files.el fileio.c keyboard.c emacs.c w32term.c text.texi dispnew.c - w32proc.c files.texi frames.texi configure.ac lisp.h dispextern.h - process.c editfns.c and 1232 other files + w32proc.c files.texi frames.texi configure.ac dispextern.h lisp.h + process.c ms-w32.h and 1236 other files Eliza Velasquez: changed server.el @@ -2610,10 +2610,10 @@ Jimmy Yuen Ho Wong: changed nsm.el gnutls.c gnutls.el disass.el Jim Paris: changed process.c Jim Porter: changed delsel.el ansi-color-tests.el ansi-color.el - bindings.el term-tests.el term.el tramp.el callproc.c - dichromacy-theme.el diff-mode.el files-tests.el gdb-mi.el grep-tests.el - ispell.el leuven-theme.el man.el menu-bar.el misterioso-theme.el - process.c process.h progmodes/grep.el and 6 other files + bindings.el esh-var.el term-tests.el term.el tramp.el callproc.c + dichromacy-theme.el diff-mode.el em-pred.el eshell-tests.el eshell.texi + files-tests.el gdb-mi.el grep-tests.el ispell.el leuven-theme.el man.el + menu-bar.el and 10 other files Jim Radford: changed gnus-start.el @@ -2950,7 +2950,7 @@ Juri Linkov: wrote compose.el files-x.el misearch.el repeat-tests.el and changed isearch.el simple.el info.el replace.el dired.el dired-aux.el progmodes/grep.el subr.el window.el image-mode.el mouse.el diff-mode.el files.el menu-bar.el minibuffer.el progmodes/compile.el startup.el - faces.el vc.el display.texi search.texi and 444 other files + faces.el vc.el display.texi search.texi and 446 other files Jussi Lahdenniemi: changed w32fns.c ms-w32.h msdos.texi w32.c w32.h w32console.c w32heap.c w32inevt.c w32term.h @@ -3306,7 +3306,7 @@ and co-wrote gnus-kill.el gnus-mh.el gnus-msg.el gnus-score.el rfc2047.el svg.el time-date.el and changed gnus.texi simple.el subr.el files.el process.c text.texi display.texi dired.el gnutls.c gnus-ems.el smtpmail.el help-fns.el - auth-source.el url-http.el edebug.el gnus-cite.el image.el pop3.el + auth-source.el url-http.el edebug.el image.el gnus-cite.el pop3.el dired-aux.el fns.c image.c and 860 other files Lars Rasmusson: changed ebrowse.c @@ -4564,9 +4564,10 @@ and changed xdisp.c comp.c fns.c pdumper.c alloc.c byte-opt.el ccl-tests.el ccl.c ccl.el cmds.c comint.el comp-test-funcs.el comp-tests.el comp.el composite.c and 28 other files -Po Lu: changed xdisp.c browse-url.el callproc.c cc-compat.el config.bat - esh-cmd.el fileio.c langinfo.h loadup.el msdos.c msdos.h nsfns.m - nsterm.m process.c sed1v2.inp sed2v2.inp sed3v2.inp sedlibmk.inp +Po Lu: changed xdisp.c anti.texi browse-url.el callproc.c cc-compat.el + config.bat esh-cmd.el fileio.c langinfo.h loadup.el msdos.c msdos.h + nsfns.m nsterm.m process.c sed1v2.inp sed2v2.inp sed3v2.inp + sedlibmk.inp tooltip.el xterm.c Pontus Michael: changed simple.el @@ -5385,8 +5386,8 @@ and co-wrote ol-gnus.el and changed bug-reference.el reftex-vars.el tex-mode.el browse-url.el gnus.texi reftex-cite.el tsdh-dark-theme.el tsdh-light-theme.el gnus-sum.el maintaining.texi file-notify-tests.el gnus-art.el misc.texi - reftex.el org-gnus.el prog-mode.el subword.el image-mode.el json.el - lisp-mode.el rcirc.el and 99 other files + reftex.el org-gnus.el prog-mode.el subword.el dired.el image-mode.el + json.el lisp-mode.el and 99 other files Tatsuya Ichikawa: changed gnus-agent.el gnus-cache.el diff --git a/etc/DEBUG b/etc/DEBUG index dd33b42f19a..7d2f810d078 100644 --- a/etc/DEBUG +++ b/etc/DEBUG @@ -947,10 +947,10 @@ several kinds of low-level problems in C code, including: * Passing invalid values to some builtin functions, e.g., __builtin_clz (0). * Reaching __builtin_unreachable calls (in Emacs, 'eassume' failure). -To use UndefinedBehaviorSanitizer with GCC and similar compilers, -append '-fsanitize=undefined' to CFLAGS, either when running -'configure' or running 'make'. When supported, you can also specify -'bound-strict' and 'float-cast-overflow'. For example: +To use GCC's UndefinedBehaviorSanitizer, append '-fsanitize=undefined' +to CFLAGS, either when running 'configure' or running 'make'. +When supported, you can also specify 'bound-strict' and +'float-cast-overflow'. For example: ./configure \ CFLAGS='-O0 -g3 -fsanitize=undefined,bounds-strict,float-cast-overflow' @@ -958,6 +958,11 @@ append '-fsanitize=undefined' to CFLAGS, either when running You may need to append '-static-libubsan' to CFLAGS if your version of GCC is installed in an unusual location. +Clang's UB sanitizer can also be used, but has coverage problems. +You'll need '-fsanitize=undefined -fno-sanitize=pointer-overflow' to +suppress misguided warnings about adding zero to a null pointer, +although this also suppresses any valid pointer overflow warnings. + When using GDB to debug an executable with undefined-behavior sanitization, the GDB command: diff --git a/etc/HELLO b/etc/HELLO index da9b388f363..dbbcc0493bf 100644 --- a/etc/HELLO +++ b/etc/HELLO @@ -27,9 +27,11 @@ Arabic (العربيّة) السّلام عليكم Armenian (հայերեն) Բարև ձեզ Belarusian (беларуская) Прывітанне Bengali (বাংলা) নমস্কার +Brahmi (𑀩𑁆𑀭𑀸𑀳𑁆𑀫𑀻) 𑀦𑀫𑀲𑁆𑀢𑁂 + Braille ⠓⠑⠇⠇⠕ Burmese (မြန်မာ) မင်္ဂလာပါ -C printf ("Hello, world!\n"); +C printf (orange red"Hello, world!\n"); Cham (ꨌꩌ) ꨦꨤꩌ ꨦꨁꨰ Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ Comanche /kəˈmæntʃiː/ Haa marʉ́awe diff --git a/etc/HISTORY b/etc/HISTORY index 1d6425e9380..bb4e3e38e1b 100644 --- a/etc/HISTORY +++ b/etc/HISTORY @@ -224,6 +224,8 @@ GNU Emacs 27.1 (2020-08-10) emacs-27.1 GNU Emacs 27.2 (2021-03-25) emacs-27.2 +GNU Emacs 28.1 (2022-04-04) emacs-28.1 + ---------------------------------------------------------------------- This file is part of GNU Emacs. diff --git a/etc/NEWS b/etc/NEWS index 80cf0a2f725..f7dddd36de1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -29,6 +29,7 @@ applies, and please also update docstrings as needed. This uses the popular sqlite3 library, and can be disabled by using the '--without-sqlite3' option to the 'configure' script. ++++ ** Emacs has been ported to the Haiku operating system. The configuration process should automatically detect and build for Haiku. There is also an optional window-system port to Haiku, which @@ -39,50 +40,78 @@ the option '--with-be-app', the resulting Emacs will only run in text-mode terminals. +++ -*** Cairo drawing support has been enabled for Haiku builds. +** Cairo drawing support has been enabled for Haiku builds. To enable Cairo support, ensure that the Cairo and FreeType development files are present on your system, and configure Emacs with '--with-be-cairo'. --- -*** Double buffering is now enabled on the Haiku operating system. +** Double buffering is now enabled on the Haiku operating system. Unlike X, there is no compile-time option to enable or disable double-buffering. If you wish to disable double-buffering, change the frame parameter 'inhibit-double-buffering' instead. +--- ** Emacs now installs the ".pdmp" file using a unique fingerprint in the name. The file is typically installed using a file name akin to "...dir/libexec/emacs/29.1/x86_64-pc-linux-gnu/emacs-.pdmp". If a constant file name is required, the file can be renamed to "emacs.pdmp", and Emacs will find it during startup anyway. -** Emacs now supports use of XInput 2 for input events. -If your X server has support and you have the XInput 2 development headers -installed, you can configure Emacs with the option '--with-xinput2' to enable -this support. +--- +** Emacs now uses of XInput 2 for input events. +If your X server has support and you have the XInput 2 development +headers installed, Emacs will use the X Input Extension for handling +input. If this causes problems, you can configure Emacs with the +option '--without-xinput2' to disable this support. -The named feature 'xinput2' can be used to test for the presence of -XInput 2 support from Lisp programs. +(featurep 'xinput2) can be used to test for the presence of XInput 2 +support from Lisp programs. ++++ ** Emacs now supports being built with pure GTK. -To use this option, make sure the GTK 3 and Cairo development files -are installed, and configure Emacs with the option '--with-pgtk'. -Unlike the default X and GTK build, the resulting Emacs binary will -work on any underlying window system supported by GDK, such as Wayland -and Broadway. We do not recommend that you use this configuration, -unless you are running a window system that's supported by GDK other -than X. Running this configuration on X is known to have problems, -such as undesirable frame positioning and various issues with keyboard -input of sequences such as 'C-;' and 'C-S-u'. +To use this option, make sure the GTK 3 (version 3.20 or later) and +Cairo development files are installed, and configure Emacs with the +option '--with-pgtk'. Unlike the default X and GTK build, the +resulting Emacs binary will work on any underlying window system +supported by GDK, such as Wayland and Broadway. We do not recommend +that you use this configuration, unless you are running a window +system that's supported by GDK other than X. Running this +configuration on X is known to have problems, such as undesirable +frame positioning and various issues with keyboard input of sequences +such as 'C-;' and 'C-S-u'. --- ** The docstrings of preloaded files are not in "etc/DOC" any more. Instead, they're fetched as needed from the corresponding ".elc" file, as was already the case for all the non-preloaded files. +** Emacs Sessions (Desktop) + ++++ +*** New option to load a locked desktop if locking Emacs is not running. +The option 'desktop-load-locked-desktop' can now be set to the value +'check-pid', which means to allow loading a locked ".emacs.desktop" +file if the Emacs process which locked it is no longer running on the +local machine. This allows avoiding questions about locked desktop +files when the Emacs session which locked it crashes, or was otherwise +interrupted, and didn't exit gracefully. See the "(emacs) Saving +Emacs Sessions" node in the Emacs manual for more details. + * Startup Changes in Emacs 29.1 ++++ +** Emacs can now be used more easily in an executable script. +If you start an executable script with + + #!/usr/bin/emacs -x + +Emacs will start without reading any init files (like with '--quick'), +and then execute the rest of the script file as Emacs Lisp. When it +reaches the end of the script, Emacs will exit with an exit code from +the value of the final form. + +++ ** Emacs now supports setting 'user-emacs-directory' via '--init-directory'. @@ -107,6 +136,33 @@ of 'user-emacs-directory'. * Incompatible changes in Emacs 29.1 +--- +** Isearch in *Help* and *info* now char-folds quote characters by default. +This means that you can say 'C-s `foo' (GRAVE ACCENT) if the buffer +contains "‘foo" (LEFT SINGLE QUOTATION MARK) and the like. These +quotation characters look somewhat similar in some fonts. To switch +this off, disable the new 'isearch-fold-quotes-mode' minor mode. + +--- +** Sorting commands no longer necessarily change modification status. +In earlier Emacs versions, commands like 'M-x sort-lines' would always +change buffer modification status to "modified", whether they changed +something in the buffer or not. This has been changed: The buffer is +marked as modified only if the sorting ended up changing the contents +of the buffer. + +--- +** 'string-lines' handles trailing newlines differently. +It no longer returns an empty final string if the string ends with a +newline. + +--- +** 'TAB' and '' are now bound in 'button-map'. +This means that if your cursor is on a button, 'TAB' will take you to +the next button, even if the mode has bound it to something else. +This also means that 'TAB' on a button in an 'outline-minor-mode' +heading will move point instead of collapsing the outline. + --- ** 'Info-default-directory-list' is no longer populated at Emacs startup. If you have code in your init file that removes directories from @@ -117,8 +173,8 @@ If you have code in your init file that removes directories from To get the previous action back, put something like the following in your init file: - (require 'ido) - (keymap-set ido-file-completion-map "C-k" #'ido-delete-file-at-head) + (require 'ido) + (keymap-set ido-file-completion-map "C-k" #'ido-delete-file-at-head) --- ** New user option 'term-clear-full-screen-programs'. @@ -139,11 +195,22 @@ files that were compiled with an old EIEIO (Emacs<25). ** 'C-x 8 .' has been moved to 'C-x 8 . .'. This is to open up the 'C-x 8 .' map to bind further characters there. +** Eshell + --- -** 'source' and '.' in Eshell no longer accept the '--help' option. +*** 'source' and '.' no longer accept the '--help' option. This is for compatibility with the shell versions of these commands, which don't handle options like '--help' in any special way. ++++ +*** String delimiters in argument predicates/modifiers are more restricted. +Previously, some argument predicates/modifiers allowed arbitrary +characters as string delimiters. To provide more unified behavior +across all predicates/modifiers, the list of allowed delimiters has +been restricted to "...", '...', /.../, |...|, (...), [...], <...>, +and {...}. See the "(eshell) Argument Predication and Modification" +node in the Eshell manual for more details. + --- ** The 'delete-forward-char' command now deletes by grapheme clusters. This command is by default bound to the function key @@ -154,13 +221,57 @@ example, if point is before an Emoji sequence, pressing will delete the entire sequence, not just a single character at its beginning. ++++ ** 'load-history' does not treat autoloads specially any more. An autoload definition appears just as a '(defun . NAME)' and the '(t . NAME)' entries are not generated any more. +--- +** The Tamil input methods no longer insert Tamil digits. +The input methods 'tamil-itrans' and 'tamil-inscript' no longer insert +the Tamil digits, as those digit characters are not used nowadays by +speakers of the Tamil language. To get back the previous behavior, +use the new 'tamil-itrans-digits' and 'tamil-inscript-digits' input +methods instead. + ++++ +** New variable current-time-list governing default timestamp form. +Functions like current-time now yield (TICKS . HZ) timestamps if this +new variable is nil. The variable defaults to t, which means these +functions default to timestamps of the forms (HI LO US PS), (HI LO US) +or (HI LO), which are less regular and less efficient. This is part +of a long-planned change first documented in Emacs 27. Developers are +encouraged to test timestamp-related code with this variable set to +nil, as it will default to nil in a future Emacs version and will be +removed some time after that. + * Changes in Emacs 29.1 ++++ +** New command 'restart-emacs'. +This is like 'save-buffers-kill-emacs', but instead of just killing +the current Emacs process at the end, it starts a new Emacs process +(using the same command line arguments as the running Emacs process). +'kill-emacs' and 'save-buffers-kill-emacs' have also gained new +optional parameters to restart instead of just killing the current +process. + ++++ +** New user option 'mouse-drag-and-drop-region-cross-program'. +If non-nil, this option allows dragging text in the region from Emacs +to another program. + +--- +** New user option 'mouse-drag-and-drop-region-scroll-margin'. +If non-nil, this option allows scrolling a window while dragging text +around without a scroll wheel. + ++++ +** New user options 'dnd-indicate-insertion-point' and 'dnd-scroll-margin'. +These options allow adjusting point and scrolling a window when +dragging items from another program. + +++ ** New function 'command-query'. This function makes its argument command prompt the user for @@ -182,6 +293,7 @@ If set to nil, commands like 'find-library' will only include library files in the completion candidates. The default is t, which preserves previous behavior, whereby non-library files could also be included. ++++ ** New command 'sqlite-mode-open-file' for examining an sqlite3 file. This uses the new 'sqlite-mode' which allows listing the tables in a DB file, and examining and modifying the columns and the contents of @@ -256,12 +368,22 @@ defaults to t, which makes Emacs use the toolkit tooltips. The existing GTK-specific option 'x-gtk-use-system-tooltips' is now an alias of this new option. +** Connection-local variables + +++ -** Some connection-local variables are now user options. +*** Some connection-local variables are now user options. The variables 'connection-local-profile-alist' and 'connection-local-criteria-alist' are now user options, in order to make it more convenient to inspect and modify them. ++++ +*** The default connection-local application can be changed temporarily. +Running 'with-connection-local-variables' defaults to application +'tramp'. This can be changed by let-binding +'connection-local-default-application' to another symbol. This is +useful when running code in a buffer, where Tramp has already set some +connection local variables. + --- ** New minor mode 'pixel-scroll-precision-mode'. When enabled, and if your mouse supports it, you can scroll the @@ -298,6 +420,7 @@ When environment variable 'EMACS_TEST_JUNIT_REPORT' is set, ERT generates a JUnit test report under this file name. This is useful for Emacs integration into CI/CD test environments. +--- *** Unbound test symbols now signal an 'ert-test-unbound' error. This affects the 'ert-select-tests' function and its callers. @@ -331,10 +454,43 @@ inserted. This command will tell you the name of the Emoji at point. (This command also works for non-Emoji characters.) +--- *** New input method 'emoji'. +This allows you to enter emoji using short strings, eg :face_palm: or +:scream:. ** Help ++++ +*** New user option 'help-window-keep-selected'. +If non-nil, commands to show the info manual and the source will reuse +the same window the *Help* buffer is shown in. + +--- +*** Commands like 'C-h f' have changed how they describe menu bindings. +For instance, previously a command might be described as having the +following bindings: + + It is bound to , C-x C-f, . + +This has been changed to: + + It is bound to and C-x C-f. + It can also be invoked from the menu: File → Visit New File... + ++++ +*** The 'C-h .' command now accepts a prefix argument. +'C-u C-h .' would previously inhibit displaying a warning message if +there's no local help at point. This has been changed to call +'button-describe'/'widget-describe' and display button/widget help +instead. + +--- +*** New user option 'help-enable-variable-value-editing'. +If enabled, 'e' on a value in *Help* will pop you to a new buffer +where you can edit the value. This is not enabled by default, because +it's easy to make an edit that yields an invalid result. + --- *** 'C-h b' uses outlining by default. Set 'describe-bindings-outline' to nil to get the old behavior. @@ -356,8 +512,19 @@ These will take you (respectively) to the next and previous "page". This will take you to the Emacs Lisp manual entry for the item displayed, if any. +--- +*** The 'C-h m' ('describe-mode') "*Help*" buffer has been reformatted. +It now only includes local minor modes at the start, and the global +minor modes are listed after the major mode. + ++++ +*** The user option 'help-window-select' now affects apropos commands. +The apropos commands will now select the apropos window if +'help-window-select' is non-nil. + ** Outline Mode ++++ *** Support for customizing the default visibility state of headings. Customize the user option 'outline-default-state' to define what headings will be visible after Outline mode is turned on. When equal @@ -381,8 +548,9 @@ This is a list of pairs of open/close strings used to display buttons. +++ ** Support for the WebP image format. This support is built by default when the libwebp library is -available. To disable it, use the '--without-webp' configure flag. -Image specifiers can now use ':type webp'. +available. (This also includes support for animated WebP images.) To +disable WebP support, use the '--without-webp' configure flag. Image +specifiers can now use ':type webp'. ** Windows @@ -395,7 +563,9 @@ For example, a 'display-buffer-alist' entry of will make the body of the chosen window 40 columns wide. For the height use 'window-height' in combination with 'body-lines'. -*** 'other-window-scroll-default' can define the other window to scroll. +--- +*** You can customize which window 'scroll-other-window' operates on. +This is controlled by the new 'other-window-scroll-default' user option. ** Frames @@ -417,6 +587,7 @@ the corresponding deleted frame. By default, it contains 'C-c ' and 'C-c ' to browse the history of tab window configurations back and forward. +--- ** Better detection of text suspiciously reordered on display. The function 'bidi-find-overridden-directionality' has been extended to detect reordering effects produced by embeddings and isolates @@ -443,8 +614,26 @@ are met. The conditions are given by the argument, which can be +++ *** New command 'rcirc-when'. ++++ +*** New user option 'rcirc-cycle-completion-flag'. +Rcirc will use the default 'completion-at-point' mechanism. The +conventional IRC behaviour of completing by cycling through the +available options can be restored by enabling this option. + ++++ +** 'imenu' is now bound to 'M-g i' globally. + * Editing Changes in Emacs 29.1 +--- +** 'scroll-other-window' and 'scroll-other-window-down' now respects remapping. +These commands (bound to 'C-M-v' and 'C-M-V') used to scroll the other +windows without looking a customizations in that other window. These +functions now check whether they have been rebound in the buffer in +that other window, and then call the remapped function instead. In +addition, these commands now also respect the +'scroll-error-top-bottom' user option. + --- ** Indentation of 'cl-flet' and 'cl-labels' has changed. These forms now indent like this: @@ -481,6 +670,7 @@ effectively dragged. Customize this option to limit the number of entries in the menu "Edit->Paste from Kill Menu". The default is 60. ++++ ** Performing a pinch gesture on a touchpad now increases the text scale. ** show-paren-mode @@ -508,10 +698,10 @@ change the terminal used on a remote host. --- *** New user options for alternate wheel events. -The options 'mouse-wheel-down-alternate-event', 'mouse-wheel-up-alternate-event', -'mouse-wheel-left-alternate-event', and 'mouse-wheel-right-alternate-event' have -been added to better support systems where two kinds of wheel events can be -received. +The options 'mouse-wheel-down-alternate-event', +'mouse-wheel-up-alternate-event', 'mouse-wheel-left-alternate-event', +and 'mouse-wheel-right-alternate-event' have been added to better +support systems where two kinds of wheel events can be received. ** Editing complex text layout (CTL) scripts @@ -527,9 +717,66 @@ to edit such sequences by allowing point to "enter" the sequence. *** New language environment "Northern Thai". This uses the Tai Tham script, whose support has been enhanced. +*** New language environment "Brahmi". +This language environment supports Brahmi, which is a historical +script that was used in ancient South Asia. A new input method, +'brahmi', is provided to type text in this script. + * Changes in Specialized Modes and Packages in Emacs 29.1 +** Package + ++++ +*** New command 'package-update'. +This command allows you to upgrade packages without using 'M-x +list-packages'. + +** Miscellaneous + ++++ +*** New command 'scratch-buffer'. +This command switches to the *scratch* buffer. If *scratch* doesn't +exist, the command creates it first. You can use this command if you +inadvertently delete the *scratch* buffer. + +** Debugging + +*** New user option 'debug-allow-recursive-debug'. +This user option controls whether the 'e' (in a *Backtrace* +buffer or while edebugging) and 'C-x C-e' (while edebugging) commands +lead to a (further) backtrace. By default, this variable is nil, +which is a change in behaviour from previous Emacs versions. + +** Compile + ++++ +*** New user option 'compilation-max-output-line-length'. +Lines longer than this will have the ends hidden, with a button to +reveal the hidden text. This speeds up operations like grepping on +files that have few newlines. + +** Flymake + ++++ +*** New user option 'flymake-mode-line-lighter'. + ++++ +** New minor mode 'word-wrap-whitespace-mode' for extending 'word-wrap'. +This mode switches 'word-wrap' on, and breaks on all the whitespace +characters instead of just SPC and TAB. + +--- +** New mode, 'emacs-news-mode', for editing the NEWS file. +This mode adds some highlighting, fixes the 'M-q' command, and has +commands for doing maintenance. + +--- +** kmacro +Kmacros are now OClosures and have a new constructor 'kmacro' which +uses the 'key-parse' syntax. It replaces the old 'kmacro-lambda-form' +(which is now declared obsolete). + --- ** 'savehist.el' can now truncate variables that are too long. An element of 'savehist-additional-variables' can now be of the form @@ -539,25 +786,84 @@ value. ** Minibuffer and Completions ++++ +*** New commands for navigating completions from the minibuffer. +When the minibuffer is the current buffer, typing 'M-' or +'M-' selects a previous/next completion candidate from the +"*Completions*" buffer and inserts it to the minibuffer. +When the user option 'minibuffer-completion-auto-choose' is nil, +'M-' and 'M-' do the same, but without inserting +a completion candidate to the minibuffer, then 'M-RET' can be used +to choose the currently active candidate from the "*Completions*" +buffer and exit the minibuffer. With a prefix argument, 'C-u M-RET' +inserts the currently active candidate to the minibuffer, but doesn't +exit the minibuffer. + ++++ *** The "*Completions*" buffer can now be automatically selected. To enable this behavior, customize the user option -'completion-auto-select' to t. Then pressing 'TAB' will switch to the -"*Completions*" buffer when it pops up that buffer. +'completion-auto-select' to t, then pressing 'TAB' will switch to the +"*Completions*" buffer when it pops up that buffer. If the value is +'second-tab', then the first 'TAB' will display "*Completions*", and +the second one will switch to the "*Completions*" buffer. +--- *** New user option 'completion-wrap-movement'. When non-nil, the commands 'next-completion' and 'previous-completion' automatically wrap around on reaching the beginning or the end of the "*Completions*" buffer. ++++ *** New user option 'completions-sort'. This option controls the sorting of the completion candidates in the "*Completions*" buffer. Available styles are no sorting, alphabetical (the default), or a custom sort function. ++++ +*** New values for the 'completion-auto-help' user option. +There are two new values to control the way the "*Completions*" buffer +behaves after pressing a 'TAB' if completion is not unique. The value +'always' updates or shows the "*Completions*" buffer after any attempt +to complete. The value 'visual' is like 'always', but only updates +the completions if they are already visible. The default value 't' +always hides the completion buffer after some completion is made. + ++++ +*** New user option 'completions-max-height'. +This option limits the height of the "*Completions*" buffer. + ++++ +*** New user option 'completions-header-format'. +This is a string to control the heading line to show in the +"*Completions*" buffer before the list of completions. +If it contains "%s", that is replaced with the number of completions. +If nil, the heading line is not shown. + ++++ +*** New user option 'completions-highlight-face'. +When this user option names a face, the current +candidate in the "*Completions*" buffer is highlighted with that face. +The nil value disables this highlighting. + +--- +*** Choosing a completion with a prefix argument doesn't exit the minibuffer. +This means that typing 'C-u RET' on a completion candidate in the +"*Completions*" buffer inserts the completion to the minibuffer, +but doesn't exit the minibuffer. + ** Isearch and Replace +++ -*** New user option 'char-fold-override' disables default character equivalences. +*** Changes in how Isearch responds to 'mouse-yank-at-point'. +If a user does 'C-s' and then uses '' ('mouse-yank-primary') +outside the echo area, Emacs will, by default, end the Isearch and +yank the text at mouse cursor. But if 'mouse-yank-at-point' is +non-nil, the text will now be added to the Isearch instead. + ++++ +*** New user option 'char-fold-override'. +Non-nil means that the default definitions of equivalent characters +are overridden. +++ *** New command 'isearch-emoji-by-name'. @@ -566,6 +872,7 @@ command accepts the Unicode name of an Emoji (for example, "smiling face" or "heart with arrow"), like 'C-x 8 e e', with minibuffer completion, and adds the Emoji into the search string. ++++ ** New minor mode 'glyphless-display-mode'. This allows an easy way to toggle seeing all glyphless characters in the current buffer. @@ -590,6 +897,9 @@ This fills the region to be no wider than a specified pixel width. ** Info ++++ +*** 'M-x info-apropos' now takes a prefix argument to search for regexps. + --- *** New command 'Info-goto-node-web' and key binding 'G'. This will take you to the gnu.org web server's version of the current @@ -630,8 +940,52 @@ header before sending a message. *** 'texinfo-mode' now has a specialised 'narrow-to-defun' definition. It narrows to the current node. +** EUDC + ++++ +*** 'eudc-expansion-overwrites-query' to 'eudc-expansion-save-query-as-kill'. +'eudc-expansion-overwrites-query' is renamed to +'eudc-expansion-save-query-as-kill' to reflect the actual behavior of +the user option. + ++++ +*** New command 'eudc-expand-try-all'. +This command can be used in place of 'eudc-expand-inline'. It takes a +prefix argument that causes 'eudc-expand-try-all' to return matches +from all servers instead of just the matches from the first server to +return any. This is useful for example, if one wants to search LDAP +for a name that happens to match a contact in one's BBDB. + ++++ +*** New behavior and default for user option 'eudc-inline-expansion-format'. +EUDC inline expansion result formatting defaulted to + + '("%s %s <%s>" firstname name email) + +Since email address specifications need to comply with RFC 5322 in +order to be useful in messages, there was a risk to produce syntax +which was standard with RFC 822, but is marked as obsolete syntax by +its successor RFC 5322. Also, the first and last name part was never +enclosed in double quotes, potentially producing invalid address +specifications, which may be rejected by a receiving MTA. Thus, this +variable can now additionally be set to nil (the new default), or a +function. In both cases, the formatted result will be in compliance +with RFC 5322. When set to nil, a default format very similar to the +old default will be produced. When set to a function, that function +is called, and the returned values are used to populate the phrase and +comment parts (see RFC 5322 for definitions). In both cases, the +phrase part will be automatically quoted if necessary. + ** eww/shr ++++ +*** New user option to automatically rename EWW buffers. +The 'eww-auto-rename-buffer' user option can be configured to rename +rendered web pages by using their title, URL, or a user-defined +function which returns a string. For the first two cases, the length +of the resulting name is controlled by 'eww-buffer-name-length'. By +default, no automatic renaming is performed. + +++ *** New user option 'shr-allowed-images'. This complements 'shr-blocked-images', but allows specifying just the @@ -651,6 +1005,16 @@ the common "utm_" trackers from URLs. ** Gnus ++++ +*** Tool bar changes in Gnus/Message. +There were previously two styles of tool bars available in Gnus and +Message, referred to as 'gnus-summary-tool-bar-retro', +'gnus-group-tool-bar-retro' and 'message-tool-bar-retro', and +'gnus-summary-tool-bar-gnome', 'gnus-group-tool-bar-gnome' and +'message-tool-bar-gnome'. The "retro" tool bars have been removed (as +well as the icons used), and the "Gnome" tool bars are now the only +pre-defined toolbars. + --- *** Gnus now uses a variable-pitch font in the headers by default. To get the monospace font back, you can put something like the @@ -675,6 +1039,17 @@ displayed as emojis. Default nil. This is bound to 'W D e' and will display symbols that have emoji representation as emojis. ++++ +*** New mu backend for gnus-search. +Configuration is very similar to the notmuch and namazu backends. It +supports the unified search syntax. + +--- +*** gnus-html-image-cache-ttl is now a seconds count. +Formerly it was a pair of numbers (A B) that represented 65536*A + B, +to cater to older Emacs implementations that lacked bignums. +The older form still works but is undocumented. + ** EIEIO +++ @@ -689,18 +1064,14 @@ M-x align' for it to work. This has now been changed. The default regexp for 'C-u M-x align-regexp' has also been changed to be easier for inexperienced users to use. -** eww - -+++ -*** New user option to automatically rename EWW buffers. -The 'eww-auto-rename-buffer' user option can be configured to rename -rendered web pages by using their title, URL, or a user-defined -function which returns a string. For the first two cases, the length -of the resulting name is controlled by 'eww-buffer-name-length'. By -default, no automatic renaming is performed. - ** Help +--- +*** New mode, 'emacs-news-view-mode', for viewing the NEWS file. +This mode is used by the 'C-h N' command, and adds buttons to manual +entries and symbol references. + +--- *** New user option 'help-link-key-to-documentation'. When this option is non-nil (which is the default), key bindings displayed in the "*Help*" buffer will be linked to the documentation @@ -737,9 +1108,11 @@ it with new 'term-{faint,italic,slow-blink,fast-blink}' faces. ** Xref ++++ *** 'project-find-file' and 'project-or-external-find-file' now accept a prefix argument which is interpreted to mean "include all files". ++++ *** 'project-kill-buffers' can display the list of buffers to kill. Customize the user option 'project-kill-buffers-display-buffer-list' to enable the display of the buffer list. @@ -749,14 +1122,19 @@ to enable the display of the buffer list. It is bound to 'C-M-,' and jumps to the location where 'xref-go-back' ('M-,', also known as 'xref-pop-marker-stack') was invoked previously. -*** 'xref-query-replace-in-results' does not prompt for FROM when -called without prefix argument, to make the most common case faster: -replacing entire matches. ++++ +*** 'xref-query-replace-in-results' prompting change. +This command no longer prompts for FROM when called without prefix +argument. This makes the most common case faster: replacing entire +matches. ++++ *** New command 'xref-find-references-and-replace' to rename one identifier. +--- *** New variable 'xref-current-item' (renamed from a private version). +--- *** New function 'xref-show-xrefs'. ** File notifications @@ -790,6 +1168,7 @@ The keybinding for 'image-transform-fit-to-width' is now 's i'. *** User option 'image-auto-resize' can now be set to 'fit-window'. This works like 'image-transform-fit-to-window'. +--- *** New user option 'image-auto-resize-max-scale-percent'. The new 'fit-window' option will never scale an image more than this much (in percent). It is nil by default, which means no limit. @@ -821,8 +1200,8 @@ user options that are no longer needed are now obsolete: *** Navigation and marking commands now work in image display buffer. The following new bindings have been added: - n / SPC image-dired-display-next-thumbnail-original - p / DEL image-dired-display-previous-thumbnail-original + n or SPC image-dired-display-next-thumbnail-original + p or DEL image-dired-display-previous-thumbnail-original m image-dired-mark-thumb-original-file d image-dired-flag-thumb-original-file u image-dired-unmark-thumb-original-file @@ -903,6 +1282,13 @@ the thumbnail file. ** Dired ++++ +*** New user option 'dired-mouse-drag-files'. +If non-nil, dragging file names with the mouse in a Dired buffer will +initiate a drag-and-drop session allowing them to be opened in other +programs. + ++++ *** New user option 'dired-free-space'. Dired will now, by default, include the free space in the first line instead of having it on a separate line. To get the previous behavior @@ -918,6 +1304,7 @@ the buffer will take you to that directory. ** Exif +--- *** New function 'exif-field'. This is a convenience function to extract the field data from 'exif-parse-file' and 'exif-parse-buffer'. @@ -966,14 +1353,14 @@ and friends. --- *** Tramp supports abbreviating remote home directories now. -When calling 'abbreviate-file-name' on a Tramp filename, the result +When calling 'abbreviate-file-name' on a Tramp file name, the result will abbreviate the user's home directory, for example by abbreviating "/ssh:user@host:/home/user" to "/ssh:user@host:~". +++ *** New user option 'tramp-use-scp-direct-remote-copying'. When set to non-nil, Tramp does not copy files between two remote -hosts via a local copy in its temporary directory, but let the 'scp' +hosts via a local copy in its temporary directory, but lets the 'scp' command do this job. +++ @@ -997,6 +1384,7 @@ the Galeon web browser was released in September, 2008. ** Ruby Mode +--- *** New user option 'ruby-toggle-block-space-before-parameters'. ** Eshell @@ -1010,13 +1398,62 @@ support for pipelines which will move a lot of data. See section "Running Shell Pipelines Natively" in the Eshell manual, node "(eshell) Input/Output". ++++ +*** New module to help supplying absolute file names to remote commands. +After enabling the new 'eshell-elecslash' module, typing a forward +slash as the first character of a command line argument will +automatically insert the Tramp prefix. The automatic insertion +applies only when 'default-directory' is remote and the command is a +Lisp function. This frees you from having to keep track of whether +commands are Lisp function or external when supplying absolute file +name arguments. See "Electric forward slash" in the Eshell manual. + ++++ +*** Double-quoting an Eshell expansion now treats the result as a single string. +If an Eshell expansion like '$FOO' is surrounded by double quotes, the +result will always be a single string, no matter the type that would +otherwise be returned. + ++++ +*** Concatenating Eshell expansions now works more similarly to other shells. +When concatenating an Eshell expansion that returns a list, "adjacent" +elements of each operand are now concatenated together, +e.g. '$list("a" "b")c' returns '("a" "bc")'. See the "(eshell) +Expansion" node in the Eshell manual for more details. + ++++ +*** Eshell subcommands with multiline numeric output return lists of numbers. +If every line of the output of an Eshell subcommand like '${COMMAND}' +is numeric, the result will be a list of numbers (or a single number +if only one line of output). Previously, this only converted numbers +when there was a single line of output. + +--- +*** Built-in Eshell commands now follow POSIX/GNU argument syntax conventions. +Built-in commands in Eshell now accept command-line options with +values passed as a single token, such as '-oVALUE' or +'--option=VALUE'. New commands can take advantage of this with the +'eshell-eval-using-options' macro. See "Defining new built-in +commands" in the "(eshell) Built-ins" node of the Eshell manual. + +** Calc + ++++ +*** New user option 'calc-kill-line-numbering'. +This can be set to nil to exclude line numbering from kills and copies. + ** Miscellaneous ++++ +*** New user option 'font-lock-ignore'. +This option provides a mechanism to selectively disable font-lock +keyword-driven fontifications. + +++ *** New package vtable.el for formatting tabular data. This package allows formatting data using variable-pitch fonts. The resulting tables can display text in variable pitch fonts, text -using fonts of different sizes, and images. See the '(vtable)Top' +using fonts of different sizes, and images. See the "(vtable) Top" manual for more details. --- @@ -1036,9 +1473,27 @@ This library provides the 'autoarg-mode' and 'autoarg-kp-mode' minor modes to emulate the behavior of the historical editor Twenex Emacs. It is believed to no longer be useful. +--- +** proced.el shows system processes of remote hosts. +When 'default-directory' is remote, and 'proced' is invoked with a +negative argument like 'C-u - proced', the system processes of that +remote host are shown. Alternatively, the user option +'proced-show-remote-processes' can be set to non-nil. +'proced-signal-function' has been marked obsolete. + * New Modes and Packages in Emacs 29.1 ++++ +** New package 'oclosure'. +Allows the creation of "functions with slots" or "function objects" +via the macros 'oclosure-define' and 'oclosure-lambda'. + +*** New generic function 'oclosure-interactive-form'. +Used by 'interactive-form' when called on an OClosure. +This allows specific OClosure types to compute their interactive specs +on demand rather than precompute them when created. + --- ** New theme 'leuven-dark'. This is a dark version of the 'leuven' theme. @@ -1052,12 +1507,29 @@ Emacs buffers, like indentation and the like. The new ert function * Incompatible Lisp Changes in Emacs 29.1 +--- +** 'prin1' doesn't always escape "." and "?" in symbols any more. +Previously, symbols like 'foo.bar' would be printed by 'prin1' as +"foo\.bar". This now prints as "foo.bar" instead. The Emacs Lisp +reader interprets these strings as referring to the same symbol, so +this is virtually always backwards-compatible, but there may +theoretically be code out there that expects a specific printed +representation. + +The same is the case with the "?" character: The 'foo?' symbol is now +printed as "foo?" instead of "foo\?". + +If the "." and "?" characters are the first character in the symbol, +they will still be escaped, so the '.foo' symbol is still printed as +"\.foo" and the '?bar' symbol is still printed as "\?bar". + +++ ** Remapping 'mode-line' no longer works as expected. 'mode-line' is now the parent face of the new 'mode-line-active' face, and remapping parent of basic faces does not work reliably. Instead of remapping 'mode-line', you have to remap 'mode-line-active'. +--- ** User option 'mail-source-ignore-errors' is now obsolete. The whole mechanism for prompting users to continue in case of mail-source errors has been removed, so this option is no longer @@ -1074,6 +1546,7 @@ a weight of 'normal' and the font doesn't have this weight, Emacs won't find the font spec. In these cases, replacing ":weight 'normal" with ":weight 'medium" should fix the issue. +--- ** Keymap descriptions have changed. 'help--describe-command', 'C-h b' and associated functions that output keymap descriptions have changed. In particular, prefix commands are @@ -1121,7 +1594,7 @@ like: --- ** The 'inhibit-changing-match-data' variable is now obsolete. Instead, functions like 'string-match' and 'looking-at' now take an -optional 'inhibit-modify' argument. +optional INHIBIT-MODIFY argument. --- ** 'gnus-define-keys' is now obsolete. @@ -1140,11 +1613,18 @@ Use 'exif-parse-file' and 'exif-field' instead. ** 'insert-directory' alternatives should not change the free disk space line. This change is now applied in 'dired-insert-directory'. +--- ** Some functions and variables obsolete since Emacs 23 have been removed: 'find-emacs-lisp-shadows', 'newsticker-cache-filename', 'unify-8859-on-decoding-mode', 'unify-8859-on-encoding-mode', 'vc-arch-command'. ++++ +** New generic function 'function-doumentation'. +Can dynamically generate a raw docstring depending on the type of +a function. +Used mainly for docstrings of OClosures. + +++ ** Base64 encoding no longer tolerates latin-1 input. The functions 'base64-encode-string', 'base64url-encode-string', @@ -1163,6 +1643,104 @@ functions. * Lisp Changes in Emacs 29.1 +--- +*** New minor mode 'isearch-fold-quotes-mode'. +This sets up 'search-default-mode' so that quote characters are +char-folded into each other. It is used, by default, in *Help* and +*info* buffers. + ++++ +** New macro 'buffer-local-set-state'. +This is a helper macro to be used by minor modes that wish to restore +buffer-local variables back to their original states when the mode is +switched off. + +--- +** New macro 'with-buffer-unmodified-if-unchanged'. +If the buffer is marked as unmodified, and code does modifications +that, in total, means that the buffer is identical to the buffer +before, mark the buffer as unmodified again. + +--- +** New function 'malloc-trim'. +This function allows returning unused memory back to the operating +system, and is mainly meant as a debugging tool. It is currently +available only when Emacs was built with glibc as the C library. + +--- +** 'x-show-tip' no longer hard-codes a timeout default. +The new 'x-show-tooltip-timeout' variable allows the user to alter +this for packages that don't use 'tooltip-show', but instead calls the +lower level function directly. + ++++ +** New function 'window-max-characters-per-line'. + ++++ +** New function 'window-char-pixel-width'. + ++++ +** New function 'window-char-pixel-width'. + +--- +** New function 'current-cpu-time'. +It gives access to the CPU time used by the Emacs process, for +example for benchmarking purposes. + +--- +** New function 'string-edit'. +This is meant to be used when the user has to edit a (potentially) +long string. It pops you to a new buffer where you can edit the +string, and a callback is called when the user types 'C-c C-c'. + ++++ +** New function 'read-string-from-buffer'. +This is a modal version of 'string-edit', and can be used as an +alternative to 'read-string'. + ++++ +** The return value of 'clear-message-function' is not ignored anymore. +If the function returns 'dont-clear-message', then the message is not +cleared, with the assumption that the function cleared it itself. + ++++ +** The local variable section now supports defining fallback modes. +This was previously only available when using a property line (i.e., +putting the modes on the first line of a file). + ++++ +** New function 'flush-standard-output'. +This enables you do display incomplete lines from batch-based Emacs +scripts. + ++++ +** New convenience function 'buttonize-region'. +This works like 'buttonize', but for a region instead of a string. + ++++ +** 'macroexp-let2*' can omit TEST arg and use single-var bindings. + ++++ +** New macro-writing macros, 'cl-with-gensyms' and 'cl-once-only'. +See the "(cl) Macro-Writing Macros" manual section for descriptions. + ++++ +** New variable 'last-event-device' and new function 'device-class'. +On X Windows, 'last-event-device' specifies the input extension device +from which the last input event originated, and 'device-class' can be +used to determine the type of an input device. + ++++ +** 'track-mouse' can be a new value 'drag-source'. +This means the same as 'dropping', but modifies the mouse position +list in reported motion events if there is no frame underneath the +mouse pointer. + ++++ +** New function 'x-begin-drag'. +This function initiates a drag-and-drop request with the contents of +the selection 'XdndSelection', and returns when a drop occurs. + --- ** New function 'ietf-drums-parse-date-string'. This function parses RFC5322 (and RFC822) date strings, and should be @@ -1171,8 +1749,9 @@ compliant. +++ ** New macro 'setopt'. -This is like 'setq', but uses 'customize-set-variable' to set the -variable(s). +This is like 'setq', but is meant to be used for user options instead +of plain variables, and +uses 'custom-set'/'set-default' to set them. +++ ** New utility predicate 'mode-line-window-selected-p'. @@ -1235,6 +1814,13 @@ property. ** New 'min-width' 'display' property. This allows setting a minimum display width for a region of text. ++++ +** New 'cursor-face' text property. +This uses 'cursor-face' instead of the default face when cursor is on or +near the character and 'cursor-face-highlight-mode' is enabled. The +user option 'cursor-face-highlight-nonselected-window' is similar to +'highlight-nonselected-windows', but for this property. + +++ ** New event type 'touch-end'. This event is sent whenever the user's finger moves off the mouse @@ -1251,6 +1837,17 @@ them towards or away from each other. This hook is run before 'x-popup-menu' is about to display a deck-of-cards menu on screen. +** New function 'buffer-match-p'. +Check if a buffer satisfies some condition. Some examples for +conditions can be regular expressions that match a buffer name, a +cons-cell like '(major-mode . shell-mode)' that matches any buffer +where 'major-mode' is 'shell-mode' or a combined with a condition like +'(and "\\`\\*.+\\*\\'" (major-mode . special-mode))'. + +** New function 'match-buffers'. +Use 'buffer-match-p' to gather a list of buffers that match a +condition. + ** Text security and suspiciousness +++ @@ -1280,10 +1877,10 @@ option. ** Keymaps and key definitions +++ -*** New functions for defining and manipulating keystrokes have been added. -These all take just the syntax defined by 'key-valid-p'. None of the -older functions have been depreciated or altered, but are deemphasised -in the documentation. +*** New functions for defining and manipulating keystrokes. +These all take the syntax defined by 'key-valid-p'. None of the older +functions have been deprecated or altered, but they are now +de-emphasized in the documentation. +++ *** Use 'keymap-set' instead of 'define-key'. @@ -1371,6 +1968,11 @@ platforms. This command lets you examine all data in the current selection and the clipboard, and insert it into the buffer. +--- +** New function 'minibuffer-lazy-highlight-setup'. +This function allows setting up the minibuffer so that lazy +highlighting of its content is applied in the original window. + +++ ** New text property 'inhibit-isearch'. If set, 'isearch' will skip these areas, which can be useful (for @@ -1383,8 +1985,10 @@ It marks the image with the 'inhibit-isearch' text property, which inhibits 'isearch' matching the STRING parameter. --- -** New function 'replace-regexp-function'. -It can be used to implement own regexp syntax for search/replace. +** New variable 'replace-regexp-function'. +Function to call to convert the entered FROM string to an Emacs +regexp in 'query-replace' and similar commands. It can be used to +implement a different regexp syntax for search/replace. --- ** New variables to customize defaults of FROM for 'query-replace*' commands. @@ -1435,14 +2039,9 @@ dimensions. Specifying a cons as the FROM argument allows to start measuring text from a specified amount of pixels above or below a position. ---- -** 'eshell-eval-using-options' now follows POSIX/GNU argument syntax conventions. -Built-in commands in Eshell now accept command-line options with -values passed as a single token, such as '-oVALUE' or -'--option=VALUE'. - ** XDG support +--- *** New function 'xdg-state-home' returns 'XDG_STATE_HOME' environment variable. This new location, introduced in the XDG Base Directory Specification version 0.8 (8th May 2021), "contains state data that should persist @@ -1605,6 +2204,7 @@ that should be displayed, and the xwidget that asked to display it. This function is used to control where and if an xwidget stores cookies set by web pages on disk. +--- ** New variable 'help-buffer-under-preparation'. This variable is bound to t during the preparation of a "*Help*" buffer. @@ -1614,11 +2214,21 @@ For example, '(time-add nil '(1 . 1000))' no longer warns that the '(1 . 1000)' acts like '(1000 . 1000000)'. This warning, which was a temporary transition aid for Emacs 27, has served its purpose. ++++ +** 'encode-time' now also accepts a 6-element list with just time and date. +(encode-time (list SECOND MINUTE HOUR DAY MONTH YEAR)) is now short for +(encode-time (list SECOND MINUTE HOUR DAY MONTH YEAR nil -1 nil)). + +++ ** 'date-to-time' now assumes earliest values if its argument lacks month, day, or time. For example, (date-to-time "2021-12-04") now assumes a time of 00:00 instead of signaling an error. ++++ +** 'format-seconds' now allows suppressing zero-value trailing elements. +The new "%x" non-printing control character will suppress zero-value +elements that appear after "%x". + +++ ** New events for taking advantage of touchscreen devices. The events 'touchscreen-begin, 'touchscreen-update', and @@ -1637,14 +2247,69 @@ The property ':position' now specifies the position of the underline when used as part of a property list specification for the ':underline' attribute. ++++ ** 'defalias' records a more precise history of definitions. -This is recorded in the `function-history` symbol property. +This is recorded in the 'function-history' symbol property. + +--- +** 'indian-tml-base-table' no longer translates digits. +Use 'indian-tml-base-digits-table' if you want digits translation. + +--- +** 'indian-tml-itrans-v5-hash' no longer translates digits. +Use 'indian-tml-itrans-digits-v5-hash' if you want digits +translation. + ++++ +** 'shell-quote-argument' has a new optional parameter POSIX. +This is useful when quoting shell arguments for a remote shell +invocation. Such shells are POSIX conformant by default. + ++++ +** 'signal-process' now consults the list 'signal-process-functions'. +This is to determine which function has to be called in order to +deliver the signal. This allows Tramp to send the signal to remote +asynchronous processes. The hitherto existing implementation has been +moved to 'signal-default-interrupt-process'. + ++++ +** 'list-system-processes' now returns remote process IDs. +This happens only when the current buffer's 'default-directory' is +remote. In order to preserve the old behavior, apply + + (let ((default-directory temporary-file-directory)) + (list-system-processes)) + ++++ +** 'process-attributes' expects a remote process ID now. +When current buffer's 'default-directory' is remote, the PID argument +of 'process-attributes' is regarded as a remote process ID. In order +to preserve the old behavior, apply + + (let ((default-directory temporary-file-directory)) + (process-attributes pid)) + * Changes in Emacs 29.1 on Non-Free Operating Systems ** MS-Windows +--- +*** Emacs now supports double-buffering on MS-Windows to reduce display flicker. +(This was supported on Free systems since Emacs 26.1.) + +To disable double-buffering (e.g., if it causes display problems), set +the frame parameter 'inhibit-double-buffering' to a non-nil value. +You can do that either by adding + + '(inhibit-double-buffering . t) + +to 'default-frame-alist', or by modifying the frame parameters of the +selected frame by evaluating + + (modify-frame-parameters nil '((inhibit-double-buffering . t))) + +++ *** Emacs now supports system dark mode. On Windows 10 (version 1809 and higher) and Windows 11, Emacs will now @@ -1652,6 +2317,29 @@ follow the system's dark mode: GUI frames use the appropriate light or dark title bar and scroll bars, based on the user's Windows-wide color settings. +--- +*** Emacs now uses native image APIs to display some image formats. +On Windows 2000 and later, Emacs now defaults to using the native +image APIs for displaying the BMP, GIF, JPEG, PNG, and TIFF images. +This means Emacs on MS-Windows needs no longer use external image +support libraries to display those images. Other image types -- XPM, +SVG, and WEBP -- still need support libraries for Emacs to be able to +display them. + +The use of native image APIs is controlled by the variable +'w32-use-native-image-API', whose value now defaults to t on systems +where those APIs are available. + ++++ +*** Emacs now supports display of BMP images using native image APIs. +When 'w32-use-native-image-API' is non-nil, Emacs on MS-Windows now +has built-in support for displaying BMP images. + +** Cygwin + +--- +*** 'process-attributes' is now implemented. + ---------------------------------------------------------------------- This file is part of GNU Emacs. @@ -1673,5 +2361,6 @@ along with GNU Emacs. If not, see . Local variables: coding: utf-8 mode: outline +mode: emacs-news paragraph-separate: "[ ]*$" end: diff --git a/etc/NEWS.28 b/etc/NEWS.28 index 84041d79c20..995de8d3177 100644 --- a/etc/NEWS.28 +++ b/etc/NEWS.28 @@ -15,12 +15,6 @@ in older Emacs versions. You can narrow news to a specific version by calling 'view-emacs-news' with a prefix argument or by typing 'C-u C-h C-n'. -Temporary note: -+++ indicates that all relevant manuals in doc/ have been updated. ---- means no change in the manuals is needed. -When you add a new item, use the appropriate mark if you are sure it -applies, and please also update docstrings as needed. - * Installation Changes in Emacs 28.1 @@ -58,30 +52,25 @@ still be available when HarfBuzz is supported, but will not be used by default. We strongly recommend building with HarfBuzz support. 'x' is still a valid backend. ---- ** 'configure' now warns about building with libXft support. libXft is unmaintained, and causes a number of problems with modern fonts including but not limited to crashes; support for it may be removed in a future version of Emacs. Please consider using Cairo + HarfBuzz instead. ---- ** 'configure' now warns about not using HarfBuzz if using Cairo. We want to encourage people to use the most modern font features available, and this is the Cairo graphics library + HarfBuzz for font shaping, so 'configure' now recommends that combination. ---- ** Building without double buffering support. 'configure --with-xdbe=no' can now be used to disable double buffering at build time. ---- ** The configure option '--without-makeinfo' has been removed. This was only ever relevant when building from a repository checkout. This now requires makeinfo, which is part of the texinfo package. ---- ** New configure option '--disable-year2038'. This causes Emacs to use only 32-bit time_t on platforms that have both 32- and 64-bit time_t. This may help when linking Emacs with a @@ -90,16 +79,13 @@ currently affects only 32-bit ARM and x86 running GNU/Linux with glibc 2.34 and later. Emacs now defaults to 64-bit time_t on these platforms. ---- ** Support for building with '-fcheck-pointer-bounds' has been removed. GCC has withdrawn the '-fcheck-pointer-bounds' option and support for its implementation has been removed from the Linux kernel. ---- ** The ftx font backend driver has been removed. It was declared obsolete in Emacs 27.1. ---- ** Emacs no longer supports old OpenBSD systems. OpenBSD 5.3 and older releases are no longer supported, as they lack proper pty support that Emacs needs. @@ -107,13 +93,11 @@ proper pty support that Emacs needs. * Startup Changes in Emacs 28.1 ---- ** In GTK builds, Emacs now supports startup notification. This means that Emacs won't steal keyboard focus upon startup (when started via the Desktop) if the user is typing into another application. ---- ** Errors in 'kill-emacs-hook' no longer prevent Emacs from shutting down. If a function in that hook signals an error in an interactive Emacs, the user will be prompted on whether to continue. If the user doesn't @@ -136,7 +120,6 @@ lacks the terminfo database, you can instruct Emacs to support 24-bit true color by setting 'COLORTERM=truecolor' in the environment. This is useful on systems such as FreeBSD which ships only with "etc/termcap". ---- ** File names given on the command line are now be pushed onto history. The file names will be pushed onto 'file-name-history', like the names of files visited via 'C-x C-f' and other commands. @@ -144,10 +127,8 @@ of files visited via 'C-x C-f' and other commands. * Changes in Emacs 28.1 ---- ** Emacs now supports Unicode Standard version 14.0. -+++ ** Improved support for Emoji. On capable systems, Emacs now correctly displays Emoji and Emoji sequences by default, provided that a suitable font is available to @@ -171,20 +152,17 @@ the above example. (Previously, the Emoji characters were assigned to the 'symbol' script, together with other symbol and punctuation characters.) -+++ ** 'glyphless-char-display-control' now applies to Variation Selectors. VS-1 through VS-16 are now displayed as 'thin-space' by default when not composed with previous characters (typically, as part of Emoji sequences). -+++ ** New command 'execute-extended-command-for-buffer'. This new command, bound to 'M-S-x', works like 'execute-extended-command', but limits the set of commands to the commands that have been determined to be particularly useful with the current mode. -+++ ** New user option 'read-extended-command-predicate'. This user option controls how 'M-x' performs completion of commands when you type 'TAB'. By default, any command that matches what you have @@ -193,36 +171,30 @@ option to exclude commands that are not applicable to the current buffer's major and minor modes, and respect the command's completion predicate (if any). -+++ ** Completion on 'M-x' shows key bindings for commands. When 'suggest-key-bindings' is non-nil (as it is by default), the completion list popped up by 'M-x' shows the key bindings for all the commands shown in the list of candidate completions that have a key binding. -+++ ** New user option 'completions-detailed'. When non-nil, some commands like 'describe-symbol' show more detailed completions with more information in completion prefix and suffix. The default is nil. ---- ** 'C-s' in 'M-x' now once again searches over completions. In Emacs 23, typing 'M-x' ('read-extended-command') and then 'C-s' (to do an interactive search) would search over possible completions. This was lost in Emacs 24, but is now back again. -+++ ** User option 'completions-format' supports a new value 'one-column'. -+++ ** New system for displaying documentation for groups of functions. This can either be used by saying 'M-x shortdoc-display-group' and choosing a group, or clicking a button in the "*Help*" buffers when looking at the doc string of a function that belongs to one of these groups. -+++ ** New minor mode 'context-menu-mode' for context menus popped by 'mouse-3'. When this mode is enabled, clicking 'down-mouse-3' (usually, the right mouse button) anywhere in the buffer pops up a menu whose @@ -232,7 +204,6 @@ by customizing the user option 'context-menu-functions'. You can also invoke the context menu by pressing 'S-' or, on macOS, by clicking 'C-down-mouse-1'. -+++ ** A new keymap for buffer actions has been added. The 'C-x x' keymap now holds keystrokes for various buffer-oriented commands. The new keystrokes are 'C-x x g' ('revert-buffer-quick'), @@ -240,34 +211,29 @@ commands. The new keystrokes are 'C-x x g' ('revert-buffer-quick'), ('clone-buffer'), 'C-x x i' ('insert-buffer'), 'C-x x t' ('toggle-truncate-lines') and 'C-x x f' ('font-lock-update'). -+++ ** Modifiers now go outside angle brackets in pretty-printed key bindings. For example, 'RET' with Control and Meta modifiers is now shown as 'C-M-' instead of ''. Either variant can be used as input; functions such as 'kbd' and 'read-kbd-macro' accept both styles as equivalent (they have done so for a long time). ---- ** 'eval-expression' no longer signals an error on incomplete expressions. Previously, typing 'M-: ( RET' would result in Emacs saying "End of file during parsing" and dropping out of the minibuffer. The user would have to type 'M-: M-p' to edit and redo the expression. Now Emacs will echo the message and allow the user to continue editing. -+++ ** 'eval-last-sexp' now handles 'defvar'/'defcustom'/'defface' specially. This command would previously not redefine values defined by these forms, but this command has now been changed to work more like 'eval-defun', and reset the values as specified. ---- ** New user option 'use-short-answers'. When non-nil, the function 'y-or-n-p' is used instead of 'yes-or-no-p'. This eliminates the need to define an alias that maps one to another in the init file. The same user option also controls whether the function 'read-answer' accepts short answers. -+++ ** New user option 'kill-buffer-delete-auto-save-files'. If non-nil, killing a buffer that has an auto-save file will prompt the user for whether that auto-save file should be deleted. (Note @@ -277,37 +243,31 @@ unsaved changes, but this has apparently not worked for several decades, so the documented semantics of this variable has been changed to match the behavior.) -+++ ** New user option 'next-error-message-highlight'. In addition to a fringe arrow, 'next-error' error may now optionally highlight the current error message in the 'next-error' buffer. This user option can be also customized to keep highlighting on all visited errors, so you can have an overview what errors were already visited. ---- ** New choice 'next-error-quit-window' for 'next-error-found-function'. When 'next-error-found-function' is customized to 'next-error-quit-window', then typing the numeric prefix argument 0 before the command 'next-error' will quit the source window after visiting the next occurrence. -+++ ** New user option 'file-preserve-symlinks-on-save'. This controls what Emacs does when saving buffers that visit files via symbolic links, and 'file-precious-flag' is non-nil. -+++ ** New user option 'copy-directory-create-symlink'. If non-nil, will make 'copy-directory' (when used on a symbolic link) copy the link instead of following the link. The default is nil, so the default behavior is unchanged. -+++ ** New user option 'ignored-local-variable-values'. This is the opposite of 'safe-local-variable-values' -- it's an alist of variable-value pairs that are to be ignored when reading a local-variables section of a file. ---- ** Specific warnings can now be disabled from the warning buffer. When a warning is displayed to the user, the resulting buffer now has buttons which allow making permanent changes to the treatment of that @@ -315,21 +275,17 @@ warning. Automatic showing of the warning can be disabled (although it is still logged to the "*Messages*" buffer), or the warning can be disabled entirely. -+++ ** ".dir-locals.el" now supports setting 'auto-mode-alist'. The new 'auto-mode-alist' specification in ".dir-locals.el" files can now be used to override the global 'auto-mode-alist' in the current directory tree. ---- ** User option 'uniquify-buffer-name-style' can now be a function. This user option can be one of the predefined styles or a function to personalize the uniquified buffer name. ---- ** 'remove-hook' is now an interactive command. ---- ** 'expand-file-name' now checks for null bytes in filenames. The function will now check for null bytes in both NAME and DEFAULT-DIRECTORY arguments, as well as in the 'default-directory' @@ -339,22 +295,18 @@ This means that practically all file-related operations will now check file names for null bytes, thus avoiding subtle bugs with silently using only the part of file name up to the first null byte. ---- ** Frames -+++ *** The key prefix 'C-x 5 5' displays next command buffer in a new frame. It's bound to the command 'other-frame-prefix' that requests the buffer of the next command to be displayed in a new frame. -+++ *** New command 'clone-frame' (bound to 'C-x 5 c'). This is like 'C-x 5 2', but uses the window configuration and frame parameters of the current frame instead of 'default-frame-alist'. When called interactively with a prefix arg, the window configuration is not cloned. ---- *** Default values of 'frame-title-format' and 'icon-title-format' have changed. These variables are used to display the title bar of visible frames and the title bar of an iconified frame. They now show the name of @@ -365,68 +317,56 @@ your init file: (setq frame-title-format '(multiple-frames "%b" ("" invocation-name "@" system-name))) -+++ *** New frame parameter 'drag-with-tab-line'. This parameter, similar to 'drag-with-header-line', allows moving frames by dragging the tab lines of their topmost windows with the mouse. -+++ *** New optional behavior of 'delete-other-frames'. When invoked with a prefix argument, 'delete-other-frames' now iconifies frames, rather than deleting them. ---- *** Commands 'set-frame-width' and 'set-frame-height' now prompt for values. These commands now prompt for the value via the minibuffer, instead of requiring the user to specify the value via the prefix argument. ** Windows -+++ *** The key prefix 'C-x 4 1' displays next command buffer in the same window. It's bound to the command 'same-window-prefix' that requests the buffer of the next command to be displayed in the same window. -+++ *** The key prefix 'C-x 4 4' displays next command buffer in a new window. It's bound to the command 'other-window-prefix' that requests the buffer of the next command to be displayed in a new window. -+++ *** New command 'recenter-other-window', bound to 'S-M-C-l'. Like 'recenter-top-bottom', but acting on the other window. -+++ *** New user option 'delete-window-choose-selected'. This allows specifying how Emacs chooses which window will be the frame's selected window after the currently selected window is deleted. -+++ *** New argument NO-OTHER for some window functions. 'get-lru-window', 'get-mru-window' and 'get-largest-window' now accept a new optional argument NO-OTHER which, if non-nil, avoids returning a window whose 'no-other-window' parameter is non-nil. -+++ *** New 'display-buffer' function 'display-buffer-use-least-recent-window'. This is like 'display-buffer-use-some-window', but won't reuse the current window, and when called repeatedly will try not to reuse a previously selected window. -+++ *** New function 'window-bump-use-time'. This updates the use time of a window. ** Minibuffer -+++ *** Minibuffer scrolling is now conservative by default. This is controlled by the new variable 'scroll-minibuffer-conservatively'. It is t by default; setting it to nil will cause scrolling in the minibuffer obey the value of 'scroll-conservatively'. -+++ *** Improved handling of minibuffers on switching frames. By default, when you switch to another frame, an active minibuffer now moves to the newly selected frame. Nevertheless, the effect of what @@ -439,14 +379,12 @@ behavior, which mixed these two, can be approximated by customizing 'minibuffer-follows-selected-frame' to a value which is neither nil nor t. -+++ *** New user option 'read-minibuffer-restore-windows'. When customized to nil, it uses 'minibuffer-restore-windows' in 'minibuffer-exit-hook' to remove only the window showing the "*Completions*" buffer, but keeps all other windows created while the minibuffer was active. ---- *** New variable 'redisplay-adhoc-scroll-in-resize-mini-windows'. Customizing it to nil will disable the ad-hoc auto-scrolling of minibuffer text shown in mini-windows when resizing those windows. @@ -457,13 +395,11 @@ cases anyway. ** Mode Line -+++ *** New user option 'mode-line-compact'. If non-nil, repeating spaces are compressed into a single space. If 'long', this is only done when the mode line is longer than the current window width (in columns). -+++ *** New user options to control format of line/column numbers in the mode line. 'mode-line-position-line-format' is the line number format (when 'line-number-mode' is on), 'mode-line-position-column-format' is @@ -473,16 +409,13 @@ both modes are on). ** Tab Bars and Tab Lines -+++ *** The prefix key 'C-x t t' can be used to display a buffer in a new tab. Typing 'C-x t t' before a command will cause the buffer shown by that command to be displayed in a new tab. 'C-x t t' is bound to the command 'other-tab-prefix'. -+++ *** New command 'C-x t C-r' to open file read-only in the other tab. -+++ *** The tab bar now supports more mouse commands. Clicking 'mouse-2' closes the tab, 'mouse-3' displays the context menu with items that operate on the clicked tab. Dragging the tab with @@ -490,20 +423,17 @@ with items that operate on the clicked tab. Dragging the tab with scrolling switches to the previous/next tab, and holding the Shift key during scrolling moves the tab to the left/right. -+++ *** Frame-specific appearance of the tab bar when 'tab-bar-show' is a number. When 'tab-bar-show' is a number, the tab bar on different frames can be shown or hidden independently, as determined by the number of tabs on each frame compared to the numerical value of 'tab-bar-show'. -+++ *** New command 'toggle-frame-tab-bar'. It can be used to enable/disable the tab bar on the currently selected frame regardless of the values of 'tab-bar-mode' and 'tab-bar-show'. This allows enabling/disabling the tab bar independently on different frames. -+++ *** New user option 'tab-bar-format' defines a list of tab bar items. When it contains 'tab-bar-format-global' (possibly appended after 'tab-bar-format-align-right'), then after enabling 'display-time-mode' @@ -512,7 +442,6 @@ aligned to the right on the tab bar instead of on the mode line. When 'tab-bar-format-tabs' is replaced with 'tab-bar-format-tabs-groups', the tab bar displays tab groups. -+++ *** New optional key binding for 'tab-last'. If you customize the user option 'tab-bar-select-tab-modifiers' to allow selecting tabs using their index numbers, the '-9' key @@ -522,20 +451,16 @@ is any of the modifiers in the list that is the value of which count from the last tab: 1 is the last tab, 2 the one before that, etc. ---- *** New command 'tab-duplicate' bound to 'C-x t n'. ---- *** 'C-x t N' creates a new tab at the specified absolute position. The position is provided as prefix arg, and specifies an index that starts at 1. Negative values count from the end of the tab bar. ---- *** 'C-x t M' moves the current tab to the specified absolute position. The position is provided as prefix arg, whose interpretation is as in 'C-x t N'. ---- *** 'C-x t G' assigns a tab to a named group of tabs. 'tab-close-group' closes all tabs that belong to the selected group. The user option 'tab-bar-new-tab-group' defines the default group of @@ -543,18 +468,14 @@ new tabs. After customizing 'tab-bar-tab-post-change-group-functions' to 'tab-bar-move-tab-to-group', changing the group of a tab will also move it closer to other tabs in the same group. ---- *** New user option 'tab-bar-tab-name-format-function'. ---- *** New user option 'tab-line-tab-name-format-function'. ---- *** The tabs in the tab line can now be scrolled using horizontal scroll. If your mouse or trackpad supports it, you can now scroll tabs when the mouse pointer is in the tab line by scrolling left or right. ---- *** New tab-line faces and user options. The face 'tab-line-tab-special' is used for tabs whose buffers are special, i.e. buffers that don't visit a file. The face @@ -569,17 +490,14 @@ in other ways. ** Mouse wheel ---- *** Mouse wheel scrolling now defaults to one line at a time. ---- *** Mouse wheel scrolling now works on more parts of frame's display. When using 'mouse-wheel-mode', the mouse wheel will now scroll also when the mouse cursor is on the scroll bars, fringes, margins, header line, and mode line. ('mouse-wheel-mode' is enabled by default on most graphical displays.) -+++ *** Mouse wheel scrolling with Shift modifier now scrolls horizontally. This works in text buffers and over images. Typing a numeric prefix arg (e.g. 'M-5') before starting horizontal scrolling changes its step value. @@ -587,10 +505,8 @@ The value is saved in the user option 'mouse-wheel-scroll-amount-horizontal'. ** Customize ---- *** Customize buffers can now be reverted with 'C-x x g'. ---- *** Most customize commands now hide obsolete user options. Obsolete user options are no longer shown in the listings produced by the commands 'customize', 'customize-group', 'customize-apropos' and @@ -599,35 +515,28 @@ the commands 'customize', 'customize-group', 'customize-apropos' and To customize obsolete user options, use 'customize-option' or 'customize-saved'. ---- *** New SVG icons for checkboxes and arrows. They will be used automatically instead of the old icons. If Emacs is built without SVG support, the old icons will be used instead. ** Help ---- *** The order of things displayed in the "*Help*" buffer has been changed. The indented "administrative" block (containing the "probably introduced" and "other relevant functions" (and similar things) has been moved to after the doc string. -+++ *** New command 'describe-command' shows help for a command. This can be used instead of 'describe-function' for interactive commands and is globally bound to 'C-h x'. -+++ *** New command 'describe-keymap' describes keybindings in a keymap. ---- *** New command 'apropos-function'. This works like 'C-u M-x apropos-command' but is more discoverable. ---- *** New keybinding 'C-h R' prompts for an Info manual and displays it. ---- *** Keybindings in 'help-mode' use the new 'help-key-binding' face. This face is added by 'substitute-command-keys' to any "\[command]" substitution. The return value of that function should consequently @@ -638,17 +547,14 @@ with the new optional argument NO-FACE non-nil. Note that the new face will also be used in tooltips. When using the GTK toolkit, this is only true if 'x-gtk-use-system-tooltips' is t. -+++ *** New user option 'help-enable-symbol-autoload'. If non-nil, displaying help for an autoloaded function whose 'autoload' form provides no documentation string will try to load the file it's from. This will give more extensive help for such functions. ---- *** The 'help-for-help' ('C-h C-h') screen has been redesigned. -+++ *** New convenience commands with short keys in the "*Help*" buffer. New command 'help-view-source' ('s') will view the source file (if any) of the current help topic. New command 'help-goto-info' ('i') @@ -656,79 +562,65 @@ will look up the current symbol (if any) in Info. New command 'help-customize' ('c') will customize the user option or the face (if any) whose doc string is being shown in the "*Help*" buffer. ---- *** New user option 'describe-bindings-outline'. It enables outlines in the output buffer of 'describe-bindings' that can provide a better overview in a long list of available bindings. -+++ *** New commands to describe buttons and widgets. 'widget-describe' (on a widget) will pop up the "*Help*" buffer and give a description of the properties. Likewise 'button-describe' does the same for a button. ---- *** Improved "find definition" feature of "*Help*" buffers. Now clicking on the link to find the definition of functions generated by 'cl-defstruct', or variables generated by 'define-derived-mode', for example, will go to the exact place where they are defined. ---- *** New commands 'apropos-next-symbol' and 'apropos-previous-symbol'. These new navigation commands are bound to 'n' and 'p' in 'apropos-mode'. ---- *** The command 'view-lossage' can now be invoked from the menu bar. The menu bar "Help" menu now has a "Show Recent Inputs" item under the "Describe" sub-menu. -+++ *** New command 'lossage-size'. It allows users to change the maximum number of keystrokes and commands recorded for the purpose of 'view-lossage'. ---- *** Closing the "*Help*" buffer from the toolbar now buries the buffer. In previous Emacs versions, the "*Help*" buffer was killed instead when clicking the "X" icon in the tool bar. ---- *** 'g' ('revert-buffer') in 'help-mode' no longer requires confirmation. ** File Locks -+++ *** New user option 'lock-file-name-transforms'. This option allows controlling where lock files are written. It uses the same syntax as 'auto-save-file-name-transforms'. -+++ *** New user option 'remote-file-name-inhibit-locks'. When non-nil, this option suppresses lock files for remote files. Default is nil. -+++ *** New minor mode 'lock-file-mode'. This command, called interactively, toggles the local value of 'create-lockfiles' in the current buffer. ** Emacs Server -+++ *** New user option 'server-client-instructions'. When emacsclient connects, Emacs will (by default) output a message about how to exit the client frame. If 'server-client-instructions' is set to nil, this message is inhibited. -+++ *** New command 'server-edit-abort'. This command (not bound to any key by default) can be used to abort an edit instead of marking it as "Done" (which the 'C-x #' command does). The 'emacsclient' program exits with an abnormal status as result of this command. -+++ *** New desktop integration for connecting to the server. If your operating system's desktop environment is freedesktop.org-compatible (which is true of most GNU/Linux and other @@ -739,25 +631,20 @@ running. ** Miscellaneous -+++ *** New command 'font-lock-update', bound to 'C-x x f'. This command updates the syntax highlighting in this buffer. -+++ *** New command 'memory-report'. This command opens a new buffer called "*Memory Report*" and gives a summary of where Emacs is using memory currently. -+++ *** New command 'submit-emacs-patch'. This works like 'report-emacs-bug', but is more geared towards sending patches to the Emacs issue tracker. ---- *** New face 'apropos-button'. Applies to buttons that indicate a face. -+++ *** New face 'font-lock-doc-markup-face'. Intended for documentation mark-up syntax and tags inside text that uses 'font-lock-doc-face', which it should appropriately stand out @@ -766,41 +653,34 @@ documentation comments in program source code by language-specific modes, for mark-up conventions like Haddock, Javadoc or Doxygen. By default this face inherits from 'font-lock-constant-face'. -+++ *** New face box style 'flat-button'. This is a plain 2D button, but uses the background color instead of the foreground color. ---- *** New faces 'shortdoc-heading' and 'shortdoc-section'. Applied to shortdoc headings and sections. ---- *** New face 'separator-line'. This is used by 'make-separator-line' (see below). -+++ *** 'redisplay-skip-fontification-on-input' helps Emacs keep up with fast input. This is another attempt to solve the problem of handling high key repeat rate and other "slow scrolling" situations. It is hoped it behaves better than 'fast-but-imprecise-scrolling' and 'jit-lock-defer-time'. It is not enabled by default. ---- *** Obsolete aliases are no longer hidden from command completion. Completion of command names now considers obsolete aliases as candidates, if they were marked obsolete in the current major version of Emacs. Invoking a command via an obsolete alias now mentions the obsolescence fact and shows the new name of the command. -+++ *** Support for '(box . SIZE)' 'cursor-type'. By default, 'box' cursor always has a filled box shape. But if you specify 'cursor-type' to be '(box . SIZE)', the cursor becomes a hollow box if the point is on an image larger than SIZE pixels in any dimension. -+++ *** The user can now customize how "default" values are prompted for. The new utility function 'format-prompt' has been added which uses the new 'minibuffer-default-prompt-format' user option to format "default" @@ -810,7 +690,6 @@ number [10]", or not have the default displayed at all, like "Enter a number". (This only affects callers that were altered to use 'format-prompt'.) ---- *** New help window when Emacs prompts before opening a large file. Commands like 'find-file' or 'visit-tags-table' ask to visit a file normally or literally when the file is larger than a certain size (by @@ -818,20 +697,17 @@ default, 9.5 MiB). Press '?' or 'C-h' in that prompt to read more about the different options to visit a file, how you can disable the prompt, and how you can tweak the file size threshold. -+++ *** Emacs now defaults to UTF-8 instead of ISO-8859-1. This is only for the default, where the user has set no 'LANG' (or similar) variable or environment. This change should lead to no user-visible changes for normal usage. ---- *** 'global-display-fill-column-indicator-mode' skips some buffers. By default, turning on 'global-display-fill-column-indicator-mode' doesn't turn on 'display-fill-column-indicator-mode' in special-mode buffers. This can be controlled by customizing the user option 'global-display-fill-column-indicator-modes'. -+++ *** 'nobreak-char-display' now also affects all non-ASCII space characters. Previously, this was limited only to 'NO-BREAK SPACE' and hyphen characters. Now it also covers the rest of the non-ASCII Unicode @@ -840,7 +716,6 @@ non-ASCII characters are displayed as themselves when 'nobreak-char-display' is t, i.e. they are not replaced on display with the ASCII space and hyphen characters. ---- *** New backward compatibility variable 'nobreak-char-ascii-display'. This variable is nil by default, and non-ASCII space and hyphen characters are displayed as themselves, even if 'nobreak-char-display' @@ -854,7 +729,6 @@ t. You may need this on text-mode terminals that produce messed up display when non-ASCII spaces and hyphens are written to the display. (This variable is only effective when 'nobreak-char-display' is t.) -+++ *** Improved support for terminal emulators that encode the Meta flag. Some terminal emulators set the 8th bit of Meta characters, and then encode the resulting character code as if it were non-ASCII character @@ -865,7 +739,6 @@ Meta characters to Emacs, e.g., send "ESC x" when the user types emulators by using the new input-meta-mode with the special value 'encoded' with these terminal emulators. ---- *** 'auto-composition-mode' can now be selectively disabled on some TTYs. Some text-mode terminals produce display glitches trying to compose characters. The 'auto-composition-mode' can now have a string value @@ -874,14 +747,12 @@ function compares equal with that string, automatic composition will be disabled in windows shown on that terminal. The Linux terminal sets this up by default. ---- *** Support for the 'strike-through' face attribute on TTY frames. If your terminal's termcap or terminfo database entry has the 'smxx' capability defined, Emacs will now emit the prescribed escape sequences necessary to render faces with the 'strike-through' attribute on TTY frames. ---- *** TTY menu navigation is now supported in 'xterm-mouse-mode'. TTY menus support mouse navigation and selection when 'xterm-mouse-mode' is active. When run on a terminal, clicking on the menu bar with the @@ -889,19 +760,15 @@ mouse now pops up a TTY menu by default instead of running the command 'tmm-menubar'. To restore the old behavior, set the user option 'tty-menu-open-use-tmm' to non-nil. ---- *** 'M-x report-emacs-bug' will no longer include "Recent messages" section. These were taken from the "*Messages*" buffer, and may inadvertently leak information from the reporting user. ---- *** 'C-u M-x dig' will now prompt for a query type to use. ---- *** Rudimentary support for the 'st' terminal emulator. Emacs now supports 256 color display on the 'st' terminal emulator. -+++ *** Update IRC-related references to point to Libera.Chat. The Free Software Foundation and the GNU Project have moved their official IRC channels from the Freenode network to Libera.Chat. For the @@ -921,12 +788,10 @@ https://lists.gnu.org/archive/html/info-gnu-emacs/2021-06/msg00000.html * Incompatible Editing Changes in Emacs 28.1 ---- ** 'toggle-truncate-lines' now disables 'visual-line-mode'. This is for symmetry with 'visual-line-mode', which disables 'truncate-lines'. ---- ** 'electric-indent-mode' now also indents inside strings and comments. (This only happens when indentation function also supports this.) @@ -935,7 +800,6 @@ To recover the previous behavior you can use: (add-hook 'electric-indent-functions (lambda (_) (if (nth 8 (syntax-ppss)) 'no-indent))) ---- ** The 'M-o' ('facemenu-keymap') global binding has been removed. To restore the old binding, say something like: @@ -947,7 +811,6 @@ To restore the old binding, say something like: The last two lines are not strictly necessary if you don't care about having those two commands on the 'M-o' keymap; see the next section. ---- ** The 'M-o M-s' and 'M-o M-S' global bindings have been removed. Use 'M-x center-line' and 'M-x center-paragraph' instead. See the previous section for how to get back the old bindings. Alternatively, @@ -957,12 +820,10 @@ had before, you can add the following to your init file: (define-key global-map "\M-o\M-s" 'center-line) (define-key global-map "\M-o\M-S" 'center-paragraph) ---- ** The 'M-o M-o' global binding has been removed. Use 'M-x font-lock-fontify-block' instead, or the new 'C-x x f' command, which updates the syntax highlighting in the current buffer. ---- ** The escape sequence '\e[29~' in Xterm is now mapped to 'menu'. Xterm sends this sequence for both 'F16' and 'Menu' keys It used to be mapped to 'print' but we couldn't find a terminal @@ -970,26 +831,21 @@ that uses this sequence for any kind of 'Print' key. This makes the Menu key (see https://en.wikipedia.org/wiki/Menu_key) work for 'context-menu-mode' in Xterm. ---- ** New user option 'xterm-store-paste-on-kill-ring'. If non-nil (the default), Emacs pushes pasted text onto the kill ring (if using an xterm-like terminal that supports bracketed paste). Setting this to nil inhibits that. ---- ** 'vc-print-branch-log' shows the change log from its root directory. It previously used to use the default directory. ---- ** 'project-shell' and 'shell' now use 'pop-to-buffer-same-window'. This is to keep the same behavior as Eshell. ---- ** In 'nroff-mode', 'center-line' is no longer bound to a key. The original key binding was 'M-s', which interfered with Isearch, since the latter uses 'M-s' as a prefix key of the search prefix map. ---- ** In 'f90-mode', the backslash character ('\') no longer escapes. For about a decade, the backslash character has no longer had a special escape syntax in Fortran F90. To get the old behavior back, @@ -997,7 +853,6 @@ say something like: (modify-syntax-entry ?\\ "\\" f90-mode-syntax-table) -+++ ** Setting 'fill-column' to nil is obsolete. This undocumented use of 'fill-column' is now obsolete. To disable auto filling, turn off 'auto-fill-mode' instead. @@ -1012,7 +867,6 @@ file: ** Input methods -+++ *** Emacs now supports "transient" input methods. A transient input method is enabled for inserting a single character, and is then automatically disabled. 'C-x \' temporarily enables the @@ -1024,33 +878,27 @@ character '½', and disable the 'compose' input method afterwards. You can use 'C-x \' in incremental search to insert a single character to the search string. ---- *** New input method 'compose' based on X Multi_key sequences. ---- *** New input method 'iso-transl' with the same keys as 'C-x 8'. After selecting it as a transient input method with 'C-u C-x \ iso-transl RET', it supports the same key sequences as 'C-x 8', so e.g. like 'C-x 8 [' inserts a left single quotation mark, 'C-x \ [' does the same. ---- *** New user option 'read-char-by-name-sort'. It defines the sorting order of characters for completion of 'C-x 8 RET TAB' and can be customized to sort them by codepoints instead of character names. Additionally, you can group characters by Unicode blocks after customizing 'completions-group' and 'completions-group-sort'. ---- *** Improved language transliteration in Malayalam input methods. Added a new Mozhi scheme. The inapplicable ITRANS scheme is now deprecated. Errors in the Inscript method were corrected. ---- *** New input method 'cham'. There's also a Cham greeting in "etc/HELLO". ---- *** New input methods for Lakota language orthographies. Two orthographies are represented here, the Suggested Lakota Orthography and what is known as the White Hat Orthography. Input @@ -1058,7 +906,6 @@ methods 'lakota-slo-prefix', 'lakota-slo-postfix', and 'lakota-white-hat-postfix' have been added. There is also a Lakota greeting in "etc/HELLO". -+++ ** Standalone 'M-y' allows interactive selection from previous kills. 'M-y' can now be typed after a command that is not a yank command. When invoked like that, it prompts in the minibuffer for one of the @@ -1068,14 +915,12 @@ in Isearch can be invoked if you bind 'C-s M-y' to the command 'isearch-yank-pop'. When the user option 'yank-from-kill-ring-rotate' is nil the kill ring is not rotated after 'yank-from-kill-ring'. -+++ ** New user option 'word-wrap-by-category'. When word-wrap is enabled, and this option is non-nil, that allows Emacs to break lines after more characters than just whitespace characters. In particular, this significantly improves word-wrapping for CJK text mixed with Latin text. -+++ ** New command 'undo-redo'. It undoes previous undo commands, but doesn't record itself as an undoable command. It is bound to 'C-?' and 'C-M-_', the first binding @@ -1084,43 +929,35 @@ works well in graphical mode, and the second one is easy to hit on tty. For full conventional undo/redo behavior, you can also customize the user option 'undo-no-redo' to t. -+++ ** New commands 'copy-matching-lines' and 'kill-matching-lines'. These commands are similar to the command 'flush-lines', but add the matching lines to the kill ring as a single string, including the newlines that separate the lines. -+++ ** New user option 'kill-transform-function'. This can be used to transform (and suppress) strings from entering the kill ring. -+++ ** 'save-interprogram-paste-before-kill' can now be a number. In that case, it's interpreted as a limit on the size of the clipboard data that will be saved to the 'kill-ring' prior to killing text: if the size of the clipboard data is greater than or equal to the limit, it will not be saved. -+++ ** New user option 'tab-first-completion'. If 'tab-always-indent' is 'complete', this new user option can be used to further tweak whether to complete or indent. ---- ** 'indent-tabs-mode' is now a global minor mode instead of just a variable. -+++ ** New choice 'permanent' for 'shift-select-mode'. When the mark was activated by shifted motion keys, non-shifted motion keys don't deactivate the mark after customizing 'shift-select-mode' to 'permanent'. Similarly, the active mark will not be deactivated by typing shifted motion keys. -+++ ** The "Edit => Clear" menu item now obeys a rectangular region. -+++ ** New command 'revert-buffer-with-fine-grain'. Revert a buffer trying to be as non-destructive as possible, preserving markers, properties and overlays. The new variable @@ -1128,18 +965,15 @@ preserving markers, properties and overlays. The new variable number of seconds that 'revert-buffer-with-fine-grain' should spend trying to be non-destructive, with a default value of 2 seconds. -+++ ** New command 'revert-buffer-quick'. This is bound to 'C-x x g' and is like 'revert-buffer', but prompts less. -+++ ** New user option 'revert-buffer-quick-short-answers'. This controls how the new 'revert-buffer-quick' ('C-x x g') command prompts. A non-nil value will make it use 'y-or-n-p' rather than 'yes-or-no-p'. Defaults to nil. -+++ ** New user option 'query-about-changed-file'. If non-nil (the default), Emacs prompts as before when re-visiting a file that has changed externally after it was visited the first time. @@ -1147,30 +981,25 @@ If nil, Emacs does not prompt, but instead shows the buffer with its contents before the change, and provides instructions how to revert the buffer. ---- ** New value 'save-some-buffers-root' of 'save-some-buffers-default-predicate'. When using this predicate, only buffers under the current project root will be considered when saving buffers with 'save-some-buffers'. ---- ** New user option 'save-place-abbreviate-file-names'. This can simplify sharing the 'save-place-file' file across different hosts. ---- ** New user options 'copy-region-blink-delay' and 'delete-pair-blink-delay'. 'copy-region-blink-delay' specifies a delay to indicate the region copied by 'kill-ring-save'. 'delete-pair-blink-delay' specifies a delay to show the paired character to delete. ---- ** 'zap-up-to-char' now uses 'read-char-from-minibuffer'. This allows navigating through the history of characters that have been input. This is mostly useful for characters that have complex input methods where inputting the character again may involve many keystrokes. -+++ ** Input history for 'goto-line' can now be made local to every buffer. In any event, line numbers used with 'goto-line' are kept in their own history list. This should help make faster the process of finding @@ -1178,7 +1007,6 @@ line numbers that were previously jumped to. By default, all buffers share a single history list. To make every buffer have its own history list, customize the user option 'goto-line-history-local'. -+++ ** New command 'goto-line-relative' for use in a narrowed buffer. It moves point to the line relative to the accessible portion of the narrowed buffer. 'M-g M-g' in Info is rebound to this command. @@ -1186,7 +1014,6 @@ When 'widen-automatically' is non-nil, 'goto-line' widens the narrowed buffer to be able to move point to the inaccessible portion. 'goto-line-relative' is bound to 'C-x n g'. -+++ ** 'goto-char' prompts for the character position. When called interactively, 'goto-char' now offers the position at point as the default. @@ -1195,11 +1022,9 @@ point as the default. Set the user option 'auto-save-visited-mode' buffer-locally to nil to achieve that. -+++ ** New command 'kdb-macro-redisplay' to force redisplay in keyboard macros. This command is bound to 'C-x C-k d'. ---- ** 'blink-cursor-mode' is now enabled by default regardless of the UI. It used to be enabled when Emacs is started in GUI mode but not when started in text mode. The cursor still only actually blinks in GUI frames. @@ -1208,7 +1033,6 @@ in text mode. The cursor still only actually blinks in GUI frames. To go back to the previous behavior, customize the user option of the same name to nil. -+++ ** New minor mode 'show-paren-local-mode'. It serves as a local counterpart for 'show-paren-mode', allowing you to toggle it separately in different buffers. To use it only in @@ -1221,7 +1045,6 @@ programming modes, for example, add the following to your init file: ** Isearch and Replace -+++ *** Interactive regular expression search now uses faces for sub-groups. E.g., 'C-M-s foo-\([0-9]+\)' will now use the 'isearch-group-1' face on the part of the regexp that matches the sub-expression "[0-9]+". @@ -1233,12 +1056,10 @@ This is controlled by the 'search-highlight-submatches' user option. This feature is available only on terminals that have enough colors to distinguish between sub-expression highlighting. -+++ *** Interactive regular expression replace now uses faces for sub-groups. Like 'search-highlight-submatches', this is controlled by the new user option 'query-replace-highlight-submatches'. -+++ *** New key 'M-s M-.' starts isearch looking for the thing at point. This key is bound to the new command 'isearch-forward-thing-at-point'. The new user option 'isearch-forward-thing-at-point' defines @@ -1246,20 +1067,17 @@ a list of symbols to try to get the "thing" at point. By default, the first element of the list is 'region' that tries to yank the currently active region to the search string. -+++ *** New user option 'isearch-wrap-pause' defines how to wrap the search. There are choices to disable wrapping completely and to wrap immediately. When wrapping immediately, it consistently handles the numeric arguments of 'C-s' ('isearch-repeat-forward') and 'C-r' ('isearch-repeat-backward'), continuing with the remaining count after wrapping. -+++ *** New user option 'isearch-repeat-on-direction-change'. When this option is set, direction changes in Isearch move to another search match, if there is one, instead of moving point to the other end of the current match. -+++ *** New user option 'isearch-allow-motion'. When 'isearch-allow-motion' is set, the commands 'beginning-of-buffer', 'end-of-buffer', 'scroll-up-command' and 'scroll-down-command', when @@ -1271,14 +1089,12 @@ during Isearch by using their 'isearch-motion' property. The user option 'isearch-motion-changes-direction' controls whether the direction of the search changes after a motion command. -+++ *** New user option 'lazy-highlight-no-delay-length'. Lazy highlighting of matches in Isearch now starts immediately if the search string is at least this long. 'lazy-highlight-initial-delay' still applies for shorter search strings, which avoids flicker in the search buffer due to too many matches being highlighted. -+++ *** The default 'search-whitespace-regexp' value has changed. This used to be "\\s-+", which meant that it was mode-dependent whether newlines were included in the whitespace set. This has now been @@ -1286,52 +1102,43 @@ changed to only match spaces and tab characters. ** Dired -+++ *** New user option 'dired-kill-when-opening-new-dired-buffer'. If non-nil, Dired will kill the current buffer when selecting a new directory to display. -+++ *** Behavior change on 'dired-do-chmod'. As a security precaution, Dired's 'M' command no longer follows symbolic links. Instead, it changes the symbolic link's own mode; this always fails on platforms where such modes are immutable. ---- *** Behavior change on 'dired-clean-confirm-killing-deleted-buffers'. Previously, if 'dired-clean-up-buffers-too' was non-nil, and 'dired-clean-confirm-killing-deleted-buffers' was nil, the buffers wouldn't be killed. This combination will now kill the buffers. -+++ *** New user option 'dired-switches-in-mode-line'. This user option controls how 'ls' switches are displayed in the mode line, and allows truncating them (to preserve space on the mode line) or showing them literally, either instead of, or in addition to, displaying "by name" or "by date" sort order. -+++ *** New user option 'dired-compress-directory-default-suffix'. This user option controls the default suffix for compressing a directory. If it's nil, ".tar.gz" will be used. Refer to 'dired-compress-files-alist' for a list of supported suffixes. -+++ *** New user option 'dired-compress-file-default-suffix'. This user option controls the default suffix for compressing files. If it's nil, ".gz" will be used. Refer to 'dired-compress-file-alist' for a list of supported suffixes. ---- *** Broken and circular links are shown with the 'dired-broken-symlink' face. ---- *** '=' ('dired-diff') will now put all backup files into the 'M-n' history. When using '=' on a file with backup files, the default file to use for diffing is the newest backup file. You can now use 'M-n' to quickly select a different backup file instead. -+++ *** New user option 'dired-maybe-use-globstar'. If set, enables globstar (recursive globbing) in shells that support this feature, but have it turned off by default. This allows producing @@ -1340,19 +1147,16 @@ subdirectories of a given directory. The new variable 'dired-enable-globstar-in-shell' lists which shells can have globstar enabled, and how to enable it. -+++ *** New user option 'dired-copy-dereference'. If set to non-nil, Dired will dereference symbolic links when copying. This can be switched off on a per-usage basis by providing 'dired-do-copy' with a 'C-u' prefix. ---- *** New user option 'dired-do-revert-buffer'. Non-nil reverts the destination Dired buffer after performing one of these operations: 'dired-do-copy', 'dired-do-rename', 'dired-do-symlink', 'dired-do-hardlink'. ---- *** New user option 'dired-mark-region'. This option affects all Dired commands that mark files. When non-nil and the region is active in Transient Mark mode, then Dired commands @@ -1360,12 +1164,10 @@ operate only on files in the active region. The values 'file' and 'line' of this user option define the details of marking the file at the end of the region. -+++ *** State changing VC operations are supported in Dired. These operations are supported on files and directories via the new command 'dired-vc-next-action'. -+++ *** 'dired-jump' and 'dired-jump-other-window' moved from 'dired-x' to 'dired'. The 'dired-jump' and 'dired-jump-other-window' commands have been moved from the 'dired-x' package to 'dired'. The user option @@ -1378,25 +1180,21 @@ keys, add the following to your init file: (global-set-key "\C-x\C-j" nil) (global-set-key "\C-x4\C-j" nil) ---- *** 'dired-query' now uses 'read-char-from-minibuffer'. Using it instead of 'read-char-choice' allows using 'C-x o' to switch to the help window displayed after typing 'C-h'. -+++ ** Emacs 28.1 comes with Org v9.5. See the file ORG-NEWS for user-visible changes in Org. ** Outline -+++ *** New commands to cycle heading visibility. Typing 'TAB' on a heading line cycles the current section between "hide all", "subheadings", and "show all" states. Typing 'S-TAB' anywhere in the buffer cycles the whole buffer between "only top-level headings", "all headings and subheadings", and "show all" states. -+++ *** New user option 'outline-minor-mode-cycle'. This user option customizes 'outline-minor-mode', with the difference that 'TAB' and 'S-TAB' on heading lines cycle heading visibility. @@ -1405,7 +1203,6 @@ Typing 'TAB' on a heading line cycles the current section between heading line cycles the whole buffer between "only top-level headings", "all headings and subheadings", and "show all" states. ---- *** New user option 'outline-minor-mode-highlight'. This user option customizes 'outline-minor-mode'. It puts highlighting on heading lines using standard outline faces. This @@ -1414,27 +1211,22 @@ major mode. ** Ispell -+++ *** 'ispell-comments-and-strings' now accepts START and END arguments. These arguments default to the active region when used interactively. -+++ *** New command 'ispell-comment-or-string-at-point'. ---- *** New user option 'ispell-help-timeout'. This controls how long the ispell help (on the '?' key) is displayed. ** Flyspell mode -+++ *** Corrections and actions menu can be optionally bound to 'mouse-3'. When Flyspell mode highlights a word as misspelled, you can click on it to display a menu of possible corrections and actions. You can now easily bind this menu to 'down-mouse-3' (usually the right mouse button) instead of 'mouse-2' (the default) by enabling 'context-menu-mode'. ---- *** The current dictionary is now displayed in the minor mode lighter. Clicking the dictionary name changes the current dictionary. @@ -1444,7 +1236,6 @@ Clicking the dictionary name changes the current dictionary. Thus, packages on NonGNU ELPA will appear by default in the list shown by 'list-packages'. ---- *** '/ s' ('package-menu-filter-by-status') changed parameter handling. The command was documented to take a comma-separated list of statuses to filter by, but instead it used the parameter as a regexp. The @@ -1452,10 +1243,8 @@ command has been changed so that it now works as documented, and checks statuses not as a regexp, but instead an exact match from the comma-separated list. -+++ *** New command 'package-browse-url' and keystroke 'w'. -+++ *** New commands to filter the package list. The filter commands are bound to the following keys: @@ -1482,7 +1271,6 @@ run the native-compilation of the package files. (Be sure to leave Emacs running until these asynchronous subprocesses exit, or else the native-compilation will be aborted when you exit Emacs.) ---- *** Column widths in 'list-packages' display can now be customized. See the new user options 'package-name-column-width', 'package-version-column-width', 'package-status-column-width', and @@ -1490,7 +1278,6 @@ See the new user options 'package-name-column-width', ** Info ---- *** New user option 'Info-warn-on-index-alternatives-wrap'. This option affects what happens when using the ',' command after looking up an entry with 'i' in info buffers. If non-nil (the @@ -1500,7 +1287,6 @@ you to the first match. ** Abbrev mode -+++ *** Emacs can now suggest to use an abbrev based on text you type. A new user option, 'abbrev-suggest', enables the new abbrev suggestion feature. When enabled, if a user manually types a piece of text that @@ -1510,17 +1296,14 @@ used instead. ** Bookmarks ---- *** Bookmarks can now be targets for new tabs. When the bookmark.el library is loaded, a customize choice is added to 'tab-bar-new-tab-choice' for new tabs to show the bookmark list. ---- *** New user option 'bookmark-set-fringe-mark'. If non-nil, setting a bookmark will set a fringe mark on the current line, and jumping to a bookmark will also set this mark. ---- *** New user option 'bookmark-menu-confirm-deletion'. In Bookmark Menu mode, Emacs by default does not prompt for confirmation when you type 'x' to execute the deletion of bookmarks @@ -1528,7 +1311,6 @@ that have been marked for deletion. However, if this new option is non-nil then Emacs will require confirmation with 'yes-or-no-p' before deleting. ---- *** The 'list-bookmarks' menu is now based on 'tabulated-list-mode'. The interactive bookmark list will now benefit from features in 'tabulated-list-mode' like sorting columns or changing column width. @@ -1540,17 +1322,14 @@ The variables 'bookmark-bmenu-use-header-line' and ** Recentf ---- *** The recentf files are no longer backed up. ---- *** 'recentf-auto-cleanup' now repeats daily when set to a time string. When 'recentf-auto-cleanup' is set to a time string, it now repeats every day, rather than only running once after the mode is turned on. ** Calc ---- *** The behavior when doing forward-delete has been changed. Previously, using the 'C-d' command would delete the final number in the input field, no matter where point was. This has been changed to @@ -1558,42 +1337,35 @@ work more traditionally, with 'C-d' deleting the next character. Likewise, point isn't moved to the end of the string before inserting digits. -+++ *** Setting the word size to zero disables word clipping. The word size normally clips the results of certain bit-oriented operations such as shifts and bitwise XOR. A word size of zero, set by 'b w', makes the operation have effect on the whole argument values and the result is not truncated in any way. ---- *** The '/' operator now has higher precedence in (La)TeX input mode. It no longer has lower precedence than '+' and '-'. ---- *** New user option 'calc-make-windows-dedicated'. When this user option is non-nil, Calc will mark its windows as dedicated. ** Calendar -+++ *** New user option 'calendar-time-zone-style'. If 'numeric', calendar functions (eg 'calendar-sunrise-sunset') that display time zones will use a form like "+0100" instead of "CET". ** Imenu -+++ *** New user option 'imenu-max-index-time'. If creating the imenu index takes longer than specified by this option (default 5 seconds), imenu indexing is stopped. ** Ido ---- *** Switching on 'ido-mode' now also overrides 'ffap-file-finder'. ---- *** Killing virtual ido buffers interactively will make them go away. Previously, killing a virtual ido buffer with 'ido-kill-buffer' didn't do anything. This has now been changed, and killing virtual buffers @@ -1601,13 +1373,11 @@ with that command will remove the buffer from recentf. ** So Long ---- *** New 'so-long-predicate' function 'so-long-statistics-excessive-p'. It efficiently detects the presence of a long line anywhere in the buffer using 'buffer-line-statistics' (see above). This is now the default predicate (replacing 'so-long-detected-long-line-p'). ---- *** Default values 'so-long-threshold' and 'so-long-max-lines' increased. The values of these user options have been raised to 10000 bytes and 500 lines respectively, to reduce the likelihood of false-positives when @@ -1615,14 +1385,12 @@ lines respectively, to reduce the likelihood of false-positives when by the old predicate, as the new predicate knows the longest line in the entire buffer. ---- *** 'so-long-target-modes' now includes 'fundamental-mode' by default. This means that 'global-so-long-mode' will also process files which were not recognised. (This only has an effect if 'set-auto-mode' chooses 'fundamental-mode'; buffers which are simply in 'fundamental-mode' by default are unaffected.) ---- *** New user options to preserve modes and variables. The new options 'so-long-mode-preserved-minor-modes' and 'so-long-mode-preserved-variables' allow specified mode and variable @@ -1631,7 +1399,6 @@ mode. By default, these new options support 'view-mode'. ** Grep -+++ *** New user option 'grep-match-regexp' matches grep markers to highlight. Grep emits SGR ANSI escape sequences to color its output. The new user option 'grep-match-regexp' holds the regular expression to match @@ -1639,7 +1406,6 @@ the appropriate markers in order to provide highlighting in the source buffer. The user option can be customized to accommodate other grep-like tools. ---- *** The 'lgrep' command now ignores directories. On systems where the grep command supports it, directories will be skipped. @@ -1653,19 +1419,16 @@ any directory names on the 'find' command lines end in a slash. This change is for better compatibility with old versions of non-GNU 'find', such as the one used on macOS. ---- *** New utility function 'grep-file-at-point'. This returns the name of the file at point (if any) in 'grep-mode' buffers. ** Shell ---- *** New command in 'shell-mode': 'shell-narrow-to-prompt'. This is bound to 'C-x n d' in 'shell-mode' buffers, and narrows to the command line under point (and any following output). ---- *** New user option 'shell-has-auto-cd'. If non-nil, 'shell-mode' handles implicit "cd" commands, changing the directory if the command is a directory. Useful for shells like "zsh" @@ -1673,20 +1436,17 @@ that has this feature. ** Term mode ---- *** New user option 'term-scroll-snap-to-bottom'. By default, 'term' and 'ansi-term' will now recenter the buffer so that the prompt is on the final line in the window. Setting this new user option to nil inhibits this behavior. ---- *** New user option 'term-set-terminal-size'. If non-nil, the 'LINES' and 'COLUMNS' environment variables will be set based on the current window size. In previous versions of Emacs, this was always done (and that could lead to odd displays when resizing the window after starting). This variable defaults to nil. ---- *** 'term-mode' now supports "bright" color codes. "Bright" ANSI color codes are now displayed using the color values defined in 'term-color-bright-*'. In addition, bold text with regular @@ -1695,15 +1455,12 @@ is non-nil. ** Eshell ---- *** 'eshell-hist-ignoredups' can now also be used to mimic "erasedups" in bash. ---- *** Environment variable 'INSIDE_EMACS' is now copied to subprocesses. Its value contains the result of evaluating '(format "%s,eshell" emacs-version)'. Other package names, like "tramp", could also be included. ---- *** Eshell no longer re-initializes its keymap every call. This allows users to use '(define-key eshell-mode-map ...)' as usual. Some modules have their own minor mode now to account for these @@ -1715,7 +1472,6 @@ will create a bookmark that opens the current directory in Eshell. ** Archive mode ---- *** Archive mode can now parse ".squashfs" files. *** Can now modify members of 'ar' archives. @@ -1727,7 +1483,6 @@ New user option 'archive-hidden-columns' and new command 'archive-hideshow-column' let you control which columns are displayed and which are kept hidden. ---- *** New command bound to 'C': 'archive-copy-file'. This command extracts the file at point and writes its data to a file. @@ -1756,15 +1511,12 @@ symbol property to the browsing commands. With a new command 'browse-url-with-browser-kind', an URL can explicitly be browsed with either an internal or external browser. ---- *** Support for browsing of remote files. If a remote file is specified, a local temporary copy of that file is passed to the browser. ---- *** Support for the conkeror browser is now obsolete. ---- *** Support for the Mosaic browser has been removed. This support has been obsolete since 25.1. @@ -1775,7 +1527,6 @@ New key bindings have been added to 'completion-list-mode': 'n' and 'p' now navigate completions, and 'M-g M-c' switches to the minibuffer and back to the completion list buffer. -+++ ** Profiler The results displayed by 'profiler-report' now have the usage figures at the left hand side followed by the function name. This is intended @@ -1785,12 +1536,10 @@ layout back. ** Icomplete ---- *** New user option 'icomplete-matches-format'. This allows controlling the current/total number of matches for the prompt prefix. -+++ *** New minor modes 'icomplete-vertical-mode' and 'fido-vertical-mode'. These modes modify Icomplete ('icomplete-mode') and Fido ('fido-mode'), to display completion candidates vertically instead of @@ -1799,20 +1548,16 @@ kept at the top. In Fido, completions scroll like a typical dropdown widget. Both these new minor modes will turn on their non-vertical counterparts first, if they are not on already. ---- *** Default value of 'icomplete-compute-delay' has been changed to 0.15 s. ---- *** Default value of 'icomplete-max-delay-chars' has been changed to 2. ---- *** Reduced blinking while completing the next completions set. Icomplete doesn't hide the hint with the previously computed completions anymore when compute delay is in effect, or the previous computation has been aborted by input. Instead it shows the previous completions until the new ones are ready. ---- *** Change in meaning of 'icomplete-show-matches-on-no-input'. Previously, choosing a different completion with commands like 'C-.' and then hitting 'RET' would choose the default completion. Doing this @@ -1822,7 +1567,6 @@ with initial input as the default directory. ** Windmove -+++ *** New user options to customize windmove keybindings. These options include 'windmove-default-keybindings', 'windmove-display-default-keybindings', @@ -1832,25 +1576,20 @@ Also new mode 'windmove-mode' enables the customized keybindings. ** Occur mode ---- *** New bindings in 'occur-mode'. The command 'next-error-no-select' is now bound to 'n' and 'previous-error-no-select' is bound to 'p'. ---- *** New command 'recenter-current-error'. It is bound to 'l' in Occur or compilation buffers, and recenters the current displayed occurrence/error. ---- *** Matches in target buffers are now highlighted as in 'compilation-mode'. The method of highlighting is specified by the user options 'next-error-highlight' and 'next-error-highlight-no-select'. ---- *** A fringe arrow in the "*Occur*" buffer indicates the selected match. ---- *** Occur mode may use a different type for 'occur-target' property values. The value was previously always a marker set to the start of the first match on the line but can now also be a list of '(BEGIN . END)' pairs @@ -1861,10 +1600,8 @@ work as before. ** Emacs Lisp mode ---- *** The mode-line now indicates whether we're using lexical or dynamic scoping. -+++ *** A space between an open paren and a symbol changes the indentation rule. The presence of a space between an open paren and a symbol now is taken as a statement by the programmer that this should be indented @@ -1876,37 +1613,31 @@ as a data list rather than as a piece of code. The mode provides refined highlighting of built-in functions, types, and variables. ---- *** Lisp mode now uses 'common-lisp-indent-function'. To revert to the previous behavior, '(setq lisp-indent-function 'lisp-indent-function)' from 'lisp-mode-hook'. ** Change Logs and VC -+++ *** 'vc-revert-show-diff' now has a third possible value: 'kill'. If this user option is 'kill', then the diff buffer will be killed after the 'vc-revert' action instead of buried. ---- *** More VC commands can be used from non-file buffers. The relevant commands are those that don't change the VC state. The non-file buffers which can use VC commands are those that have their 'default-directory' under VC. ---- *** New face 'log-view-commit-body'. This is used when expanding commit messages from 'vc-print-root-log' and similar commands. ---- *** New faces for 'vc-dir' buffers. Those are: 'vc-dir-header', 'vc-dir-header-value', 'vc-dir-directory', 'vc-dir-file', 'vc-dir-mark-indicator', 'vc-dir-status-warning', 'vc-dir-status-edited', 'vc-dir-status-up-to-date', 'vc-dir-status-ignored'. ---- *** The responsible VC backend is now the most specific one. 'vc-responsible-backend' loops over the backends in 'vc-handled-backends' to determine which backend is responsible for a @@ -1914,41 +1645,32 @@ specific (unregistered) file. Previously, the first matching backend was chosen, but now the one with the most specific path is chosen (in case there's a directory handled by one backend inside another). ---- *** New command 'vc-dir-root' uses the root directory without asking. ---- *** New commands 'vc-dir-mark-registered-files' (bound to '* r') and 'vc-dir-mark-unregistered-files'. ---- *** Support for bookmark.el. Bookmark locations can refer to VC directory buffers. ---- *** New user option 'vc-hg-create-bookmark'. It controls whether a bookmark or branch will be created when you invoke 'C-u C-x v s' ('vc-create-tag'). ---- *** 'vc-hg' now uses 'hg summary' to populate extra 'vc-dir' headers. ---- *** New user option 'vc-git-revision-complete-only-branches'. If non-nil, only branches and remotes are considered when doing completion over Git branch names. The default is nil, which causes tags to be considered as well. ---- *** New user option 'vc-git-log-switches'. String or list of strings specifying switches for Git log under VC. ---- *** Command 'vc-switch-backend' is now obsolete. If you are still using it with any regularity, please file a bug report with some details. ---- *** New variable 'vc-git-use-literal-pathspecs'. The Git backend's function now treat all file names "literally", where some of them previously could interpret file names (pathspecs) as @@ -1957,35 +1679,28 @@ the aforementioned variable to nil locally to avoid this. ** Gnus -+++ *** New user option 'gnus-topic-display-predicate'. This can be used to inhibit the display of some topics completely. -+++ *** nnimap now supports the oauth2.el library. -+++ *** New Summary buffer sort options for extra headers. The extra header sort option ('C-c C-s C-x') prompts for a header and fails if no sort function has been defined. Sorting by Newsgroups ('C-c C-s C-u') has been pre-defined. -+++ *** The '#' command in the Group and Summary buffer now toggles, instead of sets, the process mark. -+++ *** New user option 'gnus-process-mark-toggle'. If non-nil (the default), the '#' command in the Group and Summary buffers will toggle, instead of set, the process mark. -+++ *** New user option 'gnus-registry-register-all'. If non-nil (the default), create registry entries for all messages. If nil, don't automatically create entries, they must be created manually. -+++ *** New user options to customise the summary line specs "%[" and "%]". Four new options introduced in customisation group 'gnus-summary-format'. These are 'gnus-sum-opening-bracket', @@ -1998,29 +1713,24 @@ the value of 'gnus-sum-opening-bracket', but can also be normally display the value of 'gnus-sum-closing-bracket', but can also be 'gnus-sum-closing-bracket-adopted' for the adopted articles. -+++ *** New user option 'gnus-paging-select-next'. This controls what happens when using commands like 'SPC' and 'DEL' to page the current article. If non-nil (the default), go to the next/prev article, but if nil, do nothing at the end/start of the article. -+++ *** New gnus-search library. A new unified search syntax which can be used across multiple supported search engines. Set 'gnus-search-use-parsed-queries' to non-nil to enable. -+++ *** New value for user option 'smiley-style'. Smileys can now be rendered with emojis instead of small images when using the new 'emoji' value in 'smiley-style'. -+++ *** New user option 'gnus-agent-eagerly-store-articles'. If non-nil (which is the default), the Gnus Agent will store all read articles in the Agent cache. -+++ *** New user option 'gnus-global-groups'. Gnus handles private groups differently from public (i.e., NNTP-like) groups. Most importantly, Gnus doesn't download external images from @@ -2028,17 +1738,14 @@ mail-like groups. This can be overridden by putting group names in 'gnus-global-groups': Any group present in that list will be treated like a public group. -+++ *** New scoring types for the Date header. You can now score based on the relative age of an article with the new '<' and '>' date scoring types. -+++ *** User-defined scoring is now possible. The new type is 'score-fn'. More information in the Gnus manual node "(gnus) Score File Format". -+++ *** New backend 'nnselect'. The newly added 'nnselect' backend allows creating groups from an arbitrary list of articles that may come from multiple groups and @@ -2061,35 +1768,29 @@ has been removed; its functionality is now available directly in the 'gnus-refer-thread-use-nnir' has been renamed to 'gnus-refer-thread-use-search'. -+++ *** New user option 'gnus-dbus-close-on-sleep'. On systems with D-Bus support, it is now possible to register a signal to close all Gnus servers before the system sleeps. -+++ *** The key binding of 'gnus-summary-search-article-forward' has changed. This command was previously on 'M-s' and shadowed the global 'M-s' search prefix. The command has now been moved to 'M-s M-s'. (For consistency, the 'M-s M-r' key binding has been added for the 'gnus-summary-search-article-backward' command.) ---- *** The value for "all" in the 'large-newsgroup-initial' group parameter has changed. It was previously nil, which didn't work, because nil is indistinguishable from not being present. The new value for "all" is the symbol 'all'. -+++ *** The name of dependent Gnus sessions has changed from "slave" to "child". The names of the commands 'gnus-slave', 'gnus-slave-no-server' and 'gnus-slave-unplugged' have changed to 'gnus-child', 'gnus-child-no-server' and 'gnus-child-unplugged' respectively. -+++ *** The 'W Q' summary mode command now takes a numerical prefix to allow adjusting the fill width. -+++ *** New variable 'mm-inline-font-lock'. This variable is supposed to be bound by callers to determine whether inline MIME parts (that support it) are supposed to be font-locked or @@ -2097,23 +1798,19 @@ not. ** Message ---- *** Respect 'message-forward-ignored-headers' more. Previously, this user option would not be consulted if 'message-forward-show-mml' was nil and forwarding as MIME. -+++ *** New user option 'message-forward-included-mime-headers'. This is used when forwarding messages as MIME, but not using MML. -+++ *** Message now supports the OpenPGP header. To generate these headers, add the new function 'message-add-openpgp-header' to 'message-send-hook'. The header will be generated according to the new 'message-openpgp-header' user option. ---- *** A change to how "Mail-Copies-To: never" is handled. If a user has specified "Mail-Copies-To: never", and Message was asked to do a "wide reply", some other arbitrary recipient would end up in @@ -2123,7 +1820,6 @@ you're responding to a specific person in particular. This has been changed so that all the recipients are put in the "To" header in these instances. -+++ *** New command to start Emacs in Message mode to send an email. Emacs can be defined as a handler for the "x-scheme-handler/mailto" MIME type with the following command: "emacs -f message-mailto %u". @@ -2136,7 +1832,6 @@ Emacs with headers filled out according to the link, e.g. emacsclient, use "emacsclient -e '(message-mailto "%u")'" or "emacsclient-mail.desktop". ---- *** Change to default value of 'message-draft-headers' user option. The 'Date' symbol has been removed from the default value, meaning that draft or delayed messages will get a date reflecting when the message @@ -2144,7 +1839,6 @@ was sent. To restore the original behavior of dating a message from when it is first saved or delayed, add the symbol 'Date' back to this user option. -+++ *** New command to take screenshots. In Message mode buffers, the 'C-c C-p' ('message-insert-screenshot') command has been added. It depends on using an external program to @@ -2152,30 +1846,25 @@ take the actual screenshot, and defaults to "ImageMagick import". ** Smtpmail -+++ *** smtpmail now supports using the oauth2.el library. -+++ *** New user option 'smtpmail-store-queue-variables'. If non-nil, SMTP variables will be stored together with the queued messages, and will then be used when sending with command 'smtpmail-send-queued-mail'. -+++ *** Allow direct selection of smtp authentication mechanism. A server entry retrieved by auth-source can request a desired smtp authentication mechanism by setting a value for the key 'smtp-auth'. ** ElDoc -+++ *** New user option 'eldoc-echo-area-display-truncation-message'. If non-nil (the default), eldoc will display a message saying something like "(Documentation truncated. Use `M-x eldoc-doc-buffer' to see rest)" when a message has been truncated. If nil, truncated messages will be marked with just "..." at the end. -+++ *** New hook 'eldoc-documentation-functions'. This hook is intended to be used for registering doc string functions. These functions don't need to produce the doc string right away, they @@ -2190,7 +1879,6 @@ functions receive the doc string composed according to the user. Examples of such functions would use the echo area, a separate buffer, or a tooltip. -+++ *** New user option 'eldoc-documentation-strategy'. The built-in choices available for this user option let users compose the results of 'eldoc-documentation-functions' in various ways, even @@ -2206,33 +1894,27 @@ it when producing a doc string. ** Tramp -+++ *** New connection method "mtp". It allows accessing media devices like cell phones, tablets or cameras. -+++ *** New connection method "sshfs". It allows accessing remote files via a file system mounted with 'sshfs'. -+++ *** Tramp supports SSH authentication via a hardware security key now. This requires at least OpenSSH 8.2, and a FIDO U2F compatible security key, like yubikey, solokey, or nitrokey. -+++ *** Trashed remote files are moved to the local trash directory. All remote files that are trashed are moved to the local trash directory, except remote encrypted files, which are always deleted. -+++ *** New command 'tramp-crypt-add-directory'. This command marks a remote directory to contain only encrypted files. See the "(tramp) Keeping files encrypted" node of the Tramp manual for details. This feature is experimental. -+++ *** Support of direct asynchronous process invocation. When Tramp connection property "direct-async-process" is set to non-nil for a given connection, 'make-process' and 'start-file-process' @@ -2242,24 +1924,20 @@ performance of asynchronous remote processes" node of the Tramp manual for details, and also for a discussion or restrictions. This feature is experimental. -+++ *** New user option 'tramp-debug-to-file'. When non-nil, this user option instructs Tramp to mirror the debug buffer to a file under the "/tmp/" directory. This is useful, if (in rare cases) Tramp blocks Emacs, and we need further debug information. -+++ *** Tramp supports lock files now. In order to deactivate this, set user option 'remote-file-name-inhibit-locks' to t. -+++ *** Writing sensitive data locally requires confirmation. Writing auto-save, backup or lock files to the local temporary directory must be confirmed. In order to suppress this confirmation, set user option 'tramp-allow-unsafe-temporary-files' to t. -+++ *** 'make-directory' of a remote directory honors the default file modes. ** GDB/MI @@ -2268,7 +1946,6 @@ set user option 'tramp-allow-unsafe-temporary-files' to t. If non-nil, apply a register filter based on 'gdb-registers-filter-pattern-list'. -+++ *** gdb-mi can now save and restore window configurations. Use 'gdb-save-window-configuration' to save window configuration to a file and 'gdb-load-window-configuration' to load from a file. These @@ -2276,31 +1953,26 @@ commands can also be accessed through the menu bar under "Gud => GDB-Windows". 'gdb-default-window-configuration-file', when non-nil, is loaded when GDB starts up. -+++ *** gdb-mi can now restore window configuration after quitting. Set 'gdb-restore-window-configuration-after-quit' to non-nil and Emacs will remember the window configuration before GDB started and restore it after GDB quits. A toggle button is also provided under "Gud => GDB-Windows" menu item. -+++ *** gdb-mi now has a better logic for displaying source buffers. Now GDB only uses one source window to display source file by default. Customize 'gdb-max-source-window-count' to use more than one window. Control source file display by 'gdb-display-source-buffer-action'. -+++ *** The default value of 'gdb-mi-decode-strings' is now t. This means that the default coding-system is now used to decode strings and source file names from GDB. ** Compilation mode ---- *** New function 'ansi-color-compilation-filter'. This function is meant to be used in 'compilation-filter-hook'. ---- *** New user option 'ansi-color-for-compilation-mode'. This controls what 'ansi-color-compilation-filter' does. @@ -2310,7 +1982,6 @@ case-insensitive matching of messages when the old behavior is required, but the recommended solution is to use a correctly matching regexp instead. ---- *** New user option 'compilation-search-all-directories'. When doing parallel builds, directories and compilation errors may arrive in the "*compilation*" buffer out-of-order. If this option is @@ -2318,45 +1989,37 @@ non-nil (the default), Emacs will now search backwards in the buffer for any directory the file with errors may be in. If nil, this won't be done (and this restores how this previously worked). ---- *** Messages from ShellCheck are now recognized. ---- *** Messages from Visual Studio that mention column numbers are now recognized. ** Hi Lock mode ---- *** Matching in 'hi-lock-mode' can be case-sensitive. The matching is case-sensitive when a regexp contains upper case characters and 'search-upper-case' is non-nil. 'highlight-phrase' also uses 'search-whitespace-regexp' to substitute spaces in regexp search. ---- *** The default value of 'hi-lock-highlight-range' was enlarged. The new default value is 2000000 (2 megabytes). ** Whitespace mode -+++ *** New style 'missing-newline-at-eof'. If present in 'whitespace-style' (as it is by default), the final character in the buffer will be highlighted if the buffer doesn't end with a newline. ---- *** The default 'whitespace-enable-predicate' predicate has changed. It used to check elements in the list version of 'whitespace-global-modes' with 'eq', but now uses 'derived-mode-p'. ** Texinfo ---- *** New user option 'texinfo-texi2dvi-options'. This is used when invoking 'texi2dvi' from 'texinfo-tex-buffer'. ---- *** New commands for moving in and between environments. An "environment" is something that ends with '@end'. The commands are 'C-c C-c C-f' (next end), 'C-c C-c C-b' (previous end), @@ -2366,19 +2029,16 @@ current environment. ** Rmail ---- *** New user option 'rmail-re-abbrevs'. Its default value matches localized abbreviations of the "reply" prefix on the Subject line in various languages. ---- *** New user option 'rmail-show-message-set-modified'. If set non-nil, showing an unseen message will set the Rmail buffer's modified flag. The default is nil, to preserve the old behavior. ** CC mode -+++ *** Added support for Doxygen documentation style. 'doxygen' is now a valid 'c-doc-comment-style' which recognises all comment styles supported by Doxygen (namely '///', '//!', '/** … */' @@ -2393,7 +2053,6 @@ use 'doxygen' by default one might evaluate: or use it in a custom 'c-style'. -+++ *** Added support to line up '?' and ':' of a ternary operator. The new 'c-lineup-ternary-bodies' function can be used as a lineup function to align question mark and colon which are part of a ternary @@ -2413,30 +2072,25 @@ To enable, add it to appropriate entries in 'c-offsets-alist', e.g.: ** Images ---- *** You can explicitly specify base_uri for svg images. ':base-uri' image property can be used to explicitly specify base_uri for embedded images into svg. ':base-uri' is supported for both file and data svg images. -+++ *** 'svg-embed-base-uri-image' added to embed images. 'svg-embed-base-uri-image' can be used to embed images located relatively to 'file-name-directory' of the ':base-uri' svg image property. This works much faster than 'svg-embed'. -+++ *** New function 'image-cache-size'. This function returns the size of the current image cache, in bytes. ---- *** Animated images stop automatically under high CPU pressure sooner. Previously, an animated image would stop animating if any single image took more than two seconds to display. The new algorithm maintains a decaying average of delays, and if this number gets too high, the animation is stopped. -+++ *** The 'n' and 'p' commands (next/previous image) now respect Dired order. These commands would previously display the next/previous image in lexicographic order, but will now find the "parent" Dired buffer and @@ -2445,7 +2099,6 @@ sorted there. The commands have also been extended to work when the "parent" buffer is an archive mode (i.e., zip file or the like) or tar mode buffer. ---- *** 'image-converter' is now restricted to formats in 'auto-mode-alist'. When using external image converters, the external program is queried for what formats it supports. This list may contain formats that are @@ -2453,7 +2106,6 @@ problematic in some contexts (like PDFs), so this list is now filtered based on 'auto-mode-alist'. Only file names that map to 'image-mode' are now supported. ---- *** The background and foreground of images now default to face colors. When an image doesn't specify a foreground or background color, Emacs now uses colors from the face used to draw the surrounding text @@ -2469,7 +2121,6 @@ To load images with the default frame colors use the ':foreground' and This change only affects image types that support foreground and background colors or transparency, such as xbm, pbm, svg, png and gif. -+++ *** Image smoothing can now be explicitly enabled or disabled. Smoothing applies a bilinear filter while scaling or rotating an image to prevent aliasing and other unwanted effects. The new image @@ -2479,13 +2130,11 @@ and nil to disable smoothing. The default behavior of smoothing on down-scaling and not smoothing on up-scaling remains unchanged. -+++ *** New user option 'image-transform-smoothing'. This controls whether to use smoothing or not for an image. Values include nil (no smoothing), t (do smoothing) or a predicate function that's called with the image object and should return nil/t. -+++ *** SVG images now support user stylesheets. The ':css' image attribute can be used to override the default CSS stylesheet for an image. The default sets 'font-family' and @@ -2494,7 +2143,6 @@ will match the font size in use where it is embedded. This feature relies on librsvg 2.48 or above being available. -+++ *** Image properties support 'em' sizes. Size image properties, for example ':height', ':max-height', etc., can be given a cons of the form '(SIZE . em)', where SIZE is an integer or @@ -2503,42 +2151,35 @@ size, and 'em' is a symbol. ** EWW -+++ *** New user option 'eww-use-browse-url'. This is a regexp that can be set to alter how links are followed in eww. -+++ *** New user option 'eww-retrieve-command'. This can be used to download data via an external command. If nil (the default), then 'url-retrieve' is used. When 'sync', then 'url-retrieve-synchronously' is used. A list of strings specifies an external program with parameters. -+++ *** New Emacs command line convenience command. The 'eww-browse' command has been added, which allows you to register Emacs as a MIME handler for "text/x-uri", and will call 'eww' on the supplied URL. Usage example: "emacs -f eww-browse https://gnu.org". -+++ *** 'eww-download-directory' will now use the XDG location, if defined. However, if "~/Downloads/" already exists, that will continue to be used. ---- *** The command 'eww-follow-link' now supports custom 'mailto:' handlers. The function that is invoked when clicking on or otherwise following a 'mailto:' link in an EWW buffer can now be customized. For more information, see the related entry about 'shr-browse-url' below. ---- *** Support for bookmark.el. The command 'bookmark-set' (bound to 'C-x r m') is now supported, and will create a bookmark that opens the current URL in EWW. ** SHR ---- *** The command 'shr-browse-url' now supports custom 'mailto:' handlers. Clicking on or otherwise following a 'mailto:' link in an HTML buffer rendered by SHR previously invoked the command 'browse-url-mail'. @@ -2546,7 +2187,6 @@ This is still the case by default, but if you customize 'browse-url-mailto-function' or 'browse-url-handlers' to call some other function, it will now be called instead of the default. ---- *** New user option 'shr-offer-extend-specpdl'. If this is nil, rendering of HTML that requires enlarging 'max-specpdl-size', the number of Lisp variable bindings, will be @@ -2554,7 +2194,6 @@ aborted, and Emacs will not ask you whether to enlarge 'max-specpdl-size' to complete the rendering. The default is t, which preserves the original behavior. -+++ *** New user option 'shr-max-width'. If this user option is non-nil, and 'shr-width' is nil, then SHR will use the value of 'shr-max-width' to limit the width of the rendered @@ -2564,80 +2203,64 @@ to a more readable text. Customize it to nil to get the previous behavior of rendering as wide as the 'window-width' allows. If 'shr-width' is non-nil, it overrides this option. ---- *** New faces for heading elements. Those are 'shr-h1', 'shr-h2', 'shr-h3', 'shr-h4', 'shr-h5', 'shr-h6'. ** Project ---- *** New user option 'project-vc-merge-submodules'. ---- *** Project commands now have their own history. Previously used project directories are now suggested by all commands that prompt for a project directory. -+++ *** New prefix keymap 'project-prefix-map'. Key sequences that invoke project-related commands start with the prefix 'C-x p'. Type 'C-x p C-h' to show the full list. -+++ *** New commands 'project-dired', 'project-vc-dir', 'project-shell', 'project-eshell'. These commands run Dired/VC-Dir and Shell/Eshell in a project's root directory, respectively. -+++ *** New command 'project-compile'. This command runs compilation in the current project's root directory. -+++ *** New command 'project-switch-project'. This command lets you "switch" to another project and run a project command chosen from a dispatch menu. -+++ *** New commands 'project-shell-command' and 'project-async-shell-command'. These commands run 'shell-command' and 'async-shell-command' in a project's root directory, respectively. -+++ *** New user option 'project-list-file'. This specifies the file in which to save the list of known projects. -+++ *** New command 'project-remember-projects-under'. This command can automatically locate and index projects in a directory and optionally also its subdirectories, storing them in 'project-list-file'. -+++ *** New commands 'project-forget-project' and 'project-forget-projects-under'. These commands let you interactively remove entries from the list of projects in 'project-list-file'. -+++ *** New command 'project-forget-zombie-projects'. This command detects indexed projects that have since been deleted, and removes them from the list of known projects in 'project-list-file'. ---- *** 'project-find-file' now accepts non-existent file names. This is to allow easy creation of files inside some nested sub-directory. -+++ *** 'project-find-file' doesn't use the string at point as default input. Now it's only suggested as part of the "future history", accessible via 'M-n'. -+++ *** New command 'project-find-dir' runs Dired in a directory inside project. ** Xref -+++ *** New user options to automatically show the first Xref match. The new user option 'xref-auto-jump-to-first-definition' controls the behavior of 'xref-find-definitions' and its variants, like @@ -2653,57 +2276,47 @@ visit. 'xref-auto-jump-to-first-xref' changes their behavior much in the same way as 'xref-auto-jump-to-first-definition' affects the 'xref-find-definitions*' commands. ---- *** New user options 'xref-search-program' and 'xref-search-program-alist'. So far 'grep' and 'ripgrep' are supported. 'ripgrep' seems to offer better performance in certain cases, in particular for case-insensitive searches. -+++ *** New commands 'xref-prev-group' and 'xref-next-group'. These commands are bound respectively to 'P' and 'N', and navigate to the first item of the previous or next group in the "*xref*" buffer. ---- *** New alternative value for 'xref-show-definitions-function': 'xref-show-definitions-completing-read'. ---- *** The two existing alternatives for 'xref-show-definitions-function' have been renamed to have "proper" public names and documented ('xref-show-definitions-buffer' and 'xref-show-definitions-buffer-at-bottom'). -+++ *** New command 'xref-quit-and-pop-marker-stack'. This command is bound to 'M-,' in "*xref*" buffers. This combination is easy to press semi-accidentally if the user wants to go back in the middle of choosing the exact definition to go to, and this should do TRT. ---- *** New value 'project-relative' for 'xref-file-name-display'. If chosen, file names in "*xref*" buffers will be displayed relative to the 'project-root' of the current project, when available. ---- *** Prefix arg of 'xref-goto-xref' quits the "*xref*" buffer. So typing 'C-u RET' in the "*xref*" buffer quits its window before navigating to the selected location. -+++ *** The 'TAB' key binding in "*xref*" buffers is obsolete. Use 'C-u RET' instead. The 'TAB' binding in "*xref*" buffers is still supported, but we plan on removing it in a future version; at that time, the command 'xref-quit-and-goto-xref' will no longer have a key binding in 'xref--xref-buffer-mode-map'. ---- *** New user option 'etags-xref-prefer-current-file'. When non-nil, matches for identifiers in the file visited by the current buffer will be shown first in the "*xref*" buffer. -+++ *** The etags Xref backend now honors 'tags-apropos-additional-actions'. You can customize it to augment the output of 'xref-find-apropos', like it affected the output of 'tags-apropos', which is obsolete since @@ -2711,7 +2324,6 @@ Emacs 25.1. ** Battery ---- *** UPower is now the default battery status backend when available. UPower support via the function 'battery-upower' was added in Emacs 26.1, but was disabled by default. It is now the default value of @@ -2721,7 +2333,6 @@ service. The user options 'battery-upower-device' and whether to respond to status change notifications in addition to polling, respectively. ---- *** A richer syntax can be used to format battery status information. The user options 'battery-mode-line-format' and 'battery-echo-area-format' now support the full formatting syntax of @@ -2731,7 +2342,6 @@ truncation, amongst other things. ** Bug Reference ---- *** Bug reference mode uses auto-setup. If 'bug-reference-mode' or 'bug-reference-prog-mode' have been activated, their respective hook has been run, and both @@ -2748,17 +2358,14 @@ variables 'bug-reference-setup-from-vc-alist', ** HTML mode ---- *** A new skeleton for adding relative URLs has been added. It's bound to the 'C-c C-c f' keystroke, and prompts for a local file name. ** Widget -+++ *** 'widget-choose' now supports menus in extended format. ---- *** The 'editable-list' widget now supports moving items up and down. You can now move items up and down by deleting and then reinserting them, using the 'DEL' and 'INS' buttons respectively. This is useful @@ -2767,62 +2374,50 @@ a list. ** Diff ---- *** New face 'diff-changed-unspecified'. This is used to highlight "changed" lines (those marked with '!') in context diffs, when 'diff-use-changed-face' is non-nil. ---- *** New 'diff-mode' font locking face 'diff-error'. This face is used for error messages from 'diff'. -+++ *** New command 'diff-refresh-hunk'. This new command (bound to 'C-c C-l') regenerates the current hunk. ** Thing at point -+++ *** New 'thing-at-point' target: 'existing-filename'. This is like 'filename', but is a full path, and is nil if the file doesn't exist. -+++ *** New 'thing-at-point' target: 'string'. If point is inside a string, it returns that string. -+++ *** New variable 'thing-at-point-provider-alist'. This allows mode-specific alterations to how 'thing-at-point' works. ---- *** 'thing-at-point' now respects fields. 'thing-at-point' (and all functions that use it, like 'symbol-at-point') will narrow to the current field (if any) before trying to identify the thing at point. ---- *** New function 'thing-at-mouse'. This is like 'thing-at-point', but uses the mouse event position instead. ** Image Dired -+++ *** New user option 'image-dired-thumb-visible-marks'. If non-nil (the default), use the new face 'image-dired-thumb-mark' for marked images. ---- *** New command 'image-dired-delete-marked'. ---- *** 'image-dired-mouse-toggle-mark' is now sensitive to the active region. If the region is active, this command now toggles Dired marks of all the thumbnails in the region. ** Flymake mode -+++ *** New command 'flymake-show-project-diagnostics'. This lists all diagnostics for buffers in the currently active project. The listing is similar to the one obtained by @@ -2831,7 +2426,6 @@ project-relative file name. For backends which support it, 'flymake-show-project-diagnostics' also lists diagnostics for files that have not yet been visited. -+++ *** New user options to customize Flymake's mode-line. The new user option 'flymake-mode-line-format' is a mix of strings and symbols like 'flymake-mode-line-title', 'flymake-mode-line-exception' @@ -2842,7 +2436,6 @@ like 'flymake-mode-line-error-counter', ** Time ---- *** 'display-time-world' has been renamed to 'world-clock'. 'world-clock' creates a buffer with an updating time display using several time zones. It is hoped that the new names are more @@ -2865,21 +2458,17 @@ The following user options have been renamed: The old names are now obsolete. ---- *** 'world-clock-mode' can no longer be turned on interactively. Use 'world-clock' to turn on that mode. ** Python mode ---- *** New user option 'python-forward-sexp-function'. This allows the user easier customization of whether to use block-based navigation or not. ---- *** 'python-shell-interpreter' now defaults to python3 on systems with python3. ---- *** 'C-c C-r' can now be used on arbitrary regions. The command previously extended the start of the region to the start of the line, but will now actually send the marked region, as @@ -2887,12 +2476,10 @@ documented. ** Ruby mode ---- *** 'ruby-use-smie' is declared obsolete. SMIE is now always enabled and 'ruby-use-smie' only controls whether indentation is done using SMIE or with the old ad-hoc code. ---- *** Indentation has changed when 'ruby-align-chained-calls' is non-nil. This previously used to align subsequent lines with the last sibling, but it now aligns with the first sibling (which is the preferred style @@ -2900,10 +2487,8 @@ in Ruby). ** CPerl mode ---- *** New face 'perl-heredoc', used for heredoc elements. ---- *** The command 'cperl-set-style' offers the new value "PBP". This value customizes Emacs to use the style recommended in Damian Conway's book "Perl Best Practices" for indentation and formatting @@ -2911,20 +2496,17 @@ of conditionals. ** Perl mode ---- *** New face 'perl-non-scalar-variable'. This is used to fontify non-scalar variables. ** Octave mode -+++ *** Line continuations in double-quoted strings now use a backslash. Typing 'C-M-j' (bound to 'octave-indent-new-comment-line') now follows the behavior introduced in Octave 3.8 of using a backslash as a line continuation marker within double-quoted strings, and an ellipsis everywhere else. -+++ ** EasyPG GPG key servers can now be queried for keys with the 'epa-search-keys' command. Keys can then be added to your @@ -2932,11 +2514,9 @@ personal key ring. ** Etags -+++ *** Etags now supports the Mercury programming language. See https://mercurylang.org. -+++ *** Etags command line option '--declarations' now has Mercury-specific behavior. All Mercury declarations are tagged by default. However, for compatibility with 'etags' support for Prolog, predicates and @@ -2945,7 +2525,6 @@ invoked with the '--declarations' command-line option. ** Comint -+++ *** Support for OSC escape sequences. Adding the new function 'comint-osc-process-output' to 'comint-output-filter-functions' enables the interpretation of OSC @@ -2955,18 +2534,15 @@ tracking, are acted upon. Adding more entries to 'comint-osc-handlers' allows a customized treatment of further escape sequences. -+++ *** 'comint-delete-output' can now save deleted text in the kill-ring. Interactively, 'C-u C-c C-o' triggers this new optional behavior. ** ANSI color ---- *** Colors are now defined by faces. ANSI SGR codes now have corresponding faces to describe their appearance, e.g. 'ansi-color-bold'. ---- *** Support for "bright" color codes. "Bright" ANSI color codes are now displayed when applying ANSI color filters using the color values defined by the faces @@ -2981,45 +2557,37 @@ user-visible changes in ERC. ** Xwidget Webkit mode ---- *** New xwidget commands. 'xwidget-webkit-uri' (return the current URL), 'xwidget-webkit-title' (return the current title), and 'xwidget-webkit-goto-history' (goto a point in history). ---- *** Downloading files from xwidget-webkit is now supported. The new user option 'xwidget-webkit-download-dir' says where to download to. ---- *** New command 'xwidget-webkit-clone-and-split-below'. Open a new window below displaying the current URL. ---- *** New command 'xwidget-webkit-clone-and-split-right'. Open a new window to the right displaying the current URL. ---- *** Pixel-based scrolling. The 'xwidget-webkit-scroll-up', 'xwidget-webkit-scroll-down' commands now supports scrolling arbitrary pixel values. It now treats the optional 2nd argument as the pixel values to scroll. ---- *** New commands for scrolling. The new commands 'xwidget-webkit-scroll-up-line', 'xwidget-webkit-scroll-down-line', 'xwidget-webkit-scroll-forward', 'xwidget-webkit-scroll-backward' can be used to scroll webkit by the height of lines or width of chars. ---- *** New user option 'xwidget-webkit-bookmark-jump-new-session'. When non-nil, use a new xwidget webkit session after bookmark jump. Otherwise, it will use 'xwidget-webkit-last-session'. ** Checkdoc ---- *** No longer warns about command substitutions by default. Checkdoc used to warn about "too many command substitutions" (as in "\\[foo-command]"), even if you only used ten of them in a docstring. @@ -3028,19 +2596,16 @@ substitutions before it becomes a performance issue, so this warning is now disabled by default. To re-enable this warning, customize the user option 'checkdoc-max-keyref-before-warn'. ---- *** New user option 'checkdoc-column-zero-backslash-before-paren'. Checkdoc warns if there is a left parenthesis in column zero of a documentation string. That warning can now be disabled by customizing this new user option to nil. This is useful if you don't expect your code to be edited with an Emacs older than version 27.1. ---- *** Now checks the prompt format for 'yes-or-no-p'. In addition to verifying the format of the prompt for 'y-or-n-p', checkdoc will now check the format of 'yes-or-no-p'. ---- *** New command 'checkdoc-dired'. This can be used to run checkdoc on files from a Dired buffer. @@ -3052,14 +2617,12 @@ this warning therefore mostly led to false positives. ** Enriched mode ---- *** 'C-a' is by default no longer bound to 'beginning-of-line-text'. This is so 'C-a' works as in other modes, and in particular holding Shift while typing 'C-a', i.e. 'C-S-a', will now highlight the text. ** Gravatar ---- *** New user option 'gravatar-service' for host to query for gravatars. Defaults to 'gravatar', with 'unicornify' and 'libravatar' as options. @@ -3068,89 +2631,69 @@ Defaults to 'gravatar', with 'unicornify' and 'libravatar' as options. Functions and variables related to handling junk mail have been renamed to not associate color with sender quality. -+++ *** New names for mh-junk interactive functions. Function 'mh-junk-whitelist' is renamed 'mh-junk-allowlist'. Function 'mh-junk-blacklist' is renamed 'mh-junk-blocklist'. -+++ *** New binding for 'mh-junk-allowlist'. The key binding for 'mh-junk-allowlist' is changed from 'J w' to 'J a'. The old binding is supported but warns that it is obsolete. -+++ *** New names for some hooks. 'mh-whitelist-msg-hook' is renamed 'mh-allowlist-msg-hook'. 'mh-blacklist-msg-hook' is renamed 'mh-blocklist-msg-hook'. -+++ *** New names for some user options. User option 'mh-whitelist-preserves-sequences-flag' is renamed 'mh-allowlist-preserves-sequences-flag'. -+++ *** New names for some faces. Face 'mh-folder-blacklisted' is renamed 'mh-folder-blocklisted'. Face 'mh-folder-whitelisted' is renamed 'mh-folder-allowlisted'. ** Rcirc -+++ *** rcirc now supports SASL authentication. ---- *** #emacs on Libera.chat has been added to 'rcirc-server-alist'. ---- *** rcirc connects asynchronously. ---- *** Integrate formatting into 'rcirc-send-string'. The function now accepts a variable number of arguments. -+++ *** Deprecate 'rcirc-command' in favor of 'rcirc-define-command'. The new macro handles multiple and optional arguments. ---- *** Add basic IRCv3 support. This includes support for the capabilities: 'server-time', 'batch', 'message-ids', 'invite-notify', 'multi-prefix' and 'standard-replies'. ---- *** Add mouse property support to 'rcirc-track-minor-mode'. ---- *** Improve support for IRC markup codes. ---- *** Check 'auth-sources' for server passwords. -+++ *** Implement repeated reconnection strategy. See 'rcirc-reconnect-attempts'. ** MPC ---- *** New command 'mpc-goto-playing-song'. This command, bound to 'o' in any 'mpc-mode' buffer, moves point to the currently playing song in the "*MPC-Songs*" buffer. ---- *** New user option 'mpc-cover-image-re'. If non-nil, it is a regexp that should match a valid cover image. ** Miscellaneous ---- *** 'shell-script-mode' now supports 'outline-minor-mode'. The outline headings have lines that start with "###". ---- *** fileloop will now skip missing files instead of signalling an error. ---- *** 'tabulated-list-mode' can now restore original display order. Many commands (like 'C-x C-b') are derived from 'tabulated-list-mode', and that mode allows the user to sort on any column. There was @@ -3158,73 +2701,58 @@ previously no easy way to get back to the original displayed order after sorting, but giving a -1 numerical prefix to the sorting command will now restore the original order. ---- *** 'M-left' and 'M-right' now move between columns in 'tabulated-list-mode'. ---- *** New variable 'hl-line-overlay-priority'. This can be used to change the priority of the hl-line overlays. -+++ *** New command 'mailcap-view-file'. This command will open a viewer based on the file type, as determined by "~/.mailcap" and related files and variables. ---- *** New user option 'remember-diary-regexp'. ---- *** New user option 'remember-text-format-function'. ---- *** New user option 'authinfo-hide-elements'. This can be set to nil to inhibit hiding passwords in ".authinfo" files. ---- *** 'hexl-mode' scrolling commands now heed 'next-screen-context-lines'. Previously, 'hexl-scroll-down' and 'hexl-scroll-up' would scroll up/down an entire window, but they now work more like the standard scrolling commands. ---- *** New user option 'bibtex-unify-case-function'. This new option allows the user to customize how case is converted when unifying entries. ---- *** The user option 'bibtex-maintain-sorted-entries' now permits user-defined sorting schemes. ---- *** New user option 'reveal-auto-hide'. If non-nil (the default), revealed text is automatically hidden when point leaves the text. If nil, the text is not hidden again. Instead the command 'reveal-hide-revealed' can be used to hide all the revealed text. ---- *** New user option 'ffap-file-name-with-spaces'. If non-nil, 'find-file-at-point' and friends will try to guess more expansively to identify a file name with spaces. Default value is nil. ---- *** Two new commands for centering in 'doc-view-mode'. The new commands 'doc-view-center-page-horizontally' (bound to 'c h') and 'doc-view-center-page-vertically' (bound to 'c v') center the page horizontally and vertically, respectively. ---- *** 'tempo-define-template' can now re-assign templates to tags. Previously, assigning a new template to an already defined tag had no effect. ---- *** The width of the buffer-name column in 'list-buffers' is now dynamic. The width now depends on the width of the window, but will never be wider than the length of the longest buffer name, except that it will never be narrower than 19 characters. -+++ *** New diary sexp 'diary-offset'. It offsets another diary sexp by a number of days. This is useful when for example your organization has a committee meeting two days @@ -3232,13 +2760,10 @@ after every monthly meeting which takes place on the third Thursday, or if you would like to attend a virtual meeting scheduled in a different timezone causing a difference in the date. ---- *** The old non-SMIE indentation of 'sh-mode' has been removed. ---- *** 'mspools-show' is now autoloaded. ---- *** Loading dunnet.el in batch mode doesn't start the game any more. Instead you need to do "emacs --batch -f dunnet" to start the game in batch mode. @@ -3246,7 +2771,6 @@ batch mode. * New Modes and Packages in Emacs 28.1 -+++ ** New mode 'repeat-mode' to allow shorter key sequences. Type 'M-x repeat-mode' to enable this mode. You can then type 'C-x u u' instead of 'C-x u C-x u' to undo many changes, 'C-x o o' @@ -3272,7 +2796,6 @@ columns. Command 'describe-repeat-maps' will display a buffer showing which commands are repeatable in 'repeat-mode'. ---- ** New themes 'modus-vivendi' and 'modus-operandi'. These themes are designed to conform with the highest standard for color-contrast accessibility (WCAG AAA). You can load either of them @@ -3288,14 +2811,12 @@ This is a mode for searching a RFC 2229 dictionary server. the mouse in 'dictionary-tooltip-dictionary' (which must be customized first). ---- ** Lisp Data mode The new command 'lisp-data-mode' enables a major mode for buffers composed of Lisp symbolic expressions that do not form a computer program. The ".dir-locals.el" file is automatically set to use this mode, as are other data files produced by Emacs. -+++ ** New global mode 'global-goto-address-mode'. This will enable 'goto-address-mode' in all buffers. @@ -3309,7 +2830,6 @@ similar to prefix arguments, but are more flexible and discoverable. This library can create, query, navigate and display hierarchical structures. ---- ** New major mode for displaying the "etc/AUTHORS" file. This new 'etc-authors-mode' provides font-locking for displaying the "etc/AUTHORS" file from the Emacs distribution, and not much else. @@ -3317,13 +2837,11 @@ This new 'etc-authors-mode' provides font-locking for displaying the * Incompatible Lisp Changes in Emacs 28.1 -+++ ** Emacs now prints a backtrace when signaling an error in batch mode. This makes debugging Emacs Lisp scripts run in batch mode easier. To get back the old behavior, set the new variable 'backtrace-on-error-noninteractive' to a nil value. ---- ** Some floating-point numbers are now handled differently by the Lisp reader. In previous versions of Emacs, numbers with a trailing dot and an exponent were read as integers and the exponent ignored: 2.e6 was interpreted as the @@ -3331,28 +2849,24 @@ integer 2. Such numerals are now read as floats with the exponent included: 2.e6 is now read as the floating-point value 2000000.0. That is, '(read-from-string "1.e3")' => '(1000.0 . 4)' now. ---- ** 'equal' no longer examines some contents of window configurations. Instead, it considers window configurations to be equal only if they are 'eq'. To compare contents, use 'compare-window-configurations' instead. This change helps fix a bug in 'sxhash-equal', which returned incorrect hashes for window configurations and some other objects. -+++ ** The 'lexical-binding' local variable is always enabled. Previously, if 'enable-local-variables' was nil, a 'lexical-binding' local variable would not be heeded. This has now changed, and a file with a 'lexical-binding' cookie is always heeded. To revert to the old behavior, set 'permanently-enabled-local-variables' to nil. -+++ ** '&rest' in argument lists must always be followed by a variable name. Omitting the variable name after '&rest' was previously tolerated in some cases but not consistently so; it could lead to crashes or outright wrong results. Since the utility was marginal at best, it is now an error to omit the variable. ---- ** 'kill-all-local-variables' has changed how it handles non-symbol hooks. The function is documented to eliminate all buffer-local bindings except variables with a 'permanent-local' property, or hooks that @@ -3360,14 +2874,12 @@ have elements with a 'permanent-local-hook' property. In addition, it would also keep lambda expressions in hooks sometimes. The latter has now been changed: The function will now also remove these. -+++ ** Temporary buffers no longer run certain buffer hooks. The macros 'with-temp-buffer' and 'with-temp-file' no longer run the hooks 'kill-buffer-hook', 'kill-buffer-query-functions', and 'buffer-list-update-hook' for the temporary buffers they create. This avoids slowing them down when a lot of these hooks are defined. -+++ ** New face 'child-frame-border' and frame parameter 'child-frame-border-width'. The face and width of child frames borders can now be determined separately from those of normal frames. To minimize backward @@ -3376,7 +2888,6 @@ parameter will fall back to using 'internal-border-width'. However, the new 'child-frame-border' face does constitute a breaking change since child frames' borders no longer use the 'internal-border' face. ---- ** 'run-at-time' now tries harder to implement the t TIME parameter. If TIME is t, the timer runs at an integral multiple of REPEAT. (I.e., if given a REPEAT of 60, it'll run at 08:11:00, 08:12:00, @@ -3387,18 +2898,15 @@ has now changed, and the timer code now recomputes the integral multiple every time it runs, which means that if the laptop wakes at 08:16:43, it'll fire at that time, but then at 08:17:00, 08:18:00... ---- ** 'parse-partial-sexp' now signals an error if TO is smaller than FROM. Previously, this would lead to the function interpreting FROM as TO and vice versa, which would be confusing when passing in OLDSTATE, which refers to the old state at FROM. -+++ ** 'global-mode-string' constructs should end with a space. This was previously not formalized, which led to combinations of modes displaying data "smushed together" on the mode line. -+++ ** 'overlays-in' now handles zero-length overlays slightly differently. Previously, zero-length overlays at the end of the buffer were included in the result (if the region queried for stopped at that position). @@ -3406,7 +2914,6 @@ The same was not the case if the buffer had been narrowed to exclude the real end of the buffer. This has now been changed, and zero-length overlays at 'point-max' are always included in the results. ---- ** 'replace-match' now runs modification hooks slightly later. The function is documented to leave point after the replacement text, but this was not always the case if a modification hook inserted text @@ -3415,28 +2922,23 @@ point where the end of the inserted text would have been before the hook ran. 'replace-match' now always leaves point after the replacement text. -+++ ** 'completing-read-default' sets completion variables buffer-locally. 'minibuffer-completion-table' and related variables are now set buffer-locally in the minibuffer instead of being set via a global let-binding. ---- ** XML serialization functions now reject invalid characters. Previously, 'xml-print' would produce invalid XML when given a string with characters that are not valid in XML (see https://www.w3.org/TR/xml/#charsets). Now it rejects such strings. ---- ** JSON ---- *** JSON number parsing is now stricter. Numbers with a leading plus sign, leading zeros, or a missing integer component are now rejected by 'json-read' and friends. This makes them more compliant with the JSON specification and consistent with the native JSON parsing functions. ---- *** JSON functions support the semantics of RFC 8259. The JSON functions 'json-serialize', 'json-insert', 'json-parse-string', and 'json-parse-buffer' now implement some of the @@ -3444,7 +2946,6 @@ semantics of RFC 8259 instead of the earlier RFC 4627. In particular, these functions now accept top-level JSON values that are neither arrays nor objects. ---- *** Some JSON encoding functions are now obsolete. The functions 'json-encode-number', 'json-encode-hash-table', 'json-encode-key', and 'json-encode-list' are now obsolete. @@ -3454,7 +2955,6 @@ used instead. Uses of 'json-encode-list' should be changed to call one of 'json-encode', 'json-encode-alist', 'json-encode-plist', or 'json-encode-array' instead. -+++ *** Native JSON functions now signal an error if libjansson is unavailable. This affects 'json-serialize', 'json-insert', 'json-parse-string', and 'json-parse-buffer'. This can happen if Emacs was compiled with @@ -3462,148 +2962,117 @@ libjansson, but the DLL cannot be found and/or loaded by Emacs at run time. Previously, Emacs would display a message and return nil in these cases. -+++ ** The use of positional arguments in 'define-minor-mode' is obsolete. These were actually rendered obsolete in Emacs 21 but were never marked as such. ---- ** 'pcomplete-ignore-case' is now an obsolete alias of 'completion-ignore-case'. -+++ ** 'completions-annotations' face is not used when the caller puts own face. This affects the suffix specified by completion 'annotation-function'. -+++ ** An active minibuffer now has major mode 'minibuffer-mode'. This is instead of the erroneous 'minibuffer-inactive-mode' it formerly had. ---- ** 'make-text-button' no longer modifies text properties of its first argument. When its first argument is a string, 'make-text-button' no longer modifies the string's text properties; instead, it uses and returns a copy of the string. This helps avoid trouble when strings are shared or constants. -+++ ** Some properties from completion tables are now preserved. If 'minibuffer-allow-text-properties' is non-nil, doing completion over a table of strings with properties will no longer remove all the properties before returning. This affects things like 'completing-read'. ---- ** 'dns-query' now consistently uses Lisp integers to represent integers. Formerly it made an exception for integer components of SOA records, because SOA serial numbers can exceed fixnum ranges on 32-bit platforms. Emacs now supports bignums so this old glitch is no longer needed. -+++ ** The '&define' keyword in an Edebug specification now disables backtracking. The implementation was buggy, and multiple '&define' forms in an '&or' form should be exceedingly rare. See the Info node "(elisp) Backtracking" in the Emacs Lisp reference manual for background. -+++ ** The error 'ftp-error' belongs also to category 'remote-file-error'. -+++ ** The WHEN argument of 'make-obsolete' and related functions is mandatory. The use of those functions without a WHEN argument was marked obsolete back in Emacs 23.1. The affected functions are: 'make-obsolete', 'define-obsolete-function-alias', 'make-obsolete-variable', 'define-obsolete-variable-alias'. -+++ ** 'inhibit-nul-byte-detection' is renamed to 'inhibit-null-byte-detection'. ---- ** Some functions are no longer considered safe by 'unsafep': 'replace-regexp-in-string', 'catch', 'throw', 'error', 'signal' and 'play-sound-file'. ---- ** 'sql-*-statement-starters' are no longer user options. These variables describe facts about the SQL standard and product-specific additions. There should be no need for users to customize them. ---- ** Some locale-related variables have been removed. The Lisp variables 'previous-system-messages-locale' and 'previous-system-time-locale' have been removed, as they were created by mistake and were not useful to Lisp code. ---- ** Function 'lm-maintainer' is replaced with 'lm-maintainers'. The former is now declared obsolete. -+++ ** facemenu.el is no longer preloaded. To use functions/variables from the package, you now have to say '(require 'facemenu)' or similar. ---- ** 'facemenu-color-alist' is now obsolete, and is not used. ---- ** The variable 'keyboard-type' is obsolete and not dynamically scoped any more. -+++ ** The 'values' variable is now obsolete. Using it just contributes to the growth of the Emacs memory footprint. ---- ** The 'load-dangerous-libraries' variable is now obsolete. It was used to allow loading Lisp libraries compiled by XEmacs, a modified version of Emacs which is no longer actively maintained. This is no longer supported, and setting this variable has no effect. -+++ ** The macro 'with-displayed-buffer-window' is now obsolete. Use macro 'with-current-buffer-window' with action alist entry 'body-function'. ---- ** The rfc2368.el library is now obsolete. Use rfc6068.el instead. The main difference is that 'rfc2368-parse-mailto-url' and 'rfc2368-unhexify-string' assumed that the strings were all-ASCII, while 'rfc6068-parse-mailto-url' and 'rfc6068-unhexify-string' parse UTF-8 strings. ---- ** The inversion.el library is now obsolete. ---- ** The metamail.el library is now obsolete. ** Edebug changes ---- *** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'. -+++ *** The spec operator ':name NAME' is obsolete, use '&name' instead. -+++ *** The spec element 'function-form' is obsolete, use 'form' instead. -+++ *** New function 'def-edebug-elem-spec' to define Edebug spec elements. These used to be defined with 'def-edebug-spec' thus conflating the two name spaces, which lead to name collisions. The use of 'def-edebug-spec' to define Edebug spec elements is declared obsolete. ---- ** The sb-image.el library is now obsolete. This was a compatibility kludge which is no longer needed. ---- ** Some libraries obsolete since Emacs 23 have been removed: ledit.el, lmenu.el, lucid.el and old-whitespace.el. ---- ** Some functions and variables obsolete since Emacs 23 have been removed: 'GOLD-map', 'advertised-xscheme-send-previous-expression', 'allout-init', 'bookmark-jump-noselect', @@ -3675,20 +3144,16 @@ ledit.el, lmenu.el, lucid.el and old-whitespace.el. 'vcursor-toggle-vcursor-map', 'w32-focus-frame', 'w32-select-font', 'wisent-lex-make-token-table'. ---- ** Some functions and variables obsolete since Emacs 22 have been removed: 'erc-current-network', 'gnus-article-hide-pgp-hook', 'gnus-inews-mark-gcc-as-read', 'gnus-treat-display-xface', 'gnus-treat-strip-pgp', 'nnmail-spool-file'. ---- ** The obsolete function 'thread-alive-p' has been removed. ---- ** The variable 'force-new-style-backquotes' has been removed. This removes the final remaining trace of old-style backquotes. ---- ** Some obsolete variable and function aliases in dbus.el have been removed. In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to 'dbus-event-error-functions' and the function @@ -3696,7 +3161,6 @@ In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to The old names, which were kept as obsolete aliases of the new names, have now been removed. ---- ** 'find-function-source-path' renamed and re-documented. The 'find-function' command (and various related commands) were documented to respect 'find-function-source-path', and to search for @@ -3709,7 +3173,6 @@ still being used by 'find-library' and related commands, so the user option has been renamed to 'find-library-source-path', and 'find-function-source-path' is now an obsolete variable alias. ---- ** The macro 'vc-call' no longer evaluates its second argument twice. ** Xref migrated from EIEIO to 'cl-defstruct' for its core objects. @@ -3729,7 +3192,6 @@ use with "match items" without adding EIEIO as a dependency. * Lisp Changes in Emacs 28.1 -+++ ** The 'interactive' syntax has been extended to allow listing applicable modes. Forms like '(interactive "p" dired-mode)' can be used to annotate the commands as being applicable for modes derived from 'dired-mode', @@ -3740,7 +3202,6 @@ Also note that by default these annotations have no effect, unless the new user option 'read-extended-command-predicate' option is customized to call 'command-completion-default-include-p' or a similar function. -+++ ** New 'declare' forms to control completion of commands in 'M-x'. '(declare (completion PREDICATE))' can be used as a general predicate to say whether the command should be considered a completion candidate @@ -3759,74 +3220,61 @@ default value of 'read-extended-command-predicate' is nil, which means no commands that match what you have typed are excluded from being completion candidates. -+++ ** 'define-minor-mode' now takes an ':interactive' argument. This can be used for specifying which modes this minor mode is meant for, or to make the new minor mode non-interactive. The default value is t. -+++ ** 'define-derived-mode' now takes an ':interactive' argument. This can be used to control whether the defined mode is a command or not, and is useful when defining commands that aren't meant to be used by users directly. -+++ ** 'define-globalized-minor-mode' now takes a ':predicate' parameter. This can be used to control which major modes the minor mode should be used in. -+++ ** 'condition-case' now allows for a success handler. It is written as '(:success BODY...)' where BODY is executed whenever the protected form terminates without error, with the specified variable bound to the value of the protected form. -+++ ** New function 'benchmark-call' to measure the execution time of a function. Additionally, the number of repetitions can be expressed as a minimal duration in seconds. -+++ ** The value thrown to the 'exit' label can now be a function. This is in addition to values t or nil. If the value is a function, the command loop will call it with zero arguments before returning. -+++ ** The behavior of 'format-spec' is now closer to that of 'format'. In order for the two functions to behave more consistently, 'format-spec' now pads and truncates based on string width rather than length, and also supports format specifications that include a truncating precision field, such as "%.2a". ---- ** 'defvar' detects the error of defining a variable currently lexically bound. Such mixes are always signs that the outer lexical binding was an error and should have used dynamic binding instead. ---- ** New variable 'inhibit-mouse-event-check'. If bound to non-nil, a command with '(interactive "e")' doesn't signal an error when invoked by input event that is not a mouse click (e.g., a key sequence). ---- ** New variable 'redisplay-skip-initial-frame' to enable batch redisplay tests. Setting it to nil forces the redisplay to do its job even in the initial frame used in batch mode. -+++ ** Doc strings can now link to customization groups. Text like "customization group `whitespace'" will be made into a button. When clicked, it will open a Custom buffer displaying that customization group. -+++ ** Doc strings can now link to man pages. Text like "man page `chmod(1)'" will be made into a button. When clicked, it will open a Man mode buffer displaying that man page. -+++ ** Buffers can now be created with certain hooks disabled. The functions 'get-buffer-create' and 'generate-new-buffer' accept a new optional argument INHIBIT-BUFFER-HOOKS. If non-nil, the new @@ -3835,78 +3283,63 @@ buffer does not run the hooks 'kill-buffer-hook', avoids slowing down internal or temporary buffers that are never presented to users or passed on to other applications. -+++ ** New command 'make-directory-autoloads'. This does the same as the old command 'update-directory-autoloads', but has different semantics: Instead of passing in the output file via the dynamically bound 'generated-autoload-file' variable, the output file is now an explicit parameter. ---- ** Dragging a file into Emacs pushes the file name onto 'file-name-history'. ---- ** The 'easymenu' library is now preloaded. ---- ** The 'iso-transl' library is now preloaded. This means that keystrokes like 'Alt-[' are defined by default, instead of only becoming available after doing (for instance) 'C-x 8 '. ---- ** ':safe' settings in 'defcustom' are now propagated to the loaddefs files. -+++ ** New ':type' for 'defcustom' for nonnegative integers. The new 'natnum' type can be used for options that should be nonnegative integers. -+++ ** ERT can now output more verbose test failure reports. If the 'EMACS_TEST_VERBOSE' environment variable is set, failure summaries will include the failing condition. ** Byte compiler changes -+++ *** New byte-compiler check for missing dynamic variable declarations. It is meant as an (experimental) aid for converting Emacs Lisp code to lexical binding, where dynamic (special) variables bound in one file can affect code in another. For details, see the Info node "(elisp) Converting to Lexical Binding". -+++ *** 'byte-recompile-directory' can now compile symlinked "*.el" files. This is achieved by giving a non-nil FOLLOW-SYMLINKS parameter. ---- *** The byte-compiler now warns about too wide documentation strings. By default, it will warn if a documentation string is wider than the largest of 'byte-compile-docstring-max-column' or 'fill-column' characters. -+++ *** 'byte-compile-file' optional argument LOAD is now obsolete. To load the file after byte-compiling, add a call to 'load' from Lisp or use 'M-x emacs-lisp-byte-compile-and-load' interactively. ** Macroexp ---- *** New function 'macroexp-file-name' to know the name of the current file. ---- *** New function 'macroexp-compiling-p' to know if we're compiling. ---- *** New function 'macroexp-warn-and-return' to help emit warnings. This used to be named 'macroexp--warn-and-return' and has proved useful and well-behaved enough to lose the "internal" marker. ** map.el ---- *** Alist keys are now consistently compared with 'equal' by default. Until now, 'map-elt' and 'map-delete' compared alist keys with 'eq' by default. They now use 'equal' instead, for consistency with @@ -3916,14 +3349,11 @@ default. They now use 'equal' instead, for consistency with A pattern like '(map :sym)' binds the map's value for ':sym' to 'sym', equivalent to '(map (:sym sym))'. ---- *** The function 'map-copy' now uses 'copy-alist' on alists. This is a slightly deeper copy than the previous 'copy-sequence'. ---- *** The function 'map-contains-key' now supports plists. ---- *** More consistent duplicate key handling in 'map-merge-with'. Until now, 'map-merge-with' promised to call its function argument whenever multiple maps contained 'eql' keys. However, this did not @@ -3933,26 +3363,21 @@ are merged, for greater consistency with 'map-merge' and 'map-elt'. ** Pcase -+++ *** The 'or' pattern now binds the union of the vars of its sub-patterns. If a variable is not bound by the subpattern that matched, it gets bound to nil. This was already sometimes the case, but it is now guaranteed. -+++ *** The 'pred' pattern can now take the form '(pred (not FUN))'. This is like '(pred (lambda (x) (not (FUN x))))' but results in better code. ---- *** New function 'pcase-compile-patterns' to write other macros. -+++ *** Added 'cl-type' pattern. The new 'cl-type' pattern compares types using 'cl-typep', which allows comparing simple types like '(cl-type integer)', as well as forms like '(cl-type (integer 0 10))'. -+++ *** New macro 'pcase-setq'. This macro is the 'setq' equivalent of 'pcase-let', which allows for destructuring patterns in a 'setq' form. @@ -3961,49 +3386,40 @@ destructuring patterns in a 'setq' form. *** Edebug specification lists can use some new keywords: -+++ **** '&interpose SPEC FUN ARGS...' lets FUN control parsing after SPEC. More specifically, FUN is called with 'HEAD PF ARGS...' where PF is a parsing function that expects a single argument (the specs to use) and HEAD is the code that matched SPEC. -+++ **** '&error MSG' unconditionally aborts the current edebug instrumentation. -+++ **** '&name SPEC FUN' extracts the current name from the code matching SPEC. ** Dynamic modules changes -+++ *** Type aliases for module functions and finalizers. The module header "emacs-module.h" now contains type aliases 'emacs_function' and 'emacs_finalizer' for module functions and finalizers, respectively. -+++ *** Module functions can now be made interactive. Use 'make_interactive' to give a module function an interactive specification. -+++ *** Module functions can now install an optional finalizer. The finalizer is called when the function object is garbage-collected. Use 'set_function_finalizer' to set the finalizer and 'get_function_finalizer' to retrieve it. -+++ *** Modules can now open a channel to an existing pipe process. Modules can use the new module function 'open_channel' to do that. On capable systems, modules can use this functionality to asynchronously send data back to Emacs. -+++ *** A new module API 'make_unibyte_string'. It can be used to create Lisp strings with arbitrary byte sequences (a.k.a. "raw bytes"). -+++ ** Shorthands for Lisp symbols. Shorthands are a general purpose namespacing system to make Emacs Lisp's symbol-naming etiquette easier to use. A shorthand is any @@ -4014,230 +3430,182 @@ worth of symbols with proper and longer prefixes, without actually touching the Lisp source. For details, see the Info node "(elisp) Shorthands". -+++ ** New function 'string-search'. This function takes two string parameters and returns the position of the first instance of the former string in the latter. -+++ ** New function 'string-replace'. This function works along the line of 'replace-regexp-in-string', but it matches on fixed strings instead of regexps, and does not change the global match state. -+++ ** New function 'ensure-list'. This function makes a list of its object if it's not a list already. If it's already a list, the list is returned as is. -+++ ** New function 'split-string-shell-command'. This splits a shell command string into separate components, respecting quoting with single ('like this') and double ("like this") quotes, as well as backslash quoting (like\ this). -+++ ** New function 'string-clean-whitespace'. This removes whitespace from a string. -+++ ** New function 'string-fill'. Word-wrap a string so that no lines are longer that a specific length. -+++ ** New function 'string-limit'. Return (up to) a specific substring length. -+++ ** New function 'string-lines'. Return a list of strings representing the individual lines in a string. -+++ ** New function 'string-pad'. Pad a string to a specific length. -+++ ** New function 'string-chop-newline'. Remove a trailing newline from a string. -+++ ** New function 'replace-regexp-in-region'. -+++ ** New function 'replace-string-in-region'. -+++ ** New function 'file-name-with-extension'. This function allows a canonical way to set/replace the extension of a file name. -+++ ** New function 'file-modes-number-to-symbolic' to convert a numeric file mode specification into symbolic form. -+++ ** New function 'file-name-concat'. This appends file name components to a directory name and returns the result. -+++ ** New function 'file-backup-file-names'. This function returns the list of file names of all the backup files for the specified file. -+++ ** New function 'directory-empty-p'. This predicate tests whether a given file name is an accessible directory and whether it contains no other directories or files. -+++ ** New function 'buffer-local-boundp'. This predicate says whether a symbol is bound in a specific buffer. -+++ ** New function 'always'. This is identical to 'ignore', but returns t instead. -+++ ** New function 'sxhash-equal-including-properties'. This is identical to 'sxhash-equal' but also accounts for string properties. ---- ** New function 'buffer-line-statistics'. This function returns some statistics about the line lengths in a buffer. ---- ** New function 'color-values-from-color-spec'. This can be used to parse RGB color specs in several formats and convert them to a list '(R G B)' of primary color values. ---- ** New function 'custom-add-choice'. This function can be used by modes to add elements to the 'choice' customization type of a variable. ---- ** New function 'decoded-time-period'. It interprets a decoded time structure as a period and returns the equivalent period in seconds. -+++ ** New function 'dom-print'. -+++ ** New function 'dom-remove-attribute'. ---- ** New function 'dns-query-asynchronous'. It takes the same parameters as 'dns-query', but adds a callback parameter. ** New function 'garbage-collect-maybe' to trigger GC early. ---- ** New function 'get-locale-names'. This utility function returns a list of names of locales available on the current system. -+++ ** New function 'insert-into-buffer'. This inserts the contents of the current buffer into another buffer. -+++ ** New function 'json-available-p'. This predicate returns non-nil if Emacs is built with libjansson support, and it is available on the current system. ---- ** New function 'mail-header-parse-addresses-lax'. This takes a comma-separated string and returns a list of mail/name pairs. ---- ** New function 'mail-header-parse-address-lax'. Parse a string as a mail address-like string. ---- ** New function 'make-separator-line'. Make a string appropriate for usage as a visual separator line. -+++ ** New function 'num-processors'. Return the number of processors on the system. -+++ ** New function 'object-intervals'. This function returns a copy of the list of intervals (i.e., text properties) in the object in question (which must either be a string or a buffer). -+++ ** New function 'process-lines-ignore-status'. This is like 'process-lines', but does not signal an error if the return status is non-zero. 'process-lines-handling-status' has also been added, and takes a callback to handle the return status. -+++ ** New function 'require-theme'. This function is like 'require', but searches 'custom-theme-load-path' instead of 'load-path'. It can be used by Custom themes to load supporting Lisp files when 'require' is unsuitable. -+++ ** New function 'seq-union'. This function takes two sequences and returns a list of all elements that appear in either of them, with no two elements that compare equal appearing in the result. -+++ ** New function 'syntax-class-to-char'. This does almost the opposite of 'string-to-syntax' -- it returns the syntax descriptor (a character) given a raw syntax descriptor (an integer). -+++ ** New functions 'null-device' and 'path-separator'. These functions return the connection local value of the respective variables. This can be used for remote hosts. -+++ ** New predicate functions 'length<', 'length>' and 'length='. Using these functions may be more efficient than using 'length' (if the length of a (long) list is being computed just to compare this length to a number). -+++ ** New macro 'dlet' to dynamically bind variables. -+++ ** New macro 'with-existing-directory'. This macro binds 'default-directory' to some other existing directory if 'default-directory' doesn't exist, and then executes the body forms. -+++ ** New variable 'current-minibuffer-command'. This is like 'this-command', but it is bound recursively when entering the minibuffer. -+++ ** New variable 'inhibit-interaction' to make user prompts signal an error. If this is bound to something non-nil, functions like 'read-from-minibuffer', 'read-char' (and related) will signal an 'inhibited-interaction' error. ---- ** New variable 'indent-line-ignored-functions'. This allows modes to cycle through a set of indentation functions appropriate for those modes. -+++ ** New variable 'print-integers-as-characters' modifies integer printing. If this variable is non-nil, character syntax is used for printing numbers when this makes sense, such as '?A' for 65. -+++ ** New variable 'tty-menu-calls-mouse-position-function'. This controls whether 'mouse-position-function' is called by functions that retrieve the mouse position when that happens during TTY menu @@ -4245,46 +3613,38 @@ handling. Lisp programs that set 'mouse-position-function' should also set this variable non-nil if they are compatible with the tty menu handling. -+++ ** New variables that hold default buffer names for shell output. The new constants 'shell-command-buffer-name' and 'shell-command-buffer-name-async' store the default buffer names for the output of, respectively, synchronous and async shell commands. ---- ** New variables 'read-char-choice-use-read-key' and 'y-or-n-p-use-read-key'. When non-nil, then functions 'read-char-choice' and 'y-or-n-p' (respectively) use the function 'read-key' to read a character instead of using the minibuffer. -+++ ** New variable 'global-minor-modes'. This variable holds a list of currently enabled global minor modes (as a list of symbols). -+++ ** New buffer-local variable 'local-minor-modes'. This permanently buffer-local variable holds a list of currently enabled non-global minor modes in the current buffer (as a list of symbols). -+++ ** New completion function 'affixation-function' to add prefix/suffix. It accepts a list of completions and should return a list where each element is a list with three elements: a completion, a prefix string, and a suffix string. -+++ ** New completion function 'group-function' for grouping candidates. It takes two arguments: a completion candidate and a 'transform' flag. -+++ ** New error symbol 'minibuffer-quit'. Signaling it has almost the same effect as 'quit' except that it doesn't cause keyboard macro termination. -+++ ** New error symbol 'remote-file-error', a subcategory of 'file-error'. It is signaled if a remote file operation fails due to internal reasons, and could block Emacs. It does not replace 'file-error' @@ -4298,11 +3658,9 @@ Until it is solved you could ignore such errors by performing (setq debug-ignored-errors (cons 'remote-file-error debug-ignored-errors)) -+++ ** New macro 'named-let'. It provides Scheme's "named let" looping construct. ---- ** Emacs now attempts to test for high-rate subprocess output more fairly. When several subprocesses produce output simultaneously at high rate, Emacs will now by default attempt to service them all in a round-robin @@ -4311,81 +3669,66 @@ non-nil value to get back the old behavior, whereby after reading from a subprocess, Emacs would check for output of other subprocesses in a way that is likely to read from the same process again. -+++ ** 'set-process-buffer' now updates the process mark. The mark will be set to point to the end of the new buffer. -+++ ** 'unlock-buffer' displays warnings instead of signaling. Instead of signaling 'file-error' conditions for file system level errors, the function now calls 'display-warning' and continues as if the error did not occur. -+++ ** 'read-char-from-minibuffer' and 'y-or-n-p' support 'help-form'. If you bind 'help-form' to a non-nil value while calling these functions, then pressing 'C-h' ('help-char') causes the function to evaluate 'help-form' and display the result. -+++ ** 'read-number' now has its own history variable. Additionally, the function now accepts an optional HIST argument which can be used to specify a custom history variable. -+++ ** 'set-window-configuration' now takes two optional parameters, DONT-SET-FRAME and DONT-SET-MINIWINDOW. The first of these, when non-nil, instructs the function not to select the frame recorded in the configuration. The second prevents the current minibuffer being replaced by the one stored in the configuration. ---- ** 'count-windows' now takes an optional parameter ALL-FRAMES. The semantics are as with 'walk-windows'. -+++ ** 'truncate-string-ellipsis' now uses '…' by default. Modes that use 'truncate-string-to-width' with non-nil, non-string argument ELLIPSIS, will now indicate truncation using '…' when the selected frame can display it, and using "..." otherwise. -+++ ** 'string-width' now accepts two optional arguments FROM and TO. This allows calculating the width of a substring without consing a new string. -+++ ** 'directory-files' now takes an additional COUNT parameter. The parameter makes 'directory-files' return COUNT first file names from a directory. If MATCH is also given, the function will return first COUNT file names that match the expression. The same COUNT parameter has been added to 'directory-files-and-attributes'. -+++ ** 'count-lines' can now ignore invisible lines. This is controlled by the optional parameter IGNORE-INVISIBLE-LINES. ---- ** 'count-words' now crosses field boundaries. Originally, 'count-words' would stop counting at the first field boundary it encountered; now it keeps counting all the way to the region's (or buffer's) end. -+++ ** File-related APIs can optionally follow symlinks. The functions 'file-modes', 'set-file-modes', and 'set-file-times' now have an optional argument specifying whether to follow symbolic links. -+++ ** 'format-seconds' can now be used for sub-second times. The new optional "," parameter has been added, and '(format-seconds "%mm %,1ss" 66.4)' will now result in "1m 6.4s". -+++ ** 'parse-time-string' can now parse ISO 8601 format strings. These have a format like "2020-01-15T16:12:21-08:00". ---- ** 'lookup-key' is more allowing when searching for extended menu items. When looking for a menu item '[menu-bar Foo-Bar]', first try to find an exact match, then look for the lowercased '[menu-bar foo-bar]'. @@ -4393,7 +3736,6 @@ It will only try to downcase ASCII characters in the range "A-Z". This improves backwards-compatibility when converting menus to use 'easy-menu-define'. ---- ** 'make-network-process', 'make-serial-process' ':coding' behavior change. Previously, passing ':coding nil' to either of these functions would override any non-nil binding for 'coding-system-for-read' and @@ -4403,92 +3745,73 @@ Emacs depended on the previous behavior; if you really want the process' coding-system to be nil, use 'set-process-coding-system' after the process has been created, or pass in ':coding '(nil nil)'. -+++ ** 'open-network-stream' now accepts a ':coding' argument. This allows specifying the coding systems used by a network process for encoding and decoding without having to bind 'coding-system-for-{read,write}' or call 'set-process-coding-system'. -+++ ** 'open-network-stream' can now take a ':capability-command' that's a function. The function is called with the greeting from the server as its only parameter, and allows sending different TLS capability commands to the server based on that greeting. -+++ ** 'open-gnutls-stream' now also accepts a ':coding' argument. ---- ** 'process-attributes' now works under OpenBSD, too. -+++ ** 'format-spec' now takes an optional SPLIT parameter. If non-nil, 'format-spec' will split the resulting string into a list of strings, based on where the format specs (and expansions) were. ---- ** 'unload-feature' now also tries to undo additions to buffer-local hooks. ---- ** 'while-no-input-ignore-events' accepts more special events. The special events 'dbus-event' and 'file-notify' are now ignored in 'while-no-input' when added to this variable. ---- ** 'start-process-shell-command' and 'start-file-process-shell-command' do not support the old calling conventions any longer. -+++ ** 'yes-or-no-p' and 'y-or-n-p' PROMPT parameter no longer needs trailing space. In other words, the prompt can now end with "?" instead of "? ". This has been the case since Emacs 24.4 but was not announced or documented until now. (Checkdoc has also been updated to accept this convention.) -+++ ** The UNIQUIFY argument in 'auto-save-file-name-transforms' can be a symbol. If this symbol is one of the members of 'secure-hash-algorithms', Emacs constructs the nondirectory part of the auto-save file name by applying that 'secure-hash' to the buffer file name. This avoids any risk of excessively long file names. -+++ ** New user option 'process-file-return-signal-string'. It controls, whether 'process-file' returns a string when a remote process is interrupted by a signal. ** EIEIO Changes -+++ *** The macro 'oref-default' can now be used with 'setf'. It is now defined as a generalized variable that can be used with 'setf' to modify the value stored in a given class slot. ---- *** 'form' in '(eql form)' specializers in 'cl-defmethod' is now evaluated. This corresponds to the behavior of defmethod in Common Lisp Object System. For compatibility, '(eql SYMBOL)' does not evaluate SYMBOL, for now. ** D-Bus -+++ *** Property values can be typed explicitly. 'dbus-register-property' and 'dbus-set-property' accept now optional type symbols. Both functions propagate D-Bus errors. -+++ *** Registered properties can have the new access type ':write'. -+++ *** In case of problems, handlers can emit proper D-Bus error messages now. -+++ *** D-Bus errors, which have been converted from incoming D-Bus error messages, contain the error name of that message now. -+++ *** D-Bus messages can be monitored with the new command 'dbus-monitor'. -+++ *** D-Bus events have changed their internal structure. They carry now the destination and the error-name of an event. They also keep the type information of their arguments. Use the @@ -4496,19 +3819,16 @@ also keep the type information of their arguments. Use the ** Buttons -+++ *** New minor mode 'button-mode'. This minor mode does nothing except install 'button-buffer-map' as a minor mode map (which binds the 'TAB' / 'S-TAB' key bindings to navigate to buttons), and can be used in any view-mode-like buffer that has buttons in it. -+++ *** New utility function 'button-buttonize'. This function takes a string and returns a string propertized in a way that makes it a valid button. ---- ** 'text-scale-mode' can now adjust font size of the header line. When the new buffer local variable 'text-scale-remap-header-line' is non-nil, 'text-scale-adjust' will also scale the text in the header @@ -4519,10 +3839,8 @@ form below the header line. It is enabled by default in 'tabulated-list-mode' and its derived modes, and disabled by default elsewhere. ---- ** 'ascii' is now a coding system alias for 'us-ascii'. ---- ** New coding-systems for EBCDIC variants. New coding-systems 'ibm256', 'ibm273', 'ibm274', 'ibm277', 'ibm278', 'ibm280', 'ibm281', 'ibm284', 'ibm285', 'ibm290', 'ibm297'. These are @@ -4532,14 +3850,12 @@ locales. They are also available as aliases 'ebcdic-cp-*' (e.g., 'cp278' for 'ibm278'). There are also new charsets 'ibm2xx' to support these coding-systems. -+++ ** New "Bindat type expression" description language. This new system is provided by the new macro 'bindat-type' and obsoletes the old data layout specifications. It supports arbitrary-size integers, recursive types, and more. See the Info node "(elisp) Byte Packing" in the ELisp manual for more details. -+++ ** New macro 'with-environment-variables'. This macro allows setting environment variables temporarily when executing a form. @@ -4547,7 +3863,6 @@ executing a form. * Changes in Emacs 28.1 on Non-Free Operating Systems -+++ ** On MS-Windows, Emacs can now use the native image API to display images. Emacs can now use the MS-Windows GDI+ library to load and display images in JPEG, PNG, GIF and TIFF formats. This support is available @@ -4558,7 +3873,6 @@ To turn this on, set the variable 'w32-use-native-image-API' to a non-nil value. Please report any bugs you find while using the native image API via 'M-x report-emacs-bug'. -+++ ** On MS-Windows, Emacs can now toggle the IME. A new function 'w32-set-ime-open-status' can now be used to disable and enable the MS-Windows native Input Method Editor (IME) at run @@ -4570,26 +3884,21 @@ current IME activation status. 'move-beginning-of-line' and 'move-end-of-line' respectively. The commands to select previous/next frame are still bound to 's-~' and 's-`'. -+++ ** On macOS, Emacs can now load dynamic modules with a ".dylib" suffix. 'module-file-suffix' now has the value ".dylib" on macOS, but the ".so" suffix is supported as well. ---- ** On macOS, the user option 'make-pointer-invisible' is now honored. ---- ** On macOS, Xwidget is now supported. If Emacs was built with xwidget support, you can access the embedded webkit browser with command 'xwidget-webkit-browse-url'. Viewing two instances of xwidget webkit is not supported. ---- *** New user option 'xwidget-webkit-enable-plugins'. If non-nil, enable plugins in xwidget. (This is only available on macOS.) -+++ ** New macOS Contacts back-end for EUDC. This backend works on newer versions of macOS and is generally preferred over the eudcb-mab.el backend. diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS index e4bb706e08c..37a39131d93 100644 --- a/etc/ORG-NEWS +++ b/etc/ORG-NEWS @@ -451,10 +451,6 @@ you can now configure them. (the default) or use the attachment directory of the current node, if it is correctly configured as a Git repository. -*** Some faces now use fixed-pitch - -See [[msg:875z8njaol.fsf@protesilaos.com][this thread]]. - *** New option ~org-attach-sync-delete-empty-dir~ ~org-attach-sync-delete-empty-dir~ controls the deletion of an empty @@ -509,7 +505,7 @@ heading, except return nil. In the past, faces of todo keywords, emphasised text, tags, and priority cookies inherited =default= face. The resulting headline -fontification was not always consistent, as discussed in [[https://lists.gnu.org/archive/html/emacs-orgmode/2020-09/msg00331.html][this bug +fontification was not always consistent, as discussed in [[msg::87h7sawubl.fsf@protesilaos.com][this bug report]]. Now, the relevant faces adapt to face used to fontify the current headline level. diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 4e4ec6d353d..270de600d66 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -651,6 +651,46 @@ And then rename the system's readline so that it won't be loaded: See for more details on installation. +*** On MS-Windows, invoking "M-x run-python" signals an error. + +If the error says something like this: + + Python was not found; run with arguments to install + from the Microsoft Store, or disable this shortcut + from Settings > Manage App Execution Aliases. + + Process Python exited abnormally with code 49 + +then this is due to the MS-Windows "feature" that is intended to +encourage you to install the latest available Python version. It +works by placing "fake" python.exe and python3.exe executables in a +special directory, and having that directory on your Path _before_ the +directory where the real Python executable is installed. That "fake" +Python then decides whether to redirect you to the Microsoft Store or +invoke the actual Python. The directory where Windows keeps those +"fake" executables is under your Windows user's 'AppData' directory, +typically 'C:\Users\\AppData\Local\Microsoft\WindowsApps', where +"" is the user name of your Windows user. + +To solve this, you have several alternatives: + + . Go to "Settings > Manage App Execution Aliases" and turn OFF the + aliases for python.exe and/or python3.exe. This will affect only + Python, and may require you to manage upgrades to your Python + installation manually, instead of being automatically prompted by + MS-Windows. + . Move the directory with the "fake" executables to the end of Path, + or at least after the directory where the real Python is + installed. Depending on the position in Path where you move it, + it will affect Python and/or other programs which Windows monitors + via the "App Execution Aliases" feature. + . Manually remove python.exe and/or python3.exe from the above + directory. Again, this affects only your Python installation. + +Whatever you do, you will need to restart Emacs to refresh its notion +of the directory where python.exe/python3.exe lives, because that is +recorded when Python mode is started. + *** Visiting files in some auto-mounted directories causes Emacs to print 'Error reading dir-locals: (file-error "Read error" "is a directory" ...' @@ -1009,6 +1049,15 @@ index 5504171..431adf8 100644 If you can't modify that file directly, copy it to the directory ~/.m17n.d/ (create it if it doesn't exist), and apply the patch. +** On Haiku, some proportionally-spaced fonts display with artifacting. + +This is a Haiku bug: https://dev.haiku-os.org/ticket/17229, which can +be remedied by using a different font that does not exhibit this +problem, or by configuring Emacs '--with-be-cairo'. + +So far, Bitstream Charter and Noto Sans have been known to exhibit +this problem, while Noto Sans Display is known to not do so. + ** On MS-Windows, some characters display as boxes with hex code. Also, some characters could display with wrong fonts. @@ -1022,14 +1071,20 @@ modern fonts are used, such as Noto Emoji or Ebrima. The solution is to switch to a configuration that uses HarfBuzz as its shaping engine, where these problems don't exist. -** On Haiku, some proportionally-spaced fonts display with artifacting. +** On MS-Windows, selecting some fonts as the default font doesn't work. -This is a Haiku bug: https://dev.haiku-os.org/ticket/17229, which can -be remedied by using a different font that does not exhibit this -problem, or by configuring Emacs '--with-be-cairo'. +This can happen if you select font variants such as "Light" or "Thin" +or "Semibold" or "Heavy", and some others. The APIs used by Emacs on +Windows to enumerate fonts in a font family consider only 4 font +variants to belong to the same family: Regular, Italic, Bold, and +Bold-Italic. All the other variants aren't returned by those APIs +when we request to list all the fonts in a family, and thus aren't +considered by Emacs to belong to the family. So any font variant that +is not one of those 4 will likely not work as expected; in most cases +Emacs will select some other font instead. -So far, Bitstream Charter and Noto Sans have been known to exhibit -this problem, while Noto Sans Display is known to not do so. +The only workaround is not to choose such font variants as the default +font when running Emacs on MS-Windows. * Internationalization problems @@ -1786,6 +1841,21 @@ remote X server, try this: (setq mouse-highlight nil) +*** Dropping text on xterm doesn't work. + +Emacs sends sythetic button events to legacy clients such as xterm +that do not support either the XDND or Motif drag-and-drop protocols +in order to "paste" the text that was dropped. Unfortunately, xterm +is configured to ignore these events by default. Add the following to +your X defaults file to avoid the problem: + + XTerm.*.allowSendEvents: True + +Note that this can in theory pose a security risk, but in practice +modern X servers have so many other ways to send input to clients +without signifying that the event is synthesized that it does not +matter. + * Runtime problems on character terminals ** The meta key does not work on xterm. diff --git a/etc/images/gnus/catchup.pbm b/etc/images/gnus/catchup.pbm deleted file mode 100644 index 3fc571bdf80..00000000000 Binary files a/etc/images/gnus/catchup.pbm and /dev/null differ diff --git a/etc/images/gnus/catchup.xpm b/etc/images/gnus/catchup.xpm deleted file mode 100644 index cba849712df..00000000000 --- a/etc/images/gnus/catchup.xpm +++ /dev/null @@ -1,33 +0,0 @@ -/* XPM */ -static char * catchup_xpm[] = { -"24 24 6 1", -" c None", -". c #FFFFFFFFFFFF", -"X c #E1E1E0E0E0E0", -"o c #A5A5A5A59595", -"O c #999999999999", -"+ c #000000000000", -" ", -" ", -" ", -" ", -" ", -" ", -" ", -" . ", -" . .X ", -" ... .oX . ", -" ..oooX.oXo .X ", -" .oooXXXX..oXXoXX ", -" .oXXXX.XoX.oXooX ", -" X...X.X.XX.XoXX ", -" Xo..X.XXX.XXXX ", -" . Xo.oXX..XXXXXX ", -"OOOOXoXXXXXo.XXXXX++OOOO", -"OOOOOX..X.XXXXXXXX++OOOO", -"OOOOOX..XXXXXXXXX++OOOOO", -"OOOOOOXXXXXXXXX+++OOOOOO", -"OOOOOOOOOXXXX++++OOOOOOO", -"OOOOOOOOO+++++OOOOOOOOOO", -"OOOOOOOOOO+OOOOOOOOOOOOO", -"OOOOOOOOOOOOOOOOOOOOOOOO"}; diff --git a/etc/images/gnus/cu-exit.pbm b/etc/images/gnus/cu-exit.pbm deleted file mode 100644 index 210869cce78..00000000000 Binary files a/etc/images/gnus/cu-exit.pbm and /dev/null differ diff --git a/etc/images/gnus/cu-exit.xpm b/etc/images/gnus/cu-exit.xpm deleted file mode 100644 index 17236223fed..00000000000 --- a/etc/images/gnus/cu-exit.xpm +++ /dev/null @@ -1,31 +0,0 @@ -/* XPM */ -static char * cu_exit_xpm[] = { -"24 24 4 1", -" c None", -". c #000000000000", -"X c #FFFFFFFFFFFF", -"o c #999999999999", -" ", -" ", -" ", -" ", -" ", -" ..... ", -" .. .XXX. ", -" ..X..XXXX... ", -" .XXXX.XXXX.X... ", -" ..XXXX.XXX.XXX.. ", -" .XXX.......... ", -" .XXX.XXX.XXX.. ", -" .XX.XXX.XXX. ", -" .XX.XXX.XX.. ", -" ............ ", -" .X.X.X.X.. ", -"ooooooo..........ooooooo", -"ooooooo.X.X.X.X.oooooooo", -"ooooooo.........oooooooo", -"ooooooo..X...X..oooooooo", -"ooooooo...X.X...oooooooo", -"ooooooo........ooooooooo", -"ooooooooo.....oooooooooo", -"oooooooooooooooooooooooo"}; diff --git a/etc/images/gnus/describe-group.pbm b/etc/images/gnus/describe-group.pbm deleted file mode 100644 index de7bf110431..00000000000 Binary files a/etc/images/gnus/describe-group.pbm and /dev/null differ diff --git a/etc/images/gnus/describe-group.xpm b/etc/images/gnus/describe-group.xpm deleted file mode 100644 index b4a6f42a94b..00000000000 --- a/etc/images/gnus/describe-group.xpm +++ /dev/null @@ -1,32 +0,0 @@ -/* XPM */ -static char * describe_group_xpm[] = { -"24 24 5 1", -". c None", -" c #000000000000", -"o c #FFFFF5F5ACAC", -"+ c #E1E1E0E0E0E0", -"@ c #C7C7C6C6C6C6", -"........................", -"........................", -".................oooo...", -" .. .. .. .. .. oo oo o.", -"..............oooooooooo", -".............ooooooooooo", -" .. .. .. .. oo oo oo oo", -"............oooooooooooo", -"............oooooooooooo", -" .. .. .. .. oo oo oo oo", -"............oooooooooooo", -"............oooooooooooo", -" .. .. .. .. oo oo oo oo", -"............oooooooooooo", -"..... ...oooooooooooo", -" .. ++ .. .o oo oo oo", -"... @@@+ ....ooooooooo", -"... @ ....oooooooo.", -" . . .. .. .. ..", -". ..............", -" ................", -" .. .. .. .. .. ..", -" ..................", -" ...................."}; diff --git a/etc/images/gnus/exit-gnus.pbm b/etc/images/gnus/exit-gnus.pbm deleted file mode 100644 index 32ad0e0ebe9..00000000000 Binary files a/etc/images/gnus/exit-gnus.pbm and /dev/null differ diff --git a/etc/images/gnus/exit-gnus.xpm b/etc/images/gnus/exit-gnus.xpm deleted file mode 100644 index 534f3c2fafb..00000000000 --- a/etc/images/gnus/exit-gnus.xpm +++ /dev/null @@ -1,33 +0,0 @@ -/* XPM */ -static char * exit_gnus_xpm[] = { -"24 24 6 1", -" c None", -". c #8686ADAD7D7D", -"X c #919187876969", -"o c #C2C2B9B99C9C", -"O c #A8A8F0F0ECEC", -"+ c #EFEFEFEFEFEF", -" ", -" .... . ", -" .. .. . ", -" ............. ", -" . . . .... ", -" ............. ", -" .............. .. ", -" . . .......... . ", -" .XXXX... .. ", -" o.XXX. . .. ", -" oo.X. .. ... ", -" ooX. . ... ", -" oXo. .. ", -" ooX . . ", -" ooX ", -"OOOOoXXOOOOOOOOOOOOOOOOO", -"OOOoXoXOOOOOOOOOOOOOOOOO", -"OOOooXXOOOO+OOOOOOOOOOOO", -"O+OoooXOO+OOO+OO+OOO+OOO", -"OXXoXoXoXOO++O++OO++OO+O", -"XXXXXXXXXXXX+OOOOOOOOOOO", -"XXXXXXXXXXXXXX+O++OO++OO", -"XXXXXXXXXXXXXXXXOOOOOOOO", -"O++O++++O+OO++OOOO++OOO+"}; diff --git a/etc/images/gnus/exit-summ.pbm b/etc/images/gnus/exit-summ.pbm deleted file mode 100644 index d0192310607..00000000000 Binary files a/etc/images/gnus/exit-summ.pbm and /dev/null differ diff --git a/etc/images/gnus/exit-summ.xpm b/etc/images/gnus/exit-summ.xpm deleted file mode 100644 index 5234ccb11ec..00000000000 --- a/etc/images/gnus/exit-summ.xpm +++ /dev/null @@ -1,30 +0,0 @@ -/* XPM */ -static char * exit_summ_xpm[] = { -"24 24 3 1", -". c None", -" c #000000000000", -"X c #E1E1E0E0E0E0", -" .. .. .. .. .. .. .. ..", -"........................", -"........................", -" .. .. .. ..", -"...... XXXX .....", -"...... XXXXXXX .....", -" .. .. XX XX XX .. ..", -"...... XXXXXXXX .....", -"...... XXXXXXX .....", -" .. .. X XX .. ..", -"...... XXXX .....", -"...... XXXX .....", -" .. .. X XXXXX .. ..", -"...... XXXXXXX .....", -"...... XXXXX XX .....", -" .. .. X XXXXX .. ..", -"...... XXXXX .....", -"...... X .....", -" .. . . .. ..", -"........................", -"........................", -" .. .. .. .. .. .. .. ..", -"........................", -"........................"}; diff --git a/etc/images/gnus/get-news.pbm b/etc/images/gnus/get-news.pbm deleted file mode 100644 index c0080716c44..00000000000 Binary files a/etc/images/gnus/get-news.pbm and /dev/null differ diff --git a/etc/images/gnus/get-news.xpm b/etc/images/gnus/get-news.xpm deleted file mode 100644 index d7e7b4a3553..00000000000 --- a/etc/images/gnus/get-news.xpm +++ /dev/null @@ -1,31 +0,0 @@ -/* XPM */ -static char * get_news_xpm[] = { -"24 24 4 1", -". c None", -"X c #A5A5A5A59595", -"o c #E1E1E0E0E0E0", -"O c #C7C7C6C6C6C6", -"........................", -"........................", -"........................", -".....XXX................", -"...XXoooXXXXX...........", -"XXXoooooXXoooX.XXX......", -"XoXooXXXooooXXXoooX.....", -"XooXoXoXooXXXoooooX.....", -"XooXXXooXoXoXooooooX....", -"XooXOXooXXXooXooooooX...", -"XoXOOXooXOXooXXooooooX..", -"OXOOOXoXOOXooXoooooooX..", -"OXOooOXOOOXoXOooooooooX.", -".OXooOXOooOXOOooooooooX.", -".OXoooOXooOXOooooooooooX", -"..OXooOXoooOXooooooooooX", -"..OXooOOXooOXooooooooooX", -"...OXooOXoooOXoooooooXXX", -"...OXooXOXooOXooooooXOO.", -"....OXXOOXooXOXoooXXO...", -".....OO..OXXOOXooXOO....", -"..........OO..OXXO......", -"...............OO.......", -"........................"}; diff --git a/etc/images/gnus/gnntg.pbm b/etc/images/gnus/gnntg.pbm deleted file mode 100644 index 2f5e5261a97..00000000000 Binary files a/etc/images/gnus/gnntg.pbm and /dev/null differ diff --git a/etc/images/gnus/gnntg.xpm b/etc/images/gnus/gnntg.xpm deleted file mode 100644 index 21bc5f16eb2..00000000000 --- a/etc/images/gnus/gnntg.xpm +++ /dev/null @@ -1,31 +0,0 @@ -/* XPM */ -static char * gnntg_xpm[] = { -"24 24 4 1", -" c None", -". c #000000000000", -"X c #FFFFFFFFFFFF", -"o c #C7C7C6C6C6C6", -" ", -" ....... ", -" .XXXXX. ", -" .XXXXX. ... ", -" .XXXXX... .ooo. ", -" .XXXXX.... ..ooo.. ", -" .XXXXX..o.. ..ooo.. ", -" .XXXXX...o.. ..o.. ", -" .XXXXX. ..o........ ", -" .XXXXX. ..oooooooo. ", -" ....... .oooooooo.. ", -" .ooooo..o. ", -" .oooo..o. ", -" .oooo..o. ", -" .oooo..o. ", -" .oooo..o. ", -" ......... ", -" ......oo. ", -" .ooooo... ", -" .oo..o... ", -" .oo..o.. ", -" ........ ", -" .... ... ", -" ... ... "}; diff --git a/etc/images/gnus/important.pbm b/etc/images/gnus/important.pbm deleted file mode 100644 index 7139ff2d69e..00000000000 Binary files a/etc/images/gnus/important.pbm and /dev/null differ diff --git a/etc/images/gnus/important.xpm b/etc/images/gnus/important.xpm deleted file mode 100644 index e972facff24..00000000000 --- a/etc/images/gnus/important.xpm +++ /dev/null @@ -1,32 +0,0 @@ -/* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 2 1", -"! c red", -"w c Gray75", -/* pixels */ -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwww!!!wwwwwwwwwwww", -"wwwwwwwww!!!wwwwwwwwwwww", -"wwwwwwww!!!!!wwwwwwwwwww", -"wwwwwwww!!!!!wwwwwwwwwww", -"wwwwwww!!!!!!!wwwwwwwwww", -"wwwwwww!!!!!!!wwwwwwwwww", -"wwwwwww!!!!!!!wwwwwwwwww", -"wwwwwww!!!!!!!wwwwwwwwww", -"wwwwwww!!!!!!!wwwwwwwwww", -"wwwwwww!!!!!!!wwwwwwwwww", -"wwwwwww!!!!!!!wwwwwwwwww", -"wwwwwwww!!!!!wwwwwwwwwww", -"wwwwwwww!!!!!wwwwwwwwwww", -"wwwwwwww!!!!!wwwwwwwwwww", -"wwwwwwwww!!!wwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwww!!!wwwwwwwwwwww", -"wwwwwwww!!!!!wwwwwwwwwww", -"wwwwwwww!!!!!wwwwwwwwwww", -"wwwwwwwww!!!wwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww" -}; diff --git a/etc/images/gnus/next-ur.pbm b/etc/images/gnus/next-ur.pbm deleted file mode 100644 index 678bbb09f8b..00000000000 Binary files a/etc/images/gnus/next-ur.pbm and /dev/null differ diff --git a/etc/images/gnus/next-ur.xpm b/etc/images/gnus/next-ur.xpm deleted file mode 100644 index bea13280b68..00000000000 --- a/etc/images/gnus/next-ur.xpm +++ /dev/null @@ -1,35 +0,0 @@ -/* XPM */ -static char * next_ur_xpm[] = { -"24 24 8 1", -". c None", -" c #000000000000", -"X c #A5A5A5A59595", -"o c #C7C7C6C6C6C6", -"O c #FFFF00000000", -"+ c #9A9A6C6C4E4E", -"@ c #E1E1E0E0E0E0", -"# c #FFFFFFFFFFFF", -" .. .. .. .. .. .. .. ..", -"........................", -"............X...........", -" .. .. .. .XXX. .. .. ..", -".........XXooOX.........", -".......XXooo+O@X........", -" .. XXXoooo++@@@X. .. ..", -"....X@Xoooooo@@@X.......", -"....X@@Xooo@@@@@@X......", -" .. X@@XXoo@@@@@@@X.. ..", -"....X@@Xoo@@@@@@@@@X....", -"....X@Xo@@@XX@@@@@@oX...", -" .. oXoo@XXooO@@@@@@X ..", -"....oXoXXooo+OX@@@@Xo...", -"....XXXoooo++@@X@@Xo....", -" .. X@Xoooooo@@@XX .. ..", -"....X@@Xooo@@@@@@X......", -"....X@@XXoo@@@@@@@X.....", -" .. X@@Xoo@@@@@@@@@X. ..", -"....X@Xo@ @@@@@@@ X...", -"... oXoo ## @@ @@ ## ...", -" .. oXo #### @ #### ..", -".....oX #### @@@ #### ..", -".....oX@ ## @@@@X ## ..."}; diff --git a/etc/images/gnus/post.pbm b/etc/images/gnus/post.pbm deleted file mode 100644 index 577d6236bfd..00000000000 Binary files a/etc/images/gnus/post.pbm and /dev/null differ diff --git a/etc/images/gnus/post.xpm b/etc/images/gnus/post.xpm deleted file mode 100644 index 7a3eaa5e3b1..00000000000 --- a/etc/images/gnus/post.xpm +++ /dev/null @@ -1,35 +0,0 @@ -/* XPM */ -static char * post_xpm[] = { -"24 24 8 1", -". c None", -" c #434343434343", -"X c #A5A5A5A59595", -"O c #000000000000", -"+ c #C7C7C6C6C6C6", -"@ c #FFFF00000000", -"# c #9A9A6C6C4E4E", -"$ c #E1E1E0E0E0E0", -"O..O..O..O..O..O..O..O..", -"........................", -"............X...........", -"O..O..O..O.XXX.O..O..O..", -".........XX++@X.........", -".......XX+++#@$X........", -"O..OXXX++++##$$$X.O..O..", -"....X$X++++++$$$X.......", -"....X$$X+++$$$$$$X......", -"O..OX$$XX++$$$$$$$X..O..", -"....X$$X++$$$$$$$$$X....", -"....X$X+$$$$$$$$$$$+X...", -"O..O+X++$$$$$$$$$$$$XO..", -"....+X+$$$$$$$$$$$$X+...", -".....+X$$$$$$$$$$$X+....", -"O..O.+X$$$$$$$$$XXO..O..", -"......+X$$$$$$$X++......", -"......+X$$$$$XX+........", -"O..O..O+X$$$X++O..O..O..", -".......+X$$X++..........", -"........+XX+............", -"O..O..O..O+.O..O..O..O..", -"........................", -"........................"}; diff --git a/etc/images/gnus/prev-ur.pbm b/etc/images/gnus/prev-ur.pbm deleted file mode 100644 index 49389198bdf..00000000000 Binary files a/etc/images/gnus/prev-ur.pbm and /dev/null differ diff --git a/etc/images/gnus/prev-ur.xpm b/etc/images/gnus/prev-ur.xpm deleted file mode 100644 index 80131332832..00000000000 --- a/etc/images/gnus/prev-ur.xpm +++ /dev/null @@ -1,35 +0,0 @@ -/* XPM */ -static char * prev_ur_xpm[] = { -"24 24 8 1", -". c None", -" c #000000000000", -"X c #A5A5A5A59595", -"o c #C7C7C6C6C6C6", -"O c #FFFF00000000", -"+ c #9A9A6C6C4E4E", -"@ c #E1E1E0E0E0E0", -"# c #FFFFFFFFFFFF", -" .. .. .. .. .. .. .. ..", -"........................", -"............X...........", -" .. .. .. .XXX. .. .. ..", -".........XXooOX.........", -".......XXooo+O@X........", -" .. XXXoooo++@@@X. .. ..", -"....X@Xoooooo@@@X.......", -"....X@@Xooo@@@@@@X......", -" .. X@@XXoo@@@@@@@X.. ..", -"....X@@Xo @@@@@@ X....", -"....X@Xo ## X @ ## X...", -" .. oXo #XXXoO@ #### ..", -"....oXoXXooo+OX #### ...", -"....XXXoooo++@@X ## ....", -" .. X@Xoooooo@@@X .. ..", -"....X@@Xooo@@@@@@X......", -"....X@@XXoo@@@@@@@X.....", -" .. X@@Xoo@@@@@@@@@X. ..", -"....X@Xo@@@@@@@@@@@@X...", -"... oXoo@@@@@@@@@@@@X...", -" .. oXo@@@@@@@@@@@@X....", -".....oX@@@@@@@@@@@X.....", -".....oX@@@@@@@@@@X......"}; diff --git a/etc/images/gnus/receipt.pbm b/etc/images/gnus/receipt.pbm deleted file mode 100644 index 5595239f40d..00000000000 Binary files a/etc/images/gnus/receipt.pbm and /dev/null differ diff --git a/etc/images/gnus/receipt.xpm b/etc/images/gnus/receipt.xpm deleted file mode 100644 index 18caaf1cf78..00000000000 --- a/etc/images/gnus/receipt.xpm +++ /dev/null @@ -1,32 +0,0 @@ -/* XPM */ -static char * receipt_xpm[] = { -"24 24 5 1", -" c None", -". c #FFFFFFFFFFFF", -"X c #676766666363", -"o c #FFFF00000000", -"O c #AEAE3E3E4848", -" ", -" ", -" .. ", -" . ", -" . ", -" . ", -" .. ", -" Xooo .. ", -" Xoooooooo.. ", -" Xoooooooooooooo ... ", -" oooooooooooOOoo . ", -" ooooooooooOOOOo. ", -" oooooooooOO...o ", -" ooooooooooOOooo ", -" ooooooooooooooo ", -" ooooooooooooooo ", -" oooooooooooooo ", -" ooooooooooo ", -" ooooooo ", -" oooo ", -" oo ", -" ", -" ", -" "}; diff --git a/etc/images/gnus/reply-wo.pbm b/etc/images/gnus/reply-wo.pbm deleted file mode 100644 index def54da8ede..00000000000 Binary files a/etc/images/gnus/reply-wo.pbm and /dev/null differ diff --git a/etc/images/gnus/reply-wo.xpm b/etc/images/gnus/reply-wo.xpm deleted file mode 100644 index 370678af70d..00000000000 --- a/etc/images/gnus/reply-wo.xpm +++ /dev/null @@ -1,31 +0,0 @@ -/* XPM */ -static char * reply_wo_xpm[] = { -"24 24 4 1", -" c None", -". c #000000000000", -"X c #E1E1E0E0E0E0", -"O c #FFFFFFFFFFFF", -" ", -" ", -" ", -" .... ", -" ..X.... ", -" ..XX.XX.. ", -" .O.XX.XXXX.. ", -" ..O.XXX.XXXX... ", -" .OO.XXXX.X....... ", -" .OO.XXXX...XXX.OO.. ", -" ..OO.XX....XXXX.OOOO.. ", -" .......XX.XXXX.OOO.... ", -" .OOO.XXX.XXXX.OO..OOO. ", -" .OOOO....XXX....OOOOO. ", -" .OOOOOOO..XX..OOOOOOO. ", -" .OOOOOOO......OOOOOOO. ", -" .OOOOOO.OO..O..OOOOOO. ", -" .OOOOO.OOOOOOOO.OOOOO. ", -" .OOOO.OOOOOOOOOO.OOOO. ", -" .OOO.OOOOOOOOOOOO.OOO. ", -" .O..OOOOOOOOOOOOOO..O. ", -" ..OOOOOOOOOOOOOOOOOO.. ", -" ...................... ", -" "}; diff --git a/etc/images/gnus/reply.pbm b/etc/images/gnus/reply.pbm deleted file mode 100644 index ee181e663be..00000000000 Binary files a/etc/images/gnus/reply.pbm and /dev/null differ diff --git a/etc/images/gnus/reply.xpm b/etc/images/gnus/reply.xpm deleted file mode 100644 index a45884803fe..00000000000 --- a/etc/images/gnus/reply.xpm +++ /dev/null @@ -1,31 +0,0 @@ -/* XPM */ -static char * reply_xpm[] = { -"24 24 4 1", -" c None", -". c #000000000000", -"X c #E1E1E0E0E0E0", -"O c #FFFFFFFFFFFF", -" ", -" ", -" ", -" .... ", -" ..XXX.. ", -" ..XXXXX.. ", -" .O.XXXXXXX.. ", -" ..O.XXXXXXXXX.. ", -" .OO.XXXXXXXXXX... ", -" .OO.XXXXXXXXXX.OO.. ", -" ..OO.XXXXXXXXXX.OOOO.. ", -" .....XXXXXXXXX.OOO.... ", -" .OOO.XXXXXXXX.OO..OOO. ", -" .OOOO...XXXXX...OOOOO. ", -" .OOOOOOO..XX..OOOOOOO. ", -" .OOOOOOO......OOOOOOO. ", -" .OOOOOO.OO..O..OOOOOO. ", -" .OOOOO.OOOOOOOO.OOOOO. ", -" .OOOO.OOOOOOOOOO.OOOO. ", -" .OOO.OOOOOOOOOOOO.OOO. ", -" .O..OOOOOOOOOOOOOO..O. ", -" ..OOOOOOOOOOOOOOOOOO.. ", -" ...................... ", -" "}; diff --git a/etc/images/gnus/rot13.pbm b/etc/images/gnus/rot13.pbm deleted file mode 100644 index 800d9d6327b..00000000000 Binary files a/etc/images/gnus/rot13.pbm and /dev/null differ diff --git a/etc/images/gnus/rot13.xpm b/etc/images/gnus/rot13.xpm deleted file mode 100644 index 18faa3e92da..00000000000 --- a/etc/images/gnus/rot13.xpm +++ /dev/null @@ -1,128 +0,0 @@ -/* XPM */ -static char * rot13_xpm[] = { -"24 24 101 2", -" g None", -". g #000000", -"+ g #212121", -"@ g #9E9E9E", -"# g #E6E6E6", -"$ g #E7E7E7", -"% g #C8C8C8", -"& g #A0A0A0", -"* g #131313", -"= g #5F5F5F", -"- g #EDEDED", -"; g #D6D6D6", -"> g #D5D5D5", -", g #DDDDDD", -"' g #D8D8D8", -") g #A1A1A1", -"! g #3C3C3C", -"~ g #353535", -"{ g #EFEFEF", -"] g #CFCFCF", -"^ g #4C4C4C", -"/ g #141414", -"( g #6A6A6A", -"_ g #D0D0D0", -": g #B2B2B2", -"< g #454545", -"[ g #E2E2E2", -"} g #292929", -"| g #0F0F0F", -"1 g #949494", -"2 g #E9E9E9", -"3 g #C3C3C3", -"4 g #1C1C1C", -"5 g #E1E1E1", -"6 g #272727", -"7 g #DEDEDE", -"8 g #B6B6B6", -"9 g #0C0C0C", -"0 g #262626", -"a g #1F1F1F", -"b g #616161", -"c g #5B5B5B", -"d g #232323", -"e g #111111", -"f g #181818", -"g g #3D3D3D", -"h g #636363", -"i g #545454", -"j g #2E2E2E", -"k g #242424", -"l g #070707", -"m g #DCDCDC", -"n g #D3D3D3", -"o g #C5C5C5", -"p g #C2C2C2", -"q g #BFBFBF", -"r g #B5B5B5", -"s g #696969", -"t g #ACACAC", -"u g #999999", -"v g #8F8F8F", -"w g #868686", -"x g #686868", -"y g #B1B1B1", -"z g #9A9A9A", -"A g #909090", -"B g #878787", -"C g #DBDBDB", -"D g #A6A6A6", -"E g #979797", -"F g #8A8A8A", -"G g #8D8D8D", -"H g #838383", -"I g #666666", -"J g #BBBBBB", -"K g #9F9F9F", -"L g #8B8B8B", -"M g #828282", -"N g #676767", -"O g #A3A3A3", -"P g #8E8E8E", -"Q g #888888", -"R g #8C8C8C", -"S g #BABABA", -"T g #818181", -"U g #757575", -"V g #DADADA", -"W g #AFAFAF", -"X g #848484", -"Y g #7F7F7F", -"Z g #7B7B7B", -"` g #B8B8B8", -" . g #D9D9D9", -".. g #ABABAB", -"+. g #929292", -"@. g #939393", -"#. g #808080", -"$. g #919191", -"%. g #ADADAD", -"&. g #969696", -"*. g #4A4A4A", -" ", -" ", -" . . . . . ", -" . + @ # $ % & * ", -" . = - # ; > , ' ) ! . ", -" ~ { ] ^ . . / ( _ : < ", -" . [ ' } . | ( % 1 . ", -" * 2 3 . 4 5 @ . ", -" 6 7 8 . . $ 8 . ", -" 9 0 a b c d e 6 a f a g h i j k l ", -" . 7 m ' ; n o p p p p q r r r s . ", -" . 7 p 8 : t t t t t t t u v w x . ", -" . m p 8 y t t t t t t t z A B s . ", -" . C p r D E E E E E E A F G H I . ", -" . , p 8 J t t t t t t t K L M N . ", -" . m p y O E E E E E E P Q R H ( . ", -" . m p r S t t t t t t t K L T U . ", -" . V p W & E E E E E E F X B Y Z . ", -" . C p y ` t t t t t t t K F B T . ", -" . .p W ..E E E E E E E +.G @.#.. ", -" . $.%.z &.A L F F G $.A A P X *.. ", -" . . . . . . . . . . . . . . . ", -" ", -" "}; diff --git a/etc/images/gnus/save-aif.pbm b/etc/images/gnus/save-aif.pbm deleted file mode 100644 index 15829c289e7..00000000000 Binary files a/etc/images/gnus/save-aif.pbm and /dev/null differ diff --git a/etc/images/gnus/save-aif.xpm b/etc/images/gnus/save-aif.xpm deleted file mode 100644 index f0325ac2fb9..00000000000 --- a/etc/images/gnus/save-aif.xpm +++ /dev/null @@ -1,33 +0,0 @@ -/* XPM */ -static char * save_aif_xpm[] = { -"24 24 6 1", -" c None", -". c #999999999999", -"X c #E1E1E0E0E0E0", -"o c #C7C7C6C6C6C6", -"O c #000000000000", -"+ c #FFFFFFFFFFFF", -" ", -" ", -" ............. ", -" .XXXXXXXXXX.X.. ", -" .XXXXXXXXXX.XX. ", -" .XXXXXXXXXX.... ", -" .XXXXXXXXXXooo. ", -" .XXXXXXXXXXXXX. ", -" .XXXXXXXXXXXXX. ", -" .XXXXXXXXXXXXX. ", -" OOOOOOOOOOOOOOXXXXXX. ", -" O..O+++++++O.OXXXXXX. ", -" O..O+++++++O.OXXXXXX. ", -" O..O+++++++O.OXXXXXX. ", -" O..O+++++++O.OXXXXXX. ", -" O..O+++++++O.OXXXXXX. ", -" O..OOOOOOOOO.OXXXXXX. ", -" O............OXXXXXX. ", -" O............OXXXXXX. ", -" O..OOOOOOOOO.O....... ", -" O..OoooooO++.O ", -" O..OoooooO++.O ", -" O.OoooooO++.O ", -" OOOOOOOOOOOO "}; diff --git a/etc/images/gnus/save-art.pbm b/etc/images/gnus/save-art.pbm deleted file mode 100644 index 68fe0cb3098..00000000000 Binary files a/etc/images/gnus/save-art.pbm and /dev/null differ diff --git a/etc/images/gnus/save-art.xpm b/etc/images/gnus/save-art.xpm deleted file mode 100644 index fe9726fa3fe..00000000000 --- a/etc/images/gnus/save-art.xpm +++ /dev/null @@ -1,32 +0,0 @@ -/* XPM */ -static char * save_art_xpm[] = { -"24 24 5 1", -" c None", -". c #000000000000", -"X c #FFFFFFFFFFFF", -"o c #999999999999", -"O c #C7C7C6C6C6C6", -" ", -" ", -" .................. ", -" ...XXXXXXXXXXXXX.. ", -" .XX..XXXXXXXXX..X. ", -" .XXXX..XXXXX..XXX. ", -" .XXXXX......XXXXX. ", -" .XXX..XX..XX..XXX. ", -" .XX..XXXXXXXX..XX. ", -" ...XXXXXXXXXXXX... ", -" ..............XXXXXXX. ", -" .oo.XXXXXXX.o......... ", -" .oo.XXXXXXX.o. ", -" .oo.XXXXXXX.o. ", -" .oo.XXXXXXX.o. ", -" .oo.XXXXXXX.o. ", -" .oo.........o. ", -" .oooooooooooo. ", -" .oooooooooooo. ", -" .oo.........o. ", -" .oo.OOOOO.XXo. ", -" .oo.OOOOO.XXo. ", -" .o.OOOOO.XXo. ", -" ............ "}; diff --git a/etc/images/gnus/subscribe.pbm b/etc/images/gnus/subscribe.pbm deleted file mode 100644 index fe6b3920d36..00000000000 Binary files a/etc/images/gnus/subscribe.pbm and /dev/null differ diff --git a/etc/images/gnus/subscribe.xpm b/etc/images/gnus/subscribe.xpm deleted file mode 100644 index ff193a9e8ab..00000000000 --- a/etc/images/gnus/subscribe.xpm +++ /dev/null @@ -1,32 +0,0 @@ -/* XPM */ -static char * subscribe_xpm[] = { -"24 24 5 1", -" c None", -". c #A5A5A5A59595", -"X c #E1E1E0E0E0E0", -"o c #C7C7C6C6C6C6", -"O c #8686ADAD7D7D", -" ", -" ", -" ", -" ... ", -" ..XXX..... ", -"...XXXXX..XXX. ... ", -".X.XX...XXXX...XXX. ", -".XX.X.X.XX...XXXXX. ", -".XX...XX.X.X.XXXXXX. ", -".XX.o.XX...XX.XXXXXX. ", -".X.oo.XX.o.XX..XXXXXX. ", -"o.ooo.X.oo.XX.XXXOXXX. ", -"o.oXXo.ooo.X.oXXOXXXXX. ", -" o.XXo.oXXo.ooXXOXXXXX. ", -" o.XXXo.XXo.oXXXOXXXXXX.", -" o.XXo.XXXo.XOOOOXXXXX.", -" o.XXoo.XXo.XXXOOXXXXX.", -" o.XXo.XXXo.XXXXXXX...", -" o.XX.o.XXo.XXXXXX.oo ", -" o..oo.XX.o.XXX..o ", -" oo o..oo.XX.oo ", -" oo o..o ", -" oo ", -" "}; diff --git a/etc/images/gnus/unimportant.pbm b/etc/images/gnus/unimportant.pbm deleted file mode 100644 index 26a87216247..00000000000 Binary files a/etc/images/gnus/unimportant.pbm and /dev/null differ diff --git a/etc/images/gnus/unimportant.xpm b/etc/images/gnus/unimportant.xpm deleted file mode 100644 index 4298224e56c..00000000000 --- a/etc/images/gnus/unimportant.xpm +++ /dev/null @@ -1,32 +0,0 @@ -/* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 2 1", -"! c blue", -"w c Gray75", -/* pixels */ -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwww!!!wwwwwwwwww", -"wwwwwwwwwww!!!wwwwwwwwww", -"wwwwwwwwwww!!!wwwwwwwwww", -"wwwwwwwwwww!!!wwwwwwwwww", -"wwwwwwwwwww!!!wwwwwwwwww", -"wwwwwwwwwww!!!wwwwwwwwww", -"wwwwwwwwwww!!!wwwwwwwwww", -"wwwwwwwwwww!!!wwwwwwwwww", -"wwwwwwwwwww!!!wwwwwwwwww", -"wwwwwwwwwww!!!wwwwwwwwww", -"ww!!!wwwwww!!!wwwwww!!!w", -"www!!!wwwww!!!wwwww!!!ww", -"wwww!!!wwww!!!wwww!!!www", -"wwwww!!!www!!!www!!!wwww", -"wwwwww!!!ww!!!ww!!!wwwww", -"wwwwwww!!!w!!!w!!!wwwwww", -"wwwwwwww!!!!!!!!!wwwwwww", -"wwwwwwwww!!!!!!!wwwwwwww", -"wwwwwwwwww!!!!!wwwwwwwww", -"wwwwwwwwwww!!!wwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww" -}; diff --git a/etc/images/gnus/unsubscribe.pbm b/etc/images/gnus/unsubscribe.pbm deleted file mode 100644 index 7d869fb53fe..00000000000 Binary files a/etc/images/gnus/unsubscribe.pbm and /dev/null differ diff --git a/etc/images/gnus/unsubscribe.xpm b/etc/images/gnus/unsubscribe.xpm deleted file mode 100644 index a91180d00f8..00000000000 --- a/etc/images/gnus/unsubscribe.xpm +++ /dev/null @@ -1,32 +0,0 @@ -/* XPM */ -static char * unsubscribe_xpm[] = { -"24 24 5 1", -" c None", -". c #A5A5A5A59595", -"X c #E1E1E0E0E0E0", -"o c #C7C7C6C6C6C6", -"O c #FFFF00000000", -" ", -" ", -" ", -" ... ", -" ..XXX..... ", -"...XXXXX..XXX. ... ", -".X.XX...XXXX...XXX. ", -".XX.X.X.XX...XXXXX. ", -".XX...XX.X.X.XXXXXX. ", -".XX.o.XX...XX.XXXXXX. ", -".X.oo.XX.o.XX..XXXXXX. ", -"o.ooo.X.oo.XX.XXXXXXX. ", -"o.oXXo.ooo.X.oXXXXXXXX. ", -" o.XXo.oXXo.ooXXOXXXXX. ", -" o.XXXo.XXo.oXXXOXXXXXX.", -" o.XXo.XXXo.XOOOXXXXXX.", -" o.XXoo.XXo.XoOOOXXXXX.", -" o.XXo.XXXo.XOoOXXX...", -" o.XX.o.XXo.XOXoXX.oo ", -" o..oo.XX.o.oXX..o ", -" oo o..oo.XX.oo ", -" oo o..o ", -" oo ", -" "}; diff --git a/etc/images/gnus/uu-decode.pbm b/etc/images/gnus/uu-decode.pbm deleted file mode 100644 index 2b7fada1473..00000000000 Binary files a/etc/images/gnus/uu-decode.pbm and /dev/null differ diff --git a/etc/images/gnus/uu-decode.xpm b/etc/images/gnus/uu-decode.xpm deleted file mode 100644 index b9d940cc99e..00000000000 --- a/etc/images/gnus/uu-decode.xpm +++ /dev/null @@ -1,36 +0,0 @@ -/* XPM */ -static char * uu_decode_xpm[] = { -"24 24 9 1", -" c None", -". c #919187876969", -"X c #C2C2B9B99C9C", -"o c #868686868686", -"O c #8F8F8F8F8F8F", -"+ c #000000000000", -"@ c #4C4C4C4C4C4C", -"# c #E9E9EFEFE8E8", -"$ c #8686ADAD7D7D", -" ", -" ", -" ", -" .............. ", -" X.o.........O.++ ", -" XX++++++++++..++ ", -" XX@########+..++ ", -" XX@########+..++ ", -" XX@$#$$$#$#+..++ ", -" XX@#$$$$$$#+..++ ", -" XX@##$#####+..++ ", -" XX@##$#$$##+..++ ", -" XX@##$#$$##+..++ ", -" XX@##$$#$$#+..++ ", -" XX@######$#+..++ ", -" XX@########+..++ ", -" XX@########+..++ ", -" XX.@@@@@@@@@..++ ", -" X.XXXXXXXXXX..++ ", -" .XXXXXXXXXXXX.++ ", -" +++++++++++++++ ", -" +++++++++++++++ ", -" ", -" "}; diff --git a/etc/images/gnus/uu-post.pbm b/etc/images/gnus/uu-post.pbm deleted file mode 100644 index a5face70980..00000000000 Binary files a/etc/images/gnus/uu-post.pbm and /dev/null differ diff --git a/etc/images/gnus/uu-post.xpm b/etc/images/gnus/uu-post.xpm deleted file mode 100644 index 7c4204c6957..00000000000 --- a/etc/images/gnus/uu-post.xpm +++ /dev/null @@ -1,35 +0,0 @@ -/* XPM */ -static char * uu_post_xpm[] = { -"24 24 8 1", -". c None", -"X c #000000000000", -"+ c #C2C2B9B99C9C", -"@ c #919187876969", -"# c #868686868686", -"% c #4C4C4C4C4C4C", -"& c #E9E9EFEFE8E8", -"* c #8686ADAD7D7D", -"X..X..X..X.XX..X..X..X..", -"..........X.X...........", -".........X...X..........", -"X..X..X.XX..X.XX..X..X..", -".......X.......X........", -"......X.........X.......", -"X..X+X@@@@@@@@@@@XX..X..", -"....+@@@@@@@@@@@@@......", -"....++XXXXXXXXXX@@......", -"X..X++%&&&&&&&&X@@X..X..", -"....++%&&&&&&&&X@@......", -"....++%*&***&*&X@@......", -"X..X++%&******&X@@X..X..", -"....++%&&*&&&&&X@@......", -"....++%&&*&**&&X@@......", -"X..X++%&&*&**&&X@@X..X..", -"....++%&&**&**&X@@......", -"....++%&&&&&&*&X@@......", -"X..X++%&&&&&&&&X@@X..X..", -"....++%&&&&&&&&X@@......", -"....++@%%%%%%%%%@@......", -"X..X+@++++++++++@@X..X..", -"....+++++++++++++@......", -"........................"}; diff --git a/etc/publicsuffix.txt b/etc/publicsuffix.txt index 3cf06f92bbf..220ad30e484 100644 --- a/etc/publicsuffix.txt +++ b/etc/publicsuffix.txt @@ -22,8 +22,7 @@ org.ac ad nom.ad -// ae : https://en.wikipedia.org/wiki/.ae -// see also: "Domain Name Eligibility Policy" at http://www.aeda.ae/eng/aepolicy.php +// ae : https://tdra.gov.ae/en/aeda/ae-policies ae co.ae net.ae @@ -7131,7 +7130,7 @@ org.zw // newGTLDs -// List of new gTLDs imported from https://www.icann.org/resources/registries/gtlds/v2/gtlds.json on 2022-02-18T15:13:38Z +// List of new gTLDs imported from https://www.icann.org/resources/registries/gtlds/v2/gtlds.json on 2022-04-30T15:14:46Z // This list is auto-generated, don't edit it manually. // aaa : 2015-02-26 American Automobile Association, Inc. aaa @@ -7334,7 +7333,7 @@ audi // audible : 2015-06-25 Amazon Registry Services, Inc. audible -// audio : 2014-03-20 UNR Corp. +// audio : 2014-03-20 XYZ.COM LLC audio // auspost : 2015-08-13 Australian Postal Corporation @@ -7472,7 +7471,7 @@ bio // black : 2014-01-16 Afilias Limited black -// blackfriday : 2014-01-16 UNR Corp. +// blackfriday : 2014-01-16 Registry Services, LLC blackfriday // blockbuster : 2015-07-30 Dish DBS Corporation @@ -7703,7 +7702,7 @@ cheap // chintai : 2015-06-11 CHINTAI Corporation chintai -// christmas : 2013-11-21 UNR Corp. +// christmas : 2013-11-21 XYZ.COM LLC christmas // chrome : 2014-07-24 Charleston Road Registry Inc. @@ -7952,7 +7951,7 @@ dhl // diamonds : 2013-09-22 Binky Moon, LLC diamonds -// diet : 2014-06-26 UNR Corp. +// diet : 2014-06-26 XYZ.COM LLC diet // digital : 2014-03-06 Binky Moon, LLC @@ -8198,7 +8197,7 @@ flir // florist : 2013-11-07 Binky Moon, LLC florist -// flowers : 2014-10-09 UNR Corp. +// flowers : 2014-10-09 XYZ.COM LLC flowers // fly : 2014-05-08 Charleston Road Registry Inc. @@ -8285,7 +8284,7 @@ gallo // gallup : 2015-02-19 Gallup, Inc. gallup -// game : 2015-05-28 UNR Corp. +// game : 2015-05-28 XYZ.COM LLC game // games : 2015-05-28 Dog Beach, LLC @@ -8309,7 +8308,7 @@ gdn // gea : 2014-12-04 GEA Group Aktiengesellschaft gea -// gent : 2014-01-23 COMBELL NV +// gent : 2014-01-23 Easyhost BV gent // genting : 2015-03-12 Resorts World Inc Pte. Ltd. @@ -8420,7 +8419,7 @@ guge // guide : 2013-09-13 Binky Moon, LLC guide -// guitars : 2013-11-14 UNR Corp. +// guitars : 2013-11-14 XYZ.COM LLC guitars // guru : 2013-08-27 Binky Moon, LLC @@ -8468,7 +8467,7 @@ hermes // hgtv : 2015-07-02 Lifestyle Domain Holdings, Inc. hgtv -// hiphop : 2014-03-06 UNR Corp. +// hiphop : 2014-03-06 Dot Hip Hop, LLC hiphop // hisamitsu : 2015-07-16 Hisamitsu Pharmaceutical Co.,Inc. @@ -8516,7 +8515,7 @@ hospital // host : 2014-04-17 Radix FZC host -// hosting : 2014-05-29 UNR Corp. +// hosting : 2014-05-29 XYZ.COM LLC hosting // hot : 2015-08-27 Amazon Registry Services, Inc. @@ -8885,7 +8884,7 @@ locus // loft : 2015-07-30 Annco, Inc. loft -// lol : 2015-01-30 UNR Corp. +// lol : 2015-01-30 XYZ.COM LLC lol // london : 2013-11-14 Dot London Domains Limited @@ -9041,7 +9040,7 @@ moe // moi : 2014-12-18 Amazon Registry Services, Inc. moi -// mom : 2015-04-16 UNR Corp. +// mom : 2015-04-16 XYZ.COM LLC mom // monash : 2013-09-30 Monash University @@ -9308,7 +9307,7 @@ philips // phone : 2016-06-02 Dish DBS Corporation phone -// photo : 2013-11-14 UNR Corp. +// photo : 2013-11-14 Registry Services, LLC photo // photography : 2013-09-20 Binky Moon, LLC @@ -9320,7 +9319,7 @@ photos // physio : 2014-05-01 PhysBiz Pty Ltd physio -// pics : 2013-11-14 UNR Corp. +// pics : 2013-11-14 XYZ.COM LLC pics // pictet : 2014-06-26 Pictet Europe S.A. @@ -9551,7 +9550,7 @@ rsvp // rugby : 2016-12-15 World Rugby Strategic Developments Limited rugby -// ruhr : 2013-10-02 regiodot GmbH & Co. KG +// ruhr : 2013-10-02 dotSaarland GmbH ruhr // run : 2015-03-19 Binky Moon, LLC @@ -9902,7 +9901,7 @@ tatamotors // tatar : 2014-04-24 Limited Liability Company "Coordination Center of Regional Domain of Tatarstan Republic" tatar -// tattoo : 2013-08-30 UNR Corp. +// tattoo : 2013-08-30 Top Level Design, LLC tattoo // tax : 2014-03-20 Binky Moon, LLC @@ -9995,7 +9994,7 @@ toray // toshiba : 2014-04-10 TOSHIBA Corporation toshiba -// total : 2015-08-06 Total SA +// total : 2015-08-06 TOTAL SE total // tours : 2015-01-22 Binky Moon, LLC @@ -10633,6 +10632,12 @@ hlx3.page // Submitted by Przemyslaw Plewa beep.pl +// Airkit : https://www.airkit.com/ +// Submitted by Grant Cooksey +airkitapps.com +airkitapps-au.com +airkitapps.eu + // Aiven: https://aiven.io/ // Submitted by Etienne Stalmans aivencloud.com @@ -10827,7 +10832,7 @@ onavstack.net *.advisor.ws // AZ.pl sp. z.o.o: https://az.pl -// Submited by Krzysztof Wolski +// Submitted by Krzysztof Wolski ecommerce-shop.pl // b-data GmbH : https://www.b-data.io @@ -11241,6 +11246,11 @@ deno-staging.dev // Submitted by Peter Thomassen dedyn.io +// Deta: https://www.deta.sh/ +// Submitted by Aavash Shrestha +deta.app +deta.dev + // Diher Solutions : https://diher.solutions // Submitted by Didi Hermawan *.rss.my.id @@ -11658,6 +11668,11 @@ en-root.fr mytuleap.com tuleap-partners.com +// Encoretivity AB: https://encore.dev +// Submitted by André Eriksson +encr.app +encoreapi.com + // ECG Robotics, Inc: https://ecgrobotics.org // Submitted by onred.one @@ -11870,8 +11885,6 @@ app.os.stg.fedoraproject.org // FearWorks Media Ltd. : https://fearworksmedia.co.uk // submitted by Keith Fairley -couk.me -ukco.me conn.uk copro.uk hosp.uk @@ -11984,6 +11997,7 @@ independent-panel.uk independent-review.uk public-inquiry.uk royal-commission.uk +campaign.gov.uk service.gov.uk // CDDO : https://www.gov.uk/guidance/get-an-api-domain-on-govuk @@ -12277,7 +12291,7 @@ günstigbestellen.de günstigliefern.de // Hakaran group: http://hakaran.cz -// Submited by Arseniy Sokolov +// Submitted by Arseniy Sokolov fin.ci free.hr caa.li @@ -12320,7 +12334,7 @@ development.run ravendb.run // home.pl S.A.: https://home.pl -// Submited by Krzysztof Wolski +// Submitted by Krzysztof Wolski homesklep.pl // Hong Kong Productivity Council: https://www.hkpc.org/ @@ -12430,7 +12444,7 @@ to.leg.br pixolino.com // Internet-Pro, LLP: https://netangels.ru/ -// Submited by Vasiliy Sheredeko +// Submitted by Vasiliy Sheredeko na4u.ru // iopsys software solutions AB : https://iopsys.eu/ @@ -12453,7 +12467,7 @@ iserv.dev iobb.net // Jelastic, Inc. : https://jelastic.com/ -// Submited by Ihor Kolodyuk +// Submitted by Ihor Kolodyuk mel.cloudlets.com.au cloud.interhostsolutions.be users.scale.virtualcloud.com.br @@ -12653,6 +12667,10 @@ ip.linodeusercontent.com // Submitted by Victor Velchev we.bs +// Localcert : https://localcert.dev +// Submitted by Lann Martin +*.user.localcert.dev + // localzone.xyz // Submitted by Kenny Niehage localzone.xyz @@ -12780,12 +12798,13 @@ eu.meteorapp.com co.pl // Microsoft Corporation : http://microsoft.com -// Submitted by Mitch Webster +// Submitted by Public Suffix List Admin *.azurecontainer.io azurewebsites.net azure-mobile.net cloudapp.net azurestaticapps.net +1.azurestaticapps.net centralus.azurestaticapps.net eastasia.azurestaticapps.net eastus2.azurestaticapps.net @@ -13080,7 +13099,7 @@ operaunite.com tech.orange // Oursky Limited : https://authgear.com/, https://skygear.io/ -// Submited by Authgear Team , Skygear Developer +// Submitted by Authgear Team , Skygear Developer authgear-staging.com authgearapps.com skygearapp.com @@ -13379,6 +13398,34 @@ sandcats.io logoip.de logoip.com +// Scaleway : https://www.scaleway.com/ +// Submitted by Rémy Léone +fr-par-1.baremetal.scw.cloud +fr-par-2.baremetal.scw.cloud +nl-ams-1.baremetal.scw.cloud +fnc.fr-par.scw.cloud +functions.fnc.fr-par.scw.cloud +k8s.fr-par.scw.cloud +nodes.k8s.fr-par.scw.cloud +s3.fr-par.scw.cloud +s3-website.fr-par.scw.cloud +whm.fr-par.scw.cloud +priv.instances.scw.cloud +pub.instances.scw.cloud +k8s.scw.cloud +k8s.nl-ams.scw.cloud +nodes.k8s.nl-ams.scw.cloud +s3.nl-ams.scw.cloud +s3-website.nl-ams.scw.cloud +whm.nl-ams.scw.cloud +k8s.pl-waw.scw.cloud +nodes.k8s.pl-waw.scw.cloud +s3.pl-waw.scw.cloud +s3-website.pl-waw.scw.cloud +scalebook.scw.cloud +smartlabeling.scw.cloud +dedibox.fr + // schokokeks.org GbR : https://schokokeks.org/ // Submitted by Hanno Böck schokokeks.net @@ -13499,6 +13546,8 @@ srht.site stackhero-network.com // Staclar : https://staclar.com +// Submitted by Q Misell +musician.io // Submitted by Matthias Merkel novecore.site @@ -13597,19 +13646,20 @@ syncloud.it // Synology, Inc. : https://www.synology.com/ // Submitted by Rony Weng -diskstation.me dscloud.biz -dscloud.me -dscloud.mobi +direct.quickconnect.cn dsmynas.com -dsmynas.net -dsmynas.org familyds.com -familyds.net -familyds.org +diskstation.me +dscloud.me i234.me myds.me synology.me +dscloud.mobi +dsmynas.net +familyds.net +dsmynas.org +familyds.org vpnplus.to direct.quickconnect.to @@ -13742,6 +13792,10 @@ syno-ds.de synology-diskstation.de synology-ds.de +// Typedream : https://typedream.com +// Submitted by Putri Karunia +typedream.app + // Typeform : https://www.typeform.com // Submitted by Sergi Ferriz pro.typeform.com diff --git a/etc/refcards/Makefile b/etc/refcards/Makefile index 6f8913c5f01..4c5daa9f44c 100644 --- a/etc/refcards/Makefile +++ b/etc/refcards/Makefile @@ -233,10 +233,11 @@ pl-refcard.pdf: $(pl_refcard_deps) fi $(ENVADD) pdftex -output-format=pdf pl-refcard.tex pl-refcard.dvi: $(pl_refcard_deps) - if ! kpsewhich -format=fmt mex > /dev/null; then \ - echo "No mex format found."; false; \ + if kpsewhich -format=fmt mex > /dev/null; then \ + $(ENVADD) tex pl-refcard.tex; \ + else \ + $(ENVADD) mex pl-refcard.tex; \ fi - $(ENVADD) tex pl-refcard.tex pl-refcard.ps: pl-refcard.dvi dvips -t a4 -o $@ pl-refcard.dvi diff --git a/etc/refcards/orgcard.tex b/etc/refcards/orgcard.tex index dec4d174c43..2b4718805a6 100644 --- a/etc/refcards/orgcard.tex +++ b/etc/refcards/orgcard.tex @@ -1,5 +1,5 @@ % Reference Card for Org Mode -\def\orgversionnumber{9.5.2} +\def\orgversionnumber{9.5.3} \def\versionyear{2021} % latest update \input emacsver.tex diff --git a/etc/themes/modus-operandi-theme.el b/etc/themes/modus-operandi-theme.el index f71962e3f16..be80b394102 100644 --- a/etc/themes/modus-operandi-theme.el +++ b/etc/themes/modus-operandi-theme.el @@ -1,10 +1,10 @@ -;;; modus-operandi-theme.el --- Accessible and customizable light theme (WCAG AAA) -*- lexical-binding:t -*- +;;; modus-operandi-theme.el --- Elegant, highly legible and customizable light theme -*- lexical-binding:t -*- ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 2.2.0 +;; Version: 2.3.0 ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility @@ -56,17 +56,17 @@ (equal (file-name-directory load-file-name) (expand-file-name "themes/" data-directory)) (require-theme 'modus-themes t)) - (require 'modus-themes))) + (require 'modus-themes)) -(deftheme modus-operandi - "Accessible and customizable light theme (WCAG AAA standard). + (deftheme modus-operandi + "Elegant, highly legible and customizable light theme. Conforms with the highest legibility standard for color contrast between background and foreground in any given piece of text, which corresponds to a minimum contrast in relative luminance of -7:1.") +7:1 (WCAG AAA standard).") -(modus-themes-theme modus-operandi) + (modus-themes-theme modus-operandi) -(provide-theme 'modus-operandi) + (provide-theme 'modus-operandi)) ;;; modus-operandi-theme.el ends here diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el index 067fc22ee44..1c522239508 100644 --- a/etc/themes/modus-themes.el +++ b/etc/themes/modus-themes.el @@ -1,11 +1,11 @@ -;;; modus-themes.el --- Highly accessible and customizable themes (WCAG AAA) -*- lexical-binding:t -*- +;;; modus-themes.el --- Elegant, highly legible and customizable themes -*- lexical-binding:t -*- ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 2.2.0 -;; Last-Modified: <2022-02-23 08:56:46 +0200> +;; Version: 2.3.0 +;; Last-Modified: <2022-04-01 12:33:34 +0300> ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility @@ -41,6 +41,7 @@ ;; modus-themes-bold-constructs (boolean) ;; modus-themes-deuteranopia (boolean) ;; modus-themes-inhibit-reload (boolean) +;; modus-themes-intense-mouseovers (boolean) ;; modus-themes-italic-constructs (boolean) ;; modus-themes-mixed-fonts (boolean) ;; modus-themes-subtle-line-numbers (boolean) @@ -123,6 +124,7 @@ ;; deadgrep ;; debbugs ;; deft +;; devdocs ;; dictionary ;; diff-hl ;; diff-mode @@ -243,6 +245,7 @@ ;; mct ;; mentor ;; messages +;; mini-modeline ;; minimap ;; mmm-mode ;; mode-line @@ -377,7 +380,10 @@ -(eval-when-compile (require 'cl-lib)) +(eval-when-compile + (require 'cl-lib) + (require 'subr-x)) +(require 'seq) (defgroup modus-themes () "Options for `modus-operandi', `modus-vivendi'. @@ -1611,17 +1617,17 @@ The actual styling of the face is done by `modus-themes-faces'." (define-obsolete-face-alias 'modus-themes-completion-standard-first-match - 'modus-themes-completion-selection + 'modus-themes-completion-selected "2.2.0") (define-obsolete-face-alias 'modus-themes-completion-standard-selected - 'modus-themes-completion-selection + 'modus-themes-completion-selected "2.2.0") (define-obsolete-face-alias 'modus-themes-completion-extra-selected - 'modus-themes-completion-selection + 'modus-themes-completion-selected "2.2.0") (define-obsolete-face-alias @@ -1737,10 +1743,7 @@ For form, see `modus-themes-vivendi-colors'." (put 'modus-themes-vivendi-color-overrides 'custom-options (copy-sequence colors))) -(define-obsolete-variable-alias - 'modus-themes-slanted-constructs - 'modus-themes-italic-constructs - "1.5.0") +(defvaralias 'modus-themes-slanted-constructs 'modus-themes-italic-constructs) (defcustom modus-themes-italic-constructs nil "Use italic font forms in more code constructs." @@ -1762,18 +1765,6 @@ For form, see `modus-themes-vivendi-colors'." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Bold constructs")) -(defcustom modus-themes-variable-pitch-headings nil - "DEPRECATED: specify `variable-pitch' in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.0.0") - :version "28.1" - :type 'boolean - :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Headings' typeface")) - -(make-obsolete 'modus-themes-variable-pitch-headings 'modus-themes-headings "2.0.0") - (defcustom modus-themes-variable-pitch-ui nil "Use proportional fonts (variable-pitch) in UI elements. This includes the mode line, header line, tab bar, and tab line." @@ -1785,10 +1776,6 @@ This includes the mode line, header line, tab bar, and tab line." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) UI typeface")) -(define-obsolete-variable-alias - 'modus-themes-no-mixed-fonts - 'modus-themes-mixed-fonts "On 2021-10-02 for version 1.7.0") - (defcustom modus-themes-mixed-fonts nil "Non-nil to enable inheritance from `fixed-pitch' in some faces. @@ -1806,6 +1793,19 @@ Users may need to explicitly configure the font family of :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Mixed fonts")) +(defcustom modus-themes-intense-mouseovers nil + "When non-nil use more intense style for mouse hover effects. + +This affects the generic `highlight' face which, strictly +speaking, is not limited to mouse usage." + :group 'modus-themes + :package-version '(modus-themes . "2.3.0") + :version "29.1" + :type 'boolean + :set #'modus-themes--set-option + :initialize #'custom-initialize-default + :link '(info-link "(modus-themes) Mouse hover effects")) + (defconst modus-themes--headings-choice '(set :tag "Properties" :greedy t (const :tag "Background color" background) @@ -1823,7 +1823,11 @@ Users may need to explicitly configure the font family of (const :tag "Semi-bold" semibold) (const :tag "Extra-bold" extrabold) (const :tag "Ultra-bold" ultrabold)) - (float :tag "Number (float) to adjust height by" :value 1.1) + (radio :tag "Height" + (float :tag "Floating point to adjust height by") + (cons :tag "Cons cell of `(height . FLOAT)'" + (const :tag "The `height' key (constant)" height) + (float :tag "Floating point"))) (choice :tag "Colors" (const :tag "Subtle colors" nil) (const :tag "Rainbow colors" rainbow) @@ -1883,7 +1887,9 @@ weight instead. A number, expressed as a floating point (e.g. 1.5), adjusts the height of the heading to that many times the base font size. The default height is the same as 1.0, though it need not be -explicitly stated. +explicitly stated. Instead of a floating point, an acceptable +value can be in the form of a cons cell like (height . FLOAT) +or (height FLOAT), where FLOAT is the given number. Combinations of any of those properties are expressed as a list, like in these examples: @@ -1891,6 +1897,8 @@ like in these examples: (semibold) (rainbow background) (overline monochrome semibold 1.3) + (overline monochrome semibold (height 1.3)) ; same as above + (overline monochrome semibold (height . 1.3)) ; same as above The order in which the properties are set is not significant. @@ -1920,7 +1928,7 @@ For Org users, the extent of the heading depends on the variable and `background' properties. Depending on the version of Org, there may be others, such as `org-fontify-done-headline'." :group 'modus-themes - :package-version '(modus-themes . "2.0.0") + :package-version '(modus-themes . "2.3.0") :version "29.1" :type `(alist :options ,(mapcar (lambda (el) @@ -1954,12 +1962,18 @@ font size. Acceptable values come in the form of a list that can include either or both of those properties: - `variable-pitch' to use a proportionately spaced typeface; + - A number as a floating point (e.g. 1.5) to set the height of the text to that many times the default font height. A float of 1.0 or the symbol `no-scale' have the same effect of making - the font to the same height as the rest of the buffer. When + the font the same height as the rest of the buffer. When neither a number nor `no-scale' are present, the default is a small increase in height (a value of 1.15). + + Instead of a floating point, an acceptable value can be in the + form of a cons cell like (height . FLOAT) or (height FLOAT), + where FLOAT is the given number. + - The symbol of a weight attribute adjusts the font of the heading accordingly, such as `light', `semibold', etc. Valid symbols are defined in the variable `modus-themes-weights'. @@ -1987,17 +2001,24 @@ that can include any of the following properties: - `grayscale' to make weekdays use the main foreground color and weekends a more subtle gray; + - `workaholic' to make weekdays and weekends look the same in terms of color; + - `bold-today' to apply a bold typographic weight to the current date; + - `bold-all' to render all date headings in a bold weight; + - `underline-today' applies an underline to the current date while removing the background it has by default; + - A number as a floating point (e.g. 1.2) to set the height of the text to that many times the default font height. The default is the same as the base font height (the equivalent of - 1.0). + 1.0). Instead of a floating point, an acceptable value can be + in the form of a cons cell like (height . FLOAT) or (height + FLOAT), where FLOAT is the given number. For example: @@ -2085,7 +2106,7 @@ value are passed as a symbol. Those are: highlights the alert and overdue states. - When `modus-themes-deuteranopia' is non-nil the exact style of the habit graph adapts to the needs of users with red-green - colour deficiency by substituting every instance of green with + color deficiency by substituting every instance of green with blue or cyan (depending on the specifics). For example: @@ -2094,7 +2115,7 @@ For example: (habit . simplified) (habit . traffic-light)" :group 'modus-themes - :package-version '(modus-themes . "2.1.0") + :package-version '(modus-themes . "2.3.0") :version "29.1" :type '(set (cons :tag "Block header" @@ -2115,10 +2136,14 @@ For example: (const :tag "Semi-bold" semibold) (const :tag "Extra-bold" extrabold) (const :tag "Ultra-bold" ultrabold)) - (choice :tag "Scaling" + (radio :tag "Scaling" (const :tag "Slight increase in height (default)" nil) (const :tag "Do not scale" no-scale) - (float :tag "Number (float) to adjust height by" :value 1.3)))) + (radio :tag "Number (float) to adjust height by" + (float :tag "Just the number") + (cons :tag "Cons cell of `(height . FLOAT)'" + (const :tag "The `height' key (constant)" height) + (float :tag "Floating point")))))) (cons :tag "Date header" :greedy t (const header-date) (set :tag "Header presentation" :greedy t @@ -2126,8 +2151,12 @@ For example: (const :tag "Do not differentiate weekdays from weekends" workaholic) (const :tag "Make today bold" bold-today) (const :tag "Make all dates bold" bold-all) - (float :tag "Number (float) to adjust height by" :value 1.05) - (const :tag "Make today underlined; remove the background" underline-today))) + (const :tag "Make today underlined; remove the background" underline-today) + (radio :tag "Number (float) to adjust height by" + (float :tag "Just the number") + (cons :tag "Cons cell of `(height . FLOAT)'" + (const :tag "The `height' key (constant)" height) + (float :tag "Floating point"))))) (cons :tag "Event entry" :greedy t (const event) (set :tag "Text presentation" :greedy t @@ -2148,84 +2177,6 @@ For example: :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Org agenda")) -(defcustom modus-themes-scale-headings nil - "DEPRECATED: specify height in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.2.0") - :version "28.1" - :type 'boolean - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-headings 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-1 1.05 - "DEPRECATED: specify height in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.2.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-1 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-2 1.1 - "DEPRECATED: specify height in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.2.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-2 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-3 1.15 - "DEPRECATED: specify height in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.2.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-3 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-4 1.2 - "DEPRECATED: specify height in `modus-themes-headings'." - :group 'modus-themes - :package-version '(modus-themes . "1.2.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-4 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-title 1.3 - "DEPRECATED: specify height in `modus-themes-headings'. -Same principle for `modus-themes-org-agenda'." - :group 'modus-themes - :package-version '(modus-themes . "1.5.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-title 'modus-themes-headings "2.0.0") - -(defcustom modus-themes-scale-small 0.9 - "DEPRECATED." - :group 'modus-themes - :package-version '(modus-themes . "1.6.0") - :version "28.1" - :type 'number - :set #'modus-themes--set-option - :initialize #'custom-initialize-default) - -(make-obsolete 'modus-themes-scale-small nil "2.0.0") - (defcustom modus-themes-fringes nil "Define the visibility of fringes. @@ -2395,6 +2346,17 @@ the `borderless' property is also set). For users on Emacs 29, the `x-use-underline-position-properties' variable must also be set to nil. +The padding can also be expressed as a cons cell in the form +of (padding . NATNUM) or (padding NATNUM) where the key is +constant and NATNUM is the desired natural number. + +A floating point (e.g. 0.9) applies an adjusted height to the +mode line's text as a multiple of the main font size. The +default rate is 1.0 and does not need to be specified. Apart +from a floating point, the height may also be expressed as a cons +cell in the form of (height . FLOAT) or (height FLOAT) where the +key is constant and the FLOAT is the desired number. + Combinations of any of those properties are expressed as a list, like in these examples: @@ -2402,6 +2364,13 @@ like in these examples: (borderless 3d) (moody accented borderless) +Same as above, using the padding and height as an example (these +all yield the same result): + + (accented borderless 4 0.9) + (accented borderless (padding . 4) (height . 0.9)) + (accented borderless (padding 4) (height 0.9)) + The order in which the properties are set is not significant. In user configuration files the form may look like this: @@ -2433,8 +2402,8 @@ Furthermore, because Moody expects an underline and overline instead of a box style, it is strongly advised to set `x-underline-at-descent-line' to a non-nil value." :group 'modus-themes - :package-version '(modus-themes . "1.6.0") - :version "28.1" + :package-version '(modus-themes . "2.3.0") + :version "29.1" :type '(set :tag "Properties" :greedy t (choice :tag "Overall style" (const :tag "Rectangular Border" nil) @@ -2442,23 +2411,20 @@ instead of a box style, it is strongly advised to set (const :tag "No box effects (Moody-compatible)" moody)) (const :tag "Colored background" accented) (const :tag "Without border color" borderless) - (natnum :tag "With extra padding")) + (radio :tag "Padding" + (natnum :tag "Natural number (e.g. 4)") + (cons :tag "Cons cell of `(padding . NATNUM)'" + (const :tag "The `padding' key (constant)" padding) + (natnum :tag "Natural number"))) + (radio :tag "Height" + (float :tag "Floating point (e.g. 0.9)") + (cons :tag "Cons cell of `(height . FLOAT)'" + (const :tag "The `height' key (constant)" height) + (float :tag "Floating point")))) :set #'modus-themes--set-option :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Mode line")) -(defcustom modus-themes-mode-line-padding 6 - "DEPRECATED: Set natural number in `modus-themes-mode-line'." - :group 'modus-themes - :package-version '(modus-themes . "1.7.0") - :version "29.1" - :type 'natnum - :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Mode line")) - -(make-obsolete 'modus-themes-mode-line-padding 'modus-themes-mode-line "2.0.0") - (defcustom modus-themes-diffs nil "Adjust the overall style of diffs. @@ -2525,11 +2491,15 @@ regardless of the order they may appear in: The `selection' key applies to the current line or currently matched candidate, depending on the specifics of the User Interface. By default (nil or an empty list), it has a subtle -gray background and a bold weight. The list of properties it -accepts is as follows (order is not significant): +gray background, a bold weight, and the base foreground value +for the text. The list of properties it accepts is as +follows (order is not significant): - `accented' to make the background colorful instead of gray; +- `text-also' to apply extra color to the text of the selected + line; + - `intense' to increase the overall coloration; - `underline' to draw a line below the characters; @@ -2560,7 +2530,8 @@ Is the same as: In the case of the fallback, any property that does not apply to the corresponding key is simply ignored (`matches' does not have -`accented', `selection' and `popup' do not have `background'). +`accented' and `text-also', while `selection' and `popup' do not +have `background'). A concise expression of those associations can be written as follows, where the `car' is always the key and the `cdr' is the @@ -2577,7 +2548,7 @@ node `(modus-themes) Configure bold and italic faces'. Also refer to the Orderless documentation for its intersection with Company (if you choose to use those in tandem)." :group 'modus-themes - :package-version '(modus-themes . "2.2.0") + :package-version '(modus-themes . "2.3.0") :version "29.1" :type `(set (cons :tag "Matches" @@ -2614,6 +2585,7 @@ with Company (if you choose to use those in tandem)." (const :tag "Semi-bold" semibold) (const :tag "Extra-bold" extrabold) (const :tag "Ultra-bold" ultrabold)) + (const :tag "Apply color to the line's text" text-also) (const :tag "With accented background" accented) (const :tag "Increased coloration" intense) (const :tag "Italic font (oblique or slanted forms)" italic) @@ -2633,6 +2605,7 @@ with Company (if you choose to use those in tandem)." (const :tag "Semi-bold" semibold) (const :tag "Extra-bold" extrabold) (const :tag "Ultra-bold" ultrabold)) + (const :tag "Apply color to the line's text" text-also) (const :tag "With accented background" accented) (const :tag "Increased coloration" intense) (const :tag "Italic font (oblique or slanted forms)" italic) @@ -2994,11 +2967,6 @@ In user configuration files the form may look like this: :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Active region")) -(define-obsolete-variable-alias - 'modus-themes-success-deuteranopia - 'modus-themes-deuteranopia - "2.0.0") - (defcustom modus-themes-deuteranopia nil "When non-nil use red/blue color-coding instead of red/green. @@ -3101,14 +3069,23 @@ defined in the variable `modus-themes-weights'. A number, expressed as a floating point (e.g. 0.9), adjusts the height of the button's text to that many times the base font size. The default height is the same as 1.0, though it need not -be explicitly stated. +be explicitly stated. Instead of a floating point, an acceptable +value can be in the form of a cons cell like (height . FLOAT) +or (height FLOAT), where FLOAT is the given number. + +The `all-buttons' property extends the box button effect (or the +aforementioned properties) to the faces of the generic widget +library. By default, those do not look like the buttons of the +Custom UI as they are ordinary text wrapped in square brackets. Combinations of any of those properties are expressed as a list, like in these examples: (flat) (variable-pitch flat) - (variable-pitch flat 0.9 semibold) + (variable-pitch flat semibold 0.9) + (variable-pitch flat semibold (height 0.9)) ; same as above + (variable-pitch flat semibold (height . 0.9)) ; same as above The order in which the properties are set is not significant. @@ -3116,7 +3093,7 @@ In user configuration files the form may look like this: (setq modus-themes-box-buttons (quote (variable-pitch flat 0.9)))" :group 'modus-themes - :package-version '(modus-themes . "2.1.0") + :package-version '(modus-themes . "2.3.0") :version "29.1" :type '(set :tag "Properties" :greedy t (const :tag "Two-dimensional button" flat) @@ -3124,6 +3101,7 @@ In user configuration files the form may look like this: (const :tag "Reduce overall coloration" faint) (const :tag "Proportionately spaced font (variable-pitch)" variable-pitch) (const :tag "Underline instead of a box effect" underline) + (const :tag "Apply box button style to generic widget faces" all-buttons) (choice :tag "Font weight (must be supported by the typeface)" (const :tag "Thin" thin) (const :tag "Ultra-light" ultralight) @@ -3136,7 +3114,11 @@ In user configuration files the form may look like this: (const :tag "Semi-bold" semibold) (const :tag "Extra-bold" extrabold) (const :tag "Ultra-bold" ultrabold)) - (float :tag "Number (float) to adjust height by" :value 0.9)) + (radio :tag "Height" + (float :tag "Floating point to adjust height by") + (cons :tag "Cons cell of `(height . FLOAT)'" + (const :tag "The `height' key (constant)" height) + (float :tag "Floating point")))) :set #'modus-themes--set-option :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Box buttons")) @@ -3145,6 +3127,32 @@ In user configuration files the form may look like this: ;;; Internal functions +(defun modus-themes--warn (option) + "Warn that OPTION has changed." + (prog1 nil + (display-warning + 'modus-themes + (format "`%s' has changed; please read the updated documentation" option) + :warning))) + +(defun modus-themes--list-or-warn (option) + "Return list or nil value of OPTION, else `modus-themes--warn'." + (let* ((value (symbol-value option))) + (if (or (null value) (listp value)) + value + (modus-themes--warn option)))) + +(defun modus-themes--alist-or-seq (properties alist-key seq-pred seq-default) + "Return value from alist or sequence. +Check PROPERTIES for an alist value that corresponds to +ALIST-KEY. If no alist is present, search the PROPERTIES +sequence given SEQ-PRED, using SEQ-DEFAULT as a fallback." + (if-let* ((val (or (alist-get alist-key properties) + (seq-find seq-pred properties seq-default))) + ((listp val))) + (car val) + val)) + (defun modus-themes--palette (theme) "Return color palette for Modus theme THEME. THEME is a symbol, either `modus-operandi' or `modus-vivendi'." @@ -3183,8 +3191,9 @@ Those are stored in `modus-themes-faces' and (custom-theme-set-variables ',name ,@modus-themes-custom-variables)))) (defun modus-themes--current-theme () - "Return current theme." - (car custom-enabled-themes)) + "Return current modus theme." + (car (seq-filter (lambda (arg) (string-match-p "^modus" (symbol-name arg))) + custom-enabled-themes))) ;; Helper functions that are meant to ease the implementation of the ;; above customization variables. @@ -3269,45 +3278,36 @@ pattern and represent a value that is faint or vibrant respectively. INTENSEFG-ALT is used when the intensity is high. SUBTLEBG and INTENSEBG are color-coded background colors that differ in overall intensity. FAINTFG is a nuanced color." - (let ((modus-themes-lang-checkers - (if (listp modus-themes-lang-checkers) - modus-themes-lang-checkers - (pcase modus-themes-lang-checkers - ('colored-background '(background intense)) - ('intense-foreground '(intense)) - ('intense-foreground-straight-underline '(intense straight-underline)) - ('subtle-foreground '(text-also)) - ('subtle-foreground-straight-underline '(text-also straight-underline)) - ('straight-underline '(straight-underline)))))) + (let ((properties (modus-themes--list-or-warn 'modus-themes-lang-checkers))) (list :underline (list :color - (if (memq 'faint modus-themes-lang-checkers) + (if (memq 'faint properties) faintfg underline) :style - (if (memq 'straight-underline modus-themes-lang-checkers) + (if (memq 'straight-underline properties) 'line 'wave)) :background (cond - ((and (memq 'background modus-themes-lang-checkers) - (memq 'faint modus-themes-lang-checkers)) + ((and (memq 'background properties) + (memq 'faint properties)) subtlebg) - ((and (memq 'background modus-themes-lang-checkers) - (memq 'intense modus-themes-lang-checkers)) + ((and (memq 'background properties) + (memq 'intense properties)) intensebg) - ((memq 'background modus-themes-lang-checkers) + ((memq 'background properties) subtlebg) ('unspecified)) :foreground (cond - ((and (memq 'faint modus-themes-lang-checkers) - (memq 'text-also modus-themes-lang-checkers)) + ((and (memq 'faint properties) + (memq 'text-also properties)) faintfg) - ((and (memq 'background modus-themes-lang-checkers) - (memq 'intense modus-themes-lang-checkers)) + ((and (memq 'background properties) + (memq 'intense properties)) intensefg-alt) - ((memq 'intense modus-themes-lang-checkers) + ((memq 'intense properties) intensefg) - ((memq 'text-also modus-themes-lang-checkers) + ((memq 'text-also properties) subtlefg) ('unspecified))))) @@ -3326,7 +3326,7 @@ should be combinable with INTENSEBG-FG. SUBTLEBGGRAY and INTENSEBGGRAY are background values. The former can be combined with GRAYFG, while the latter only works with the theme's fallback text color." - (let ((properties modus-themes-prompts)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-prompts))) (list :foreground (cond ((and (memq 'gray properties) @@ -3368,11 +3368,11 @@ theme's fallback text color." (defun modus-themes--paren (normalbg intensebg) "Conditional use of intense colors for matching parentheses. -NORMALBG should be the special palette color 'bg-paren-match' or +NORMALBG should be the special palette color `bg-paren-match' or something similar. INTENSEBG must be easier to discern next to other backgrounds, such as the special palette color -'bg-paren-match-intense'." - (let ((properties modus-themes-paren-match)) +`bg-paren-match-intense'." + (let ((properties (modus-themes--list-or-warn 'modus-themes-paren-match))) (list :inherit (if (memq 'bold properties) 'bold @@ -3390,7 +3390,7 @@ other backgrounds, such as the special palette color "Apply foreground value to code syntax. FG is the default. FAINT is typically the same color in its desaturated version." - (let ((properties modus-themes-syntax)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax))) (list :foreground (cond ((memq 'faint properties) @@ -3402,7 +3402,7 @@ desaturated version." FG is the default. FAINT is typically the same color in its desaturated version. ALT is another hue while optional FAINT-ALT is its subtle alternative." - (let ((properties modus-themes-syntax)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax))) (list :foreground (cond ((and (memq 'alt-syntax properties) @@ -3421,7 +3421,7 @@ desaturated version. GREEN is a color variant in that side of the spectrum. ALT is another hue. Optional FAINT-GREEN is a subtle alternative to GREEN. Optional FAINT-ALT is a subtle alternative to ALT." - (let ((properties modus-themes-syntax)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax))) (list :foreground (cond ((and (memq 'faint properties) @@ -3443,7 +3443,7 @@ alternative to ALT." FG is the default. YELLOW is a color variant of that name while optional FAINT-YELLOW is its subtle variant. Optional FAINT is an alternative to the default value." - (let ((properties modus-themes-syntax)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax))) (list :foreground (cond ((and (memq 'faint properties) @@ -3521,7 +3521,7 @@ that combines well with the background and foreground." fg-alt) (fg)) :height - (seq-find #'floatp properties 'unspecified) + (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified) :weight (or weight 'unspecified) :overline @@ -3546,7 +3546,7 @@ FG is the foreground color to use." (or weight 'unspecified) :height (cond ((memq 'no-scale properties) 'unspecified) - ((seq-find #'floatp properties 1.15))) + ((modus-themes--alist-or-seq properties 'height #'floatp 1.15))) :foreground fg))) (defun modus-themes--agenda-date (defaultfg grayscalefg &optional workaholicfg grayscaleworkaholicfg bg bold ul) @@ -3581,7 +3581,7 @@ weight. Optional UL applies an underline." (t defaultfg)) :height - (seq-find #'floatp properties 'unspecified) + (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified) :underline (if (and ul (memq 'underline-today properties)) t @@ -3637,8 +3637,8 @@ clearly distinguishes past, present, future tasks." (defun modus-themes--agenda-habit (default traffic simple &optional default-d traffic-d simple-d) "Specify background values for `modus-themes-org-agenda' habits. DEFAULT is the original foregrounc color. TRAFFIC is to be used -when the 'traffic-light' style is applied, while SIMPLE -corresponds to the 'simplified style'. +when the `traffic-light' style is applied, while SIMPLE +corresponds to the \"simplified style\". Optional DEFAULT-D, TRAFFIC-D, SIMPLE-D are alternatives to the main colors, meant for dopia when `modus-themes-deuteranopia' is @@ -3711,8 +3711,9 @@ line's box property. Optional FG-DISTANT should be close to the main background values. It is intended to be used as a distant-foreground property." - (let* ((properties modus-themes-mode-line) - (padding (seq-find #'natnump properties 1)) + (let* ((properties (modus-themes--list-or-warn 'modus-themes-mode-line)) + (padding (modus-themes--alist-or-seq properties 'padding #'natnump 1)) + (height (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified)) (padded (> padding 1)) (base (cond ((memq 'accented properties) (cons fg-accent bg-accent)) @@ -3735,6 +3736,7 @@ property." (border)))) (list :foreground (car base) :background (cdr base) + :height height :box (cond ((memq 'moody properties) 'unspecified) @@ -3807,26 +3809,21 @@ unspecified." (list deuteran) (list main))) -(defun modus-themes--completion (key bg fg bgintense fgintense &optional bgaccent bgaccentintense) +(make-obsolete 'modus-themes--completion 'modus-themes--completion-line "2.3.0") +(make-obsolete 'modus-themes--completion 'modus-themes--completion-match "2.3.0") + +(defun modus-themes--completion-line (key bg fg bgintense fgintense &optional bgaccent bgaccentintense) "Styles for `modus-themes-completions'. KEY is the key of a cons cell. BG and FG are the main colors. BGINTENSE works with the main foreground. FGINTENSE works on its own. BGACCENT and BGACCENTINTENSE are colorful variants of the other backgrounds." - (let* ((var (if (listp modus-themes-completions) - modus-themes-completions - (prog1 nil - (warn (concat "`modus-themes-completions' has changed." - "\n" - "Its value must now be an alist." - "\n" - "Please read the updated doc string."))))) + (let* ((var (modus-themes--list-or-warn 'modus-themes-completions)) (properties (or (alist-get key var) (alist-get t var))) (popup (eq key 'popup)) (selection (eq key 'selection)) (line (or popup selection)) - (background (or line (memq 'background properties))) - (base-fg (if selection fg 'unspecified)) + (text (memq 'text-also properties)) (accented (memq 'accented properties)) (intense (memq 'intense properties)) (italic (memq 'italic properties)) @@ -3847,6 +3844,43 @@ other backgrounds." bgaccentintense) ((and accented line) bgaccent) + (intense bgintense) + (bg)) + :foreground + (cond + ((and line text intense) + fgintense) + ((and line text) + fg) + ('unspecified)) + :underline + (if (memq 'underline properties) t 'unspecified) + :weight + (if (and weight (null bold)) weight 'unspecified)))) + +(defun modus-themes--completion-match (key bg fg bgintense fgintense) + "Styles for `modus-themes-completions'. +KEY is the key of a cons cell. BG and FG are the main colors. +BGINTENSE works with the main foreground. FGINTENSE works on its +own." + (let* ((var (modus-themes--list-or-warn 'modus-themes-completions)) + (properties (or (alist-get key var) (alist-get t var))) + (background (memq 'background properties)) + (intense (memq 'intense properties)) + (italic (memq 'italic properties)) + (weight (modus-themes--weight properties)) + (bold (when (and weight (eq weight 'bold)) 'bold))) + (list + :inherit + (cond + ((and italic weight (not (eq weight 'bold))) + 'italic) + ((and weight (not (eq weight 'bold))) + 'unspecified) + (italic 'bold-italic) + ('bold)) + :background + (cond ((and background intense) bgintense) (background bg) @@ -3854,7 +3888,7 @@ other backgrounds." :foreground (cond ((and background intense) - base-fg) + 'unspecified) (background fg) (intense fgintense) (fg)) @@ -3869,7 +3903,7 @@ FG is the link's default color for its text and underline property. FGFAINT is a desaturated color for the text and underline. UNDERLINE is a gray color only for the undeline. BG is a background color and BGNEUTRAL is its fallback value." - (let ((properties modus-themes-links)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-links))) (list :inherit (cond ((and (memq 'bold properties) @@ -3907,7 +3941,7 @@ is a background color and BGNEUTRAL is its fallback value." "Extend `modus-themes--link'. FG is the main accented foreground. FGFAINT is also accented, yet desaturated. Optional NEUTRALFG is a gray value." - (let ((properties modus-themes-links)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-links))) (list :foreground (cond ((memq 'no-color properties) @@ -3931,7 +3965,7 @@ is a subtle background value that can be combined with all colors used to fontify text and code syntax. BGACCENT is a colored background that combines well with FG. BGACCENTSUBTLE can be combined with all colors used to fontify text." - (let ((properties modus-themes-region)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-region))) (list :background (cond ((and (memq 'accented properties) @@ -3967,7 +4001,7 @@ LINEACCENT are color values that can remain distinct against the buffer's possible backgrounds: the former is neutral, the latter is accented. LINENEUTRALINTENSE and LINEACCENTINTENSE are their more prominent alternatives." - (let ((properties modus-themes-hl-line)) + (let ((properties (modus-themes--list-or-warn 'modus-themes-hl-line))) (list :background (cond ((and (memq 'intense properties) @@ -4034,7 +4068,12 @@ application of a variable-pitch font." (defun modus-themes--button (bg bgfaint bgaccent bgaccentfaint border &optional pressed-button-p) "Apply `modus-themes-box-buttons' styles. -Work in progress. BG BGFAINT BGACCENT BGACCENTFAINT BORDER PRESSED-BUTTON-P." +BG is the main background. BGFAINT is its subtle alternative. +BGACCENT is its accented variant and BGACCENTFAINT is the same +but less intense. BORDER is the color around the box. + +When optional PRESSED-BUTTON-P is non-nil, the box uses the +pressed button style, else the released button." (let* ((properties modus-themes-box-buttons) (weight (modus-themes--weight properties))) (list :inherit @@ -4075,7 +4114,7 @@ Work in progress. BG BGFAINT BGACCENT BGACCENTFAINT BORDER PRESSED-BUTTON-P." (weight weight) ('unspecified)) :height - (seq-find #'floatp properties 'unspecified) + (modus-themes--alist-or-seq properties 'height #'floatp 'unspecified) :underline (if (memq 'underline properties) t @@ -4228,30 +4267,6 @@ as when they are declared in the `:config' phase)." (defvar modus-themes-after-load-theme-hook nil "Hook that runs after the `modus-themes-toggle' routines.") -;; The reason we use `load-theme' instead of `enable-theme' is that the -;; former does a kind of "reset" on the face specs. So it plays nicely -;; with `custom-set-faces', as well as defcustom user customizations, -;; including the likes of `modus-themes-operandi-color-overrides'. -;; -;; Tests show that `enable-theme' does not re-read those variables, so -;; it might appear to the unsuspecting user that the themes are somehow -;; broken. -;; -;; This "reset", however, comes at the cost of being a bit slower than -;; `enable-theme'. User who have a stable setup and seldom update their -;; variables during a given Emacs session, are better off using -;; something like this: -;; -;; (defun modus-themes-toggle-enabled () -;; "Toggle between `modus-operandi' and `modus-vivendi' themes." -;; (interactive) -;; (pcase (modus-themes--current-theme) -;; ('modus-operandi (progn (enable-theme 'modus-vivendi) -;; (disable-theme 'modus-operandi))) -;; ('modus-vivendi (progn (enable-theme 'modus-operandi) -;; (disable-theme 'modus-vivendi))) -;; (_ (error "No Modus theme is loaded; evaluate `modus-themes-load-themes' first")))) - ;;;###autoload (defun modus-themes-load-operandi () "Load `modus-operandi' and disable `modus-vivendi'. @@ -4505,30 +4520,30 @@ by virtue of calling either of `modus-themes-load-operandi' and `(modus-themes-tab-inactive ((,class ,@(modus-themes--tab bg-tab-inactive bg-tab-inactive-accent fg-dim nil t)))) ;;;;; completion frameworks `(modus-themes-completion-match-0 - ((,class ,@(modus-themes--completion + ((,class ,@(modus-themes--completion-match 'matches bg-special-faint-calm magenta-alt magenta-subtle-bg magenta-intense)))) `(modus-themes-completion-match-1 - ((,class ,@(modus-themes--completion + ((,class ,@(modus-themes--completion-match 'matches bg-special-faint-cold cyan cyan-subtle-bg cyan-intense)))) `(modus-themes-completion-match-2 - ((,class ,@(modus-themes--completion + ((,class ,@(modus-themes--completion-match 'matches bg-special-faint-mild green green-subtle-bg green-intense)))) `(modus-themes-completion-match-3 - ((,class ,@(modus-themes--completion + ((,class ,@(modus-themes--completion-match 'matches bg-special-faint-warm yellow yellow-subtle-bg orange-intense)))) `(modus-themes-completion-selected - ((,class ,@(modus-themes--completion - 'selection bg-inactive 'unspecified - bg-active 'unspecified + ((,class ,@(modus-themes--completion-line + 'selection bg-inactive blue-alt + bg-active blue-active bg-completion-subtle bg-completion)))) `(modus-themes-completion-selected-popup - ((,class ,@(modus-themes--completion - 'popup bg-active 'unspecified - bg-region 'unspecified + ((,class ,@(modus-themes--completion-line + 'popup bg-active blue-alt + bg-region blue-active cyan-subtle-bg cyan-refine-bg)))) ;;;;; buttons `(modus-themes-box-button @@ -4568,6 +4583,7 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; basic and/or ungrouped styles `(bold ((,class :weight bold))) `(bold-italic ((,class :inherit (bold italic)))) + `(underline ((,class :underline ,fg-alt))) `(buffer-menu-buffer ((,class :inherit bold))) `(child-frame-border ((,class :background ,fg-window-divider-inner))) `(comint-highlight-input ((,class :inherit bold))) @@ -4598,6 +4614,7 @@ by virtue of calling either of `modus-themes-load-operandi' and bg-hl-alt-intense bg-region-accent bg-region-accent-subtle)))) `(secondary-selection ((,class :inherit modus-themes-special-cold))) + `(separator-line ((,class :underline ,bg-region))) `(shadow ((,class :foreground ,fg-alt))) `(success ((,class :inherit (bold modus-themes-grue)))) `(trailing-whitespace ((,class :background ,red-intense-bg))) @@ -4611,8 +4628,12 @@ by virtue of calling either of `modus-themes-load-operandi' and ,@(modus-themes--link-color magenta-alt-other magenta-alt-other-faint fg-alt)))) `(tooltip ((,class :background ,bg-special-cold :foreground ,fg-main))) - `(widget-button ((,class :inherit bold :foreground ,blue-alt))) - `(widget-button-pressed ((,class :inherit widget-button :foreground ,magenta))) + `(widget-button ((,class ,@(if (memq 'all-buttons modus-themes-box-buttons) + (list :inherit 'modus-themes-box-button) + (list :inherit 'bold :foreground blue-alt))))) + `(widget-button-pressed ((,class ,@(if (memq 'all-buttons modus-themes-box-buttons) + (list :inherit 'modus-themes-box-button-pressed) + (list :inherit 'bold :foreground magenta-alt))))) `(widget-documentation ((,class :foreground ,green))) `(widget-field ((,class :background ,bg-alt :foreground ,fg-main :extend nil))) `(widget-inactive ((,class :inherit shadow :background ,bg-dim))) @@ -4724,7 +4745,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(font-latex-string-face ((,class :inherit font-lock-string-face))) `(font-latex-subscript-face ((,class :height 0.95))) `(font-latex-superscript-face ((,class :height 0.95))) - `(font-latex-verbatim-face ((,class :background ,bg-dim :foreground ,fg-special-mild))) + `(font-latex-verbatim-face ((,class :inherit modus-themes-markup-verbatim))) `(font-latex-warning-face ((,class :inherit font-lock-warning-face))) `(tex-match ((,class :foreground ,blue-alt-other))) `(tex-verbatim ((,class :inherit modus-themes-markup-verbatim))) @@ -4737,11 +4758,11 @@ by virtue of calling either of `modus-themes-load-operandi' and `(auto-dim-other-buffers-face ((,class :background ,bg-alt))) ;;;;; avy `(avy-background-face ((,class :background ,bg-dim :foreground ,fg-dim :extend t))) - `(avy-goto-char-timer-face ((,class :inherit (modus-themes-intense-yellow bold)))) - `(avy-lead-face ((,class :inherit (modus-themes-intense-magenta bold modus-themes-reset-soft)))) - `(avy-lead-face-0 ((,class :inherit (modus-themes-refine-cyan bold modus-themes-reset-soft)))) - `(avy-lead-face-1 ((,class :inherit (modus-themes-intense-neutral bold modus-themes-reset-soft)))) - `(avy-lead-face-2 ((,class :inherit (modus-themes-refine-red bold modus-themes-reset-soft)))) + `(avy-goto-char-timer-face ((,class :inherit (modus-themes-intense-neutral bold)))) + `(avy-lead-face ((,class :inherit (modus-themes-intense-blue bold modus-themes-reset-soft)))) + `(avy-lead-face-0 ((,class :inherit (modus-themes-refine-magenta bold modus-themes-reset-soft)))) + `(avy-lead-face-1 ((,class :inherit (modus-themes-special-warm modus-themes-reset-soft)))) + `(avy-lead-face-2 ((,class :inherit (modus-themes-refine-green bold modus-themes-reset-soft)))) ;;;;; aw (ace-window) `(aw-background-face ((,class :foreground ,fg-unfocused))) `(aw-key-face ((,class :inherit modus-themes-key-binding))) @@ -4835,7 +4856,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(centaur-tabs-close-unselected ((,class :inherit centaur-tabs-unselected))) `(centaur-tabs-modified-marker-selected ((,class :inherit centaur-tabs-selected))) `(centaur-tabs-modified-marker-unselected ((,class :inherit centaur-tabs-unselected))) - `(centaur-tabs-default (( ))) + `(centaur-tabs-default ((,class :background ,bg-main))) `(centaur-tabs-selected ((,class :inherit modus-themes-tab-active))) `(centaur-tabs-selected-modified ((,class :inherit (italic centaur-tabs-selected)))) `(centaur-tabs-unselected ((,class :inherit modus-themes-tab-inactive))) @@ -4926,7 +4947,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(company-preview-common ((,class :inherit company-echo-common))) `(company-preview-search ((,class :inherit modus-themes-special-calm))) `(company-template-field ((,class :inherit modus-themes-intense-magenta))) - `(company-tooltip ((,class :background ,bg-alt :foreground ,fg-alt))) + `(company-tooltip ((,class :background ,bg-alt))) `(company-tooltip-annotation ((,class :inherit completions-annotations))) `(company-tooltip-common ((,class :inherit company-echo-common))) `(company-tooltip-deprecated ((,class :inherit company-tooltip :strike-through t))) @@ -5079,6 +5100,8 @@ by virtue of calling either of `modus-themes-load-operandi' and `(deft-summary-face ((,class :inherit (shadow modus-themes-slant)))) `(deft-time-face ((,class :foreground ,fg-special-cold))) `(deft-title-face ((,class :inherit bold :foreground ,fg-main))) +;;;;; devdocs + `(devdocs-code-block ((,class :inherit modus-themes-fixed-pitch :background ,bg-dim :extend t))) ;;;;; dictionary `(dictionary-button-face ((,class :inherit bold :foreground ,fg-special-cold))) `(dictionary-reference-face ((,class :inherit button))) @@ -5224,7 +5247,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(diredp-tagged-autofile-name ((,class :inherit modus-themes-refine-magenta))) `(diredp-write-priv ((,class :foreground ,cyan))) ;;;;; display-fill-column-indicator-mode - `(fill-column-indicator ((,class :foreground ,bg-active))) + `(fill-column-indicator ((,class :height 1 :background ,bg-inactive :foreground ,bg-inactive))) ;;;;; doom-modeline `(doom-modeline-bar ((,class :inherit modus-themes-active-blue))) `(doom-modeline-bar-inactive ((,class :background ,fg-inactive :foreground ,bg-main))) @@ -5341,10 +5364,11 @@ by virtue of calling either of `modus-themes-load-operandi' and `(elpher-gemini-heading3 ((,class :inherit modus-themes-heading-3))) ;;;;; embark `(embark-keybinding ((,class :inherit modus-themes-key-binding))) + `(embark-collect-marked ((,class :inherit modus-themes-mark-sel))) ;;;;; ement (ement.el) `(ement-room-fully-read-marker ((,class :background ,cyan-subtle-bg))) `(ement-room-membership ((,class :inherit shadow))) - `(ement-room-mention (( ))) + `(ement-room-mention ((,class :background ,bg-hl-alt-intense))) `(ement-room-name ((,class :inherit bold))) `(ement-room-reactions ((,class :inherit shadow))) `(ement-room-read-receipt-marker ((,class :background ,yellow-subtle-bg))) @@ -5910,7 +5934,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(hi-red-b ((,class :inherit bold :background ,red-intense-bg :foreground ,fg-main))) `(hi-salmon ((,class :background ,red-subtle-bg :foreground ,fg-main))) `(hi-yellow ((,class :background ,yellow-subtle-bg :foreground ,fg-main))) - `(highlight ((,class :background ,cyan-subtle-bg :foreground ,fg-main))) + `(highlight ((,class ,@(if modus-themes-intense-mouseovers + (list :background blue-intense-bg :foreground fg-main) + (list :background cyan-subtle-bg :foreground fg-main))))) `(highlight-changes ((,class :foreground ,red-alt :underline nil))) `(highlight-changes-delete ((,class :background ,red-nuanced-bg :foreground ,red :underline t))) @@ -5942,7 +5968,7 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; icomplete-vertical `(icomplete-vertical-separator ((,class :inherit shadow))) ;;;;; ido-mode - `(ido-first-match ((,class :inherit modus-themes-completion-selected))) + `(ido-first-match ((,class :inherit modus-themes-completion-match-0))) `(ido-incomplete-regexp ((,class :inherit error))) `(ido-indicator ((,class :inherit modus-themes-subtle-yellow))) `(ido-only-match ((,class :inherit ido-first-match))) @@ -6436,6 +6462,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(message-header-xheader ((,class :foreground ,blue-alt))) `(message-mml ((,class :foreground ,cyan-alt-other))) `(message-separator ((,class :inherit modus-themes-intense-neutral))) +;;;;; mini-modeline + `(mini-modeline-mode-line ((,class :background ,blue-intense :height 0.14))) + `(mini-modeline-mode-line-inactive ((,class :background ,fg-window-divider-inner :height 0.1))) ;;;;; minimap `(minimap-active-region-background ((,class :background ,bg-active))) `(minimap-current-line-face ((,class :background ,cyan-intense-bg :foreground ,fg-main))) @@ -6459,7 +6488,9 @@ by virtue of calling either of `modus-themes-load-operandi' and `(mode-line-active ((,class :inherit mode-line))) `(mode-line-buffer-id ((,class :inherit bold))) `(mode-line-emphasis ((,class :inherit bold :foreground ,magenta-active))) - `(mode-line-highlight ((,class :inherit highlight))) + `(mode-line-highlight ((,class ,@(if modus-themes-intense-mouseovers + (list :inherit 'modus-themes-active-blue) + (list :inherit 'highlight))))) `(mode-line-inactive ((,class :inherit modus-themes-ui-variable-pitch ,@(modus-themes--mode-line-attrs fg-inactive bg-inactive @@ -6616,7 +6647,7 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; org `(org-agenda-calendar-event ((,class ,@(modus-themes--agenda-event blue-alt)))) `(org-agenda-calendar-sexp ((,class ,@(modus-themes--agenda-event blue-alt t)))) - `(org-agenda-clocking ((,class :inherit modus-themes-special-cold :extend t))) + `(org-agenda-clocking ((,class :background ,yellow-nuanced-bg :foreground ,red-alt))) `(org-agenda-column-dateline ((,class :background ,bg-alt))) `(org-agenda-current-time ((,class :foreground ,blue-alt-other-faint))) `(org-agenda-date ((,class ,@(modus-themes--agenda-date cyan fg-main)))) @@ -6650,7 +6681,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-checkbox (( ))) `(org-checkbox-statistics-done ((,class :inherit org-done))) `(org-checkbox-statistics-todo ((,class :inherit org-todo))) - `(org-clock-overlay ((,class :inherit modus-themes-special-cold))) + `(org-clock-overlay ((,class :background ,yellow-nuanced-bg :foreground ,red-alt-faint))) `(org-code ((,class :inherit modus-themes-markup-code :extend t))) `(org-column ((,class :inherit (modus-themes-fixed-pitch default) :background ,bg-alt))) @@ -6721,7 +6752,7 @@ by virtue of calling either of `modus-themes-load-operandi' and `(org-hide ((,class :foreground ,bg-main))) `(org-indent ((,class :inherit (fixed-pitch org-hide)))) `(org-imminent-deadline ((,class :foreground ,red-intense))) - `(org-latex-and-related ((,class :foreground ,magenta-refine-fg))) + `(org-latex-and-related ((,class :foreground ,magenta-faint))) `(org-level-1 ((,class :inherit modus-themes-heading-1))) `(org-level-2 ((,class :inherit modus-themes-heading-2))) `(org-level-3 ((,class :inherit modus-themes-heading-3))) @@ -7044,13 +7075,14 @@ by virtue of calling either of `modus-themes-load-operandi' and `(show-paren-match-expression ((,class :background ,bg-paren-expression))) `(show-paren-mismatch ((,class :inherit modus-themes-intense-red))) ;;;;; shr + `(shr-abbreviation ((,class :inherit modus-themes-lang-note))) + `(shr-code ((,class :inherit modus-themes-markup-verbatim))) `(shr-h1 ((,class :inherit modus-themes-heading-1))) `(shr-h2 ((,class :inherit modus-themes-heading-2))) `(shr-h3 ((,class :inherit modus-themes-heading-3))) `(shr-h4 ((,class :inherit modus-themes-heading-4))) `(shr-h5 ((,class :inherit modus-themes-heading-5))) `(shr-h6 ((,class :inherit modus-themes-heading-6))) - `(shr-abbreviation ((,class :inherit modus-themes-lang-note))) `(shr-selected-link ((,class :inherit modus-themes-subtle-red))) ;;;;; side-notes `(side-notes ((,class :background ,bg-dim :foreground ,fg-dim))) @@ -7428,8 +7460,8 @@ by virtue of calling either of `modus-themes-load-operandi' and ;;;;; vertico `(vertico-current ((,class :inherit modus-themes-completion-selected))) ;;;;; vertico-quick - `(vertico-quick1 ((,class :inherit (modus-themes-intense-magenta bold)))) - `(vertico-quick2 ((,class :inherit (modus-themes-refine-cyan bold)))) + `(vertico-quick1 ((,class :inherit (modus-themes-intense-blue bold)))) + `(vertico-quick2 ((,class :inherit (modus-themes-refine-magenta bold)))) ;;;;; vimish-fold `(vimish-fold-fringe ((,class :foreground ,cyan-active))) `(vimish-fold-mouse-face ((,class :inherit modus-themes-intense-blue))) @@ -7645,6 +7677,8 @@ by virtue of calling either of `modus-themes-load-operandi' and ("XXX+" . ,red-alt) ("REVIEW" . ,cyan-alt-other) ("DEPRECATED" . ,blue-nuanced-fg))) +;;;; mini-modeline + `(mini-modeline-face-attr '(:background unspecified)) ;;;; pdf-tools `(pdf-view-midnight-colors '(,fg-main . ,bg-dim)) @@ -7671,6 +7705,20 @@ by virtue of calling either of `modus-themes-load-operandi' and (340 . ,blue-alt-other) (360 . ,magenta-alt-other))) `(vc-annotate-very-old-color nil) +;;;; wid-edit + `(widget-link-prefix ,(if (memq 'all-buttons modus-themes-box-buttons) + " " + "[")) + `(widget-link-suffix ,(if (memq 'all-buttons modus-themes-box-buttons) + " " + "]")) + `(widget-mouse-face '(highlight widget-button)) + `(widget-push-button-prefix ,(if (memq 'all-buttons modus-themes-box-buttons) + " " + "[")) + `(widget-push-button-suffix ,(if (memq 'all-buttons modus-themes-box-buttons) + " " + "]")) ;;;; xterm-color `(xterm-color-names ["black" ,red ,green ,yellow ,blue ,magenta ,cyan "gray65"]) `(xterm-color-names-bright ["gray35" ,red-alt ,green-alt ,yellow-alt ,blue-alt ,magenta-alt ,cyan-alt "white"]) diff --git a/etc/themes/modus-vivendi-theme.el b/etc/themes/modus-vivendi-theme.el index 7d38e5cbf27..fb95772654f 100644 --- a/etc/themes/modus-vivendi-theme.el +++ b/etc/themes/modus-vivendi-theme.el @@ -1,10 +1,10 @@ -;;; modus-vivendi-theme.el --- Accessible and customizable dark theme (WCAG AAA) -*- lexical-binding:t -*- +;;; modus-vivendi-theme.el --- Elegant, highly legible and customizable light theme -*- lexical-binding:t -*- ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou ;; URL: https://gitlab.com/protesilaos/modus-themes -;; Version: 2.2.0 +;; Version: 2.3.0 ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility @@ -56,17 +56,17 @@ (equal (file-name-directory load-file-name) (expand-file-name "themes/" data-directory)) (require-theme 'modus-themes t)) - (require 'modus-themes))) + (require 'modus-themes)) -(deftheme modus-vivendi - "Accessible and customizable dark theme (WCAG AAA standard). + (deftheme modus-vivendi + "Elegant, highly legible and customizable dark theme. Conforms with the highest legibility standard for color contrast between background and foreground in any given piece of text, which corresponds to a minimum contrast in relative luminance of -7:1.") +7:1 (WCAG AAA standard).") -(modus-themes-theme modus-vivendi) + (modus-themes-theme modus-vivendi) -(provide-theme 'modus-vivendi) + (provide-theme 'modus-vivendi)) ;;; modus-vivendi-theme.el ends here diff --git a/leim/Makefile.in b/leim/Makefile.in index 6cf0abb40ca..4e70e8b7e9d 100644 --- a/leim/Makefile.in +++ b/leim/Makefile.in @@ -131,6 +131,7 @@ ${leimdir}/ja-dic/ja-dic.el: | $(leimdir)/ja-dic ${leimdir}/ja-dic/ja-dic.el: $(srcdir)/SKK-DIC/SKK-JISYO.L $(AM_V_GEN)$(RUN_EMACS) -batch -l ja-dic-cnv \ + --eval "(setq max-specpdl-size 5000)" \ -f batch-skkdic-convert -dir "$(leimdir)/ja-dic" "$<" ${srcdir}/../lisp/language/pinyin.el: ${srcdir}/MISC-DIC/pinyin.map diff --git a/lib-src/ebrowse.c b/lib-src/ebrowse.c index b77572734fe..641570da02e 100644 --- a/lib-src/ebrowse.c +++ b/lib-src/ebrowse.c @@ -1209,17 +1209,14 @@ sym_scope (struct sym *p) } -/* Dump the list of members M to file FP. Value is the length of the - list. */ +/* Dump the list of members M to file FP. */ -static int +static void dump_members (FILE *fp, struct member *m) { - int n; - putc ('(', fp); - for (n = 0; m; m = m->next, ++n) + for (; m; m = m->next) { fputs (MEMBER_STRUCT, fp); putstr (m->name, fp); @@ -1239,7 +1236,6 @@ dump_members (FILE *fp, struct member *m) putc (')', fp); putc ('\n', fp); - return n; } @@ -1268,15 +1264,11 @@ dump_sym (FILE *fp, struct sym *root) } -/* Dump class ROOT and its subclasses to file FP. Value is the - number of classes written. */ +/* Dump class ROOT and its subclasses to file FP. */ -static int +static void dump_tree (FILE *fp, struct sym *root) { - struct link *lk; - unsigned n = 0; - dump_sym (fp, root); if (f_verbose) @@ -1287,20 +1279,20 @@ dump_tree (FILE *fp, struct sym *root) putc ('(', fp); - for (lk = root->subs; lk; lk = lk->next) + for (struct link *lk = root->subs; lk; lk = lk->next) { fputs (TREE_STRUCT, fp); - n += dump_tree (fp, lk->sym); + dump_tree (fp, lk->sym); putc (']', fp); } putc (')', fp); dump_members (fp, root->vars); - n += dump_members (fp, root->fns); + dump_members (fp, root->fns); dump_members (fp, root->static_vars); - n += dump_members (fp, root->static_fns); - n += dump_members (fp, root->friends); + dump_members (fp, root->static_fns); + dump_members (fp, root->friends); dump_members (fp, root->types); /* Superclasses. */ @@ -1312,7 +1304,6 @@ dump_tree (FILE *fp, struct sym *root) putc (')', fp); putc ('\n', fp); - return n; } @@ -1321,9 +1312,6 @@ dump_tree (FILE *fp, struct sym *root) static void dump_roots (FILE *fp) { - int i, n = 0; - struct sym *r; - /* Output file header containing version string, command line options etc. */ if (!f_append) @@ -1347,12 +1335,12 @@ dump_roots (FILE *fp) mark_inherited_virtual (); /* Dump the roots of the graph. */ - for (i = 0; i < TABLE_SIZE; ++i) - for (r = class_table[i]; r; r = r->next) + for (int i = 0; i < TABLE_SIZE; ++i) + for (struct sym *r = class_table[i]; r; r = r->next) if (!r->supers) { fputs (TREE_STRUCT, fp); - n += dump_tree (fp, r); + dump_tree (fp, r); putc (']', fp); } diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c index 7406ef3490e..73c8e45a865 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -1431,8 +1431,7 @@ local_sockname (int s, char sockname[socknamesize], int tmpdirlen, char *emacsdirend = sockname + tmpdirlen + suffixlen - strlen(server_name) - 1; *emacsdirend = '\0'; - int dir = openat (AT_FDCWD, sockname, - O_PATH | O_DIRECTORY | O_NOFOLLOW | O_CLOEXEC); + int dir = open (sockname, O_PATH | O_DIRECTORY | O_NOFOLLOW | O_CLOEXEC); *emacsdirend = '/'; if (dir < 0) return errno; diff --git a/lib/cdefs.h b/lib/cdefs.h index cb2514504f1..7b8ed5b344b 100644 --- a/lib/cdefs.h +++ b/lib/cdefs.h @@ -164,13 +164,13 @@ || (__builtin_constant_p (__l) && (__l) > 0)) /* Length is known to be safe at compile time if the __L * __S <= __OBJSZ - condition can be folded to a constant and if it is true. The -1 check is - redundant because since it implies that __glibc_safe_len_cond is true. */ + condition can be folded to a constant and if it is true, or unknown (-1) */ #define __glibc_safe_or_unknown_len(__l, __s, __osz) \ - (__glibc_unsigned_or_positive (__l) \ - && __builtin_constant_p (__glibc_safe_len_cond ((__SIZE_TYPE__) (__l), \ - __s, __osz)) \ - && __glibc_safe_len_cond ((__SIZE_TYPE__) (__l), __s, __osz)) + ((__osz) == (__SIZE_TYPE__) -1 \ + || (__glibc_unsigned_or_positive (__l) \ + && __builtin_constant_p (__glibc_safe_len_cond ((__SIZE_TYPE__) (__l), \ + (__s), (__osz))) \ + && __glibc_safe_len_cond ((__SIZE_TYPE__) (__l), (__s), (__osz)))) /* Conversely, we know at compile time that the length is unsafe if the __L * __S <= __OBJSZ condition can be folded to a constant and if it is diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h index 3e0c302af33..9270ced8973 100644 --- a/lib/fcntl.in.h +++ b/lib/fcntl.in.h @@ -435,6 +435,10 @@ _GL_WARN_ON_USE (openat, "openat is not portable - " # define AT_EACCESS 4 #endif +/* Ignore this flag if not supported. */ +#ifndef AT_NO_AUTOMOUNT +# define AT_NO_AUTOMOUNT 0 +#endif #endif /* _@GUARD_PREFIX@_FCNTL_H */ #endif /* _@GUARD_PREFIX@_FCNTL_H */ diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in index 3deeca98bef..bbb05fdba50 100644 --- a/lib/gnulib.mk.in +++ b/lib/gnulib.mk.in @@ -931,6 +931,7 @@ LIB_EXECINFO = @LIB_EXECINFO@ LIB_GETRANDOM = @LIB_GETRANDOM@ LIB_HAS_ACL = @LIB_HAS_ACL@ LIB_MATH = @LIB_MATH@ +LIB_NANOSLEEP = @LIB_NANOSLEEP@ LIB_PTHREAD = @LIB_PTHREAD@ LIB_PTHREAD_SIGMASK = @LIB_PTHREAD_SIGMASK@ LIB_TIMER_TIME = @LIB_TIMER_TIME@ @@ -1238,6 +1239,8 @@ WINDRES = @WINDRES@ WINT_T_SUFFIX = @WINT_T_SUFFIX@ XARGS_LIMIT = @XARGS_LIMIT@ XCB_LIBS = @XCB_LIBS@ +XCOMPOSITE_CFLAGS = @XCOMPOSITE_CFLAGS@ +XCOMPOSITE_LIBS = @XCOMPOSITE_LIBS@ XCRUN = @XCRUN@ XDBE_CFLAGS = @XDBE_CFLAGS@ XDBE_LIBS = @XDBE_LIBS@ @@ -1256,6 +1259,8 @@ XOBJ = @XOBJ@ XRANDR_CFLAGS = @XRANDR_CFLAGS@ XRANDR_LIBS = @XRANDR_LIBS@ XRENDER_LIBS = @XRENDER_LIBS@ +XSHAPE_CFLAGS = @XSHAPE_CFLAGS@ +XSHAPE_LIBS = @XSHAPE_LIBS@ XSYNC_CFLAGS = @XSYNC_CFLAGS@ XSYNC_LIBS = @XSYNC_LIBS@ XWIDGETS_OBJ = @XWIDGETS_OBJ@ diff --git a/lib/libc-config.h b/lib/libc-config.h index 8fec4893787..a56665b1ce3 100644 --- a/lib/libc-config.h +++ b/lib/libc-config.h @@ -121,6 +121,7 @@ # undef __attr_dealloc # undef __attr_dealloc_free # undef __attribute__ +# undef __attribute_alloc_align__ # undef __attribute_alloc_size__ # undef __attribute_artificial__ # undef __attribute_const__ @@ -129,6 +130,7 @@ # undef __attribute_format_arg__ # undef __attribute_format_strfmon__ # undef __attribute_malloc__ +# undef __attribute_maybe_unused__ # undef __attribute_noinline__ # undef __attribute_nonstring__ # undef __attribute_pure__ @@ -142,16 +144,24 @@ # undef __extern_always_inline # undef __extern_inline # undef __flexarr +# undef __fortified_attr_access # undef __fortify_function # undef __glibc_c99_flexarr_available +# undef __glibc_fortify +# undef __glibc_fortify_n # undef __glibc_has_attribute # undef __glibc_has_builtin # undef __glibc_has_extension +# undef __glibc_likely # undef __glibc_macro_warning # undef __glibc_macro_warning1 # undef __glibc_objsize # undef __glibc_objsize0 +# undef __glibc_safe_len_cond +# undef __glibc_safe_or_unknown_len # undef __glibc_unlikely +# undef __glibc_unsafe_len +# undef __glibc_unsigned_or_positive # undef __inline # undef __ptr_t # undef __restrict @@ -159,6 +169,7 @@ # undef __va_arg_pack # undef __va_arg_pack_len # undef __warnattr +# undef __wur /* Include our copy of glibc . */ # include diff --git a/lib/md5.h b/lib/md5.h index 5b92eac5ec8..611c230b817 100644 --- a/lib/md5.h +++ b/lib/md5.h @@ -24,6 +24,9 @@ #include # if HAVE_OPENSSL_MD5 +# ifndef OPENSSL_API_COMPAT +# define OPENSSL_API_COMPAT 0x10101000L /* FIXME: Use OpenSSL 1.1+ API. */ +# endif # include # endif diff --git a/lib/mini-gmp-gnulib.c b/lib/mini-gmp-gnulib.c index a18ee8f6ab7..7d09c80e9e9 100644 --- a/lib/mini-gmp-gnulib.c +++ b/lib/mini-gmp-gnulib.c @@ -40,7 +40,8 @@ #endif /* Pacify GCC -Wunused-variable for variables used only in 'assert' calls. */ -#if defined NDEBUG && 4 < __GNUC__ + (6 <= __GNUC_MINOR__) +#if (defined NDEBUG \ + && (4 < __GNUC__ + (6 <= __GNUC_MINOR__) || defined __clang__)) # pragma GCC diagnostic ignored "-Wunused-variable" #endif diff --git a/lib/mini-gmp.c b/lib/mini-gmp.c index e7a320a6420..95f067f82d6 100644 --- a/lib/mini-gmp.c +++ b/lib/mini-gmp.c @@ -10,7 +10,7 @@ The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free - Software Foundation, either version 3 of the License, or (at your + Software Foundation; either version 3 of the License, or (at your option) any later version. or @@ -90,6 +90,7 @@ see https://www.gnu.org/licenses/. */ #define gmp_assert_nocarry(x) do { \ mp_limb_t __cy = (x); \ assert (__cy == 0); \ + (void) (__cy); \ } while (0) #define gmp_clz(count, x) do { \ @@ -1937,9 +1938,8 @@ mpz_neg (mpz_t r, const mpz_t u) void mpz_swap (mpz_t u, mpz_t v) { - MP_SIZE_T_SWAP (u->_mp_size, v->_mp_size); MP_SIZE_T_SWAP (u->_mp_alloc, v->_mp_alloc); - MP_PTR_SWAP (u->_mp_d, v->_mp_d); + MPN_PTR_SWAP (u->_mp_d, u->_mp_size, v->_mp_d, v->_mp_size); } diff --git a/lib/openat.h b/lib/openat.h index 5c8ff90b804..56919ef8dc4 100644 --- a/lib/openat.h +++ b/lib/openat.h @@ -98,12 +98,14 @@ lchmodat (int fd, char const *file, mode_t mode) # define STATAT_INLINE _GL_INLINE # endif +_GL_ATTRIBUTE_DEPRECATED STATAT_INLINE int statat (int fd, char const *name, struct stat *st) { return fstatat (fd, name, st, 0); } +_GL_ATTRIBUTE_DEPRECATED STATAT_INLINE int lstatat (int fd, char const *name, struct stat *st) { diff --git a/lib/regcomp.c b/lib/regcomp.c index b607c85320f..122c3de58c3 100644 --- a/lib/regcomp.c +++ b/lib/regcomp.c @@ -2038,15 +2038,25 @@ peek_token_bracket (re_token_t *token, re_string_t *input, reg_syntax_t syntax) } switch (c) { - case '-': - token->type = OP_CHARSET_RANGE; - break; case ']': token->type = OP_CLOSE_BRACKET; break; case '^': token->type = OP_NON_MATCH_LIST; break; + case '-': + /* In V7 Unix grep and Unix awk and mawk, [...---...] + (3 adjacent minus signs) stands for a single minus sign. + Support that without breaking anything else. */ + if (! (re_string_cur_idx (input) + 2 < re_string_length (input) + && re_string_peek_byte (input, 1) == '-' + && re_string_peek_byte (input, 2) == '-')) + { + token->type = OP_CHARSET_RANGE; + break; + } + re_string_skip_bytes (input, 2); + FALLTHROUGH; default: token->type = CHARACTER; } diff --git a/lib/regex_internal.c b/lib/regex_internal.c index 3945ee7ecbf..0e6919f3400 100644 --- a/lib/regex_internal.c +++ b/lib/regex_internal.c @@ -1396,24 +1396,22 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token) if (__glibc_unlikely (new_nodes == NULL)) return -1; dfa->nodes = new_nodes; + dfa->nodes_alloc = new_nodes_alloc; new_nexts = re_realloc (dfa->nexts, Idx, new_nodes_alloc); + if (new_nexts != NULL) + dfa->nexts = new_nexts; new_indices = re_realloc (dfa->org_indices, Idx, new_nodes_alloc); + if (new_indices != NULL) + dfa->org_indices = new_indices; new_edests = re_realloc (dfa->edests, re_node_set, new_nodes_alloc); + if (new_edests != NULL) + dfa->edests = new_edests; new_eclosures = re_realloc (dfa->eclosures, re_node_set, new_nodes_alloc); + if (new_eclosures != NULL) + dfa->eclosures = new_eclosures; if (__glibc_unlikely (new_nexts == NULL || new_indices == NULL || new_edests == NULL || new_eclosures == NULL)) - { - re_free (new_nexts); - re_free (new_indices); - re_free (new_edests); - re_free (new_eclosures); - return -1; - } - dfa->nexts = new_nexts; - dfa->org_indices = new_indices; - dfa->edests = new_edests; - dfa->eclosures = new_eclosures; - dfa->nodes_alloc = new_nodes_alloc; + return -1; } dfa->nodes[dfa->nodes_len] = token; dfa->nodes[dfa->nodes_len].constraint = 0; diff --git a/lib/regexec.c b/lib/regexec.c index aea1e7da52c..521cb028415 100644 --- a/lib/regexec.c +++ b/lib/regexec.c @@ -1308,8 +1308,8 @@ push_fail_stack (struct re_fail_stack_t *fs, Idx str_idx, Idx dest_node, re_node_set *eps_via_nodes) { reg_errcode_t err; - Idx num = fs->num++; - if (fs->num == fs->alloc) + Idx num = fs->num; + if (num == fs->alloc) { struct re_fail_stack_ent_t *new_array; new_array = re_realloc (fs->stack, struct re_fail_stack_ent_t, @@ -1324,6 +1324,7 @@ push_fail_stack (struct re_fail_stack_t *fs, Idx str_idx, Idx dest_node, fs->stack[num].regs = re_malloc (regmatch_t, 2 * nregs); if (fs->stack[num].regs == NULL) return REG_ESPACE; + fs->num = num + 1; memcpy (fs->stack[num].regs, regs, sizeof (regmatch_t) * nregs); memcpy (fs->stack[num].regs + nregs, prevregs, sizeof (regmatch_t) * nregs); err = re_node_set_init_copy (&fs->stack[num].eps_via_nodes, eps_via_nodes); diff --git a/lib/sha1.h b/lib/sha1.h index 098678d8da6..bc3470a508d 100644 --- a/lib/sha1.h +++ b/lib/sha1.h @@ -23,6 +23,9 @@ # include # if HAVE_OPENSSL_SHA1 +# ifndef OPENSSL_API_COMPAT +# define OPENSSL_API_COMPAT 0x10101000L /* FIXME: Use OpenSSL 1.1+ API. */ +# endif # include # endif diff --git a/lib/sha256.h b/lib/sha256.h index dc9d87e615f..533173a59e8 100644 --- a/lib/sha256.h +++ b/lib/sha256.h @@ -22,6 +22,9 @@ # include # if HAVE_OPENSSL_SHA256 +# ifndef OPENSSL_API_COMPAT +# define OPENSSL_API_COMPAT 0x10101000L /* FIXME: Use OpenSSL 1.1+ API. */ +# endif # include # endif diff --git a/lib/sha512.h b/lib/sha512.h index f38819faf0f..1eb18702278 100644 --- a/lib/sha512.h +++ b/lib/sha512.h @@ -22,6 +22,9 @@ # include "u64.h" # if HAVE_OPENSSL_SHA512 +# ifndef OPENSSL_API_COMPAT +# define OPENSSL_API_COMPAT 0x10101000L /* FIXME: Use OpenSSL 1.1+ API. */ +# endif # include # endif diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h index d52c2f79638..a86643c3ca3 100644 --- a/lib/stdlib.in.h +++ b/lib/stdlib.in.h @@ -184,7 +184,11 @@ _GL_WARN_ON_USE (_Exit, "_Exit is unportable - " # undef free # define free rpl_free # endif +# if defined __cplusplus && (__GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2) +_GL_FUNCDECL_RPL (free, void, (void *ptr) throw ()); +# else _GL_FUNCDECL_RPL (free, void, (void *ptr)); +# endif _GL_CXXALIAS_RPL (free, void, (void *ptr)); # else _GL_CXXALIAS_SYS (free, void, (void *ptr)); diff --git a/lib/string.in.h b/lib/string.in.h index c9432948c15..33160b25254 100644 --- a/lib/string.in.h +++ b/lib/string.in.h @@ -125,14 +125,22 @@ _GL_EXTERN_C void rpl_free (void *); # if defined _MSC_VER _GL_EXTERN_C void __cdecl free (void *); # else +# if defined __cplusplus && (__GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2) +_GL_EXTERN_C void free (void *) throw (); +# else _GL_EXTERN_C void free (void *); +# endif # endif # endif #else # if defined _MSC_VER _GL_EXTERN_C void __cdecl free (void *); # else +# if defined __cplusplus && (__GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2) +_GL_EXTERN_C void free (void *) throw (); +# else _GL_EXTERN_C void free (void *); +# endif # endif #endif @@ -230,10 +238,11 @@ _GL_CXXALIAS_SYS_CAST2 (memchr, void const *, (void const *__s, int __c, size_t __n)); # endif # if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \ - && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4)) -_GL_CXXALIASWARN1 (memchr, void *, (void *__s, int __c, size_t __n)); + && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \ + || defined __clang__) +_GL_CXXALIASWARN1 (memchr, void *, (void *__s, int __c, size_t __n) throw ()); _GL_CXXALIASWARN1 (memchr, void const *, - (void const *__s, int __c, size_t __n)); + (void const *__s, int __c, size_t __n) throw ()); # elif __GLIBC__ >= 2 _GL_CXXALIASWARN (memchr); # endif @@ -315,9 +324,10 @@ _GL_CXXALIAS_SYS_CAST2 (memrchr, void *, (void const *, int, size_t), void const *, (void const *, int, size_t)); # if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \ - && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4)) -_GL_CXXALIASWARN1 (memrchr, void *, (void *, int, size_t)); -_GL_CXXALIASWARN1 (memrchr, void const *, (void const *, int, size_t)); + && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \ + || defined __clang__) +_GL_CXXALIASWARN1 (memrchr, void *, (void *, int, size_t) throw ()); +_GL_CXXALIASWARN1 (memrchr, void const *, (void const *, int, size_t) throw ()); # else _GL_CXXALIASWARN (memrchr); # endif @@ -345,9 +355,11 @@ _GL_CXXALIAS_SYS_CAST2 (rawmemchr, void *, (void const *__s, int __c_in), void const *, (void const *__s, int __c_in)); # if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \ - && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4)) -_GL_CXXALIASWARN1 (rawmemchr, void *, (void *__s, int __c_in)); -_GL_CXXALIASWARN1 (rawmemchr, void const *, (void const *__s, int __c_in)); + && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \ + || defined __clang__) +_GL_CXXALIASWARN1 (rawmemchr, void *, (void *__s, int __c_in) throw ()); +_GL_CXXALIASWARN1 (rawmemchr, void const *, + (void const *__s, int __c_in) throw ()); # else _GL_CXXALIASWARN (rawmemchr); # endif @@ -449,9 +461,11 @@ _GL_CXXALIAS_SYS_CAST2 (strchrnul, char const *, (char const *__s, int __c_in)); # endif # if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \ - && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4)) -_GL_CXXALIASWARN1 (strchrnul, char *, (char *__s, int __c_in)); -_GL_CXXALIASWARN1 (strchrnul, char const *, (char const *__s, int __c_in)); + && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \ + || defined __clang__) +_GL_CXXALIASWARN1 (strchrnul, char *, (char *__s, int __c_in) throw ()); +_GL_CXXALIASWARN1 (strchrnul, char const *, + (char const *__s, int __c_in) throw ()); # else _GL_CXXALIASWARN (strchrnul); # endif @@ -569,7 +583,7 @@ _GL_FUNCDECL_RPL (strndup, char *, _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE); _GL_CXXALIAS_RPL (strndup, char *, (char const *__s, size_t __n)); # else -# if !@HAVE_DECL_STRNDUP@ || __GNUC__ >= 11 +# if !@HAVE_DECL_STRNDUP@ || (__GNUC__ >= 11 && !defined strndup) _GL_FUNCDECL_SYS (strndup, char *, (char const *__s, size_t __n) _GL_ARG_NONNULL ((1)) @@ -579,7 +593,7 @@ _GL_CXXALIAS_SYS (strndup, char *, (char const *__s, size_t __n)); # endif _GL_CXXALIASWARN (strndup); #else -# if __GNUC__ >= 11 +# if __GNUC__ >= 11 && !defined strndup /* For -Wmismatched-dealloc: Associate strndup with free or rpl_free. */ _GL_FUNCDECL_SYS (strndup, char *, (char const *__s, size_t __n) @@ -651,10 +665,11 @@ _GL_CXXALIAS_SYS_CAST2 (strpbrk, char *, (char const *__s, char const *__accept), const char *, (char const *__s, char const *__accept)); # if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \ - && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4)) -_GL_CXXALIASWARN1 (strpbrk, char *, (char *__s, char const *__accept)); + && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \ + || defined __clang__) +_GL_CXXALIASWARN1 (strpbrk, char *, (char *__s, char const *__accept) throw ()); _GL_CXXALIASWARN1 (strpbrk, char const *, - (char const *__s, char const *__accept)); + (char const *__s, char const *__accept) throw ()); # elif __GLIBC__ >= 2 _GL_CXXALIASWARN (strpbrk); # endif @@ -759,10 +774,12 @@ _GL_CXXALIAS_SYS_CAST2 (strstr, const char *, (const char *haystack, const char *needle)); # endif # if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \ - && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4)) -_GL_CXXALIASWARN1 (strstr, char *, (char *haystack, const char *needle)); + && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \ + || defined __clang__) +_GL_CXXALIASWARN1 (strstr, char *, + (char *haystack, const char *needle) throw ()); _GL_CXXALIASWARN1 (strstr, const char *, - (const char *haystack, const char *needle)); + (const char *haystack, const char *needle) throw ()); # elif __GLIBC__ >= 2 _GL_CXXALIASWARN (strstr); # endif @@ -808,10 +825,12 @@ _GL_CXXALIAS_SYS_CAST2 (strcasestr, const char *, (const char *haystack, const char *needle)); # endif # if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \ - && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4)) -_GL_CXXALIASWARN1 (strcasestr, char *, (char *haystack, const char *needle)); + && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \ + || defined __clang__) +_GL_CXXALIASWARN1 (strcasestr, char *, + (char *haystack, const char *needle) throw ()); _GL_CXXALIASWARN1 (strcasestr, const char *, - (const char *haystack, const char *needle)); + (const char *haystack, const char *needle) throw ()); # else _GL_CXXALIASWARN (strcasestr); # endif diff --git a/lib/verify.h b/lib/verify.h index 07b2f4866f2..c5c63ae97c6 100644 --- a/lib/verify.h +++ b/lib/verify.h @@ -34,7 +34,7 @@ #ifndef __cplusplus # if (201112L <= __STDC_VERSION__ \ || (!defined __STRICT_ANSI__ \ - && (4 < __GNUC__ + (6 <= __GNUC_MINOR__) || 4 <= __clang_major__))) + && (4 < __GNUC__ + (6 <= __GNUC_MINOR__) || 5 <= __clang_major__))) # define _GL_HAVE__STATIC_ASSERT 1 # endif # if (202000L <= __STDC_VERSION__ \ @@ -215,6 +215,9 @@ template # define _GL_VERIFY(R, DIAGNOSTIC, ...) \ extern int (*_GL_GENSYM (_gl_verify_function) (void)) \ [_GL_VERIFY_TRUE (R, DIAGNOSTIC)] +# if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) +# pragma GCC diagnostic ignored "-Wnested-externs" +# endif #endif /* _GL_STATIC_ASSERT_H is defined if this code is copied into assert.h. */ diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 308407a8bf1..fabf6ed55e1 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -78,7 +78,9 @@ AUTOGENEL = ${loaddefs} ${srcdir}/cus-load.el ${srcdir}/finder-inf.el \ BYTE_COMPILE_FLAGS = \ --eval '(setq load-prefer-newer t)' $(BYTE_COMPILE_EXTRA_FLAGS) # ... but we must prefer .elc files for those in the early bootstrap. -compile-first: BYTE_COMPILE_FLAGS = $(BYTE_COMPILE_EXTRA_FLAGS) +# A larger `max-specpdl-size' is needed for emacs-lisp/comp.el. +compile-first: BYTE_COMPILE_FLAGS = \ + --eval '(setq max-specpdl-size 5000)' $(BYTE_COMPILE_EXTRA_FLAGS) # Files to compile before others during a bootstrap. This is done to # speed up the bootstrap process. They're ordered by size, so we use diff --git a/lisp/align.el b/lisp/align.el index b054b1bac47..9364d546654 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -546,15 +546,16 @@ The possible settings for `align-region-separate' are: (regexp . "\\(\\s-*\\)\\\\\\\\") (modes . align-tex-modes)) - ;; With a numeric prefix argument, or C-u, space delimited text - ;; tables will be aligned. + ;; Align space delimited text as columns. (text-column (regexp . "\\(^\\|\\S-\\)\\([ \t]+\\)\\(\\S-\\|$\\)") (group . 2) (modes . align-text-modes) (repeat . t) (run-if . ,(lambda () - (not (eq '- current-prefix-arg))))) + (and (not (eq '- current-prefix-arg)) + (not (apply #'provided-mode-derived-p + major-mode align-tex-modes)))))) ;; With a negative prefix argument, lists of dollar figures will ;; be aligned. diff --git a/lisp/apropos.el b/lisp/apropos.el index a98f2328ac2..79c4df10d25 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -663,7 +663,10 @@ search for matches for any two (or more) of those words. With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, consider all symbols (if they match PATTERN). -Return list of symbols and documentation found." +Return list of symbols and documentation found. + +The *Apropos* window will be selected if `help-window-select' is +non-nil." (interactive (list (apropos-read-pattern "symbol") current-prefix-arg)) (setq apropos--current (list #'apropos pattern do-all)) @@ -1249,7 +1252,9 @@ as a heading." (apropos-print-doc 5 'apropos-widget t) (apropos-print-doc 4 'apropos-plist nil)) (setq-local truncate-partial-width-windows t) - (setq-local truncate-lines t)))) + (setq-local truncate-lines t))) + (when help-window-select + (select-window (get-buffer-window "*Apropos*")))) (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 4f0edbbfa98..1c5faa1152b 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1063,7 +1063,8 @@ NEW-NAME." #'archive--file-desc-ext-file-name (or (archive-get-marked ?*) (list (archive-get-descr)))))) (list names - (read-file-name (format "Copy %s to: " (string-join names ", ")))))) + (read-file-name (format "Copy %s to: " (string-join names ", ")) + nil default-directory)))) (unless (consp files) (setq files (list files))) (when (and (> (length files) 1) @@ -1340,7 +1341,8 @@ NEW-NAME." t) (defun archive-*-write-file-member (archive descr command) - (let* ((ename (archive--file-desc-ext-file-name descr)) + (let* ((archive (expand-file-name archive)) + (ename (archive--file-desc-ext-file-name descr)) (tmpfile (expand-file-name ename archive-tmpdir)) (top (directory-file-name (file-name-as-directory archive-tmpdir))) (default-directory (file-name-as-directory top))) @@ -1364,6 +1366,7 @@ NEW-NAME." (setq ename (encode-coding-string ename archive-file-name-coding-system)) (let* ((coding-system-for-write 'no-conversion) + (default-directory (file-name-as-directory archive-tmpdir)) (exitcode (apply #'call-process (car command) nil diff --git a/lisp/auth-source.el b/lisp/auth-source.el index cb528cebdcd..fc62e36dfc2 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -573,19 +573,24 @@ which says: or P. The resulting token will only have keys user, host, and port.\" -:create \\='(A B C) also means to create a token if possible. +:create \\='(A B C) or +:create \\='(:unencrypted A B :encrypted C) +also means to create a token if possible. The behavior is like :create t but if the list contains any parameter, that parameter will be required in the resulting -token. The value for that parameter will be obtained from the -search parameters or from user input. If any queries are needed, -the alist `auth-source-creation-defaults' will be checked for the -default value. If the user, host, or port are missing, the alist -`auth-source-creation-prompts' will be used to look up the -prompts IN THAT ORDER (so the `user' prompt will be queried first, -then `host', then `port', and finally `secret'). Each prompt string -can use %u, %h, and %p to show the user, host, and port. The prompt -is formatted with `format-prompt', a trailing \": \" is removed. +token (the second form is used only with the plstore backend and +specifies if any of the extra parameters should be stored in +encrypted format.) The value for that parameter will be obtained +from the search parameters or from user input. If any queries +are needed, the alist `auth-source-creation-defaults' will be +checked for the default value. If the user, host, or port are +missing, the alist `auth-source-creation-prompts' will be used to +look up the prompts IN THAT ORDER (so the `user' prompt will be +queried first, then `host', then `port', and finally `secret'). +Each prompt string can use %u, %h, and %p to show the user, host, +and port. The prompt is formatted with `format-prompt', a +trailing \": \" is removed. Here's an example: @@ -862,7 +867,7 @@ while \(:host t) would find all host entries." secret))) (defun auth-source-pick-first-password (&rest spec) - "Pick the first secret found by applying 'auth-source-search' to SPEC." + "Pick the first secret found by applying `auth-source-search' to SPEC." (auth-info-password (car (apply #'auth-source-search (plist-put spec :max 1))))) (defun auth-source-format-prompt (prompt alist) @@ -1953,7 +1958,7 @@ entries for git.gnus.org: (defun auth-source--decode-octal-string (string) - "Convert octal STRING to utf-8 string. E.g: 'a\134b' to 'a\b'." + "Convert octal STRING to utf-8 string. E.g: \"a\134b\" to \"a\b\"." (let ((list (string-to-list string)) (size (length string))) (decode-coding-string @@ -2131,12 +2136,17 @@ entries for git.gnus.org: (let* ((base-required '(host user port secret)) (base-secret '(secret)) ;; we know (because of an assertion in auth-source-search) that the - ;; :create parameter is either t or a list (which includes nil) - (create-extra (if (eq t create) nil create)) + ;; :create parameter is either t, or a list (which includes nil + ;; or a plist) + (create-extra-secret (plist-get create :encrypted)) + (create-extra (if (eq t create) nil + (or (append (plist-get create :unencrypted) + create-extra-secret) create))) (current-data (car (auth-source-search :max 1 :host host :port port))) (required (append base-required create-extra)) + (required-secret (append base-secret create-extra-secret)) ;; `valist' is an alist valist ;; `artificial' will be returned if no creation is needed @@ -2158,10 +2168,11 @@ entries for git.gnus.org: (auth-source--aput valist br br-choice)))))) ;; for extra required elements, see if the spec includes a value for them - (dolist (er create-extra) - (let ((k (auth-source--symbol-keyword er)) - (keys (cl-loop for i below (length spec) by 2 - collect (nth i spec)))) + (let ((keys (cl-loop for i below (length spec) by 2 + collect (nth i spec))) + k) + (dolist (er create-extra) + (setq k (auth-source--symbol-keyword er)) (when (memq k keys) (auth-source--aput valist er (plist-get spec k))))) @@ -2225,7 +2236,7 @@ entries for git.gnus.org: (eval default))))) (when data - (if (member r base-secret) + (if (member r required-secret) (setq secret-artificial (plist-put secret-artificial (auth-source--symbol-keyword r) diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index f60aa9be6fa..d25275e3ec4 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -89,9 +89,10 @@ If this contains a %s, that will be replaced by the matching rule." :type 'string :version "28.1") +(declare-function sgml-tag "sgml-mode" (&optional str arg)) (defcustom auto-insert-alist - '((("\\.\\([Hh]\\|hh\\|hpp\\|hxx\\|h\\+\\+\\)\\'" . "C / C++ header") + `((("\\.\\([Hh]\\|hh\\|hpp\\|hxx\\|h\\+\\+\\)\\'" . "C / C++ header") (replace-regexp-in-string "[^A-Z0-9]" "_" (string-replace @@ -113,7 +114,7 @@ If this contains a %s, that will be replaced by the matching rule." (("[Mm]akefile\\'" . "Makefile") . "makefile.inc") - (html-mode . (lambda () (sgml-tag "html"))) + (html-mode . ,(lambda () (sgml-tag "html"))) (plain-tex-mode . "tex-insert.tex") (bibtex-mode . "tex-insert.tex") @@ -128,9 +129,9 @@ If this contains a %s, that will be replaced by the matching rule." "\n\\end{document}") (("/bin/.*[^/]\\'" . "Shell-Script mode magic number") . - (lambda () - (if (eq major-mode (default-value 'major-mode)) - (sh-mode)))) + ,(lambda () + (if (eq major-mode (default-value 'major-mode)) + (sh-mode)))) (ada-mode . ada-header) @@ -171,7 +172,7 @@ If this contains a %s, that will be replaced by the matching rule." '(setq v1 (let (modes) (mapatoms (lambda (mode) (let ((name (symbol-name mode))) - (when (string-match "-mode$" name) + (when (string-match "-mode\\'" name) (push name modes))))) (sort modes 'string<))) (completing-read "Local variables for mode: " v1 nil t) @@ -210,7 +211,8 @@ If this contains a %s, that will be replaced by the matching rule." "\n")) ((let ((minibuffer-help-form v2)) (completing-read "Keyword, C-h: " v1 nil t)) - str ", ") & -2 " + str ", ") + & -2 " \;; 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 diff --git a/lisp/bindings.el b/lisp/bindings.el index 8ae8c3d60ef..bfe5ba86237 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -1127,6 +1127,7 @@ if `inhibit-field-text-motion' is non-nil." (define-key goto-map "p" 'previous-error) (define-key goto-map "\M-p" 'previous-error) (define-key goto-map "\t" 'move-to-column) +(define-key goto-map "i" 'imenu) (defvar search-map (make-sparse-keymap) "Keymap for search related commands.") @@ -1402,10 +1403,8 @@ if `inhibit-field-text-motion' is non-nil." (define-key esc-map [?\C-\ ] 'mark-sexp) (define-key esc-map "\C-d" 'down-list) (define-key esc-map "\C-k" 'kill-sexp) -;;; These are dangerous in various situations, -;;; so let's not encourage anyone to use them. -;;;(define-key global-map [C-M-delete] 'backward-kill-sexp) -;;;(define-key global-map [C-M-backspace] 'backward-kill-sexp) +(define-key global-map [C-M-delete] 'backward-kill-sexp) +(define-key global-map [C-M-backspace] 'backward-kill-sexp) (define-key esc-map [C-delete] 'backward-kill-sexp) (define-key esc-map [C-backspace] 'backward-kill-sexp) (define-key esc-map "\C-n" 'forward-list) diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 80fb1cdfc78..c604395dd7d 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -246,11 +246,13 @@ functions have a binding in this keymap." Bookmark functions update the value automatically. You probably do NOT want to change the value yourself. -The value is an alist with bookmarks of the form +The value is an alist whose elements are of the form (BOOKMARK-NAME . PARAM-ALIST) -or the deprecated form (BOOKMARK-NAME PARAM-ALIST). +or the deprecated form (BOOKMARK-NAME PARAM-ALIST). The alist is +ordered from most recently created bookmark at the front to least +recently created bookmark at the end. BOOKMARK-NAME is the name you gave to the bookmark when creating it. @@ -583,10 +585,10 @@ old one." ;; Modify using the new (NAME . ALIST) format. (setcdr bm alist)) - ;; otherwise just cons it onto the front (either the bookmark - ;; doesn't exist already, or there is no prefix arg. In either - ;; case, we want the new bookmark consed onto the alist...) - + ;; Otherwise just put it onto the front of the list. Either the + ;; bookmark doesn't exist already, or there is no prefix arg. + ;; In either case, we want the new bookmark on the front of the + ;; list, since the list is kept in reverse order of creation. (push (cons stripped-name alist) bookmark-alist)) ;; Added by db @@ -1140,7 +1142,9 @@ it to the name of the bookmark currently being set, advancing (defun bookmark-maybe-sort-alist () "Return `bookmark-alist' for display. -If `bookmark-sort-flag' is non-nil, then return a sorted copy of the alist." +If `bookmark-sort-flag' is non-nil, then return a sorted copy of the alist. +Otherwise, just return `bookmark-alist', which by default is ordered +from most recently created to least recently created bookmark." (if bookmark-sort-flag (sort (copy-alist bookmark-alist) (lambda (x y) (string-lessp (car x) (car y)))) @@ -1728,6 +1732,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." "x" #'bookmark-bmenu-execute-deletions "d" #'bookmark-bmenu-delete "D" #'bookmark-bmenu-delete-all + "S-SPC" #'previous-line "SPC" #'next-line "DEL" #'bookmark-bmenu-backup-unmark "u" #'bookmark-bmenu-unmark @@ -1818,8 +1823,34 @@ Don't affect the buffer ring order." ,@(if bookmark-bmenu-toggle-filenames (list location))]) entries))) - (tabulated-list-init-header) - (setq tabulated-list-entries (reverse entries))) + ;; The value of `bookmark-sort-flag' might have changed since the + ;; last time the buffer contents were generated, so re-check it. + (if bookmark-sort-flag + (progn + (setq tabulated-list-sort-key '("Bookmark Name" . nil)) + (setq tabulated-list-entries entries)) + (setq tabulated-list-sort-key nil) + ;; And since we're not sorting by bookmark name, show bookmarks + ;; according to order of creation, with the most recently + ;; created bookmarks at the top and the least recently created + ;; at the bottom. + ;; + ;; Note that clicking the column sort toggle for the bookmark + ;; name column will invoke the `tabulated-list-mode' sort, which + ;; uses `bookmark-bmenu--name-predicate' to sort lexically by + ;; bookmark name instead of by (reverse) creation order. + ;; Clicking the toggle again will reverse the lexical sort, but + ;; the sort will still be lexical not creation-order. However, + ;; if the user reverts the buffer, then the above check of + ;; `bookmark-sort-flag' will happen again and the buffer will + ;; go back to a creation-order sort. This is all expected + ;; behavior, as documented in `bookmark-bmenu-mode'. + (setq tabulated-list-entries (reverse entries))) + ;; Generate the header only after `tabulated-list-sort-key' is + ;; settled, because if that's non-nil then the sort-direction + ;; indicator will be shown in the named column, but if it's + ;; nil then the indicator will not be shown. + (tabulated-list-init-header)) (tabulated-list-print t)) ;;;###autoload @@ -1863,6 +1894,18 @@ deletion, or > if it is flagged for displaying." Each line describes one of the bookmarks in Emacs. Letters do not insert themselves; instead, they are commands. Bookmark names preceded by a \"*\" have annotations. + +If `bookmark-sort-flag' is non-nil, then sort the list by +bookmark name (case-insensitively, in collation order); the +direction of that sort can be reversed by using the column sort +toggle for the bookmark name column. + +If `bookmark-sort-flag' is nil, then sort the list by bookmark +creation order, with most recently created bookmarks on top. +However, the column sort toggle will still activate (and +thereafter toggle the direction of) lexical sorting by bookmark name. +At any time you may use \\[revert-buffer] to go back to sorting by creation order. + \\ \\[bookmark-bmenu-mark] -- mark bookmark to be displayed. \\[bookmark-bmenu-mark-all] -- mark all listed bookmarks to be displayed. @@ -1895,20 +1938,23 @@ Bookmark names preceded by a \"*\" have annotations. in another buffer. \\[bookmark-bmenu-show-all-annotations] -- show the annotations of all bookmarks in another buffer. \\[bookmark-bmenu-edit-annotation] -- edit the annotation for the current bookmark. -\\[bookmark-bmenu-search] -- incrementally search for bookmarks." +\\[bookmark-bmenu-search] -- incrementally search for bookmarks. +\\[revert-buffer] -- refresh the buffer, and thus refresh the sort order (useful + if `bookmark-sort-flag' is nil)." (setq truncate-lines t) (setq buffer-read-only t) ;; FIXME: The header could also display the current default bookmark file ;; according to `bookmark-bookmarks-timestamp'. (setq tabulated-list-format `[("" 1) ;; Space to add "*" for bookmark with annotation - ("Bookmark" ,bookmark-bmenu-file-column bookmark-bmenu--name-predicate) + ("Bookmark Name" + ,bookmark-bmenu-file-column bookmark-bmenu--name-predicate) ("Type" 8 bookmark-bmenu--type-predicate) ,@(if bookmark-bmenu-toggle-filenames '(("File" 0 bookmark-bmenu--file-predicate)))]) (setq tabulated-list-padding bookmark-bmenu-marks-width) (when bookmark-sort-flag - (setq tabulated-list-sort-key '("Bookmark" . nil))) + (setq tabulated-list-sort-key '("Bookmark Name" . nil))) (add-hook 'tabulated-list-revert-hook #'bookmark-bmenu--revert nil t)' (setq revert-buffer-function 'bookmark-bmenu--revert) (tabulated-list-init-header)) @@ -1917,17 +1963,19 @@ Bookmark names preceded by a \"*\" have annotations. (defun bookmark-bmenu--name-predicate (a b) "Predicate to sort \"*Bookmark List*\" buffer by the name column. This is used for `tabulated-list-format' in `bookmark-bmenu-mode'." - (string< (caar a) (caar b))) + (string-collate-lessp (caar a) (caar b) nil t)) (defun bookmark-bmenu--type-predicate (a b) "Predicate to sort \"*Bookmark List*\" buffer by the type column. This is used for `tabulated-list-format' in `bookmark-bmenu-mode'." - (string< (elt (cadr a) 2) (elt (cadr b) 2))) + (string-collate-lessp (elt (cadr a) 2) (elt (cadr b) 2) nil t)) (defun bookmark-bmenu--file-predicate (a b) "Predicate to sort \"*Bookmark List*\" buffer by the file column. This is used for `tabulated-list-format' in `bookmark-bmenu-mode'." - (string< (bookmark-location (car a)) (bookmark-location (car b)))) + (string-collate-lessp (bookmark-location (car a)) + (bookmark-location (car b)) + nil t)) (defun bookmark-bmenu-toggle-filenames (&optional show) diff --git a/lisp/button.el b/lisp/button.el index 8a7751d00da..80b73033d68 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -55,29 +55,24 @@ "Default face used for buttons." :group 'basic-faces) -(defvar button-map - (let ((map (make-sparse-keymap))) - ;; The following definition needs to avoid using escape sequences that - ;; might get converted to ^M when building loaddefs.el - (define-key map [(control ?m)] 'push-button) - (define-key map [mouse-2] 'push-button) - (define-key map [follow-link] 'mouse-face) - ;; FIXME: You'd think that for keymaps coming from text-properties on the - ;; mode-line or header-line, the `mode-line' or `header-line' prefix - ;; shouldn't be necessary! - (define-key map [mode-line mouse-2] 'push-button) - (define-key map [header-line mouse-2] 'push-button) - map) - "Keymap used by buttons.") +(defvar-keymap button-buffer-map + :doc "Keymap useful for buffers containing buttons. +Mode-specific keymaps may want to use this as their parent keymap." + "TAB" #'forward-button + "ESC TAB" #'backward-button + "" #'backward-button) -(defvar button-buffer-map - (let ((map (make-sparse-keymap))) - (define-key map [?\t] 'forward-button) - (define-key map "\e\t" 'backward-button) - (define-key map [backtab] 'backward-button) - map) - "Keymap useful for buffers containing buttons. -Mode-specific keymaps may want to use this as their parent keymap.") +(defvar-keymap button-map + :doc "Keymap used by buttons." + :parent button-buffer-map + "RET" #'push-button + "" #'push-button + "" 'mouse-face + ;; FIXME: You'd think that for keymaps coming from text-properties on the + ;; mode-line or header-line, the `mode-line' or `header-line' prefix + ;; shouldn't be necessary! + " " #'push-button + " " #'push-button) (define-minor-mode button-mode "A minor mode for navigating to buttons with the TAB key." @@ -625,17 +620,34 @@ When clicked, CALLBACK will be called with the DATA as the function argument. If DATA isn't present (or is nil), the button itself will be used instead as the function argument. -If HELP-ECHO, use that as the `help-echo' property." - (propertize string - 'face 'button - 'mouse-face 'highlight - 'help-echo help-echo - 'button t - 'follow-link t - 'category t - 'button-data data - 'keymap button-map - 'action callback)) +If HELP-ECHO, use that as the `help-echo' property. + +Also see `buttonize-region'." + (apply #'propertize string + (button--properties callback data help-echo))) + +(defun button--properties (callback data help-echo) + (list 'face 'button + 'font-lock-face 'button + 'mouse-face 'highlight + 'help-echo help-echo + 'button t + 'follow-link t + 'category t + 'button-data data + 'keymap button-map + 'action callback)) + +(defun buttonize-region (start end callback &optional data help-echo) + "Make the region between START and END into a button. +When clicked, CALLBACK will be called with the DATA as the +function argument. If DATA isn't present (or is nil), the button +itself will be used instead as the function argument. + +If HELP-ECHO, use that as the `help-echo' property. + +Also see `buttonize'." + (add-text-properties start end (button--properties callback data help-echo))) (provide 'button) diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el index 8c6d3f51e5d..172ccf1adcd 100644 --- a/lisp/calc/calc-yank.el +++ b/lisp/calc/calc-yank.el @@ -47,6 +47,8 @@ (calc-check-stack num) (let ((stuff (calc-top-list n (- num n -1)))) (calc-cursor-stack-index num) + (unless calc-kill-line-numbering + (re-search-forward "\\=[0-9]+:\\s-+" (point-at-eol) t)) (let ((first (point))) (calc-cursor-stack-index (- num n)) (if (null nn) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 3b1cf248fd9..b03dcfeb5b7 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -439,6 +439,14 @@ to be identified as that note." :version "24.1" :type 'string) +(defcustom calc-kill-line-numbering t + "If non-nil, calculator kills include any line numbering. + +This option does not affect calc kill and copy commands which +operate on the region, such as `calc-copy-region-as-kill'." + :version "29.1" + :type 'boolean) + (defvar math-format-date-cache) ; calc-forms.el (defface calc-nonselected-face @@ -1375,7 +1383,7 @@ Notations: 3.14e6 3.14 * 10^6 LONG is a desired text for a wide window, SHORT is a desired abbreviated text, and width is the buffer width, which will be -some fraction of the 'parent' window width (At the time of +some fraction of the \"parent\" window width (At the time of writing, 2/3 for calc, 1/3 for trail). The optional FUDGE is a trial-and-error adjustment number for the edge-cases at the border of the two cases." @@ -1816,7 +1824,7 @@ See calc-keypad for details." (if win (progn (calc-cursor-stack-index 0) - (vertical-motion (- 2 (window-height win))) + (vertical-motion (- 3 (window-height win 'floor))) (set-window-start win (point))))) (calc-cursor-stack-index 0) (if (looking-at " *\\.$") diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el index ebdafb438e3..a7d13cff9a1 100644 --- a/lisp/calendar/appt.el +++ b/lisp/calendar/appt.el @@ -510,9 +510,13 @@ The time should be in either 24 hour format or am/pm format. Optional argument WARNTIME is an integer (or string) giving the number of minutes before the appointment at which to start warning. The default is `appt-message-warning-time'." - (interactive "sTime (hh:mm[am/pm]): \nsMessage: \n\ -sMinutes before the appointment to start warning: ") - (unless (string-match appt-time-regexp time) + (interactive (list (let ((time (read-string "Time (hh:mm[am/pm]): "))) + (unless (string-match-p appt-time-regexp time) + (user-error "Unacceptable time-string")) + time) + (read-string "Message: ") + (read-string "Minutes before the appointment to start warning: "))) + (unless (string-match-p appt-time-regexp time) (user-error "Unacceptable time-string")) (and (stringp warntime) (setq warntime (unless (string-equal warntime "") diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index 61ce029e077..1c08de53fbd 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -798,6 +798,10 @@ In this case, the following civil date corresponds to the Hebrew birthday." (diary-ordinal-suffix age) (if (= b-date d) "" " (evening)"))))) +(defvar diary-hebrew-omer-sefirot + ["Hesed" "Gevurah" "Tiferet" "Netzach" "Hod" "Yesod" "Malchut"] + "The order of Sefirot for counting the Omer. +See https://opensiddur.org/prayers/solilunar/solar-cycles/sefirat-haomer/the-order-of-counting-the-omer-in-the-spring/") ;;;###diary-autoload (defun diary-hebrew-omer (&optional mark) "Omer count diary entry. @@ -813,7 +817,7 @@ use when highlighting the day in the calendar." (day (% omer 7))) (if (and (> omer 0) (< omer 50)) (cons mark - (format "Day %d%s of the omer (until sunset)" + (format "Day %d%s of the omer (until sunset) %s she'be'%s" omer (if (zerop week) "" @@ -823,7 +827,10 @@ use when highlighting the day in the calendar." (if (zerop day) "" (format " and %d day%s" - day (if (= day 1) "" "s")))))))))) + day (if (= day 1) "" "s"))))) + (aref diary-hebrew-omer-sefirot (% (+ 6 day) 7)) + (aref diary-hebrew-omer-sefirot + (+ (if (zerop day) -1 0) week))))))) (autoload 'diary-make-date "diary-lib") diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el index 2afa667a56c..7e11044dbc0 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el @@ -400,6 +400,36 @@ This function is suitable for execution in an init file." (displayed-year (calendar-extract-year date))) (calendar-list-holidays)))) +(defun holiday-available-holiday-lists () + "Return a list of all holiday lists. +This is used by `list-holidays', and you can customize the return +value by using `add-function'." + (delq + nil + (list + (cons "All" calendar-holidays) + (cons "Equinoxes/Solstices" + (list (list 'solar-equinoxes-solstices))) + (if holiday-general-holidays + (cons "General" holiday-general-holidays)) + (if holiday-local-holidays + (cons "Local" holiday-local-holidays)) + (if holiday-other-holidays + (cons "Other" holiday-other-holidays)) + (if holiday-christian-holidays + (cons "Christian" holiday-christian-holidays)) + (if holiday-hebrew-holidays + (cons "Hebrew" holiday-hebrew-holidays)) + (if holiday-islamic-holidays + (cons "Islamic" holiday-islamic-holidays)) + (if holiday-bahai-holidays + (cons "Bahá’í" holiday-bahai-holidays)) + (if holiday-oriental-holidays + (cons "Oriental" holiday-oriental-holidays)) + (if holiday-solar-holidays + (cons "Solar" holiday-solar-holidays)) + (cons "Ask" nil)))) + ;; rms: "Emacs commands to display a list of something generally start ;; with `list-'. Please make `list-holidays' the principal name." ;;;###autoload @@ -421,7 +451,12 @@ documentation of `calendar-holidays' for a list of the variables that control the choices, as well as a description of the format of a holiday list. -The optional LABEL is used to label the buffer created." +The optional LABEL is used to label the buffer created. + +The list of holiday lists is computed by the +`holiday-available-holiday-lists' and you can alter the results +by redefining that function, or use `add-function' to add +values." (interactive (let* ((start-year (calendar-read-sexp "Starting year of holidays (>0)" @@ -433,30 +468,7 @@ The optional LABEL is used to label the buffer created." start-year start-year)) (completion-ignore-case t) - (lists - (list - (cons "All" calendar-holidays) - (cons "Equinoxes/Solstices" - (list (list 'solar-equinoxes-solstices))) - (if holiday-general-holidays - (cons "General" holiday-general-holidays)) - (if holiday-local-holidays - (cons "Local" holiday-local-holidays)) - (if holiday-other-holidays - (cons "Other" holiday-other-holidays)) - (if holiday-christian-holidays - (cons "Christian" holiday-christian-holidays)) - (if holiday-hebrew-holidays - (cons "Hebrew" holiday-hebrew-holidays)) - (if holiday-islamic-holidays - (cons "Islamic" holiday-islamic-holidays)) - (if holiday-bahai-holidays - (cons "Bahá’í" holiday-bahai-holidays)) - (if holiday-oriental-holidays - (cons "Oriental" holiday-oriental-holidays)) - (if holiday-solar-holidays - (cons "Solar" holiday-solar-holidays)) - (cons "Ask" nil))) + (lists (holiday-available-holiday-lists)) (choice (capitalize (completing-read "List (TAB for choices): " lists nil t))) (which (if (string-equal choice "Ask") diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 51cf7eb213f..ba7c48b290d 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -287,17 +287,23 @@ use. \"%,1s\" means \"use one decimal\". The \"%z\" specifier does not print anything. When it is used, specifiers must be given in order of decreasing size. To the left of \"%z\", nothing -is output until the first non-zero unit is encountered." +is output until the first non-zero unit is encountered. + +The \"%x\" specifier does not print anything. When it is used, +specifiers must be given in order of decreasing size. To the +right of \"%x\", trailing zero units are not output." (let ((start 0) (units '(("y" "year" 31536000) ("d" "day" 86400) ("h" "hour" 3600) ("m" "minute" 60) ("s" "second" 1) - ("z"))) + ("z") + ("x"))) (case-fold-search t) - spec match usedunits zeroflag larger prev name unit num zeropos - fraction) + spec match usedunits zeroflag larger prev name unit num + leading-zeropos trailing-zeropos fraction + chop-leading chop-trailing) (while (string-match "%\\.?[0-9]*\\(,[0-9]\\)?\\(.\\)" string start) (setq start (match-end 0) spec (match-string 2 string)) @@ -306,15 +312,16 @@ is output until the first non-zero unit is encountered." (error "Bad format specifier: `%s'" spec)) (if (assoc (downcase spec) usedunits) (error "Multiple instances of specifier: `%s'" spec)) - (if (string-equal (car match) "z") + (if (or (string-equal (car match) "z") + (string-equal (car match) "x")) (setq zeroflag t) (unless larger (setq unit (nth 2 match) larger (and prev (> unit prev)) prev unit))) (push match usedunits))) - (and zeroflag larger - (error "Units are not in decreasing order of size")) + (when (and zeroflag larger) + (error "Units are not in decreasing order of size")) (unless (numberp seconds) (setq seconds (float-time seconds))) (setq fraction (mod seconds 1) @@ -326,18 +333,28 @@ is output until the first non-zero unit is encountered." (when (string-match (format "%%\\(\\.?[0-9]+\\)?\\(,[0-9]+\\)?\\(%s\\)" spec) string) - (if (string-equal spec "z") ; must be last in units - (setq string - (replace-regexp-in-string - "%z" "" - (substring string (min (or zeropos (match-end 0)) - (match-beginning 0))))) + (cond + ((string-equal spec "z") + (setq chop-leading (and leading-zeropos + (min leading-zeropos (match-beginning 0))))) + ((string-equal spec "x") + (setq chop-trailing t)) + (t ;; Cf article-make-date-line in gnus-art. (setq num (floor seconds unit) seconds (- seconds (* num unit))) - ;; Start position of the first non-zero unit. - (or zeropos - (setq zeropos (unless (zerop num) (match-beginning 0)))) + (let ((is-zero (zerop (if (= unit 1) + (+ num fraction) + num)))) + ;; Start position of the first non-zero unit. + (when (and (not leading-zeropos) + (not is-zero)) + (setq leading-zeropos (match-beginning 0))) + (unless is-zero + (setq trailing-zeropos nil)) + (when (and (not trailing-zeropos) + is-zero) + (setq trailing-zeropos (match-beginning 0)))) (setq string (replace-match (format (if (match-string 2 string) @@ -360,7 +377,17 @@ is output until the first non-zero unit is encountered." (format " %s%s" name (if (= num 1) "" "s")))) t t string)))))) - (string-replace "%%" "%" string)) + (let ((pre string)) + (when (and chop-trailing trailing-zeropos) + (setq string (substring string 0 trailing-zeropos))) + (when chop-leading + (setq string (substring string chop-leading))) + ;; If we ended up removing everything, return the formatted + ;; string in full. + (when (equal string "") + (setq string pre))) + (setq string (replace-regexp-in-string "%[zx]" "" string))) + (string-trim (string-replace "%%" "%" string))) (defvar seconds-to-string (list (list 1 "ms" 0.001) diff --git a/lisp/cedet/ede/files.el b/lisp/cedet/ede/files.el index 3b9002a6e31..b8acb192c17 100644 --- a/lisp/cedet/ede/files.el +++ b/lisp/cedet/ede/files.el @@ -257,7 +257,7 @@ If optional EXACT is non-nil, only return exact matches for DIR." (defun ede-flush-directory-hash () "Flush the project directory hash. Do this only when developing new projects that are incorrectly putting -'nomatch tokens into the hash." +`nomatch' tokens into the hash." (interactive) (setq ede-project-directory-hash (make-hash-table :test 'equal)) ;; Also slush the current project's locator hash. diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el index dc6751db6cf..78002dd8abc 100644 --- a/lisp/cedet/semantic.el +++ b/lisp/cedet/semantic.el @@ -497,8 +497,8 @@ is requested." (defvar semantic-working-type 'percent "The type of working message to use when parsing. -'percent means we are doing a linear parse through the buffer. -'dynamic means we are reparsing specific tags.") +`percent' means we are doing a linear parse through the buffer. +`dynamic' means we are reparsing specific tags.") (defvar semantic-minimum-working-buffer-size (* 1024 5) "The minimum size of a buffer before working messages are displayed. diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el index 7f25a848918..82785ec6d2e 100644 --- a/lisp/cedet/semantic/db.el +++ b/lisp/cedet/semantic/db.el @@ -729,7 +729,7 @@ Exit the save between databases if there is user input." (defvar semanticdb-project-predicate-functions nil "List of predicates to try that indicate a directory belongs to a project. This list is used when `semanticdb-persistent-path' contains the value -'project. If the predicate list is nil, then presume all paths are valid. +`project'. If the predicate list is nil, then presume all paths are valid. Project Management software (such as EDE and JDE) should add their own predicates with `add-hook' to this variable, and semanticdb will save tag diff --git a/lisp/cedet/semantic/find.el b/lisp/cedet/semantic/find.el index e894022315f..92644ce0066 100644 --- a/lisp/cedet/semantic/find.el +++ b/lisp/cedet/semantic/find.el @@ -591,7 +591,7 @@ in the new list. If optional argument SEARCH-PARTS is non-nil, all sub-parts of tags are searched. The overloadable function `semantic-tag-components' is used for the searching child lists. If SEARCH-PARTS is the symbol -'positiononly, then only children that have positional information are +`positiononly', then only children that have positional information are searched. If SEARCH-INCLUDES has not been implemented. diff --git a/lisp/cedet/semantic/java.el b/lisp/cedet/semantic/java.el index a7c02032e22..9b70afd0a33 100644 --- a/lisp/cedet/semantic/java.el +++ b/lisp/cedet/semantic/java.el @@ -391,7 +391,7 @@ That is TAG `symbol-name' without the leading `@'." Return the list of FUN results. If optional PROPERTY is non-nil only call FUN for javadoc keywords which have a value for PROPERTY. FUN receives two arguments: the javadoc keyword and its associated -'javadoc property list. It can return any value. All nil values are +`javadoc' property list. It can return any value. All nil values are removed from the result list." (delq nil (mapcar diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el index 26a3b39f0d6..57e59f4e9fe 100644 --- a/lisp/cedet/semantic/lex-spp.el +++ b/lisp/cedet/semantic/lex-spp.el @@ -726,7 +726,7 @@ Returns position with the end of that macro." (point)))))) (defun semantic-lex-spp-get-overlay (&optional point) - "Return first overlay which has a 'semantic-spp property." + "Return first overlay which has a `semantic-spp' property." (let ((overlays (overlays-at (or point (point))))) (while (and overlays (null (overlay-get (car overlays) 'semantic-spp))) diff --git a/lisp/cedet/semantic/symref.el b/lisp/cedet/semantic/symref.el index ba236059f66..e48cefa4ca6 100644 --- a/lisp/cedet/semantic/symref.el +++ b/lisp/cedet/semantic/symref.el @@ -101,7 +101,7 @@ Where PREDICATE is a function that takes a directory name for the root of a project, and returns non-nil if the tool represented by KEY is supported. -If no tools are supported, then 'grep is assumed.") +If no tools are supported, then `grep' is assumed.") (defun semantic-symref-calculate-rootdir () "Calculate the root directory for a symref search. @@ -475,7 +475,7 @@ already." Return the Semantic tag associated with HIT. SEARCHTXT is the text that is being searched for. Used to narrow the in-buffer search. -SEARCHTYPE is the type of search (such as 'symbol or 'tagname). +SEARCHTYPE is the type of search (such as `symbol' or `tagname'). If there is no database, or if the searchtype is wrong, return nil." ;; Allowed search types for this mechanism: ;; tagname, tagregexp, tagcompletions @@ -506,7 +506,7 @@ If there is no database, or if the searchtype is wrong, return nil." Return the Semantic tag associated with HIT. SEARCHTXT is the text that is being searched for. Used to narrow the in-buffer search. -SEARCHTYPE is the type of search (such as 'symbol or 'tagname). +SEARCHTYPE is the type of search (such as `symbol' or `tagname'). Optional OPEN-BUFFERS, when nil will use a faster version of `find-file' when a file needs to be opened. If non-nil, then normal buffer initialization will be used. diff --git a/lisp/color.el b/lisp/color.el index 0fe663d97a7..fe629f4f988 100644 --- a/lisp/color.el +++ b/lisp/color.el @@ -403,7 +403,7 @@ See `color-desaturate-hsl'." Given a color defined in terms of hue, saturation, and luminance \(arguments H, S, and L), return a color that is PERCENT lighter. Returns a list (HUE SATURATION LUMINANCE)." - (list H S (color-clamp (+ L (/ percent 100.0))))) + (list H S (color-clamp (+ L (* L (/ percent 100.0)))))) (defun color-lighten-name (name percent) "Make a color with a specified NAME lighter by PERCENT. diff --git a/lisp/comint.el b/lisp/comint.el index 4c82e74e4bc..88eaf1120e3 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -1110,7 +1110,8 @@ See also `comint-read-input-ring'." (use-local-map keymap)) (forward-line 3) (while (search-backward "completion" nil 'move) - (replace-match "history reference"))) + (replace-match (apply #'propertize "history reference" + (text-properties-at (point)))))) (sit-for 0) (message "Hit space to flush") (setq comint-dynamic-list-input-ring-window-conf conf) @@ -1515,6 +1516,7 @@ Intended to be added to `isearch-mode-hook' in `comint-mode'." #'comint-history-isearch-wrap) (setq-local isearch-push-state-function #'comint-history-isearch-push-state) + (setq-local isearch-lazy-count nil) (add-hook 'isearch-mode-end-hook 'comint-history-isearch-end nil t))) (defun comint-history-isearch-end () @@ -1526,6 +1528,7 @@ Intended to be added to `isearch-mode-hook' in `comint-mode'." (setq isearch-message-function nil) (setq isearch-wrap-function nil) (setq isearch-push-state-function nil) + (kill-local-variable 'isearch-lazy-count) (remove-hook 'isearch-mode-end-hook 'comint-history-isearch-end t) (unless isearch-suspended (custom-reevaluate-setting 'comint-history-isearch))) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index bec7348099a..dae97b02303 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1560,12 +1560,12 @@ If TYPE is `groups', include only groups." ;;;###autoload (defun custom-prompt-customize-unsaved-options () "Prompt user to customize any unsaved customization options. -Return non-nil if user chooses to customize, for use in +Return nil if user chooses to customize, for use in `kill-emacs-query-functions'." (not (and (custom-unsaved-options) - (yes-or-no-p "Some customized options have not been saved; Examine? ") - (customize-unsaved) - t))) + (yes-or-no-p + "Some customized options have not been saved; Examine? ") + (progn (customize-unsaved) t)))) ;;; Buffer. @@ -4798,7 +4798,11 @@ if only the first line of the docstring is shown.")) (delay-mode-hooks (emacs-lisp-mode))) (let ((inhibit-read-only t) (print-length nil) - (print-level nil)) + (print-level nil) + ;; We might be saving byte-code with embedded NULs, which + ;; can cause problems when read back, so print them + ;; readably. (Bug#52554) + (print-escape-control-characters t)) (atomic-change-group (custom-save-variables) (custom-save-faces))) diff --git a/lisp/descr-text.el b/lisp/descr-text.el index a8160889325..0f01ad676ae 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -176,6 +176,10 @@ otherwise." (insert "\n")) ;; Text properties (when properties + (when (plist-get properties 'invisible) + (insert "\nNote that character has an invisibility property,\n" + " so the character displayed at point in the buffer may\n" + " differ from the character described here.\n")) (newline) (insert "There are text properties here:\n") (describe-property-list properties))))) diff --git a/lisp/desktop.el b/lisp/desktop.el index e7a368e21f5..1a4103e2090 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -230,16 +230,26 @@ Zero or nil means disable auto-saving due to idleness." (defcustom desktop-load-locked-desktop 'ask "Specifies whether the desktop should be loaded if locked. Possible values are: - t -- load anyway. - nil -- don't load. - ask -- ask the user. -If the value is nil, or `ask' and the user chooses not to load the desktop, -the normal hook `desktop-not-loaded-hook' is run." + t -- load anyway. + nil -- don't load. + ask -- ask the user. + check-pid -- load if locking Emacs process is missing locally. + +If the value is nil, or `ask' and the user chooses not to load +the desktop, the normal hook `desktop-not-loaded-hook' is run. + +If the value is `check-pid', load the desktop if the Emacs +process that has locked it is not running on the local machine. +This should not be used in circumstances where the locking Emacs +might still be running on another machine. That could be the +case if you have remotely mounted (NFS) paths in +`desktop-dirname'." :type '(choice (const :tag "Load anyway" t) (const :tag "Don't load" nil) - (const :tag "Ask the user" ask)) + (const :tag "Ask the user" ask) + (const :tag "Load if no local process" check-pid)) :group 'desktop :version "22.2") @@ -424,7 +434,9 @@ If `all', also restores frames that are partially offscreen onscreen. Note that checking of frame boundaries is only approximate. It can fail to reliably detect frames whose onscreen/offscreen state depends on a few pixels, especially near the right / bottom borders -of the screen." +of the screen. +Text-mode frames are always considered onscreen, so this option has +no effect on restoring frames in a non-GUI session." :type '(choice (const :tag "Only fully offscreen frames" t) (const :tag "Also partially offscreen frames" all) (const :tag "Do not force frames onscreen" nil)) @@ -635,6 +647,14 @@ Only valid during frame saving & restoring; intended for internal use.") "When the desktop file was last modified to the knowledge of this Emacs. Used to detect desktop file conflicts.") +(defun desktop--get-file-modtime () + "Get desktop file modtime, in list form for desktop format version 208." + (setq desktop-file-modtime + (time-convert (file-attribute-modification-time + (file-attributes + (desktop-full-file-name))) + 'list))) + (defvar desktop-var-serdes-funs (list (list 'mark-ring @@ -662,6 +682,44 @@ DIRNAME omitted or nil means use `desktop-dirname'." (integerp owner))) owner))) +(defun desktop--emacs-pid-running-p (pid) + "Return non-nil if an Emacs process whose ID is PID might still be running." + (when-let ((attr (process-attributes pid))) + (let ((proc-cmd (alist-get 'comm attr)) + (my-cmd (file-name-nondirectory (car command-line-args))) + (case-fold-search t)) + (or (equal proc-cmd my-cmd) + (and (eq system-type 'windows-nt) + (eq t (compare-strings proc-cmd + nil + (if (string-suffix-p ".exe" proc-cmd t) + -4) + my-cmd + nil + (if (string-suffix-p ".exe" my-cmd t) + -4)))) + ;; We should err on the safe side here: if any of the + ;; executables is something like "emacs-nox" or "emacs-42.1" + ;; or "gemacs" or "xemacs", let's recognize them as well. + (and (string-match-p "emacs" proc-cmd) + (string-match-p "emacs" my-cmd)))))) + +(defun desktop--load-locked-desktop-p (owner) + "Return t if a locked desktop should be loaded. +OWNER is the pid in the lock file. +The return value of this function depends on the value of +`desktop-load-locked-desktop'." + (pcase desktop-load-locked-desktop + ('ask + (unless (daemonp) + (y-or-n-p (format "Warning: desktop file appears to be in use by PID %s.\n\ +Using it may cause conflicts. Use it anyway? " owner)))) + ('check-pid + (or (eq (emacs-pid) owner) + (not (desktop--emacs-pid-running-p owner)))) + ('nil nil) + (_ t))) + (defun desktop-claim-lock (&optional dirname) "Record this Emacs process as the owner of the desktop file in DIRNAME. DIRNAME omitted or nil means use `desktop-dirname'." @@ -799,15 +857,16 @@ buffer, which is (in order): ,(buffer-name) ,major-mode ;; minor modes - ,(let (ret) - (dolist (minor-mode (mapcar #'car minor-mode-alist) ret) - (and (boundp minor-mode) - (symbol-value minor-mode) - (let* ((special (assq minor-mode desktop-minor-mode-table)) - (value (cond (special (cadr special)) - ((get minor-mode :minor-mode-function)) - ((functionp minor-mode) minor-mode)))) - (when value (cl-pushnew value ret)))))) + ,(seq-filter + (lambda (minor-mode) + ;; Just two sanity checks. + (and (boundp minor-mode) + (symbol-value minor-mode) + (let ((special + (assq minor-mode desktop-minor-mode-table))) + (or (not special) + (cadr special))))) + local-minor-modes) ;; point and mark, and read-only status ,(point) ,(list (mark t) mark-active) @@ -1072,7 +1131,7 @@ no questions asked." (file-attributes (desktop-full-file-name))))) (when (or (not new-modtime) ; nothing to overwrite - (equal desktop-file-modtime new-modtime) + (time-equal-p desktop-file-modtime new-modtime) (yes-or-no-p (if desktop-file-modtime (if (time-less-p desktop-file-modtime new-modtime) @@ -1172,9 +1231,7 @@ no questions asked." (write-region (point-min) (point-max) (desktop-full-file-name) nil 'nomessage)) (setq desktop-file-checksum checksum) ;; We remember when it was modified (which is presumably just now). - (setq desktop-file-modtime (file-attribute-modification-time - (file-attributes - (desktop-full-file-name))))))))))) + (desktop--get-file-modtime)))))))) ;; ---------------------------------------------------------------------------- ;;;###autoload @@ -1196,7 +1253,11 @@ This function also sets `desktop-dirname' to nil." ;; ---------------------------------------------------------------------------- (defun desktop-restoring-frameset-p () "True if calling `desktop-restore-frameset' will actually restore it." - (and desktop-restore-frames desktop-saved-frameset (display-graphic-p) t)) + (and desktop-restore-frames desktop-saved-frameset + ;; Don't restore frames when the selected frame is the daemon's + ;; initial frame. + (not (and (daemonp) (not (frame-parameter nil 'client)))) + t)) (defun desktop-restore-frameset () "Restore the state of a set of frames. @@ -1207,7 +1268,17 @@ being set (usually, by reading it from the desktop)." :reuse-frames (eq desktop-restore-reuses-frames t) :cleanup-frames (not (eq desktop-restore-reuses-frames 'keep)) :force-display desktop-restore-in-current-display - :force-onscreen desktop-restore-forces-onscreen))) + :force-onscreen (and desktop-restore-forces-onscreen + (display-graphic-p))) + ;; When at least one restored frame contains a tab bar, + ;; enable `tab-bar-mode' that takes care about recalculating + ;; the correct values of the frame parameter `tab-bar-lines' + ;; (that depends on `tab-bar-show'), and also loads graphical buttons. + (when (seq-some + (lambda (frame) + (menu-bar-positive-p (frame-parameter frame 'tab-bar-lines))) + (frame-list)) + (tab-bar-mode 1)))) ;; Just to silence the byte compiler. ;; Dynamically bound in `desktop-read'. @@ -1263,11 +1334,7 @@ It returns t if a desktop file was loaded, nil otherwise. (desktop-save nil) (desktop-autosave-was-enabled)) (if (and owner - (memq desktop-load-locked-desktop '(nil ask)) - (or (null desktop-load-locked-desktop) - (daemonp) - (not (y-or-n-p (format "Warning: desktop file appears to be in use by PID %s.\n\ -Using it may cause conflicts. Use it anyway? " owner))))) + (not (desktop--load-locked-desktop-p owner))) (let ((default-directory desktop-dirname)) (setq desktop-dirname nil) (run-hooks 'desktop-not-loaded-hook) @@ -1287,9 +1354,7 @@ Using it may cause conflicts. Use it anyway? " owner))))) 'window-configuration-change-hook))) (desktop-auto-save-disable) ;; Evaluate desktop buffer and remember when it was modified. - (setq desktop-file-modtime (file-attribute-modification-time - (file-attributes - (desktop-full-file-name)))) + (desktop--get-file-modtime) (load (desktop-full-file-name) t t t) ;; If it wasn't already, mark it as in-use, to bother other ;; desktop instances. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 56897826cbc..64cdab28f9a 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -795,6 +795,15 @@ offer a smarter default choice of shell command." (dired-mark-pop-up nil 'shell files 'read-shell-command prompt nil nil)))) +;;;###autoload +(defcustom dired-confirm-shell-command t + "Whether to prompt for confirmation for ‘dired-do-shell-command’. +If non-nil, prompt for confirmation if the command contains potentially +dangerous characters. If nil, never prompt for confirmation." + :type 'boolean + :group 'dired + :version "29.1") + ;;;###autoload (defun dired-do-async-shell-command (command &optional arg file-list) "Run a shell command COMMAND on the marked files asynchronously. @@ -873,7 +882,9 @@ can be produced by `dired-get-marked-files', for example. `dired-guess-shell-alist-default' and `dired-guess-shell-alist-user' are consulted when the user is -prompted for the shell command to use interactively." +prompted for the shell command to use interactively. + +Also see the `dired-confirm-shell-command' variable." ;; Functions dired-run-shell-command and dired-shell-stuff-it do the ;; actual work and can be redefined for customization. (interactive @@ -891,6 +902,8 @@ prompted for the shell command to use interactively." (ok (cond ((not (or on-each no-subst)) (error "You can not combine `*' and `?' substitution marks")) + ((not dired-confirm-shell-command) + t) ((setq confirmations (dired--need-confirm-positions command "*")) (dired--no-subst-confirm confirmations command)) ((setq confirmations (dired--need-confirm-positions command "?")) @@ -1251,7 +1264,8 @@ and `dired-compress-files-alist'." (when (zerop (dired-shell-command (format-spec (cdr rule) - `((?o . ,(shell-quote-argument out-file)) + `((?o . ,(shell-quote-argument + (file-local-name out-file))) (?i . ,(mapconcat (lambda (in-file) (shell-quote-argument @@ -1883,22 +1897,23 @@ rename them using `vc-rename-file'." "Rename FILE to NEWNAME. Signal a `file-already-exists' error if a file NEWNAME already exists unless OK-IF-ALREADY-EXISTS is non-nil." - (dired-handle-overwrite newname) - (dired-maybe-create-dirs (file-name-directory newname)) - (if (and dired-vc-rename-file - (vc-backend file) - (ignore-errors (vc-responsible-backend newname))) - (vc-rename-file file newname) - ;; error is caught in -create-files - (rename-file file newname ok-if-already-exists)) - ;; Silently rename the visited file of any buffer visiting this file. - (and (get-file-buffer file) - (with-current-buffer (get-file-buffer file) - (set-visited-file-name newname nil t))) - (dired-remove-file file) - ;; See if it's an inserted subdir, and rename that, too. - (when (file-directory-p file) - (dired-rename-subdir file newname))) + (let ((file-is-dir-p (file-directory-p file))) + (dired-handle-overwrite newname) + (dired-maybe-create-dirs (file-name-directory newname)) + (if (and dired-vc-rename-file + (vc-backend file) + (ignore-errors (vc-responsible-backend newname))) + (vc-rename-file file newname) + ;; error is caught in -create-files + (rename-file file newname ok-if-already-exists)) + ;; Silently rename the visited file of any buffer visiting this file. + (and (get-file-buffer file) + (with-current-buffer (get-file-buffer file) + (set-visited-file-name newname nil t))) + (dired-remove-file file) + ;; See if it's an inserted subdir, and rename that, too. + (when file-is-dir-p + (dired-rename-subdir file newname)))) (defun dired-rename-subdir (from-dir to-dir) (setq from-dir (file-name-as-directory from-dir) @@ -1911,7 +1926,7 @@ unless OK-IF-ALREADY-EXISTS is non-nil." (while blist (with-current-buffer (car blist) (if (and buffer-file-name - (file-in-directory-p buffer-file-name expanded-from-dir)) + (dired-in-this-tree-p buffer-file-name expanded-from-dir)) (let ((modflag (buffer-modified-p)) (to-file (replace-regexp-in-string (concat "^" (regexp-quote from-dir)) @@ -1930,7 +1945,7 @@ unless OK-IF-ALREADY-EXISTS is non-nil." (while alist (setq elt (car alist) alist (cdr alist)) - (if (file-in-directory-p (car elt) expanded-dir) + (if (dired-in-this-tree-p (car elt) expanded-dir) ;; ELT's subdir is affected by the rename (dired-rename-subdir-2 elt dir to))) (if (equal dir default-directory) @@ -2455,6 +2470,10 @@ If `dired-copy-preserve-time' is non-nil, this command preserves the modification time of each old file in the copy, similar to the \"-p\" option for the \"cp\" shell command. +The `dired-keep-marker-copy' user option controls how this +command handles file marking. The default is to mark all new +copies of files with a \"C\" mark. + This command copies symbolic links by creating new ones, similar to the \"-d\" option for the \"cp\" shell command. But if `dired-copy-dereference' is non-nil, the symbolic @@ -3142,16 +3161,16 @@ a file name. Otherwise, it searches the whole buffer without restrictions." (define-minor-mode dired-isearch-filenames-mode "Toggle file names searching on or off. -When on, Isearch skips matches outside file names using the predicate -`dired-isearch-filter-filenames' that matches only at file names. -When off, it uses the original predicate." +When on, Isearch skips matches outside file names using the search function +`dired-isearch-search-filenames' that matches only at file names. +When off, it uses the default search function." :lighter nil (if dired-isearch-filenames-mode - (add-function :before-while (local 'isearch-filter-predicate) - #'dired-isearch-filter-filenames + (add-function :around (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames '((isearch-message-prefix . "filename "))) - (remove-function (local 'isearch-filter-predicate) - #'dired-isearch-filter-filenames)) + (remove-function (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames)) (when isearch-mode (setq isearch-success t isearch-adjusted t) (isearch-update))) @@ -3175,12 +3194,46 @@ Intended to be added to `isearch-mode-hook'." (unless isearch-suspended (kill-local-variable 'dired-isearch-filenames))) -(defun dired-isearch-filter-filenames (beg end) - "Test whether some part of the current search match is inside a file name. -This function returns non-nil if some part of the text between BEG and END -is part of a file name (i.e., has the text property `dired-filename')." - (text-property-not-all (min beg end) (max beg end) - 'dired-filename nil)) +(defun dired-isearch-search-filenames (orig-fun) + "Return the function that searches inside file names. +The returned function narrows the search to match the search string +only as part of a file name enclosed by the text property `dired-filename'. +It's intended to override the default search function." + (let ((search-fun (funcall orig-fun)) + (property 'dired-filename)) + (lambda (string &optional bound noerror count) + (let* ((old (point)) + ;; Check if point is already on the property. + (beg (when (get-text-property + (if isearch-forward old (max (1- old) (point-min))) + property) + old)) + end found) + ;; Otherwise, try to search for the next property. + (unless beg + (setq beg (if isearch-forward + (next-single-property-change old property) + (previous-single-property-change old property))) + (when beg (goto-char beg))) + ;; Non-nil `beg' means there are more properties. + (while (and beg (not found)) + ;; Search for the end of the current property. + (setq end (if isearch-forward + (next-single-property-change beg property) + (previous-single-property-change beg property))) + (setq found (funcall + search-fun string (if bound (if isearch-forward + (min bound end) + (max bound end)) + end) + noerror count)) + (unless found + (setq beg (if isearch-forward + (next-single-property-change end property) + (previous-single-property-change end property))) + (when beg (goto-char beg)))) + (unless found (goto-char old)) + found)))) ;;;###autoload (defun dired-isearch-filenames () @@ -3233,9 +3286,14 @@ To continue searching for next match, use command \\[fileloop-continue]." ;;;###autoload (defun dired-do-query-replace-regexp (from to &optional delimited) "Do `query-replace-regexp' of FROM with TO, on all marked files. +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. + Third arg DELIMITED (prefix arg) means replace only word-delimited matches. -If you exit (\\[keyboard-quit], RET or q), you can resume the query replace -with the command \\[tags-loop-continue]." +If you exit the query-replace loop (\\[keyboard-quit], RET or q), you can +resume the query replace with the command \\[tags-loop-continue]." (interactive (let ((common (query-replace-read-args @@ -3287,7 +3345,7 @@ REGEXP should use constructs supported by your local `grep' command." (project--files-in-directory mark ignores "*") files)) (push mark files))) - (nreverse marks)) + (reverse marks)) (message "Searching...") (setq xrefs (xref-matches-in-files regexp files)) @@ -3301,6 +3359,11 @@ REGEXP should use constructs supported by your local `grep' command." (defun dired-do-find-regexp-and-replace (from to) "Replace matches of FROM with TO, in all marked files. +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. + If no files are marked, use the file under point. For any marked directory, matches in all of its files are replaced, @@ -3308,7 +3371,10 @@ recursively. However, files matching `grep-find-ignored-files' and subdirectories matching `grep-find-ignored-directories' are skipped in the marked directories. -REGEXP should use constructs supported by your local `grep' command." +REGEXP should use constructs supported by your local `grep' command. + +Also see `query-replace' for user options that affect how this +function works." (interactive (let ((common (query-replace-read-args diff --git a/lisp/dired.el b/lisp/dired.el index bca30189230..89fbd52aa62 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -248,6 +248,28 @@ The target is used in the prompt for file copy, rename etc." (other :tag "Try to guess" t)) :group 'dired) + +(defcustom dired-mouse-drag-files nil + "If non-nil, allow the mouse to drag files from inside a Dired buffer. +Dragging the mouse and then releasing it over the window of +another program will result in that program opening the file, or +creating a copy of it. This feature is supported only on X +Windows and Haiku. + +If the value is `link', then a symbolic link will be created to +the file instead by the other program (usually a file manager)." + :set (lambda (option value) + (set-default option value) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p 'dired-mode) + (revert-buffer nil t))))) + :type '(choice (const :tag "Don't allow dragging" nil) + (const :tag "Copy file to other window" t) + (const :tag "Create symbolic link to file" link)) + :group 'dired + :version "29.1") + (defcustom dired-copy-preserve-time t "If non-nil, Dired preserves the last-modified time in a file copy. \(This works on only some systems.)" @@ -1012,8 +1034,11 @@ If a directory or nothing is found at point, return nil." ;;;###autoload (defun dired (dirname &optional switches) "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. -Optional second argument SWITCHES specifies the `ls' options used. -\(Interactively, use a prefix argument to be able to specify SWITCHES.) +Optional second argument SWITCHES specifies the options to be used +when invoking `insert-directory-program', usually `ls', which produces +the listing of the directory files and their attributes. +Interactively, a prefix argument will cause the command to prompt +for SWITCHES. If DIRNAME is a string, Dired displays a list of files in DIRNAME (which may also have shell wildcards appended to select certain files). @@ -1260,39 +1285,42 @@ The return value is the target column for the file names." ;; This differs from dired-buffers-for-dir in that it does not consider ;; subdirs of default-directory and searches for the first match only. ;; Also, the major mode must be MODE. - (if (and (featurep 'dired-x) - dired-find-subdir - ;; Don't try to find a wildcard as a subdirectory. - (string-equal dirname (file-name-directory dirname))) - (let* ((cur-buf (current-buffer)) - (buffers (nreverse (dired-buffers-for-dir dirname))) - (cur-buf-matches (and (memq cur-buf buffers) - ;; Wildcards must match, too: - (equal dired-directory dirname)))) - ;; We don't want to switch to the same buffer--- - (setq buffers (delq cur-buf buffers)) - (or (car (sort buffers #'dired-buffer-more-recently-used-p)) - ;; ---unless it's the only possibility: - (and cur-buf-matches cur-buf))) - ;; No dired-x, or dired-find-subdir nil. - (setq dirname (expand-file-name dirname)) - (let (found (blist dired-buffers)) ; was (buffer-list) - (or mode (setq mode 'dired-mode)) - (while blist - (if (null (buffer-name (cdr (car blist)))) - (setq blist (cdr blist)) - (with-current-buffer (cdr (car blist)) - (if (and (eq major-mode mode) - dired-directory ;; nil during find-alternate-file - (equal dirname - (expand-file-name - (if (consp dired-directory) - (car dired-directory) - dired-directory)))) - (setq found (cdr (car blist)) - blist nil) - (setq blist (cdr blist)))))) - found))) + ;; We bind `non-essential' in order to avoid hangs in remote buffers + ;; with a blocked connection. (Bug#54542) + (let ((non-essential t)) + (if (and (featurep 'dired-x) + dired-find-subdir + ;; Don't try to find a wildcard as a subdirectory. + (string-equal dirname (file-name-directory dirname))) + (let* ((cur-buf (current-buffer)) + (buffers (nreverse (dired-buffers-for-dir dirname))) + (cur-buf-matches (and (memq cur-buf buffers) + ;; Wildcards must match, too: + (equal dired-directory dirname)))) + ;; We don't want to switch to the same buffer--- + (setq buffers (delq cur-buf buffers)) + (or (car (sort buffers #'dired-buffer-more-recently-used-p)) + ;; ---unless it's the only possibility: + (and cur-buf-matches cur-buf))) + ;; No dired-x, or dired-find-subdir nil. + (setq dirname (expand-file-name dirname)) + (let (found (blist dired-buffers)) ; was (buffer-list) + (or mode (setq mode 'dired-mode)) + (while blist + (if (null (buffer-name (cdr (car blist)))) + (setq blist (cdr blist)) + (with-current-buffer (cdr (car blist)) + (if (and (eq major-mode mode) + dired-directory ;; nil during find-alternate-file + (equal dirname + (expand-file-name + (if (consp dired-directory) + (car dired-directory) + dired-directory)))) + (setq found (cdr (car blist)) + blist nil) + (setq blist (cdr blist)))))) + found)))) ;;; Read in a new dired buffer @@ -1674,6 +1702,83 @@ see `dired-use-ls-dired' for more details.") beg)) beg)))) +(defvar dired-last-dragged-remote-file nil + "If non-nil, the name of a local copy of the last remote file that was dragged. +It can't be removed immediately after the drag-and-drop operation +completes, since there is no way to determine when the drop +target has finished opening it. So instead, this file is removed +when Emacs exits or the user drags another file.") + +(declare-function x-begin-drag "xfns.c") + +(defun dired-remove-last-dragged-local-file () + "Remove the local copy of the last remote file to be dragged." + (when dired-last-dragged-remote-file + (unwind-protect + (delete-file dired-last-dragged-remote-file) + (setq dired-last-dragged-remote-file nil))) + (remove-hook 'kill-emacs-hook #'dired-remove-last-dragged-local-file)) + +(defun dired-mouse-drag (event) + "Begin a drag-and-drop operation for the file at EVENT." + (interactive "e") + (when mark-active + (deactivate-mark)) + (dired-remove-last-dragged-local-file) + (save-excursion + (with-selected-window (posn-window (event-end event)) + (goto-char (posn-point (event-end event)))) + (track-mouse + (let ((beginning-position (mouse-pixel-position)) + new-event) + (catch 'track-again + (setq new-event (read-event)) + (if (not (eq (event-basic-type new-event) 'mouse-movement)) + (when (eq (event-basic-type new-event) 'mouse-1) + (push new-event unread-command-events)) + (let ((current-position (mouse-pixel-position))) + ;; If the mouse didn't move far enough, don't + ;; inadvertently trigger a drag. + (when (and (eq (car current-position) (car beginning-position)) + (ignore-errors + (and (> 3 (abs (- (cadr beginning-position) + (cadr current-position)))) + (> 3 (abs (- (caddr beginning-position) + (caddr current-position))))))) + (throw 'track-again nil))) + ;; We can get an error if there's by some chance no file + ;; name at point. + (condition-case nil + (let ((filename (with-selected-window (posn-window + (event-end event)) + (dired-file-name-at-point)))) + (when filename + ;; In theory x-dnd-username combined with a proper + ;; file URI containing the hostname of the remote + ;; server could be used here instead of creating a + ;; local copy of the remote file, but no program + ;; actually implements file DND according to the + ;; spec. + (when (file-remote-p filename) + (setq filename (file-local-copy filename)) + (setq dired-last-dragged-remote-file filename) + (add-hook 'kill-emacs-hook + #'dired-remove-last-dragged-local-file)) + (gui-backend-set-selection 'XdndSelection filename) + (x-begin-drag '("text/uri-list" "text/x-dnd-username" + "FILE_NAME" "FILE" "HOST_NAME") + (if (eq 'dired-mouse-drag-files 'link) + 'XdndActionLink + 'XdndActionCopy) + nil nil t))) + (error (when (eq (event-basic-type new-event) 'mouse-1) + (push new-event unread-command-events)))))))))) + +(defvar dired-mouse-drag-files-map (let ((keymap (make-sparse-keymap))) + (define-key keymap [down-mouse-1] #'dired-mouse-drag) + keymap) + "Keymap applied to file names when `dired-mouse-drag-files' is enabled.") + (defun dired-insert-set-properties (beg end) "Add various text properties to the lines in the region, from BEG to END." (save-excursion @@ -1688,15 +1793,27 @@ see `dired-use-ls-dired' for more details.") 'invisible 'dired-hide-details-information)) (put-text-property (+ (line-beginning-position) 1) (1- (point)) 'invisible 'dired-hide-details-detail) + (when (and dired-mouse-drag-files (fboundp 'x-begin-drag)) + (put-text-property (point) + (save-excursion + (dired-move-to-end-of-filename) + (backward-char) + (point)) + 'keymap + dired-mouse-drag-files-map)) (add-text-properties (point) (progn (dired-move-to-end-of-filename) (point)) - '(mouse-face + `(mouse-face highlight dired-filename t - help-echo "mouse-2: visit this file in other window")) + help-echo ,(if (and dired-mouse-drag-files + (fboundp 'x-begin-drag)) + "down-mouse-1: drag this file to another program +mouse-2: visit this file in other window" + "mouse-2: visit this file in other window"))) (when (< (+ (point) 4) (line-end-position)) (put-text-property (+ (point) 4) (line-end-position) 'invisible 'dired-hide-details-link)))) @@ -2416,6 +2533,8 @@ If the current buffer can be edited with Wdired, (i.e. the major mode is `dired-mode'), call `wdired-change-to-wdired-mode'. Otherwise, toggle `read-only-mode'." (interactive) + (unless (file-exists-p default-directory) + (user-error "The current directory no longer exists")) (when (and (not (file-writable-p default-directory)) (not (y-or-n-p "Directory isn't writable; edit anyway? "))) @@ -2949,12 +3068,10 @@ You can then feed the file name(s) to other commands with \\[yank]." ;;; Keeping Dired buffers in sync with the filesystem and with each other -(defun dired-buffers-for-dir (dir &optional file subdirs) +(defun dired-buffers-for-dir (dir &optional file) "Return a list of buffers for DIR (top level or in-situ subdir). If FILE is non-nil, include only those whose wildcard pattern (if any) matches FILE. -If SUBDIRS is non-nil, also include the dired buffers of -directories below DIR. The list is in reverse order of buffer creation, most recent last. As a side effect, killed dired buffers for DIR are removed from `dired-buffers'." @@ -2966,20 +3083,35 @@ As a side effect, killed dired buffers for DIR are removed from ((null (buffer-name buf)) ;; Buffer is killed - clean up: (setq dired-buffers (delq elt dired-buffers))) - ((dired-in-this-tree-p (car elt) dir) + ((dired-in-this-tree-p dir (car elt)) (with-current-buffer buf - (when (and (or subdirs - (assoc dir dired-subdir-alist)) - (or (null file) - (if (stringp dired-directory) - (let ((wildcards (file-name-nondirectory - dired-directory))) - (or (zerop (length wildcards)) - (string-match-p (dired-glob-regexp wildcards) - file))) - (member (expand-file-name file dir) - (cdr dired-directory))))) - (setq result (cons buf result))))))) + (and (assoc dir dired-subdir-alist) + (or (null file) + (if (stringp dired-directory) + (let ((wildcards (file-name-nondirectory + dired-directory))) + (or (zerop (length wildcards)) + (string-match-p (dired-glob-regexp wildcards) + file))) + (member (expand-file-name file dir) + (cdr dired-directory)))) + (setq result (cons buf result))))))) + result)) + +(defun dired-buffers-for-dir-or-subdir (dir) + "Return a list of buffers for DIR or a subdirectory thereof. +As a side effect, killed dired buffers for DIR are removed from +`dired-buffers'." + (setq dir (file-name-as-directory dir)) + (let (result buf) + (dolist (elt dired-buffers) + (setq buf (cdr elt)) + (cond + ((null (buffer-name buf)) + ;; Buffer is killed - clean up: + (setq dired-buffers (delq elt dired-buffers))) + ((dired-in-this-tree-p (car elt) dir) + (setq result (cons buf result))))) result)) (defun dired-glob-regexp (pattern) @@ -3558,14 +3690,16 @@ confirmation. To disable the confirmation, see (file-name-nondirectory fn)))) (not dired-clean-confirm-killing-deleted-buffers)) (kill-buffer buf))) - (let ((buf-list (dired-buffers-for-dir fn nil 'subdirs))) + (let ((buf-list (dired-buffers-for-dir-or-subdir + (expand-file-name fn)))) (and buf-list (or (and dired-clean-confirm-killing-deleted-buffers (y-or-n-p (format - (ngettext "Kill Dired buffer of %s, too? " - "Kill Dired buffers of %s, too? " - (length buf-list)) + (ngettext + "Kill Dired buffer of %s, too? " + "Kill Dired buffers of %s and its sub-directories, too? " + (length buf-list)) (file-name-nondirectory ;; FN may end in a / if `dired-listing-switches' ;; contains -p, so we need to strip that diff --git a/lisp/dnd.el b/lisp/dnd.el index 97e81e9bf11..4f71edf1aa1 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -42,8 +42,7 @@ `((,(purecopy "^file:///") . dnd-open-local-file) ; XDND format. (,(purecopy "^file://") . dnd-open-file) ; URL with host (,(purecopy "^file:") . dnd-open-local-file) ; Old KDE, Motif, Sun - (,(purecopy "^\\(https?\\|ftp\\|file\\|nfs\\)://") . dnd-open-file) - ) + (,(purecopy "^\\(https?\\|ftp\\|file\\|nfs\\)://") . dnd-open-file)) "The functions to call for different protocols when a drop is made. This variable is used by `dnd-handle-one-url' and `dnd-handle-file-name'. @@ -57,7 +56,8 @@ If no match is found, the URL is inserted as text by calling `dnd-insert-text'. The function shall return the action done (move, copy, link or private) if some action was made, or nil if the URL is ignored." :version "22.1" - :type '(repeat (cons (regexp) (function)))) + :type '(repeat (cons (regexp) (function))) + :group 'dnd) (defcustom dnd-open-remote-file-function @@ -73,17 +73,68 @@ Predefined functions are `dnd-open-local-file' and `dnd-open-remote-url'. is the default on MS-Windows. `dnd-open-remote-url' uses `url-handler-mode' and is the default except for MS-Windows." :version "22.1" - :type 'function) + :type 'function + :group 'dnd) (defcustom dnd-open-file-other-window nil "If non-nil, always use `find-file-other-window' to open dropped files." :version "22.1" - :type 'boolean) + :type 'boolean + :group 'dnd) +(defcustom dnd-scroll-margin nil + "The scroll margin inside a window underneath the cursor during drag-and-drop. +If the mouse moves this many lines close to the top or bottom of +a window while dragging text, then that window will be scrolled +down and up respectively." + :type '(choice (const :tag "Don't scroll during mouse movement") + (integer :tag "This many lines from window top or bottom")) + :version "29.1" + :group 'dnd) + +(defcustom dnd-indicate-insertion-point nil + "Whether or not point should follow the position of the mouse. +If non-nil, the point of the window underneath the mouse will be +adjusted to reflect where any text will be inserted upon drop +when the mouse moves while receiving a drop from another +program." + :type 'boolean + :version "29.1" + :group 'dnd) ;; Functions +(defun dnd-handle-movement (posn) + "Handle mouse movement to POSN when receiving a drop from another program." + (when (windowp (posn-window posn)) + (with-selected-window (posn-window posn) + (when dnd-scroll-margin + (ignore-errors + (let* ((row (cdr (posn-col-row posn))) + (window (when (windowp (posn-window posn)) + (posn-window posn))) + (text-height (window-text-height window)) + ;; Make sure it's possible to scroll both up + ;; and down if the margin is too large for the + ;; window. + (margin (min (/ text-height 3) dnd-scroll-margin))) + ;; At 2 lines, the window becomes too small for any + ;; meaningful scrolling. + (unless (<= text-height 2) + (cond + ;; Inside the bottom scroll margin, scroll up. + ((> row (- text-height margin)) + (with-selected-window window + (scroll-up 1))) + ;; Inside the top scroll margin, scroll down. + ((< row margin) + (with-selected-window window + (scroll-down 1)))))))) + (when dnd-indicate-insertion-point + (ignore-errors + (goto-char (posn-point posn))))))) + (defun dnd-handle-one-url (window action url) "Handle one dropped url by calling the appropriate handler. The handler is first located by looking at `dnd-protocol-alist'. diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 5b07d75f6d8..22570dd5103 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -234,8 +234,8 @@ Higher values result in larger images." (defvar doc-view-doc-type nil "The type of document in the current buffer. -Can be `dvi', `pdf', `ps', `djvu', `odf', 'epub', `cbz', `fb2', -`'xps' or `oxps'.") +Can be `dvi', `pdf', `ps', `djvu', `odf', `epub', `cbz', `fb2', +`xps' or `oxps'.") ;; FIXME: The doc-view-current-* definitions below are macros because they ;; map to accessors which we want to use via `setf' as well! @@ -632,17 +632,16 @@ Typically \"page-%s.png\".") (propertize (format "Page %d of %d." page len) 'face 'bold) ;; Tell user if converting isn't finished yet - (if doc-view--current-converter-processes - " (still converting...)\n" - "\n") - ;; Display context infos if this page matches the last search - (when (and doc-view--current-search-matches - (assq page doc-view--current-search-matches)) - (concat (propertize "Search matches:\n" 'face 'bold) + (and doc-view--current-converter-processes + " (still converting...)") + ;; Display context infos if this page matches the last search + (when (and doc-view--current-search-matches + (assq page doc-view--current-search-matches)) + (concat "\n" (propertize "Search matches:" 'face 'bold) (let ((contexts "")) (dolist (m (cdr (assq page doc-view--current-search-matches))) - (setq contexts (concat contexts " - \"" m "\"\n"))) + (setq contexts (concat contexts "\n - \"" m "\""))) contexts))))) ;; Update the buffer ;; We used to find the file name from doc-view--current-files but @@ -1947,8 +1946,7 @@ If BACKWARD is non-nil, jump to the previous match." ;; zip-archives, so that this same association is used for ;; cbz files. This is fine, as cbz files should be handled ;; like epub anyway. - ((looking-at "PK") '(epub)) - )))) + ((looking-at "PK") '(epub odf)))))) (setq-local doc-view-doc-type (car (or (nreverse (seq-intersection name-types content-types #'eq)) diff --git a/lisp/edmacro.el b/lisp/edmacro.el index 2561994f7bd..179fea786d0 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -99,8 +99,7 @@ With a prefix argument, format the macro in a more concise way." (when keys (let ((cmd (if (arrayp keys) (key-binding keys) keys)) (cmd-noremap (when (arrayp keys) (key-binding keys nil t))) - (mac nil) (mac-counter nil) (mac-format nil) - kmacro) + (mac nil) (mac-counter nil) (mac-format nil)) (cond (store-hook (setq mac keys) (setq cmd nil)) @@ -131,10 +130,10 @@ With a prefix argument, format the macro in a more concise way." (t (setq mac cmd) (setq cmd nil))) - (when (setq kmacro (kmacro-extract-lambda mac)) - (setq mac (car kmacro) - mac-counter (nth 1 kmacro) - mac-format (nth 2 kmacro))) + (when (kmacro-p mac) + (setq mac (kmacro--keys mac) + mac-counter (kmacro--counter mac) + mac-format (kmacro--format mac))) (unless (arrayp mac) (error "Key sequence %s is not a keyboard macro" (key-description keys))) @@ -260,7 +259,7 @@ or nil, use a compact 80-column format." (push key keys) (let ((b (key-binding key))) (and b (commandp b) (not (arrayp b)) - (not (kmacro-extract-lambda b)) + (not (kmacro-p b)) (or (not (fboundp b)) (not (or (arrayp (symbol-function b)) (get b 'kmacro)))) @@ -313,10 +312,7 @@ or nil, use a compact 80-column format." (when cmd (if (= (length mac) 0) (fmakunbound cmd) - (fset cmd - (if (and mac-counter mac-format) - (kmacro-lambda-form mac mac-counter mac-format) - mac)))) + (fset cmd (kmacro mac mac-counter mac-format)))) (if no-keys (when cmd (cl-loop for key in (where-is-internal cmd '(keymap)) do @@ -327,10 +323,8 @@ or nil, use a compact 80-column format." (cl-loop for key in keys do (global-set-key key (or cmd - (if (and mac-counter mac-format) - (kmacro-lambda-form - mac mac-counter mac-format) - mac)))))))))) + (kmacro mac mac-counter + mac-format)))))))))) (kill-buffer buf) (when (buffer-name obuf) (switch-to-buffer obuf)) @@ -645,9 +639,9 @@ This function assumes that the events can be stored in a string." ;;; Parsing a human-readable keyboard macro. -(defun edmacro-parse-keys (string &optional need-vector) +(defun edmacro-parse-keys (string &optional _need-vector) (let ((result (kbd string))) - (if (and need-vector (stringp result)) + (if (stringp result) (seq-into result 'vector) result))) diff --git a/lisp/ehelp.el b/lisp/ehelp.el index 8c1555249ca..0c2f02639fc 100644 --- a/lisp/ehelp.el +++ b/lisp/ehelp.el @@ -76,7 +76,10 @@ (define-key map [?\C-7] 'electric-help-undefined) (define-key map [?\C-8] 'electric-help-undefined) (define-key map [?\C-9] 'electric-help-undefined) - (define-key map (char-to-string help-char) 'electric-help-help) + (define-key map (if (characterp help-char) + (char-to-string help-char) + (vector help-char)) + 'electric-help-help) (define-key map "?" 'electric-help-help) (define-key map " " 'scroll-up) (define-key map [?\S-\ ] 'scroll-down) diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el index c3fd90e5bfd..231dcdeb980 100644 --- a/lisp/elec-pair.el +++ b/lisp/elec-pair.el @@ -256,7 +256,7 @@ cache is flushed from position START, defaulting to point." (defun electric-pair--syntax-ppss (&optional pos where) "Like `syntax-ppss', but sometimes fallback to `parse-partial-sexp'. -WHERE is a list defaulting to '(string comment) and indicates +WHERE is a list defaulting to \\='(string comment) and indicates when to fallback to `parse-partial-sexp'." (let* ((pos (or pos (point))) (where (or where '(string comment))) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 8e43ae68072..86a42b208e7 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1814,8 +1814,7 @@ Redefining advices affect the construction of an advised definition." (if (symbolp function) (setq function (if (fboundp function) (advice--strip-macro (symbol-function function))))) - (while (advice--p function) (setq function (advice--cdr function))) - function) + (advice--cd*r function)) (defun ad-clear-advicefunname-definition (function) (let ((advicefunname (ad-get-advice-info-field function 'advicefunname))) diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index d0bf342b842..1e4b2c14a01 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1108,6 +1108,9 @@ directory or directories specified." ;; Files with no autoload cookies or whose autoloads go to other ;; files because of file-local autoload-generated-file settings. (no-autoloads nil) + ;; Ensure that we don't do odd things when putting the doc + ;; strings into the autoloads file. + (left-margin 0) (autoload-modified-buffers nil) (output-time (and (file-exists-p output-file) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 0a79bf9b797..d3d8405d068 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -338,7 +338,7 @@ for speeding up processing.") (let ((exps-opt (byte-optimize-body exps t))) (if (macroexp-const-p exp-opt) `(progn ,@exps-opt ,exp-opt) - `(prog1 ,exp-opt ,@exps-opt))) + `(,fn ,exp-opt ,@exps-opt))) exp-opt))) (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) @@ -358,7 +358,7 @@ for speeding up processing.") (then-opt (and test-opt (byte-optimize-form then for-effect))) (else-opt (and (not (and test-opt const)) (byte-optimize-body else for-effect)))) - `(if ,test-opt ,then-opt . ,else-opt))) + `(,fn ,test-opt ,then-opt . ,else-opt))) (`(,(or 'and 'or) . ,exps) ;; FIXME: We have to traverse the expressions in left-to-right @@ -397,7 +397,7 @@ for speeding up processing.") ;; as mutated variables have been marked as non-substitutable. (condition (byte-optimize-form (car condition-body) nil)) (body (byte-optimize-body (cdr condition-body) t))) - `(while ,condition . ,body))) + `(,fn ,condition . ,body))) (`(interactive . ,_) (byte-compile-warn-x form "misplaced interactive spec: `%s'" form) @@ -409,7 +409,7 @@ for speeding up processing.") form) (`(condition-case ,var ,exp . ,clauses) - `(condition-case ,var ;Not evaluated. + `(,fn ,var ;Not evaluated. ,(byte-optimize-form exp for-effect) ,@(mapcar (lambda (clause) (let ((byte-optimize--lexvars @@ -432,14 +432,14 @@ for speeding up processing.") (let ((bodyform (byte-optimize-form exp for-effect))) (pcase exps (`(:fun-body ,f) - `(unwind-protect ,bodyform + `(,fn ,bodyform :fun-body ,(byte-optimize-form f nil))) (_ - `(unwind-protect ,bodyform + `(,fn ,bodyform . ,(byte-optimize-body exps t)))))) (`(catch ,tag . ,exps) - `(catch ,(byte-optimize-form tag nil) + `(,fn ,(byte-optimize-form tag nil) . ,(byte-optimize-body exps for-effect))) ;; Needed as long as we run byte-optimize-form after cconv. @@ -495,7 +495,7 @@ for speeding up processing.") (cons (byte-optimize-form (car rest) nil) (cdr rest))))) (push name byte-optimize--dynamic-vars) - `(defvar ,name . ,optimized-rest))) + `(,fn ,name . ,optimized-rest))) (`(,(pred byte-code-function-p) . ,exps) (cons fn (mapcar #'byte-optimize-form exps))) @@ -561,49 +561,50 @@ for speeding up processing.") (defun byte-optimize--rename-var (var new-var form) "Replace VAR with NEW-VAR in FORM." - (pcase form - ((pred symbolp) (if (eq form var) new-var form)) - (`(setq . ,args) - (let ((new-args nil)) - (while args - (push (byte-optimize--rename-var var new-var (car args)) new-args) - (push (byte-optimize--rename-var var new-var (cadr args)) new-args) - (setq args (cddr args))) - `(setq . ,(nreverse new-args)))) - ;; In binding constructs like `let', `let*' and `condition-case' we - ;; rename everything for simplicity, even new bindings named VAR. - (`(,(and head (or 'let 'let*)) ,bindings . ,body) - `(,head - ,(mapcar (lambda (b) (byte-optimize--rename-var-body var new-var b)) - bindings) - ,@(byte-optimize--rename-var-body var new-var body))) - (`(condition-case ,res-var ,protected-form . ,handlers) - `(condition-case ,(byte-optimize--rename-var var new-var res-var) - ,(byte-optimize--rename-var var new-var protected-form) - ,@(mapcar (lambda (h) - (cons (car h) - (byte-optimize--rename-var-body var new-var (cdr h)))) - handlers))) - (`(internal-make-closure ,vars ,env . ,rest) - `(internal-make-closure - ,vars ,(byte-optimize--rename-var-body var new-var env) . ,rest)) - (`(defvar ,name . ,rest) - ;; NAME is not renamed here; we only care about lexical variables. - `(defvar ,name . ,(byte-optimize--rename-var-body var new-var rest))) + (let ((fn (car-safe form))) + (pcase form + ((pred symbolp) (if (eq form var) new-var form)) + (`(setq . ,args) + (let ((new-args nil)) + (while args + (push (byte-optimize--rename-var var new-var (car args)) new-args) + (push (byte-optimize--rename-var var new-var (cadr args)) new-args) + (setq args (cddr args))) + `(,fn . ,(nreverse new-args)))) + ;; In binding constructs like `let', `let*' and `condition-case' we + ;; rename everything for simplicity, even new bindings named VAR. + (`(,(and head (or 'let 'let*)) ,bindings . ,body) + `(,head + ,(mapcar (lambda (b) (byte-optimize--rename-var-body var new-var b)) + bindings) + ,@(byte-optimize--rename-var-body var new-var body))) + (`(condition-case ,res-var ,protected-form . ,handlers) + `(,fn ,(byte-optimize--rename-var var new-var res-var) + ,(byte-optimize--rename-var var new-var protected-form) + ,@(mapcar (lambda (h) + (cons (car h) + (byte-optimize--rename-var-body var new-var (cdr h)))) + handlers))) + (`(internal-make-closure ,vars ,env . ,rest) + `(,fn + ,vars ,(byte-optimize--rename-var-body var new-var env) . ,rest)) + (`(defvar ,name . ,rest) + ;; NAME is not renamed here; we only care about lexical variables. + `(,fn ,name . ,(byte-optimize--rename-var-body var new-var rest))) - (`(cond . ,clauses) - `(cond ,@(mapcar (lambda (c) - (byte-optimize--rename-var-body var new-var c)) - clauses))) + (`(cond . ,clauses) + `(,fn ,@(mapcar (lambda (c) + (byte-optimize--rename-var-body var new-var c)) + clauses))) - (`(function . ,_) form) - (`(quote . ,_) form) - (`(lambda . ,_) form) + (`(function . ,_) form) + (`(quote . ,_) form) + (`(lambda . ,_) form) - ;; Function calls and special forms not handled above. - (`(,head . ,args) - `(,head . ,(byte-optimize--rename-var-body var new-var args))) - (_ form))) + ;; Function calls and special forms not handled above. + (`(,head . ,args) + `(,head . ,(byte-optimize--rename-var-body var new-var args))) + (_ form)))) (defun byte-optimize-let-form (head form for-effect) ;; Recursively enter the optimizer for the bindings and body @@ -1049,6 +1050,14 @@ See Info node `(elisp) Integer Basics'." form ; No improvement. (cons 'concat (nreverse newargs))))) +(defun byte-optimize-string-greaterp (form) + ;; Rewrite in terms of `string-lessp' which has its own bytecode. + (pcase (cdr form) + (`(,a ,b) (let ((arg1 (make-symbol "arg1"))) + `(let ((,arg1 ,a)) + (string-lessp ,b ,arg1)))) + (_ form))) + (put 'identity 'byte-optimizer #'byte-optimize-identity) (put 'memq 'byte-optimizer #'byte-optimize-memq) (put 'memql 'byte-optimizer #'byte-optimize-member) @@ -1072,6 +1081,9 @@ See Info node `(elisp) Integer Basics'." (put 'string= 'byte-optimizer #'byte-optimize-binary-predicate) (put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'string-greaterp 'byte-optimizer #'byte-optimize-string-greaterp) +(put 'string> 'byte-optimizer #'byte-optimize-string-greaterp) + (put 'concat 'byte-optimizer #'byte-optimize-concat) ;; I'm not convinced that this is necessary. Doesn't the optimizer loop @@ -1163,21 +1175,21 @@ See Info node `(elisp) Integer Basics'." (proper-list-p clause)) (if (null (cddr clause)) ;; A trivial `progn'. - (byte-optimize-if `(if ,(cadr clause) ,@(nthcdr 2 form))) + (byte-optimize-if `(,(car form) ,(cadr clause) ,@(nthcdr 2 form))) (nconc (butlast clause) (list (byte-optimize-if - `(if ,(car (last clause)) ,@(nthcdr 2 form))))))) + `(,(car form) ,(car (last clause)) ,@(nthcdr 2 form))))))) ((byte-compile-trueconstp clause) `(progn ,clause ,(nth 2 form))) ((byte-compile-nilconstp clause) `(progn ,clause ,@(nthcdr 3 form))) ((nth 2 form) (if (equal '(nil) (nthcdr 3 form)) - (list 'if clause (nth 2 form)) + (list (car form) clause (nth 2 form)) form)) ((or (nth 3 form) (nthcdr 4 form)) - (list 'if + (list (car form) ;; Don't make a double negative; ;; instead, take away the one that is there. (if (and (consp clause) (memq (car clause) '(not null)) @@ -1256,7 +1268,7 @@ See Info node `(elisp) Integer Basics'." (and (consp binding) (cadr binding))) bindings) ,const) - `(let* ,(butlast bindings) + `(,head ,(butlast bindings) ,@(and (consp (car (last bindings))) (cdar (last bindings))) ,const))) @@ -1271,7 +1283,7 @@ See Info node `(elisp) Integer Basics'." `(progn ,@(mapcar (lambda (binding) (and (consp binding) (cadr binding))) bindings)) - `(let* ,(butlast bindings) + `(,head ,(butlast bindings) ,@(and (consp (car (last bindings))) (cdar (last bindings)))))) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 384e8cba88f..0113051c8eb 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -32,8 +32,7 @@ (defvar byte-run--ssp-seen nil "Which conses/vectors/records have been processed in strip-symbol-positions? -The value is a hash table, the key being the old element and the value being -the corresponding new element of the same type. +The value is a hash table, the keys being the elements and the values being t. The purpose of this is to detect circular structures.") diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9be44a8d5af..c0dffe544cf 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -471,7 +471,7 @@ Return the compile-time value of FORM." (let ((print-symbols-bare t)) ; Possibly redundant binding. (setf form (macroexp-macroexpand form byte-compile-macro-environment))) (if (eq (car-safe form) 'progn) - (cons 'progn + (cons (car form) (mapcar (lambda (subform) (byte-compile-recurse-toplevel subform non-toplevel-case)) @@ -500,8 +500,9 @@ Return the compile-time value of FORM." byte-compile-new-defuns)) (setf result (byte-compile-eval + (byte-run-strip-symbol-positions (byte-compile-top-level - (byte-compile-preprocess form))))))) + (byte-compile-preprocess form)))))))) (list 'quote result)))) (eval-and-compile . ,(lambda (&rest body) (byte-compile-recurse-toplevel @@ -512,9 +513,10 @@ Return the compile-time value of FORM." ;; or byte-compile-file-form. (let* ((print-symbols-bare t) ; Possibly redundant binding. (expanded - (macroexpand--all-toplevel - form - macroexpand-all-environment))) + (byte-run-strip-symbol-positions + (macroexpand--all-toplevel + form + macroexpand-all-environment)))) (eval expanded lexical-binding) expanded))))) (with-suppressed-warnings @@ -1007,13 +1009,22 @@ CONST2 may be evaluated multiple times." ;; Similarly, replace TAGs in all jump tables with the correct PC index. (dolist (hash-table byte-compile-jump-tables) - (maphash #'(lambda (value tag) - (setq pc (cadr tag)) - ;; We don't need to split PC here, as it is stored as a lisp - ;; object in the hash table (whereas other goto-* ops store - ;; it within 2 bytes in the byte string). - (puthash value pc hash-table)) - hash-table)) + (let (alist) + (maphash #'(lambda (value tag) + (setq pc (cadr tag)) + ;; We don't need to split PC here, as it is stored as a + ;; lisp object in the hash table (whereas other goto-* + ;; ops store it within 2 bytes in the byte string). + ;; De-position any symbols with position in `value'. + ;; Since this may change the hash table key, we remove + ;; the entry from the table and reinsert it outside the + ;; scope of the `maphash'. + (setq value (byte-run-strip-symbol-positions value)) + (push (cons value pc) alist) + (remhash value hash-table)) + hash-table) + (dolist (elt alist) + (puthash (car elt) (cdr elt) hash-table)))) (let ((bytecode (apply 'unibyte-string (nreverse bytes)))) (when byte-native-compiling ;; Spill LAP for the native compiler here. @@ -1162,27 +1173,27 @@ message buffer `default-directory'." (f2 (file-relative-name file dir))) (if (< (length f2) (length f1)) f2 f1))) -(defun byte-compile--first-symbol (form) - "Return the \"first\" symbol found in form, or 0 if there is none. +(defun byte-compile--first-symbol-with-pos (form) + "Return the \"first\" symbol with position found in form, or 0 if none. Here, \"first\" is by a depth first search." (let (sym) (cond - ((symbolp form) form) + ((symbol-with-pos-p form) form) ((consp form) - (or (and (symbolp (setq sym (byte-compile--first-symbol (car form)))) + (or (and (symbol-with-pos-p (setq sym (byte-compile--first-symbol-with-pos (car form)))) sym) - (and (symbolp (setq sym (byte-compile--first-symbol (cdr form)))) + (and (symbolp (setq sym (byte-compile--first-symbol-with-pos (cdr form)))) sym) 0)) - ((and (vectorp form) + ((and (or (vectorp form) (recordp form)) (> (length form) 0)) (let ((i 0) (len (length form)) elt) (catch 'sym (while (< i len) - (when (symbolp - (setq elt (byte-compile--first-symbol (aref form i)))) + (when (symbol-with-pos-p + (setq elt (byte-compile--first-symbol-with-pos (aref form i)))) (throw 'sym elt)) (setq i (1+ i))) 0))) @@ -1193,7 +1204,7 @@ Here, \"first\" is by a depth first search." Return nil if such is not found." (catch 'offset (dolist (form byte-compile-form-stack) - (let ((s (byte-compile--first-symbol form))) + (let ((s (byte-compile--first-symbol-with-pos form))) (if (symbol-with-pos-p s) (throw 'offset (symbol-with-pos-pos s))))))) @@ -1428,7 +1439,7 @@ when printing the error message." (and (eq 'macro (car-safe f)) (setq f (cdr f))) ;; Advice wrappers have "catch all" args, so fetch the actual underlying ;; function to find the real arguments. - (while (advice--p f) (setq f (advice--cdr f))) + (setq f (advice--cd*r f)) (if (eq (car-safe f) 'declared) (byte-compile-arglist-signature (nth 1 f)) (condition-case nil @@ -3073,7 +3084,7 @@ lambda-expression." ;; which may include "calls" to ;; internal-make-closure (Bug#29988). lexical-binding) - (setq int `(interactive ,newform))))) + (setq int `(,(car int) ,newform))))) ((cdr int) ; Invalid (interactive . something). (byte-compile-warn-x int "malformed interactive spec: %s" int)))) @@ -3922,7 +3933,7 @@ discarding." docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) (byte-compile-form - (if (or (not docstring-exp) (stringp docstring-exp)) + (if (macroexp-const-p docstring-exp) ;; Use symbols V0, V1 ... as placeholders for closure variables: ;; they should be short (to save space in the .elc file), yet ;; distinct when disassembled. @@ -3938,7 +3949,7 @@ discarding." (vconcat dummy-vars (aref fun 2)) (aref fun 3) (if docstring-exp - (cons docstring-exp (cdr opt-args)) + (cons (eval docstring-exp t) (cdr opt-args)) opt-args)))) `(make-closure ,proto-fun ,@env)) ;; Nontrivial doc string expression: create a bytecode object diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index c16619bc45d..4535f1aa6eb 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -201,7 +201,10 @@ Returns a form where all lambdas don't have any free variables." (i 0) (new-env ())) ;; Build the "formal and actual envs" for the closure-converted function. - (dolist (fv fvs) + ;; Hack for OClosure: `nreverse' here intends to put the captured vars + ;; in the closure such that the first one is the one that is bound + ;; most closely. + (dolist (fv (nreverse fvs)) (let ((exp (or (cdr (assq fv env)) fv))) (pcase exp ;; If `fv' is a variable that's wrapped in a cons-cell, @@ -240,7 +243,7 @@ Returns a form where all lambdas don't have any free variables." ;; this case better, we'd need to traverse the tree one more time to ;; collect this data, and I think that it's not worth it. (mapcar (lambda (mapping) - (if (not (eq (cadr mapping) 'apply-partially)) + (if (not (eq (cadr mapping) #'apply-partially)) mapping (cl-assert (eq (car mapping) (nth 2 mapping))) `(,(car mapping) @@ -449,6 +452,9 @@ places where they originally did not directly appear." (let ((var-def (cconv--lifted-arg var env)) (closedsym (make-symbol (format "closed-%s" var)))) (setq new-env (cconv--remap-llv new-env var closedsym)) + ;; FIXME: `closedsym' doesn't need to be added to `extend' + ;; but adding it makes it easier to write the assertion at + ;; the beginning of this function. (setq new-extend (cons closedsym (remq var new-extend))) (push `(,closedsym ,var-def) binders-new))) @@ -494,11 +500,11 @@ places where they originally did not directly appear." args))) (`(cond . ,cond-forms) ; cond special form - `(cond . ,(mapcar (lambda (branch) - (mapcar (lambda (form) - (cconv-convert form env extend)) - branch)) - cond-forms))) + `(,(car form) . ,(mapcar (lambda (branch) + (mapcar (lambda (form) + (cconv-convert form env extend)) + branch)) + cond-forms))) (`(function (lambda ,args . ,body) . ,_) (let ((docstring (if (eq :documentation (car-safe (car body))) @@ -532,7 +538,7 @@ places where they originally did not directly appear." (msg (when (eq class :unused) (cconv--warn-unused-msg var "variable"))) (newprotform (cconv-convert protected-form env extend))) - `(condition-case ,var + `(,(car form) ,var ,(if msg (macroexp--warn-wrap var msg newprotform 'lexical) newprotform) @@ -548,9 +554,9 @@ places where they originally did not directly appear." `((let ((,var (list ,var))) ,@body)))))) handlers)))) - (`(unwind-protect ,form . ,body) - `(unwind-protect ,(cconv-convert form env extend) - :fun-body ,(cconv--convert-function () body env form))) + (`(unwind-protect ,form1 . ,body) + `(,(car form) ,(cconv-convert form1 env extend) + :fun-body ,(cconv--convert-function () body env form1))) (`(setq . ,forms) ; setq special form (if (= (logand (length forms) 1) 1) @@ -562,7 +568,7 @@ places where they originally did not directly appear." (sym-new (or (cdr (assq sym env)) sym)) (value (cconv-convert (pop forms) env extend))) (push (pcase sym-new - ((pred symbolp) `(setq ,sym-new ,value)) + ((pred symbolp) `(,(car form) ,sym-new ,value)) (`(car-safe ,iexp) `(setcar ,iexp ,value)) ;; This "should never happen", but for variables which are ;; mutated+captured+unused, we may end up trying to `setq' @@ -598,12 +604,20 @@ places where they originally did not directly appear." (cons fun args))))))) (`(interactive . ,forms) - `(interactive . ,(mapcar (lambda (form) + `(,(car form) . ,(mapcar (lambda (form) (cconv-convert form nil nil)) forms))) (`(declare . ,_) form) ;The args don't contain code. + (`(oclosure--fix-type (ignore . ,vars) ,exp) + (dolist (var vars) + (let ((x (assq var env))) + (pcase (cdr x) + (`(car-safe . ,_) (error "Slot %S should not be mutated" var)) + (_ (cl-assert (null (cdr x))))))) + (cconv-convert exp env extend)) + (`(,func . ,forms) ;; First element is function or whatever function-like forms are: or, and, ;; if, catch, progn, prog1, while, until diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index ed9b1b7d836..8e38df43c87 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -553,10 +553,14 @@ too large if positive or too small if negative)." ,new))))) (seq-subseq seq start end)) +;;; This isn't a defalias because autoloading defalises doesn't work +;;; very well. + ;;;###autoload -(defalias 'cl-concatenate #'seq-concatenate +(defun cl-concatenate (type &rest sequences) "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. -\n(fn TYPE SEQUENCE...)") +\n(fn TYPE SEQUENCE...)" + (apply #'seq-concatenate type sequences)) ;;; List functions. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index b44dda6f9d4..200af057cd7 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -144,13 +144,20 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG (cl-defstruct (cl--generic-method (:constructor nil) (:constructor cl--generic-make-method - (specializers qualifiers uses-cnm function)) + (specializers qualifiers call-con function)) (:predicate nil)) (specializers nil :read-only t :type list) (qualifiers nil :read-only t :type (list-of atom)) - ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument - ;; holding the next-method. - (uses-cnm nil :read-only t :type boolean) + ;; CALL-CON indicates the calling convention expected by FUNCTION: + ;; - nil: FUNCTION is just a normal function with no extra arguments for + ;; `call-next-method' or `next-method-p' (which it hence can't use). + ;; - `curried': FUNCTION is a curried function that first takes the + ;; "next combined method" and return the resulting combined method. + ;; It can distinguish `next-method-p' by checking if that next method + ;; is `cl--generic-isnot-nnm-p'. + ;; - t: FUNCTION takes the `call-next-method' function as its first (extra) + ;; argument. + (call-con nil :read-only t :type symbol) (function nil :read-only t :type function)) (cl-defstruct (cl--generic @@ -262,6 +269,16 @@ DEFAULT-BODY, if present, is used as the body of a default method. (declarations nil) (methods ()) (options ()) + (warnings + (let ((nonsymargs + (delq nil (mapcar (lambda (arg) (unless (symbolp arg) arg)) + args)))) + (when nonsymargs + (list + (macroexp-warn-and-return + (format "Non-symbol arguments to cl-defgeneric: %s" + (mapconcat #'prin1-to-string nonsymargs "")) + nil nil nil nonsymargs))))) next-head) (while (progn (setq next-head (car-safe (car options-and-methods))) (or (keywordp next-head) @@ -284,14 +301,17 @@ DEFAULT-BODY, if present, is used as the body of a default method. (setq name (gv-setter (cadr name)))) `(prog1 (progn + ,@warnings (defalias ',name (cl-generic-define ',name ',args ',(nreverse options)) ,(if (consp doc) ;An expression rather than a constant. `(help-add-fundoc-usage ,doc ',args) (help-add-fundoc-usage doc args))) :autoload-end - ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) - (nreverse methods))) + ,(when methods + `(with-suppressed-warnings ((obsolete ,name)) + ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) + (nreverse methods))))) ,@(mapcar (lambda (declaration) (let ((f (cdr (assq (car declaration) defun-declarations-alist)))) @@ -381,14 +401,16 @@ the specializer used will be the one returned by BODY." . ,(lambda () spec-args)) macroexpand-all-environment))) (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. - (when (assq 'interactive (cadr fun)) + (when (assq 'interactive body) (message "Interactive forms not supported in generic functions: %S" - (assq 'interactive (cadr fun)))) + (assq 'interactive body))) ;; First macroexpand away the cl-function stuff (e.g. &key and ;; destructuring args, `declare' and whatnot). (pcase (macroexpand fun macroenv) (`#'(lambda ,args . ,body) (let* ((parsed-body (macroexp-parse-body body)) + (nm (make-symbol "cl--nm")) + (arglist (make-symbol "cl--args")) (cnm (make-symbol "cl--cnm")) (nmp (make-symbol "cl--nmp")) (nbody (macroexpand-all @@ -401,15 +423,49 @@ the specializer used will be the one returned by BODY." ;; is used. ;; FIXME: Also, optimize the case where call-next-method is ;; only called with explicit arguments. - (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody))) - (cons (not (not uses-cnm)) - `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) - ,@(car parsed-body) - ,(if (not (assq nmp uses-cnm)) - nbody - `(let ((,nmp (lambda () - (cl--generic-isnot-nnm-p ,cnm)))) - ,nbody)))))) + (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody)) + (λ-lift (mapcar #'car uses-cnm))) + (if (not uses-cnm) + (cons nil + `#'(lambda (,@args) + ,@(car parsed-body) + ,nbody)) + (cons 'curried + `#'(lambda (,nm) ;Called when constructing the effective method. + (let ((,nmp (if (cl--generic-isnot-nnm-p ,nm) + #'always #'ignore))) + ;; This `(λ (&rest x) .. (apply (λ (args) ..) x))' + ;; dance is needed because we need to get the original + ;; args as a list when `cl-call-next-method' is + ;; called with no arguments. It's important to + ;; capture it as a list since it needs to distinguish + ;; the nil case from the absent case in optional + ;; arguments and it needs to properly remember the + ;; original value if `nbody' mutates some of its + ;; formal args. + ;; FIXME: This `(λ (&rest ,arglist)' could be skipped + ;; when we know `cnm' is always called with args, and + ;; it could be implemented more efficiently if `cnm' + ;; is always called directly and there are no + ;; `&optional' args. + (lambda (&rest ,arglist) + ,@(let* ((prebody (car parsed-body)) + (ds (if (stringp (car prebody)) + prebody + (setq prebody (cons nil prebody)))) + (usage (help-split-fundoc (car ds) nil))) + (unless usage + (setcar ds (help-add-fundoc-usage (car ds) + args))) + prebody) + (let ((,cnm (lambda (&rest args) + (apply ,nm (or args ,arglist))))) + ;; This `apply+lambda' basically parses + ;; `arglist' according to `args'. + ;; A destructuring-bind would do the trick + ;; as well when/if it's more efficient. + (apply (lambda (,@λ-lift ,@args) ,nbody) + ,@λ-lift ,arglist))))))))) (f (error "Unexpected macroexpansion result: %S" f)))))) (put 'cl-defmethod 'function-documentation @@ -498,8 +554,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined cl--generic-edebug-make-name nil] lambda-doc ; documentation string def-body))) ; part to be debugged - (let ((qualifiers nil) - (orig-name name)) + (let ((qualifiers nil)) (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) @@ -507,23 +562,18 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (require 'gv) (declare-function gv-setter "gv" (name)) (setq name (gv-setter (cadr name)))) - (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body))) + (pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda args body))) `(progn - ,(and (get name 'byte-obsolete-info) - (or (not (fboundp 'byte-compile-warning-enabled-p)) - (byte-compile-warning-enabled-p 'obsolete name)) - (let* ((obsolete (get name 'byte-obsolete-info))) - (macroexp-warn-and-return - (macroexp--obsolete-warning name obsolete "generic function") - nil nil nil orig-name))) ;; You could argue that `defmethod' modifies rather than defines the ;; function, so warnings like "not known to be defined" are fair game. ;; But in practice, it's common to use `cl-defmethod' ;; without a previous `cl-defgeneric'. ;; The ",'" is a no-op that pacifies check-declare. (,'declare-function ,name "") - (cl-generic-define-method ',name ',(nreverse qualifiers) ',args - ,uses-cnm ,fun))))) + ;; We use #' to quote `name' so as to trigger an + ;; obsolescence warning when applicable. + (cl-generic-define-method #',name ',(nreverse qualifiers) ',args + ',call-con ,fun))))) (defun cl--generic-member-method (specializers qualifiers methods) (while @@ -541,7 +591,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined `(,name ,qualifiers . ,specializers)) ;;;###autoload -(defun cl-generic-define-method (name qualifiers args uses-cnm function) +(defun cl-generic-define-method (name qualifiers args call-con function) (pcase-let* ((generic (cl-generic-ensure-function name)) (`(,spec-args . ,_) (cl--generic-split-args args)) @@ -550,7 +600,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined spec-arg (cdr spec-arg))) spec-args)) (method (cl--generic-make-method - specializers qualifiers uses-cnm function)) + specializers qualifiers call-con function)) (mt (cl--generic-method-table generic)) (me (cl--generic-member-method specializers qualifiers mt)) (dispatches (cl--generic-dispatches generic)) @@ -603,6 +653,14 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (defvar cl--generic-dispatchers (make-hash-table :test #'equal)) +(defvar cl--generic-compiler + ;; Don't byte-compile the dispatchers if cl-generic itself is not + ;; compiled. Otherwise the byte-compiler and all the code on + ;; which it depends needs to be usable before cl-generic is loaded, + ;; which imposes a significant burden on the bootstrap. + (if (consp (lambda (x) (+ x 1))) + (lambda (exp) (eval exp t)) #'byte-compile)) + (defun cl--generic-get-dispatcher (dispatch) (with-memoization ;; We need `copy-sequence` here because this `dispatch' object might be @@ -647,7 +705,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; FIXME: For generic functions with a single method (or with 2 methods, ;; one of which always matches), using a tagcode + hash-table is ;; overkill: better just use a `cl-typep' test. - (byte-compile + (funcall + cl--generic-compiler `(lambda (generic dispatches-left methods) ;; FIXME: We should find a way to expand `with-memoize' once ;; and forall so we don't need `subr-x' when we get here. @@ -718,29 +777,38 @@ for all those different tags in the method-cache.") (list (cl--generic-name generic))) f)))) -(defun cl--generic-no-next-method-function (generic method) - (lambda (&rest args) - (apply #'cl-no-next-method generic method args))) +(oclosure-define (cl--generic-nnm) + "Special type for `call-next-method's that just call `no-next-method'.") (defun cl-generic-call-method (generic method &optional fun) "Return a function that calls METHOD. FUN is the function that should be called when METHOD calls `call-next-method'." - (if (not (cl--generic-method-uses-cnm method)) - (cl--generic-method-function method) - (let ((met-fun (cl--generic-method-function method)) - (next (or fun (cl--generic-no-next-method-function - generic method)))) - (lambda (&rest args) - (apply met-fun - ;; FIXME: This sucks: passing just `next' would - ;; be a lot more efficient than the lambda+apply - ;; quasi-η, but we need this to implement the - ;; "if call-next-method is called with no - ;; arguments, then use the previous arguments". - (lambda (&rest cnm-args) - (apply next (or cnm-args args))) - args))))) + (let ((met-fun (cl--generic-method-function method))) + (pcase (cl--generic-method-call-con method) + ('nil met-fun) + ('curried + (funcall met-fun (or fun + (oclosure-lambda (cl--generic-nnm) (&rest args) + (apply #'cl-no-next-method generic method + args))))) + ;; FIXME: backward compatibility with old convention for `.elc' files + ;; compiled before the `curried' convention. + (_ + (lambda (&rest args) + (apply met-fun + (if fun + ;; FIXME: This sucks: passing just `next' would + ;; be a lot more efficient than the lambda+apply + ;; quasi-η, but we need this to implement the + ;; "if call-next-method is called with no + ;; arguments, then use the previous arguments". + (lambda (&rest cnm-args) + (apply fun (or cnm-args args))) + (oclosure-lambda (cl--generic-nnm) (&rest cnm-args) + (apply #'cl-no-next-method generic method + (or cnm-args args)))) + args)))))) ;; Standard CLOS name. (defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers) @@ -875,11 +943,20 @@ those methods.") (setq arg-or-context `(&context . ,arg-or-context))) (unless (fboundp 'cl--generic-get-dispatcher) (require 'cl-generic)) - (let ((fun (cl--generic-get-dispatcher - `(,arg-or-context - ,@(apply #'append - (mapcar #'cl-generic-generalizers specializers)) - ,cl--generic-t-generalizer)))) + (let ((fun + ;; Let-bind cl--generic-dispatchers so we *re*compute the function + ;; from scratch, since the one in the cache may be non-compiled! + (let ((cl--generic-dispatchers (make-hash-table)) + ;; When compiling `cl-generic' during bootstrap, make sure + ;; we prefill with compiled dispatchers even though the loaded + ;; `cl-generic' is still interpreted. + (cl--generic-compiler + (if (featurep 'bytecomp) #'byte-compile cl--generic-compiler))) + (cl--generic-get-dispatcher + `(,arg-or-context + ,@(apply #'append + (mapcar #'cl-generic-generalizers specializers)) + ,cl--generic-t-generalizer))))) ;; Recompute dispatch at run-time, since the generalizers may be slightly ;; different (e.g. byte-compiled rather than interpreted). ;; FIXME: There is a risk that the run-time generalizer is not equivalent @@ -897,36 +974,9 @@ those methods.") "Standard support for :after, :before, :around, and `:extra NAME' qualifiers." (cl--generic-standard-method-combination generic methods)) -(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t)) -(defconst cl--generic-cnm-sample - (funcall (cl--generic-build-combined-method - nil (list (cl--generic-make-method () () t #'identity))))) - (defun cl--generic-isnot-nnm-p (cnm) "Return non-nil if CNM is the function that calls `cl-no-next-method'." - ;; ¡Big Gross Ugly Hack! - ;; `next-method-p' just sucks, we should let it die. But EIEIO did support - ;; it, and some packages use it, so we need to support it. - (catch 'found - (cl-assert (function-equal cnm cl--generic-cnm-sample)) - (if (byte-code-function-p cnm) - (let ((cnm-constants (aref cnm 2)) - (sample-constants (aref cl--generic-cnm-sample 2))) - (dotimes (i (length sample-constants)) - (when (function-equal (aref sample-constants i) - cl--generic-nnm-sample) - (throw 'found - (not (function-equal (aref cnm-constants i) - cl--generic-nnm-sample)))))) - (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample))) - (let ((cnm-env (cadr cnm))) - (dolist (vb (cadr cl--generic-cnm-sample)) - (when (function-equal (cdr vb) cl--generic-nnm-sample) - (throw 'found - (not (function-equal (cdar cnm-env) - cl--generic-nnm-sample)))) - (setq cnm-env (cdr cnm-env))))) - (error "Haven't found no-next-method-sample in cnm-sample"))) + (not (eq (oclosure-type cnm) 'cl--generic-nnm))) ;;; Define some pre-defined generic functions, used internally. @@ -1002,9 +1052,12 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (defun cl--generic-method-info (method) (let* ((specializers (cl--generic-method-specializers method)) (qualifiers (cl--generic-method-qualifiers method)) - (uses-cnm (cl--generic-method-uses-cnm method)) + (call-con (cl--generic-method-call-con method)) (function (cl--generic-method-function method)) - (args (help-function-arglist function 'names)) + (args (help-function-arglist (if (not (eq call-con 'curried)) + function + (funcall function #'ignore)) + 'names)) (docstring (documentation function)) (qual-string (if (null qualifiers) "" @@ -1015,7 +1068,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (let ((split (help-split-fundoc docstring nil))) (if split (cdr split) docstring)))) (combined-args ())) - (if uses-cnm (setq args (cdr args))) + (if (eq t call-con) (setq args (cdr args))) (dolist (specializer specializers) (let ((arg (if (eq '&rest (car args)) (intern (format "arg%d" (length combined-args))) @@ -1025,6 +1078,19 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (setq combined-args (append (nreverse combined-args) args)) (list qual-string combined-args doconly))) +(defun cl--generic-upcase-formal-args (args) + (mapcar (lambda (arg) + (cond + ((symbolp arg) + (let ((name (symbol-name arg))) + (if (eq ?& (aref name 0)) arg + (intern (upcase name))))) + ((consp arg) + (cons (intern (upcase (symbol-name (car arg)))) + (cdr arg))) + (t arg))) + args)) + (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) (defun cl--generic-describe (function) ;; Supposedly this is called from help-fns, so help-fns should be loaded at @@ -1041,9 +1107,20 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (insert (propertize "Implementations:\n\n" 'face 'bold)) ;; Loop over fanciful generics (dolist (method (cl--generic-method-table generic)) - (let* ((info (cl--generic-method-info method))) + (pcase-let* + ((`(,qualifiers ,args ,doc) (cl--generic-method-info method))) ;; FIXME: Add hyperlinks for the types as well. - (insert (format "%s%S" (nth 0 info) (nth 1 info))) + (let ((print-quoted nil) + (quals (if (length> qualifiers 0) + (concat (substring qualifiers + 0 (string-match " *\\'" + qualifiers)) + "\n") + ""))) + (insert (format "%s%S" + quals + (cons function + (cl--generic-upcase-formal-args args))))) (let* ((met-name (cl--generic-load-hist-format function (cl--generic-method-qualifiers method) @@ -1055,7 +1132,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." 'help-function-def met-name file 'cl-defmethod) (insert (substitute-command-keys "'.\n")))) - (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) + (insert "\n" (or doc "Undocumented") "\n\n"))))))) (defun cl--generic-specializers-apply-to-type-p (specializers type) "Return non-nil if a method with SPECIALIZERS applies to TYPE." @@ -1071,7 +1148,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (let ((sclass (cl--find-class specializer)) (tclass (cl--find-class type))) (when (and sclass tclass) - (member specializer (cl--generic-class-parents tclass)))))) + (member specializer (cl--class-allparents tclass)))))) (setq applies t))) applies)) @@ -1200,22 +1277,11 @@ These match if the argument is `eql' to VAL." ;; Use exactly the same code as for `typeof'. `(if ,name (type-of ,name) 'null)) -(defun cl--generic-class-parents (class) - (let ((parents ()) - (classes (list class))) - ;; BFS precedence. FIXME: Use a topological sort. - (while (let ((class (pop classes))) - (cl-pushnew (cl--class-name class) parents) - (setq classes - (append classes - (cl--class-parents class))))) - (nreverse parents))) - (defun cl--generic-struct-specializers (tag &rest _) (and (symbolp tag) (let ((class (get tag 'cl--class))) (when (cl-typep class 'cl-structure-class) - (cl--generic-class-parents class))))) + (cl--class-allparents class))))) (cl-generic-define-generalizer cl--generic-struct-generalizer 50 #'cl--generic-struct-tag @@ -1298,6 +1364,42 @@ Used internally for the (major-mode MODE) context specializers." (progn (cl-assert (null modes)) mode) `(derived-mode ,mode . ,modes)))) +;;; Dispatch on OClosure type + +;; It would make sense to put this into `oclosure.el' except that when +;; `oclosure.el' is loaded `cl-defmethod' is not available yet. + +(defun cl--generic-oclosure-tag (name &rest _) + `(oclosure-type ,name)) + +(defun cl-generic--oclosure-specializers (tag &rest _) + (and (symbolp tag) + (let ((class (cl--find-class tag))) + (when (cl-typep class 'oclosure--class) + (oclosure--class-allparents class))))) + +(cl-generic-define-generalizer cl-generic--oclosure-generalizer + ;; Give slightly higher priority than the struct specializer, so that + ;; for a generic function with methods dispatching structs and on OClosures, + ;; we first try `oclosure-type' before `type-of' since `type-of' will return + ;; non-nil for an OClosure as well. + 51 #'cl--generic-oclosure-tag + #'cl-generic--oclosure-specializers) + +(cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type) + "Support for dispatch on types defined by `oclosure-define'." + (or + (when (symbolp type) + ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than + ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can + ;; take place without requiring cl-lib. + (let ((class (cl--find-class type))) + (and (cl-typep class 'oclosure--class) + (list cl-generic--oclosure-generalizer)))) + (cl-call-next-method))) + +(cl--generic-prefill-dispatchers 0 oclosure) + ;;; Support for unloading. (cl-defmethod loadhist-unload-element ((x (head cl-defmethod))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 4e60a3c63d0..3f40ab07605 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -114,7 +114,10 @@ a future Emacs interpreter will be able to use it.") (defmacro cl-incf (place &optional x) "Increment PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. -The return value is the incremented value of PLACE." +The return value is the incremented value of PLACE. + +If X is specified, it should be an expression that should +evaluate to a number." (declare (debug (place &optional form))) (if (symbolp place) (list 'setq place (if x (list '+ place x) (list '1+ place))) @@ -123,7 +126,10 @@ The return value is the incremented value of PLACE." (defmacro cl-decf (place &optional x) "Decrement PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. -The return value is the decremented value of PLACE." +The return value is the decremented value of PLACE. + +If X is specified, it should be an expression that should +evaluate to a number." (declare (debug cl-incf)) (if (symbolp place) (list 'setq place (if x (list '- place x) (list '1- place))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 4b231d81496..a9d422929f1 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2430,6 +2430,57 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (unless advised (advice-remove 'macroexpand #'cl--sm-macroexpand))))) +;;;###autoload +(defmacro cl-with-gensyms (names &rest body) + "Bind each of NAMES to an uninterned symbol and evaluate BODY." + (declare (debug (sexp body)) (indent 1)) + `(let ,(cl-loop for name in names collect + `(,name (gensym (symbol-name ',name)))) + ,@body)) + +;;;###autoload +(defmacro cl-once-only (names &rest body) + "Generate code to evaluate each of NAMES just once in BODY. + +This macro helps with writing other macros. Each of names is +either (NAME FORM) or NAME, which latter means (NAME NAME). +During macroexpansion, each NAME is bound to an uninterned +symbol. The expansion evaluates each FORM and binds it to the +corresponding uninterned symbol. + +For example, consider this macro: + + (defmacro my-cons (x) + (cl-once-only (x) + \\=`(cons ,x ,x))) + +The call (my-cons (pop y)) will expand to something like this: + + (let ((g1 (pop y))) + (cons g1 g1)) + +The use of `cl-once-only' ensures that the pop is performed only +once, as intended. + +See also `macroexp-let2'." + (declare (debug (sexp body)) (indent 1)) + (setq names (mapcar #'ensure-list names)) + (let ((our-gensyms (cl-loop for _ in names collect (gensym)))) + ;; During macroexpansion, obtain a gensym for each NAME. + `(let ,(cl-loop for sym in our-gensyms collect `(,sym (gensym))) + ;; Evaluate each FORM and bind to the corresponding gensym. + ;; + ;; We require this explicit call to `list' rather than using + ;; (,,@(cl-loop ...)) due to a limitation of Elisp's backquote. + `(let ,(list + ,@(cl-loop for name in names for gensym in our-gensyms + for to-eval = (or (cadr name) (car name)) + collect ``(,,gensym ,,to-eval))) + ;; During macroexpansion, bind each NAME to its gensym. + ,(let ,(cl-loop for name in names for gensym in our-gensyms + collect `(,(car name) ,gensym)) + ,@body))))) + ;;; Multiple values. ;;;###autoload @@ -2509,7 +2560,7 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (push x defun-declarations-alist))) (defun cl--optimize (f _args &rest qualities) - "Serve 'cl-optimize' in function declarations. + "Serve `cl-optimize' in function declarations. Example: (defun foo (x) (declare (cl-optimize (speed 3) (safety 0))) @@ -2901,18 +2952,10 @@ To see the documentation for a defined struct type, use (debug (&define ;Makes top-level form not be wrapped. [&or symbolp - (gate + (gate ;; FIXME: Why? symbolp &rest - [&or symbolp - (&or [":conc-name" symbolp] - [":constructor" symbolp &optional cl-lambda-list] - [":copier" symbolp] - [":predicate" symbolp] - [":include" symbolp &rest sexp] ;; Not finished. - [":print-function" sexp] - [":type" symbolp] - [":named"] - [":initial-offset" natnump])])] + [&or (":constructor" &define name &optional cl-lambda-list) + sexp])] [&optional stringp] ;; All the above is for the following def-form. &rest &or symbolp (symbolp &optional def-form &rest sexp)))) @@ -3287,8 +3330,9 @@ the form NAME which is a shorthand for (NAME NAME)." (funcall orig pred1 (cl--defstruct-predicate t2)))) (funcall orig pred1 pred2)))) -(advice-add 'pcase--mutually-exclusive-p - :around #'cl--pcase-mutually-exclusive-p) +(when (fboundp 'advice-add) ;Not available during bootstrap. + (advice-add 'pcase--mutually-exclusive-p + :around #'cl--pcase-mutually-exclusive-p)) (defun cl-struct-sequence-type (struct-type) @@ -3359,9 +3403,11 @@ Of course, we really can't know that for sure, so it's just a heuristic." (boolean . booleanp) (bool-vector . bool-vector-p) (buffer . bufferp) + (byte-code-function . byte-code-function-p) (character . natnump) (char-table . char-table-p) (command . commandp) + (compiled-function . byte-code-function-p) (hash-table . hash-table-p) (cons . consp) (fixnum . fixnump) @@ -3375,6 +3421,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." (null . null) (real . numberp) (sequence . sequencep) + (subr . subrp) (string . stringp) (symbol . symbolp) (vector . vectorp) @@ -3632,7 +3679,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (define-inline cl-struct-slot-value (struct-type slot-name inst) "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE. -STRUCT and SLOT-NAME are symbols. INST is a structure instance." +STRUCT-TYPE and SLOT-NAME are symbols. INST is a structure instance." (declare (side-effect-free t)) (inline-letevals (struct-type slot-name inst) (inline-quote diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index b4be54bbd63..46f5ab35ff7 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -53,13 +53,23 @@ (defconst cl--typeof-types ;; Hand made from the source code of `type-of'. '((integer number number-or-marker atom) - (symbol atom) (string array sequence atom) + (symbol-with-pos symbol atom) (symbol atom) (string array sequence atom) (cons list sequence) ;; Markers aren't `numberp', yet they are accepted wherever integers are ;; accepted, pretty much. (marker number-or-marker atom) (overlay atom) (float number atom) (window-configuration atom) - (process atom) (window atom) (subr atom) (compiled-function function atom) + (process atom) (window atom) + ;; FIXME: We'd want to put `function' here, but that's only true + ;; for those `subr's which aren't special forms! + (subr atom) + ;; FIXME: We should probably reverse the order between + ;; `compiled-function' and `byte-code-function' since arguably + ;; `subr' and also "compiled functions" but not "byte code functions", + ;; but it would require changing the value returned by `type-of' for + ;; byte code objects, which risks breaking existing code, which doesn't + ;; seem worth the trouble. + (compiled-function byte-code-function function atom) (module-function function atom) (buffer atom) (char-table array sequence atom) (bool-vector array sequence atom) @@ -307,6 +317,17 @@ supertypes from the most specific to least specific.") (cl-assert (cl--class-p (cl--find-class 'cl-structure-class))) (cl-assert (cl--class-p (cl--find-class 'cl-structure-object))) +(defun cl--class-allparents (class) + (let ((parents ()) + (classes (list class))) + ;; BFS precedence. FIXME: Use a topological sort. + (while (let ((class (pop classes))) + (cl-pushnew (cl--class-name class) parents) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse parents))) + ;; Make sure functions defined with cl-defsubst can be inlined even in ;; packages which do not require CL. We don't put an autoload cookie ;; directly on that function, since those cookies only go to cl-loaddefs. diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 2aade140e25..30d7e6525a4 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -221,26 +221,11 @@ into a button whose action shows the function's disassembly.") 'byte-code-function object))))) (princ ")" stream)) -;; This belongs in nadvice.el, of course, but some load-ordering issues make it -;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add -;; from nadvice, so nadvice needs to be loaded before cl-generic and hence -;; can't use cl-defmethod. -(cl-defmethod cl-print-object :extra "nadvice" - ((object compiled-function) stream) - (if (not (advice--p object)) - (cl-call-next-method) - (princ "#f(advice-wrapper " stream) - (when (fboundp 'advice--where) - (princ (advice--where object) stream) - (princ " " stream)) - (cl-print-object (advice--cdr object) stream) - (princ " " stream) - (cl-print-object (advice--car object) stream) - (let ((props (advice--props object))) - (when props - (princ " " stream) - (cl-print-object props stream))) - (princ ")" stream))) +;; This belongs in oclosure.el, of course, but some load-ordering issues make it +;; complicated. +(cl-defmethod cl-print-object ((object accessor) stream) + ;; FIXME: η-reduce! + (oclosure--accessor-cl-print object stream)) (cl-defmethod cl-print-object ((object cl-structure-object) stream) (if (and cl-print--depth (natnump print-level) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 122638077ce..237de52884b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -238,7 +238,7 @@ native compilation runs.") (defvar comp-curr-allocation-class 'd-default "Current allocation class. -Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") +Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify @@ -898,6 +898,8 @@ non local exit (ends with an `unreachable' insn).")) :documentation "Doc string.") (int-spec nil :type list :documentation "Interactive form.") + (command-modes nil :type list + :documentation "Command modes.") (lap () :type list :documentation "LAP assembly representation.") (ssa-status nil :type symbol @@ -1021,7 +1023,7 @@ To be used by all entry points." (defun comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS, return the data container for the current context. -Assume allocation class 'd-default as default." +Assume allocation class `d-default' as default." (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) (defsubst comp-add-const-to-relocs (obj) @@ -1243,6 +1245,7 @@ clashes." :c-name c-name :doc (documentation f t) :int-spec (interactive-form f) + :command-modes (command-modes f) :speed (comp-spill-speed function-name) :pure (comp-spill-decl-spec function-name 'pure)))) @@ -1282,10 +1285,12 @@ clashes." (make-comp-func-l :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) + :command-modes (command-modes form) :speed (comp-ctxt-speed comp-ctxt)) (make-comp-func-d :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) + :command-modes (command-modes form) :speed (comp-ctxt-speed comp-ctxt))))) (let ((lap (byte-to-native-lambda-lap (gethash (aref byte-code 1) @@ -1327,6 +1332,7 @@ clashes." (comp-func-byte-func func) byte-func (comp-func-doc func) (documentation byte-func t) (comp-func-int-spec func) (interactive-form byte-func) + (comp-func-command-modes func) (command-modes byte-func) (comp-func-c-name func) c-name (comp-func-lap func) lap (comp-func-frame-size func) (comp-byte-frame-size byte-func) @@ -2079,7 +2085,8 @@ and the annotation emission." (i (hash-table-count h))) (puthash i (comp-func-doc f) h) i) - (comp-func-int-spec f))) + (comp-func-int-spec f) + (comp-func-command-modes f))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0)))))) @@ -2122,7 +2129,8 @@ These are stored in the reloc data array." (i (hash-table-count h))) (puthash i (comp-func-doc func) h) i) - (comp-func-int-spec func))) + (comp-func-int-spec func) + (comp-func-command-modes func))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0))))) @@ -2625,8 +2633,8 @@ TARGET-BB-SYM is the symbol name of the target block." do (comp-emit-call-cstr target insn-cell cstr))))))) (defun comp-add-cstrs (_) - "Rewrite conditional branches adding appropriate 'assume' insns. -This is introducing and placing 'assume' insns in use by fwprop + "Rewrite conditional branches adding appropriate `assume' insns. +This is introducing and placing `assume' insns in use by fwprop to propagate conditional branch test information on target basic blocks." (maphash (lambda (_ f) @@ -3474,7 +3482,7 @@ Return the list of m-var ids nuked." (defun comp-remove-type-hints-func () "Remove type hints from the current function. -These are substituted with a normal 'set' op." +These are substituted with a normal `set' op." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (comp-loop-insn-in-block b @@ -4209,7 +4217,7 @@ Generate .elc files in addition to the .eln files. Force the produced .eln to be outputted in the eln system directory (the last entry in `native-comp-eln-load-path') unless `native-compile-target-directory' is non-nil. If the environment -variable 'NATIVE_DISABLED' is set, only byte compile." +variable \"NATIVE_DISABLED\" is set, only byte compile." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index f3e1981732c..8a5c3d3730c 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -254,6 +254,23 @@ with empty strings removed." 'crm--choose-completion-string nil 'local) (setq-local minibuffer-completion-table #'crm--collection-fn) (setq-local minibuffer-completion-predicate predicate) + (setq-local completion-list-insert-choice-function + (lambda (start end choice) + (if (and (stringp start) (stringp end)) + (let* ((beg (save-excursion + (goto-char (minibuffer-prompt-end)) + (or (search-forward start nil t) + (search-forward-regexp crm-separator nil t) + (minibuffer-prompt-end)))) + (end (save-excursion + (goto-char (point-max)) + (or (search-backward end nil t) + (progn + (goto-char beg) + (search-forward-regexp crm-separator nil t)) + (point-max))))) + (completion--replace beg end choice)) + (completion--replace start end choice)))) ;; see completing_read in src/minibuf.c (setq-local minibuffer-completion-confirm (unless (eq require-match t) require-match)) diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el index 85ed5f2176c..4f1f4b81557 100644 --- a/lisp/emacs-lisp/debug-early.el +++ b/lisp/emacs-lisp/debug-early.el @@ -35,30 +35,34 @@ (defalias 'debug-early-backtrace #'(lambda () - "Print a trace of Lisp function calls currently active. + "Print a trace of Lisp function calls currently active. The output stream used is the value of `standard-output'. This is a simplified version of the standard `backtrace' function, intended for use in debugging the early parts of the build process." - (princ "\n") - (mapbacktrace - #'(lambda (evald func args _flags) - (let ((args args)) - (if evald - (progn - (princ " ") - (prin1 func) - (princ "(")) - (progn - (princ " (") - (setq args (cons func args)))) - (if args - (while (progn - (prin1 (car args)) - (setq args (cdr args))) - (princ " "))) - (princ ")\n")))))) + (princ "\n") + (let ((print-escape-newlines t) + (print-escape-control-characters t) + (print-escape-nonascii t) + (prin1 (if (fboundp 'cl-prin1) #'cl-prin1 #'prin1))) + (mapbacktrace + #'(lambda (evald func args _flags) + (let ((args args)) + (if evald + (progn + (princ " ") + (funcall prin1 func) + (princ "(")) + (progn + (princ " (") + (setq args (cons func args)))) + (if args + (while (progn + (funcall prin1 (car args)) + (setq args (cdr args))) + (princ " "))) + (princ ")\n"))))))) (defalias 'debug-early #'(lambda (&rest args) @@ -76,7 +80,7 @@ superseded by `debug' after enough Lisp has been loaded to support the latter, except in batch mode which always uses `debug-early'. -(In versions of Emacs prior to Emacs 29, no backtrace was +\(In versions of Emacs prior to Emacs 29, no backtrace was available before `debug' was usable.)" (princ "\nError: ") (prin1 (car (car (cdr args)))) ; The error symbol. diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 46b0306d64f..6c172d6c31d 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -90,6 +90,11 @@ The value used here is passed to `quit-restore-window'." :group 'debugger :version "24.3") +(defcustom debug-allow-recursive-debug nil + "If non-nil, erroring in debug and edebug won't recursively debug." + :type 'boolean + :version "29.1") + (defvar debugger-step-after-exit nil "Non-nil means \"single-step\" after the debugger exits.") @@ -534,11 +539,23 @@ The environment used is the one when entering the activation frame at point." (error 0)))) ;; If on first line. (base (debugger--backtrace-base))) (debugger-env-macro - (let ((val (backtrace-eval exp nframe base))) - (prog1 - (debugger--print val t) - (let ((str (eval-expression-print-format val))) - (if str (princ str t)))))))) + (let* ((errored nil) + (val (if debug-allow-recursive-debug + (backtrace-eval exp nframe base) + (condition-case err + (backtrace-eval exp nframe base) + (error (setq errored + (format "%s: %s" + (get (car err) 'error-message) + (car (cdr err))))))))) + (if errored + (progn + (message "Error: %s" errored) + nil) + (prog1 + (debugger--print val t) + (let ((str (eval-expression-print-format val))) + (if str (princ str t))))))))) (define-obsolete-function-alias 'debugger-toggle-locals 'backtrace-toggle-locals "28.1") diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 688c76e0c54..54cac116168 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -82,11 +82,9 @@ replacing its case-insensitive matches with the literal string in LIGHTER." (replace-regexp-in-string (regexp-quote lighter) lighter name t t)))) (defconst easy-mmode--arg-docstring - " - -This is a minor mode. If called interactively, toggle the `%s' -mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. + "This is a %sminor mode. If called interactively, toggle the +`%s' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. If called from Lisp, toggle the mode if ARG is `toggle'. Enable the mode if ARG is nil, omitted, or is a positive number. @@ -99,28 +97,50 @@ The mode's hook is called both when the mode is enabled and when it is disabled.") (defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym - getter) - (let ((doc (or doc (format "Toggle %s on or off. - -\\{%s}" mode-pretty-name keymap-sym)))) - (if (string-match-p "\\bARG\\b" doc) - doc - (let* ((fill-prefix nil) - (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) - (fill-column (if (integerp docs-fc) docs-fc 65)) - (argdoc (format easy-mmode--arg-docstring mode-pretty-name - ;; Avoid having quotes turn into pretty quotes. - (string-replace "'" "\\\\='" - (format "%S" getter)))) - (filled (if (fboundp 'fill-region) - (with-temp-buffer - (insert argdoc) - (fill-region (point-min) (point-max) 'left t) - (buffer-string)) - argdoc))) - (replace-regexp-in-string "\\(\n\n\\|\\'\\)\\(.\\|\n\\)*\\'" - (concat filled "\\1") - doc nil nil 1))))) + getter global) + ;; If we have a doc string, and it's already complete (which we + ;; guess at with the simple heuristic below), then just return that + ;; as is. + (if (and doc (string-match-p "\\bARG\\b" doc)) + doc + ;; Compose a new doc string. + (with-temp-buffer + (let ((lines (if doc + (string-lines doc) + (list (format "Toggle %s on or off." mode-pretty-name))))) + ;; Insert the first line from the doc string. + (insert (pop lines)) + ;; Ensure that we have (only) one blank line after the first + ;; line. + (ensure-empty-lines) + (while (and lines + (equal (car lines) "")) + (pop lines)) + ;; Insert the doc string. + (dolist (line lines) + (insert line "\n")) + (ensure-empty-lines) + ;; Insert the boilerplate. + (let* ((fill-prefix nil) + (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) + (fill-column (if (integerp docs-fc) docs-fc 65)) + (argdoc (format + easy-mmode--arg-docstring + (if global "global " "") + mode-pretty-name + ;; Avoid having quotes turn into pretty quotes. + (string-replace "'" "\\='" (format "%S" getter))))) + (let ((start (point))) + (insert argdoc) + (when (fboundp 'fill-region) + (fill-region start (point) 'left t)))) + ;; Finally, insert the keymap. + (when (and (boundp keymap-sym) + (or (not doc) + (not (string-search "\\{" doc)))) + (ensure-empty-lines) + (insert (format "\\{%s}" keymap-sym))) + (buffer-string))))) ;;;###autoload (defalias 'easy-mmode-define-minor-mode #'define-minor-mode) @@ -317,7 +337,7 @@ or call the function `%s'.")))) warnwrap `(defun ,modefun (&optional arg ,@extra-args) ,(easy-mmode--mode-docstring doc pretty-name keymap-sym - getter) + getter globalp) ,(when interactive ;; Use `toggle' rather than (if ,mode 0 1) so that using ;; repeat-command still does the toggling correctly. @@ -805,7 +825,6 @@ Interactively, COUNT is the prefix numeric argument, and defaults to 1." ,@body)) (put ',prev-sym 'definition-name ',base)))) - (provide 'easy-mmode) ;;; easy-mmode.el ends here diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 722283b88ff..d8b0a13c305 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -57,6 +57,7 @@ (require 'cl-lib) (require 'seq) (eval-when-compile (require 'pcase)) +(require 'debug) ;;; Options @@ -3711,12 +3712,25 @@ Return the result of the last expression." If interactive, prompt for the expression. Print result in minibuffer." (interactive (list (read--expression "Eval: "))) - (princ - (edebug-outside-excursion - (let ((result (edebug-eval expr))) - (values--store-value result) - (concat (edebug-safe-prin1-to-string result) - (eval-expression-print-format result)))))) + (let* ((errored nil) + (result + (edebug-outside-excursion + (let ((result (if debug-allow-recursive-debug + (edebug-eval expr) + (condition-case err + (edebug-eval expr) + (error + (setq errored + (format "%s: %s" + (get (car err) 'error-message) + (car (cdr err))))))))) + (unless errored + (values--store-value result) + (concat (edebug-safe-prin1-to-string result) + (eval-expression-print-format result))))))) + (if errored + (message "Error: %s" errored) + (princ result)))) (defun edebug-eval-last-sexp (&optional no-truncate) "Evaluate sexp before point in the outside environment. diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 19aa20fa086..d687289b22f 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -92,7 +92,7 @@ Currently under control of this var: (:copier nil)) children initarg-tuples ;; initarg tuples list - (class-slots nil :type eieio--slot) + (class-slots nil :type (vector-of eieio--slot)) class-allocation-values ;; class allocated value vector default-object-cache ;; what a newly created object would look like. ; This will speed up instantiation time as @@ -130,10 +130,7 @@ Currently under control of this var: class)) (defsubst eieio--object-class (obj) - (let ((tag (eieio--object-class-tag obj))) - (if eieio-backward-compatibility - (eieio--class-object tag) - tag))) + (eieio--class-object (eieio--object-class-tag obj))) (defun class-p (x) "Return non-nil if X is a valid class vector. @@ -265,6 +262,10 @@ use '%s or turn off `eieio-backward-compatibility' instead" cname) (defvar eieio--known-slot-names nil) (defvar eieio--known-class-slot-names nil) +(defun eieio--known-slot-name-p (name) + (or (memq name eieio--known-slot-names) + (get name 'slot-name))) + (defun eieio-defclass-internal (cname superclasses slots options) "Define CNAME as a new subclass of SUPERCLASSES. SLOTS are the slots residing in that class definition, and OPTIONS @@ -710,9 +711,9 @@ an error." (cond ((not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value))) + (list (cl--class-name class) slot st value))) ((alist-get :read-only (cl--slot-descriptor-props sd)) - (signal 'eieio-read-only (list (eieio--class-name class) slot))))))) + (signal 'eieio-read-only (list (cl--class-name class) slot))))))) (defun eieio--validate-class-slot-value (class slot-idx value slot) "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. @@ -725,7 +726,7 @@ an error." slot-idx)))) (if (not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value)))))) + (list (cl--class-name class) slot st value)))))) (defun eieio-barf-if-slot-unbound (value instance slotname fn) "Throw a signal if VALUE is a representation of an UNBOUND slot. @@ -746,31 +747,35 @@ Argument FN is the function calling this verifier." (ignore obj) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) (_ exp)))) + ;; FIXME: Make it a gv-expander such that the hash-table lookup is + ;; only performed once when used in `push' and friends? (gv-setter eieio-oset)) (cl-check-type slot symbol) - (cl-check-type obj (or eieio-object class cl-structure-object)) - (let* ((class (cond ((symbolp obj) - (error "eieio-oref called on a class: %s" obj) - (eieio--full-class-object obj)) - (t (eieio--object-class obj)))) - (c (eieio--slot-name-index class slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c (eieio--class-slot-name-index class slot)) - ;; Oref that slot. - (aref (eieio--class-class-allocation-values class) c) - ;; The slot-missing method is a cool way of allowing an object author - ;; to intercept missing slot definitions. Since it is also the LAST - ;; thing called in this fn, its return value would be retrieved. - (slot-missing obj slot 'oref)) - (cl-check-type obj (or eieio-object cl-structure-object)) - (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + (cond + ((cl-typep obj '(or eieio-object cl-structure-object)) + (let* ((class (eieio--object-class obj)) + (c (eieio--slot-name-index class slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c (eieio--class-slot-name-index class slot)) + ;; Oref that slot. + (aref (eieio--class-class-allocation-values class) c) + ;; The slot-missing method is a cool way of allowing an object author + ;; to intercept missing slot definitions. Since it is also the LAST + ;; thing called in this fn, its return value would be retrieved. + (slot-missing obj slot 'oref)) + (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + ((cl-typep obj 'oclosure) (oclosure--slot-value obj slot)) + (t + (signal 'wrong-type-argument + (list '(or eieio-object cl-structure-object oclosure) obj))))) + (defun eieio-oref-default (class slot) @@ -782,7 +787,7 @@ Fills in CLASS's SLOT with its default value." (ignore class) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) @@ -817,24 +822,29 @@ Fills in CLASS's SLOT with its default value." (defun eieio-oset (obj slot value) "Do the work for the macro `oset'. Fills in OBJ's SLOT with VALUE." - (cl-check-type obj (or eieio-object cl-structure-object)) (cl-check-type slot symbol) - (let* ((class (eieio--object-class obj)) - (c (eieio--slot-name-index class slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c - (eieio--class-slot-name-index class slot)) - ;; Oset that slot. - (progn - (eieio--validate-class-slot-value class c value slot) - (aset (eieio--class-class-allocation-values class) - c value)) - ;; See oref for comment on `slot-missing' - (slot-missing obj slot 'oset value)) - (eieio--validate-slot-value class c value slot) - (aset obj c value)))) + (cond + ((cl-typep obj '(or eieio-object cl-structure-object)) + (let* ((class (eieio--object-class obj)) + (c (eieio--slot-name-index class slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c + (eieio--class-slot-name-index class slot)) + ;; Oset that slot. + (progn + (eieio--validate-class-slot-value class c value slot) + (aset (eieio--class-class-allocation-values class) + c value)) + ;; See oref for comment on `slot-missing' + (slot-missing obj slot 'oset value)) + (eieio--validate-slot-value class c value slot) + (aset obj c value)))) + ((cl-typep obj 'oclosure) (oclosure--set-slot-value obj slot value)) + (t + (signal 'wrong-type-argument + (list '(or eieio-object cl-structure-object oclosure) obj))))) (defun eieio-oset-default (class slot value) "Do the work for the macro `oset-default'. @@ -844,7 +854,7 @@ Fills in the default value in CLASS' in SLOT with VALUE." (ignore class value) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) exp nil 'compile-only name)) @@ -867,7 +877,7 @@ Fills in the default value in CLASS' in SLOT with VALUE." (eieio--validate-class-slot-value class c value slot) (aset (eieio--class-class-allocation-values class) c value)) - (signal 'invalid-slot-name (list (eieio--class-name class) slot))) + (signal 'invalid-slot-name (list (cl--class-name class) slot))) ;; `oset-default' on an instance-allocated slot is allowed by EIEIO but ;; not by CLOS and is mildly inconsistent with the :initform thingy, so ;; it'd be nice to get rid of it. @@ -896,7 +906,7 @@ The slot is a symbol which is installed in CLASS by the `defclass' call. If SLOT is the value created with :initarg instead, reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call - (let* ((fsi (gethash slot (eieio--class-index-table class)))) + (let* ((fsi (gethash slot (cl--class-index-table class)))) (if (integerp fsi) fsi (let ((fn (eieio--initarg-to-attribute class slot))) diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 73713a3dec9..74ffeb166d4 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -5,7 +5,7 @@ ;; Author: Noah Friedman ;; Keywords: extensions ;; Created: 1995-10-06 -;; Version: 1.11.0 +;; Version: 1.11.1 ;; Package-Requires: ((emacs "26.3")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -102,7 +102,7 @@ put in the echo area. If a positive integer, the number is used directly, while a float specifies the number of lines as a proportion of the echo area frame's height. -If value is the symbol `truncate-sym-name-if-fit' t, the part of +If value is the symbol `truncate-sym-name-if-fit', the part of the doc string that represents a symbol's name may be truncated if it will enable the rest of the doc string to fit on a single line, without resizing the echo area. @@ -525,7 +525,8 @@ Helper for `eldoc-display-in-echo-area'." (goto-char (point-min)) (skip-chars-forward " \t\n") (point)) - (goto-char (line-end-position available)) + (forward-visible-line (1- available)) + (end-of-visible-line) (skip-chars-backward " \t\n"))) (truncated (save-excursion (skip-chars-forward " \t\n") @@ -535,7 +536,8 @@ Helper for `eldoc-display-in-echo-area'." ((and truncated (> available 1) eldoc-echo-area-display-truncation-message) - (goto-char (line-end-position 0)) + (forward-visible-line -1) + (end-of-visible-line) (concat (buffer-substring start (point)) (format "\n(Documentation truncated. Use `%s' to see rest)" @@ -610,7 +612,8 @@ Honor `eldoc-echo-area-use-multiline-p' and (let ((string (with-current-buffer (eldoc--format-doc-buffer docs) (buffer-substring (goto-char (point-min)) - (line-end-position 1))))) + (progn (end-of-visible-line) + (point)))))) (if (> (length string) width) ; truncation to happen (unless (eldoc--echo-area-prefer-doc-buffer-p t) (truncate-string-to-width string width)) diff --git a/lisp/emacs-lisp/faceup.el b/lisp/emacs-lisp/faceup.el index 77689f434c2..b44132dcead 100644 --- a/lisp/emacs-lisp/faceup.el +++ b/lisp/emacs-lisp/faceup.el @@ -1006,7 +1006,7 @@ which could be defined as: (defun my-test-explain (args...) (let ((faceup-test-explain t)) (the-test args...))) - (put 'my-test 'ert-explainer 'my-test-explain) + (put \\='my-test \\='ert-explainer \\='my-test-explain) Alternative, you can use the macro `faceup-defexplainer' as follows: diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 571087c963d..96eaf1ab642 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -61,6 +61,7 @@ "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ +cl-\\(?:defun\\|defmethod\\|defgeneric\\)\\|\ menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" find-function-space-re "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 7df40e36f8f..e7c3a4b64f5 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1436,29 +1436,49 @@ and initial semicolons." (derived-mode-p 'emacs-lisp-mode)) emacs-lisp-docstring-fill-column fill-column))) - (save-restriction + (let ((ppss (syntax-ppss)) + (start (point))) (save-excursion - (let ((ppss (syntax-ppss)) - (start (point))) - ;; If we're in a string, then narrow (roughly) to that - ;; string before filling. This avoids filling Lisp - ;; statements that follow the string. - (when (ppss-string-terminator ppss) - (goto-char (ppss-comment-or-string-start ppss)) - (beginning-of-line) - ;; The string may be unterminated -- in that case, don't - ;; narrow. - (when (ignore-errors - (progn - (forward-sexp 1) - t)) - (narrow-to-region (ppss-comment-or-string-start ppss) - (point)))) - ;; Move back to where we were. + (save-restriction + ;; If we're not inside a string, then do very basic + ;; filling. This avoids corrupting embedded strings in + ;; code. + (if (not (ppss-comment-or-string-start ppss)) + (lisp--fill-line-simple) + ;; If we're in a string, then narrow (roughly) to that + ;; string before filling. This avoids filling Lisp + ;; statements that follow the string. + (when (ppss-string-terminator ppss) + (goto-char (ppss-comment-or-string-start ppss)) + ;; The string may be unterminated -- in that case, don't + ;; narrow. + (when (ignore-errors + (progn + (forward-sexp 1) + t)) + (narrow-to-region (ppss-comment-or-string-start ppss) + (point)))) + ;; Move back to where we were. + (goto-char start) + (fill-paragraph justify))))))) + ;; Never return nil. + t) + +(defun lisp--fill-line-simple () + (narrow-to-region (line-beginning-position) (line-end-position)) + (goto-char (point-min)) + (while (and (not (eobp)) + (re-search-forward "\\_>" nil t)) + (when (> (current-column) fill-column) + (let ((start (point))) + (backward-sexp) + (if (looking-back "[[(]" (point-min)) (goto-char start) - (fill-paragraph justify))))) - ;; Never return nil. - t)) + (skip-chars-backward " \t") + (insert "\n") + (forward-sexp)))) + (unless (eobp) + (forward-char 1)))) (defun indent-code-rigidly (start end arg &optional nochange-regexp) "Indent all lines of code, starting in the region, sideways by ARG columns. diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 4aeca9c6b00..ffca0dcf4f5 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -171,6 +171,8 @@ This command assumes point is not in a string or comment. If INTERACTIVE is non-nil, as it is interactively, report errors as appropriate for this kind of usage." (interactive "^p\nd") + (when (ppss-comment-or-string-start (syntax-ppss)) + (user-error "This command doesn't work in strings or comments")) (if interactive (condition-case _ (down-list arg nil) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index e91b302af10..51c6e8e0ca2 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -330,108 +330,109 @@ Assumes the caller has bound `macroexpand-all-environment'." (setq form (macroexp-macroexpand form macroexpand-all-environment)) ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when ;; I tried it, it broke the bootstrap :-( - (pcase form - (`(cond . ,clauses) - (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) - (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) - (macroexp--cons - 'condition-case - (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) - form)) - (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) - (push name macroexp--dynvars) - (macroexp--all-forms form 2)) - (`(function ,(and f `(lambda . ,_))) - (let ((macroexp--dynvars macroexp--dynvars)) - (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form))) - (`(,(or 'function 'quote) . ,_) form) - (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) - pcase--dontcare)) - (let ((macroexp--dynvars macroexp--dynvars)) + (let ((fn (car-safe form))) + (pcase form + (`(cond . ,clauses) + (macroexp--cons fn (macroexp--all-clauses clauses) form)) + (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) (macroexp--cons - fun - (macroexp--cons - (macroexp--all-clauses bindings 1) - (if (null body) - (macroexp-unprogn - (macroexp-warn-and-return - (format "Empty %s body" fun) - nil nil 'compile-only fun)) - (macroexp--all-forms body)) - (cdr form)) - form))) - (`(,(and fun `(lambda . ,_)) . ,args) - ;; Embedded lambda in function position. - ;; If the byte-optimizer is loaded, try to unfold this, - ;; i.e. rewrite it to (let () ). We'd do it in the optimizer - ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the - ;; creation of a closure, thus resulting in much better code. - (let ((newform (macroexp--unfold-lambda form))) - (if (eq newform form) - ;; Unfolding failed for some reason, avoid infinite recursion. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form) - (macroexp--expand-all newform)))) - (`(funcall ,exp . ,args) - (let ((eexp (macroexp--expand-all exp)) - (eargs (macroexp--all-forms args))) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro, or to unfold it. - (pcase eexp - ((and `#',f - (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636 - (macroexp--expand-all `(,f . ,eargs))) - (_ `(funcall ,eexp . ,eargs))))) - (`(funcall . ,_) form) ;bug#53227 - (`(,func . ,_) - (let ((handler (function-get func 'compiler-macro)) - (funargs (function-get func 'funarg-positions))) - ;; Check functions quoted with ' rather than with #' - (dolist (funarg funargs) - (let ((arg (nth funarg form))) - (when (and (eq 'quote (car-safe arg)) - (eq 'lambda (car-safe (cadr arg)))) - (setcar (nthcdr funarg form) - (macroexp-warn-and-return - (format "%S quoted with ' rather than with #'" - (let ((f (cadr arg))) - (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) - arg nil nil (cadr arg)))))) - ;; Macro expand compiler macros. This cannot be delayed to - ;; byte-optimize-form because the output of the compiler-macro can - ;; use macros. - (if (null handler) - ;; No compiler macro. We just expand each argument (for - ;; setq/setq-default this works alright because the variable names - ;; are symbols). - (macroexp--all-forms form 1) - ;; If the handler is not loaded yet, try (auto)loading the - ;; function itself, which may in turn load the handler. - (unless (functionp handler) - (with-demoted-errors "macroexp--expand-all: %S" - (autoload-do-load (indirect-function func) func))) - (let ((newform (macroexp--compiler-macro handler form))) - (if (eq form newform) - ;; The compiler macro did not find anything to do. - (if (equal form (setq newform (macroexp--all-forms form 1))) - form - ;; Maybe after processing the args, some new opportunities - ;; appeared, so let's try the compiler macro again. - (setq form (macroexp--compiler-macro handler newform)) - (if (eq newform form) - newform - (macroexp--expand-all newform))) - (macroexp--expand-all newform)))))) - (_ form))) + fn + (macroexp--cons err + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form)) + (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) + (push name macroexp--dynvars) + (macroexp--all-forms form 2)) + (`(function ,(and f `(lambda . ,_))) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons fn + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form))) + (`(,(or 'function 'quote) . ,_) form) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) + pcase--dontcare)) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons + fun + (macroexp--cons + (macroexp--all-clauses bindings 1) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + (format "Empty %s body" fun) + nil nil 'compile-only fun)) + (macroexp--all-forms body)) + (cdr form)) + form))) + (`(,(and fun `(lambda . ,_)) . ,args) + ;; Embedded lambda in function position. + ;; If the byte-optimizer is loaded, try to unfold this, + ;; i.e. rewrite it to (let () ). We'd do it in the optimizer + ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the + ;; creation of a closure, thus resulting in much better code. + (let ((newform (macroexp--unfold-lambda form))) + (if (eq newform form) + ;; Unfolding failed for some reason, avoid infinite recursion. + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form) + (macroexp--expand-all newform)))) + (`(funcall ,exp . ,args) + (let ((eexp (macroexp--expand-all exp)) + (eargs (macroexp--all-forms args))) + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. + (pcase eexp + ((and `#',f + (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636 + (macroexp--expand-all `(,f . ,eargs))) + (_ `(funcall ,eexp . ,eargs))))) + (`(funcall . ,_) form) ;bug#53227 + (`(,func . ,_) + (let ((handler (function-get func 'compiler-macro)) + (funargs (function-get func 'funarg-positions))) + ;; Check functions quoted with ' rather than with #' + (dolist (funarg funargs) + (let ((arg (nth funarg form))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (setcar (nthcdr funarg form) + (macroexp-warn-and-return + (format "%S quoted with ' rather than with #'" + (let ((f (cadr arg))) + (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) + arg nil nil (cadr arg)))))) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. + (if (null handler) + ;; No compiler macro. We just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexp--all-forms form 1) + ;; If the handler is not loaded yet, try (auto)loading the + ;; function itself, which may in turn load the handler. + (unless (functionp handler) + (with-demoted-errors "macroexp--expand-all: %S" + (autoload-do-load (indirect-function func) func))) + (let ((newform (macroexp--compiler-macro handler form))) + (if (eq form newform) + ;; The compiler macro did not find anything to do. + (if (equal form (setq newform (macroexp--all-forms form 1))) + form + ;; Maybe after processing the args, some new opportunities + ;; appeared, so let's try the compiler macro again. + (setq form (macroexp--compiler-macro handler newform)) + (if (eq newform form) + newform + (macroexp--expand-all newform))) + (macroexp--expand-all newform)))))) + (_ form)))) (pop byte-compile-form-stack))) ;; Record which arguments expect functions, so we can warn when those @@ -567,12 +568,20 @@ cases where EXP is a constant." (defmacro macroexp-let2* (test bindings &rest body) "Multiple binding version of `macroexp-let2'. -BINDINGS is a list of elements of the form (SYM EXP). Each EXP -can refer to symbols specified earlier in the binding list." +BINDINGS is a list of elements of the form (SYM EXP) or just SYM, +which then stands for (SYM SYM). +Each EXP can refer to symbols specified earlier in the binding list. + +TEST has to be a symbol, and if it is nil it can be omitted." (declare (indent 2) (debug (sexp (&rest (sexp form)) body))) + (when (consp test) ;; `test' was omitted. + (push bindings body) + (setq bindings test) + (setq test nil)) (pcase-exhaustive bindings ('nil (macroexp-progn body)) - (`((,var ,exp) . ,tl) + (`(,(or `(,var ,exp) (and (pred symbolp) var (let exp var))) + . ,tl) `(macroexp-let2 ,test ,var ,exp (macroexp-let2* ,test ,tl ,@body))))) diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index b3e7fca4781..c47025f8846 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -278,11 +278,17 @@ Type \\`SPC' or \\`y' to %s the current %s; ;; For backward compatibility check if short y/n answers are preferred. (defcustom read-answer-short 'auto - "If non-nil, `read-answer' accepts single-character answers. + "If non-nil, the `read-answer' function accepts single-character answers. If t, accept short (single key-press) answers to the question. If nil, require long answers. If `auto', accept short answers if `use-short-answers' is non-nil, or the function cell of `yes-or-no-p' -is set to `y-or-n-p'." +is set to `y-or-n-p'. + +Note that this variable does not affect calls to the more +commonly-used `yes-or-no-p' function; it only affects calls to +the `read-answer' function. To control whether `yes-or-no-p' +requires a long or a short answer, see the `use-short-answers' +variable." :type '(choice (const :tag "Accept short answers" t) (const :tag "Require long answer" nil) (const :tag "Guess preference" auto)) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index dea5b34991a..8c67d7c7a25 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -175,7 +175,17 @@ MAP can be an alist, plist, hash-table, or array." (cl-defgeneric map-delete (map key) "Delete KEY in-place from MAP and return MAP. -Keys not present in MAP are ignored.") +Keys not present in MAP are ignored. + +Note that if MAP is a list (either alist or plist), and you're +deleting the final element in the list, the list isn't actually +destructively modified (but the return value will reflect the +deletion). So if you're using this method on a list, you have to +say + + (setq map (map-delete map key)) + +for this to work reliably.") (cl-defmethod map-delete ((map list) key) ;; FIXME: Signal map-not-inplace i.s.o returning a different list? @@ -540,7 +550,7 @@ TYPE is a list whose car is `hash-table' and cdr a list of keyword-args forwarded to `make-hash-table'. Example: - (map-into '((1 . 3)) '(hash-table :test eql))" + (map-into \\='((1 . 3)) \\='(hash-table :test eql))" (map--into-hash map (cdr type))) (defun map--make-pcase-bindings (args) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 77e140dda19..00c9e5438b8 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -42,55 +42,61 @@ ;; as this one), so we have to do it by hand! (push (purecopy '(nadvice 1 0)) package--builtin-versions) +(oclosure-define (advice + (:predicate advice--p) + (:copier advice--cons (cdr)) + (:copier advice--copy (car cdr how props))) + car cdr how props) + +(eval-when-compile + (defmacro advice--make-how-alist (&rest args) + `(list + ,@(mapcar + (lambda (arg) + (pcase-let ((`(,how . ,body) arg)) + `(list ,how + (oclosure-lambda (advice (how ,how)) (&rest r) + ,@body) + ,(replace-regexp-in-string + "\\" "FUNCTION" + (replace-regexp-in-string + "\\" "OLDFUN" + (format "%S" `(lambda (&rest r) ,@body)) + t t) + t t)))) + args)))) + ;;;; Lightweight advice/hook -(defvar advice--where-alist - '((:around "\300\301\302\003#\207" 5) - (:before "\300\301\002\"\210\300\302\002\"\207" 4) - (:after "\300\302\002\"\300\301\003\"\210\207" 5) - (:override "\300\301\002\"\207" 4) - (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4) - (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4) - (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4) - (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4) - (:filter-args "\300\302\301\003!\"\207" 5) - (:filter-return "\301\300\302\003\"!\207" 5)) +(defvar advice--how-alist + (advice--make-how-alist + (:around (apply car cdr r)) + (:before (apply car r) (apply cdr r)) + (:after (prog1 (apply cdr r) (apply car r))) + (:override (apply car r)) + (:after-until (or (apply cdr r) (apply car r))) + (:after-while (and (apply cdr r) (apply car r))) + (:before-until (or (apply car r) (apply cdr r))) + (:before-while (and (apply car r) (apply cdr r))) + (:filter-args (apply cdr (funcall car r))) + (:filter-return (funcall car (apply cdr r)))) "List of descriptions of how to add a function. -Each element has the form (WHERE BYTECODE STACK) where: - WHERE is a keyword indicating where the function is added. - BYTECODE is the corresponding byte-code that will be used. - STACK is the amount of stack space needed by the byte-code.") - -(defvar advice--bytecodes (mapcar #'cadr advice--where-alist)) - -(defun advice--p (object) - (and (byte-code-function-p object) - (eq 128 (aref object 0)) - (memq (length object) '(5 6)) - (memq (aref object 1) advice--bytecodes) - (eq #'apply (aref (aref object 2) 0)))) - -(defsubst advice--car (f) (aref (aref f 2) 1)) -(defsubst advice--cdr (f) (aref (aref f 2) 2)) -(defsubst advice--props (f) (aref (aref f 2) 3)) +Each element has the form (HOW OCL DOC) where HOW is a keyword, +OCL is a \"prototype\" function of type `advice', and +DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") (defun advice--cd*r (f) (while (advice--p f) (setq f (advice--cdr f))) f) -(defun advice--where (f) - (let ((bytecode (aref f 1)) - (where nil)) - (dolist (elem advice--where-alist) - (if (eq bytecode (cadr elem)) (setq where (car elem)))) - where)) +(define-obsolete-function-alias 'advice--where #'advice--how "29.1") (defun advice--make-single-doc (flist function macrop) - (let ((where (advice--where flist))) + (let ((how (advice--how flist))) (concat (format "This %s has %s advice: " (if macrop "macro" "function") - where) + how) (let ((fun (advice--car flist))) (if (symbolp fun) (format-message "`%S'." fun) (let* ((name (cdr (assq 'name (advice--props flist)))) @@ -180,33 +186,41 @@ Each element has the form (WHERE BYTECODE STACK) where: `(funcall ',fspec ',(cadr ifm)) (cadr (or iff ifm))))) -(defun advice--make-1 (byte-code stack-depth function main props) - "Build a function value that adds FUNCTION to MAIN." - (let ((adv-sig (gethash main advertised-signature-table)) - (advice - (apply #'make-byte-code 128 byte-code - (vector #'apply function main props) stack-depth nil - (and (or (commandp function) (commandp main)) - (list (advice--make-interactive-form - function main)))))) - (when adv-sig (puthash advice adv-sig advertised-signature-table)) - advice)) -(defun advice--make (where function main props) - "Build a function value that adds FUNCTION to MAIN at WHERE. -WHERE is a symbol to select an entry in `advice--where-alist'." +(cl-defmethod oclosure-interactive-form ((ad advice) &optional _) + (let ((car (advice--car ad)) + (cdr (advice--cdr ad))) + (when (or (commandp car) (commandp cdr)) + `(interactive ,(advice--make-interactive-form car cdr))))) + +(cl-defmethod cl-print-object ((object advice) stream) + (cl-assert (advice--p object)) + (princ "#f(advice " stream) + (cl-print-object (advice--car object) stream) + (princ " " stream) + (princ (advice--how object) stream) + (princ " " stream) + (cl-print-object (advice--cdr object) stream) + (let ((props (advice--props object))) + (when props + (princ " " stream) + (cl-print-object props stream))) + (princ ")" stream)) + +(defun advice--make (how function main props) + "Build a function value that adds FUNCTION to MAIN at HOW. +HOW is a symbol to select an entry in `advice--how-alist'." (let ((fd (or (cdr (assq 'depth props)) 0)) (md (if (advice--p main) (or (cdr (assq 'depth (advice--props main))) 0)))) (if (and md (> fd md)) ;; `function' should go deeper. - (let ((rest (advice--make where function (advice--cdr main) props))) - (advice--make-1 (aref main 1) (aref main 3) - (advice--car main) rest (advice--props main))) - (let ((desc (assq where advice--where-alist))) - (unless desc (error "Unknown add-function location `%S'" where)) - (advice--make-1 (nth 1 desc) (nth 2 desc) - function main props))))) + (let ((rest (advice--make how function (advice--cdr main) props))) + (advice--cons main rest)) + (let ((proto (assq how advice--how-alist))) + (unless proto (error "Unknown add-function location `%S'" how)) + (advice--copy (cadr proto) + function main how props))))) (defun advice--member-p (function use-name definition) (let ((found nil)) @@ -232,8 +246,7 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (if val (car val) (let ((nrest (advice--tweak rest tweaker))) (if (eq rest nrest) flist - (advice--make-1 (aref flist 1) (aref flist 3) - first nrest props)))))))) + (advice--cons flist nrest)))))))) ;;;###autoload (defun advice--remove-function (flist function) @@ -273,10 +286,33 @@ different, but `function-equal' will hopefully ignore those differences.") ((symbolp place) `(default-value ',place)) (t place)))) +(defun nadvice--make-docstring (sym) + (let* ((main (documentation (symbol-function sym) 'raw)) + (ud (help-split-fundoc main 'pcase)) + (doc (or (cdr ud) main)) + (col1width (apply #'max (mapcar (lambda (x) + (string-width (symbol-name (car x)))) + advice--how-alist))) + (table (mapconcat (lambda (x) + (format (format " %%-%ds %%s" col1width) + (car x) (nth 2 x))) + advice--how-alist "\n")) + (table (if global-prettify-symbols-mode + (replace-regexp-in-string "(lambda\\>" "(λ" table t t) + table)) + (combined-doc + (if (not (string-match "<<>>" doc)) + doc + (replace-match table t t doc)))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))) + +(put 'add-function 'function-documentation + '(nadvice--make-docstring 'add-function)) + ;;;###autoload -(defmacro add-function (where place function &optional props) +(defmacro add-function (how place function &optional props) ;; TODO: - ;; - maybe let `where' specify some kind of predicate and use it + ;; - maybe let `how' specify some kind of predicate and use it ;; to implement things like mode-local or eieio-defmethod. ;; Of course, that only makes sense if the predicates of all advices can ;; be combined and made more efficient. @@ -285,20 +321,11 @@ different, but `function-equal' will hopefully ignore those differences.") ;; :before-until is like add-hook on run-hook-with-args-until-success. ;; Same with :after-* but for (add-hook ... 'append). "Add a piece of advice on the function stored at PLACE. -FUNCTION describes the code to add. WHERE describes where to add it. -WHERE can be explained by showing the resulting new function, as the +FUNCTION describes the code to add. HOW describes how to add it. +HOW can be explained by showing the resulting new function, as the result of combining FUNCTION and the previous value of PLACE, which we call OLDFUN here: -`:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) -`:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r))) -`:around' (lambda (&rest r) (apply FUNCTION OLDFUN r)) -`:override' (lambda (&rest r) (apply FUNCTION r)) -`:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r))) -`:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r))) -`:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r))) -`:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r))) -`:filter-args' (lambda (&rest r) (apply OLDFUN (funcall FUNCTION r))) -`:filter-return'(lambda (&rest r) (funcall FUNCTION (apply OLDFUN r))) +<<>> If FUNCTION was already added, do nothing. PROPS is an alist of additional properties, among which the following have a special meaning: @@ -326,13 +353,13 @@ is also interactive. There are 3 cases: ;;(indent 2) (debug (form [&or symbolp ("local" form) ("var" sexp) gv-place] form &optional form))) - `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) + `(advice--add-function ,how (gv-ref ,(advice--normalize-place place)) ,function ,props)) (declare-function comp-subr-trampoline-install "comp") ;;;###autoload -(defun advice--add-function (where ref function props) +(defun advice--add-function (how ref function props) (when (and (featurep 'native-compile) (subr-primitive-p (gv-deref ref))) (let ((subr-name (intern (subr-name (gv-deref ref))))) @@ -357,7 +384,7 @@ is also interactive. There are 3 cases: (advice--remove-function (gv-deref ref) (or name (advice--car a))))) (setf (gv-deref ref) - (advice--make where function (gv-deref ref) props)))) + (advice--make how function (gv-deref ref) props)))) ;;;###autoload (defmacro remove-function (place function) @@ -455,11 +482,16 @@ of the piece of advice." (put symbol 'advice--pending (advice--subst-main oldadv nil))) (funcall fsetfun symbol newdef)))) +(put 'advice-add 'function-documentation + '(nadvice--make-docstring 'advice-add)) + ;;;###autoload -(defun advice-add (symbol where function &optional props) +(defun advice-add (symbol how function &optional props) "Like `add-function' but for the function named SYMBOL. Contrary to `add-function', this will properly handle the cases where SYMBOL -is defined as a macro, alias, command, ..." +is defined as a macro, alias, command, ... +HOW can be one of: +<<>>" ;; TODO: ;; - record the advice location, to display in describe-function. ;; - change all defadvice in lisp/**/*.el. @@ -467,21 +499,21 @@ is defined as a macro, alias, command, ..." (let* ((f (symbol-function symbol)) (nf (advice--normalize symbol f))) (unless (eq f nf) (fset symbol nf)) - (add-function where (cond - ((eq (car-safe nf) 'macro) (cdr nf)) - ;; Reasons to delay installation of the advice: - ;; - If the function is not yet defined, installing - ;; the advice would affect `fboundp'ness. - ;; - the symbol-function slot of an autoloaded - ;; function is not itself a function value. - ;; - `autoload' does nothing if the function is - ;; not an autoload or undefined. - ((or (not nf) (autoloadp nf)) - (get symbol 'advice--pending)) - (t (symbol-function symbol))) + (add-function how (cond + ((eq (car-safe nf) 'macro) (cdr nf)) + ;; Reasons to delay installation of the advice: + ;; - If the function is not yet defined, installing + ;; the advice would affect `fboundp'ness. + ;; - the symbol-function slot of an autoloaded + ;; function is not itself a function value. + ;; - `autoload' does nothing if the function is + ;; not an autoload or undefined. + ((or (not nf) (autoloadp nf)) + (get symbol 'advice--pending)) + (t (symbol-function symbol))) function props) - ;; FIXME: We could use a defmethod on `function-docstring' instead, - ;; except when (or (not nf) (autoloadp nf))! + ;; FIXME: We could use a defmethod on `function-documentation' instead, + ;; except when (autoloadp nf)! (put symbol 'function-documentation `(advice--make-docstring ',symbol)) (add-function :around (get symbol 'defalias-fset-function) #'advice--defalias-fset)) @@ -517,12 +549,12 @@ See `advice-add' and `add-function' for explanation on the arguments. Note if NAME is nil the advice is anonymous; otherwise it is named `SYMBOL@NAME'. -\(fn SYMBOL (WHERE LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" +\(fn SYMBOL (HOW LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" (declare (indent 2) (doc-string 3) (debug (sexp sexp def-body))) (or (listp args) (signal 'wrong-type-argument (list 'listp args))) (or (<= 2 (length args) 4) (signal 'wrong-number-of-arguments (list 2 4 (length args)))) - (let* ((where (nth 0 args)) + (let* ((how (nth 0 args)) (lambda-list (nth 1 args)) (name (nth 2 args)) (depth (nth 3 args)) @@ -532,7 +564,7 @@ otherwise it is named `SYMBOL@NAME'. (intern (format "%s@%s" symbol name))) (t (error "Unrecognized name spec `%S'" name))))) `(prog1 ,@(and (symbolp advice) `((defun ,advice ,lambda-list ,@body))) - (advice-add ',symbol ,where #',advice ,@(and props `(',props)))))) + (advice-add ',symbol ,how #',advice ,@(and props `(',props)))))) (defun advice-mapc (fun symbol) "Apply FUN to every advice function in SYMBOL. diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el new file mode 100644 index 00000000000..cb8c59b05a2 --- /dev/null +++ b/lisp/emacs-lisp/oclosure.el @@ -0,0 +1,562 @@ +;;; oclosure.el --- Open Closures -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; Author: Stefan Monnier + +;; 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 . + +;;; Commentary: + +;; An OClosure is an object that combines the properties of records +;; with those of a function. More specifically it is a function extended +;; with a notion of type (e.g. for defmethod dispatch) as well as the +;; ability to have some fields that are accessible from the outside. + +;; See "Open closures", ELS'2022 (https://zenodo.org/record/6228797). + +;; Here are some cases of "callable objects" where OClosures have found use: +;; - nadvice.el (the original motivation) +;; - kmacros (for cl-print and for `kmacro-extract-lambda') +;; - cl-generic: turn `cl--generic-isnot-nnm-p' into a mere type test +;; (by putting the no-next-methods into their own class). +;; - Slot accessor functions, where the type-dispatch can be used to +;; dynamically compute the docstring, and also to pretty print them. +;; - `save-some-buffers-function' +;; Here are other cases of "callable objects" where OClosures could be used: +;; - Use the type to distinguish macros from functions. +;; - Use a `name' and `depth' property from the function passed to +;; `add-function' (or `add-hook') instead of passing it via "props". +;; - iterators (generator.el), thunks (thunk.el), streams (stream.el). +;; - PEG rules: they're currently just functions, but they should carry +;; their original (macro-expanded) definition (and should be printed +;; differently from functions)! +;; - auto-generate docstrings for cl-defstruct slot accessors instead of +;; storing them in the accessor itself? +;; - SRFI-17's `setter'. +;; - coercion wrappers, as in "Threesomes, with and without blame" +;; https://dl.acm.org/doi/10.1145/1706299.1706342, or +;; "On the Runtime Complexity of Type-Directed Unboxing" +;; http://sv.c.titech.ac.jp/minamide/papers.html +;; - An efficient `negate' operation such that +;; (negate (negate f)) returns just `f' and (negate #'<) returns #'>=. +;; - Autoloads (tho currently our bytecode functions (and hence OClosures) +;; are too fat for that). + +;; Related constructs: +;; - `funcallable-standard-object' (FSO) in Common-Lisp. These are different +;; from OClosures in that they involve an additional indirection to get +;; to the actual code, and that they offer the possibility of +;; changing (via mutation) the code associated with +;; an FSO. Also the FSO's function can't directly access the FSO's +;; other fields, contrary to the case with OClosures where those are directly +;; available as local variables. +;; - Function objects in Javascript. +;; - Function objects in Python. +;; - Callable/Applicable classes in OO languages, i.e. classes with +;; a single method called `apply' or `call'. The most obvious +;; difference with OClosures (beside the fact that Callable can be +;; extended with additional methods) is that all instances of +;; a given Callable class have to use the same method, whereas every +;; OClosure object comes with its own code, so two OClosure objects of the +;; same type can have different code. Of course, you can get the +;; same result by turning every `oclosure-lambda' into its own class +;; declaration creating an ad-hoc subclass of the specified type. +;; In this sense, OClosures are just a generalization of `lambda' which brings +;; some of the extra feature of Callable objects. +;; - Apply hooks and "entities" in MIT Scheme +;; https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Application-Hooks.html +;; Apply hooks are basically the same as Common-Lisp's FSOs, and "entities" +;; are a variant of it where the inner function gets the FSO itself as +;; additional argument (a kind of "self" arg), thus making it easier +;; for the code to get data from the object's extra info, tho still +;; not as easy as with OClosures. +;; - "entities" in Lisp Machine Lisp (LML) +;; https://hanshuebner.github.io/lmman/fd-clo.xml +;; These are arguably identical to OClosures, modulo the fact that LML doesn't +;; have lexically-scoped closures and uses a form of closures based on +;; capturing (and reinstating) dynamically scoped bindings instead. + +;; Naming: OClosures were originally named FunCallableRecords (FCR), but +;; that name suggested these were fundamentally records that happened +;; to be called, whereas OClosures are really just closures that happen +;; to enjoy some characteristics of records. +;; The "O" comes from "Open" because OClosures aren't completely opaque +;; (for that same reason, an alternative name suggested at the time was +;; "disclosures"). +;; The "O" can also be understood to mean "Object" since you have notions +;; of inheritance, and the ability to associate methods with particular +;; OClosure types, just as is the case for OO classes. + +;;; Code: + +;; TODO: +;; - `oclosure-(cl-)defun', `oclosure-(cl-)defsubst', `oclosure-define-inline'? +;; - Use accessor in cl-defstruct. +;; - Add pcase patterns for OClosures. +;; - anonymous OClosure types. +;; - copiers for mixins +;; - class-allocated slots? +;; - code-allocated slots? +;; The `where' slot of `advice' would like to be code-allocated, and the +;; interactive-spec of commands is currently code-allocated but would like +;; to be instance-allocated. Their scoping rules are a bit odd, so maybe +;; it's best to avoid them. + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;For `named-let'. + +(defun oclosure--index-table (slotdescs) + (let ((i -1) + (it (make-hash-table :test #'eq))) + (dolist (desc slotdescs) + (let* ((slot (cl--slot-descriptor-name desc))) + (cl-incf i) + (when (gethash slot it) + (error "Duplicate slot name: %S" slot)) + (setf (gethash slot it) i))) + it)) + +(cl-defstruct (oclosure--class + (:constructor nil) + (:constructor oclosure--class-make + ( name docstring slots parents allparents + &aux (index-table (oclosure--index-table slots)))) + (:include cl--class) + (:copier nil)) + "Metaclass for OClosure classes." + (allparents nil :read-only t :type (list-of symbol))) + +(setf (cl--find-class 'oclosure) + (oclosure--class-make 'oclosure + "The root parent of all OClosure classes" + nil nil '(oclosure))) +(defun oclosure--p (oclosure) + (not (not (oclosure-type oclosure)))) + +(cl-deftype oclosure () '(satisfies oclosure--p)) + +(defun oclosure--slot-mutable-p (slotdesc) + (not (alist-get :read-only (cl--slot-descriptor-props slotdesc)))) + +(defun oclosure--defstruct-make-copiers (copiers slotdescs name) + (require 'cl-macs) ;`cl--arglist-args' is not autoloaded. + (let* ((mutables '()) + (slots (mapcar + (lambda (desc) + (let ((name (cl--slot-descriptor-name desc))) + (when (oclosure--slot-mutable-p desc) + (push name mutables)) + name)) + slotdescs))) + (mapcar + (lambda (copier) + (pcase-let* + ((cname (pop copier)) + (args (or (pop copier) `(&key ,@slots))) + (inline (and (eq :inline (car copier)) (pop copier))) + (doc (or (pop copier) + (format "Copier for objects of type `%s'." name))) + (obj (make-symbol "obj")) + (absent (make-symbol "absent")) + (anames (cl--arglist-args args)) + (mnames + (let ((res '()) + (tmp args)) + (while (and tmp + (not (memq (car tmp) + cl--lambda-list-keywords))) + (push (pop tmp) res)) + res)) + (index -1) + (mutlist '()) + (argvals + (mapcar + (lambda (slot) + (setq index (1+ index)) + (let* ((mutable (memq slot mutables)) + (get `(oclosure--get ,obj ,index ,(not (not mutable))))) + (push mutable mutlist) + (cond + ((not (memq slot anames)) get) + ((memq slot mnames) slot) + (t + `(if (eq ',absent ,slot) + ,get + ,slot))))) + slots))) + `(,(if inline 'cl-defsubst 'cl-defun) ,cname + (&cl-defs (',absent) ,obj ,@args) + ,doc + (declare (side-effect-free t)) + (oclosure--copy ,obj ',(if (remq nil mutlist) (nreverse mutlist)) + ,@argvals)))) + copiers))) + + +(defmacro oclosure-define (name &optional docstring &rest slots) + "Define a new OClosure type. +NAME should be a symbol which is the name of the new type. +It can also be of the form (NAME . PROPS) in which case PROPS +is a list of additional properties among the following: + (:predicate PRED): asks to create a predicate function named PRED. + (:parent TYPE): make TYPE (another OClosure type) be a parent of NAME. + (:copier COPIER ARGS): asks to create a \"copier\" (i.e. functional update + function) named COPIER. It will take an object of type NAME as first + argument followed by ARGS. ARGS lists the names of the slots that will + be updated with the value of the corresponding argument. +SLOTS is a list if slot descriptions. Each slot can be a single symbol +which is the name of the slot, or it can be of the form (SLOT-NAME . SPROPS) +where SLOT-NAME is then the name of the slot and SPROPS is a property +list of slot properties. The currently known properties are the following: + `:mutable': A non-nil value mean the slot can be mutated. + `:type': Specifies the type of the values expected to appear in the slot." + (declare (doc-string 2) (indent 1)) + (unless (stringp docstring) + (push docstring slots) + (setq docstring nil)) + (let* ((options (when (consp name) + (prog1 (copy-sequence (cdr name)) + (setq name (car name))))) + (get-opt (lambda (opt &optional all) + (let ((val (assq opt options)) + tmp) + (when val (setq options (delq val options))) + (if (not all) + (cdr val) + (when val + (setq val (list (cdr val))) + (while (setq tmp (assq opt options)) + (push (cdr tmp) val) + (setq options (delq tmp options))) + (nreverse val)))))) + (predicate (car (funcall get-opt :predicate))) + (parent-names (or (funcall get-opt :parent) + (funcall get-opt :include))) + (copiers (funcall get-opt :copier 'all))) + `(progn + ,(when options (macroexp-warn-and-return name + (format "Ignored options: %S" options) + nil)) + (eval-and-compile + (oclosure--define ',name ,docstring ',parent-names ',slots + ,@(when predicate `(:predicate ',predicate)))) + (oclosure--define-functions ,name ,copiers)))) + +(defun oclosure--build-class (name docstring parent-names slots) + (cl-assert (null (cdr parent-names))) + (let* ((parent-class (let ((name (or (car parent-names) 'oclosure))) + (or (cl--find-class name) + (error "Unknown class: %S" name)))) + (slotdescs + (append + (oclosure--class-slots parent-class) + (mapcar (lambda (field) + (if (not (consp field)) + (cl--make-slot-descriptor field nil nil + '((:read-only . t))) + (let ((name (pop field)) + (type nil) + (read-only t) + (props '())) + (while field + (pcase (pop field) + (:mutable (setq read-only (not (car field)))) + (:type (setq type (car field))) + (p (message "Unknown property: %S" p) + (push (cons p (car field)) props))) + (setq field (cdr field))) + (cl--make-slot-descriptor name nil type + `((:read-only . ,read-only) + ,@props))))) + slots)))) + (oclosure--class-make name docstring slotdescs + (if (cdr parent-names) + (oclosure--class-parents parent-class) + (list parent-class)) + (cons name (oclosure--class-allparents + parent-class))))) + +(defmacro oclosure--define-functions (name copiers) + (let* ((class (cl--find-class name)) + (slotdescs (oclosure--class-slots class))) + `(progn + ,@(let ((i -1)) + (mapcar (lambda (desc) + (let* ((slot (cl--slot-descriptor-name desc)) + (mutable (oclosure--slot-mutable-p desc)) + ;; Always use a double hyphen: if users wants to + ;; make it public, they can do so with an alias. + (aname (intern (format "%S--%S" name slot)))) + (cl-incf i) + (if (not mutable) + `(defalias ',aname + ;; We use `oclosure--copy' instead of + ;; `oclosure--accessor-copy' here to circumvent + ;; bootstrapping problems. + (oclosure--copy + oclosure--accessor-prototype + nil ',name ',slot ,i)) + (require 'gv) ;For `gv-setter'. + `(progn + (defalias ',aname + (oclosure--accessor-copy + oclosure--mut-getter-prototype + ',name ',slot ,i)) + (defalias ',(gv-setter aname) + (oclosure--accessor-copy + oclosure--mut-setter-prototype + ',name ',slot ,i)))))) + slotdescs)) + ,@(oclosure--defstruct-make-copiers + copiers slotdescs name)))) + +;;;###autoload +(defun oclosure--define (name docstring parent-names slots + &rest props) + (let* ((class (oclosure--build-class name docstring parent-names slots)) + (pred (lambda (oclosure) + (let ((type (oclosure-type oclosure))) + (when type + (memq name (oclosure--class-allparents + (cl--find-class type))))))) + (predname (or (plist-get props :predicate) + (intern (format "%s--internal-p" name))))) + (setf (cl--find-class name) class) + (dolist (slot (oclosure--class-slots class)) + (put (cl--slot-descriptor-name slot) 'slot-name t)) + (defalias predname pred) + (put name 'cl-deftype-satisfies predname))) + +(defmacro oclosure--lambda (type bindings mutables args &rest body) + "Low level construction of an OClosure object. +TYPE should be a form returning an OClosure type (a symbol) +BINDINGS should list all the slots expected by this type, in the proper order. +MUTABLE is a list of symbols indicating which of the BINDINGS +should be mutable. +No checking is performed," + (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body))) + ;; FIXME: Fundamentally `oclosure-lambda' should be a special form. + ;; We define it here as a macro which expands to something that + ;; looks like "normal code" in order to avoid backward compatibility + ;; issues with third party macros that do "code walks" and would + ;; likely mishandle such a new special form (e.g. `generator.el'). + ;; But don't be fooled: this macro is tightly bound to `cconv.el'. + (pcase-let* + ((`(,prebody . ,body) (macroexp-parse-body body)) + (rovars (mapcar #'car bindings))) + (dolist (mutable mutables) + (setq rovars (delq mutable rovars))) + `(let ,(mapcar (lambda (bind) + (if (cdr bind) bind + ;; Bind to something that doesn't look + ;; like a value to avoid the "Variable + ;; ‘foo’ left uninitialized" warning. + `(,(car bind) (progn nil)))) + (reverse bindings)) + ;; FIXME: Make sure the slotbinds whose value is duplicable aren't + ;; just value/variable-propagated by the optimizer (tho I think our + ;; optimizer is too naive to be a problem currently). + (oclosure--fix-type + ;; This `oclosure--fix-type' + `ignore' call is used by the compiler (in + ;; `cconv.el') to detect and signal an error in case of + ;; store-conversion (i.e. if a variable/slot is mutated). + (ignore ,@rovars) + (lambda ,args + (:documentation ,type) + ,@prebody + ;; Add dummy code which accesses the field's vars to make sure + ;; they're captured in the closure. + (if t nil ,@rovars ,@(mapcar (lambda (m) `(setq ,m ,m)) mutables)) + ,@body))))) + +(defmacro oclosure-lambda (type-and-slots args &rest body) + "Define anonymous OClosure function. +TYPE-AND-SLOTS should be of the form (TYPE . SLOTS) +where TYPE is an OClosure type name (defined by `oclosure-define') +and SLOTS is a let-style list of bindings for the various slots of TYPE. +ARGS and BODY are the same as for `lambda'." + (declare (indent 2) (debug ((sexp &rest (sexp form)) sexp def-body))) + ;; FIXME: Should `oclosure-define' distinguish "optional" from + ;; "mandatory" slots, and/or provide default values for slots missing + ;; from `fields'? + (pcase-let* + ((`(,type . ,fields) type-and-slots) + (class (or (cl--find-class type) + (error "Unknown class: %S" type))) + (slots (oclosure--class-slots class)) + (mutables '()) + (slotbinds (mapcar (lambda (slot) + (let ((name (cl--slot-descriptor-name slot))) + (when (oclosure--slot-mutable-p slot) + (push name mutables)) + (list name))) + slots)) + (tempbinds (mapcar + (lambda (field) + (let* ((name (car field)) + (bind (assq name slotbinds))) + (cond + ;; FIXME: Should we also warn about missing slots? + ((not bind) + (error "Unknown slot: %S" name)) + ((cdr bind) + (error "Duplicate slot: %S" name)) + (t + (let ((temp (gensym "temp"))) + (setcdr bind (list temp)) + (cons temp (cdr field))))))) + fields))) + ;; FIXME: Optimize temps away when they're provided in the right order? + `(let ,tempbinds + (oclosure--lambda ',type ,slotbinds ,mutables ,args ,@body)))) + +(defun oclosure--fix-type (_ignore oclosure) + "Helper function to implement `oclosure-lambda' via a macro. +This has 2 uses: +- For interpreted code, this converts the representation of type information + by moving it from the docstring to the environment. +- For compiled code, this is used as a marker which cconv uses to check that + immutable fields are indeed not mutated." + (if (byte-code-function-p oclosure) + ;; Actually, this should never happen since the `cconv.el' should have + ;; optimized away the call to this function. + oclosure + ;; For byte-coded functions, we store the type as a symbol in the docstring + ;; slot. For interpreted functions, there's no specific docstring slot + ;; so `Ffunction' turns the symbol into a string. + ;; We thus have convert it back into a symbol (via `intern') and then + ;; stuff it into the environment part of the closure with a special + ;; marker so we can distinguish this entry from actual variables. + (cl-assert (eq 'closure (car-safe oclosure))) + (let ((typename (nth 3 oclosure))) ;; The "docstring". + (cl-assert (stringp typename)) + (push (cons :type (intern typename)) + (cadr oclosure)) + oclosure))) + +(defun oclosure--copy (oclosure mutlist &rest args) + (if (byte-code-function-p oclosure) + (apply #'make-closure oclosure + (if (null mutlist) + args + (mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args))) + (cl-assert (eq 'closure (car-safe oclosure)) + nil "oclosure not closure: %S" oclosure) + (cl-assert (eq :type (caar (cadr oclosure)))) + (let ((env (cadr oclosure))) + `(closure + (,(car env) + ,@(named-let loop ((env (cdr env)) (args args)) + (when args + (cons (cons (caar env) (car args)) + (loop (cdr env) (cdr args))))) + ,@(nthcdr (1+ (length args)) env)) + ,@(nthcdr 2 oclosure))))) + +(defun oclosure--get (oclosure index mutable) + (if (byte-code-function-p oclosure) + (let* ((csts (aref oclosure 2)) + (v (aref csts index))) + (if mutable (car v) v)) + (cl-assert (eq 'closure (car-safe oclosure))) + (cl-assert (eq :type (caar (cadr oclosure)))) + (cdr (nth (1+ index) (cadr oclosure))))) + +(defun oclosure--set (v oclosure index) + (if (byte-code-function-p oclosure) + (let* ((csts (aref oclosure 2)) + (cell (aref csts index))) + (setcar cell v)) + (cl-assert (eq 'closure (car-safe oclosure))) + (cl-assert (eq :type (caar (cadr oclosure)))) + (setcdr (nth (1+ index) (cadr oclosure)) v))) + +(defun oclosure-type (oclosure) + "Return the type of OCLOSURE, or nil if the arg is not a OClosure." + (if (byte-code-function-p oclosure) + (let ((type (and (> (length oclosure) 4) (aref oclosure 4)))) + (if (symbolp type) type)) + (and (eq 'closure (car-safe oclosure)) + (let* ((env (car-safe (cdr oclosure))) + (first-var (car-safe env))) + (and (eq :type (car-safe first-var)) + (cdr first-var)))))) + +(defconst oclosure--accessor-prototype + ;; Use `oclosure--lambda' to circumvent a bootstrapping problem: + ;; `oclosure-accessor' is not yet defined at this point but + ;; `oclosure--accessor-prototype' is needed when defining `oclosure-accessor'. + (oclosure--lambda 'oclosure-accessor ((type) (slot) (index)) nil + (oclosure) (oclosure--get oclosure index nil))) + +(oclosure-define accessor + "OClosure function to access a specific slot of an object." + type slot) + +(defun oclosure--accessor-cl-print (object stream) + (princ "#f(accessor " stream) + (prin1 (accessor--type object) stream) + (princ "." stream) + (prin1 (accessor--slot object) stream) + (princ ")" stream)) + +(defun oclosure--accessor-docstring (f) + ;; This would like to be a (cl-defmethod function-documentation ...) + ;; but for circularity reason the defmethod is in `simple.el'. + (format "Access slot \"%S\" of OBJ of type `%S'.\n\n(fn OBJ)" + (accessor--slot f) (accessor--type f))) + +(oclosure-define (oclosure-accessor + (:parent accessor) + (:copier oclosure--accessor-copy (type slot index))) + "OClosure function to access a specific slot of an OClosure function." + index) + +(defun oclosure--slot-index (oclosure slotname) + (gethash slotname + (oclosure--class-index-table + (cl--find-class (oclosure-type oclosure))))) + +(defun oclosure--slot-value (oclosure slotname) + (let ((class (cl--find-class (oclosure-type oclosure))) + (index (oclosure--slot-index oclosure slotname))) + (oclosure--get oclosure index + (oclosure--slot-mutable-p + (nth index (oclosure--class-slots class)))))) + +(defun oclosure--set-slot-value (oclosure slotname value) + (let ((class (cl--find-class (oclosure-type oclosure))) + (index (oclosure--slot-index oclosure slotname))) + (unless (oclosure--slot-mutable-p + (nth index (oclosure--class-slots class))) + (signal 'setting-constant (list oclosure slotname))) + (oclosure--set value oclosure index))) + +(defconst oclosure--mut-getter-prototype + (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure) + (oclosure--get oclosure index t))) +(defconst oclosure--mut-setter-prototype + ;; FIXME: The generated docstring is wrong. + (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (val oclosure) + (oclosure--set val oclosure index))) + +;; Ideally, this should be in `files.el', but that file is loaded +;; before `oclosure.el'. +(oclosure-define (save-some-buffers-function + (:predicate save-some-buffers-function--p))) + + +(provide 'oclosure) +;;; oclosure.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 6aa82e576d9..58c1349e1c2 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -566,9 +566,9 @@ This is the name of the package with its version appended." "Return file-name extension of package-desc object PKG-DESC. Depending on the `package-desc-kind' of PKG-DESC, this is one of: - 'single - \".el\" - 'tar - \".tar\" - 'dir - \"\" + \\='single - \".el\" + \\='tar - \".tar\" + \\='dir - \"\" Signal an error if the kind is none of the above." (pcase (package-desc-kind pkg-desc) @@ -1854,8 +1854,12 @@ SEEN is used internally to detect infinite recursion." (error "Need package `%s-%s', but only %s is available" next-pkg (package-version-join next-version) found-something)) - (t (error "Package `%s-%s' is unavailable" - next-pkg (package-version-join next-version))))) + (t + (if (eq next-pkg 'emacs) + (error "This package requires Emacs version %s" + (package-version-join next-version)) + (error "Package `%s-%s' is unavailable" + next-pkg (package-version-join next-version)))))) (setq packages (package-compute-transaction (cons found packages) (package-desc-reqs found) @@ -2132,6 +2136,31 @@ to install it but still mark it as selected." (message "Package `%s' installed." name)) (message "`%s' is already installed" name)))) +;;;###autoload +(defun package-update (name) + "Update package NAME if a newer version exists." + (interactive + (progn + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (package--archives-initialize) + (list (completing-read + "Update package: " + (mapcar + #'car + (seq-filter + (lambda (elt) + (let ((available + (assq (car elt) package-archive-contents))) + (and available + (version-list-< + (package-desc-priority-version (cadr elt)) + (package-desc-priority-version (cadr available)))))) + package-alist)) + nil t)))) + (package-delete (cadr (assq (intern name) package-alist)) 'force) + (package-install (intern name) 'dont-select)) + (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. If the result looks like a dotted numeric version, return it. @@ -3461,7 +3490,7 @@ corresponding to the newer version." ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC]) (let ((pkg-desc (car entry)) (status (aref (cadr entry) 2))) - (cond ((member status '("installed" "dependency" "unsigned")) + (cond ((member status '("installed" "dependency" "unsigned" "external")) (push pkg-desc installed)) ((member status '("available" "new")) (setq available (package--append-to-alist pkg-desc available)))))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 0330a2a0aba..07443dabfef 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -328,7 +328,7 @@ PATTERNS are normal `pcase' patterns, and VALUES are expression. Evaluation happens sequentially as in `setq' (not in parallel). -An example: (pcase-setq `((,a) [(,b)]) '((1) [(2)])) +An example: (pcase-setq \\=`((,a) [(,b)]) \\='((1) [(2)])) VAL is presumed to match PAT. Failure to match may signal an error or go undetected, binding variables to arbitrary values, such as nil. diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index e782cdb1dab..ad693fa5a61 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -177,6 +177,10 @@ Also add the value to the front of the list in the variable `values'." (let ((pt (point))) (save-excursion (forward-sexp -1) + ;; Make `pp-eval-last-sexp' work the same way `eval-last-sexp' + ;; does. + (when (looking-at ",@?") + (goto-char (match-end 0))) (read ;; If first line is commented, ignore all leading comments: (if (save-excursion (beginning-of-line) (looking-at-p "[ \t]*;")) diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index e635c7f200c..195035e6be9 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -112,9 +112,15 @@ (goto-char start) (dolist (line (split-string text "\n")) (end-of-line) - (if (bolp) - (insert line "\n") - (insert line)) + (if (not (bolp)) + (insert line) + (insert (make-string + (max (- (* (mod (1- times) columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (insert line "\n")) (forward-line 1)))))))) buf)) @@ -163,8 +169,9 @@ Usage example: \\='((?a \"always\") (?s \"session only\") (?n \"no\")))" - (let* ((choices (if show-help choices (append choices '((?? "?"))))) - (altered-names (mapcar #'rmc--add-key-description choices)) + (let* ((prompt-choices + (if show-help choices (append choices '((?? "?"))))) + (altered-names (mapcar #'rmc--add-key-description prompt-choices)) (full-prompt (format "%s (%s): " @@ -175,7 +182,7 @@ Usage example: (save-excursion (if show-help (setq buf (rmc--show-help prompt help-string show-help - choices altered-names))) + choices altered-names))) (while (not tchar) (message "%s%s" (if wrong-char @@ -194,7 +201,7 @@ Usage example: (lambda (elem) (cons (capitalize (cadr elem)) (car elem))) - choices))) + prompt-choices))) (condition-case nil (let ((cursor-in-echo-area t)) (read-event)) @@ -232,7 +239,7 @@ Usage example: (when wrong-char (ding)) (setq buf (rmc--show-help prompt help-string show-help - choices altered-names)))))) + choices altered-names)))))) (when (buffer-live-p buf) (kill-buffer buf)) (assq tchar choices))) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 5ea9fae2e9b..133d3c9e118 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -403,23 +403,23 @@ found or not." (setq count (+ 1 count)))) count)) -(with-suppressed-warnings ((obsolete seq-contains)) - (cl-defgeneric seq-contains (sequence elt &optional testfn) - "Return the first element in SEQUENCE that is equal to ELT. +(cl-defgeneric seq-contains (sequence elt &optional testfn) + "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." - (declare (obsolete seq-contains-p "27.1")) - (seq-some (lambda (e) - (when (funcall (or testfn #'equal) elt e) - e)) - sequence))) + (declare (obsolete seq-contains-p "27.1")) + (seq-some (lambda (e) + (when (funcall (or testfn #'equal) elt e) + e)) + sequence)) (cl-defgeneric seq-contains-p (sequence elt &optional testfn) "Return non-nil if SEQUENCE contains an element equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." (catch 'seq--break (seq-doseq (e sequence) - (when (funcall (or testfn #'equal) e elt) - (throw 'seq--break t))) + (let ((r (funcall (or testfn #'equal) e elt))) + (when r + (throw 'seq--break r)))) nil)) (cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 8cd371321ae..2343a9b589f 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -177,12 +177,11 @@ See the documentation for `list-load-path-shadows' for further information." . (1 font-lock-warning-face))) "Keywords to highlight in `load-path-shadows-mode'.") -(define-derived-mode load-path-shadows-mode fundamental-mode "LP-Shadows" +(define-derived-mode load-path-shadows-mode special-mode "LP-Shadows" "Major mode for `load-path' shadows buffer." (setq-local font-lock-defaults '((load-path-shadows-font-lock-keywords))) - (setq buffer-undo-list t - buffer-read-only t)) + (setq buffer-undo-list t)) ;; TODO use text-properties instead, a la dired. (define-button-type 'load-path-shadows-find-file diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 658edd67527..340fe766c1e 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -47,30 +47,67 @@ "Add GROUP to the list of defined documentation groups. FUNCTIONS is a list of elements on the form: - (fun + (FUNC :no-manual BOOL :args ARGS - :eval EXAMPLE-FORM + :eval EVAL :no-eval EXAMPLE-FORM - :no-eval* EXAMPLE-FORM :no-value EXAMPLE-FORM + :no-eval* EXAMPLE-FORM :result RESULT-FORM - :result-string RESULT-FORM + :result-string RESULT-STRING :eg-result RESULT-FORM - :eg-result-string RESULT-FORM) + :eg-result-string RESULT-STRING) -BOOL should be non-nil if the function isn't documented in the +FUNC is the function being documented. + +NO-MANUAL should be non-nil if FUNC isn't documented in the manual. -ARGS is optional; the function's signature is displayed if ARGS -is not present. +ARGS is optional list of function FUNC's arguments. FUNC's +signature is displayed automatically if ARGS is not present. +Specifying ARGS might be useful where you don't want to document +some of the uncommon arguments a function might have. -If EVAL isn't a string, it will be printed with `prin1', and then -evaluated to give a result, which is also printed. If it's a -string, it'll be inserted as is, then the string will be `read', -and then evaluated. +While the `:no-manual' and `:args' property can be used for +any (FUNC ..) form, all of the other properties shown above +cannot be used simultaneously in such a form. -There can be any number of :example/:result elements." +Here are some common forms with examples of properties that go +together: + +1. Document a form or string, and its evaluated return value. + (FUNC + :eval EVAL) + +If EVAL is a string, it will be inserted as is, and then that +string will be `read' and evaluated. + +2. Document a form or string, but manually document its evalation + result. The provided form will not be evaluated. + + (FUNC + :no-eval EXAMPLE-FORM + :result RESULT-FORM ;Use `:result-string' if value is in string form + ) + +Using `:no-value' is the same as using `:no-eval'. + +Use `:no-eval*' instead of `:no-eval' where the successful +execution of the documented form depends on some conditions. + +3. Document a form or string EXAMPLE-FORM. Also manually + document an example result. This result could be unrelated to + the documented form. + + (FUNC + :no-eval EXAMPLE-FORM + :eg-result RESULT-FORM ;Use `:eg-result-string' if value is in string form + ) + +A FUNC form can have any number of `:no-eval' (or `:no-value'), +`:no-eval*', `:result', `:result-string', `:eg-result' and +`:eg-result-string' properties." (declare (indent defun)) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) @@ -1261,16 +1298,20 @@ There can be any number of :example/:result elements." :eval (keymap-lookup (current-global-map) "C-x x g"))) ;;;###autoload -(defun shortdoc-display-group (group &optional function) +(defun shortdoc-display-group (group &optional function same-window) "Pop to a buffer with short documentation summary for functions in GROUP. -If FUNCTION is non-nil, place point on the entry for FUNCTION (if any)." +If FUNCTION is non-nil, place point on the entry for FUNCTION (if any). +If SAME-WINDOW, don't pop to a new window." (interactive (list (completing-read "Show summary for functions in: " (mapcar #'car shortdoc--groups)))) (when (stringp group) (setq group (intern group))) (unless (assq group shortdoc--groups) (error "No such documentation group %s" group)) - (pop-to-buffer (format "*Shortdoc %s*" group)) + (funcall (if same-window + #'pop-to-buffer-same-window + #'pop-to-buffer) + (format "*Shortdoc %s*" group)) (let ((inhibit-read-only t) (prev nil)) (erase-buffer) @@ -1408,11 +1449,14 @@ function's documentation in the Info manual"))) If GROUP doesn't exist, it will be created. If SECTION doesn't exist, it will be added. +ELEM is a Lisp form. See `define-short-documentation-group' for +details. + Example: (shortdoc-add-function - 'file \"Predicates\" - '(file-locked-p :no-eval (file-locked-p \"/tmp\")))" + \\='file \"Predicates\" + \\='(file-locked-p :no-eval (file-locked-p \"/tmp\")))" (let ((glist (assq group shortdoc--groups))) (unless glist (setq glist (list group)) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 2bab1319132..61d52026b38 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1846,7 +1846,9 @@ to which that point should be aligned, if we were to reindent it.") (move-to-column fc) (syntax-ppss)))) (while - (and (with-demoted-errors "SMIE Error: %S" + ;; We silence the error completely since errors are "normal" in + ;; some cases and an error message would be annoying (bug#19342). + (and (ignore-error scan-error (save-excursion (let ((end (point)) (bsf nil) ;Best-so-far. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 7ad4e9ba2ab..9cd793d05c5 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -81,116 +81,6 @@ Note how the single `-' got converted into a list before threading." (declare (indent 0) (debug thread-first)) `(internal--thread-argument nil ,@forms)) - -(defsubst internal--listify (elt) - "Wrap ELT in a list if it is not one. -If ELT is of the form ((EXPR)), listify (EXPR) with a dummy symbol." - (cond - ((symbolp elt) (list elt elt)) - ((null (cdr elt)) - (list (make-symbol "s") (car elt))) - (t elt))) - -(defsubst internal--check-binding (binding) - "Check BINDING is properly formed." - (when (> (length binding) 2) - (signal - 'error - (cons "`let' bindings can have only one value-form" binding))) - binding) - -(defsubst internal--build-binding-value-form (binding prev-var) - "Build the conditional value form for BINDING using PREV-VAR." - (let ((var (car binding))) - `(,var (and ,prev-var ,(cadr binding))))) - -(defun internal--build-binding (binding prev-var) - "Check and build a single BINDING with PREV-VAR." - (thread-first - binding - internal--listify - internal--check-binding - (internal--build-binding-value-form prev-var))) - -(defun internal--build-bindings (bindings) - "Check and build conditional value forms for BINDINGS." - (let ((prev-var t)) - (mapcar (lambda (binding) - (let ((binding (internal--build-binding binding prev-var))) - (setq prev-var (car binding)) - binding)) - bindings))) - -(defmacro if-let* (varlist then &rest else) - "Bind variables according to VARLIST and evaluate THEN or ELSE. -This is like `if-let' but doesn't handle a VARLIST of the form -\(SYMBOL SOMETHING) specially." - (declare (indent 2) - (debug ((&rest [&or symbolp (symbolp form) (form)]) - body))) - (if varlist - `(let* ,(setq varlist (internal--build-bindings varlist)) - (if ,(caar (last varlist)) - ,then - ,@else)) - `(let* () ,then))) - -(defmacro when-let* (varlist &rest body) - "Bind variables according to VARLIST and conditionally evaluate BODY. -This is like `when-let' but doesn't handle a VARLIST of the form -\(SYMBOL SOMETHING) specially." - (declare (indent 1) (debug if-let*)) - (list 'if-let* varlist (macroexp-progn body))) - -(defmacro and-let* (varlist &rest body) - "Bind variables according to VARLIST and conditionally evaluate BODY. -Like `when-let*', except if BODY is empty and all the bindings -are non-nil, then the result is non-nil." - (declare (indent 1) (debug if-let*)) - (let (res) - (if varlist - `(let* ,(setq varlist (internal--build-bindings varlist)) - (when ,(setq res (caar (last varlist))) - ,@(or body `(,res)))) - `(let* () ,@(or body '(t)))))) - -;;;###autoload -(defmacro if-let (spec then &rest else) - "Bind variables according to SPEC and evaluate THEN or ELSE. -Evaluate each binding in turn, as in `let*', stopping if a -binding value is nil. If all are non-nil return the value of -THEN, otherwise the last form in ELSE. - -Each element of SPEC is a list (SYMBOL VALUEFORM) that binds -SYMBOL to the value of VALUEFORM. An element can additionally be -of the form (VALUEFORM), which is evaluated and checked for nil; -i.e. SYMBOL can be omitted if only the test result is of -interest. It can also be of the form SYMBOL, then the binding of -SYMBOL is checked for nil. - -As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) -like \((SYMBOL SOMETHING)). This exists for backward compatibility -with an old syntax that accepted only one binding." - (declare (indent 2) - (debug ([&or (symbolp form) ; must be first, Bug#48489 - (&rest [&or symbolp (symbolp form) (form)])] - body))) - (when (and (<= (length spec) 2) - (not (listp (car spec)))) - ;; Adjust the single binding case - (setq spec (list spec))) - (list 'if-let* spec then (macroexp-progn else))) - -;;;###autoload -(defmacro when-let (spec &rest body) - "Bind variables according to SPEC and conditionally evaluate BODY. -Evaluate each binding in turn, stopping if a binding value is nil. -If all are non-nil, return the value of the last form in BODY. - -The variable list SPEC is the same as in `if-let'." - (declare (indent 1) (debug if-let)) - (list 'if-let spec (macroexp-progn body))) - (defsubst hash-table-empty-p (hash-table) "Check whether HASH-TABLE is empty (has 0 elements)." (zerop (hash-table-count hash-table))) @@ -320,12 +210,6 @@ than this function." (end (substring string (- (length string) length))) (t (substring string 0 length))))) -;;;###autoload -(defun string-lines (string &optional omit-nulls) - "Split STRING into a list of lines. -If OMIT-NULLS, empty lines will be removed from the results." - (split-string string "\n" omit-nulls)) - (defun string-pad (string length &optional padding start) "Pad STRING to LENGTH using PADDING. If PADDING is nil, the space character is used. If not nil, it @@ -414,32 +298,6 @@ and return the value found in PLACE instead." ,(funcall setter val) ,val))))) -;;;###autoload -(defun ensure-empty-lines (&optional lines) - "Ensure that there are LINES number of empty lines before point. -If LINES is nil or omitted, ensure that there is a single empty -line before point. - -If called interactively, LINES is given by the prefix argument. - -If there are more than LINES empty lines before point, the number -of empty lines is reduced to LINES. - -If point is not at the beginning of a line, a newline character -is inserted before adjusting the number of empty lines." - (interactive "p") - (unless (bolp) - (insert "\n")) - (let ((lines (or lines 1)) - (start (save-excursion - (if (re-search-backward "[^\n]" nil t) - (+ (point) 2) - (point-min))))) - (cond - ((> (- (point) start) lines) - (delete-region (point) (- (point) (- (point) start lines)))) - ((< (- (point) start) lines) - (insert (make-string (- lines (- (point) start)) ?\n)))))) ;;;###autoload (defun string-pixel-width (string) @@ -558,6 +416,43 @@ this defaults to the current buffer." (error "No process selected")) process))) +(defmacro with-buffer-unmodified-if-unchanged (&rest body) + "Like `progn', but change buffer-modified status only if buffer text changes. +If the buffer was unmodified before execution of BODY, and +buffer text after execution of BODY is identical to what it was +before, ensure that buffer is still marked unmodified afterwards. +For example, the following won't change the buffer's modification +status: + + (with-buffer-unmodified-if-unchanged + (insert \"a\") + (delete-char -1)) + +Note that only changes in the raw byte sequence of the buffer text, +as stored in the internal representation, are monitored for the +purpose of detecting the lack of changes in buffer text. Any other +changes that are normally perceived as \"buffer modifications\", such +as changes in text properties, `buffer-file-coding-system', buffer +multibyteness, etc. -- will not be noticed, and the buffer will still +be marked unmodified, effectively ignoring those changes." + (declare (debug t) (indent 0)) + (let ((hash (gensym)) + (buffer (gensym))) + `(let ((,hash (and (not (buffer-modified-p)) + (buffer-hash))) + (,buffer (current-buffer))) + (prog1 + (progn + ,@body) + ;; If we didn't change anything in the buffer (and the buffer + ;; was previously unmodified), then flip the modification status + ;; back to "unchanged". + (when (and ,hash (buffer-live-p ,buffer)) + (with-current-buffer ,buffer + (when (and (buffer-modified-p) + (equal ,hash (buffer-hash))) + (restore-buffer-modified-p nil)))))))) + (provide 'subr-x) ;;; subr-x.el ends here diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el index 9f86a28eb64..d11980f4f45 100644 --- a/lisp/emacs-lisp/text-property-search.el +++ b/lisp/emacs-lisp/text-property-search.el @@ -47,7 +47,7 @@ match if is not `equal' to VALUE. Furthermore, a nil PREDICATE means that the match region is ended if the value changes. For instance, this means that if you loop with - (while (setq prop (text-property-search-forward 'face)) + (while (setq prop (text-property-search-forward \\='face)) ...) you will get all distinct regions with non-nil `face' values in @@ -166,7 +166,6 @@ and if a matching region is found, place point at the start of the region." (let ((origin (point)) (ended nil) pos) - (forward-char -1) ;; Find the previous candidate. (while (not ended) (setq pos (previous-single-property-change (point) property)) diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index c93a50cabfe..aef18d0ba27 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -62,7 +62,7 @@ ((numberp repeat) (propertize (format "%12s" (format-seconds - "%dd %hh %mm %z%,1ss" repeat)) + "%x%dd %hh %mm %z%,1ss" repeat)) 'help-echo "Repeat interval")) ((null repeat) (propertize " -" 'help-echo "Runs once")) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index d8577c19762..61265c97c28 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -28,6 +28,12 @@ (require 'text-property-search) (require 'mule-util) +(defface vtable + '((t :inherit variable-pitch)) + "Face used (by default) for vtables." + :version "29.1" + :group 'faces) + (cl-defstruct vtable-column "A vtable column." name @@ -55,10 +61,16 @@ (actions :initarg :actions :accessor vtable-actions) (keymap :initarg :keymap :accessor vtable-keymap) (separator-width :initarg :separator-width :accessor vtable-separator-width) + (divider :initarg :divider :accessor vtable-divider :initform nil) (sort-by :initarg :sort-by :accessor vtable-sort-by) (ellipsis :initarg :ellipsis :accessor vtable-ellipsis) - (-cache :initform (make-hash-table :test #'equal))) - "A object to hold the data for a table.") + (column-colors :initarg :column-colors :accessor vtable-column-colors) + (row-colors :initarg :row-colors :accessor vtable-row-colors) + (-cached-colors :initform nil) + (-cache :initform (make-hash-table :test #'equal)) + (-cached-keymap :initform nil) + (-has-column-spec :initform nil)) + "An object to hold the data for a table.") (defvar-keymap vtable-map "S" #'vtable-sort-by-current-column @@ -78,53 +90,84 @@ formatter displayer (use-header-line t) - (face 'variable-pitch) + (face 'vtable) actions keymap (separator-width 1) + divider + divider-width sort-by (ellipsis t) - (insert t)) + (insert t) + row-colors + column-colors) "Create and insert a vtable at point. The vtable object is returned. If INSERT is nil, the table won't -be inserted." +be inserted. + +See info node `(vtable)Top' for vtable documentation." (when objects-function (setq objects (funcall objects-function))) - ;; Auto-generate the columns. - (unless columns - (unless objects - (error "Can't auto-generate columns; no objects")) - (setf columns (make-list (length (car objects)) ""))) - (setq columns (mapcar (lambda (column) - (cond - ;; We just have the name (as a string). - ((stringp column) - (make-vtable-column :name column)) - ;; A plist of keywords/values. - ((listp column) - (apply #'make-vtable-column column)) - ;; A full `vtable-column' object. - (t - column))) - columns)) ;; We'll be altering the list, so create a copy. (setq objects (copy-sequence objects)) (let ((table - (make-instance 'vtable - :columns columns - :objects objects - :objects-function objects-function - :getter getter - :formatter formatter - :displayer displayer - :use-header-line use-header-line - :face face - :actions actions - :keymap keymap - :separator-width separator-width - :sort-by sort-by - :ellipsis ellipsis))) + (make-instance + 'vtable + :objects objects + :objects-function objects-function + :getter getter + :formatter formatter + :displayer displayer + :use-header-line use-header-line + :face face + :actions actions + :keymap keymap + :separator-width separator-width + :sort-by sort-by + :row-colors row-colors + :column-colors column-colors + :ellipsis ellipsis))) + ;; Store whether the user has specified columns or not. + (setf (slot-value table '-has-column-spec) (not (not columns))) + ;; Auto-generate the columns. + (unless columns + (unless objects + (error "Can't auto-generate columns; no objects")) + (setq columns (make-list (length (car objects)) ""))) + (setf (vtable-columns table) + (mapcar (lambda (column) + (cond + ;; We just have the name (as a string). + ((stringp column) + (make-vtable-column :name column)) + ;; A plist of keywords/values. + ((listp column) + (apply #'make-vtable-column column)) + ;; A full `vtable-column' object. + (t + column))) + columns)) ;; Compute missing column data. (setf (vtable-columns table) (vtable--compute-columns table)) + ;; Compute the colors. + (when (or row-colors column-colors) + (setf (slot-value table '-cached-colors) + (vtable--compute-colors row-colors column-colors))) + ;; Compute the divider. + (when (or divider divider-width) + (setf (vtable-divider table) + (propertize + (or (copy-sequence divider) + (propertize + " " 'display + (list 'space :width + (list (vtable--compute-width table divider-width))))) + 'mouse-face 'highlight + 'keymap + (define-keymap + "" #'vtable--drag-resize-column + "" #'ignore)))) + ;; Compute the keymap. + (setf (slot-value table '-cached-keymap) (vtable--make-keymap table)) (unless sort-by (seq-do-indexed (lambda (column index) (when (vtable-column-primary column) @@ -135,6 +178,52 @@ be inserted." (vtable-insert table)) table)) +(defun vtable--compute-colors (row-colors column-colors) + (cond + ((null column-colors) + (mapcar #'vtable--make-color-face row-colors)) + ((null row-colors) + (mapcar #'vtable--make-color-face column-colors)) + (t + (cl-loop for row in row-colors + collect (cl-loop for column in column-colors + collect (vtable--face-blend + (vtable--make-color-face row) + (vtable--make-color-face column))))))) + +(defun vtable--make-color-face (object) + (if (stringp object) + (list :background object) + object)) + +(defun vtable--face-blend (face1 face2) + (let ((foreground (vtable--face-color face1 face2 #'face-foreground + :foreground)) + (background (vtable--face-color face1 face2 #'face-background + :background))) + `(,@(and foreground (list :foreground foreground)) + ,@(and background (list :background background))))) + +(defun vtable--face-color (face1 face2 accessor slot) + (let ((col1 (if (facep face1) + (funcall accessor face1) + (plist-get face1 slot))) + (col2 (if (facep face2) + (funcall accessor face2) + (plist-get face2 slot)))) + (if (and col1 col2) + (vtable--color-blend col1 col2) + (or col1 col2)))) + +;;; FIXME: This is probably not the right way to blend two colors, is +;;; it? +(defun vtable--color-blend (color1 color2) + (cl-destructuring-bind (r g b) + (mapcar (lambda (n) (* (/ n 2) 255.0)) + (cl-mapcar #'+ (color-name-to-rgb color1) + (color-name-to-rgb color2))) + (format "#%02X%02X%02X" r g b))) + ;;; Interface utility functions. (defun vtable-current-table () @@ -210,7 +299,8 @@ If it can't be found, return nil and don't move point." (error "Can't find the old object")) (setcar (cdr objects) object)) ;; Then update the cache... - (let ((line (assq old-object (car (vtable--cache table))))) + (let* ((line-number (seq-position old-object (car (vtable--cache table)))) + (line (elt (car (vtable--cache table)) line-number))) (unless line (error "Can't find cached object")) (setcar line object) @@ -221,7 +311,8 @@ If it can't be found, return nil and don't move point." (let ((keymap (get-text-property (point) 'keymap)) (start (point))) (delete-line) - (vtable--insert-line table line (nth 1 (vtable--cache table)) + (vtable--insert-line table line line-number + (nth 1 (vtable--cache table)) (vtable--spacer table)) (add-text-properties start (point) (list 'keymap keymap 'vtable table)))) @@ -276,7 +367,10 @@ This also updates the displayed table." (unless (vtable-goto-object after-object) (vtable-end-of-table)))) (let ((start (point))) - (vtable--insert-line table line (nth 1 cache) (vtable--spacer table)) + ;; FIXME: We have to adjust colors in lines below this if we + ;; have :row-colors. + (vtable--insert-line table line 0 + (nth 1 cache) (vtable--spacer table)) (add-text-properties start (point) (list 'keymap keymap 'vtable table))) ;; We may have inserted a non-numerical value into a previously @@ -333,6 +427,16 @@ This also updates the displayed table." (defun vtable--spacer (table) (vtable--compute-width table (vtable-separator-width table))) +(defun vtable--recompute-cache (table) + (let* ((data (vtable--compute-cache table)) + (widths (vtable--compute-widths table data))) + (setf (gethash (vtable--cache-key) (slot-value table '-cache)) + (list data widths)))) + +(defun vtable--ensure-cache (table) + (or (vtable--cache table) + (vtable--recompute-cache table))) + (defun vtable-insert (table) (let* ((spacer (vtable--spacer table)) (start (point)) @@ -341,43 +445,48 @@ This also updates the displayed table." 'face (vtable-face table)) "")) (ellipsis-width (string-pixel-width ellipsis)) - data widths) - ;; We maintain a cache per screen/window width, so that we render - ;; correctly if Emacs is open on two different screens (or the - ;; user resizes the frame). - (if-let ((cache (vtable--cache table))) - (setq data (nth 0 cache) - widths (nth 1 cache)) - (setq data (vtable--compute-cache table) - widths (vtable--compute-widths table data)) - (setf (gethash (vtable--cache-key) (slot-value table '-cache)) - (list data widths))) - (if (vtable-use-header-line table) - (vtable--set-header-line table widths spacer) - ;; Insert the header line directly into the buffer, and put a - ;; keymap to be able to sort the columns there (by clicking on - ;; them). - (vtable--insert-header-line table widths spacer) - (add-text-properties start (point) - (list 'keymap vtable-header-line-map - 'rear-nonsticky t - 'vtable table)) - (setq start (point))) + ;; We maintain a cache per screen/window width, so that we render + ;; correctly if Emacs is open on two different screens (or the + ;; user resizes the frame). + (widths (nth 1 (vtable--ensure-cache table)))) + ;; Don't insert any header or header line if the user hasn't + ;; specified the columns. + (when (slot-value table '-has-column-spec) + (if (vtable-use-header-line table) + (vtable--set-header-line table widths spacer) + ;; Insert the header line directly into the buffer, and put a + ;; keymap to be able to sort the columns there (by clicking on + ;; them). + (vtable--insert-header-line table widths spacer) + (add-text-properties start (point) + (list 'keymap vtable-header-line-map + 'rear-nonsticky t + 'vtable table)) + (setq start (point)))) (vtable--sort table) ;; Insert the data. - (dolist (line (car (vtable--cache table))) - (vtable--insert-line table line widths spacer - ellipsis ellipsis-width)) + (let ((line-number 0)) + (dolist (line (car (vtable--cache table))) + (vtable--insert-line table line line-number widths spacer + ellipsis ellipsis-width) + (setq line-number (1+ line-number)))) (add-text-properties start (point) - (list 'keymap (vtable--make-keymap table) - 'rear-nonsticky t + (list 'rear-nonsticky t 'vtable table)) (goto-char start))) -(defun vtable--insert-line (table line widths spacer +(defun vtable--insert-line (table line line-number widths spacer &optional ellipsis ellipsis-width) (let ((start (point)) - (columns (vtable-columns table))) + (columns (vtable-columns table)) + (column-colors + (and (vtable-column-colors table) + (if (vtable-row-colors table) + (elt (slot-value table '-cached-colors) + (mod line-number (length (vtable-row-colors table)))) + (slot-value table '-cached-colors)))) + (divider (vtable-divider table)) + (keymap (slot-value table '-cached-keymap))) (seq-do-indexed (lambda (elem index) (let ((value (nth 0 elem)) @@ -418,30 +527,47 @@ This also updates the displayed table." value (- (elt widths index) ellipsis-width)) ellipsis) value)))) - (start (point))) + (start (point)) + ;; Don't insert the separator after the final column. + (last (= index (- (length line) 2)))) (if (eq (vtable-column-align column) 'left) - (insert displayed - (propertize - " " 'display - (list 'space - :width (list - (+ (- (elt widths index) - (string-pixel-width displayed)) - spacer))))) + (progn + (insert displayed) + (insert (propertize + " " 'display + (list 'space + :width (list + (+ (- (elt widths index) + (string-pixel-width displayed)) + (if last 0 spacer))))))) ;; Align to the right. (insert (propertize " " 'display (list 'space :width (list (- (elt widths index) (string-pixel-width displayed))))) - displayed - (propertize " " 'display - (list 'space - :width (list spacer))))) - (put-text-property start (point) 'vtable-column index)))) + displayed) + (unless last + (insert (propertize " " 'display + (list 'space + :width (list spacer)))))) + (put-text-property start (point) 'vtable-column index) + (put-text-property start (point) 'keymap keymap) + (when column-colors + (add-face-text-property + start (point) + (elt column-colors (mod index (length column-colors))))) + (when divider + (insert divider) + (setq start (point)))))) (cdr line)) (insert "\n") - (put-text-property start (point) 'vtable-object (car line)))) + (put-text-property start (point) 'vtable-object (car line)) + (unless column-colors + (when-let ((row-colors (slot-value table '-cached-colors))) + (add-face-text-property + start (point) + (elt row-colors (mod line-number (length row-colors)))))))) (defun vtable--cache-key () (cons (frame-terminal) (window-width))) @@ -456,22 +582,26 @@ This also updates the displayed table." (pcase-dolist (`(,index . ,direction) (vtable-sort-by table)) (let ((cache (vtable--cache table)) (numerical (vtable-column--numerical - (elt (vtable-columns table) index)))) + (elt (vtable-columns table) index))) + (numcomp (if (eq direction 'descend) + #'> #'<)) + (stringcomp (if (eq direction 'descend) + #'string> #'string<))) (setcar cache (sort (car cache) (lambda (e1 e2) (let ((c1 (elt e1 (1+ index))) (c2 (elt e2 (1+ index)))) (if numerical - (< (car c1) (car c2)) - (string< (if (stringp (car c1)) - (car c1) - (format "%s" (car c1))) - (if (stringp (car c2)) - (car c2) - (format "%s" (car c2))))))))) - (when (eq direction 'descend) - (setcar cache (nreverse (car cache))))))) + (funcall numcomp (car c1) (car c2)) + (funcall + stringcomp + (if (stringp (car c1)) + (car c1) + (format "%s" (car c1))) + (if (stringp (car c2)) + (car c2) + (format "%s" (car c2)))))))))))) (defun vtable--indicator (table index) (let ((order (car (last (vtable-sort-by table))))) @@ -489,35 +619,112 @@ This also updates the displayed table." (defun vtable--insert-header-line (table widths spacer) ;; Insert the header directly into the buffer. - (let* ((start (point))) + (let ((start (point)) + (divider (vtable-divider table)) + (cmap (define-keymap + " " #'vtable--drag-resize-column + " " #'ignore)) + (dmap (define-keymap + " " + (lambda (e) + (interactive "e") + (vtable--drag-resize-column e t)) + " " #'ignore))) (seq-do-indexed (lambda (column index) (let* ((name (propertize (vtable-column-name column) - 'face (list 'header-line (vtable-face table)))) + 'face (list 'header-line (vtable-face table)) + 'mouse-face 'header-line-highlight + 'keymap cmap)) (start (point)) (indicator (vtable--indicator table index)) (indicator-width (string-pixel-width indicator)) + (last (= index (1- (length (vtable-columns table))))) displayed) - (insert - (setq displayed - (concat - (if (> (string-pixel-width name) - (- (elt widths index) indicator-width)) - (vtable--limit-string - name (- (elt widths index) indicator-width)) - name) - indicator)) - (propertize " " 'display - (list 'space :width - (list (+ (- (elt widths index) - (string-pixel-width displayed)) - spacer))))) + (setq displayed + (if (> (string-pixel-width name) + (- (elt widths index) indicator-width)) + (vtable--limit-string + name (- (elt widths index) indicator-width)) + name)) + (let ((fill-width + (+ (- (elt widths index) + (string-pixel-width displayed) + indicator-width + (vtable-separator-width table) + ;; We want the indicator to not be quite flush + ;; right. + (/ (vtable--char-width table) 2.0)) + (if last 0 spacer)))) + (if (or (not last) + (zerop indicator-width) + (< (seq-reduce #'+ widths 0) (window-width nil t))) + ;; Normal case. + (insert + displayed + (propertize " " 'display + (list 'space :width (list fill-width))) + indicator) + ;; This is the final column, and we have a sorting + ;; indicator, and the table is too wide for the window. + (let* ((pre-indicator (string-pixel-width + (buffer-substring (point-min) (point)))) + (pre-fill + (- (window-width nil t) + pre-indicator + (string-pixel-width displayed)))) + (insert + displayed + (propertize " " 'display + (list 'space :width (list pre-fill))) + indicator + (propertize " " 'display + (list 'space :width + (list (- fill-width pre-fill)))))))) + (when (and divider (not last)) + (insert (propertize divider 'keymap dmap))) + (insert (propertize + " " 'display + (list 'space :width (list + (/ (vtable--char-width table) 2.0))))) (put-text-property start (point) 'vtable-column index))) (vtable-columns table)) (insert "\n") (add-face-text-property start (point) 'header-line))) +(defun vtable--drag-resize-column (e &optional next) + "Resize the column by dragging. +If NEXT, do the next column." + (interactive "e") + (let* ((pos-start (event-start e)) + (obj (posn-object pos-start))) + (with-current-buffer (window-buffer (posn-window pos-start)) + (let ((column + ;; In the header line we have a text property on the + ;; divider. + (or (get-text-property (if obj (cdr obj) + (posn-point pos-start)) + 'vtable-column + (car obj)) + ;; For reasons of efficiency, we don't have that in + ;; the buffer itself, so find the column. + (save-excursion + (goto-char (posn-point pos-start)) + (1+ + (get-text-property + (prop-match-beginning + (text-property-search-backward 'vtable-column)) + 'vtable-column))))) + (start-x (car (posn-x-y pos-start))) + (end-x (car (posn-x-y (event-end e))))) + (when (or (> column 0) next) + (vtable--alter-column-width (vtable-current-table) + (if next + column + (1- column)) + (- end-x start-x))))))) + (defun vtable--recompute-numerical (table line) "Recompute numericalness of columns if necessary." (let ((columns (vtable-columns table)) @@ -661,7 +868,7 @@ This also updates the displayed table." (vtable-goto-column column)))) (defun vtable--widths (table) - (nth 1 (vtable--cache table))) + (nth 1 (vtable--ensure-cache table))) ;;; Commands. @@ -673,25 +880,36 @@ This also updates the displayed table." "Minor mode for buffers with vtables with headers." :keymap vtable-header-mode-map) -(defun vtable-narrow-current-column () - "Narrow the current column." - (interactive) +(defun vtable-narrow-current-column (&optional n) + "Narrow the current column by N characters. +If N isn't given, N defaults to 1. + +Interactively, N is the prefix argument." + (interactive "p") (let* ((table (vtable-current-table)) - (column (vtable-current-column)) - (widths (vtable--widths table))) + (column (vtable-current-column))) + (unless column + (user-error "No column under point")) + (vtable--alter-column-width table column + (- (* (vtable--char-width table) (or n 1)))))) + +(defun vtable--alter-column-width (table column delta) + (let ((widths (vtable--widths table))) (setf (aref widths column) (max (* (vtable--char-width table) 2) - (- (aref widths column) (vtable--char-width table)))) + (+ (aref widths column) delta))) + ;; Store the width so it'll be respected on a revert. + (setf (vtable-column-width (elt (vtable-columns table) column)) + (format "%dpx" (aref widths column))) (vtable-revert))) -(defun vtable-widen-current-column () - "Widen the current column." - (interactive) - (let* ((table (vtable-current-table)) - (column (vtable-current-column)) - (widths (nth 1 (vtable--cache table)))) - (cl-incf (aref widths column) (vtable--char-width table)) - (vtable-revert))) +(defun vtable-widen-current-column (&optional n) + "Widen the current column by N characters. +If N isn't given, N defaults to 1. + +Interactively, N is the prefix argument." + (interactive "p") + (vtable-narrow-current-column (- n))) (defun vtable-previous-column () "Go to the previous column." diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index e399fd0fbf3..a7f3d5fe14c 100644 --- a/lisp/emulation/cua-rect.el +++ b/lisp/emulation/cua-rect.el @@ -572,7 +572,7 @@ Only call fct for visible lines if VISIBLE==t. Set undo boundary if UNDO is non-nil. Rectangle is padded if PAD = t or numeric and (cua--rectangle-virtual-edges) Perform auto-tabify after operation if TABIFY is non-nil. -Mark is kept if keep-clear is 'keep and cleared if keep-clear is 'clear." +Mark is kept if keep-clear is `keep' and cleared if keep-clear is `clear'." (declare (indent 4)) (let* ((inhibit-field-text-motion t) (start (cua--rectangle-top)) diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index 83944285e91..ddb49609d40 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -1783,7 +1783,7 @@ Undo previous insertion and inserts new." (do-not-change-default t)) (setq quote-str (viper-read-string-with-history - "Quote string" + "Quote string: " nil 'viper-quote-region-history ;; FIXME: Use comment-region. @@ -1992,17 +1992,24 @@ problems." #'viper-minibuffer-standard-hook (if (or (not (listp old)) (eq (car old) 'lambda)) (list old) old)))) - (val "")) + (val "") + (padding "") + temp-msg) (setq keymap (or keymap minibuffer-local-map) initial (or initial "") - viper-initial initial) + viper-initial initial + temp-msg (if default + (format "(default %s) " default) + "")) (setq viper-incomplete-ex-cmd nil) - (setq val (read-from-minibuffer (format-prompt prompt default) - nil - keymap nil history-var default)) - (setq minibuffer-setup-hook nil) + (setq val (read-from-minibuffer prompt + (concat temp-msg initial val padding) + keymap nil history-var)) + (setq minibuffer-setup-hook nil + padding (viper-array-to-string (this-command-keys)) + temp-msg "") ;; the following tries to be smart about what to put in history (if (not (string= val (car (symbol-value history-var)))) (push val (symbol-value history-var))) @@ -3815,7 +3822,7 @@ Null string will repeat previous search." (let (buffer buffer-name) (setq buffer-name (funcall viper-read-buffer-function - (format-prompt "Kill buffer" + (format "Kill buffer (%s): " (buffer-name (current-buffer))))) (setq buffer (if (null buffer-name) @@ -4157,12 +4164,17 @@ cursor move past the beginning of line." "Query replace. If a null string is supplied as the string to be replaced, the query replace mode will toggle between string replace -and regexp replace." +and regexp replace. + +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time." (interactive) (let (str) (setq str (viper-read-string-with-history - (if viper-re-query-replace "Query replace regexp" - "Query replace") + (if viper-re-query-replace "Query replace regexp: " + "Query replace: ") nil ; no initial 'viper-replace1-history (car viper-replace1-history) ; default @@ -4177,7 +4189,7 @@ and regexp replace." (query-replace-regexp str (viper-read-string-with-history - (format-message "Query replace regexp `%s' with" str) + (format-message "Query replace regexp `%s' with: " str) nil ; no initial 'viper-replace1-history (car viper-replace1-history) ; default @@ -4185,7 +4197,7 @@ and regexp replace." (query-replace str (viper-read-string-with-history - (format-message "Query replace `%s' with" str) + (format-message "Query replace `%s' with: " str) nil ; no initial 'viper-replace1-history (car viper-replace1-history) ; default diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el index 7581ece2142..1a90cab7674 100644 --- a/lisp/emulation/viper-mous.el +++ b/lisp/emulation/viper-mous.el @@ -62,8 +62,8 @@ or a triple-click." ;; time interval in millisecond within which successive clicks are ;; considered related (defcustom viper-multiclick-timeout (if (viper-window-display-p) - double-click-time - 500) + (mouse-double-click-time) + 500) "Time interval in milliseconds for mouse clicks to be considered related." :type 'integer) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 398fe6cc9e7..4b21711da42 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -464,7 +464,7 @@ If POS is out of range, the value is nil." (defun erc-bounds-of-word-at-point () "Return the bounds of word at point, or nil if we're not at a word. If no `subword-mode' is active, then this is -\(bounds-of-thing-at-point 'word)." +\(bounds-of-thing-at-point \\='word)." (if (or (erc-word-at-arg-p (point)) (erc-word-at-arg-p (1- (point)))) (save-excursion diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index cc4143bfa23..59bfd246036 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -768,7 +768,7 @@ the matching regexp, or nil if none found." PROC is the process-object of the DCC connection. Returns the number of bytes sent." (let* ((elt (erc-dcc-member :peer proc)) - (confirmed-marker (plist-get elt :sent)) + (confirmed-marker (plist-get elt :confirmed)) (sent-marker (plist-get elt :sent))) (with-current-buffer (process-buffer proc) (when erc-dcc-verbose diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 9ee8d38b026..06381c5ebee 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1761,12 +1761,7 @@ nil." (lambda (bufname) (let ((buf (if (consp bufname) (cdr bufname) (get-buffer bufname)))) - (when buf - (erc--buffer-p buf (lambda () t) proc) - (with-current-buffer buf - (and (derived-mode-p 'erc-mode) - (or (null proc) - (eq proc erc-server-process)))))))))) + (and buf (erc--buffer-p buf (lambda () t) proc))))))) (defun erc-switch-to-buffer (&optional arg) "Prompt for an ERC buffer to switch to. When invoked with prefix argument, use all ERC buffers. Without @@ -2274,7 +2269,7 @@ Example usage: (erc-tls :server \"irc.libera.chat\" :port 6697 :client-certificate - '(\"/home/bandali/my-cert.key\" + \\='(\"/home/bandali/my-cert.key\" \"/home/bandali/my-cert.crt\"))" (interactive (let ((erc-default-port erc-default-port-tls)) (erc-select-read-args))) diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el index ba868cee59e..448b6787ee7 100644 --- a/lisp/eshell/em-basic.el +++ b/lisp/eshell/em-basic.el @@ -155,39 +155,37 @@ or `eshell-printn' for display." "umask" args '((?S "symbolic" nil symbolic-p "display umask symbolically") (?h "help" nil nil "display this usage message") + :preserve-args :usage "[-S] [mode]") - (if (or (not args) symbolic-p) - (let ((modstr - (concat "000" - (format "%o" - (logand (lognot (default-file-modes)) - 511))))) - (setq modstr (substring modstr (- (length modstr) 3))) - (when symbolic-p - (let ((mode (default-file-modes))) - (setq modstr - (format - "u=%s,g=%s,o=%s" - (concat (and (= (logand mode 64) 64) "r") - (and (= (logand mode 128) 128) "w") - (and (= (logand mode 256) 256) "x")) - (concat (and (= (logand mode 8) 8) "r") - (and (= (logand mode 16) 16) "w") - (and (= (logand mode 32) 32) "x")) - (concat (and (= (logand mode 1) 1) "r") - (and (= (logand mode 2) 2) "w") - (and (= (logand mode 4) 4) "x")))))) - (eshell-printn modstr)) - (setcar args (eshell-convert (car args))) - (if (numberp (car args)) - (set-default-file-modes - (- 511 (car (read-from-string - (concat "?\\" (number-to-string (car args))))))) - (error "Setting umask symbolically is not yet implemented")) + (cond + (symbolic-p + (let ((mode (default-file-modes))) + (eshell-printn + (format "u=%s,g=%s,o=%s" + (concat (and (= (logand mode 64) 64) "r") + (and (= (logand mode 128) 128) "w") + (and (= (logand mode 256) 256) "x")) + (concat (and (= (logand mode 8) 8) "r") + (and (= (logand mode 16) 16) "w") + (and (= (logand mode 32) 32) "x")) + (concat (and (= (logand mode 1) 1) "r") + (and (= (logand mode 2) 2) "w") + (and (= (logand mode 4) 4) "x")))))) + ((not args) + (eshell-printn (format "%03o" (logand (lognot (default-file-modes)) + #o777)))) + (t + (when (stringp (car args)) + (if (string-match "^[0-7]+$" (car args)) + (setcar args (string-to-number (car args) 8)) + (error "Setting umask symbolically is not yet implemented"))) + (set-default-file-modes (- #o777 (car args))) (eshell-print - "Warning: umask changed for all new files created by Emacs.\n")) + "Warning: umask changed for all new files created by Emacs.\n"))) nil)) +(put 'eshell/umask 'eshell-no-numeric-conversions t) + (provide 'em-basic) ;; Local Variables: diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index b79475f6e07..f4c1302629b 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -311,18 +311,24 @@ to writing a completion function." (describe-prefix-bindings) (call-interactively 'pcomplete-help))) +(defun eshell--pcomplete-insert-tab () + (if (not pcomplete-allow-modifications) + (throw 'pcompleted nil) + (insert-and-inherit "\t") + (throw 'pcompleted t))) + (defun eshell-complete-parse-arguments () "Parse the command line arguments for `pcomplete-argument'." (when (and eshell-no-completion-during-jobs (eshell-interactive-process-p)) - (insert-and-inherit "\t") - (throw 'pcompleted t)) + (eshell--pcomplete-insert-tab)) (let ((end (point-marker)) (begin (save-excursion (eshell-bol) (point))) (posns (list t)) args delim) - (when (memq this-command '(pcomplete-expand - pcomplete-expand-and-complete)) + (when (and pcomplete-allow-modifications + (memq this-command '(pcomplete-expand + pcomplete-expand-and-complete))) (run-hook-with-args 'eshell-expand-input-functions begin end) (if (= begin end) (end-of-line)) @@ -335,14 +341,11 @@ to writing a completion function." (setq begin (1+ (cadr delim)) args (eshell-parse-arguments begin end))) ((eq (car delim) ?\() - (eshell-complete-lisp-symbol) - (throw 'pcompleted t)) + (throw 'pcompleted (elisp-completion-at-point))) (t - (insert-and-inherit "\t") - (throw 'pcompleted t)))) + (eshell--pcomplete-insert-tab)))) (when (get-text-property (1- end) 'comment) - (insert-and-inherit "\t") - (throw 'pcompleted t)) + (eshell--pcomplete-insert-tab)) (let ((pos begin)) (while (< pos end) (if (get-text-property pos 'arg-begin) diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 3998026d7f4..5396044d8ca 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -313,7 +313,7 @@ With the following piece of advice, you can make this functionality available in most of Emacs, with the exception of filename completion in the minibuffer: - (advice-add 'expand-file-name :around #'my-expand-multiple-dots) + (advice-add \\='expand-file-name :around #\\='my-expand-multiple-dots) (defun my-expand-multiple-dots (orig-fun filename &rest args) (apply orig-fun (eshell-expand-multiple-dots filename) args))" (while (string-match "\\(?:\\`\\|/\\)\\.\\.\\(\\.+\\)\\(?:\\'\\|/\\)" diff --git a/lisp/eshell/em-elecslash.el b/lisp/eshell/em-elecslash.el new file mode 100644 index 00000000000..091acb9a861 --- /dev/null +++ b/lisp/eshell/em-elecslash.el @@ -0,0 +1,120 @@ +;;; em-elecslash.el --- electric forward slashes -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Sean Whitton + +;; 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 . + +;;; Commentary: + +;; Electric forward slash in remote Eshells. + +;;; Code: + +(require 'tramp) +(require 'thingatpt) +(require 'esh-cmd) +(require 'esh-ext) +(require 'esh-mode) + +;; This makes us an option when customizing `eshell-modules-list'. +;;;###autoload +(progn +(defgroup eshell-elecslash nil + "Electric forward slash in remote Eshells. + +This module helps with supplying absolute file name arguments to +remote commands. After enabling it, typing a forward slash as +the first character of a command line argument will automatically +insert the Tramp prefix, /method:host:. The automatic insertion +applies only when `default-directory' is remote and the command +is a Lisp function. + +The result is that in most cases of supplying absolute file name +arguments to commands you should see the Tramp prefix inserted +automatically only when that's what you'd reasonably expect. +This frees you from having to keep track of whether commands are +Lisp functions or external when typing command line arguments." + :tag "Electric forward slash" + :group 'eshell-module)) + +;;; Functions: + +(defun eshell-elecslash-initialize () ;Called from `eshell-mode' via intern-soft! + "Initialize remote Eshell electric forward slash support." + (add-hook 'post-self-insert-hook + #'eshell-electric-forward-slash nil t)) + +(defun eshell-electric-forward-slash () + "Implementation of electric forward slash in remote Eshells. + +Initializing the `eshell-elecslash' module adds this function to +`post-self-insert-hook'. Typing / or ~/ as the first character +of a command line argument automatically inserts the Tramp prefix +in the case that `default-directory' is remote and the command is +a Lisp function. Typing a second forward slash undoes the +insertion." + (when (eq ?/ (char-before)) + (delete-char -1) + (let ((tilde-before (eq ?~ (char-before))) + (command (save-excursion + (eshell-bol) + (skip-syntax-forward " ") + (thing-at-point 'sexp)))) + (if (and (file-remote-p default-directory) + ;; We can't formally parse the input. But if there is + ;; one of these operators behind us, then looking at + ;; the first command would not be sensible. So be + ;; conservative: don't insert the Tramp prefix if there + ;; are any of these operators behind us. + (not (looking-back (regexp-opt '("&&" "|" ";")) + eshell-last-output-end)) + (or (= (point) eshell-last-output-end) + (and tilde-before + (= (1- (point)) eshell-last-output-end)) + (and (or tilde-before + (eq ?\s (char-syntax (char-before)))) + (or (eshell-find-alias-function command) + (and (fboundp (intern-soft command)) + (or eshell-prefer-lisp-functions + (not (eshell-search-path command)))))))) + (let ((map (make-sparse-keymap)) + (start (if tilde-before (1- (point)) (point))) + (localname + (tramp-file-name-localname + (tramp-dissect-file-name default-directory)))) + (when tilde-before (delete-char -1)) + (insert + (substring default-directory 0 + (string-search localname default-directory))) + (unless tilde-before (insert "/")) + ;; Typing a second slash undoes the insertion, for when + ;; you really do want to type a local absolute file name. + (define-key map "/" (lambda () + (interactive) + (delete-region start (point)) + (insert (if tilde-before "~/" "/")))) + (set-transient-map map)) + (insert "/"))))) + +(provide 'em-elecslash) + +;; Local Variables: +;; generated-autoload-file: "esh-groups.el" +;; End: + +;;; esh-elecslash.el ends here diff --git a/lisp/eshell/em-extpipe.el b/lisp/eshell/em-extpipe.el index eb5b3bfe1df..3db1dea5955 100644 --- a/lisp/eshell/em-extpipe.el +++ b/lisp/eshell/em-extpipe.el @@ -49,6 +49,19 @@ (add-hook 'eshell-pre-rewrite-command-hook #'eshell-rewrite-external-pipeline -20 t)) +(defmacro em-extpipe--or-with-catch (&rest disjuncts) + "Evaluate DISJUNCTS like `or' but catch `eshell-incomplete'. + +If `eshell-incomplete' is thrown during the evaluation of a +disjunct, that disjunct yields nil." + (let ((result (gensym))) + `(let (,result) + (or ,@(cl-loop for disjunct in disjuncts collect + `(if (catch 'eshell-incomplete + (ignore (setq ,result ,disjunct))) + nil + ,result)))))) + (defun eshell-parse-external-pipeline () "Parse a pipeline intended for execution by the external shell. @@ -105,10 +118,11 @@ as though it were Eshell syntax." (if (re-search-forward pat next t) (throw 'found (match-beginning 1)) (goto-char next) - (while (or (eshell-parse-lisp-argument) - (eshell-parse-backslash) - (eshell-parse-double-quote) - (eshell-parse-literal-quote))) + (while (em-extpipe--or-with-catch + (eshell-parse-lisp-argument) + (eshell-parse-backslash) + (eshell-parse-double-quote) + (eshell-parse-literal-quote))) ;; Guard against an infinite loop if none of ;; the parsers moved us forward. (unless (or (> (point) next) (eobp)) diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 842f27a4920..52531ff8939 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -233,7 +233,10 @@ resulting regular expression." "\\'"))) (defun eshell-extended-glob (glob) - "Return a list of files generated from GLOB, perhaps looking for DIRS-ONLY. + "Return a list of files matched by GLOB. +If no files match, signal an error (if `eshell-error-if-no-glob' +is non-nil), or otherwise return GLOB itself. + This function almost fully supports zsh style filename generation syntax. Things that are not supported are: @@ -243,12 +246,7 @@ syntax. Things that are not supported are: foo~x(a|b) (a|b) will be interpreted as a predicate/modifier list Mainly they are not supported because file matching is done with Emacs -regular expressions, and these cannot support the above constructs. - -If this routine fails, it returns nil. Otherwise, it returns a list -the form: - - (INCLUDE-REGEXP EXCLUDE-REGEXP (PRED-FUNC-LIST) (MOD-FUNC-LIST))" +regular expressions, and these cannot support the above constructs." (let ((paths (eshell-split-path glob)) eshell-glob-matches message-shown) (unwind-protect @@ -287,7 +285,7 @@ the form: glob (car globs) len (length glob))))) (if (and recurse-p (not glob)) - (error "`**' cannot end a globbing pattern")) + (error "`**/' cannot end a globbing pattern")) (let ((index 1)) (setq incl glob) (while (and (eq incl glob) diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index 16abf044899..a18127a547a 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -341,7 +341,7 @@ unless a different file is specified on the command line.") (error "No history")) (let (length file) (when (and args (string-match "^[0-9]+$" (car args))) - (setq length (min (eshell-convert (car args)) + (setq length (min (string-to-number (car args)) (ring-length eshell-history-ring)) args (cdr args))) (and length diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index 846f3d5e290..874591d2501 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -100,15 +100,14 @@ faster and conserves more memory." :type 'boolean) (defface eshell-ls-directory - '((((class color) (background light)) (:foreground "Blue" :weight bold)) - (((class color) (background dark)) (:foreground "SkyBlue" :weight bold)) - (t (:weight bold))) - "The face used for highlighting directories.") + '((t (:inherit font-lock-function-name-face))) + "The face used for highlighting directories." + :version "29.1") (defface eshell-ls-symlink - '((((class color) (background light)) (:foreground "Dark Cyan" :weight bold)) - (((class color) (background dark)) (:foreground "Cyan" :weight bold))) - "The face used for highlighting symbolic links.") + '((t (:inherit font-lock-keyword-face))) + "The face used for highlighting symbolic links." + :version "29.1") (defface eshell-ls-executable '((((class color) (background light)) (:foreground "ForestGreen" :weight bold)) diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index 216c71f59e4..d73976d3464 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -68,7 +68,7 @@ ordinary strings." (defcustom eshell-predicate-alist '((?/ . (eshell-pred-file-type ?d)) ; directories (?. . (eshell-pred-file-type ?-)) ; regular files - (?s . (eshell-pred-file-type ?s)) ; sockets + (?= . (eshell-pred-file-type ?s)) ; sockets (?p . (eshell-pred-file-type ?p)) ; named pipes (?@ . (eshell-pred-file-type ?l)) ; symbolic links (?% . (eshell-pred-file-type ?%)) ; allow user to specify (c def.) @@ -88,17 +88,17 @@ ordinary strings." (if (file-exists-p file) (= (file-attribute-user-id (file-attributes file)) (user-uid))))) - ;; (?G . (lambda (file) ; owned by effective gid - ;; (if (file-exists-p file) - ;; (= (file-attribute-user-id (file-attributes file)) - ;; (user-uid))))) + (?G . (lambda (file) ; owned by effective gid + (if (file-exists-p file) + (= (file-attribute-group-id (file-attributes file)) + (group-gid))))) (?* . (lambda (file) (and (file-regular-p file) (not (file-symlink-p file)) (file-executable-p file)))) (?l . (eshell-pred-file-links)) - (?u . (eshell-pred-user-or-group ?u "user" 2 'eshell-user-id)) - (?g . (eshell-pred-user-or-group ?g "group" 3 'eshell-group-id)) + (?u . (eshell-pred-user-or-group ?u "user" 2 #'eshell-user-id)) + (?g . (eshell-pred-user-or-group ?g "group" 3 #'eshell-group-id)) (?a . (eshell-pred-file-time ?a "access" 4)) (?m . (eshell-pred-file-time ?m "modification" 5)) (?c . (eshell-pred-file-time ?c "change" 6)) @@ -111,28 +111,23 @@ The format of each entry is :risky t) (defcustom eshell-modifier-alist - '((?E . (lambda (lst) - (mapcar - (lambda (str) - (eshell-stringify - (car (eshell-parse-argument str)))) - lst))) + '((?E . (lambda (lst) (mapcar #'eshell-eval-argument lst))) (?L . (lambda (lst) (mapcar #'downcase lst))) (?U . (lambda (lst) (mapcar #'upcase lst))) (?C . (lambda (lst) (mapcar #'capitalize lst))) (?h . (lambda (lst) (mapcar #'file-name-directory lst))) - (?i . (eshell-include-members)) - (?x . (eshell-include-members t)) + (?i . (eshell-include-members ?i)) + (?x . (eshell-include-members ?x t)) (?r . (lambda (lst) (mapcar #'file-name-sans-extension lst))) (?e . (lambda (lst) (mapcar #'file-name-extension lst))) (?t . (lambda (lst) (mapcar #'file-name-nondirectory lst))) (?q . (lambda (lst) (mapcar #'eshell-escape-arg lst))) (?u . (lambda (lst) (seq-uniq lst))) (?o . (lambda (lst) (sort lst #'string-lessp))) - (?O . (lambda (lst) (nreverse (sort lst #'string-lessp)))) + (?O . (lambda (lst) (sort lst #'string-greaterp))) (?j . (eshell-join-members)) (?S . (eshell-split-members)) - (?R . 'reverse) + (?R . #'reverse) (?g . (progn (forward-char) (if (eq (char-before) ?s) @@ -142,7 +137,7 @@ The format of each entry is "A list of modifiers than can be applied to an argument expansion. The format of each entry is - (CHAR ENTRYWISE-P MODIFIER-FUNC-SEXP)" + (CHAR . MODIFIER-FUNC-SEXP)" :type '(repeat (cons character sexp)) :risky t) @@ -166,6 +161,7 @@ PERMISSION BITS (for owner/group/world): OWNERSHIP: U owned by effective uid + G owned by effective gid u(UID|\\='user\\=') owned by UID/user g(GID|\\='group\\=') owned by GID/group @@ -217,12 +213,26 @@ FOR LISTS OF ARGUMENTS: i/PAT/ exclude all members not matching PAT x/PAT/ exclude all members matching PAT - s/pat/match/ substitute PAT with MATCH - g/pat/match/ substitute PAT with MATCH for all occurrences + s/pat/match/ substitute PAT with MATCH + gs/pat/match/ substitute PAT with MATCH for all occurrences EXAMPLES: *.c(:o) sorted list of .c files") +(defvar eshell-pred-delimiter-pairs + '((?\( . ?\)) + (?\[ . ?\]) + (?\< . ?\>) + (?\{ . ?\}) + (?\' . ?\') + (?\" . ?\") + (?/ . ?/) + (?| . ?|)) + "A list of delimiter pairs that can be used in argument predicates/modifiers. +Each element is of the form (OPEN . CLOSE), where OPEN and CLOSE +are characters representing the opening and closing delimiter, +respectively.") + (defvar-keymap eshell-pred-mode-map "C-c M-q" #'eshell-display-predicate-help "C-c M-m" #'eshell-display-modifier-help) @@ -360,46 +370,78 @@ resultant list of strings." (defun eshell-add-pred-func (pred funcs negate follow) "Add the predicate function PRED to FUNCS." - (if negate - (setq pred (lambda (file) - (not (funcall pred file))))) - (if follow - (setq pred (lambda (file) - (funcall pred (file-truename file))))) + (when negate + (setq pred (let ((pred pred)) + (lambda (file) (not (funcall pred file)))))) + (when follow + (setq pred (let ((pred pred)) + (lambda (file) (funcall pred (file-truename file)))))) (cons pred funcs)) +(defun eshell-get-comparison-modifier-argument (&optional functions) + "Starting at point, get the comparison modifier argument, if any. +These are the -/+ characters, corresponding to `<' and `>', +respectively. If no comparison modifier is at point, return `='. + +FUNCTIONS, if non-nil, is a list of comparison functions, +specified as (LESS-THAN GREATER-THAN EQUAL-TO)." + (let ((functions (or functions (list #'< #'> #'=)))) + (if (memq (char-after) '(?- ?+)) + (prog1 + (if (eq (char-after) ?-) (nth 0 functions) (nth 1 functions)) + (forward-char)) + (nth 2 functions)))) + +(defun eshell-get-numeric-modifier-argument () + "Starting at point, get the numeric modifier argument, if any. +If a number is found, update point to just after the number." + (when (looking-at "[0-9]+") + (prog1 + (string-to-number (match-string 0)) + (goto-char (match-end 0))))) + +(defun eshell-get-delimited-modifier-argument (&optional chained-p) + "Starting at point, get the delimited modifier argument, if any. +If the character after point is a predicate/modifier +delimiter (see `eshell-pred-delimiter-pairs', read the value of +the argument and update point to be just after the closing +delimiter. + +If CHAINED-P is true, then another delimited modifier argument +will immediately follow this one. In this case, when the opening +and closing delimiters are the same, update point to be just +before the closing delimiter. This allows modifiers like +`:s/match/repl' to work as expected." + (when-let* ((open (char-after)) + (close (cdr (assoc open eshell-pred-delimiter-pairs))) + (end (eshell-find-delimiter open close nil nil t))) + (prog1 + (replace-regexp-in-string + (rx-to-string `(seq "\\" (group (or "\\" ,open ,close)))) "\\1" + (buffer-substring-no-properties (1+ (point)) end)) + (goto-char (if (and chained-p (eq open close)) + end + (1+ end)))))) + (defun eshell-pred-user-or-group (mod-char mod-type attr-index get-id-func) "Return a predicate to test whether a file match a given user/group id." - (let (ugid open close end) - (if (looking-at "[0-9]+") - (progn - (setq ugid (string-to-number (match-string 0))) - (goto-char (match-end 0))) - (setq open (char-after)) - (if (setq close (memq open '(?\( ?\[ ?\< ?\{))) - (setq close (car (last '(?\) ?\] ?\> ?\}) - (length close)))) - (setq close open)) - (forward-char) - (setq end (eshell-find-delimiter open close)) - (unless end - (error "Malformed %s name string for modifier `%c'" - mod-type mod-char)) - (setq ugid - (funcall get-id-func (buffer-substring (point) end))) - (goto-char (1+ end))) + (let ((ugid (eshell-get-numeric-modifier-argument))) + (unless ugid + (let ((ugname (or (eshell-get-delimited-modifier-argument) + (error "Malformed %s name string for modifier `%c'" + mod-type mod-char)))) + (setq ugid (funcall get-id-func ugname)))) (unless ugid (error "Unknown %s name specified for modifier `%c'" mod-type mod-char)) (lambda (file) - (let ((attrs (file-attributes file))) - (if attrs - (= (nth attr-index attrs) ugid)))))) + (when-let ((attrs (file-attributes file))) + (= (nth attr-index attrs) ugid))))) (defun eshell-pred-file-time (mod-char mod-type attr-index) "Return a predicate to test whether a file matches a certain time." (let* ((quantum 86400) - qual when open close end) + qual when) (when (memq (char-after) '(?M ?w ?h ?m ?s)) (setq quantum (char-after)) (cond @@ -414,36 +456,21 @@ resultant list of strings." ((eq quantum ?s) (setq quantum 1))) (forward-char)) - (when (memq (char-after) '(?+ ?-)) - (setq qual (char-after)) - (forward-char)) - (if (looking-at "[0-9]+") - (progn - (setq when (time-since (* (string-to-number (match-string 0)) - quantum))) - (goto-char (match-end 0))) - (setq open (char-after)) - (if (setq close (memq open '(?\( ?\[ ?\< ?\{))) - (setq close (car (last '(?\) ?\] ?\> ?\}) - (length close)))) - (setq close open)) - (forward-char) - (setq end (eshell-find-delimiter open close)) - (unless end - (error "Malformed %s time modifier `%c'" mod-type mod-char)) - (let* ((file (buffer-substring (point) end)) - (attrs (file-attributes file))) - (unless attrs - (error "Cannot stat file `%s'" file)) - (setq when (nth attr-index attrs))) - (goto-char (1+ end))) - (let ((f (cond ((eq qual ?-) #'time-less-p) - ((eq qual ?+) (lambda (a b) (time-less-p b a))) - (#'time-equal-p)))) - (lambda (file) - (let ((attrs (file-attributes file))) - (if attrs - (funcall f when (nth attr-index attrs)))))))) + (setq qual (eshell-get-comparison-modifier-argument + (list #'time-less-p + (lambda (a b) (time-less-p b a)) + #'time-equal-p))) + (if-let ((number (eshell-get-numeric-modifier-argument))) + (setq when (time-since (* number quantum))) + (let* ((file (or (eshell-get-delimited-modifier-argument) + (error "Malformed %s time modifier `%c'" + mod-type mod-char))) + (attrs (or (file-attributes file) + (error "Cannot stat file `%s'" file)))) + (setq when (nth attr-index attrs)))) + (lambda (file) + (when-let ((attrs (file-attributes file))) + (funcall qual when (nth attr-index attrs)))))) (defun eshell-pred-file-type (type) "Return a test which tests that the file is of a certain TYPE. @@ -458,36 +485,23 @@ that `ls -l' will show in the first column of its display." '(?b ?c) (list type)))) (lambda (file) - (let ((attrs (eshell-file-attributes (directory-file-name file)))) - (if attrs - (memq (aref (file-attribute-modes attrs) 0) set)))))) + (when-let ((attrs (eshell-file-attributes (directory-file-name file)))) + (memq (aref (file-attribute-modes attrs) 0) set))))) (defsubst eshell-pred-file-mode (mode) "Return a test which tests that MODE pertains to the file." (lambda (file) - (let ((modes (file-modes file 'nofollow))) - (if modes - (not (zerop (logand mode modes))))))) + (when-let ((modes (file-modes file 'nofollow))) + (not (zerop (logand mode modes)))))) (defun eshell-pred-file-links () "Return a predicate to test whether a file has a given number of links." - (let (qual amount) - (when (memq (char-after) '(?- ?+)) - (setq qual (char-after)) - (forward-char)) - (unless (looking-at "[0-9]+") - (error "Invalid file link count modifier `l'")) - (setq amount (string-to-number (match-string 0))) - (goto-char (match-end 0)) - (let ((f (if (eq qual ?-) - #'< - (if (eq qual ?+) - #'> - #'=)))) - (lambda (file) - (let ((attrs (eshell-file-attributes file))) - (if attrs - (funcall f (file-attribute-link-number attrs) amount))))))) + (let ((qual (eshell-get-comparison-modifier-argument)) + (amount (or (eshell-get-numeric-modifier-argument) + (error "Invalid file link count modifier `l'")))) + (lambda (file) + (when-let ((attrs (eshell-file-attributes file))) + (funcall qual (file-attribute-link-number attrs) amount))))) (defun eshell-pred-file-size () "Return a predicate to test whether a file is of a given size." @@ -502,89 +516,52 @@ that `ls -l' will show in the first column of its display." ((eq qual ?p) (setq quantum 512))) (forward-char)) - (when (memq (char-after) '(?- ?+)) - (setq qual (char-after)) - (forward-char)) - (unless (looking-at "[0-9]+") - (error "Invalid file size modifier `L'")) - (setq amount (* (string-to-number (match-string 0)) quantum)) - (goto-char (match-end 0)) - (let ((f (if (eq qual ?-) - #'< - (if (eq qual ?+) - #'> - #'=)))) - (lambda (file) - (let ((attrs (eshell-file-attributes file))) - (if attrs - (funcall f (file-attribute-size attrs) amount))))))) + (setq qual (eshell-get-comparison-modifier-argument)) + (setq amount (* (or (eshell-get-numeric-modifier-argument) + (error "Invalid file size modifier `L'")) + quantum)) + (lambda (file) + (when-let ((attrs (eshell-file-attributes file))) + (funcall qual (file-attribute-size attrs) amount))))) (defun eshell-pred-substitute (&optional repeat) "Return a modifier function that will substitute matches." - (let ((delim (char-after)) - match replace end) - (forward-char) - (setq end (eshell-find-delimiter delim delim nil nil t) - match (buffer-substring-no-properties (point) end)) - (goto-char (1+ end)) - (setq end (eshell-find-delimiter delim delim nil nil t) - replace (buffer-substring-no-properties (point) end)) - (goto-char (1+ end)) - (if repeat - (lambda (lst) - (mapcar - (lambda (str) - (let ((i 0)) - (while (setq i (string-match match str i)) - (setq str (replace-match replace t nil str)))) - str) - lst)) - (lambda (lst) - (mapcar - (lambda (str) - (if (string-match match str) - (setq str (replace-match replace t nil str)) - (error (concat str ": substitution failed"))) - str) - lst))))) + (let* ((match (or (eshell-get-delimited-modifier-argument t) + (error "Malformed pattern string for modifier `s'"))) + (replace (or (eshell-get-delimited-modifier-argument) + (error "Malformed replace string for modifier `s'"))) + (function (if repeat + (lambda (str) + (replace-regexp-in-string match replace str t)) + (lambda (str) + (if (string-match match str) + (replace-match replace t nil str) + (error (concat str ": substitution failed"))))))) + (lambda (lst) (mapcar function lst)))) -(defun eshell-include-members (&optional invert-p) - "Include only Lisp members matching a regexp." - (let ((delim (char-after)) - regexp end) - (forward-char) - (setq end (eshell-find-delimiter delim delim nil nil t) - regexp (buffer-substring-no-properties (point) end)) - (goto-char (1+ end)) - (let ((predicates - (list (if invert-p - (lambda (elem) (not (string-match regexp elem))) - (lambda (elem) (string-match regexp elem)))))) - (lambda (lst) - (eshell-winnow-list lst nil predicates))))) +(defun eshell-include-members (mod-char &optional invert-p) + "Include only Lisp members matching a regexp. +If INVERT-P is non-nil, include only members not matching a regexp." + (let* ((regexp (or (eshell-get-delimited-modifier-argument) + (error "Malformed pattern string for modifier `%c'" + mod-char))) + (predicates + (list (if invert-p + (lambda (elem) (not (string-match regexp elem))) + (lambda (elem) (string-match regexp elem)))))) + (lambda (lst) + (eshell-winnow-list lst nil predicates)))) (defun eshell-join-members () "Return a modifier function that join matches." - (let ((delim (char-after)) - str end) - (if (not (memq delim '(?' ?/))) - (setq delim " ") - (forward-char) - (setq end (eshell-find-delimiter delim delim nil nil t) - str (buffer-substring-no-properties (point) end)) - (goto-char (1+ end))) + (let ((str (or (eshell-get-delimited-modifier-argument) + " "))) (lambda (lst) (mapconcat #'identity lst str)))) (defun eshell-split-members () "Return a modifier function that splits members." - (let ((delim (char-after)) - sep end) - (when (memq delim '(?' ?/)) - (forward-char) - (setq end (eshell-find-delimiter delim delim nil nil t) - sep (buffer-substring-no-properties (point) end)) - (goto-char (1+ end))) + (let ((sep (eshell-get-delimited-modifier-argument))) (lambda (lst) (mapcar (lambda (str) diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index ee3f907f85c..459487f4358 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -180,19 +180,63 @@ treated as a literal character." (add-text-properties 0 (length string) '(escaped t) string)) string) +(defun eshell-concat (quoted &rest rest) + "Concatenate all the arguments in REST and return the result. +If QUOTED is nil, the resulting value(s) may be converted to +numbers (see `eshell-concat-1'). + +If each argument in REST is a non-list value, the result will be +a single value, as if (mapconcat #'eshell-stringify REST) had been +called, possibly converted to a number. + +If there is at least one (non-nil) list argument, the result will +be a list, with \"adjacent\" elements of consecutive arguments +concatenated as strings (again, possibly converted to numbers). +For example, concatenating \"a\", (\"b\"), and (\"c\" \"d\") +would produce (\"abc\" \"d\")." + (let (result) + (dolist (i rest result) + (when i + (cond + ((null result) + (setq result i)) + ((listp result) + (let (curr-head curr-tail) + (if (listp i) + (setq curr-head (car i) + curr-tail (cdr i)) + (setq curr-head i + curr-tail nil)) + (setq result + (append + (butlast result 1) + (list (eshell-concat-1 quoted (car (last result)) + curr-head)) + curr-tail)))) + ((listp i) + (setq result + (cons (eshell-concat-1 quoted result (car i)) + (cdr i)))) + (t + (setq result (eshell-concat-1 quoted result i)))))))) + +(defun eshell-concat-1 (quoted first second) + "Concatenate FIRST and SECOND. +If QUOTED is nil and either FIRST or SECOND are numbers, try to +convert the result to a number as well." + (let ((result (concat (eshell-stringify first) (eshell-stringify second)))) + (if (and (not quoted) + (or (numberp first) (numberp second))) + (eshell-convert-to-number result) + result))) + (defun eshell-resolve-current-argument () "If there are pending modifications to be made, make them now." (when eshell-current-argument (when eshell-arg-listified - (let ((parts eshell-current-argument)) - (while parts - (unless (stringp (car parts)) - (setcar parts - (list 'eshell-to-flat-string (car parts)))) - (setq parts (cdr parts))) - (setq eshell-current-argument - (list 'eshell-convert - (append (list 'concat) eshell-current-argument)))) + (setq eshell-current-argument + (append (list 'eshell-concat eshell-current-quoted) + eshell-current-argument)) (setq eshell-arg-listified nil)) (while eshell-current-modifiers (setq eshell-current-argument @@ -401,7 +445,9 @@ If the form has no `type', the syntax is parsed as if `type' were (if (eshell-arg-delimiter (1+ end)) (prog1 (list (if buffer-p 'get-buffer-create 'get-process) - (buffer-substring-no-properties (point) end)) + (replace-regexp-in-string + (rx "\\" (group (or "\\" "<" ">"))) "\\1" + (buffer-substring-no-properties (point) end))) (goto-char (1+ end))) (ignore (goto-char here))))))) diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 8be1136e311..42616e7037d 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -1002,6 +1002,14 @@ produced by `eshell-parse-command'." (let ((base (cadr (nth 2 (nth 2 (cadr command)))))) (eshell--invoke-command-directly base))) +(defun eshell-eval-argument (argument) + "Evaluate a single Eshell ARGUMENT and return the result." + (let* ((form (eshell-with-temp-command argument + (eshell-parse-argument))) + (result (eshell-do-eval form t))) + (cl-assert (eq (car result) 'quote)) + (cadr result))) + (defun eshell-eval-command (command &optional input) "Evaluate the given COMMAND iteratively." (if eshell-current-command diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el index fc023f23ce2..98902fc6f23 100644 --- a/lisp/eshell/esh-ext.el +++ b/lisp/eshell/esh-ext.el @@ -163,7 +163,7 @@ by the user on the command line." (defcustom eshell-explicit-command-char ?* "If this char occurs before a command name, call it externally. -That is, although `vi' may be an alias, `\vi' will always call the +That is, although `vi' may be an alias, `*vi' will always call the external version." :type 'character :group 'eshell-ext) diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 788404fc43a..b5a423f0237 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -151,67 +151,98 @@ Otherwise, evaluates FORM with no error handling." (defun eshell-find-delimiter (open close &optional bound reverse-p backslash-p) "From point, find the CLOSE delimiter corresponding to OPEN. -The matching is bounded by BOUND. -If REVERSE-P is non-nil, process the region backwards. -If BACKSLASH-P is non-nil, and OPEN and CLOSE are the same character, -then quoting is done by a backslash, rather than a doubled delimiter." +The matching is bounded by BOUND. If REVERSE-P is non-nil, +process the region backwards. + +If BACKSLASH-P is non-nil, or OPEN and CLOSE are different +characters, then a backslash can be used to escape a delimiter +(or another backslash). Otherwise, the delimiter is escaped by +doubling it up." (save-excursion (let ((depth 1) (bound (or bound (point-max)))) - (if (if reverse-p - (eq (char-before) close) - (eq (char-after) open)) - (forward-char (if reverse-p -1 1))) + (when (if reverse-p + (eq (char-before) close) + (eq (char-after) open)) + (forward-char (if reverse-p -1 1))) (while (and (> depth 0) - (funcall (if reverse-p '> '<) (point) bound)) - (let ((c (if reverse-p (char-before) (char-after))) nc) + (funcall (if reverse-p #'> #'<) (point) bound)) + (let ((c (if reverse-p (char-before) (char-after)))) (cond ((and (not reverse-p) (or (not (eq open close)) backslash-p) (eq c ?\\) - (setq nc (char-after (1+ (point)))) - (or (eq nc open) (eq nc close))) + (memq (char-after (1+ (point))) + (list open close ?\\))) (forward-char 1)) ((and reverse-p (or (not (eq open close)) backslash-p) - (or (eq c open) (eq c close)) - (eq (char-before (1- (point))) - ?\\)) + (eq (char-before (1- (point))) ?\\) + (memq c (list open close ?\\))) (forward-char -1)) ((eq open close) - (if (eq c open) - (if (and (not backslash-p) - (eq (if reverse-p - (char-before (1- (point))) - (char-after (1+ (point)))) open)) - (forward-char (if reverse-p -1 1)) - (setq depth (1- depth))))) + (when (eq c open) + (if (and (not backslash-p) + (eq (if reverse-p + (char-before (1- (point))) + (char-after (1+ (point)))) + open)) + (forward-char (if reverse-p -1 1)) + (setq depth (1- depth))))) ((= c open) (setq depth (+ depth (if reverse-p -1 1)))) ((= c close) (setq depth (+ depth (if reverse-p 1 -1)))))) (forward-char (if reverse-p -1 1))) - (if (= depth 0) - (if reverse-p (point) (1- (point))))))) + (when (= depth 0) + (if reverse-p (point) (1- (point))))))) -(defun eshell-convert (string) - "Convert STRING into a more native looking Lisp object." - (if (not (stringp string)) - string - (let ((len (length string))) - (if (= len 0) - string - (if (eq (aref string (1- len)) ?\n) +(defun eshell-convertible-to-number-p (string) + "Return non-nil if STRING can be converted to a number. +If `eshell-convert-numeric-aguments', always return nil." + (and eshell-convert-numeric-arguments + (string-match + (concat "\\`\\s-*" eshell-number-regexp "\\s-*\\'") + string))) + +(defun eshell-convert-to-number (string) + "Try to convert STRING to a number. +If STRING doesn't look like a number (or +`eshell-convert-numeric-aguments' is nil), just return STRING +unchanged." + (if (eshell-convertible-to-number-p string) + (string-to-number string) + string)) + +(defun eshell-convert (string &optional to-string) + "Convert STRING into a more-native Lisp object. +If TO-STRING is non-nil, always return a single string with +trailing newlines removed. Otherwise, this behaves as follows: + +* Return non-strings as-is. + +* Split multiline strings by line. + +* If `eshell-convert-numeric-aguments' is non-nil and every line + of output looks like a number, convert them to numbers." + (cond + ((not (stringp string)) + (if to-string + (eshell-stringify string) + string)) + (to-string (string-trim-right string "\n+")) + (t (let ((len (length string))) + (if (= len 0) + string + (when (eq (aref string (1- len)) ?\n) (setq string (substring string 0 (1- len)))) - (if (string-search "\n" string) - (split-string string "\n") - (if (and eshell-convert-numeric-arguments - (string-match - (concat "\\`\\s-*" eshell-number-regexp - "\\s-*\\'") string)) - (string-to-number string) - string)))))) + (if (string-search "\n" string) + (let ((lines (split-string string "\n"))) + (if (seq-every-p #'eshell-convertible-to-number-p lines) + (mapcar #'string-to-number lines) + lines)) + (eshell-convert-to-number string))))))) (defvar-local eshell-path-env (getenv "PATH") "Content of $PATH. @@ -262,6 +293,7 @@ Prepend remote identification of `default-directory', if any." (defun eshell-to-flat-string (value) "Make value a string. If separated by newlines change them to spaces." + (declare (obsolete nil "29.1")) (let ((text (eshell-stringify value))) (if (string-match "\n+\\'" text) (setq text (replace-match "" t t text))) @@ -589,11 +621,11 @@ list." The optional argument ID-FORMAT specifies the preferred uid and gid format. Valid values are `string' and `integer', defaulting to `integer'. See `file-attributes'." - (let* ((file (expand-file-name file)) + (let* ((expanded-file (expand-file-name file)) entry) - (if (string-equal (file-remote-p file 'method) "ftp") - (let ((base (file-name-nondirectory file)) - (dir (file-name-directory file))) + (if (string-equal (file-remote-p expanded-file 'method) "ftp") + (let ((base (file-name-nondirectory expanded-file)) + (dir (file-name-directory expanded-file))) (if (string-equal "" base) (setq base ".")) (unless entry (setq entry (eshell-parse-ange-ls dir)) diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index ca4cbd744c1..1c28d24af12 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -402,27 +402,34 @@ process any indices that come after the variable reference." (let* ((get-len (when (eq (char-after) ?#) (forward-char) t)) value indices) - (setq value (eshell-parse-variable-ref) + (setq value (eshell-parse-variable-ref get-len) indices (and (not (eobp)) (eq (char-after) ?\[) (eshell-parse-indices)) ;; This is an expression that will be evaluated by `eshell-do-eval', ;; which only support let-binding of dynamically-scoped vars value `(let ((indices (eshell-eval-indices ',indices))) ,value)) - (if get-len - `(length ,value) - value))) + (when get-len + (setq value `(length ,value))) + (when eshell-current-quoted + (setq value `(eshell-stringify ,value))) + value)) -(defun eshell-parse-variable-ref () +(defun eshell-parse-variable-ref (&optional modifier-p) "Eval a variable reference. Returns a Lisp form which, if evaluated, will return the value of the variable. -Possible options are: +If MODIFIER-P is non-nil, the value of the variable will be +modified by some function. If MODIFIER-P is nil, the value will be +used as-is; this allows optimization of some kinds of variable +references. + +Possible variable references are: NAME an environment or Lisp variable value \"LONG-NAME\" disambiguates the length of the name - 'LONG-NAME' as above + `LONG-NAME' as above {COMMAND} result of command is variable's value (LISP-FORM) result of Lisp form is variable's value write the output of command to a temporary file; @@ -441,8 +448,16 @@ Possible options are: ,(let ((subcmd (or (eshell-unescape-inner-double-quote end) (cons (point) end))) (eshell-current-quoted nil)) - (eshell-parse-command subcmd))))) - indices) + (eshell-parse-command subcmd)))) + ;; If this is a simple double-quoted form like + ;; "${COMMAND}" (i.e. no indices after the subcommand + ;; and no `#' modifier before), ensure we convert to a + ;; single string. This avoids unnecessary work + ;; (e.g. splitting the output by lines) when it would + ;; just be joined back together afterwards. + ,(when (and (not modifier-p) eshell-current-quoted) + '(not indices))) + indices ,eshell-current-quoted) (goto-char (1+ end)))))) ((eq (char-after) ?\<) (let ((end (eshell-find-delimiter ?\< ?\>))) @@ -466,7 +481,7 @@ Possible options are: ;; properly. See bug#54190. (list (function (lambda () (delete-file ,temp)))))) - (eshell-apply-indices ,temp indices))) + (eshell-apply-indices ,temp indices ,eshell-current-quoted))) (goto-char (1+ end))))))) ((eq (char-after) ?\() (condition-case nil @@ -475,7 +490,7 @@ Possible options are: (eshell-lisp-command ',(read (or (eshell-unescape-inner-double-quote (point-max)) (current-buffer))))) - indices) + indices ,eshell-current-quoted) (end-of-file (throw 'eshell-incomplete ?\()))) ((looking-at (rx-to-string @@ -487,14 +502,15 @@ Possible options are: (eshell-parse-literal-quote) (eshell-parse-double-quote)))) (when name - `(eshell-get-variable ,(eval name) indices))))) + `(eshell-get-variable ,(eval name) indices ,eshell-current-quoted))))) ((assoc (char-to-string (char-after)) eshell-variable-aliases-list) (forward-char) - `(eshell-get-variable ,(char-to-string (char-before)) indices)) + `(eshell-get-variable ,(char-to-string (char-before)) indices + ,eshell-current-quoted)) ((looking-at eshell-variable-name-regexp) (prog1 - `(eshell-get-variable ,(match-string 0) indices) + `(eshell-get-variable ,(match-string 0) indices ,eshell-current-quoted) (goto-char (match-end 0)))) (t (error "Invalid variable reference")))) @@ -525,8 +541,10 @@ For example, \"[0 1][2]\" becomes: "Evaluate INDICES, a list of index-lists generated by `eshell-parse-indices'." (mapcar (lambda (i) (mapcar #'eval i)) indices)) -(defun eshell-get-variable (name &optional indices) - "Get the value for the variable NAME." +(defun eshell-get-variable (name &optional indices quoted) + "Get the value for the variable NAME. +INDICES is a list of index-lists (see `eshell-parse-indices'). +If QUOTED is non-nil, this was invoked inside double-quotes." (let* ((alias (assoc name eshell-variable-aliases-list)) (var (if alias (cadr alias) @@ -547,9 +565,9 @@ For example, \"[0 1][2]\" becomes: (symbol-value var)) (t (error "Unknown variable `%s'" (eshell-stringify var)))) - indices)))) + indices quoted)))) -(defun eshell-apply-indices (value indices) +(defun eshell-apply-indices (value indices &optional quoted) "Apply to VALUE all of the given INDICES, returning the sub-result. The format of INDICES is: @@ -558,12 +576,17 @@ The format of INDICES is: Each member of INDICES represents a level of nesting. If the first member of a sublist is not an integer or name, and the value it's -reference is a string, that will be used as the regexp with which is -to divide the string into sub-parts. The default is whitespace. +referencing is a string, that will be used as the regexp with which +is to divide the string into sub-parts. The default is whitespace. Otherwise, each INT-OR-NAME refers to an element of the list value. Integers imply a direct index, and names, an associate lookup using `assoc'. +If QUOTED is non-nil, this was invoked inside double-quotes. This +affects the behavior of splitting strings: without quoting, the +split values are converted to Lisp forms via `eshell-convert'; with +quoting, they're left as strings. + For example, to retrieve the second element of a user's record in '/etc/passwd', the variable reference would look like: @@ -577,7 +600,7 @@ For example, to retrieve the second element of a user's record in (setq separator index refs (cdr refs))) (setq value - (mapcar #'eshell-convert + (mapcar (lambda (i) (eshell-convert i quoted)) (split-string value separator))))) (cond ((< (length refs) 0) diff --git a/lisp/faces.el b/lisp/faces.el index 30f8483159a..12a386c8f63 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -46,7 +46,8 @@ the terminal-initialization file to be loaded." ("vt320" . "vt200") ("vt400" . "vt200") ("vt420" . "vt200") - ("alacritty" . "xterm")) + ("alacritty" . "xterm") + ("foot" . "xterm")) "Alist of terminal type aliases. Entries are of the form (TYPE . ALIAS), where both elements are strings. This means to treat a terminal of type TYPE as if it were of type ALIAS." @@ -448,6 +449,10 @@ of FACE on FRAME." (defun face-attribute (face attribute &optional frame inherit) "Return the value of FACE's ATTRIBUTE on FRAME. + +See `set-face-attribute' for the list of supported attributes +and their meanings and allowed values. + If the optional argument FRAME is given, report on face FACE in that frame. If FRAME is t, report on the defaults for face FACE (for new frames). If FRAME is omitted or nil, use the selected frame. @@ -1857,8 +1862,8 @@ on which one provides better contrast with COLOR." "#ffffff" "black")) (defconst color-luminance-dark-limit 0.325 - "The relative luminance below which a color is considered 'dark'. -A 'dark' color in this sense provides better contrast with white + "The relative luminance below which a color is considered \"dark\". +A \"dark\" color in this sense provides better contrast with white than with black; see `color-dark-p'. This value was determined experimentally.") @@ -2656,8 +2661,9 @@ non-nil." :background "grey75" :foreground "black") (t :inverse-video t)) - "Face for the mode lines (for the selected window) as well as header lines. -See `mode-line-display' for the face used on mode lines." + "Face for the mode lines as well as header lines. +See `mode-line-active' and `mode-line-inactive' for the faces +used on mode lines." :version "21.1" :group 'mode-line-faces :group 'basic-faces) @@ -2871,7 +2877,10 @@ Note: Other faces cannot inherit from the cursor face." '((default :box (:line-width 1 :style released-button) :foreground "black") - (((type x w32 ns haiku pgtk) (class color)) + (((type haiku)) + :foreground "B_MENU_ITEM_TEXT_COLOR" + :background "B_MENU_BACKGROUND_COLOR") + (((type x w32 ns pgtk) (class color)) :background "grey75") (((type x) (class mono)) :background "grey")) diff --git a/lisp/ffap.el b/lisp/ffap.el index b5d2a02cd1d..30a9577d38f 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -79,7 +79,7 @@ ;; (setq ffap-shell-prompt-regexp nil) ; disable shell prompt stripping ;; (setq ffap-gopher-regexp nil) ; disable gopher bookmark matching ;; -;; ffap uses `browse-url' (if found, else `w3-fetch') to fetch URL's. +;; ffap uses `browse-url' (if found, else `w3-fetch') to fetch URLs. ;; For a hairier `ffap-url-fetcher', try ffap-url.el (same ftp site). ;; Also, you can add `ffap-menu-rescan' to various hooks to fontify ;; the file and URL references within a buffer. @@ -282,7 +282,7 @@ For a fancy alternative, get `ffap-url.el'." :risky t) (defcustom ffap-next-regexp - ;; If you want ffap-next to find URL's only, try this: + ;; If you want ffap-next to find URLs only, try this: ;; (and ffap-url-regexp (string-match "\\\\`" ffap-url-regexp) ;; (concat "\\<" (substring ffap-url-regexp 2)))) ;; @@ -315,7 +315,7 @@ disable ffap most of the time." ;;; Find Next Thing in buffer (`ffap-next'): ;; -;; Original ffap-next-url (URL's only) from RPECK 30 Mar 1995. Since +;; Original ffap-next-url (URLs only) from RPECK 30 Mar 1995. Since ;; then, broke it up into ffap-next-guess (noninteractive) and ;; ffap-next (a command). It now work on files as well as url's. @@ -363,7 +363,7 @@ Actual search is done by the function `ffap-next-guess'." (sit-for 0) ; display point movement (find-file-at-point (ffap-prompter guess))) (goto-char pt) ; restore point - (message "No %sfiles or URL's found" + (message "No %sfiles or URLs found" (if wrap "" "more "))))) (defun ffap-next-url (&optional back wrap) diff --git a/lisp/files-x.el b/lisp/files-x.el index 319bfe05655..0ae9fb076eb 100644 --- a/lisp/files-x.el +++ b/lisp/files-x.el @@ -722,14 +722,18 @@ will not be changed." (copy-tree connection-local-variables-alist))) (hack-local-variables-apply))) +(defvar connection-local-default-application 'tramp + "Default application in connection-local functions, a symbol. +This variable must not be changed globally.") + (defsubst connection-local-criteria-for-default-directory (&optional application) "Return a connection-local criteria, which represents `default-directory'. -If APPLICATION is nil, the symbol `tramp' is used." +If APPLICATION is nil, `connection-local-default-application' is used." (when (file-remote-p default-directory) - `(:application ,(or application 'tramp) - :protocol ,(file-remote-p default-directory 'method) - :user ,(file-remote-p default-directory 'user) - :machine ,(file-remote-p default-directory 'host)))) + `(:application ,(or application connection-local-default-application) + :protocol ,(file-remote-p default-directory 'method) + :user ,(file-remote-p default-directory 'user) + :machine ,(file-remote-p default-directory 'host)))) ;;;###autoload (defmacro with-connection-local-variables (&rest body) diff --git a/lisp/files.el b/lisp/files.el index a0501cffa1a..2b0dc54db8f 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -987,10 +987,7 @@ one or more of those symbols." (logior (if (memq 'executable predicate) 1 0) (if (memq 'writable predicate) 2 0) (if (memq 'readable predicate) 4 0)))) - (let ((file (locate-file-internal filename path suffixes predicate))) - (if (and file (string-match "\\.eln\\'" file)) - (gethash (file-name-nondirectory file) comp-eln-to-el-h) - file))) + (locate-file-internal filename path suffixes predicate)) (defun locate-file-completion-table (dirs suffixes string pred action) "Do completion for file names passed to `locate-file'." @@ -3744,8 +3741,8 @@ return as the symbol specifying the mode." (while (not (or (and (eq handle-mode t) result) (>= (point) end))) (unless (looking-at hack-local-variable-regexp) - (message "Malformed mode-line: %S" - (buffer-substring-no-properties (point) end)) + (message "Malformed mode-line: %S in buffer %S" + (buffer-substring-no-properties (point) end) (buffer-name)) (throw 'malformed-line nil)) (goto-char (match-end 0)) ;; There used to be a downcase here, @@ -3902,8 +3899,8 @@ inhibited." (with-demoted-errors "Directory-local variables error: %s" ;; Note this is a no-op if enable-local-variables is nil. (hack-dir-local-variables)) - (let ((result (append (hack-local-variables--find-variables) - (hack-local-variables-prop-line)))) + (let ((result (append (hack-local-variables--find-variables handle-mode) + (hack-local-variables-prop-line handle-mode)))) (if (and enable-local-variables (not (inhibit-local-variables-p))) (progn @@ -3981,8 +3978,7 @@ major-mode." (forward-line 1)) (goto-char (point-min)) - (while (not (or (eobp) - (and (eq handle-mode t) result))) + (while (not (eobp)) ;; Find the variable name; (unless (looking-at hack-local-variable-regexp) (user-error "Malformed local variable line: %S" @@ -4008,7 +4004,8 @@ major-mode." (not (string-match "-minor\\'" (setq val2 (downcase (symbol-name val))))) - (setq result (intern (concat val2 "-mode")))) + ;; Allow several mode: elements. + (push (intern (concat val2 "-mode")) result)) (cond ((eq var 'coding)) ((eq var 'lexical-binding) (unless hack-local-variables--warned-lexical @@ -4032,7 +4029,10 @@ major-mode." val) result)))))) (forward-line 1))))))) - result)) + (if (eq handle-mode t) + ;; Return the final mode: setting that's defined. + (car (seq-filter #'fboundp result)) + result))) (defun hack-local-variables-apply () "Apply the elements of `file-local-variables-alist'. @@ -5094,7 +5094,11 @@ On most systems, this will be true: ;; If there's nothing left to peel off, we're at the root and ;; we can stop. (when (and dir (equal dir filename)) - (push "" components) + (push (if (equal dir "") "" + ;; On Windows, the first component might be "c:" or + ;; the like. + (substring dir 0 -1)) + components) (setq filename nil)))) components)) @@ -7324,7 +7328,9 @@ need to be passed verbatim to shell commands." (defvar insert-directory-program (purecopy "ls") - "Absolute or relative name of the `ls' program used by `insert-directory'.") + "Absolute or relative name of the `ls'-like program. +This is used by `insert-directory' and `dired-insert-directory' +\(thus, also by `dired').") (defcustom directory-free-space-program (purecopy "df") "Program to get the amount of free space on a file system. @@ -7759,14 +7765,17 @@ prompt the user before killing them." :group 'convenience :version "26.1") -(defun save-buffers-kill-emacs (&optional arg) +(defun save-buffers-kill-emacs (&optional arg restart) "Offer to save each buffer, then kill this Emacs process. With prefix ARG, silently save all file-visiting buffers without asking. If there are active processes where `process-query-on-exit-flag' returns non-nil and `confirm-kill-processes' is non-nil, asks whether processes should be killed. + Runs the members of `kill-emacs-query-functions' in turn and stops -if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." +if any returns nil. If `confirm-kill-emacs' is non-nil, calls it. + +If RESTART, restart Emacs after killing the current Emacs process." (interactive "P") ;; Don't use save-some-buffers-default-predicate, because we want ;; to ask about all the buffers before killing Emacs. @@ -7820,7 +7829,7 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." (run-hook-with-args-until-failure 'kill-emacs-query-functions) (or (null confirm) (funcall confirm "Really exit Emacs? ")) - (kill-emacs)))) + (kill-emacs nil restart)))) (defun save-buffers-kill-terminal (&optional arg) "Offer to save each buffer, then kill the current connection. @@ -7835,6 +7844,16 @@ only these files will be asked to be saved." (if (frame-parameter nil 'client) (server-save-buffers-kill-terminal arg) (save-buffers-kill-emacs arg))) + +(defun restart-emacs () + "Kill the current Emacs process and start a new one. +This goes through the same shutdown procedure as +`save-buffers-kill-emacs', but instead of killing Emacs and +exiting, it re-executes Emacs (using the same command line +arguments as the running Emacs)." + (interactive) + (save-buffers-kill-emacs nil t)) + ;; We use /: as a prefix to "quote" a file name ;; so that magic file name handlers will not apply to it. diff --git a/lisp/finder.el b/lisp/finder.el index a40f8c64f24..a2a27ea061d 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -1,7 +1,6 @@ ;;; finder.el --- topic & keyword-based code finder -*- lexical-binding: t -*- -;; Copyright (C) 1992, 1997-1999, 2001-2022 Free Software Foundation, -;; Inc. +;; Copyright (C) 1992-2022 Free Software Foundation, Inc. ;; Author: Eric S. Raymond ;; Created: 16 Jun 1992 @@ -76,20 +75,18 @@ "Association list of the standard \"Keywords:\" headers. Each element has the form (KEYWORD . DESCRIPTION).") -(defvar finder-mode-map - (let ((map (make-sparse-keymap))) - (define-key map " " 'finder-select) - (define-key map "f" 'finder-select) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] 'finder-mouse-select) - (define-key map "\C-m" 'finder-select) - (define-key map "?" 'finder-summary) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - (define-key map "q" 'finder-exit) - (define-key map "d" 'finder-list-keywords) - map) - "Keymap used in `finder-mode'.") +(defvar-keymap finder-mode-map + :doc "Keymap used in `finder-mode'." + "SPC" #'finder-select + "f" #'finder-select + "" 'mouse-face + "" #'finder-mouse-select + "C-m" #'finder-select + "?" #'finder-summary + "n" #'next-line + "p" #'previous-line + "q" #'finder-exit + "d" #'finder-list-keywords) (easy-menu-define finder-mode-menu finder-mode-map "Menu for `finder-mode'." @@ -367,7 +364,7 @@ not `finder-known-keywords'." "Display FILE's commentary section. FILE should be in a form suitable for passing to `locate-library'." ;; FIXME: Merge this function into `describe-package', which is - ;; strictly better as it has links to URL's and is in a proper help + ;; strictly better as it has links to URLs and is in a proper help ;; buffer with navigation forward and backward, etc. (interactive (list diff --git a/lisp/foldout.el b/lisp/foldout.el index 4b192a7b6aa..e00fb40e3ca 100644 --- a/lisp/foldout.el +++ b/lisp/foldout.el @@ -473,7 +473,7 @@ What happens depends on the number of mouse clicks:- "Swallow intervening mouse events so we only get the final click-count. Signal an error if the final event isn't the same type as the first one." (let ((initial-event-type (event-basic-type event))) - (while (null (sit-for (/ double-click-time 1000.0) 'nodisplay)) + (while (null (sit-for (/ (mouse-double-click-time) 1000.0) 'nodisplay)) (setq event (read--potential-mouse-event))) (or (eq initial-event-type (event-basic-type event)) (error ""))) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index d8a1fe399b6..488874a1755 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -208,6 +208,7 @@ (require 'syntax) (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;; Define core `font-lock' group. (defgroup font-lock '((jit-lock custom-group)) @@ -279,6 +280,47 @@ decoration for buffers in C++ mode, and level 1 decoration otherwise." (integer :tag "level" 1))))) :group 'font-lock) +(defcustom font-lock-ignore nil + "Rules to selectively disable fontifications due to `font-lock-keywords'. +If non-nil, the value should be a list of condition sets of the form + + (SYMBOL CONDITION ...) + +where: + + - SYMBOL is a symbol, usually a major or minor mode. The subsequent + CONDITIONs apply if SYMBOL is bound as variable and its value is non-nil. + If SYMBOL is a symbol of a mode, that means the buffer has that mode + enabled (for major modes, it means the buffer's major mode is derived + from SYMBOL's mode). + + - Each CONDITION can be one of the following: + - A symbol, typically a face. It matches any element of + `font-lock-keywords' that references the symbol. The symbol is + interpreted as a glob pattern; in particular, `*' matches + everything, `?' matches any single character, and `[abcd]' + matches one character from the set. + - A string. It matches any element of `font-lock-keywords' whose + MATCHER is a regexp that matches the string. This can be used to + disable fontification of a particular programming keyword. + - A form (pred FUNCTION). It matches an element of `font-lock-keywords' + if FUNCTION, when called with the element as the argument, returns + non-nil. + - A form (not CONDITION). It matches if CONDITION doesn't. + - A form (and CONDITION ...). It matches if all the provided + CONDITIONs match. + - A form (or CONDITION ...). It matches if at least one of the + provided CONDITIONs matches. + - A form (except CONDITIONs ...). This can be used only at top level + or inside an `or' clause. It undoes the effect of previous + matching CONDITIONs on the same level. + +In each buffer, fontifications due to the elements of `font-lock-keywords' +that match at least one applicable CONDITION are disabled." + :type '(alist :key-type symbol :value-type sexp) + :group 'font-lock + :version "29.1") + (defcustom font-lock-verbose nil "If non-nil, means show status messages for buffer fontification. If a number, only buffers greater than this size have fontification messages." @@ -349,7 +391,7 @@ This can be an \"!\" or the \"n\" in \"ifndef\".") ;; Fontification variables: (defvar font-lock-keywords nil - "A list of the keywords to highlight. + "A list of keywords and corresponding font-lock highlighting rules. There are two kinds of values: user-level, and compiled. A user-level keywords list is what a major mode or the user would @@ -374,10 +416,10 @@ point, and set `match-data' appropriately if it succeeds; like `re-search-forward' would). MATCHER regexps can be generated via the function `regexp-opt'. -FORM is an expression, whose value should be a keyword element, -evaluated when the keyword is (first) used in a buffer. This -feature can be used to provide a keyword that can only be -generated when Font Lock mode is actually turned on. +FORM is an expression, whose value should be a keyword element +of one of the above forms, evaluated when the keyword is (first) +used in a buffer. This feature can be used to provide a keyword +that can only be generated when Font Lock mode is actually turned on. HIGHLIGHT should be either MATCH-HIGHLIGHT or MATCH-ANCHORED. @@ -1810,9 +1852,8 @@ If SYNTACTIC-KEYWORDS is non-nil, it means these keywords are used for (error "Font-lock trying to use keywords before setting them up")) (if (eq (car-safe keywords) t) keywords - (setq keywords - (cons t (cons keywords - (mapcar #'font-lock-compile-keyword keywords)))) + (let ((compiled (mapcar #'font-lock-compile-keyword keywords))) + (setq keywords `(t ,keywords ,@(font-lock--filter-keywords compiled)))) (if (and (not syntactic-keywords) (let ((beg-function (with-no-warnings syntax-begin-function))) (or (eq beg-function #'beginning-of-defun) @@ -1883,6 +1924,50 @@ A LEVEL of nil is equal to a LEVEL of 0, a LEVEL of t is equal to (t (car keywords)))) +(defun font-lock--match-keyword (rule keyword) + "Return non-nil if font-lock KEYWORD matches RULE. +See `font-lock-ignore' for the possible rules." + (pcase-exhaustive rule + ('* t) + ((pred symbolp) + (let ((regexp (when (string-match-p "[*?]" (symbol-name rule)) + (wildcard-to-regexp (symbol-name rule))))) + (named-let search ((obj keyword)) + (cond + ((consp obj) (or (search (car obj)) (search (cdr obj)))) + ((not regexp) (eq rule obj)) + ((symbolp obj) (string-match-p regexp (symbol-name obj))))))) + ((pred stringp) (when (stringp (car keyword)) + (string-match-p (concat "\\`\\(?:" (car keyword) "\\)") + rule))) + (`(or . ,rules) (let ((match nil)) + (while rules + (pcase-exhaustive (pop rules) + (`(except ,rule) + (when match + (setq match (not (font-lock--match-keyword rule keyword))))) + (rule + (unless match + (setq match (font-lock--match-keyword rule keyword)))))) + match)) + (`(not ,rule) (not (font-lock--match-keyword rule keyword))) + (`(and . ,rules) (seq-every-p (lambda (rule) + (font-lock--match-keyword rule keyword)) + rules)) + (`(pred ,fun) (funcall fun keyword)))) + +(defun font-lock--filter-keywords (keywords) + "Filter a list of KEYWORDS using `font-lock-ignore'." + (if-let ((rules (mapcan (pcase-lambda (`(,mode . ,rules)) + (when (or (and (boundp mode) mode) + (derived-mode-p mode)) + (copy-sequence rules))) + font-lock-ignore))) + (seq-filter (lambda (keyword) (not (font-lock--match-keyword + `(or ,@rules) keyword))) + keywords) + keywords)) + (defun font-lock-refresh-defaults () "Restart fontification in current buffer after recomputing from defaults. Recompute fontification variables using `font-lock-defaults' and diff --git a/lisp/frame.el b/lisp/frame.el index b681a971aa3..49eabcf9786 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -1727,7 +1727,7 @@ to the selected frame. Storing information about resize operations is off by default. If you set the variable `frame-size-history' like this -(setq frame-size-history '(100)) +(setq frame-size-history \\='(100)) then Emacs will save information about the next 100 significant operations affecting any frame's size in that variable. This @@ -2433,6 +2433,70 @@ monitors." ,(display-mm-height display))) (frames . ,(frames-on-display-list display))))))))) +(declare-function x-device-class (name) "x-win.el") +(declare-function pgtk-device-class (name) "pgtk-win.el") + +(defun device-class (frame name) + "Return the class of the device NAME for an event generated on FRAME. +NAME is a string that can be the value of `last-event-device', or +nil. FRAME is a window system frame, typically the value of +`last-event-frame' when `last-event-device' was set. On some +window systems, it can also be a display name or a terminal. + +The class of a device is one of the following symbols: + + `core-keyboard' means the device is a keyboard-like device, but + any other characteristics are unknown. + + `core-pointer' means the device is a pointing device, but any + other characteristics are unknown. + + `mouse' means the device is a computer mouse. + + `trackpoint' means the device is a joystick or trackpoint. + + `eraser' means the device is an eraser, which is typically the + other end of a stylus on a graphics tablet. + + `pen' means the device is a stylus or some other similar + device. + + `puck' means the device is a device similar to a mouse, but + reports absolute coordinates. + + `power-button' means the device is a power button, volume + button, or some similar control. + + `keyboard' means the device is a keyboard. + + `touchscreen' means the device is a touchscreen. + + `pad' means the device is a collection of buttons and rings and + strips commonly found in drawing tablets. + + `touchpad' means the device is an indirect touch device, such + as a touchpad. + + `piano' means the device is a piano, or some other kind of + musical instrument. + + `test' means the device is used by the XTEST extension to + report input. + +It can also be nil, which means the class of the device could not +be determined. Individual window systems may also return other +symbols." + (let ((frame-type (framep-on-display frame))) + (cond ((eq frame-type 'x) + (x-device-class name)) + ((eq frame-type 'pgtk) + (pgtk-device-class name)) + (t (cond + ((string= name "Virtual core pointer") + 'core-pointer) + ((string= name "Virtual core keyboard") + 'core-keyboard)))))) + ;;;; Frame geometry values @@ -2896,6 +2960,12 @@ If the frame is in fullscreen state, don't change its state, but set the frame's `fullscreen-restore' parameter to `maximized', so the frame will be maximized after disabling fullscreen state. +If you wish to hide the title bar when the frame is maximized, you +can add something like the following to your init file: + + (add-hook \\='window-size-change-functions + #\\='frame-hide-title-bar-when-maximized) + Note that with some window managers you may have to set `frame-resize-pixelwise' to non-nil in order to make a frame appear truly maximized. In addition, you may have to set @@ -3011,6 +3081,13 @@ Offer NUMBER as default value, if it is a natural number." bidi-display-reordering bidi-inhibit-bpa)) +(defun frame-hide-title-bar-when-maximized (frame) + "Hide the title bar if FRAME is maximized. +If FRAME isn't maximized, show the title bar." + (set-frame-parameter + frame 'undecorated + (eq (alist-get 'fullscreen (frame-parameters frame)) 'maximized))) + (provide 'frame) ;;; frame.el ends here diff --git a/lisp/frameset.el b/lisp/frameset.el index 05884eed3a8..a589f7b5d96 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -448,6 +448,7 @@ DO NOT MODIFY. See `frameset-filter-alist' for a full description.") (defvar frameset-persistent-filter-alist (append '((background-color . frameset-filter-sanitize-color) + (bottom . frameset-filter-shelve-param) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) @@ -464,13 +465,20 @@ DO NOT MODIFY. See `frameset-filter-alist' for a full description.") (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) + (GUI:bottom . frameset-filter-unshelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) + (GUI:left . frameset-filter-unshelve-param) + (GUI:right . frameset-filter-unshelve-param) + (GUI:top . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) + (left . frameset-filter-shelve-param) (parent-frame . :never) (mouse-wheel-frame . :never) + (right . frameset-filter-shelve-param) + (top . frameset-filter-shelve-param) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) @@ -1010,13 +1018,15 @@ not be changed once the frame has been created. Internal use only." (cl-loop for param in '(left top width height border-width minibuffer) when (assq param parameters) collect it)) -(defun frameset--restore-frame (parameters window-state filters force-onscreen) +(defun frameset--restore-frame (parameters window-state filters force-onscreen + &optional dx dy) "Set up and return a frame according to its saved state. That means either reusing an existing frame or creating one anew. PARAMETERS is the frame's parameter alist; WINDOW-STATE is its window state. For the meaning of FILTERS and FORCE-ONSCREEN, see `frameset-restore'. Internal use only." (let* ((fullscreen (cdr (assq 'fullscreen parameters))) + (tty-to-GUI (frameset-switch-to-gui-p parameters)) (filtered-cfg (frameset-filter-params parameters filters nil)) (display (cdr (assq 'display filtered-cfg))) ;; post-filtering alt-cfg frame) @@ -1093,6 +1103,14 @@ Internal use only." (not (eq (frame-parameter frame 'visibility) 'icon))) (frameset-move-onscreen frame force-onscreen)) + ;; Frames saved on TTY shall be all considered visible when + ;; restoring on GUI display. Also, offset each new such frame + ;; relative to the previous one, to make it more visible. + (when tty-to-GUI + (push '(visibility . t) alt-cfg) + (when (and (numberp dx) (numberp dy)) + (push (cons 'left (+ (frame-parameter frame 'left) dx)) alt-cfg) + (push (cons 'top (+ (frame-parameter frame 'top) dy)) alt-cfg))) ;; Let's give the finishing touches (visibility, maximization). (when alt-cfg (modify-frame-parameters frame alt-cfg)) ;; Now restore window state. @@ -1216,7 +1234,9 @@ All keyword parameters default to nil." ((pred functionp) (cl-remove-if-not reuse-frames frames)) (_ - (error "Invalid arg :reuse-frames %s" reuse-frames))))) + (error "Invalid arg :reuse-frames %s" reuse-frames)))) + (dx 0) + (dy 0)) ;; Mark existing frames in the map; candidates to reuse are marked as :ignored; ;; they will be reassigned later, if chosen. @@ -1289,11 +1309,21 @@ All keyword parameters default to nil." (setq mb-window nil))) (when mb-window (push (cons 'minibuffer mb-window) frame-cfg)))))) + ;; Apply small offsets to each frame that came from + ;; a TTY-saved desktop, so that they don't obscure + ;; each other, but only if we don't have real frame + ;; position info from a GUI session in some, + ;; possibly distant, past. + (when (and (frameset-switch-to-gui-p frame-cfg) + (null (cdr (assq 'GUI:top frame-cfg))) + (null (cdr (assq 'GUI:left frame-cfg)))) + (setq dx (+ dx 20) + dy (+ dy 10))) ;; OK, we're ready at last to create (or reuse) a frame and ;; restore the window config. (setq frame (frameset--restore-frame frame-cfg window-cfg (or filters frameset-filter-alist) - force-onscreen)) + force-onscreen dx dy)) ;; Now reset any duplicate frameset--id (when (and duplicate (not (eq frame duplicate))) (set-frame-parameter duplicate 'frameset--id nil)) diff --git a/lisp/fringe.el b/lisp/fringe.el index 8c833f02429..1cfcce4542a 100644 --- a/lisp/fringe.el +++ b/lisp/fringe.el @@ -244,10 +244,18 @@ When used in a Lisp program, MODE should be one of these: nil (meaning the default width). - a single integer, which specifies the pixel widths of both fringes. + This command may round up the left and right width specifications to ensure that their sum is a multiple of the character width of a frame. It never rounds up a fringe width of 0. +Note that removing a right or left fringe (by setting the width +to zero) makes Emacs reserve one column of the window body to +display a line continuation marker. (This happens for both the +left and right fringe, since Emacs can display both left-to-right +and right-to-left text.) You can use `window-max-characters-per-line' +to check the effective width. + Fringe widths set by `set-window-fringes' override the default fringe widths set by this command. This command applies to all frames that exist and frames to be created in the future. If you diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el index d2edfdf09f4..732c6062b8b 100644 --- a/lisp/gnus/deuglify.el +++ b/lisp/gnus/deuglify.el @@ -439,6 +439,7 @@ If NODISPLAY is non-nil, don't redisplay the article buffer." (unless nodisplay (gnus-outlook-display-article-buffer)) attrib-start)) +;;;###autoload (defun gnus-article-outlook-rearrange-citation (&optional nodisplay) "Repair broken citations. If NODISPLAY is non-nil, don't redisplay the article buffer." diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index 697ce01343a..fc18d8a1c51 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -134,47 +134,8 @@ ARGS are passed to `message'." (const :tag "No map") (plist :inline t :tag "Properties")))) -(define-widget 'gmm-tool-bar-zap-list 'lazy - "Tool bar zap list." - :tag "Tool bar zap list" - :type '(choice (const :tag "Zap all" t) - (const :tag "Keep all" nil) - (list - ;; :value - ;; Work around (bug in customize?), see - ;; - ;; (new-file open-file dired kill-buffer write-file - ;; print-buffer customize help) - (set :inline t - (const new-file) - (const open-file) - (const dired) - (const kill-buffer) - (const save-buffer) - (const write-file) - (const undo) - (const cut) - (const copy) - (const paste) - (const search-forward) - (const print-buffer) - (const customize) - (const help)) - (repeat :inline t - :tag "Other" - (symbol :tag "Icon item"))))) - -(defcustom gmm-tool-bar-style - (if (and (boundp 'tool-bar-mode) - tool-bar-mode - (not (memq (display-visual-class) - (list 'static-gray 'gray-scale - 'static-color 'pseudo-color)))) - 'gnome - 'retro) - "Preferred tool bar style." - :type '(choice (const :tag "GNOME style" gnome) - (const :tag "Retro look" retro))) +(defvar gmm-tool-bar-style 'gnome) +(make-obsolete-variable 'gmm-tool-bar-style nil "29.1") (defvar tool-bar-map) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 550f4e940a8..04d19e29a3a 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -983,66 +983,36 @@ simple manner." (gnus-run-hooks 'gnus-group-menu-hook))) - (defvar gnus-group-tool-bar-map nil) -(defun gnus-group-tool-bar-update (&optional symbol value) - "Update group buffer toolbar. -Setter function for custom variables." - (when symbol - (set-default symbol value)) - ;; (setq-default gnus-group-tool-bar-map nil) - ;; (use-local-map gnus-group-mode-map) - (when (gnus-alive-p) - (with-current-buffer gnus-group-buffer - (gnus-group-make-tool-bar t)))) - -(defcustom gnus-group-tool-bar (if (eq gmm-tool-bar-style 'gnome) - 'gnus-group-tool-bar-gnome - 'gnus-group-tool-bar-retro) - "Specifies the Gnus group tool bar. - -It can be either a list or a symbol referring to a list. See -`gmm-tool-bar-from-list' for the format of the list. The -default key map is `gnus-group-mode-map'. - -Pre-defined symbols include `gnus-group-tool-bar-gnome' and -`gnus-group-tool-bar-retro'." - :type '(choice (const :tag "GNOME style" gnus-group-tool-bar-gnome) - (const :tag "Retro look" gnus-group-tool-bar-retro) - (repeat :tag "User defined list" gmm-tool-bar-item) - (symbol)) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-group-tool-bar-update - :group 'gnus-group) - -(defcustom gnus-group-tool-bar-gnome +(defcustom gnus-group-tool-bar '((gnus-group-post-news "mail/compose") ;; Some useful agent icons? I don't use the agent so agent users should ;; suggest useful commands: - (gnus-agent-toggle-plugged "unplugged" t - :help "Gnus is currently unplugged. Click to work online." - :visible (and gnus-agent (not gnus-plugged))) - (gnus-agent-toggle-plugged "plugged" t - :help "Gnus is currently plugged. Click to work offline." - :visible (and gnus-agent gnus-plugged)) - ;; FIXME: gnus-agent-toggle-plugged (in gnus-agent-group-make-menu-bar) - ;; should have a better help text. - (gnus-group-send-queue "mail/outbox" t - :visible (and gnus-agent gnus-plugged) - :help "Send articles from the queue group") - (gnus-group-get-new-news "mail/inbox" nil - :visible (or (not gnus-agent) - gnus-plugged)) - ;; FIXME: gnus-*-read-group should have a better help text. - (gnus-topic-read-group "open" nil - :visible (and (boundp 'gnus-topic-mode) - gnus-topic-mode)) - (gnus-group-read-group "open" nil - :visible (not (and (boundp 'gnus-topic-mode) - gnus-topic-mode))) - ;; (gnus-group-find-new-groups "???" nil) + (gnus-agent-toggle-plugged + "unplugged" t + :help "Gnus is currently unplugged. Click to work online." + :visible (and gnus-agent (not gnus-plugged))) + (gnus-agent-toggle-plugged + "plugged" t + :help "Gnus is currently plugged. Click to work offline." + :visible (and gnus-agent gnus-plugged)) + (gnus-group-send-queue + "mail/outbox" t + :visible (and gnus-agent gnus-plugged) + :help "Send articles from the queue group") + (gnus-group-get-new-news + "mail/inbox" nil + :visible (or (not gnus-agent) + gnus-plugged)) + (gnus-topic-read-group + "open" nil + :visible (and (boundp 'gnus-topic-mode) + gnus-topic-mode)) + (gnus-group-read-group + "open" nil + :visible (not (and (boundp 'gnus-topic-mode) + gnus-topic-mode))) (gnus-group-save-newsrc "save") (gnus-group-describe-group "describe") (gnus-group-toggle-subscription-at-point "gnus/toggle-subscription") @@ -1051,44 +1021,22 @@ Pre-defined symbols include `gnus-group-tool-bar-gnome' and (gnus-group-exit "exit") (gmm-customize-mode "preferences" t :help "Edit mode preferences") (gnus-info-find-node "help")) - "List of functions for the group tool bar (GNOME style). + "Specifies the Gnus group tool bar. -See `gmm-tool-bar-from-list' for the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-group-tool-bar-update +It can be either a list or a symbol referring to a list. See +`gmm-tool-bar-from-list' for the format of the list. The +default key map is `gnus-group-mode-map'." + :type '(choice (repeat :tag "User defined list" gmm-tool-bar-item) + (symbol)) + :version "29.1" :group 'gnus-group) -(defcustom gnus-group-tool-bar-retro - '((gnus-group-get-new-news "gnus/get-news") - (gnus-group-get-new-news-this-group "gnus/gnntg") - (gnus-group-catchup-current "gnus/catchup") - (gnus-group-describe-group "gnus/describe-group") - (gnus-group-subscribe "gnus/subscribe" t - :help "Subscribe to the current group") - (gnus-group-unsubscribe "gnus/unsubscribe" t - :help "Unsubscribe from the current group") - (gnus-group-exit "gnus/exit-gnus" gnus-group-mode-map)) - "List of functions for the group tool bar (retro look). - -See `gmm-tool-bar-from-list' for the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-group-tool-bar-update - :group 'gnus-group) - -(defcustom gnus-group-tool-bar-zap-list t - "List of icon items from the global tool bar. -These items are not displayed in the Gnus group mode tool bar. - -See `gmm-tool-bar-from-list' for the format of the list." - :type 'gmm-tool-bar-zap-list - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-group-tool-bar-update - :group 'gnus-group) +(defvar gnus-group-tool-bar-gnome nil) +(make-obsolete-variable 'gnus-group-tool-bar-gnome nil "29.1") +(defvar gnus-group-tool-bar-retro nil) +(make-obsolete-variable 'gnus-group-tool-bar-retro nil "29.1") +(defvar gnus-group-tool-bar-zap-list t) +(make-obsolete-variable 'gnus-group-tool-bar-zap-list nil "29.1") (defvar image-load-path) (defvar tool-bar-map) diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index 45f1e6099ea..87f3ee63623 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -40,14 +40,11 @@ (require 'help-fns) (require 'url-queue) -(defcustom gnus-html-image-cache-ttl (days-to-time 7) - "Time used to determine if we should use images from the cache." - :version "24.1" +(defcustom gnus-html-image-cache-ttl (time-convert (days-to-time 7) 'integer) + "Number of seconds used to determine if we should use images from the cache." + :version "29.1" :group 'gnus-art - ;; FIXME hardly the friendliest type. The allowed value is actually - ;; any time value, but we are assuming no-one cares about USEC and - ;; PSEC here. It would be better to eg make it a number of minutes. - :type '(list integer integer)) + :type 'number) (defcustom gnus-html-image-automatic-caching t "Whether automatically cache retrieve images." diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index f38f6f4ee2b..17a87134be0 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -1571,8 +1571,9 @@ this is a reply." (when gcc (message-remove-header "gcc") (widen) - (setq groups (message-unquote-tokens - (message-tokenize-header gcc ",\n\t"))) + (setq groups (mapcar #'string-trim + (message-unquote-tokens + (message-tokenize-header gcc)))) ;; Copy the article over to some group(s). (while (setq group (pop groups)) (setq method (gnus-inews-group-method group)) @@ -1593,9 +1594,10 @@ this is a reply." (nnheader-set-temp-buffer " *acc*") (setq message-options (with-current-buffer cur message-options)) (insert-buffer-substring cur) + (restore-buffer-modified-p nil) (run-hooks 'gnus-gcc-pre-body-encode-hook) ;; Avoid re-doing things like GPG-encoding secret parts. - (if (not encoded-cache) + (if (or (buffer-modified-p) (not encoded-cache)) (message-encode-message-body) (erase-buffer) (insert encoded-cache)) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 4ca873eeec9..369df81d9bd 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -349,6 +349,41 @@ This variable can also be set per-server." :version "28.1" :type 'boolean) +(defcustom gnus-search-mu-program "mu" + "Name of the mu search executable. +This can also be set per-server." + :version "29.1" + :type 'string) + +(defcustom gnus-search-mu-switches nil + "A list of strings, to be given as additional arguments to mu. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-mu-switches \"-u -r\") +Instead, use this: + (setq gnus-search-mu-switches \\='(\"-u\" \"-r\")) +This can also be set per-server." + :version "29.1" + :type '(repeat string)) + +(defcustom gnus-search-mu-remove-prefix (expand-file-name "~/Mail/") + "A prefix to remove from the mu results to get a group name. +Usually this will be set to the path to your mail directory. This +can also be set per-server." + :version "29.1" + :type 'directory) + +(defcustom gnus-search-mu-config-directory (expand-file-name "~/.cache/mu") + "Configuration directory for mu. +This can also be set per-server." + :version "29.1" + :type 'file) + +(defcustom gnus-search-mu-raw-queries-p nil + "If t, all mu engines will only accept raw search query strings. +This can also be set per-server." + :version "29.1" + :type 'boolean) + ;; Options for search language parsing. (defcustom gnus-search-expandable-keys @@ -903,6 +938,18 @@ quirks.") (raw-queries-p :initform (symbol-value 'gnus-search-notmuch-raw-queries-p)))) +(defclass gnus-search-mu (gnus-search-indexed) + ((program + :initform (symbol-value 'gnus-search-mu-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-mu-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-mu-switches)) + (config-directory + :initform (symbol-value 'gnus-search-mu-config-directory)) + (raw-queries-p + :initform (symbol-value 'gnus-search-mu-raw-queries-p)))) + (define-obsolete-variable-alias 'nnir-method-default-engines 'gnus-search-default-engines "28.1") @@ -1290,7 +1337,11 @@ elements are present." (cl-defmethod gnus-search-imap-handle-string ((engine gnus-search-imap) (str string)) (with-slots (literal-plus) engine - (if (multibyte-string-p str) + ;; TODO: Figure out how Exchange IMAP servers actually work. They + ;; do not accept any CHARSET but US-ASCII, but they do report + ;; Literal+ capability. So what do we do? Will quoted strings + ;; always work? + (if (string-match-p "[^[:ascii:]]" str) ;; If LITERAL+ is available, use it and encode string as ;; UTF-8. (if literal-plus @@ -1849,6 +1900,101 @@ Assume \"size\" key is equal to \"larger\"." (when (alist-get 'thread query) (list "-t")) (list qstring)))) +;;; Mu interface + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mu) + (expr list)) + (cl-case (car expr) + (recipient (setf (car expr) 'recip)) + (address (setf (car expr) 'contact)) + (id (setf (car expr) 'msgid)) + (attachment (setf (car expr) 'file))) + (cl-flet () + (cond + ((consp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ;; Explicitly leave out 'date as gnus-search will encode it + ;; first; it is handled later + ((memq (car expr) '(cc c bcc h from f to t subject s body b + maildir m msgid i prio p flag g d + size z embed e file j mime y tag x + list v)) + (format "%s:%s" (car expr) + (if (string-match "\\`\\*" (cdr expr)) + (replace-match "" nil nil (cdr expr)) + (cdr expr)))) + ((eq (car expr) 'mark) + (format "flag:%s" (gnus-search-mu-handle-flag (cdr expr)))) + ((eq (car expr) 'date) + (format "date:%s" (gnus-search-mu-handle-date (cdr expr)))) + ((eq (car expr) 'before) + (format "date:..%s" (gnus-search-mu-handle-date (cdr expr)))) + ((eq (car expr) 'since) + (format "date:%s.." (gnus-search-mu-handle-date (cdr expr)))) + (t (ignore-errors (cl-call-next-method)))))) + +(defun gnus-search-mu-handle-date (date) + (if (stringp date) + date + (pcase date + (`(nil ,m nil) + (nth (1- m) gnus-english-month-names)) + (`(nil nil ,y) + (number-to-string y)) + ;; mu prefers ISO date YYYY-MM-DD HH:MM:SS + (`(,d ,m nil) + (let* ((ct (decode-time)) + (cm (decoded-time-month ct)) + (cy (decoded-time-year ct)) + (y (if (> cm m) + cy + (1- cy)))) + (format "%d-%02d-%02d" y m d))) + (`(nil ,m ,y) + (format "%d-%02d" y m)) + (`(,d ,m ,y) + (format "%d-%02d-%02d" y m d))))) + +(defun gnus-search-mu-handle-flag (flag) + ;; Only change what doesn't match + (cond ((string= flag "flag") + "flagged") + ((string= flag "read") + "seen") + (t + flag))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-mu)) + (prog1 + (let ((bol (line-beginning-position)) + (eol (line-end-position))) + (list (buffer-substring-no-properties bol eol) + 100)) + (move-beginning-of-line 2))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-mu) + (qstring string) + query &optional groups) + (let ((limit (alist-get 'limit query)) + (thread (alist-get 'thread query))) + (with-slots (switches config-directory) engine + `("find" ; command must come first + "--nocolor" ; mu will always give coloured output otherwise + ,(format "--muhome=%s" config-directory) + ,@switches + ,(if thread "-r" "") + ,(if limit (format "--maxnum=%d" limit) "") + ,qstring + ,@(if groups + `("and" "(" + ,@(nbutlast (mapcan (lambda (x) + (list (concat "maildir:/" x) "or")) + groups)) + ")") + "") + "--format=plain" + "--fields=l")))) + ;;; Find-grep interface (cl-defmethod gnus-search-transform-expression ((_engine gnus-search-find-grep) @@ -1983,9 +2129,9 @@ Assume \"size\" key is equal to \"larger\"." (defun gnus-search-prepare-query (query-spec) "Accept a search query in raw format, and prepare it. QUERY-SPEC is an alist produced by functions such as -`gnus-group-make-search-group', and contains at least a 'query +`gnus-group-make-search-group', and contains at least a `query' key, and possibly some meta keys. This function extracts any -additional meta keys from the 'query string, and parses the +additional meta keys from the `query' string, and parses the remaining string, then adds all that to the top-level spec." (let ((query (alist-get 'query query-spec)) val) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 1be5a48068c..a4f98c91573 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -2887,45 +2887,11 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) (defvar gnus-summary-tool-bar-map nil) -;; Note: The :set function in the `gnus-summary-tool-bar*' variables will only -;; affect _new_ message buffers. We might add a function that walks thru all -;; summary-mode buffers and force the update. -(defun gnus-summary-tool-bar-update (&optional symbol value) - "Update summary mode toolbar. -Setter function for custom variables." - (setq-default gnus-summary-tool-bar-map nil) - (when symbol - ;; When used as ":set" function: - (set-default symbol value)) - (when (gnus-buffer-live-p gnus-summary-buffer) - (with-current-buffer gnus-summary-buffer - (gnus-summary-make-tool-bar)))) - -(defcustom gnus-summary-tool-bar (if (eq gmm-tool-bar-style 'gnome) - 'gnus-summary-tool-bar-gnome - 'gnus-summary-tool-bar-retro) - "Specifies the Gnus summary tool bar. - -It can be either a list or a symbol referring to a list. See -`gmm-tool-bar-from-list' for the format of the list. The -default key map is `gnus-summary-mode-map'. - -Pre-defined symbols include `gnus-summary-tool-bar-gnome' and -`gnus-summary-tool-bar-retro'." - :type '(choice (const :tag "GNOME style" gnus-summary-tool-bar-gnome) - (const :tag "Retro look" gnus-summary-tool-bar-retro) - (repeat :tag "User defined list" gmm-tool-bar-item) - (symbol)) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-summary-tool-bar-update - :group 'gnus-summary) - -(defcustom gnus-summary-tool-bar-gnome +(defcustom gnus-summary-tool-bar '((gnus-summary-post-news "mail/compose" nil) - (gnus-summary-insert-new-articles "mail/inbox" nil - :visible (or (not gnus-agent) - gnus-plugged)) + (gnus-summary-insert-new-articles + "mail/inbox" nil + :visible (or (not gnus-agent) gnus-plugged)) (gnus-summary-reply-with-original "mail/reply") (gnus-summary-reply "mail/reply" nil :visible nil) (gnus-summary-followup-with-original "mail/reply-all") @@ -2935,17 +2901,10 @@ Pre-defined symbols include `gnus-summary-tool-bar-gnome' and (gnus-summary-search-article-forward "search" nil :visible nil) (gnus-summary-print-article "print") (gnus-summary-tick-article-forward "flag-followup" nil :visible nil) - ;; Some new commands that may need more suitable icons: (gnus-summary-save-newsrc "save" nil :visible nil) - ;; (gnus-summary-show-article "stock_message-display" nil :visible nil) (gnus-summary-prev-article "left-arrow") (gnus-summary-next-article "right-arrow") (gnus-summary-next-page "next-page") - ;; (gnus-summary-enter-digest-group "right_arrow" nil :visible nil) - ;; - ;; Maybe some sort-by-... could be added: - ;; (gnus-summary-sort-by-author "sort-a-z" nil :visible nil) - ;; (gnus-summary-sort-by-date "sort-1-9" nil :visible nil) (gnus-summary-mark-as-expirable "delete" nil :visible (gnus-check-backend-function 'request-expire-articles @@ -2959,64 +2918,25 @@ Pre-defined symbols include `gnus-summary-tool-bar-gnome' and "mail/not-spam" nil :visible (and (fboundp 'spam-group-spam-contents-p) (spam-group-spam-contents-p gnus-newsgroup-name))) - ;; (gnus-summary-exit "exit") (gmm-customize-mode "preferences" t :help "Edit mode preferences") (gnus-info-find-node "help")) - "List of functions for the summary tool bar (GNOME style). + "Specifies the Gnus summary tool bar. -See `gmm-tool-bar-from-list' for the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-summary-tool-bar-update +It can be either a list or a symbol referring to a list. See +`gmm-tool-bar-from-list' for the format of the list. The +default key map is `gnus-summary-mode-map'." + :type '(choice (repeat :tag "User defined list" gmm-tool-bar-item) + (symbol)) + :version "29.1" :group 'gnus-summary) -(defcustom gnus-summary-tool-bar-retro - '((gnus-summary-prev-unread-article "gnus/prev-ur") - (gnus-summary-next-unread-article "gnus/next-ur") - (gnus-summary-post-news "gnus/post") - (gnus-summary-followup-with-original "gnus/fuwo") - (gnus-summary-followup "gnus/followup") - (gnus-summary-reply-with-original "gnus/reply-wo") - (gnus-summary-reply "gnus/reply") - (gnus-summary-caesar-message "gnus/rot13") - (gnus-uu-decode-uu "gnus/uu-decode") - (gnus-summary-save-article-file "gnus/save-aif") - (gnus-summary-save-article "gnus/save-art") - (gnus-uu-post-news "gnus/uu-post") - (gnus-summary-catchup "gnus/catchup") - (gnus-summary-catchup-and-exit "gnus/cu-exit") - (gnus-summary-exit "gnus/exit-summ") - ;; Some new command that may need more suitable icons: - (gnus-summary-print-article "gnus/print" nil :visible nil) - (gnus-summary-mark-as-expirable "gnus/close" nil :visible nil) - (gnus-summary-save-newsrc "gnus/save" nil :visible nil) - ;; (gnus-summary-enter-digest-group "gnus/right_arrow" nil :visible nil) - (gnus-summary-search-article-forward "gnus/search" nil :visible nil) - ;; (gnus-summary-insert-new-articles "gnus/paste" nil :visible nil) - ;; (gnus-summary-toggle-threads "gnus/open" nil :visible nil) - ;; - (gnus-info-find-node "gnus/help" nil :visible nil)) - "List of functions for the summary tool bar (retro look). - -See `gmm-tool-bar-from-list' for the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-summary-tool-bar-update - :group 'gnus-summary) - -(defcustom gnus-summary-tool-bar-zap-list t - "List of icon items from the global tool bar. -These items are not displayed in the Gnus summary mode tool bar. - -See `gmm-tool-bar-from-list' for the format of the list." - :type 'gmm-tool-bar-zap-list - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-summary-tool-bar-update - :group 'gnus-summary) +(defvar gnus-summary-tool-bar-gnome nil) +(make-obsolete-variable 'gnus-summary-tool-bar-gnome nil "29.1") +(defvar gnus-summary-tool-bar-retro nil) +(make-obsolete-variable 'gnus-summary-tool-bar-retro nil "29.1") +(defvar gnus-summary-tool-bar-zap-list t) +(make-obsolete-variable 'gnus-summary-tool-bar-zap-list nil "29.1") (defvar image-load-path) (defvar tool-bar-map) @@ -8663,7 +8583,7 @@ these articles." (when matching-subject (gnus-summary-limit-include-matching-articles "subject" - matching-subject) + (regexp-quote matching-subject)) ;; Each of the previous two limit calls push a limit onto ;; the limit stack. Presumably we want to think of the ;; thread and its associated subject matches as a single @@ -9445,6 +9365,16 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (push primary urls)) (delete-dups urls))) +(defun gnus-collect-urls-from-article () + "Select the article and return the list of URLs in it. +See `gnus-collect-urls'." + (gnus-summary-select-article) + (gnus-with-article-buffer + (article-goto-body) + ;; Back up a char, in case body starts with a button. + (backward-char) + (gnus-collect-urls))) + (defun gnus-shorten-url (url max) "Return an excerpt from URL not exceeding MAX characters." (if (<= (length url) max) @@ -9460,33 +9390,27 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." "Scan the current article body for links, and offer to browse them. Links are opened using `browse-url' unless a prefix argument is -given: Then `browse-url-secondary-browser-function' is used instead. +given: then `browse-url-secondary-browser-function' is used instead. If only one link is found, browse that directly, otherwise use completion to select a link. The first link marked in the article text with `gnus-collect-urls-primary-text' is the default." (interactive "P" gnus-summary-mode) - (let (urls target) - (gnus-summary-select-article) - (gnus-with-article-buffer - (article-goto-body) - ;; Back up a char, in case body starts with a button. - (backward-char) - (setq urls (gnus-collect-urls)) - (setq target - (cond ((= (length urls) 1) - (car urls)) - ((> (length urls) 1) - (completing-read - (format-prompt "URL to browse" - (gnus-shorten-url (car urls) 40)) - urls nil t nil nil (car urls))))) - (if target - (if external - (funcall browse-url-secondary-browser-function target) - (browse-url target)) - (message "No URLs found."))))) + (let* ((urls (gnus-collect-urls-from-article)) + (target + (cond ((= (length urls) 1) + (car urls)) + ((> (length urls) 1) + (completing-read + (format-prompt "URL to browse" + (gnus-shorten-url (car urls) 40)) + urls nil t nil nil (car urls)))))) + (if target + (if external + (funcall browse-url-secondary-browser-function target) + (browse-url target)) + (message "No URLs found.")))) (defun gnus-summary-isearch-article (&optional regexp-p) "Do incremental search forward on the current article. diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index c079d889d98..fa942bee8e8 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -650,6 +650,7 @@ articles in the topic and its subtopics." (let* ((visible (if visiblep "" "...")) (level level) (name name) + (entries entries) (indentation (make-string (* gnus-topic-indent-level level) ? )) (total-number-of-articles unread) (number-of-groups (length entries)) @@ -677,7 +678,7 @@ articles in the topic and its subtopics." (defun gnus-topic-update-topics-containing-group (group) "Update all topics that have GROUP as a member." - (when (and (eq major-mode 'gnus-topic-mode) + (when (and (derived-mode-p 'gnus-group-mode) gnus-topic-mode) (save-excursion (let ((alist gnus-topic-alist)) @@ -693,7 +694,7 @@ articles in the topic and its subtopics." (defun gnus-topic-update-topic () "Update all parent topics to the current group." - (when (and (eq major-mode 'gnus-topic-mode) + (when (and (derived-mode-p 'gnus-group-mode) gnus-topic-mode) (let ((group (gnus-group-group-name)) (m (point-marker)) @@ -747,8 +748,8 @@ articles in the topic and its subtopics." (car type) (car gnus-group-list-mode) (cdr gnus-group-list-mode))) (all-groups (gnus-topic-find-groups - (car type) (car gnus-group-list-mode) - (cdr gnus-group-list-mode) nil t)) + (car type) (car gnus-group-list-mode) + (cdr gnus-group-list-mode) nil t)) entry) (while children (cl-incf unread (gnus-topic-unread (caar (pop children))))) @@ -787,8 +788,8 @@ articles in the topic and its subtopics." (car type) (car gnus-group-list-mode) (cdr gnus-group-list-mode))) (all-groups (gnus-topic-find-groups - (car type) (car gnus-group-list-mode) - (cdr gnus-group-list-mode) t)) + (car type) (car gnus-group-list-mode) + (cdr gnus-group-list-mode) nil t)) (parent (gnus-topic-parent-topic topic-name)) (all-entries entries) (unread 0) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 6150781fecc..218a4d242b2 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -562,7 +562,7 @@ If N, return the Nth ancestor instead." buffer)) (define-obsolete-function-alias 'gnus-buffer-exists-p - 'gnus-buffer-live-p "27.1") + #'gnus-buffer-live-p "27.1") (defun gnus-horizontal-recenter () "Recenter the current buffer horizontally." @@ -680,7 +680,7 @@ yield \"nnimap:yxa\"." (defun gnus-turn-off-edit-menu (type) "Turn off edit menu in `gnus-TYPE-mode-map'." (define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) - [menu-bar edit] 'undefined)) + [menu-bar edit] #'undefined)) (defvar print-string-length) @@ -954,9 +954,9 @@ ARG is passed to the first function." (with-current-buffer gnus-group-buffer (eq major-mode 'gnus-group-mode)))) -(define-obsolete-function-alias 'gnus-remove-if 'seq-remove "27.1") +(define-obsolete-function-alias 'gnus-remove-if #'seq-remove "27.1") -(define-obsolete-function-alias 'gnus-remove-if-not 'seq-filter "27.1") +(define-obsolete-function-alias 'gnus-remove-if-not #'seq-filter "27.1") (defun gnus-grep-in-list (word list) "Find if a WORD matches any regular expression in the given LIST." @@ -1091,9 +1091,10 @@ ARG is passed to the first function." (defun gnus-byte-compile (form) "Byte-compile FORM if `gnus-use-byte-compile' is non-nil." (if gnus-use-byte-compile - (let ((byte-compile-warnings '(unresolved callargs redefine))) + (let ((byte-compile-warnings '(unresolved callargs redefine)) + (lexical-binding t)) (byte-compile form)) - form)) + (eval form t))) (defun gnus-remassoc (key alist) "Delete by side effect any elements of LIST whose car is `equal' to KEY. diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 0daecf7df54..1f673771fa1 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -662,12 +662,11 @@ be used directly.") (gnus-prune-buffers) (cl-pushnew (current-buffer) gnus-buffers)) -(defmacro gnus-kill-buffer (buffer) +(defun gnus-kill-buffer (buffer) "Kill BUFFER and remove from the list of Gnus buffers." - `(let ((buf ,buffer)) - (when (gnus-buffer-live-p buf) - (kill-buffer buf) - (gnus-prune-buffers)))) + (when (gnus-buffer-live-p buffer) + (kill-buffer buffer) + (gnus-prune-buffers))) (defun gnus-buffers () "Return a list of live Gnus buffers." @@ -2529,7 +2528,8 @@ are always t.") ("nnmail" nnmail-split-fancy nnmail-article-group) ("nnvirtual" nnvirtual-catchup-group nnvirtual-convert-headers) ("gnus-xmas" gnus-xmas-splash) - ("score-mode" :interactive t gnus-score-mode gnus-score-edit-all-score) + ("score-mode" :interactive t gnus-score-mode) + ("gnus-score" :interactive t gnus-score-edit-all-score) ("gnus-mh" gnus-summary-save-article-folder gnus-Folder-save-name gnus-folder-save-name) ("gnus-mh" :interactive (gnus-summary-mode) gnus-summary-save-in-folder) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 5d0c0e2654b..320bc9c3b0e 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -413,7 +413,7 @@ the `mail-source-keyword-map' variable." (let* ((type (pop source)) (defaults (cdr (assq type mail-source-keyword-map))) (search '(:max 1)) - found default value keyword user-auth pass-auth) ;; auth-info + found default keyword user-auth pass-auth) ;; auth-info ;; append to the search the useful info from the source and the defaults: ;; user, host, and port @@ -440,22 +440,22 @@ the `mail-source-keyword-map' variable." ;; for each default :SYMBOL, set SYMBOL to the plist value for :SYMBOL ;; using `mail-source-value' to evaluate the plist value (set (mail-source-strip-keyword (setq keyword (car default))) - ;; note the following reasons for this structure: + ;; Note the following reasons for this structure: ;; 1) the auth-sources user and password override everything ;; 2) it avoids macros, so it's cleaner ;; 3) it falls through to the mail-sources and then default values (cond ((and - (eq keyword :user) - (setq user-auth - (plist-get - ;; cache the search result in `found' - (or found - (setq found (nth 0 (apply #'auth-source-search - search)))) - :user))) + (eq keyword :user) + (setq user-auth + (plist-get + ;; cache the search result in `found' + (or found + (setq found (nth 0 (apply #'auth-source-search + search)))) + :user))) user-auth) - ((and ; cf. 'auth-source-pick-first-password' + ((and ; cf. 'auth-source-pick-first-password' (eq keyword :password) (setq pass-auth (plist-get @@ -468,9 +468,8 @@ the `mail-source-keyword-map' variable." (if (functionp pass-auth) (setq pass-auth (funcall pass-auth)) pass-auth)) - (t (if (setq value (plist-get source keyword)) - (mail-source-value value) - (mail-source-value (cadr default))))))))) + (t (mail-source-value (or (plist-get source keyword) + (cadr default))))))))) (eval-and-compile (defun mail-source-bind-common-1 () @@ -1066,9 +1065,7 @@ This only works when `display-time' is enabled." (let ((from (format "%s:%s:%s" server user port)) (found 0) (buf (generate-new-buffer " *imap source*")) - (mail-source-string (format "imap:%s:%s" server mailbox)) - (imap-shell-program (or (list program) imap-shell-program)) - remove) + (imap-shell-program (or (list program) imap-shell-program))) (if (and (imap-open server port stream authentication buf) (imap-authenticate user (or (cdr (assoc from mail-source-password-cache)) @@ -1077,8 +1074,10 @@ This only works when `display-time' is enabled." (let ((mailbox-list (if (listp mailbox) mailbox (list mailbox)))) (dolist (mailbox mailbox-list) (when (imap-mailbox-select mailbox nil buf) - (let ((coding-system-for-write mail-source-imap-file-coding-system) - str) + (let ((coding-system-for-write + mail-source-imap-file-coding-system) + (mail-source-string (format "imap:%s:%s" server mailbox)) + str remove) (message "Fetching from %s..." mailbox) (with-temp-file mail-source-crash-box ;; Avoid converting 8-bit chars from inserted strings to diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index a5b3d404671..e7dc089a3c6 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -50,6 +50,7 @@ (require 'subr-x) (require 'yank-media) (require 'mailcap) +(require 'sendmail) (autoload 'mailclient-send-it "mailclient") @@ -8016,7 +8017,18 @@ is for the internal use." (select-safe-coding-system-function nil) message-required-mail-headers message-generate-hashcash - rfc2047-encode-encoded-words) + rfc2047-encode-encoded-words + ;; If `message-sendmail-envelope-from' is `header' then + ;; the envelope-from will be the original sender's + ;; address, not the resender's. But when resending, the + ;; envelope-from should be the resender's address. Defuse + ;; that particular case. + (message-sendmail-envelope-from + (and (not (and (eq message-sendmail-envelope-from + 'obey-mail-envelope-from) + (eq mail-envelope-from 'header))) + (not (eq message-sendmail-envelope-from 'header)) + message-sendmail-envelope-from))) (message-send-mail)) (when gcc (message-goto-eoh) @@ -8155,39 +8167,7 @@ which specify the range to operate on." ;; Support for toolbar (defvar tool-bar-mode) -;; Note: The :set function in the `message-tool-bar*' variables will only -;; affect _new_ message buffers. We might add a function that walks thru all -;; message-mode buffers and force the update. -(defun message-tool-bar-update (&optional symbol value) - "Update message mode toolbar. -Setter function for custom variables." - (setq-default message-tool-bar-map nil) - (when symbol - ;; When used as ":set" function: - (set-default symbol value))) - -(defcustom message-tool-bar (if (eq gmm-tool-bar-style 'gnome) - 'message-tool-bar-gnome - 'message-tool-bar-retro) - "Specifies the message mode tool bar. - -It can be either a list or a symbol referring to a list. See -`gmm-tool-bar-from-list' for the format of the list. The -default key map is `message-mode-map'. - -Pre-defined symbols include `message-tool-bar-gnome' and -`message-tool-bar-retro'." - :type '(repeat gmm-tool-bar-list-item) - :type '(choice (const :tag "GNOME style" message-tool-bar-gnome) - (const :tag "Retro look" message-tool-bar-retro) - (repeat :tag "User defined list" gmm-tool-bar-item) - (symbol)) - :version "23.1" ;; No Gnus - :initialize #'custom-initialize-default - :set #'message-tool-bar-update - :group 'message) - -(defcustom message-tool-bar-gnome +(defcustom message-tool-bar '((ispell-message "spell" nil :vert-only t :visible (not flyspell-mode)) @@ -8203,47 +8183,23 @@ Pre-defined symbols include `message-tool-bar-gnome' and (message-insert-importance-high "important" nil :visible nil) (message-insert-importance-low "unimportant" nil :visible nil) (message-insert-disposition-notification-to "receipt" nil :visible nil)) - "List of items for the message tool bar (GNOME style). + "Specifies the message mode tool bar. -See `gmm-tool-bar-from-list' for details on the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize #'custom-initialize-default - :set #'message-tool-bar-update +It can be either a list or a symbol referring to a list. See +`gmm-tool-bar-from-list' for the format of the list. The +default key map is `message-mode-map'." + :type '(repeat gmm-tool-bar-list-item) + :type '(choice (repeat :tag "User defined list" gmm-tool-bar-item) + (symbol)) + :version "29.1" :group 'message) -(defcustom message-tool-bar-retro - '(;; Old Emacs 21 icon for consistency. - (message-send-and-exit "mail/send") - (message-kill-buffer "close") - (message-dont-send "cancel") - (mml-attach-file "attach" mml-mode-map) - (ispell-message "spell") - (mml-preview "preview" mml-mode-map) - (message-insert-importance-high "gnus/important") - (message-insert-importance-low "gnus/unimportant") - (message-insert-disposition-notification-to "gnus/receipt")) - "List of items for the message tool bar (retro style). - -See `gmm-tool-bar-from-list' for details on the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize #'custom-initialize-default - :set #'message-tool-bar-update - :group 'message) - -(defcustom message-tool-bar-zap-list - '(new-file open-file dired kill-buffer write-file - print-buffer customize help) - "List of icon items from the global tool bar. -These items are not displayed on the message mode tool bar. - -See `gmm-tool-bar-from-list' for the format of the list." - :type 'gmm-tool-bar-zap-list - :version "23.1" ;; No Gnus - :initialize #'custom-initialize-default - :set #'message-tool-bar-update - :group 'message) +(defvar message-tool-bar-gnome nil) +(make-obsolete-variable 'message-tool-bar-gnome nil "29.1") +(defvar message-tool-bar-retro nil) +(make-obsolete-variable 'message-tool-bar-gnome nil "29.1") +(defvar message-tool-bar-zap-list t) +(make-obsolete-variable 'message-tool-bar-zap-list nil "29.1") (defvar image-load-path) (declare-function image-load-path-for-library "image" @@ -8265,17 +8221,23 @@ When FORCE, rebuild the tool bar." 'message-mode-map)))) message-tool-bar-map) -;;; Group name completion. +;;; Group name and email address completion. (defcustom message-newgroups-header-regexp "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):" - "Regexp that match headers that lists groups." + "Regexp matching headers that list groups." :group 'message :type 'regexp) +(defcustom message-email-recipient-header-regexp + "^\\([^ :]*-\\)?\\(To\\|B?Cc\\|From\\|Reply-to\\|Mail-Followup-To\\|Mail-Copies-To\\):" + "Regexp matching headers that list email addresses." + :version "29.1" + :type 'regexp) + (defcustom message-completion-alist `((,message-newgroups-header-regexp . ,#'message-expand-group) - ("^\\([^ :]*-\\)?\\(To\\|B?Cc\\|From\\):" . ,#'message-expand-name)) + (,message-email-recipient-header-regexp . ,#'message-expand-name)) "Alist of (RE . FUN). Use FUN for completion on header lines matching RE. FUN should be a function that obeys the same rules as those of `completion-at-point-functions'." @@ -8990,7 +8952,7 @@ used to take the screenshot." This is meant to be used for MIME handlers: Setting the handler for \"x-scheme-handler/mailto;\" to \"emacs -f message-mailto %u\" will then start up Emacs ready to compose mail. For emacsclient use - emacsclient -e '(message-mailto \"%u\")'" + emacsclient -e \\='(message-mailto \"%u\")'" (interactive) ;; Send email (message-mail) diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el index 956449dac14..9045966df5a 100644 --- a/lisp/gnus/mm-bodies.el +++ b/lisp/gnus/mm-bodies.el @@ -191,19 +191,21 @@ If TYPE is `text/plain' CRLF->LF translation may occur." ((eq encoding 'base64) (base64-decode-region (point-min) - ;; Some mailers insert whitespace - ;; junk at the end which - ;; base64-decode-region dislikes. - ;; Also remove possible junk which could - ;; have been added by mailing list software. (save-excursion + ;; Some mailers insert whitespace junk at the end which + ;; base64-decode-region dislikes. (goto-char (point-min)) (while (re-search-forward "^[\t ]*\r?\n" nil t) (delete-region (match-beginning 0) (match-end 0))) + ;; Also ignore junk which could have been added by + ;; mailing list software by finding the final line with + ;; base64 text. (goto-char (point-max)) - (when (re-search-backward "^[\t ]*[A-Za-z0-9+/]+=*[\t ]*$" - nil t) - (forward-line)) + (beginning-of-line) + (while (and (not (mm-base64-line-p)) + (not (bobp))) + (forward-line -1)) + (forward-line 1) (point)))) ((memq encoding '(nil 7bit 8bit binary)) ;; Do nothing. @@ -236,6 +238,20 @@ If TYPE is `text/plain' CRLF->LF translation may occur." (while (search-forward "\r\n" nil t) (replace-match "\n" t t))))) +(defun mm-base64-line-p () + "Say whether the current line is base64." + ;; This is coded in this way to avoid using regexps that may + ;; overflow -- a base64 line may be megabytes long. + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (and (looking-at "[A-Za-z0-9+/]\\{3\\}") + (progn + (skip-chars-forward "A-Za-z0-9+/") + (skip-chars-forward "=") + (skip-chars-forward " \t") + (eolp))))) + (defun mm-decode-body (charset &optional encoding type) "Decode the current article that has been encoded with ENCODING to CHARSET. ENCODING is a MIME content transfer encoding. diff --git a/lisp/gnus/mm-encode.el b/lisp/gnus/mm-encode.el index ead3bae219d..39b1ad1f3b9 100644 --- a/lisp/gnus/mm-encode.el +++ b/lisp/gnus/mm-encode.el @@ -99,7 +99,7 @@ This variable should never be set directly, but bound before a call to ;;;###autoload (define-obsolete-function-alias 'mm-default-file-encoding - #'mm-default-file-type "future") ;Old bad name. + #'mm-default-file-type "28.1") ;Old bad name. ;;;###autoload (defun mm-default-file-type (file) "Return a default content type for FILE." diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 5a526025061..093e582ea7a 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -500,7 +500,8 @@ type detected." (when (and (consp (car cont)) (= (length cont) 1) content-type) - (setcdr (assq 'type (cdr (car cont))) content-type)) + (when-let ((spec (assq 'type (cdr (car cont))))) + (setcdr spec content-type))) (when (fboundp 'libxml-parse-html-region) (setq cont (mapcar #'mml-expand-all-html-into-multipart-related cont))) (prog1 diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index 4e8e329f983..8c811b0c6c0 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -333,7 +333,7 @@ this might lead to problems, especially when used with marks propagation." (defvar nnmairix-widget-other '(threads flags) "Other editable mairix commands when using customization widgets. -Currently there are 'threads and 'flags.") +Currently there are `threads' and `flags'.") (defvar nnmairix-interactive-query-parameters '((?f "from" "f" "From") (?t "to" "t" "To") (?c "to" "tc" "To or Cc") diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index c880d79840f..cdbfa0b5910 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -110,6 +110,7 @@ selection))) (make-obsolete 'nnselect-group-server 'gnus-group-server "28.1") +(make-obsolete 'nnselect-run 'nnselect-generate-artlist "29.1") ;; Data type article list. @@ -231,11 +232,6 @@ as `(keyfunc member)' and the corresponding element is just `(gnus-group-prefixed-name (gnus-group-short-name ,group) '(nnselect "nnselect"))) -(defmacro nnselect-get-artlist (group) - "Retrieve the list of articles for GROUP." - `(when (gnus-nnselect-group-p ,group) - (nnselect-uncompress-artlist - (gnus-group-get-parameter ,group 'nnselect-artlist t)))) (defmacro nnselect-add-novitem (novitem) "Add NOVITEM to the list of headers." @@ -271,6 +267,63 @@ If this variable is nil, or if the provided function returns nil, :version "28.1" :type '(repeat function)) +(defun nnselect-generate-artlist (group &optional specs) + "Generate the artlist for GROUP using SPECS. +SPECS should be an alist including an `nnselect-function' and an +`nnselect-args'. The former applied to the latter should create +the artlist. If SPECS is nil retrieve the specs from the group +parameters." + (let* ((specs + (or specs (gnus-group-get-parameter group 'nnselect-specs t))) + (function (alist-get 'nnselect-function specs)) + (args (alist-get 'nnselect-args specs))) + (condition-case-unless-debug err + (funcall function args) + ;; Don't swallow gnus-search errors; the user should be made + ;; aware of them. + (gnus-search-error + (signal (car err) (cdr err))) + (error + (gnus-error + 3 + "nnselect-generate-artlist: %s on %s gave error %s" function args err) + [])))) + +(defmacro nnselect-get-artlist (group) + "Get the list of articles for GROUP. +If the group parameter 'nnselect-get-artlist-override-function is +non-nil call this function with argument GROUP to get the +artlist; if the group parameter 'nnselect-always-regenerate is +non-nil, regenerate the artlist; otherwise retrieve the artlist +directly from the group parameters." + `(when (gnus-nnselect-group-p ,group) + (let ((override (gnus-group-get-parameter + ,group + 'nnselect-get-artlist-override-function))) + (cond + (override (funcall override ,group)) + ((gnus-group-get-parameter ,group 'nnselect-always-regenerate) + (nnselect-generate-artlist ,group)) + (t + (nnselect-uncompress-artlist + (gnus-group-get-parameter ,group 'nnselect-artlist t))))))) + +(defmacro nnselect-store-artlist (group artlist) + "Store the ARTLIST for GROUP. +If the group parameter 'nnselect-store-artlist-override-function +is non-nil call this function on GROUP and ARTLIST; if the group +parameter 'nnselect-always-regenerate is non-nil don't store the +artlist; otherwise store the ARTLIST in the group parameters." + `(let ((override (gnus-group-get-parameter + ,group + 'nnselect-store-artlist-override-function))) + (cond + (override (funcall override ,group ,artlist)) + ((gnus-group-get-parameter ,group 'nnselect-always-regenerate) t) + (t + (gnus-group-set-parameter ,group 'nnselect-artlist + (nnselect-compress-artlist ,artlist)))))) + ;; Gnus backend interface functions. (deffoo nnselect-open-server (server &optional definitions) @@ -296,11 +349,8 @@ If this variable is nil, or if the provided function returns nil, ;; Check for cached select result or run the selection and cache ;; the result. (unless nnselect-artlist - (gnus-group-set-parameter - group 'nnselect-artlist - (nnselect-compress-artlist (setq nnselect-artlist - (nnselect-run - (gnus-group-get-parameter group 'nnselect-specs t))))) + (nnselect-store-artlist group + (setq nnselect-artlist (nnselect-generate-artlist group))) (nnselect-request-update-info group (or info (gnus-get-info group)))) (if (zerop (setq length (nnselect-artlist-length nnselect-artlist))) @@ -338,6 +388,7 @@ If this variable is nil, or if the provided function returns nil, (gnus-group-find-parameter artgroup 'gnus-fetch-old-headers t)) fetch-old))) + (gnus-request-group artgroup) (erase-buffer) (pcase (setq gnus-headers-retrieved-by (or @@ -652,8 +703,15 @@ If this variable is nil, or if the provided function returns nil, (lambda (article) (if (setq seq - (cl-position article - gnus-newsgroup-selection :test 'equal)) + (cl-position + article + gnus-newsgroup-selection + :test + (lambda (x y) + (and (equal (nnselect-artitem-group x) + (nnselect-artitem-group y)) + (eql (nnselect-artitem-number x) + (nnselect-artitem-number y)))))) (push (1+ seq) old-arts) (setq gnus-newsgroup-selection (vconcat gnus-newsgroup-selection (vector article))) @@ -664,10 +722,7 @@ If this variable is nil, or if the provided function returns nil, (append (sort old-arts #'<) (number-sequence first last)) nil t)) - (gnus-group-set-parameter - group - 'nnselect-artlist - (nnselect-compress-artlist gnus-newsgroup-selection)) + (nnselect-store-artlist group gnus-newsgroup-selection) (when (>= last first) (let (new-marks) (pcase-dolist (`(,artgroup . ,artids) @@ -714,6 +769,7 @@ If this variable is nil, or if the provided function returns nil, (message "Creating nnselect group %s" group) (let* ((group (gnus-group-prefixed-name group '(nnselect "nnselect"))) (specs (assq 'nnselect-specs args)) + (otherargs (assq-delete-all 'nnselect-specs args)) (function-spec (or (alist-get 'nnselect-function specs) (intern (completing-read "Function: " obarray #'functionp)))) @@ -723,10 +779,12 @@ If this variable is nil, or if the provided function returns nil, (nnselect-specs (list (cons 'nnselect-function function-spec) (cons 'nnselect-args args-spec)))) (gnus-group-set-parameter group 'nnselect-specs nnselect-specs) - (gnus-group-set-parameter - group 'nnselect-artlist - (nnselect-compress-artlist (or (alist-get 'nnselect-artlist args) - (nnselect-run nnselect-specs)))) + (dolist (arg otherargs) + (gnus-group-set-parameter group (car arg) (cdr arg))) + (nnselect-store-artlist + group + (or (alist-get 'nnselect-artlist args) + (nnselect-generate-artlist group nnselect-specs))) (nnselect-request-update-info group (gnus-get-info group))) t) @@ -758,13 +816,10 @@ If this variable is nil, or if the provided function returns nil, (deffoo nnselect-request-group-scan (group &optional _server _info) (let* ((group (nnselect-add-prefix group)) - (artlist (nnselect-uncompress-artlist (nnselect-run - (gnus-group-get-parameter group 'nnselect-specs t))))) + (artlist (nnselect-generate-artlist group))) (gnus-set-active group (cons 1 (nnselect-artlist-length artlist))) - (gnus-group-set-parameter - group 'nnselect-artlist - (nnselect-compress-artlist artlist)))) + (nnselect-store-artlist group artlist))) ;; Add any undefined required backend functions @@ -779,20 +834,6 @@ If this variable is nil, or if the provided function returns nil, (eq 'nnselect (car gnus-command-method)))) -(defun nnselect-run (specs) - "Apply nnselect-function to nnselect-args from SPECS. -Return an article list." - (let ((func (alist-get 'nnselect-function specs)) - (args (alist-get 'nnselect-args specs))) - (condition-case-unless-debug err - (funcall func args) - ;; Don't swallow gnus-search errors; the user should be made - ;; aware of them. - (gnus-search-error - (signal (car err) (cdr err))) - (error (gnus-error 3 "nnselect-run: %s on %s gave error %s" func args err) - [])))) - (defun nnselect-search-thread (header) "Make an nnselect group containing the thread with article HEADER. The current server will be searched. If the registry is @@ -871,6 +912,9 @@ article came from is also searched." ;; When the backend can store marks we collect any ;; changes. Unlike a normal group the mark lists only ;; include marks for articles we retrieved. + (when (and (gnus-check-backend-function + 'request-set-mark gnus-newsgroup-name) + (not (gnus-article-unpropagatable-p type))) (let* ((old (range-list-intersection artlist (alist-get type (gnus-info-marks group-info)))) @@ -882,7 +926,7 @@ article came from is also searched." ;; This shouldn't happen, but is a sanity check. (setq del (range-intersection (gnus-active artgroup) del)) - (push (list del 'del (list type)) delta-marks))) + (push (list del 'del (list type)) delta-marks)))) ;; Marked sets are of mark-type 'tuple, 'list, or ;; 'range. We merge the lists with what is already in @@ -907,12 +951,15 @@ article came from is also searched." (setq list (cdr all)))) ;; now merge with the original list and sort just to ;; make sure - (setq list - (sort (map-merge - 'alist list - (alist-get type (gnus-info-marks group-info))) - (lambda (elt1 elt2) - (< (car elt1) (car elt2)))))) + (setq + list (sort + (map-merge + 'alist list + (delq nil + (mapcar + (lambda (x) (unless (memq (car x) artlist) x)) + (alist-get type (gnus-info-marks group-info))))) + 'car-less-than-car))) (t (setq list (range-compress-list @@ -956,9 +1003,13 @@ article came from is also searched." (cdr (assoc artgroup select-reads))) (sort (cdr (assoc artgroup select-unreads)) #'<)))) (gnus-get-unread-articles-in-group - group-info (gnus-active artgroup) t) - (gnus-group-update-group artgroup t t))))))) - + group-info (gnus-active artgroup) t)) + (gnus-group-update-group + artgroup t + (equal group-info + (setq group-info (copy-sequence (gnus-get-info artgroup)) + group-info + (delq (gnus-info-params group-info) group-info))))))))) (declare-function gnus-registry-get-id-key "gnus-registry" (id key)) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 0dcff9743ad..f047c832931 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -1225,6 +1225,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the (generate-new-buffer (format " *server %s %s %s*" nntp-address nntp-port-number buffer)) + (gnus-add-buffer) (mm-disable-multibyte) (setq-local after-change-functions nil nntp-process-wait-for nil diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index cc87a707ce6..ae4265de7fb 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -114,14 +114,9 @@ It is computed from the marks of individual component groups.") (gnus-check-server (gnus-find-method-for-group cgroup) t) (gnus-request-group cgroup t) - (setq prefix (gnus-group-real-prefix cgroup)) - ;; FIX FIX FIX we want to check the cache! - ;; This is probably evil if people have set - ;; gnus-use-cache to nil themselves, but I - ;; have no way of finding the true value of it. - (let ((gnus-use-cache t)) - (setq result (gnus-retrieve-headers - articles cgroup nil)))) + (setq prefix (gnus-group-real-prefix cgroup) + result (gnus-retrieve-headers + articles cgroup nil))) (set-buffer nntp-server-buffer) ;; If we got HEAD headers, we convert them into NOV ;; headers. This is slow, inefficient and, come to think diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index ac1e0810417..87b5551d31c 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -119,7 +119,7 @@ ;;; Code: (require 'dig) - +(require 'gnutls) (require 'password-cache) (eval-when-compile (require 'cl-lib)) @@ -149,10 +149,11 @@ certificate." :type '(choice (const :tag "none" nil) directory)) -(defcustom smime-CA-file nil - "Files containing certificates for CAs you trust. -File should contain certificates in PEM format." - :version "22.1" +(defcustom smime-CA-file (car (gnutls-trustfiles)) + "File containing certificates for CAs you trust. +The file should contain certificates in PEM format. By default, +this is initialized from the `gnutls-trusfiles' variable." + :version "29.1" :type '(choice (const :tag "none" nil) file)) diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 297576288bb..5af29c0a246 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -852,7 +852,7 @@ The value nil means that the check does not yield a decision, and so, that further checks are needed. The value t means that the message is definitely not spam, and that further spam checks should be inhibited. Otherwise, a mailgroup name or the symbol -'spam (depending on `spam-split-symbolic-return') is returned where +`spam' (depending on `spam-split-symbolic-return') is returned where the mail should go, and further checks are also inhibited. The usual mailgroup name is the value of `spam-split-group', meaning that the message is definitely a spam." diff --git a/lisp/help-at-pt.el b/lisp/help-at-pt.el index c5a9a93482c..1a6d374db09 100644 --- a/lisp/help-at-pt.el +++ b/lisp/help-at-pt.el @@ -81,25 +81,37 @@ If this produces no string either, return nil." (echo (help-at-pt-string))) (if (and kbd (not (eq kbd t))) kbd echo))) +(declare-function widget-describe "wid-edit" (&optional widget-or-pos)) +(declare-function widget-at "wid-edit" (&optional pos)) + ;;;###autoload -(defun display-local-help (&optional arg) +(defun display-local-help (&optional inhibit-warning describe-button) "Display local help in the echo area. -This displays a short help message, namely the string produced by -the `kbd-help' property at point. If `kbd-help' does not produce -a string, but the `help-echo' property does, then that string is -printed instead. +This command, by default, displays a short help message, namely +the string produced by the `kbd-help' property at point. If +`kbd-help' does not produce a string, but the `help-echo' +property does, then that string is printed instead. The string is passed through `substitute-command-keys' before it is displayed. -A numeric argument ARG prevents display of a message in case -there is no help. While ARG can be used interactively, it is -mainly meant for use from Lisp." - (interactive "P") +If INHIBIT-WARNING is non-nil, this prevents display of a message +in case there is no help. + +If DESCRIBE-BUTTON in non-nil (interactively, the prefix arg), and +there's a button/widget at point, pop a buffer describing that +button/widget instead." + (interactive (list nil current-prefix-arg)) (let ((help (help-at-pt-kbd-string))) - (if help - (message "%s" (substitute-command-keys help)) - (if (not arg) (message "No local help at point"))))) + (cond + ((and describe-button (button-at (point))) + (button-describe)) + ((and describe-button (widget-at (point))) + (widget-describe)) + (help + (message "%s" (substitute-command-keys help))) + ((not inhibit-warning) + (message "No local help at point"))))) (defvar help-at-pt-timer nil "Non-nil means that a timer is set that checks for local help. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 80d7d5cb028..927a4f0d2c4 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -133,6 +133,14 @@ with the current prefix. The files are chosen according to :group 'help :version "26.3") +(defcustom help-enable-variable-value-editing nil + "If non-nil, allow editing values in *Help* buffers. +Values that aren't readable by the Emacs Lisp reader can't be +edited even if this option is enabled." + :type 'boolean + :group 'help + :version "29.1") + (defcustom help-enable-symbol-autoload nil "Perform autoload if docs are missing from autoload objects." :type 'boolean @@ -557,13 +565,10 @@ the C sources, too." (insert "\n")) (when menus (let ((start (point))) - (insert (concat "It can " - (and keys "also ") - "be invoked from the menu: ")) - ;; FIXME: Should insert menu names instead of key - ;; binding names. - (help-fns--insert-bindings menus) - (insert ".") + (help-fns--insert-menu-bindings + menus + (concat "It can " (and keys "also ") + "be invoked from the menu: ")) (fill-region-as-paragraph start (point)))) (ensure-empty-lines))))))) @@ -576,6 +581,38 @@ the C sources, too." (insert (help--key-description-fontified key))) keys)) +(defun help-fns--insert-menu-bindings (menus heading) + (seq-do-indexed + (lambda (menu i) + (insert + (cond ((zerop i) "") + ((= i (1- (length menus))) " and ") + (t ", "))) + (let ((map (lookup-key global-map (seq-take menu 1))) + (start (point))) + (seq-do-indexed + (lambda (entry level) + (when (symbolp map) + (setq map (symbol-function map))) + (when-let ((elem (assq entry (cdr map)))) + (when heading + (insert heading) + (setq heading nil start (point))) + (when (> level 0) + (insert + (if (char-displayable-p ?→) + " → " + " => "))) + (if (eq (nth 1 elem) 'menu-item) + (progn + (insert (nth 2 elem)) + (setq map (cadddr elem))) + (insert (nth 1 elem)) + (setq map (cddr elem))))) + (cdr (seq-into menu 'list))) + (put-text-property start (point) 'face 'help-key-binding))) + menus)) + (defun help-fns--compiler-macro (function) (let ((handler (function-get function 'compiler-macro))) (when handler @@ -800,7 +837,8 @@ the C sources, too." (insert-text-button (symbol-name group) 'action (lambda (_) - (shortdoc-display-group group object)) + (shortdoc-display-group group object + help-window-keep-selected)) 'follow-link t 'help-echo (purecopy "mouse-1, RET: show documentation group"))) groups) @@ -1167,10 +1205,11 @@ it is displayed along with the global value." (let ((rep (let ((print-quoted t) (print-circle t)) - (cl-prin1-to-string val)))) - (if (and (symbolp val) (not (booleanp val))) + (cl-prin1-to-string val)))) + (if (and (symbolp val) (not (booleanp val))) (format-message "`%s'" rep) - rep)))) + rep))) + (start (point))) (if (< (+ (length print-rep) (point) (- line-beg)) 68) (insert " " print-rep) (terpri) @@ -1185,6 +1224,8 @@ it is displayed along with the global value." (insert-buffer-substring pp-buffer))))) ;; Remove trailing newline. (and (= (char-before) ?\n) (delete-char -1))) + (help-fns--editable-variable start (point) + variable val buffer) (let* ((sv (get variable 'standard-value)) (origval (and (consp sv) (condition-case nil @@ -1204,6 +1245,8 @@ it is displayed along with the global value." (save-restriction (narrow-to-region from (point)) (save-excursion (pp-buffer))) + (help-fns--editable-variable from (point) + variable origval buffer) (if (< (point) (+ from 20)) (delete-region (1- from) from))))))) (terpri) @@ -1236,7 +1279,9 @@ it is displayed along with the global value." ;; See previous comment for this function. ;; (help-xref-on-pp from (point)) (if (< (point) (+ from 20)) - (delete-region (1- from) from))))))) + (delete-region (1- from) from)) + (help-fns--editable-variable + from (point) variable global-val buffer)))))) (terpri)) ;; If the value is large, move it to the end. @@ -1286,6 +1331,66 @@ it is displayed along with the global value." ;; Return the text we displayed. (buffer-string)))))))) +(defun help-fns--editable-variable (start end variable value buffer) + (when (and (readablep value) + (or (not (symbolp value)) + (and (not (and (symbolp value) (boundp value))) + (not (and (symbolp value) (fboundp value))))) + help-enable-variable-value-editing) + (add-text-properties + start end + (list 'help-echo "`e' to edit the value" + 'help-fns--edit-variable (list variable value buffer + (current-buffer)) + 'keymap (define-keymap + "e" #'help-fns-edit-variable))))) + +(defvar help-fns--edit-variable) + +(put 'help-fns-edit-variable 'disabled t) +(defun help-fns-edit-variable () + "Edit the variable under point." + (interactive) + (declare (completion ignore)) + (let ((var (get-text-property (point) 'help-fns--edit-variable))) + (unless var + (error "No variable under point")) + (pop-to-buffer-same-window (format "*edit %s*" (nth 0 var))) + (prin1 (nth 1 var) (current-buffer)) + (pp-buffer) + (goto-char (point-min)) + (insert (format ";; Edit the `%s' variable.\n" (nth 0 var)) + ";; C-c C-c to update the value and exit.\n\n") + (help-fns--edit-value-mode) + (setq-local help-fns--edit-variable var))) + +(defvar-keymap help-fns--edit-value-mode-map + "C-c C-c" #'help-fns-edit-mode-done) + +(define-derived-mode help-fns--edit-value-mode emacs-lisp-mode "Elisp" + :interactive nil) + +(defun help-fns-edit-mode-done (&optional kill) + "Update the value of the variable and kill the buffer. +If KILL (the prefix), don't update the value, but just kill the +current buffer." + (interactive "P" help-fns--edit-value-mode) + (unless help-fns--edit-variable + (error "Invalid buffer")) + (goto-char (point-min)) + (cl-destructuring-bind (variable _ buffer help-buffer) + help-fns--edit-variable + (unless (buffer-live-p buffer) + (error "Original buffer is gone; can't update")) + (unless kill + (let ((value (read (current-buffer)))) + (with-current-buffer buffer + (set variable value)))) + (kill-buffer (current-buffer)) + (when (buffer-live-p help-buffer) + (with-current-buffer help-buffer + (revert-buffer))))) + (defun help-fns--run-describe-functions (functions &rest args) (with-current-buffer standard-output (unless (bolp) @@ -1878,107 +1983,96 @@ whose documentation describes the minor mode. If called from Lisp with a non-nil BUFFER argument, display documentation for the major and minor modes of that buffer." (interactive "@") - (let ((help-buffer-under-preparation t)) - (unless buffer (setq buffer (current-buffer))) + (unless buffer + (setq buffer (current-buffer))) + (let ((help-buffer-under-preparation t) + (local-minors (buffer-local-value 'local-minor-modes buffer))) (help-setup-xref (list #'describe-mode buffer) (called-interactively-p 'interactive)) ;; For the sake of help-do-xref and help-xref-go-back, ;; don't switch buffers before calling `help-buffer'. (with-help-window (help-buffer) - (with-current-buffer buffer - (let (minors) - ;; Older packages do not register in minor-mode-list but only in - ;; minor-mode-alist. - (dolist (x minor-mode-alist) - (setq x (car x)) - (unless (memq x minor-mode-list) - (push x minor-mode-list))) - ;; Find enabled minor mode we will want to mention. - (dolist (mode minor-mode-list) - ;; Document a minor mode if it is listed in minor-mode-alist, - ;; non-nil, and has a function definition. - (let ((fmode (or (get mode :minor-mode-function) mode))) - (and (boundp mode) (symbol-value mode) - (fboundp fmode) - (let ((pretty-minor-mode - (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'" - (symbol-name fmode)) - (capitalize - (substring (symbol-name fmode) - 0 (match-beginning 0))) - fmode))) - (push (list fmode pretty-minor-mode - (format-mode-line (assq mode minor-mode-alist))) - minors))))) - ;; Narrowing is not a minor mode, but its indicator is part of - ;; mode-line-modes. - (when (buffer-narrowed-p) - (push '(narrow-to-region "Narrow" " Narrow") minors)) - (setq minors - (sort minors - (lambda (a b) (string-lessp (cadr a) (cadr b))))) - (when minors - (princ "Enabled minor modes:\n") - (make-local-variable 'help-button-cache) - (with-current-buffer standard-output - (dolist (mode minors) - (let ((mode-function (nth 0 mode)) - (pretty-minor-mode (nth 1 mode)) - (indicator (nth 2 mode))) - (save-excursion - (goto-char (point-max)) - (princ "\n\f\n") - (push (point-marker) help-button-cache) - ;; Document the minor modes fully. - (insert-text-button - pretty-minor-mode 'type 'help-function - 'help-args (list mode-function) - 'button '(t)) - (princ (format " minor mode (%s):\n" - (if (zerop (length indicator)) - "no indicator" - (format "indicator%s" - indicator)))) - (princ (help-split-fundoc (documentation mode-function) - nil 'doc))) - (insert-button pretty-minor-mode - 'action (car help-button-cache) - 'follow-link t - 'help-echo "mouse-2, RET: show full information") - (newline))) - (forward-line -1) - (fill-paragraph nil) - (forward-line 1)) + (with-current-buffer (help-buffer) + ;; Add the local minor modes at the start. + (when local-minors + (insert (format "Minor mode%s enabled in this buffer:" + (if (length> local-minors 1) + "s" ""))) + (describe-mode--minor-modes local-minors)) - (princ "\n(Information about these minor modes follows the major mode info.)\n\n")) - ;; Document the major mode. - (let ((mode mode-name)) - (with-current-buffer standard-output - (let ((start (point))) - (insert (format-mode-line mode nil nil buffer)) - (add-text-properties start (point) '(face bold))))) - (princ " mode") - (let* ((mode major-mode) - (file-name (find-lisp-object-file-name mode nil))) - (if (not file-name) - (setq help-mode--current-data (list :symbol mode)) - (princ (format-message " defined in `%s'" - (help-fns-short-filename file-name))) - ;; Make a hyperlink to the library. - (with-current-buffer standard-output - (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") - nil t) - (setq help-mode--current-data (list :symbol mode - :file file-name)) - (help-xref-button 1 'help-function-def mode file-name))))) - (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc))) - (with-current-buffer standard-output - (insert ":\n") - (insert fundoc) - (insert (help-fns--list-local-commands)))))))) - ;; For the sake of IELM and maybe others - nil) + ;; Document the major mode. + (let ((major (buffer-local-value 'major-mode buffer))) + (insert "The major mode is " + (buttonize + (propertize (format-mode-line + (buffer-local-value 'mode-name buffer) + nil nil buffer) + 'face 'bold) + (lambda (_) + (describe-function major)))) + (insert " mode") + (when-let ((file-name (find-lisp-object-file-name major nil))) + (insert (format " defined in %s:\n\n" + (buttonize + (help-fns-short-filename file-name) + (lambda (_) + (help-function-def--button-function + major file-name)))))) + (insert (help-split-fundoc (documentation major) nil 'doc) + (with-current-buffer buffer + (help-fns--list-local-commands))) + (ensure-empty-lines 1) + + ;; Insert the global minor modes after the major mode. + (when global-minor-modes + (insert (format "Global minor mode%s enabled:" + (if (length> global-minor-modes 1) + "s" ""))) + (describe-mode--minor-modes global-minor-modes) + (when (re-search-forward "^\f") + (beginning-of-line) + (ensure-empty-lines 1))) + ;; For the sake of IELM and maybe others + nil))))) + +(defun describe-mode--minor-modes (modes) + (dolist (mode (seq-sort #'string< modes)) + (let ((pretty-minor-mode + (capitalize + (replace-regexp-in-string + "\\(\\(-minor\\)?-mode\\)?\\'" "" + (symbol-name mode))))) + (insert + " " + (buttonize + pretty-minor-mode + (lambda (mode) + (goto-char (point-min)) + (text-property-search-forward + 'help-minor-mode mode t) + (beginning-of-line)) + mode)) + (save-excursion + (goto-char (point-max)) + (insert "\n\n\f\n") + ;; Document the minor modes fully. + (insert (buttonize + (propertize pretty-minor-mode 'help-minor-mode mode) + (lambda (mode) + (describe-function mode)) + mode)) + (let ((indicator + (format-mode-line (assq mode minor-mode-alist)))) + (insert (format " minor mode (%s):\n" + (if (zerop (length indicator)) + "no indicator" + (format "indicator%s" + indicator))))) + (insert (help-split-fundoc (documentation mode) nil 'doc))))) + (forward-line -1) + (fill-paragraph nil) + (forward-paragraph 1) + (ensure-empty-lines 1)) (defun help-fns--list-local-commands () (let ((functions nil)) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index d1b9357f3c9..a0a587cd810 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -268,7 +268,9 @@ The format is (FUNCTION ARGS...).") (let* ((location (find-function-search-for-symbol fun type file)) (position (cdr location))) - (pop-to-buffer (car location)) + (if help-window-keep-selected + (pop-to-buffer-same-window (car location)) + (pop-to-buffer (car location))) (run-hooks 'find-function-after-hook) (if position (progn @@ -294,7 +296,10 @@ The format is (FUNCTION ARGS...).") (setq file (locate-library file t)) (if (and file (file-readable-p file)) (progn - (pop-to-buffer (find-file-noselect file)) + (if help-window-keep-selected + (pop-to-buffer-same-window + (find-file-noselect file)) + (pop-to-buffer (find-file-noselect file))) (widen) (goto-char (point-min)) (if (re-search-forward @@ -313,7 +318,9 @@ The format is (FUNCTION ARGS...).") (setq file (help-C-file-name var 'var))) (let* ((location (find-variable-noselect var file)) (position (cdr location))) - (pop-to-buffer (car location)) + (if help-window-keep-selected + (pop-to-buffer-same-window (car location)) + (pop-to-buffer (car location))) (run-hooks 'find-function-after-hook) (if position (progn @@ -334,7 +341,9 @@ The format is (FUNCTION ARGS...).") (let* ((location (find-function-search-for-symbol fun 'defface file)) (position (cdr location))) - (pop-to-buffer (car location)) + (if help-window-keep-selected + (pop-to-buffer-same-window (car location)) + (pop-to-buffer (car location))) (if position (progn ;; Widen the buffer if necessary to go to this position. @@ -376,7 +385,9 @@ The format is (FUNCTION ARGS...).") :supertype 'help-xref 'help-function (lambda (file pos) - (view-buffer-other-window (find-file-noselect file)) + (if help-window-keep-selected + (view-buffer (find-file-noselect file)) + (view-buffer-other-window (find-file-noselect file))) (goto-char pos)) 'help-echo (purecopy "mouse-2, RET: show corresponding NEWS announcement")) @@ -393,7 +404,8 @@ The format is (FUNCTION ARGS...).") ;;;###autoload (define-derived-mode help-mode special-mode "Help" "Major mode for viewing help text and navigating references in it. -Entry to this mode runs the normal hook `help-mode-hook'. +Also see the `help-enable-editing' variable. + Commands: \\{help-mode-map}" (setq-local revert-buffer-function @@ -403,7 +415,9 @@ Commands: help-mode-tool-bar-map) (setq-local help-mode--current-data nil) (setq-local bookmark-make-record-function - #'help-bookmark-make-record)) + #'help-bookmark-make-record) + (unless search-default-mode + (isearch-fold-quotes-mode))) ;;;###autoload (defun help-mode-setup () @@ -818,7 +832,8 @@ The help buffers are divided into \"pages\" by the ^L character." (unless help-mode--current-data (error "No symbol to look up in the current buffer")) (info-lookup-symbol (plist-get help-mode--current-data :symbol) - 'emacs-lisp-mode)) + 'emacs-lisp-mode + help-window-keep-selected)) (defun help-goto-lispref-info () "View the Emacs Lisp manual *info* node of the current help item." diff --git a/lisp/help.el b/lisp/help.el index d60b5867792..3c0370fee16 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -453,8 +453,8 @@ With argument, display info only for the selected version." ((< vn 18) "NEWS.1-17") (t (format "NEWS.%d" vn)))) res) - (view-file (expand-file-name file data-directory)) - (widen) + (find-file (expand-file-name file data-directory)) + (emacs-news-view-mode) (goto-char (point-min)) (when (stringp version) (when (re-search-forward @@ -621,7 +621,7 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." (enable-recursive-minibuffers t) val) (setq val (completing-read (format-prompt "Where is command" fn) - obarray 'commandp t nil nil + obarray #'commandp t nil nil (and fn (symbol-name fn)))) (list (unless (equal val "") (intern val)) current-prefix-arg))) @@ -867,7 +867,7 @@ with `mouse-movement' events." (memq 'down last-modifiers) ;; After a click, see if a double click is on the way. (and (memq 'click last-modifiers) - (not (sit-for (/ double-click-time 1000.0) t)))) + (not (sit-for (/ (mouse-double-click-time) 1000.0) t)))) (let* ((seq (read-key-sequence "\ Describe the following key, mouse click, or menu item: " nil nil 'can-return-switch-frame)) @@ -1273,7 +1273,8 @@ Otherwise, return a new string." (defvar help--keymaps-seen nil) (defun describe-map-tree (startmap &optional partial shadow prefix title - no-menu transl always-title mention-shadow) + no-menu transl always-title mention-shadow + buffer) "Insert a description of the key bindings in STARTMAP. This is followed by the key bindings of all maps reachable through STARTMAP. @@ -1299,7 +1300,10 @@ maps to look through. If MENTION-SHADOW is non-nil, then when something is shadowed by SHADOW, don't omit it; instead, mention it but say it is -shadowed." +shadowed. + +If BUFFER, lookup keys while in that buffer. This only affects +things like :filters for menu bindings." (let* ((amaps (accessible-keymaps startmap prefix)) (orig-maps (if no-menu (progn @@ -1340,7 +1344,8 @@ shadowed." (setq sub-shadows (cons (cdr (car tail)) sub-shadows))) (setq tail (cdr tail)))) (describe-map (cdr elt) elt-prefix transl partial - sub-shadows no-menu mention-shadow))) + sub-shadows no-menu mention-shadow + buffer))) (setq maps (cdr maps))) ;; Print title... (when (and print-title @@ -1388,7 +1393,8 @@ Return nil if the key sequence is too long." ((keymapp definition) (insert "Prefix Command\n")) ((byte-code-function-p definition) - (insert "[%s]\n" (buttonize "byte-code" #'disassemble definition))) + (insert (format "[%s]\n" + (buttonize "byte-code" #'disassemble definition)))) ((and (consp definition) (memq (car definition) '(closure lambda))) (insert (format "[%s]\n" @@ -1417,13 +1423,13 @@ Return nil if the key sequence is too long." (t nil)))) (defun describe-map (map &optional prefix transl partial shadow - nomenu mention-shadow) + nomenu mention-shadow buffer) "Describe the contents of keymap MAP. Assume that this keymap itself is reached by the sequence of prefix keys PREFIX (a string or vector). -TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in -`describe-map-tree'." +TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW and BUFFER are as +in `describe-map-tree'." ;; Converted from describe_map in keymap.c. (let* ((suppress (and partial 'suppress-keymap)) (map (keymap-canonicalize map)) @@ -1474,7 +1480,10 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in ((and mention-shadow (not (eq tem definition))) (setq this-shadowed t)) (t nil)))) - (eq definition (lookup-key tail (vector event) t)) + (eq definition (if buffer + (with-current-buffer buffer + (lookup-key tail (vector event) t)) + (lookup-key tail (vector event) t))) (push (list event definition this-shadowed) vect)))) ((eq (car tail) 'keymap) ;; The same keymap might be in the structure twice, if @@ -1793,13 +1802,25 @@ the help window appears on another frame, it may get selected and its frame get input focus even if this option is nil. This option has effect if and only if the help window was created -by `with-help-window'." +by `with-help-window'. + +Also see `help-window-keep-selected'." :type '(choice (const :tag "never (nil)" nil) (const :tag "other" other) (const :tag "always (t)" t)) :group 'help :version "23.1") +(defcustom help-window-keep-selected nil + "If non-nil, navigation commands in the *Help* buffer will reuse the window. +If nil, many commands in the *Help* buffer, like \\\\[help-view-source] and \\[help-goto-info], will +pop to a different window to display the results. + +Also see `help-window-select'." + :type 'boolean + :group 'help + :version "29.1") + (define-obsolete-variable-alias 'help-enable-auto-load 'help-enable-autoload "27.1") @@ -2030,7 +2051,7 @@ the same names as used in the original source code, when possible." (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) ;; Advice wrappers have "catch all" args, so fetch the actual underlying ;; function to find the real arguments. - (while (advice--p def) (setq def (advice--cdr def))) + (setq def (advice--cd*r def)) ;; If definition is a macro, find the function inside it. (if (eq (car-safe def) 'macro) (setq def (cdr def))) (cond @@ -2146,7 +2167,10 @@ the suggested string to use instead. See confusables ", ") string)))) -(defun help-command-error-confusable-suggestions (data _context _signal) +(defun help-command-error-confusable-suggestions (data context signal) + ;; Delegate most of the work to the original default value of + ;; `command-error-function' implemented in C. + (command-error-default-function data context signal) (pcase data (`(void-variable ,var) (let ((suggestions (help-uni-confusable-suggestions @@ -2155,8 +2179,12 @@ the suggested string to use instead. See (princ (concat "\n " suggestions) t)))) (_ nil))) -(add-function :after command-error-function - #'help-command-error-confusable-suggestions) +(when (eq command-error-function #'command-error-default-function) + ;; Override the default set in the C code. + ;; This is not done using `add-function' so as to loosen the bootstrap + ;; dependencies. + (setq command-error-function + #'help-command-error-confusable-suggestions)) (define-obsolete-function-alias 'help-for-help-internal #'help-for-help "28.1") diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 8e60ddf6b07..e5ca6819f0d 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -102,7 +102,16 @@ This variable has no effect in Global Highlight Line mode. For that, use `global-hl-line-sticky-flag'." :type 'boolean :version "22.1" - :group 'hl-line) + :group 'hl-line + :set (lambda (symbol value) + (set-default symbol value) + (when (featurep 'hl-line) + (unless value + (let ((selected (window-buffer (selected-window)))) + (dolist (buffer (buffer-list)) + (unless (eq buffer selected) + (with-current-buffer buffer + (hl-line-unhighlight))))))))) (defcustom global-hl-line-sticky-flag nil "Non-nil means the Global HL-Line mode highlight appears in all windows. @@ -125,8 +134,11 @@ This variable is expected to be made buffer-local by modes.") (defvar hl-line-overlay-buffer nil "Most recently visited buffer in which Hl-Line mode is enabled.") -(defvar hl-line-overlay-priority -50 - "Priority used on the overlay used by hl-line.") +(defcustom hl-line-overlay-priority -50 + "Priority used on the overlay used by hl-line." + :type 'integer + :version "28.1" + :group 'hl-line) ;;;###autoload (define-minor-mode hl-line-mode diff --git a/lisp/icomplete.el b/lisp/icomplete.el index 2986aa192c8..ee1a131a6ee 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -153,8 +153,7 @@ with other features and packages. For instance: will constrain Emacs to a maximum minibuffer height of 3 lines when icompletion is occurring." - :type 'hook - :group 'icomplete) + :type 'hook) ;;;_* Initialization @@ -174,11 +173,11 @@ Used to implement the option `icomplete-show-matches-on-no-input'.") (defvar icomplete-minibuffer-map (let ((map (make-sparse-keymap))) - (define-key map [?\M-\t] 'icomplete-force-complete) - (define-key map [remap minibuffer-complete-and-exit] 'icomplete-ret) - (define-key map [?\C-j] 'icomplete-force-complete-and-exit) - (define-key map [?\C-.] 'icomplete-forward-completions) - (define-key map [?\C-,] 'icomplete-backward-completions) + (define-key map [?\M-\t] #'icomplete-force-complete) + (define-key map [remap minibuffer-complete-and-exit] #'icomplete-ret) + (define-key map [?\C-j] #'icomplete-force-complete-and-exit) + (define-key map [?\C-.] #'icomplete-forward-completions) + (define-key map [?\C-,] #'icomplete-backward-completions) map) "Keymap used by `icomplete-mode' in the minibuffer.") @@ -394,18 +393,18 @@ if that doesn't produce a completion match." (defvar icomplete-fido-mode-map (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-k") 'icomplete-fido-kill) - (define-key map (kbd "C-d") 'icomplete-fido-delete-char) - (define-key map (kbd "RET") 'icomplete-fido-ret) - (define-key map (kbd "C-m") 'icomplete-fido-ret) - (define-key map (kbd "DEL") 'icomplete-fido-backward-updir) - (define-key map (kbd "M-j") 'icomplete-fido-exit) - (define-key map (kbd "C-s") 'icomplete-forward-completions) - (define-key map (kbd "C-r") 'icomplete-backward-completions) - (define-key map (kbd "") 'icomplete-forward-completions) - (define-key map (kbd "") 'icomplete-backward-completions) - (define-key map (kbd "C-.") 'icomplete-forward-completions) - (define-key map (kbd "C-,") 'icomplete-backward-completions) + (define-key map (kbd "C-k") #'icomplete-fido-kill) + (define-key map (kbd "C-d") #'icomplete-fido-delete-char) + (define-key map (kbd "RET") #'icomplete-fido-ret) + (define-key map (kbd "C-m") #'icomplete-fido-ret) + (define-key map (kbd "DEL") #'icomplete-fido-backward-updir) + (define-key map (kbd "M-j") #'icomplete-fido-exit) + (define-key map (kbd "C-s") #'icomplete-forward-completions) + (define-key map (kbd "C-r") #'icomplete-backward-completions) + (define-key map (kbd "") #'icomplete-forward-completions) + (define-key map (kbd "") #'icomplete-backward-completions) + (define-key map (kbd "C-.") #'icomplete-forward-completions) + (define-key map (kbd "C-,") #'icomplete-backward-completions) map) "Keymap used by `fido-mode' in the minibuffer.") @@ -431,7 +430,7 @@ if that doesn't produce a completion match." This global minor mode makes minibuffer completion behave more like `ido-mode' than regular `icomplete-mode'." - :global t :group 'icomplete + :global t (remove-hook 'minibuffer-setup-hook #'icomplete-minibuffer-setup) (remove-hook 'minibuffer-setup-hook #'icomplete--fido-mode-setup) (when fido-mode @@ -457,7 +456,7 @@ You can use the following key bindings to navigate and select completions: \\{icomplete-minibuffer-map}" - :global t :group 'icomplete + :global t (remove-hook 'minibuffer-setup-hook #'icomplete-minibuffer-setup) (remove-hook 'completion-in-region-mode-hook #'icomplete--in-region-setup) (when icomplete-mode @@ -532,7 +531,7 @@ Usually run by inclusion in `minibuffer-setup-hook'." (setq icomplete--in-region-buffer nil) (delete-overlay icomplete-overlay) (kill-local-variable 'completion-show-inline-help) - (remove-hook 'post-command-hook 'icomplete-post-command-hook t) + (remove-hook 'post-command-hook #'icomplete-post-command-hook t) (message nil))) (when (and completion-in-region-mode icomplete-mode (icomplete-simple-completing-p)) @@ -543,7 +542,7 @@ Usually run by inclusion in `minibuffer-setup-hook'." (unless (memq icomplete-minibuffer-map (cdr tem)) (setcdr tem (make-composed-keymap icomplete-minibuffer-map (cdr tem))))) - (add-hook 'post-command-hook 'icomplete-post-command-hook nil t))) + (add-hook 'post-command-hook #'icomplete-post-command-hook nil t))) (defun icomplete--sorted-completions () (or completion-all-sorted-completions @@ -630,12 +629,12 @@ Usually run by inclusion in `minibuffer-setup-hook'." (defvar icomplete-vertical-mode-minibuffer-map (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-n") 'icomplete-forward-completions) - (define-key map (kbd "C-p") 'icomplete-backward-completions) - (define-key map (kbd "") 'icomplete-forward-completions) - (define-key map (kbd "") 'icomplete-backward-completions) - (define-key map (kbd "M-<") 'icomplete-vertical-goto-first) - (define-key map (kbd "M->") 'icomplete-vertical-goto-last) + (define-key map (kbd "C-n") #'icomplete-forward-completions) + (define-key map (kbd "C-p") #'icomplete-backward-completions) + (define-key map (kbd "") #'icomplete-forward-completions) + (define-key map (kbd "") #'icomplete-backward-completions) + (define-key map (kbd "M-<") #'icomplete-vertical-goto-first) + (define-key map (kbd "M->") #'icomplete-vertical-goto-last) map) "Keymap used by `icomplete-vertical-mode' in the minibuffer.") @@ -691,7 +690,7 @@ See `icomplete-mode' and `minibuffer-setup-hook'." (icomplete-simple-completing-p)) ;Shouldn't be necessary. (let ((saved-point (point))) (save-excursion - (goto-char (point-max)) + (goto-char (icomplete--field-end)) ; Insert the match-status information: (when (and (or icomplete-show-matches-on-no-input (not (equal (icomplete--field-string) @@ -1043,7 +1042,7 @@ matches exist." (push first prospects))) (concat determ "{" - (mapconcat 'identity prospects icomplete-separator) + (mapconcat #'identity prospects icomplete-separator) (concat (and limit (concat icomplete-separator ellipsis)) "}"))) ;; Restore the base-size info, since completion-all-sorted-completions diff --git a/lisp/image-mode.el b/lisp/image-mode.el index b2af3f06a27..721f2f2bbd8 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -419,39 +419,31 @@ window configuration prior to the last `image-mode-fit-frame' call." (interactive (list nil t)) (let* ((buffer (current-buffer)) - (display (image-get-display-property)) - (size (image-display-size display)) (saved (frame-parameter frame 'image-mode-saved-params)) (window-configuration (current-window-configuration frame)) - (width (frame-width frame)) - (height (frame-height frame))) + (frame-width (frame-text-width frame)) + (frame-height (frame-text-height frame))) (with-selected-frame (or frame (selected-frame)) (if (and toggle saved - (= (caar saved) width) - (= (cdar saved) height)) + (= (caar saved) frame-width) + (= (cdar saved) frame-height)) (progn - (set-frame-width frame (car (nth 1 saved))) - (set-frame-height frame (cdr (nth 1 saved))) + (set-frame-width frame (car (nth 1 saved)) nil t) + (set-frame-height frame (cdr (nth 1 saved)) nil t) (set-window-configuration (nth 2 saved)) (set-frame-parameter frame 'image-mode-saved-params nil)) (delete-other-windows) (switch-to-buffer buffer t t) - (let* ((edges (window-inside-edges)) - (inner-width (- (nth 2 edges) (nth 0 edges))) - (inner-height (- (nth 3 edges) (nth 1 edges)))) - (set-frame-width frame (+ (ceiling (car size)) - width (- inner-width))) - (set-frame-height frame (+ (ceiling (cdr size)) - height (- inner-height))) - ;; The frame size after the above `set-frame-*' calls may - ;; differ from what we specified, due to window manager - ;; interference. We have to call `frame-width' and - ;; `frame-height' to get the actual results. - (set-frame-parameter frame 'image-mode-saved-params - (list (cons (frame-width) - (frame-height)) - (cons width height) - window-configuration))))))) + (fit-frame-to-buffer frame) + ;; The frame size after the above `set-frame-*' calls may + ;; differ from what we specified, due to window manager + ;; interference. We have to call `frame-width' and + ;; `frame-height' to get the actual results. + (set-frame-parameter frame 'image-mode-saved-params + (list (cons (frame-text-width frame) + (frame-text-height frame)) + (cons frame-width frame-height) + window-configuration)))))) ;;; Image Mode setup @@ -625,6 +617,8 @@ image as text, when opening such images in `image-mode'." (put 'image-mode 'mode-class 'special) +(declare-function image-converter-initialize "image-converter.el") + ;;;###autoload (defun image-mode () "Major mode for image files. @@ -650,7 +644,12 @@ Key bindings: "Empty file" "(New file)") "Empty buffer")) - (image-mode--display))) + (image-mode--display) + ;; Ensure that we recognize externally parsed image formats in + ;; commands like `n'. + (when image-use-external-converter + (require 'image-converter) + (image-converter-initialize)))) (defun image-mode--display () (if (not (image-get-display-property)) @@ -1197,8 +1196,9 @@ replacing the current Image mode buffer." "Return an alist of type/buffer for all \"parent\" buffers to image FILE. This is normally a list of Dired buffers, but can also be archive and tar mode buffers." - (let ((buffers nil) - (dir (file-name-directory file))) + (let* ((non-essential t) ; Do not block for remote buffers. + (buffers nil) + (dir (file-name-directory file))) (cond ((and (boundp 'tar-superior-buffer) tar-superior-buffer) @@ -1213,6 +1213,8 @@ tar mode buffers." (dolist (buffer (buffer-list)) (with-current-buffer buffer (when (and (derived-mode-p 'dired-mode) + (equal (file-remote-p dir) + (file-remote-p default-directory)) (equal (file-truename dir) (file-truename default-directory))) (push (cons 'dired (current-buffer)) buffers)))) diff --git a/lisp/image.el b/lisp/image.el index ec4ee06eb14..1b684d5c57a 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -380,6 +380,7 @@ be determined." "Determine the type of image file FILE from its name. Value is a symbol specifying the image type, or nil if type cannot be determined." + (declare (obsolete image-supported-file-p "29.1")) (let (type first (case-fold-search t)) (catch 'found (dolist (elem image-type-file-name-regexps first) @@ -389,6 +390,20 @@ be determined." ;; If nothing seems to be supported, return first type that matched. (or first (setq first type)))))))) + ;;;###autoload +(defun image-supported-file-p (file) + "Say whether Emacs has native support for displaying TYPE. +The value is a symbol specifying the image type, or nil if type +cannot be determined (or if Emacs doesn't have built-in support +for the image type)." + (let ((case-fold-search t) + type) + (catch 'found + (dolist (elem image-type-file-name-regexps) + (when (and (string-match-p (car elem) file) + (image-type-available-p (setq type (cdr elem)))) + (throw 'found type)))))) + (declare-function image-convert-p "image-converter.el" (source &optional image-format)) (declare-function image-convert "image-converter.el" @@ -417,7 +432,7 @@ type if we can't otherwise guess it." (require 'image-converter) (image-convert-p source data-p)))) (or (image-type-from-file-header source) - (image-type-from-file-name source) + (image-supported-file-p source) (and image-use-external-converter (progn (require 'image-converter) @@ -461,6 +476,7 @@ must be available." (and auto (or (eq auto t) (image-type-available-p type))))) +(defvar image-convert-to-format) ;;;###autoload (defun create-image (file-or-data &optional type data-p &rest props) @@ -498,7 +514,7 @@ Image file names that are not absolute are searched for in the (when (eq type 'image-convert) (require 'image-converter) (setq file-or-data (image-convert file-or-data data-format) - type 'png + type (intern image-convert-to-format) data-p t))) (when (image-type-available-p type) (let ((image diff --git a/lisp/image/exif.el b/lisp/image/exif.el index 35666b954ca..fd4673dc1b6 100644 --- a/lisp/image/exif.el +++ b/lisp/image/exif.el @@ -100,7 +100,10 @@ mirrored or not.") "Parse FILE (a JPEG file) and return the Exif data, if any. The return value is a list of Exif items. -If the data is invalid, an `exif-error' is signaled." +If the data is invalid, an `exif-error' is signaled. + +Also see the `exif-field' convenience function to extract data +from the return value of this function." (with-temp-buffer (set-buffer-multibyte nil) (insert-file-contents-literally file) @@ -110,7 +113,10 @@ If the data is invalid, an `exif-error' is signaled." "Parse BUFFER (which should be a JPEG file) and return the Exif data, if any. The return value is a list of Exif items. -If the data is invalid, an `exif-error' is signaled." +If the data is invalid, an `exif-error' is signaled. + +Also see the `exif-field' convenience function to extract data +from the return value of this function." (setq buffer (or buffer (current-buffer))) (with-current-buffer buffer (if enable-multibyte-characters diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el index 460ff16adb0..7914d28c293 100644 --- a/lisp/image/image-converter.el +++ b/lisp/image/image-converter.el @@ -46,6 +46,16 @@ formats that are to be supported: Only the suffixes that map to :type 'symbol :version "27.1") +(defcustom image-convert-to-format "png" + "The image format to convert to. +This should be a string like \"png\" or \"ppm\" or some +other (preferrably lossless) format that Emacs understands +natively. The converter chosen has to support the format, and if +not, conversion will fail." + :group 'image + :version "29.1" + :type 'string) + (defvar image-converter-regexp nil "A regexp that matches the file name suffixes that can be converted.") @@ -58,15 +68,19 @@ formats that are to be supported: Only the suffixes that map to (imagemagick :command "convert" :probe ("-list" "format"))) "List of supported image converters to try.") +(defun image-converter-initialize () + "Determine the external image converter to be used. +This also determines which external formats we can parse." + (unless image-converter + (image-converter--find-converter))) + (defun image-convert-p (source &optional data-p) "Return `image-convert' if SOURCE is an image that can be converted. SOURCE can either be a file name or a string containing image data. In the latter case, DATA-P should be non-nil. If DATA-P is a string, it should be a MIME format string like \"image/gif\"." - ;; Find an installed image converter. - (unless image-converter - (image-converter--find-converter)) + (image-converter-initialize) ;; When image-converter was customized (when (and image-converter (not image-converter-regexp)) (when-let ((formats (image-converter--probe image-converter))) @@ -85,22 +99,23 @@ is a string, it should be a MIME format string like 'image-convert)) (defun image-convert (image &optional image-format) - "Convert IMAGE file to the PNG format. + "Convert IMAGE file to an image format Emacs understands. +This will usually be \"png\", but this is controlled by the +`image-convert-to-format' user option. + IMAGE can either be a file name or image data. To pass in image data, IMAGE should a string containing the image data, and IMAGE-FORMAT should be a symbol with a MIME format name like \"image/webp\". For instance: - (image-convert data-string 'image/bmp) + (image-convert data-string \\='image/bmp) IMAGE can also be an image object as returned by `create-image'. -This function converts the image to PNG, and the converted image -data is returned as a string." - ;; Find an installed image converter. - (unless image-converter - (image-converter--find-converter)) +This function converts the image the preferred format, and the +converted image data is returned as a string." + (image-converter-initialize) (unless image-converter (error "No external image converters available")) (when (and image-format @@ -120,7 +135,9 @@ data is returned as a string." (if (listp image) ;; Return an image object that's the same as we were passed, ;; but ignore the :type value. - (apply #'create-image (buffer-string) 'png t + (apply #'create-image (buffer-string) + (intern image-convert-to-format) + t (cl-loop for (key val) on (cdr image) by #'cddr unless (eq key :type) append (list key val))) @@ -239,12 +256,15 @@ Only suffixes that map to `image-mode' are returned." (list (format "%s:-" (image-converter--mime-type image-format)) - "png:-")))) + (concat image-convert-to-format + ":-"))))) ;; SOURCE is a file name. (apply #'call-process (car command) nil t nil (append (cdr command) - (list (expand-file-name source) "png:-"))))) + (list (expand-file-name source) + (concat image-convert-to-format + ":-")))))) ;; If the command failed, hopefully the buffer contains the ;; error message. (buffer-string)))) @@ -262,14 +282,15 @@ Only suffixes that map to `image-mode' are returned." (append (cdr command) (list "-i" "-" - "-c:v" "png" + "-c:v" image-convert-to-format "-f" "image2pipe" "-")))) (apply #'call-process (car command) nil '(t nil) nil (append (cdr command) (list "-i" (expand-file-name source) - "-c:v" "png" "-f" "image2pipe" + "-c:v" image-convert-to-format + "-f" "image2pipe" "-"))))) "ffmpeg error when converting"))) diff --git a/lisp/info-look.el b/lisp/info-look.el index aa07c3f5e70..6c8ef091a08 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -280,7 +280,7 @@ system." ;;;###autoload (put 'info-lookup-symbol 'info-file "emacs") ;;;###autoload -(defun info-lookup-symbol (symbol &optional mode) +(defun info-lookup-symbol (symbol &optional mode same-window) "Look up and display documentation of SYMBOL in the relevant Info manual. SYMBOL should be an identifier: a function or method, a macro, a variable, a data type, a class, etc. @@ -293,10 +293,13 @@ MODE is the major mode whose Info manuals to search for the documentation of SYMBOL. It defaults to the current buffer's `major-mode'; if that mode doesn't have any Info manuals known to Emacs, the command will prompt for MODE to use, with completion. With prefix arg, the command -always prompts for MODE." +always prompts for MODE. + +Is SAME-WINDOW, try to reuse the current window instead of +popping up a new one." (interactive (info-lookup-interactive-arguments 'symbol current-prefix-arg)) - (info-lookup 'symbol symbol mode)) + (info-lookup 'symbol symbol mode same-window)) ;;;###autoload (put 'info-lookup-file 'info-file "emacs") ;;;###autoload @@ -388,7 +391,7 @@ If optional argument QUERY is non-nil, query for the help mode." spec mode))) -(defun info-lookup (topic item mode) +(defun info-lookup (topic item mode &optional same-window) "Display the documentation of TOPIC whose name is ITEM, using MODE's manuals. TOPIC should be any known symbol of a help topic type, such as `file' or `symbol'. See the documentation of HELP-TOPIC in the doc @@ -397,7 +400,10 @@ ITEM is the item whose documentation to search: file name if TOPIC is `file', a symbol if TOPIC is `symbol', etc. MODE is the `major-mode' whose Info manuals to search for documentation of ITEM; if it's nil, the function uses `info-lookup-file-name-alist' -and the current buffer's file name to guess the mode.." +and the current buffer's file name to guess the mode. + +If SAME-WINDOW, reuse the current window. If nil, pop to a +different window." (or mode (setq mode (info-lookup-select-mode))) (setq mode (info-lookup--item-to-mode item mode)) (if-let ((info (info-lookup->mode-value topic mode))) @@ -423,19 +429,21 @@ and the current buffer's file name to guess the mode.." (if (not info-lookup-other-window-flag) (info) (save-window-excursion (info)) - (let* ((info-window (get-buffer-window "*info*" t)) - (info-frame (and info-window (window-frame info-window)))) - (if (and info-frame - (not (eq info-frame (selected-frame))) - (display-multi-frame-p) - (memq info-frame (frames-on-display-list))) - ;; *info* is visible in another frame on same display. - ;; Raise that frame and select the window. - (progn - (select-window info-window) - (raise-frame info-frame)) - ;; In any other case, switch to *info* in another window. - (switch-to-buffer-other-window "*info*"))))) + (if same-window + (pop-to-buffer-same-window "*info*") + (let* ((info-window (get-buffer-window "*info*" t)) + (info-frame (and info-window (window-frame info-window)))) + (if (and info-frame + (not (eq info-frame (selected-frame))) + (display-multi-frame-p) + (memq info-frame (frames-on-display-list))) + ;; *info* is visible in another frame on same display. + ;; Raise that frame and select the window. + (progn + (select-window info-window) + (raise-frame info-frame)) + ;; In any other case, switch to *info* another window. + (switch-to-buffer-other-window "*info*")))))) (while (and (not found) modes) (setq doc-spec (info-lookup->doc-spec topic (car modes))) (while (and (not found) doc-spec) diff --git a/lisp/info.el b/lisp/info.el index db95574bf72..514cf7b3f47 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -907,17 +907,20 @@ find a node." filename))) filename)))) -(defun Info-find-node (filename nodename &optional no-going-back strict-case) +(defun Info-find-node (filename nodename &optional no-going-back strict-case + noerror) "Go to an Info node specified as separate FILENAME and NODENAME. NO-GOING-BACK is non-nil if recovering from an error in this function; it says do not attempt further (recursive) error recovery. This function first looks for a case-sensitive match for NODENAME; if none is found it then tries a case-insensitive match (unless -STRICT-CASE is non-nil)." +STRICT-CASE is non-nil). + +If NOERROR, inhibit error messages when we can't find the node." (info-initialize) (setq nodename (info--node-canonicalize-whitespace nodename)) - (setq filename (Info-find-file filename)) + (setq filename (Info-find-file filename noerror)) ;; Go into Info buffer. (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*")) ;; Record the node we are leaving, if we were in one. @@ -1822,41 +1825,22 @@ directories to search if FILENAME is not absolute; SUFFIXES is a list of valid filename suffixes for Info files. See `try-completion' for a description of the remaining arguments." (setq suffixes (remove "" suffixes)) - (when (file-name-absolute-p string) - (setq dirs (list (file-name-directory string)))) (let ((names nil) - (names-sans-suffix nil) - (suffix (concat (regexp-opt suffixes t) "\\'")) - (string-dir (file-name-directory string))) + (suffix (concat (regexp-opt suffixes t) "\\'"))) (dolist (dir dirs) - (unless dir - (setq dir default-directory)) - (if string-dir (setq dir (expand-file-name string-dir dir))) (when (file-directory-p dir) - (dolist (file (file-name-all-completions - (file-name-nondirectory string) dir)) - ;; If the file name has no suffix or a standard suffix, - ;; include it. - (and (or (null (file-name-extension file)) - (string-match suffix file)) - ;; But exclude subfiles of split Info files. - (not (string-match "-[0-9]+\\'" file)) - ;; And exclude backup files. - (not (string-match "~\\'" file)) - (push (if string-dir (concat string-dir file) file) names)) - ;; If the file name ends in a standard suffix, - ;; add the unsuffixed name as a completion option. - (when (string-match suffix file) - (setq file (substring file 0 (match-beginning 0))) - (push (if string-dir (concat string-dir file) file) - names-sans-suffix))))) - ;; If there is just one file, don't duplicate it with suffixes, - ;; so `Info-read-node-name-1' will be able to complete a single - ;; candidate and to add the terminating ")". - (if (and (= (length names) 1) (= (length names-sans-suffix) 1)) - (setq names names-sans-suffix) - (setq names (append names-sans-suffix names))) - (complete-with-action action names string pred))) + (dolist (file (directory-files dir)) + ;; If the file name has a standard suffix, + ;; include it (without the suffix). + (when (and (string-match suffix file) + ;; But exclude subfiles of split Info files. + (not (string-match "\.info-[0-9]+" file)) + ;; And exclude backup files. + (not (string-match "~\\'" file))) + (push (substring file 0 (match-beginning 0)) + names))))) + (complete-with-action action (delete-dups (nreverse names)) + string pred))) (defun Info-read-node-name-1 (string predicate code) "Internal function used by `Info-read-node-name'. @@ -2615,7 +2599,8 @@ new buffer." (if (eq alt-default t) (setq alt-default str)) ;; Don't add this string if it's a duplicate. (or (assoc-string str completions t) - (push str completions)))) + (push str completions))) + (setq completions (nreverse completions))) ;; If no good default was found, try an alternate. (or default (setq default alt-default)) @@ -3632,13 +3617,16 @@ MATCHES is a list of index matches found by `Info-apropos-matches'.") (format " (line %s)" (nth 3 entry)) ""))))))))) -(defun Info-apropos-matches (string) +(defun Info-apropos-matches (string &optional regexp) "Collect STRING matches from all known Info files on your system. +If REGEXP, use regexp matching instead of literal matching. Return a list of matches where each element is in the format \((FILENAME INDEXTEXT NODENAME LINENUMBER))." (unless (string= string "") (let ((pattern (format "\n\\* +\\([^\n]*\\(%s\\)[^\n]*\\):[ \t]+\\([^\n]+\\)\\.\\(?:[ \t\n]*(line +\\([0-9]+\\))\\)?" - (regexp-quote string))) + (if regexp + string + (regexp-quote string)))) (ohist Info-history) (ohist-list Info-history-list) (current-node Info-current-node) @@ -3663,9 +3651,9 @@ Return a list of matches where each element is in the format (dolist (manual (nreverse manuals)) (message "Searching %s" manual) (condition-case err - (if (setq nodes (Info-index-nodes (Info-find-file manual))) + (if (setq nodes (Info-index-nodes (Info-find-file manual t))) (save-excursion - (Info-find-node manual (car nodes)) + (Info-find-node manual (car nodes) nil nil t) (while (progn (goto-char (point-min)) @@ -3692,19 +3680,22 @@ Return a list of matches where each element is in the format (or (nreverse matches) t)))) ;;;###autoload -(defun info-apropos (string) - "Grovel indices of all known Info files on your system for STRING. -Build a menu of the possible matches." - (interactive "sIndex apropos: ") +(defun info-apropos (string &optional regexp) + "Search indices of all known Info files on your system for STRING. +If REGEXP (interactively, the prefix), use a regexp match. + +Display a menu of the possible matches." + (interactive "sIndex apropos: \nP") (if (equal string "") (Info-find-node Info-apropos-file "Top") - (let* ((nodes Info-apropos-nodes) nodename) + (let ((nodes Info-apropos-nodes) + nodename) (while (and nodes (not (equal string (nth 1 (car nodes))))) (setq nodes (cdr nodes))) (if nodes - (Info-find-node Info-apropos-file (car (car nodes))) + (Info-find-node Info-apropos-file (car (car nodes)) nil nil t) (setq nodename (format "Index for ‘%s’" string)) - (push (list nodename string (Info-apropos-matches string)) + (push (list nodename string (Info-apropos-matches string regexp)) Info-apropos-nodes) (Info-find-node Info-apropos-file nodename))))) @@ -4295,7 +4286,8 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (substring str (match-end 0)))) (setq i (1+ i))) (setq items - (cons str items)))) + (cons str items))) + (setq items (nreverse items))) (while (and items (< number 9)) (setq current (car items) items (cdr items) @@ -4498,7 +4490,9 @@ Advanced commands: (setq-local revert-buffer-function #'Info-revert-buffer-function) (setq-local font-lock-defaults '(Info-mode-font-lock-keywords t t)) (Info-set-mode-line) - (setq-local bookmark-make-record-function #'Info-bookmark-make-record)) + (setq-local bookmark-make-record-function #'Info-bookmark-make-record) + (unless search-default-mode + (isearch-fold-quotes-mode))) ;; When an Info buffer is killed, make sure the associated tags buffer ;; is killed too. @@ -5440,7 +5434,8 @@ completion alternatives to currently visited manuals." (progn (info-initialize) (completing-read "Manual name: " - (info--manual-names current-prefix-arg) + (info--filter-manual-names + (info--manual-names current-prefix-arg)) nil t)))) (let ((blist (buffer-list)) (manual-re (concat "\\(/\\|\\`\\)" manual "\\(\\.\\|\\'\\)")) @@ -5468,6 +5463,22 @@ completion alternatives to currently visited manuals." (info (Info-find-file manual) (generate-new-buffer-name "*info*"))))) +(defun info--filter-manual-names (names) + (cl-flet ((strip (name) + (replace-regexp-in-string "\\([-.]info\\)?\\(\\.gz\\)?\\'" + "" name))) + (seq-uniq (sort (seq-filter + (lambda (name) + (and (not (string-match-p "info-[0-9]" name)) + (not (member name '("./" "../" "ChangeLog" + "NEWS" "README"))))) + names) + ;; We prefer the shorter names ("foo" over "foo.gz"). + (lambda (s1 s2) + (< (length s1) (length s2)))) + (lambda (s1 s2) + (equal (strip s1) (strip s2)))))) + (defun info--manual-names (visited-only) (let (names) (dolist (buffer (buffer-list)) diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el index 9188e3d6ae4..c7d883276db 100644 --- a/lisp/international/ccl.el +++ b/lisp/international/ccl.el @@ -577,7 +577,7 @@ Return register which holds a value of the expression." (ccl-check-register expr cmd))) (defun ccl-compile-branch-blocks (code rrr blocks) - "Compile BLOCKs of BRANCH statement. CODE is 'branch or 'read-branch. + "Compile BLOCKs of BRANCH statement. CODE is `branch' or `read-branch'. REG is a register which holds a value of EXPRESSION part. BLOCKs is a list of CCL-BLOCKs." (let ((branches (length blocks)) diff --git a/lisp/international/characters.el b/lisp/international/characters.el index 63ac455ea6a..ca28222c815 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -303,7 +303,8 @@ with L, LRE, or LRO Unicode bidi character type.") (setq charsets (cdr charsets)))) (modify-category-entry '(#x600 . #x6ff) ?b) (modify-category-entry '(#x870 . #x8ff) ?b) -(modify-category-entry '(#xfb50 . #xfdff) ?b) +(modify-category-entry '(#xfb50 . #xfdcf) ?b) +(modify-category-entry '(#xfdf0 . #xfdff) ?b) (modify-category-entry '(#xfe70 . #xfefe) ?b) ;; Cyrillic character set (ISO-8859-5) diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index 1950a409354..883f08905e9 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -231,6 +231,7 @@ (chorasmian #x10FB0) (elymaic #x10FE0) (old-uyghur #x10F70) + (brahmi #x11013 #x11045 #x11052 #x11065) (mahajani #x11150) (khojki #x11200) (khudawadi #x112B0) @@ -770,6 +771,7 @@ chorasmian elymaic old-uyghur + brahmi makasar dives-akuru cuneiform diff --git a/lisp/international/iso-transl.el b/lisp/international/iso-transl.el index 10f8ce6efbd..b90c065461a 100644 --- a/lisp/international/iso-transl.el +++ b/lisp/international/iso-transl.el @@ -182,10 +182,10 @@ ("o" . [?°]) ("Oe" . [?œ]) ("OE" . [?Œ]) - ("*u" . [?µ]) - ("u" . [?µ]) - ("*m" . [?µ]) - ("m" . [?µ]) + ("*u" . [?μ]) + ("u" . [?μ]) + ("*m" . [?μ]) + ("m" . [?μ]) ("*x" . [?×]) ("x" . [?×]) ("*|" . [?¦]) diff --git a/lisp/international/quail.el b/lisp/international/quail.el index 14d4c383b23..529cf97215e 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -412,8 +412,8 @@ If it is nil, the current key is shown. DOCSTRING is the documentation string of this package. The command `describe-input-method' shows this string while replacing the form -\\=\\ in the string by the value of VAR. That value should be a -string. For instance, the form \\=\\ is +\\=\\=\\=\\ in the string by the value of VAR. That value should be a +string. For instance, the form \\=\\=\\=\\ is replaced by a description about how to select a translation from a list of candidates. diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el index 6985f4f3efe..82eba1b5d51 100644 --- a/lisp/international/textsec.el +++ b/lisp/international/textsec.el @@ -231,6 +231,22 @@ The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." (textsec-single-script-p string1) (textsec-single-script-p string2))) +(defun textsec--ipvx-address-p (domain) + "Return non-nil if DOMAIN is an ipv4 or ipv6 address." + ;; This is a very relaxed pattern for IPv4 or IPv6 addresses. The + ;; assumption is that any malformed address accepted by this rule + ;; will be rejected by the actual address parser eventually. + (let ((case-fold-search t)) + (rx-let ((ipv4 (** 1 4 + (** 1 3 (in "0-9")) + (? "."))) + (ipv6 (: (** 1 7 + (** 0 4 (in "0-9a-f")) + ":") + (** 0 4 (in "0-9a-f")) + (? ":" ipv4)))) + (string-match-p (rx bos (or ipv4 ipv6 (: "[" ipv6 "]")) eos) domain)))) + (defun textsec-domain-suspicious-p (domain) "Say whether DOMAIN's name looks suspicious. Return nil if it isn't suspicious. If it is, return a string explaining @@ -241,6 +257,9 @@ that can look similar to other characters when displayed, or use characters that are not allowed by Unicode's IDNA mapping, or use certain other unusual mixtures of characters." (catch 'found + ;; Plain domains aren't suspicious. + (when (textsec--ipvx-address-p domain) + (throw 'found nil)) (seq-do (lambda (char) (when (eq (elt idna-mapping-table char) t) diff --git a/lisp/isearch.el b/lisp/isearch.el index 8970216398b..96168f94bd5 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -868,14 +868,16 @@ This variable is set and changed during isearch. To change the default behavior used for searches, see `search-default-mode' instead.") -(defvar isearch-lax-whitespace t +(defcustom isearch-lax-whitespace t "If non-nil, a space will match a sequence of whitespace chars. When you enter a space or spaces in ordinary incremental search, it will match any sequence matched by the regexp defined by the variable `search-whitespace-regexp'. If the value is nil, each space you type matches literally, against one space. You can toggle the value of this variable by the command `isearch-toggle-lax-whitespace', usually bound to -`M-s SPC' during isearch.") +`M-s SPC' during isearch." + :type 'boolean + :version "25.1") (defvar isearch-regexp-lax-whitespace nil "If non-nil, a space will match a sequence of whitespace chars. @@ -1813,17 +1815,19 @@ The following additional command keys are active while editing. ;; Search string might have meta information on text properties. (minibuffer-allow-text-properties t)) (setq isearch-new-string - (read-from-minibuffer - (isearch-message-prefix nil isearch-nonincremental) - (cons isearch-string (1+ (or (isearch-fail-pos) - (length isearch-string)))) - minibuffer-local-isearch-map nil - (if isearch-regexp - (cons 'regexp-search-ring - (1+ (or regexp-search-ring-yank-pointer -1))) - (cons 'search-ring - (1+ (or search-ring-yank-pointer -1)))) - nil t) + (minibuffer-with-setup-hook + (minibuffer-lazy-highlight-setup) + (read-from-minibuffer + (isearch-message-prefix nil isearch-nonincremental) + (cons isearch-string (1+ (or (isearch-fail-pos) + (length isearch-string)))) + minibuffer-local-isearch-map nil + (if isearch-regexp + (cons 'regexp-search-ring + (1+ (or regexp-search-ring-yank-pointer -1))) + (cons 'search-ring + (1+ (or search-ring-yank-pointer -1)))) + nil t)) isearch-new-message (mapconcat 'isearch-text-char-description isearch-new-string ""))))) @@ -2327,7 +2331,12 @@ arg means replace backward. Note that using the prefix arg is possible only when `isearch-allow-scroll' is non-nil or `isearch-allow-prefix' is non-nil, and it doesn't always provide the correct matches for `query-replace', so the preferred way to run word -replacements from Isearch is `M-s w ... M-%'." +replacements from Isearch is `M-s w ... M-%'. + +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time." (interactive (list current-prefix-arg)) (barf-if-buffer-read-only) @@ -2381,7 +2390,12 @@ replacements from Isearch is `M-s w ... M-%'." (defun isearch-query-replace-regexp (&optional arg) "Start `query-replace-regexp' with string to replace from last search string. -See `isearch-query-replace' for more information." +See `isearch-query-replace' for more information. + +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time." (interactive (list current-prefix-arg)) (isearch-query-replace arg t)) @@ -2627,9 +2641,10 @@ is bound to outside of Isearch." ;; Key search depends on mode (bug#47755) (isearch-mode nil)) (key-binding (this-command-keys-vector) t)))) - (if (and (window-minibuffer-p w) - (not (minibuffer-window-active-p w))) ; in echo area - (isearch-yank-x-selection) + (if (or mouse-yank-at-point + (and (window-minibuffer-p w) + (not (minibuffer-window-active-p w)))) ; in echo area + (isearch-yank-x-selection) (when (functionp binding) (call-interactively binding))))) @@ -2668,7 +2683,7 @@ or it might return the position of the end of the line." (interactive "p") (if (eobp) (insert - (with-current-buffer (cadr (buffer-list)) + (with-minibuffer-selected-window (buffer-substring-no-properties (point) (progn (forward-char arg) (point))))) (forward-char arg))) @@ -3455,11 +3470,13 @@ the word mode." (if (and (not isearch-success) (not isearch-case-fold-search)) "case-sensitive ") (let ((prefix "")) - (advice-function-mapc - (lambda (_ props) - (let ((np (cdr (assq 'isearch-message-prefix props)))) - (if np (setq prefix (concat np prefix))))) - isearch-filter-predicate) + (dolist (advice-function (list isearch-filter-predicate + isearch-search-fun-function)) + (advice-function-mapc + (lambda (_ props) + (let ((np (cdr (assq 'isearch-message-prefix props)))) + (if np (setq prefix (concat np prefix))))) + advice-function)) prefix) (isearch--describe-regexp-mode isearch-regexp-function) (cond @@ -3990,6 +4007,8 @@ since they have special meaning in a regexp." (defvar isearch-lazy-count-current nil) (defvar isearch-lazy-count-total nil) (defvar isearch-lazy-count-hash (make-hash-table)) +(defvar lazy-count-update-hook nil + "Hook run after new lazy count results are computed.") (defun lazy-highlight-cleanup (&optional force procrastinate) "Stop lazy highlighting and remove extra highlighting from current buffer. @@ -4048,7 +4067,7 @@ by other Emacs features." isearch-lazy-highlight-window-end)))))) ;; something important did indeed change (lazy-highlight-cleanup t (not (equal isearch-string ""))) ;stop old timer - (when (and isearch-lazy-count isearch-mode (null isearch-message-function)) + (when isearch-lazy-count (when (or (equal isearch-string "") ;; Check if this place was reached by a condition above ;; other than changed window boundaries (that shouldn't @@ -4067,7 +4086,10 @@ by other Emacs features." (setq isearch-lazy-count-current nil isearch-lazy-count-total nil) ;; Delay updating the message if possible, to avoid flicker - (when (string-equal isearch-string "") (isearch-message)))) + (when (string-equal isearch-string "") + (when (and isearch-mode (null isearch-message-function)) + (isearch-message)) + (run-hooks 'lazy-count-update-hook)))) (setq isearch-lazy-highlight-window-start-changed nil) (setq isearch-lazy-highlight-window-end-changed nil) (setq isearch-lazy-highlight-error isearch-error) @@ -4120,13 +4142,15 @@ by other Emacs features." 'isearch-lazy-highlight-start)))) ;; Update the current match number only in isearch-mode and ;; unless isearch-mode is used specially with isearch-message-function - (when (and isearch-lazy-count isearch-mode (null isearch-message-function)) + (when isearch-lazy-count ;; Update isearch-lazy-count-current only when it was already set ;; at the end of isearch-lazy-highlight-buffer-update (when isearch-lazy-count-current (setq isearch-lazy-count-current (gethash (point) isearch-lazy-count-hash 0)) - (isearch-message)))) + (when (and isearch-mode (null isearch-message-function)) + (isearch-message)) + (run-hooks 'lazy-count-update-hook)))) (defun isearch-lazy-highlight-search (string bound) "Search ahead for the next or previous match, for lazy highlighting. @@ -4327,16 +4351,106 @@ Attempt to do the search exactly the way the pending Isearch would." (setq looping nil nomore t)))) (if nomore - (when (and isearch-lazy-count isearch-mode (null isearch-message-function)) + (when isearch-lazy-count (unless isearch-lazy-count-total (setq isearch-lazy-count-total 0)) (setq isearch-lazy-count-current (gethash opoint isearch-lazy-count-hash 0)) - (isearch-message)) + (when (and isearch-mode (null isearch-message-function)) + (isearch-message))) (setq isearch-lazy-highlight-timer (run-at-time lazy-highlight-interval nil - 'isearch-lazy-highlight-buffer-update))))))))) + 'isearch-lazy-highlight-buffer-update))))) + (when (and nomore isearch-lazy-count) + (run-hooks 'lazy-count-update-hook)))))) + +;; Reading from minibuffer with lazy highlight and match count + +(defcustom minibuffer-lazy-count-format "%s " + "Format of the total number of matches for the prompt prefix." + :type '(choice (const :tag "Don't display a count" nil) + (string :tag "Display match count" "%s ")) + :group 'lazy-count + :version "29.1") + +(cl-defun minibuffer-lazy-highlight-setup + (&key (highlight isearch-lazy-highlight) + (cleanup lazy-highlight-cleanup) + (transform #'identity) + (filter nil) + (regexp isearch-regexp) + (regexp-function isearch-regexp-function) + (case-fold isearch-case-fold-search) + (lax-whitespace (if regexp + isearch-regexp-lax-whitespace + isearch-lax-whitespace))) + "Set up minibuffer for lazy highlight of matches in the original window. + +This function return a closure intended to be added to +`minibuffer-setup-hook'. It accepts the following keyword +arguments, all of which have a default based on the current +isearch settings. + +HIGHLIGHT: Whether to perform lazy highlight. +CLEANUP: Whether to clean up the lazy highlight when the minibuffer +exits. +TRANSFORM: A function taking one argument, the minibuffer contents, +and returning the `isearch-string' to use for lazy highlighting. +FILTER: A function to add to `isearch-filter-predicate'. +REGEXP: The value of `isearch-regexp' to use for lazy highlighting. +REGEXP-FUNCTION: The value of `isearch-regexp-function' to use for +lazy highlighting. +CASE-FOLD: The value of `isearch-case-fold' to use for lazy +highlighting. +LAX-WHITESPACE: The value of `isearch-lax-whitespace' and +`isearch-regexp-lax-whitespace' to use for lazy highlighting." + (if (not highlight) + #'ignore + (let ((unwind (make-symbol "minibuffer-lazy-highlight--unwind")) + (after-change (make-symbol "minibuffer-lazy-highlight--after-change")) + (display-count (make-symbol "minibuffer-lazy-highlight--display-count")) + overlay) + (fset unwind + (lambda () + (remove-function isearch-filter-predicate filter) + (remove-hook 'lazy-count-update-hook display-count) + (when overlay (delete-overlay overlay)) + (remove-hook 'after-change-functions after-change) + (remove-hook 'minibuffer-exit-hook unwind) + (let ((lazy-highlight-cleanup cleanup)) + (lazy-highlight-cleanup)))) + (fset after-change + (lambda (_beg _end _len) + (let ((inhibit-redisplay t) ;; Avoid cursor flickering + (string (minibuffer-contents))) + (with-minibuffer-selected-window + (let* ((isearch-forward t) + (isearch-regexp regexp) + (isearch-regexp-function regexp-function) + (isearch-case-fold-search case-fold) + (isearch-lax-whitespace lax-whitespace) + (isearch-regexp-lax-whitespace lax-whitespace) + (isearch-string (funcall transform string))) + (isearch-lazy-highlight-new-loop)))))) + (fset display-count + (lambda () + (overlay-put overlay 'before-string + (and isearch-lazy-count-total + (not isearch-error) + (format minibuffer-lazy-count-format + isearch-lazy-count-total))))) + (lambda () + (add-hook 'minibuffer-exit-hook unwind) + (add-hook 'after-change-functions after-change) + (when minibuffer-lazy-count-format + (setq overlay (make-overlay (point-min) (point-min) (current-buffer) t)) + (add-hook 'lazy-count-update-hook display-count)) + (when filter + (add-function :after-while isearch-filter-predicate filter)) + (funcall after-change nil nil nil))))) + + (defun isearch-resume (string regexp word forward message case-fold) "Resume an incremental search. STRING is the string or regexp searched for. @@ -4352,6 +4466,23 @@ CASE-FOLD non-nil means the search was case-insensitive." (isearch-search) (isearch-update)) + +(defvar isearch-fold-quotes-mode--state) +(define-minor-mode isearch-fold-quotes-mode + "Minor mode to aid searching for \\=` characters in help modes." + :lighter "" + (if isearch-fold-quotes-mode + (setq-local isearch-fold-quotes-mode--state + (buffer-local-set-state + search-default-mode + (lambda (string &optional _lax) + (thread-last + (regexp-quote string) + (replace-regexp-in-string "`" "[`‘]") + (replace-regexp-in-string "'" "['’]") + (replace-regexp-in-string "\"" "[\"“”]"))))) + (buffer-local-restore-state isearch-fold-quotes-mode--state))) + (provide 'isearch) ;;; isearch.el ends here diff --git a/lisp/keymap.el b/lisp/keymap.el index c0fdf8721b2..71454eba5e5 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -281,18 +281,7 @@ See `kbd' for a descripion of KEYS." (when key (dolist (_ (number-sequence 1 times)) (setq res (vconcat res key)))))) - (if (and (>= (length res) 4) - (eq (aref res 0) ?\C-x) - (eq (aref res 1) ?\() - (eq (aref res (- (length res) 2)) ?\C-x) - (eq (aref res (- (length res) 1)) ?\))) - (apply #'vector (let ((lres (append res nil))) - ;; Remove the first and last two elements. - (setq lres (cdr (cdr lres))) - (nreverse lres) - (setq lres (cdr (cdr lres))) - (nreverse lres))) - res)))) + res))) (defun key-valid-p (keys) "Say whether KEYS is a valid key. @@ -306,10 +295,10 @@ number of characters have a special shorthand syntax. Here's some example key sequences. - \"f\" (the key 'f') - \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm') - \"C-c o\" (a two key sequence of the keys 'c' with the control modifier - and then the key 'o') + \"f\" (the key `f') + \"S o m\" (a three key sequence of the keys `S', `o' and `m') + \"C-c o\" (a two key sequence of the keys `c' with the control modifier + and then the key `o') \"H-\" (the key named \"left\" with the hyper modifier) \"M-RET\" (the \"return\" key with a meta modifier) \"C-M-\" (the \"space\" key with both the control and meta modifiers) diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 9bbaaa666da..3f1f12fad6f 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -362,9 +362,13 @@ information." ;;; Keyboard macro ring +(oclosure-define kmacro + "Keyboard macro." + keys (counter :mutable t) format) + (defvar kmacro-ring nil "The keyboard macro ring. -Each element is a list (MACRO COUNTER FORMAT). Actually, the head of +Each element is a `kmacro'. Actually, the head of the macro ring (when defining or executing) is not stored in the ring; instead it is available in the variables `last-kbd-macro', `kmacro-counter', and `kmacro-counter-format'.") @@ -378,20 +382,23 @@ and `kmacro-counter-format'.") (defun kmacro-ring-head () "Return pseudo head element in macro ring." (and last-kbd-macro - (list last-kbd-macro kmacro-counter kmacro-counter-format-start))) + (kmacro last-kbd-macro kmacro-counter kmacro-counter-format-start))) (defun kmacro-push-ring (&optional elt) "Push ELT or current macro onto `kmacro-ring'." (when (setq elt (or elt (kmacro-ring-head))) + (when (consp elt) + (message "Converting obsolete list form of kmacro: %S" elt) + (setq elt (apply #'kmacro elt))) (let ((history-delete-duplicates nil)) (add-to-history 'kmacro-ring elt kmacro-ring-max)))) (defun kmacro-split-ring-element (elt) - (setq last-kbd-macro (car elt) - kmacro-counter (nth 1 elt) - kmacro-counter-format-start (nth 2 elt))) + (setq last-kbd-macro (kmacro--keys elt) + kmacro-counter (kmacro--counter elt) + kmacro-counter-format-start (kmacro--format elt))) (defun kmacro-pop-ring1 (&optional raw) @@ -481,21 +488,16 @@ Optional arg EMPTY is message to print if no macros are defined." ;;;###autoload -(defun kmacro-exec-ring-item (item arg) +(define-obsolete-function-alias 'kmacro-exec-ring-item #'funcall "29.1" "Execute item ITEM from the macro ring. -ARG is the number of times to execute the item." - ;; Use counter and format specific to the macro on the ring! - (let ((kmacro-counter (nth 1 item)) - (kmacro-counter-format-start (nth 2 item))) - (execute-kbd-macro (car item) arg #'kmacro-loop-setup-function) - (setcar (cdr item) kmacro-counter))) +ARG is the number of times to execute the item.") (defun kmacro-call-ring-2nd (arg) "Execute second keyboard macro in macro ring." (interactive "P") (unless (kmacro-ring-empty-p) - (kmacro-exec-ring-item (car kmacro-ring) arg))) + (funcall (car kmacro-ring) arg))) (defun kmacro-call-ring-2nd-repeat (arg) @@ -515,7 +517,7 @@ without repeating the prefix." "Display the second macro in the keyboard macro ring." (interactive) (unless (kmacro-ring-empty-p) - (kmacro-display (car (car kmacro-ring)) nil "2nd macro"))) + (kmacro-display (kmacro--keys (car kmacro-ring)) nil "2nd macro"))) (defun kmacro-cycle-ring-next (&optional _arg) @@ -611,8 +613,7 @@ Use \\[kmacro-bind-to-key] to bind it to a key sequence." (let ((append (and arg (listp arg)))) (unless append (if last-kbd-macro - (kmacro-push-ring - (list last-kbd-macro kmacro-counter kmacro-counter-format-start))) + (kmacro-push-ring)) (setq kmacro-counter (or (if arg (prefix-numeric-value arg)) kmacro-initial-counter-value 0) @@ -748,9 +749,9 @@ With \\[universal-argument], call second macro in macro ring." (if kmacro-call-repeat-key (kmacro-call-macro arg no-repeat t) (kmacro-end-macro arg))) - ((and (eq this-command 'kmacro-view-macro) ;; We are in repeat mode! + ((and (eq this-command #'kmacro-view-macro) ;; We are in repeat mode! kmacro-view-last-item) - (kmacro-exec-ring-item (car kmacro-view-last-item) arg)) + (funcall (car kmacro-view-last-item) arg)) ((and arg (listp arg)) (kmacro-call-ring-2nd 1)) (t @@ -811,42 +812,68 @@ If kbd macro currently being defined end it before activating it." ;; letters and digits, provided that we inhibit the keymap while ;; executing the macro later on (but that's controversial...) +;;;###autoload +(defun kmacro (keys &optional counter format) + "Create a `kmacro' for macro bound to symbol or key. +KEYS should be a vector or a string that obeys `key-valid-p'." + (oclosure-lambda (kmacro (keys (if (stringp keys) (key-parse keys) keys)) + (counter (or counter 0)) + (format (or format "%d"))) + (&optional arg) + ;; Use counter and format specific to the macro on the ring! + (let ((kmacro-counter counter) + (kmacro-counter-format-start format)) + (execute-kbd-macro keys arg #'kmacro-loop-setup-function) + (setq counter kmacro-counter)))) + +(cl-defmethod oclosure-interactive-form ((_ kmacro)) '(interactive "p")) + ;;;###autoload (defun kmacro-lambda-form (mac &optional counter format) - "Create lambda form for macro bound to symbol or key." ;; Apparently, there are two different ways this is called: ;; either `counter' and `format' are both provided and `mac' is a vector, ;; or only `mac' is provided, as a list (MAC COUNTER FORMAT). ;; The first is used from `insert-kbd-macro' and `edmacro-finish-edit', ;; while the second is used from within this file. - (let ((mac (if counter (list mac counter format) mac))) - ;; FIXME: This should be a "funcallable struct"! - (lambda (&optional arg) - "Keyboard macro." - ;; We put an "unused prompt" as a special marker so - ;; `kmacro-extract-lambda' can see it's "one of us". - (interactive "pkmacro") - (if (eq arg 'kmacro--extract-lambda) - (cons 'kmacro--extract-lambda mac) - (kmacro-exec-ring-item mac arg))))) + (declare (obsolete kmacro "29.1")) + (if (kmacro-p mac) mac + (when (and (null counter) (consp mac)) + (setq format (nth 2 mac)) + (setq counter (nth 1 mac)) + (setq mac (nth 0 mac))) + (when (stringp mac) + ;; `kmacro' interprets a string according to `key-parse'. + (require 'macros) + (declare-function macro--string-to-vector "macros") + (setq mac (macro--string-to-vector mac))) + (kmacro mac counter format))) (defun kmacro-extract-lambda (mac) "Extract kmacro from a kmacro lambda form." - (let ((mac (cond - ((eq (car-safe mac) 'lambda) - (let ((e (assoc 'kmacro-exec-ring-item mac))) - (car-safe (cdr-safe (car-safe (cdr-safe e)))))) - ((and (functionp mac) - (equal (interactive-form mac) '(interactive "pkmacro"))) - (let ((r (funcall mac 'kmacro--extract-lambda))) - (and (eq (car-safe r) 'kmacro--extract-lambda) (cdr r))))))) - (and (consp mac) - (= (length mac) 3) - (arrayp (car mac)) - mac))) + (declare (obsolete nil "29.1")) + (when (kmacro-p mac) + (list (kmacro--keys mac) + (kmacro--counter mac) + (kmacro--format mac)))) -(defalias 'kmacro-p #'kmacro-extract-lambda - "Return non-nil if MAC is a kmacro keyboard macro.") +(defun kmacro-p (x) + "Return non-nil if MAC is a kmacro keyboard macro." + (cl-typep x 'kmacro)) + +(cl-defmethod cl-print-object ((object kmacro) stream) + (princ "#f(kmacro " stream) + (require 'macros) + (declare-function macros--insert-vector-macro "macros" (definition)) + (let ((vecdef (kmacro--keys object)) + (counter (kmacro--counter object)) + (format (kmacro--format object))) + (prin1 (key-description vecdef) stream) + (unless (and (equal counter 0) (equal format "%d")) + (princ " " stream) + (prin1 counter stream) + (princ " " stream) + (prin1 format stream)) + (princ ")" stream))) (defun kmacro-bind-to-key (_arg) "When not defining or executing a macro, offer to bind last macro to a key. @@ -884,16 +911,15 @@ The ARG parameter is unused." (yes-or-no-p (format "%s runs command %S. Bind anyway? " (format-kbd-macro key-seq) cmd)))) - (define-key global-map key-seq - (kmacro-lambda-form (kmacro-ring-head))) + (define-key global-map key-seq (kmacro-ring-head)) (message "Keyboard macro bound to %s" (format-kbd-macro key-seq)))))) (defun kmacro-keyboard-macro-p (symbol) "Return non-nil if SYMBOL is the name of some sort of keyboard macro." (let ((f (symbol-function symbol))) (when f - (or (stringp f) - (vectorp f) + (or (stringp f) ;FIXME: Really deprecated. + (vectorp f) ;FIXME: Deprecated. (kmacro-p f))))) (defun kmacro-name-last-macro (symbol) @@ -910,9 +936,7 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command symbol)) (if (string-equal symbol "") (error "No command name given")) - ;; FIXME: Use plain old `last-kbd-macro' for kmacros where it doesn't - ;; make a difference? - (fset symbol (kmacro-lambda-form (kmacro-ring-head))) + (fset symbol (kmacro-ring-head)) ;; This used to be used to detect when a symbol corresponds to a kmacro. ;; Nowadays it's unused because we used `kmacro-p' instead to see if the ;; symbol's function definition matches that of a kmacro, which is more @@ -930,7 +954,7 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command (cl-defmethod register-val-describe ((data kmacro-register) _verbose) (princ (format "a keyboard macro:\n %s" - (format-kbd-macro (kmacro-register-macro data))))) + (key-description (kmacro-register-macro data))))) (cl-defmethod register-val-insert ((data kmacro-register)) (insert (format-kbd-macro (kmacro-register-macro data)))) @@ -953,7 +977,7 @@ The ARG parameter is unused." (interactive) (cond ((or (kmacro-ring-empty-p) - (not (eq last-command 'kmacro-view-macro))) + (not (eq last-command #'kmacro-view-macro))) (setq kmacro-view-last-item nil)) ((null kmacro-view-last-item) (setq kmacro-view-last-item kmacro-ring @@ -963,10 +987,10 @@ The ARG parameter is unused." kmacro-view-item-no (1+ kmacro-view-item-no))) (t (setq kmacro-view-last-item nil))) - (setq this-command 'kmacro-view-macro + (setq this-command #'kmacro-view-macro last-command this-command) ;; in case we repeat (kmacro-display (if kmacro-view-last-item - (car (car kmacro-view-last-item)) + (kmacro--keys (car kmacro-view-last-item)) last-kbd-macro) nil (if kmacro-view-last-item @@ -1068,21 +1092,27 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (concat (format "Macro: %s%s%s%s%s\n" (format-kbd-macro kmacro-step-edit-new-macro 1) - (if (and kmacro-step-edit-new-macro (> (length kmacro-step-edit-new-macro) 0)) " " "") + (if (and kmacro-step-edit-new-macro + (> (length kmacro-step-edit-new-macro) 0)) + " " "") (propertize (if keys (format-kbd-macro keys) - (if kmacro-step-edit-appending "" "")) 'face 'region) + (if kmacro-step-edit-appending + "" "")) + 'face 'region) (if future " " "") (if future (format-kbd-macro future) "")) (cond ((minibufferp) (format "%s\n%s\n" (propertize "\ - minibuffer " 'face 'header-line) + minibuffer " + 'face 'header-line) (buffer-substring (point-min) (point-max)))) (curmsg (format "%s\n%s\n" (propertize "\ - echo area " 'face 'header-line) + echo area " + 'face 'header-line) curmsg)) (t "")) (if keys @@ -1113,7 +1143,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', ;; Handle commands which reads additional input using read-char. (cond - ((and (eq this-command 'quoted-insert) + ((and (eq this-command #'quoted-insert) (not (eq kmacro-step-edit-action t))) ;; Find the actual end of this key sequence. ;; Must be able to backtrack in case we actually execute it. @@ -1133,7 +1163,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (cond ((eq kmacro-step-edit-action t) ;; Reentry for actual command @ end of prefix arg. (cond - ((eq this-command 'quoted-insert) + ((eq this-command #'quoted-insert) (clear-this-command-keys) ;; recent-keys actually (let (unread-command-events) (quoted-insert (prefix-numeric-value current-prefix-arg)) @@ -1177,7 +1207,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', ((eq act 'skip) nil) ((eq act 'skip-keep) - (setq this-command 'ignore) + (setq this-command #'ignore) t) ((eq act 'skip-rest) (setq kmacro-step-edit-active 'ignore) @@ -1227,7 +1257,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (if restore-index (setq executing-kbd-macro-index restore-index))) (t - (setq this-command 'ignore))) + (setq this-command #'ignore))) (setq kmacro-step-edit-key-index next-index))) (defun kmacro-step-edit-insert () @@ -1271,7 +1301,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (setq next-index kmacro-step-edit-key-index) t) (t nil)) - (setq this-command 'ignore) + (setq this-command #'ignore) (setq this-command cmd) (if (memq this-command '(self-insert-command digit-argument)) (setq last-command-event (aref keys (1- (length keys))))) @@ -1284,7 +1314,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (when kmacro-step-edit-active (cond ((eq kmacro-step-edit-active 'ignore) - (setq this-command 'ignore)) + (setq this-command #'ignore)) ((eq kmacro-step-edit-active 'append-end) (if (= executing-kbd-macro-index (length executing-kbd-macro)) (setq executing-kbd-macro (vconcat executing-kbd-macro [nil]) diff --git a/lisp/language/ind-util.el b/lisp/language/ind-util.el index 8b1c3d69ae5..60ada03fa25 100644 --- a/lisp/language/ind-util.el +++ b/lisp/language/ind-util.el @@ -255,6 +255,29 @@ "ണ്" ?ൺ "ന്" ?ൻ "ര്" ?ർ "ല്" ?ൽ "ള്" ?ൾ))) (defvar indian-tml-base-table + '( + (;; VOWELS + (?அ nil) (?ஆ ?ா) (?இ ?ி) (?ஈ ?ீ) (?உ ?ு) (?ஊ ?ூ) + nil nil nil (?ஏ ?ே) (?எ ?ெ) (?ஐ ?ை) + nil (?ஓ ?ோ) (?ஒ ?ொ) (?ஔ ?ௌ) nil nil) + (;; CONSONANTS + ?க nil nil nil ?ங ;; GUTTRULS + ?ச nil ?ஜ nil ?ஞ ;; PALATALS + ?ட nil nil nil ?ண ;; CEREBRALS + ?த nil nil nil ?ந ?ன ;; DENTALS + ?ப nil nil nil ?ம ;; LABIALS + ?ய ?ர ?ற ?ல ?ள ?ழ ?வ ;; SEMIVOWELS + nil ?ஷ ?ஸ ?ஹ ;; SIBILANTS + nil nil nil nil nil nil nil nil ;; NUKTAS + "ஜ்ஞ" "க்ஷ") + (;; Misc Symbols + nil ?ஂ ?ஃ nil ?் nil nil) + (;; Digits + nil nil nil nil nil nil nil nil nil nil) + (;; Inscript-extra (4) (#, $, ^, *, ]) + "்ர" "ர்" "த்ர" nil nil))) + +(defvar indian-tml-base-digits-table '( (;; VOWELS (?அ nil) (?ஆ ?ா) (?இ ?ி) (?ஈ ?ீ) (?உ ?ு) (?ஊ ?ூ) @@ -557,6 +580,10 @@ (defvar indian-tml-itrans-v5-hash (indian-make-hash indian-tml-base-table indian-itrans-v5-table-for-tamil)) + +(defvar indian-tml-itrans-digits-v5-hash + (indian-make-hash indian-tml-base-digits-table + indian-itrans-v5-table-for-tamil)) ) (defmacro indian-translate-region (from to hashtable encode-p) diff --git a/lisp/language/indian.el b/lisp/language/indian.el index e0adb0de6c3..c3d59b6f770 100644 --- a/lisp/language/indian.el +++ b/lisp/language/indian.el @@ -126,6 +126,17 @@ environment.")) South Indian language Malayalam is supported in this language environment.")) '("Indian")) +(set-language-info-alist + "Brahmi" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "brahmi") + (sample-text . "Brahmi (𑀩𑁆𑀭𑀸𑀳𑁆𑀫𑀻) 𑀦𑀫𑀲𑁆𑀢𑁂") + (documentation . "\ +The ancient Brahmi script is supported in this language environment.")) + '("Indian")) ; Should we have an "Old" category? + + ;; Replace mnemonic characters in REGEXP according to TABLE. TABLE is ;; an alist of (MNEMONIC-STRING . REPLACEMENT-STRING). @@ -384,6 +395,32 @@ South Indian language Malayalam is supported in this language environment.")) (list (vector (cdr slot) 0 #'font-shape-gstring)))))) char-script-table)) +;; Brahmi composition rules +(let ((consonant "[\U00011013-\U00011034]") + (non-consonant "[^\U00011013-\U00011034\U00011046\U0001107F]") + (vowel "[\U00011038-\U00011045]") + (numeral "[\U00011052-\U00011065]") + (multiplier "[\U00011064\U00011065]") + (virama "\U00011046") + (number-joiner "\U0001107F")) + (set-char-table-range composition-function-table + '(#x11046 . #x11046) + (list (vector + ;; Consonant conjuncts + (concat consonant "\\(?:" virama consonant "\\)+" + vowel "?") + 1 'font-shape-gstring) + (vector + ;; Vowelless consonants + (concat consonant virama non-consonant) + 1 'font-shape-gstring))) + (set-char-table-range composition-function-table + '(#x1107F . #x1107F) + (list (vector + ;; Additive-multiplicative numerals + (concat multiplier number-joiner numeral) + 1 'font-shape-gstring)))) + (provide 'indian) ;;; indian.el ends here diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 9f5169605b5..b79c6b2a08b 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -527,20 +527,6 @@ Return t if `allout-mode' is active in current buffer." nil t) (autoload 'allout-mode "allout" "\ Toggle Allout outline mode. -This is a minor mode. If called interactively, toggle the `Allout -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `allout-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - \\ Allout outline mode is a minor mode that provides extensive outline oriented formatting and manipulation. It enables @@ -801,6 +787,20 @@ CONCEALED: CLOSED: A TOPIC whose immediate OFFSPRING and body-text is CONCEALED. OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be. +This is a minor mode. If called interactively, toggle the +`Allout mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `allout-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defalias 'outlinify-sticky #'outlineify-sticky) @@ -851,20 +851,6 @@ See `allout-widgets-mode' for allout widgets mode features.") (autoload 'allout-widgets-mode "allout-widgets" "\ Toggle Allout Widgets mode. -This is a minor mode. If called interactively, toggle the -`Allout-Widgets mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `allout-widgets-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Allout Widgets mode is an extension of Allout mode that provides graphical decoration of outline structure. It is meant to operate along with `allout-mode', via `allout-mode-hook'. @@ -883,6 +869,20 @@ The bullet-icon and guide line graphics provide keybindings and mouse bindings for easy outline navigation and exposure control, extending outline hot-spot navigation (see `allout-mode'). +This is a minor mode. If called interactively, toggle the +`Allout-Widgets mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `allout-widgets-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "allout-widgets" '("allout-")) @@ -1130,6 +1130,9 @@ consider all symbols (if they match PATTERN). Return list of symbols and documentation found. +The *Apropos* window will be selected if `help-window-select' is +non-nil. + \(fn PATTERN &optional DO-ALL)" t nil) (autoload 'apropos-library "apropos" "\ @@ -1286,20 +1289,6 @@ Entering array mode calls the function `array-mode-hook'. (autoload 'artist-mode "artist" "\ Toggle Artist mode. -This is a minor mode. If called interactively, toggle the `Artist -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `artist-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Artist lets you draw lines, squares, rectangles and poly-lines, ellipses and circles with your mouse and/or keyboard. @@ -1495,6 +1484,20 @@ Keymap summary \\{artist-mode-map} +This is a minor mode. If called interactively, toggle the +`Artist mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `artist-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "artist" '("artist-")) @@ -1579,78 +1582,6 @@ key2: value2 (register-definition-prefixes "auth-source-pass" '("auth-source-pass-")) -;;;*** - -;;;### (autoloads nil "autoarg" "autoarg.el" (0 0 0 0)) -;;; Generated autoloads from autoarg.el - -(defvar autoarg-mode nil "\ -Non-nil if Autoarg mode is enabled. -See the `autoarg-mode' command -for a description of this minor mode.") - -(custom-autoload 'autoarg-mode "autoarg" nil) - -(autoload 'autoarg-mode "autoarg" "\ -Toggle Autoarg mode, a global minor mode. - -\\ -In Autoarg mode, digits are bound to `digit-argument', i.e. they -supply prefix arguments as C-DIGIT and M-DIGIT normally do. -Furthermore, C-DIGIT inserts DIGIT. -\\[autoarg-terminate] terminates the prefix sequence and inserts -the digits of the autoarg sequence into the buffer. -Without a numeric prefix arg, the normal binding of \\[autoarg-terminate] -is invoked, i.e. what it would be with Autoarg mode off. - -For example: -`6 9 \\[autoarg-terminate]' inserts `69' into the buffer, as does `C-6 C-9'. -`6 9 a' inserts 69 `a's into the buffer. -`6 9 \\[autoarg-terminate] \\[autoarg-terminate]' inserts `69' into the buffer and -then invokes the normal binding of \\[autoarg-terminate]. -`\\[universal-argument] \\[autoarg-terminate]' invokes the normal binding of \\[autoarg-terminate] four times. - -\\{autoarg-mode-map} - -\(fn &optional ARG)" t nil) - -(defvar autoarg-kp-mode nil "\ -Non-nil if Autoarg-Kp mode is enabled. -See the `autoarg-kp-mode' command -for a description of this minor mode. -Setting this variable directly does not take effect; -either customize it (see the info node `Easy Customization') -or call the function `autoarg-kp-mode'.") - -(custom-autoload 'autoarg-kp-mode "autoarg" nil) - -(autoload 'autoarg-kp-mode "autoarg" "\ -Toggle Autoarg-KP mode, a global minor mode. - -This is a minor mode. If called interactively, toggle the `Autoarg-Kp -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='autoarg-kp-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\\ -This is similar to `autoarg-mode' but rebinds the keypad keys -`kp-1' etc. to supply digit arguments. - -\\{autoarg-kp-mode-map} - -\(fn &optional ARG)" t nil) - -(register-definition-prefixes "autoarg" '("autoarg-")) - ;;;*** ;;;### (autoloads nil "autoconf" "progmodes/autoconf.el" (0 0 0 0)) @@ -1694,22 +1625,22 @@ or call the function `auto-insert-mode'.") (autoload 'auto-insert-mode "autoinsert" "\ Toggle Auto-insert mode, a global minor mode. -This is a minor mode. If called interactively, toggle the -`Auto-Insert mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +When Auto-insert mode is enabled, when new files are created you can +insert a template for the file depending on the mode of the buffer. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a global minor mode. If called interactively, toggle the +`Auto-Insert mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='auto-insert-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When Auto-insert mode is enabled, when new files are created you can -insert a template for the file depending on the mode of the buffer. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -1790,20 +1721,6 @@ should be non-nil)." nil nil) (autoload 'auto-revert-mode "autorevert" "\ Toggle reverting buffer when the file changes (Auto-Revert Mode). -This is a minor mode. If called interactively, toggle the -`Auto-Revert mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `auto-revert-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Auto-Revert Mode is a minor mode that affects only the current buffer. When enabled, it reverts the buffer when the file on disk changes. @@ -1819,6 +1736,20 @@ Use `global-auto-revert-mode' to automatically revert all buffers. Use `auto-revert-tail-mode' if you know that the file will only grow without being changed in the part that is already in the buffer. +This is a minor mode. If called interactively, toggle the +`Auto-Revert mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `auto-revert-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'turn-on-auto-revert-mode "autorevert" "\ @@ -1830,20 +1761,6 @@ This function is designed to be added to hooks, for example: (autoload 'auto-revert-tail-mode "autorevert" "\ Toggle reverting tail of buffer when the file grows. -This is a minor mode. If called interactively, toggle the -`Auto-Revert-Tail mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `auto-revert-tail-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Auto-Revert Tail Mode is enabled, the tail of the file is constantly followed, as with the shell command `tail -f'. This means that whenever the file grows on disk (presumably because @@ -1859,6 +1776,21 @@ suppressed by setting `auto-revert-verbose' to nil. Use `auto-revert-mode' for changes other than appends! +This is a minor mode. If called interactively, toggle the +`Auto-Revert-Tail mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `auto-revert-tail-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'turn-on-auto-revert-tail-mode "autorevert" "\ @@ -1880,20 +1812,6 @@ or call the function `global-auto-revert-mode'.") (autoload 'global-auto-revert-mode "autorevert" "\ Toggle Global Auto-Revert Mode. -This is a minor mode. If called interactively, toggle the `Global -Auto-Revert mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='global-auto-revert-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Global Auto-Revert Mode is a global minor mode that reverts any buffer associated with a file when the file changes on disk. Use `auto-revert-mode' to revert a particular buffer. @@ -1911,6 +1829,21 @@ This function calls the hook `global-auto-revert-mode-hook'. It displays the text that `global-auto-revert-mode-text' specifies in the mode line. +This is a global minor mode. If called interactively, toggle the +`Global Auto-Revert mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='global-auto-revert-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "autorevert" '("auto-revert-" "global-auto-revert-")) @@ -2019,25 +1952,25 @@ or call the function `display-battery-mode'.") (autoload 'display-battery-mode "battery" "\ Toggle battery status display in mode line (Display Battery mode). -This is a minor mode. If called interactively, toggle the -`Display-Battery mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='display-battery-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - The text displayed in the mode line is controlled by `battery-mode-line-format' and `battery-status-function'. The mode line is be updated every `battery-update-interval' seconds. +This is a global minor mode. If called interactively, toggle the +`Display-Battery mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='display-battery-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "battery" '("battery-")) @@ -3002,18 +2935,18 @@ columns on its right towards the left. Toggle hyperlinking bug references in the buffer (Bug Reference mode). This is a minor mode. If called interactively, toggle the -`Bug-Reference mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Bug-Reference mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `bug-reference-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -3021,18 +2954,19 @@ disabled. Like `bug-reference-mode', but only buttonize in comments and strings. This is a minor mode. If called interactively, toggle the -`Bug-Reference-Prog mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Bug-Reference-Prog mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `bug-reference-prog-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -4794,26 +4728,26 @@ Prefix argument is the same as for `checkdoc-defun'." t nil) (autoload 'checkdoc-minor-mode "checkdoc" "\ Toggle automatic docstring checking (Checkdoc minor mode). -This is a minor mode. If called interactively, toggle the `Checkdoc -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `checkdoc-minor-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - In Checkdoc minor mode, the usual bindings for `eval-defun' which is bound to \\\\[checkdoc-eval-defun] and `checkdoc-eval-current-buffer' are overridden to include checking of documentation strings. \\{checkdoc-minor-mode-map} +This is a minor mode. If called interactively, toggle the +`Checkdoc minor mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `checkdoc-minor-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'checkdoc-package-keywords "checkdoc" "\ @@ -4913,20 +4847,20 @@ or call the function `cl-font-lock-built-in-mode'.") (autoload 'cl-font-lock-built-in-mode "cl-font-lock" "\ Highlight built-in functions, variables, and types in `lisp-mode'. -This is a minor mode. If called interactively, toggle the +This is a global minor mode. If called interactively, toggle the `Cl-Font-Lock-Built-In mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable the -mode. +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='cl-font-lock-built-in-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -5013,7 +4947,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (autoload 'cl-generic-define-method "cl-generic" "\ -\(fn NAME QUALIFIERS ARGS USES-CNM FUNCTION)" nil nil) +\(fn NAME QUALIFIERS ARGS CALL-CON FUNCTION)" nil nil) (autoload 'cl-find-method "cl-generic" "\ @@ -5131,6 +5065,9 @@ Increment PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. The return value is the incremented value of PLACE. +If X is specified, it should be an expression that should +evaluate to a number. + \(fn PLACE &optional X)" nil t) (defvar cl-old-struct-compat-mode nil "\ @@ -5145,23 +5082,25 @@ or call the function `cl-old-struct-compat-mode'.") (autoload 'cl-old-struct-compat-mode "cl-lib" "\ Enable backward compatibility with old-style structs. + This can be needed when using code byte-compiled using the old macro-expansion of `cl-defstruct' that used vectors objects instead of record objects. -This is a minor mode. If called interactively, toggle the -`Cl-Old-Struct-Compat mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Cl-Old-Struct-Compat mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='cl-old-struct-compat-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -5461,7 +5400,7 @@ Generate .elc files in addition to the .eln files. Force the produced .eln to be outputted in the eln system directory (the last entry in `native-comp-eln-load-path') unless `native-compile-target-directory' is non-nil. If the environment -variable 'NATIVE_DISABLED' is set, only byte compile." nil nil) +variable \"NATIVE_DISABLED\" is set, only byte compile." nil nil) (autoload 'native-compile-async "comp" "\ Compile FILES asynchronously. @@ -5689,48 +5628,49 @@ Runs `compilation-mode-hook' with `run-mode-hooks' (which see). (autoload 'compilation-shell-minor-mode "compile" "\ Toggle Compilation Shell minor mode. -This is a minor mode. If called interactively, toggle the -`Compilation-Shell minor mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable the -mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `compilation-shell-minor-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Compilation Shell minor mode is enabled, all the error-parsing commands of the Compilation major mode are available but bound to keys that don't collide with Shell mode. See `compilation-mode'. +This is a minor mode. If called interactively, toggle the +`Compilation-Shell minor mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `compilation-shell-minor-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'compilation-minor-mode "compile" "\ Toggle Compilation minor mode. -This is a minor mode. If called interactively, toggle the -`Compilation minor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +When Compilation minor mode is enabled, all the error-parsing +commands of Compilation major mode are available. See +`compilation-mode'. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a minor mode. If called interactively, toggle the +`Compilation minor mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `compilation-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When Compilation minor mode is enabled, all the error-parsing -commands of Compilation major mode are available. See -`compilation-mode'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -5760,19 +5700,20 @@ or call the function `dynamic-completion-mode'.") (autoload 'dynamic-completion-mode "completion" "\ Toggle dynamic word-completion on or off. -This is a minor mode. If called interactively, toggle the -`Dynamic-Completion mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Dynamic-Completion mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='dynamic-completion-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -6329,20 +6270,6 @@ or call the function `cua-mode'.") (autoload 'cua-mode "cua-base" "\ Toggle Common User Access style editing (CUA mode). -This is a minor mode. If called interactively, toggle the `Cua mode' -mode. If the prefix argument is positive, enable the mode, and if it -is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='cua-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - CUA mode is a global minor mode. When enabled, typed text replaces the active selection, and you can use C-z, C-x, C-c, and C-v to undo, cut, copy, and paste in addition to the normal Emacs @@ -6361,6 +6288,20 @@ You can customize `cua-enable-cua-keys' to completely disable the CUA bindings, or `cua-prefix-override-inhibit-delay' to change the prefix fallback behavior. +This is a global minor mode. If called interactively, toggle the +`Cua mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='cua-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'cua-selection-mode "cua-base" "\ @@ -6384,21 +6325,23 @@ Enable CUA selection mode without the C-z/C-x/C-c/C-v bindings. (autoload 'cua-rectangle-mark-mode "cua-rect" "\ Toggle the region as rectangular. + Activates the region if needed. Only lasts until the region is deactivated. This is a minor mode. If called interactively, toggle the -`Cua-Rectangle-Mark mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Cua-Rectangle-Mark mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `cua-rectangle-mark-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -6419,23 +6362,25 @@ By convention, this is a list of symbols where each symbol stands for the Keep cursor outside of any `cursor-intangible' text property. This is a minor mode. If called interactively, toggle the -`Cursor-Intangible mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Cursor-Intangible mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `cursor-intangible-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) (autoload 'cursor-sensor-mode "cursor-sensor" "\ Handle the `cursor-sensor-functions' text property. + This property should hold a list of functions which react to the motion of the cursor. They're called with three arguments (WINDOW OLDPOS DIR) where WINDOW is the affected window, OLDPOS is the last known position of @@ -6443,18 +6388,18 @@ the cursor and DIR can be `entered' or `left' depending on whether the cursor is entering the area covered by the text-property property or leaving it. This is a minor mode. If called interactively, toggle the -`Cursor-Sensor mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Cursor-Sensor mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `cursor-sensor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -6517,6 +6462,19 @@ If given a prefix (or a COMMENT argument), also prompt for a comment. \(fn VARIABLE VALUE &optional COMMENT)" t nil) +(autoload 'setopt "cus-edit" "\ +Set VARIABLE/VALUE pairs, and return the final VALUE. +This is like `setq', but is meant for user options instead of +plain variables. This means that `setopt' will execute any +`custom-set' form associated with VARIABLE. + +\(fn [VARIABLE VALUE]...)" nil t) + +(autoload 'setopt--set "cus-edit" "\ + + +\(fn VARIABLE VALUE)" nil nil) + (autoload 'customize-save-variable "cus-edit" "\ Set the default for VARIABLE to VALUE, and save it for future sessions. Return VALUE. @@ -6690,7 +6648,7 @@ Customize all loaded groups matching REGEXP. (autoload 'custom-prompt-customize-unsaved-options "cus-edit" "\ Prompt user to customize any unsaved customization options. -Return non-nil if user chooses to customize, for use in +Return nil if user chooses to customize, for use in `kill-emacs-query-functions'." nil nil) (autoload 'custom-buffer-create "cus-edit" "\ @@ -6831,26 +6789,26 @@ Mode used for cvs status output. (autoload 'cwarn-mode "cwarn" "\ Minor mode that highlights suspicious C and C++ constructions. -This is a minor mode. If called interactively, toggle the `Cwarn -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `cwarn-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Suspicious constructs are highlighted using `font-lock-warning-face'. Note, in addition to enabling this minor mode, the major mode must be included in the variable `cwarn-configuration'. By default C and C++ modes are included. +This is a minor mode. If called interactively, toggle the `Cwarn +mode' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `cwarn-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (define-obsolete-function-alias 'turn-on-cwarn-mode 'cwarn-mode "24.1") @@ -7302,20 +7260,6 @@ or call the function `delete-selection-mode'.") (autoload 'delete-selection-mode "delsel" "\ Toggle Delete Selection mode. -This is a minor mode. If called interactively, toggle the -`Delete-Selection mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='delete-selection-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Delete Selection mode is enabled, typed text replaces the selection if the selection is active. Otherwise, typed text is just inserted at point regardless of any selection. @@ -7323,6 +7267,21 @@ point regardless of any selection. See `delete-selection-helper' and `delete-selection-pre-hook' for information on adapting behavior of commands in Delete Selection mode. +This is a global minor mode. If called interactively, toggle the +`Delete-Selection mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='delete-selection-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'delete-active-region "delsel" "\ @@ -7492,20 +7451,6 @@ or call the function `desktop-save-mode'.") (autoload 'desktop-save-mode "desktop" "\ Toggle desktop saving (Desktop Save mode). -This is a minor mode. If called interactively, toggle the -`Desktop-Save mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='desktop-save-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Desktop Save mode is enabled, the state of Emacs is saved from one session to another. In particular, Emacs will save the desktop when it exits (this may prompt you; see the option `desktop-save'). The next @@ -7521,6 +7466,20 @@ To see all the options you can set, browse the `desktop' customization group. For further details, see info node `(emacs)Saving Emacs Sessions'. +This is a global minor mode. If called interactively, toggle the +`Desktop-Save mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='desktop-save-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defvar desktop-locals-to-save '(desktop-locals-to-save truncate-lines case-fold-search case-replace fill-column overwrite-mode change-log-default-name line-number-mode column-number-mode size-indication-mode buffer-file-coding-system buffer-display-time indent-tabs-mode tab-width indicate-buffer-boundaries indicate-empty-lines show-trailing-whitespace) "\ @@ -7729,6 +7688,12 @@ If NODISPLAY is non-nil, don't redisplay the article buffer. \(fn &optional NODISPLAY)" '(gnus-article-mode gnus-summary-mode) nil) +(autoload 'gnus-article-outlook-rearrange-citation "deuglify" "\ +Repair broken citations. +If NODISPLAY is non-nil, don't redisplay the article buffer. + +\(fn &optional NODISPLAY)" '(gnus-article-mode gnus-summary-mode) nil) + (autoload 'gnus-outlook-deuglify-article "deuglify" "\ Full deuglify of broken Outlook (Express) articles. Treat \"smartquotes\", unwrap lines, repair attribution and @@ -7740,7 +7705,7 @@ article buffer. (autoload 'gnus-article-outlook-deuglify-article "deuglify" "\ Deuglify broken Outlook (Express) articles and redisplay." '(gnus-article-mode gnus-summary-mode) nil) -(register-definition-prefixes "deuglify" '("gnus-")) +(register-definition-prefixes "deuglify" '("gnus-outlook-")) ;;;*** @@ -7956,6 +7921,8 @@ diff command. OLD and NEW may each be a buffer or a buffer name. +Also see the `diff-entire-buffers' variable. + \(fn OLD NEW &optional SWITCHES NO-ASYNC)" t nil) (register-definition-prefixes "diff" '("diff-")) @@ -7985,21 +7952,21 @@ a diff with \\[diff-reverse-direction]. (autoload 'diff-minor-mode "diff-mode" "\ Toggle Diff minor mode. -This is a minor mode. If called interactively, toggle the `Diff minor -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +\\{diff-minor-mode-map} -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a minor mode. If called interactively, toggle the `Diff +minor mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `diff-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\\{diff-minor-mode-map} +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -8045,7 +8012,7 @@ some of the `ls' switches are not supported; see the doc string of (custom-autoload 'dired-listing-switches "dired" t) -(defvar dired-directory nil "\ +(defvar-local dired-directory nil "\ The directory name or wildcard spec that this Dired directory lists. Local to each Dired buffer. May be a list, in which case the car is the directory name and the cdr is the list of files to mention. @@ -8054,8 +8021,11 @@ The directory name must be absolute, but need not be fully expanded.") (autoload 'dired "dired" "\ \"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. -Optional second argument SWITCHES specifies the `ls' options used. -\(Interactively, use a prefix argument to be able to specify SWITCHES.) +Optional second argument SWITCHES specifies the options to be used +when invoking `insert-directory-program', usually `ls', which produces +the listing of the directory files and their attributes. +Interactively, a prefix argument will cause the command to prompt +for SWITCHES. If DIRNAME is a string, Dired displays a list of files in DIRNAME (which may also have shell wildcards appended to select certain files). @@ -8183,20 +8153,6 @@ Like \\[dired-jump] (`dired-jump') but in other window. (autoload 'dirtrack-mode "dirtrack" "\ Toggle directory tracking in shell buffers (Dirtrack mode). -This is a minor mode. If called interactively, toggle the `Dirtrack -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `dirtrack-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - This method requires that your shell prompt contain the current working directory at all times, and that you set the variable `dirtrack-list' to match the prompt. @@ -8205,6 +8161,20 @@ This is an alternative to `shell-dirtrack-mode', which works by tracking `cd' and similar commands which change the shell working directory. +This is a minor mode. If called interactively, toggle the +`Dirtrack mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `dirtrack-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'dirtrack "dirtrack" "\ @@ -8361,23 +8331,9 @@ in `.emacs'. (autoload 'display-fill-column-indicator-mode "display-fill-column-indicator" "\ Toggle display of `fill-column' indicator. + This uses `display-fill-column-indicator' internally. -This is a minor mode. If called interactively, toggle the -`Display-Fill-Column-Indicator mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable the -mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `display-fill-column-indicator-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - To change the position of the column displayed by default customize `display-fill-column-indicator-column'. You can change the character for the indicator setting `display-fill-column-indicator-character'. @@ -8385,6 +8341,21 @@ The globalized version is `global-display-fill-column-indicator-mode', which see. See Info node `Displaying Boundaries' for details. +This is a minor mode. If called interactively, toggle the +`Display-Fill-Column-Indicator mode' mode. If the prefix +argument is positive, enable the mode, and if it is zero or +negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `display-fill-column-indicator-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (put 'global-display-fill-column-indicator-mode 'globalized-minor-mode t) @@ -8445,26 +8416,28 @@ list.") (autoload 'display-line-numbers-mode "display-line-numbers" "\ Toggle display of line numbers in the buffer. + This uses `display-line-numbers' internally. -This is a minor mode. If called interactively, toggle the -`Display-Line-Numbers mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `display-line-numbers-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - To change the type of line numbers displayed by default, customize `display-line-numbers-type'. To change the type while the mode is on, set `display-line-numbers' directly. +This is a minor mode. If called interactively, toggle the +`Display-Line-Numbers mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `display-line-numbers-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (put 'global-display-line-numbers-mode 'globalized-minor-mode t) @@ -8603,21 +8576,21 @@ to the next best mode." nil nil) (autoload 'doc-view-minor-mode "doc-view" "\ Toggle displaying buffer via Doc View (Doc View minor mode). -This is a minor mode. If called interactively, toggle the `Doc-View -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +See the command `doc-view-mode' for more information on this mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a minor mode. If called interactively, toggle the +`Doc-View minor mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `doc-view-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -See the command `doc-view-mode' for more information on this mode. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -8674,22 +8647,22 @@ Switch to *doctor* buffer and start giving psychotherapy." t nil) (autoload 'double-mode "double" "\ Toggle special insertion on double keypresses (Double mode). -This is a minor mode. If called interactively, toggle the `Double -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +When Double mode is enabled, some keys will insert different +strings when pressed twice. See `double-map' for details. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a minor mode. If called interactively, toggle the +`Double mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `double-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When Double mode is enabled, some keys will insert different -strings when pressed twice. See `double-map' for details. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -9266,6 +9239,11 @@ If regular expression is nil, repeat last search. Query replace FROM with TO in all files of a class tree. With prefix arg, process files of marked classes only. +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. + \(fn FROM TO)" t nil) (autoload 'ebrowse-tags-search-member-use "ebrowse" "\ @@ -9384,22 +9362,22 @@ or call the function `global-ede-mode'.") (autoload 'global-ede-mode "ede" "\ Toggle global EDE (Emacs Development Environment) mode. -This is a minor mode. If called interactively, toggle the `Global Ede -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This global minor mode enables `ede-minor-mode' in all buffers in +an EDE controlled project. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a global minor mode. If called interactively, toggle the +`Global Ede mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='global-ede-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -This global minor mode enables `ede-minor-mode' in all buffers in -an EDE controlled project. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -10229,7 +10207,7 @@ It creates an autoload function for CNAME's constructor. ;;;### (autoloads nil "eldoc" "emacs-lisp/eldoc.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/eldoc.el -(push (purecopy '(eldoc 1 11 0)) package--builtin-versions) +(push (purecopy '(eldoc 1 11 1)) package--builtin-versions) ;;;*** @@ -10249,20 +10227,6 @@ or call the function `electric-pair-mode'.") (autoload 'electric-pair-mode "elec-pair" "\ Toggle automatic parens pairing (Electric Pair mode). -This is a minor mode. If called interactively, toggle the -`Electric-Pair mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='electric-pair-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Electric Pair mode is a global minor mode. When enabled, typing an open parenthesis automatically inserts the corresponding closing parenthesis, and vice versa. (Likewise for brackets, etc.). @@ -10271,25 +10235,40 @@ inserted around the region instead. To toggle the mode in a single buffer, use `electric-pair-local-mode'. +This is a global minor mode. If called interactively, toggle the +`Electric-Pair mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='electric-pair-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'electric-pair-local-mode "elec-pair" "\ Toggle `electric-pair-mode' only in this buffer. This is a minor mode. If called interactively, toggle the -`Electric-Pair-Local mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Electric-Pair-Local mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(buffer-local-value \\='electric-pair-mode \(current-buffer))'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -10303,26 +10282,26 @@ disabled. (autoload 'elide-head-mode "elide-head" "\ Toggle eliding (hiding) header material in the current buffer. -This is a minor mode. If called interactively, toggle the `Elide-Head -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `elide-head-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Elide Header mode is enabled, headers are hidden according to `elide-head-headers-to-hide'. This is suitable as an entry on `find-file-hook' or appropriate mode hooks. +This is a minor mode. If called interactively, toggle the +`Elide-Head mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `elide-head-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'elide-head "elide-head" "\ @@ -10397,6 +10376,11 @@ For example, to instrument all ELP functions, do the following: \\[elp-instrument-package] RET elp- RET +Note that only functions that are currently loaded will be +instrumented. If you run this function, and then later load +further functions that start with PREFIX, they will not be +instrumented automatically. + \(fn PREFIX)" t nil) (autoload 'elp-results "elp" "\ @@ -10413,7 +10397,7 @@ displayed." t nil) ;;;;;; 0)) ;;; Generated autoloads from eshell/em-extpipe.el -(register-definition-prefixes "em-extpipe" '("eshell-")) +(register-definition-prefixes "em-extpipe" '("em-extpipe--or-with-catch" "eshell-")) ;;;*** @@ -10445,6 +10429,24 @@ some major modes from being locked under some circumstances. (register-definition-prefixes "emacs-lock" '("emacs-lock-" "toggle-emacs-lock")) +;;;*** + +;;;### (autoloads nil "emacs-news-mode" "textmodes/emacs-news-mode.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from textmodes/emacs-news-mode.el + +(autoload 'emacs-news-mode "emacs-news-mode" "\ +Major mode for editing the Emacs NEWS file. + +\(fn)" t nil) + +(autoload 'emacs-news-view-mode "emacs-news-mode" "\ +Major mode for viewing the Emacs NEWS file. + +\(fn)" t nil) + +(register-definition-prefixes "emacs-news-mode" '("emacs-news-")) + ;;;*** ;;;### (autoloads nil "emacsbug" "mail/emacsbug.el" (0 0 0 0)) @@ -10576,23 +10578,10 @@ the name is not known. (autoload 'enriched-mode "enriched" "\ Minor mode for editing text/enriched files. + These are files with embedded formatting information in the MIME standard text/enriched format. -This is a minor mode. If called interactively, toggle the `Enriched -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `enriched-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Turning the mode on or off runs `enriched-mode-hook'. More information about Enriched mode is available in the file @@ -10602,6 +10591,20 @@ Commands: \\{enriched-mode-map} +This is a minor mode. If called interactively, toggle the +`Enriched mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `enriched-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'enriched-encode "enriched" "\ @@ -10865,19 +10868,19 @@ enough, since keyservers have strict timeout settings. (autoload 'epa-mail-mode "epa-mail" "\ A minor-mode for composing encrypted/clearsigned mails. -This is a minor mode. If called interactively, toggle the `epa-mail -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the +`epa-mail mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `epa-mail-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -10938,19 +10941,19 @@ or call the function `epa-global-mail-mode'.") (autoload 'epa-global-mail-mode "epa-mail" "\ Minor mode to hook EasyPG into Mail mode. -This is a minor mode. If called interactively, toggle the +This is a global minor mode. If called interactively, toggle the `Epa-Global-Mail mode' mode. If the prefix argument is positive, enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='epa-global-mail-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -11078,7 +11081,7 @@ Example usage: (erc-tls :server \"irc.libera.chat\" :port 6697 :client-certificate - '(\"/home/bandali/my-cert.key\" + \\='(\"/home/bandali/my-cert.key\" \"/home/bandali/my-cert.crt\")) \(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) PASSWORD (FULL-NAME (erc-compute-full-name)) CLIENT-CERTIFICATE)" t nil) @@ -11624,7 +11627,13 @@ Do `query-replace-regexp' of FROM with TO on all files listed in tags table. Third arg DELIMITED (prefix arg) means replace only word-delimited matches. If you exit (\\[keyboard-quit], RET or q), you can resume the query replace with the command \\[fileloop-continue]. -For non-interactive use, superseded by `fileloop-initialize-replace'. + +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. + +For non-interactive use, this is superseded by `fileloop-initialize-replace'. \(fn FROM TO &optional DELIMITED FILES)" t nil) @@ -11854,6 +11863,15 @@ If ERROR is non-nil, report an error if there is none. \(fn NAME &optional ERROR)" t nil) +(autoload 'eudc-expand-try-all "eudc" "\ +Wrap `eudc-expand-inline' with a prefix argument. +If TRY-ALL-SERVERS -- the prefix argument when called +interactively -- is non-nil, collect results from all servers. +If TRY-ALL-SERVERS is nil, do not try subsequent servers after +one server returns any match. + +\(fn &optional TRY-ALL-SERVERS)" t nil) + (autoload 'eudc-expand-inline "eudc" "\ Query the directory server, and expand the query string before point. The query string consists of the buffer substring from the point back to @@ -11862,12 +11880,19 @@ The variable `eudc-inline-query-format' controls how to associate the individual inline query words with directory attribute names. After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is inserted in the buffer at point. -If REPLACE is non-nil, then this expansion replaces the name in the buffer. -`eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE. +If SAVE-QUERY-AS-KILL is non-nil, then save the pre-expansion +text to the kill ring. `eudc-expansion-save-query-as-kill' being +non-nil inverts the meaning of SAVE-QUERY-AS-KILL. Multiple servers can be tried with the same query until one finds a match, -see `eudc-inline-expansion-servers'. +see `eudc-inline-expansion-servers'. If TRY-ALL-SERVERS is +non-nil, collect results from all servers. -\(fn &optional REPLACE)" t nil) +\(fn &optional SAVE-QUERY-AS-KILL TRY-ALL-SERVERS)" t nil) + +(autoload 'eudc-format-inline-expansion-result "eudc" "\ +Format a query result according to `eudc-inline-expansion-format'. + +\(fn RES QUERY-ATTRS)" nil nil) (autoload 'eudc-query-with-words "eudc" "\ Query the directory server, and return the matching responses. @@ -11875,11 +11900,12 @@ The variable `eudc-inline-query-format' controls how to associate the individual QUERY-WORDS with directory attribute names. After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is applied to the -matches before returning them.inserted in the buffer at point. +matches before returning them. Multiple servers can be tried with the same query until one finds a match, -see `eudc-inline-expansion-servers'. +see `eudc-inline-expansion-servers'. When TRY-ALL-SERVERS is non-nil, +keep collecting results from subsequent servers after the first match. -\(fn QUERY-WORDS)" nil nil) +\(fn QUERY-WORDS &optional TRY-ALL-SERVERS)" nil nil) (autoload 'eudc-query-form "eudc" "\ Display a form to query the directory server. @@ -12398,22 +12424,22 @@ Adjust the height of the default face by the scale in the pinch event EVENT. (autoload 'buffer-face-mode "face-remap" "\ Minor mode for a buffer-specific default face. -This is a minor mode. If called interactively, toggle the -`Buffer-Face mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +When enabled, the face specified by the variable +`buffer-face-mode-face' is used to display the buffer text. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a minor mode. If called interactively, toggle the +`Buffer-Face mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `buffer-face-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When enabled, the face specified by the variable -`buffer-face-mode-face' is used to display the buffer text. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -13058,6 +13084,9 @@ Interactively, prompt for LIBRARY using the one at or near point. This function searches `find-library-source-path' if non-nil, and `load-path' otherwise. +See the `find-library-include-other-files' user option for +customizing the candidate completions. + \(fn LIBRARY)" t nil) (autoload 'read-library-name "find-func" "\ @@ -13218,7 +13247,7 @@ Find directly the variable at point in the other window." t nil) (autoload 'find-function-setup-keys "find-func" "\ Define some key bindings for the `find-function' family of functions." nil nil) -(register-definition-prefixes "find-func" '("find-")) +(register-definition-prefixes "find-func" '("find-" "read-library-name--find-files")) ;;;*** @@ -13309,7 +13338,7 @@ lines. ;;;### (autoloads nil "flymake" "progmodes/flymake.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/flymake.el -(push (purecopy '(flymake 1 2 1)) package--builtin-versions) +(push (purecopy '(flymake 1 2 2)) package--builtin-versions) (autoload 'flymake-log "flymake" "\ Log, at level LEVEL, the message MSG formatted with ARGS. @@ -13362,20 +13391,6 @@ region is invalid. This function saves match data. (autoload 'flymake-mode "flymake" "\ Toggle Flymake mode on or off. -This is a minor mode. If called interactively, toggle the `Flymake -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `flymake-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Flymake is an Emacs minor mode for on-the-fly syntax checking. Flymake collects diagnostic information from multiple sources, called backends, and visually annotates the buffer with the @@ -13406,6 +13421,20 @@ suitable for the current buffer. The commands `flymake-reporting-backends' summarize the situation, as does the special *Flymake log* buffer. +This is a minor mode. If called interactively, toggle the +`Flymake mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `flymake-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'flymake-mode-on "flymake" "\ @@ -13453,24 +13482,13 @@ Turn on `flyspell-mode' for comments and strings." t nil) (autoload 'flyspell-mode "flyspell" "\ Toggle on-the-fly spell checking (Flyspell mode). -This is a minor mode. If called interactively, toggle the `Flyspell -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `flyspell-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Flyspell mode is a buffer-local minor mode. When enabled, it spawns a single Ispell process and checks each word. The default flyspell behavior is to highlight incorrect words. +This mode is geared toward text modes. In buffers that contain +code, `flyspell-prog-mode' is usually a better choice. + Bindings: \\[ispell-word]: correct words (using Ispell). \\[flyspell-auto-correct-word]: automatically correct word. @@ -13493,6 +13511,20 @@ in your init file. \\[flyspell-region] checks all words inside a region. \\[flyspell-buffer] checks the whole buffer. +This is a minor mode. If called interactively, toggle the +`Flyspell mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `flyspell-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'turn-on-flyspell "flyspell" "\ @@ -13539,20 +13571,6 @@ Turn off Follow mode. Please see the function `follow-mode'." nil nil) (autoload 'follow-mode "follow" "\ Toggle Follow mode. -This is a minor mode. If called interactively, toggle the `Follow -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `follow-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Follow mode is a minor mode that combines windows into one tall virtual window. This is accomplished by two main techniques: @@ -13582,6 +13600,20 @@ This command runs the normal hook `follow-mode-hook'. Keys specific to Follow mode: \\{follow-mode-map} +This is a minor mode. If called interactively, toggle the +`Follow mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `follow-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'follow-scroll-up-window "follow" "\ @@ -13672,25 +13704,25 @@ selected if the original window is the first one in the frame. (autoload 'footnote-mode "footnote" "\ Toggle Footnote mode. -This is a minor mode. If called interactively, toggle the `Footnote -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `footnote-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Footnote mode is a buffer-local minor mode. If enabled, it provides footnote support for `message-mode'. To get started, play around with the following keys: \\{footnote-minor-mode-map} +This is a minor mode. If called interactively, toggle the +`Footnote mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `footnote-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "footnote" '("footnote-")) @@ -13935,7 +13967,7 @@ and choose the directory as the fortune-file. Minimum set of parameters to filter for live (on-session) framesets. DO NOT MODIFY. See `frameset-filter-alist' for a full description.") -(defvar frameset-persistent-filter-alist (append '((background-color . frameset-filter-sanitize-color) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) (client . :never) (delete-before . :never) (font . frameset-filter-font-param) (font-backend . :never) (foreground-color . frameset-filter-sanitize-color) (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) (parent-frame . :never) (mouse-wheel-frame . :never) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) (window-system . :never)) frameset-session-filter-alist) "\ +(defvar frameset-persistent-filter-alist (append '((background-color . frameset-filter-sanitize-color) (bottom . frameset-filter-shelve-param) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) (client . :never) (delete-before . :never) (font . frameset-filter-font-param) (font-backend . :never) (foreground-color . frameset-filter-sanitize-color) (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) (GUI:bottom . frameset-filter-unshelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) (GUI:left . frameset-filter-unshelve-param) (GUI:right . frameset-filter-unshelve-param) (GUI:top . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) (left . frameset-filter-shelve-param) (parent-frame . :never) (mouse-wheel-frame . :never) (right . frameset-filter-shelve-param) (top . frameset-filter-shelve-param) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) (window-system . :never)) frameset-session-filter-alist) "\ Parameters to filter for persistent framesets. DO NOT MODIFY. See `frameset-filter-alist' for a full description.") @@ -14140,25 +14172,27 @@ for a description of this minor mode.") (autoload 'gdb-enable-debug "gdb-mi" "\ Toggle logging of transaction between Emacs and Gdb. + The log is stored in `gdb-debug-log' as an alist with elements whose cons is send, send-item or recv and whose cdr is the string being transferred. This list may grow up to a size of `gdb-debug-log-max' after which the oldest element (at the end of the list) is deleted every time a new one is added (at the front). -This is a minor mode. If called interactively, toggle the -`Gdb-Enable-Debug mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Gdb-Enable-Debug mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='gdb-enable-debug)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -14333,22 +14367,22 @@ regular expression that can be used as an element of (autoload 'glasses-mode "glasses" "\ Minor mode for making identifiers likeThis readable. -This is a minor mode. If called interactively, toggle the `Glasses -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +When this mode is active, it tries to add virtual +separators (like underscores) at places they belong to. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a minor mode. If called interactively, toggle the +`Glasses mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `glasses-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When this mode is active, it tries to add virtual -separators (like underscores) at places they belong to. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -14362,22 +14396,24 @@ separators (like underscores) at places they belong to. (autoload 'glyphless-display-mode "glyphless-mode" "\ Minor mode for displaying glyphless characters in the current buffer. + If enabled, all glyphless characters will be displayed as boxes that display their acronyms. This is a minor mode. If called interactively, toggle the -`Glyphless-Display mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Glyphless-Display mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `glyphless-display-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -14981,21 +15017,22 @@ If FORCE is non-nil, replace the old ones. (autoload 'gnus-mailing-list-mode "gnus-ml" "\ Minor mode for providing mailing-list commands. -This is a minor mode. If called interactively, toggle the -`Gnus-Mailing-List mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +\\{gnus-mailing-list-mode-map} -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a minor mode. If called interactively, toggle the +`Gnus-Mailing-List mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `gnus-mailing-list-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\\{gnus-mailing-list-mode-map} +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -15453,18 +15490,18 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and Minor mode to buttonize URLs and e-mail addresses in the current buffer. This is a minor mode. If called interactively, toggle the -`Goto-Address mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Goto-Address mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `goto-address-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -15500,18 +15537,19 @@ See `goto-address-mode' for more information on Goto-Address mode. Like `goto-address-mode', but only for comments and strings. This is a minor mode. If called interactively, toggle the -`Goto-Address-Prog mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Goto-Address-Prog mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `goto-address-prog-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -15623,8 +15661,8 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'." nil nil) Compute the defaults for the `grep' command. The value depends on `grep-command', `grep-template', `grep-use-null-device', `grep-find-command', `grep-find-template', -`grep-use-null-filename-separator', `grep-find-use-xargs' and -`grep-highlight-matches'." nil nil) +`grep-use-null-filename-separator', `grep-find-use-xargs', +`grep-highlight-matches', and `grep-quoting-style'." nil nil) (autoload 'grep-mode "grep" "\ Sets `grep-last-buffer' and `compilation-window-height'. @@ -15666,7 +15704,7 @@ easily repeat a find command. \(fn COMMAND-ARGS)" t nil) -(defalias 'find-grep 'grep-find) +(defalias 'find-grep #'grep-find) (autoload 'lgrep "grep" "\ Run grep, searching for REGEXP in FILES in directory DIR. @@ -15728,7 +15766,7 @@ command before it's run. \(fn REGEXP &optional FILES DIR CONFIRM TEMPLATE)" t nil) -(defalias 'rzgrep 'zrgrep) +(defalias 'rzgrep #'zrgrep) (register-definition-prefixes "grep" '("grep-" "kill-grep" "rgrep-")) @@ -15847,19 +15885,19 @@ or call the function `gud-tooltip-mode'.") (autoload 'gud-tooltip-mode "gud" "\ Toggle the display of GUD tooltips. -This is a minor mode. If called interactively, toggle the -`Gud-Tooltip mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Gud-Tooltip mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='gud-tooltip-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -16092,19 +16130,22 @@ If this produces no string either, return nil." nil nil) (autoload 'display-local-help "help-at-pt" "\ Display local help in the echo area. -This displays a short help message, namely the string produced by -the `kbd-help' property at point. If `kbd-help' does not produce -a string, but the `help-echo' property does, then that string is -printed instead. +This command, by default, displays a short help message, namely +the string produced by the `kbd-help' property at point. If +`kbd-help' does not produce a string, but the `help-echo' +property does, then that string is printed instead. The string is passed through `substitute-command-keys' before it is displayed. -A numeric argument ARG prevents display of a message in case -there is no help. While ARG can be used interactively, it is -mainly meant for use from Lisp. +If INHIBIT-WARNING is non-nil, this prevents display of a message +in case there is no help. -\(fn &optional ARG)" t nil) +If DESCRIBE-BUTTON in non-nil (interactively, the prefix arg), and +there's a button/widget at point, pop a buffer describing that +button/widget instead. + +\(fn &optional INHIBIT-WARNING DESCRIBE-BUTTON)" t nil) (autoload 'help-at-pt-cancel-timer "help-at-pt" "\ Cancel any timer set by `help-at-pt-set-timer'. @@ -16237,10 +16278,15 @@ If TYPE is not a symbol, search for a function definition. The return value is the absolute name of a readable file where OBJECT is defined. If several such files exist, preference is given to a file found via `load-path'. The return value can also be `C-source', which -means that OBJECT is a function or variable defined in C. If no -suitable file is found, return nil. +means that OBJECT is a function or variable defined in C, but +it's currently unknown where. If no suitable file is found, +return nil. -\(fn OBJECT TYPE)" nil nil) +If ALSO-C-SOURCE is non-nil, instead of returning `C-source', +this function will attempt to locate the definition of OBJECT in +the C sources, too. + +\(fn OBJECT TYPE &optional ALSO-C-SOURCE)" nil nil) (autoload 'describe-function-1 "help-fns" "\ @@ -16375,7 +16421,8 @@ gives the window that lists the options.") (autoload 'help-mode "help-mode" "\ Major mode for viewing help text and navigating references in it. -Entry to this mode runs the normal hook `help-mode-hook'. +Also see the `help-enable-editing' variable. + Commands: \\{help-mode-map} @@ -16596,20 +16643,6 @@ This discards the buffer's undo information." t nil) (autoload 'hi-lock-mode "hi-lock" "\ Toggle selective highlighting of patterns (Hi Lock mode). -This is a minor mode. If called interactively, toggle the `Hi-Lock -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `hi-lock-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Hi Lock mode is automatically enabled when you invoke any of the highlighting commands listed below, such as \\[highlight-regexp]. To enable Hi Lock mode in all buffers, use `global-hi-lock-mode' @@ -16670,6 +16703,20 @@ position (number of characters into buffer) Hi-lock: end is found. A mode is excluded if it's in the list `hi-lock-exclude-modes'. +This is a minor mode. If called interactively, toggle the +`Hi-Lock mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `hi-lock-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (put 'global-hi-lock-mode 'globalized-minor-mode t) @@ -16818,20 +16865,6 @@ Populate MENU with a menu item to highlight symbol at CLICK. (autoload 'hide-ifdef-mode "hideif" "\ Toggle features to hide/show #ifdef blocks (Hide-Ifdef mode). -This is a minor mode. If called interactively, toggle the `Hide-Ifdef -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `hide-ifdef-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Hide-Ifdef mode is a buffer-local minor mode for use with C and C-like major modes. When enabled, code within #ifdef constructs that the C preprocessor would eliminate may be hidden from view. @@ -16866,6 +16899,20 @@ Several variables affect how the hiding is done: \\{hide-ifdef-mode-map} +This is a minor mode. If called interactively, toggle the +`Hide-Ifdef mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `hide-ifdef-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "hideif" '("backward-ifdef" "down-ifdef" "forward-ifdef" "hide-ifdef" "hif-" "intern-safe" "next-ifdef" "previous-ifdef" "show-ifdef" "up-ifdef")) @@ -16906,20 +16953,6 @@ whitespace. Case does not matter.") (autoload 'hs-minor-mode "hideshow" "\ Minor mode to selectively hide/show code and comment blocks. -This is a minor mode. If called interactively, toggle the `hs minor -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `hs-minor-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When hideshow minor mode is on, the menu bar is augmented with hideshow commands and the hideshow commands are enabled. The value (hs . t) is added to `buffer-invisibility-spec'. @@ -16936,6 +16969,20 @@ Lastly, the normal hook `hs-minor-mode-hook' is run using `run-hooks'. Key bindings: \\{hs-minor-mode-map} +This is a minor mode. If called interactively, toggle the `hs +minor mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `hs-minor-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'turn-off-hideshow "hideshow" "\ @@ -16959,20 +17006,6 @@ Unconditionally turn off `hs-minor-mode'." nil nil) (autoload 'highlight-changes-mode "hilit-chg" "\ Toggle highlighting changes in this buffer (Highlight Changes mode). -This is a minor mode. If called interactively, toggle the -`Highlight-Changes mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `highlight-changes-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Highlight Changes is enabled, changes are marked with a text property. Normally they are displayed in a distinctive face, but command \\[highlight-changes-visible-mode] can be used to toggle @@ -16988,26 +17021,26 @@ through various faces. buffer with the contents of a file \\[highlight-compare-buffers] highlights differences between two buffers. +This is a minor mode. If called interactively, toggle the +`Highlight-Changes mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `highlight-changes-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'highlight-changes-visible-mode "hilit-chg" "\ Toggle visibility of highlighting due to Highlight Changes mode. -This is a minor mode. If called interactively, toggle the -`Highlight-Changes-Visible mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable the -mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `highlight-changes-visible-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Highlight Changes Visible mode only has an effect when Highlight Changes mode is on. When enabled, the changed text is displayed in a distinctive face. @@ -17017,6 +17050,21 @@ The default value can be customized with variable This command does not itself set Highlight Changes mode. +This is a minor mode. If called interactively, toggle the +`Highlight-Changes-Visible mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `highlight-changes-visible-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'highlight-changes-remove-highlight "hilit-chg" "\ @@ -17150,20 +17198,6 @@ argument VERBOSE non-nil makes the function verbose. (autoload 'hl-line-mode "hl-line" "\ Toggle highlighting of the current line (Hl-Line mode). -This is a minor mode. If called interactively, toggle the `Hl-Line -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `hl-line-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Hl-Line mode is a buffer-local minor mode. If `hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the line about the buffer's point in all windows. Caveat: the @@ -17174,6 +17208,20 @@ non-selected window. Hl-Line mode uses the function When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the line about point in the selected window only. +This is a minor mode. If called interactively, toggle the +`Hl-Line mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `hl-line-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defvar global-hl-line-mode nil "\ @@ -17189,20 +17237,6 @@ or call the function `global-hl-line-mode'.") (autoload 'global-hl-line-mode "hl-line" "\ Toggle line highlighting in all buffers (Global Hl-Line mode). -This is a minor mode. If called interactively, toggle the `Global -Hl-Line mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='global-hl-line-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode highlights the line about the current buffer's point in all live windows. @@ -17210,6 +17244,20 @@ windows. Global-Hl-Line mode uses the function `global-hl-line-highlight' on `post-command-hook'. +This is a global minor mode. If called interactively, toggle the +`Global Hl-Line mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='global-hl-line-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "hl-line" '("global-hl-line-" "hl-line-")) @@ -17334,6 +17382,11 @@ of a holiday list. The optional LABEL is used to label the buffer created. +The list of holiday lists is computed by the +`holiday-available-holiday-lists' and you can alter the results +by redefining that function, or use `add-function' to add +values. + \(fn Y1 &optional Y2 L LABEL)" t nil) (defalias 'holiday-list 'list-holidays) @@ -17610,22 +17663,22 @@ or call the function `fido-mode'.") (autoload 'fido-mode "icomplete" "\ An enhanced `icomplete-mode' that emulates `ido-mode'. -This is a minor mode. If called interactively, toggle the `Fido mode' -mode. If the prefix argument is positive, enable the mode, and if it -is zero or negative, disable the mode. +This global minor mode makes minibuffer completion behave +more like `ido-mode' than regular `icomplete-mode'. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a global minor mode. If called interactively, toggle the +`Fido mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='fido-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -This global minor mode makes minibuffer completion behave -more like `ido-mode' than regular `icomplete-mode'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -17642,20 +17695,6 @@ or call the function `icomplete-mode'.") (autoload 'icomplete-mode "icomplete" "\ Toggle incremental minibuffer completion (Icomplete mode). -This is a minor mode. If called interactively, toggle the `Icomplete -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='icomplete-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When this global minor mode is enabled, typing in the minibuffer continuously displays a list of possible completions that match the string you have typed. See `icomplete-completions' for a @@ -17669,6 +17708,20 @@ completions: \\{icomplete-minibuffer-map} +This is a global minor mode. If called interactively, toggle the +`Icomplete mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='icomplete-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defvar icomplete-vertical-mode nil "\ @@ -17684,26 +17737,27 @@ or call the function `icomplete-vertical-mode'.") (autoload 'icomplete-vertical-mode "icomplete" "\ Toggle vertical candidate display in `icomplete-mode' or `fido-mode'. -This is a minor mode. If called interactively, toggle the -`Icomplete-Vertical mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='icomplete-vertical-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - If none of these modes are on, turn on `icomplete-mode'. As many completion candidates as possible are displayed, depending on the value of `max-mini-window-height', and the way the mini-window is resized depends on `resize-mini-windows'. +This is a global minor mode. If called interactively, toggle the +`Icomplete-Vertical mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='icomplete-vertical-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defvar fido-vertical-mode nil "\ @@ -17718,22 +17772,23 @@ or call the function `fido-vertical-mode'.") (autoload 'fido-vertical-mode "icomplete" "\ Toggle vertical candidate display in `fido-mode'. + When turning on, if non-vertical `fido-mode' is off, turn it on. If it's on, just add the vertical display. -This is a minor mode. If called interactively, toggle the -`Fido-Vertical mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Fido-Vertical mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='fido-vertical-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) (when (locate-library "obsolete/iswitchb") @@ -18249,6 +18304,14 @@ See `inferior-emacs-lisp-mode' for details. (register-definition-prefixes "ietf-drums" '("ietf-drums-")) +;;;*** + +;;;### (autoloads nil "ietf-drums-date" "mail/ietf-drums-date.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from mail/ietf-drums-date.el + +(register-definition-prefixes "ietf-drums-date" '("date-parse-error" "ietf-drums-")) + ;;;*** ;;;### (autoloads nil "iimage" "iimage.el" (0 0 0 0)) @@ -18259,21 +18322,19 @@ See `inferior-emacs-lisp-mode' for details. (autoload 'iimage-mode "iimage" "\ Toggle Iimage mode on or off. -This is a minor mode. If called interactively, toggle the `Iimage -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the +`Iimage mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `iimage-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\\{iimage-mode-map} +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -18310,6 +18371,16 @@ be determined. \(fn FILE)" nil nil) +(make-obsolete 'image-type-from-file-name 'image-supported-file-p '"29.1") + +(autoload 'image-supported-file-p "image" "\ +Say whether Emacs has native support for displaying TYPE. +The value is a symbol specifying the image type, or nil if type +cannot be determined (or if Emacs doesn't have built-in support +for the image type). + +\(fn FILE)" nil nil) + (autoload 'image-type "image" "\ Determine and return image type. SOURCE is an image file name or image data. @@ -18590,22 +18661,24 @@ Jump to thumbnail buffer." t nil) (autoload 'image-dired-minor-mode "image-dired" "\ Setup easy-to-use keybindings for the commands to be used in Dired mode. + Note that n, p and and will be hijacked and bound to `image-dired-dired-next-line' and `image-dired-dired-previous-line'. This is a minor mode. If called interactively, toggle the -`Image-Dired minor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Image-Dired minor mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `image-dired-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -18705,23 +18778,23 @@ or call the function `auto-image-file-mode'.") (autoload 'auto-image-file-mode "image-file" "\ Toggle visiting of image files as images (Auto Image File mode). -This is a minor mode. If called interactively, toggle the +An image file is one whose name has an extension in +`image-file-name-extensions', or matches a regexp in +`image-file-name-regexps'. + +This is a global minor mode. If called interactively, toggle the `Auto-Image-File mode' mode. If the prefix argument is positive, enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='auto-image-file-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -An image file is one whose name has an extension in -`image-file-name-extensions', or matches a regexp in -`image-file-name-regexps'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -18743,23 +18816,23 @@ Key bindings: (autoload 'image-minor-mode "image-mode" "\ Toggle Image minor mode in this buffer. +Image minor mode provides the key \\\\[image-toggle-display], +to switch back to `image-mode' and display an image file as the +actual image. + This is a minor mode. If called interactively, toggle the `Image minor mode' mode. If the prefix argument is positive, enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `image-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Image minor mode provides the key \\\\[image-toggle-display], -to switch back to `image-mode' and display an image file as the -actual image. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -18984,7 +19057,7 @@ quoted using shell quote syntax. ;;;### (autoloads nil "info" "info.el" (0 0 0 0)) ;;; Generated autoloads from info.el -(defcustom Info-default-directory-list (let* ((config-dir (file-name-as-directory (or (and (featurep 'ns) (let ((dir (expand-file-name "../info" data-directory))) (if (file-directory-p dir) dir))) configure-info-directory))) (prefixes (prune-directory-list '("/usr/local/" "/usr/" "/opt/"))) (suffixes '("share/" "")) (standard-info-dirs (apply #'nconc (mapcar (lambda (pfx) (let ((dirs (mapcar (lambda (sfx) (concat pfx sfx "info/")) suffixes))) (prune-directory-list dirs))) prefixes))) (dirs (if (member config-dir standard-info-dirs) (nconc standard-info-dirs (list config-dir)) (cons config-dir standard-info-dirs)))) (if (not (eq system-type 'windows-nt)) dirs (let* ((instdir (file-name-directory invocation-directory)) (dir1 (expand-file-name "../info/" instdir)) (dir2 (expand-file-name "../../../info/" instdir))) (cond ((file-exists-p dir1) (append dirs (list dir1))) ((file-exists-p dir2) (append dirs (list dir2))) (t dirs))))) "\ +(defvar Info-default-directory-list nil "\ Default list of directories to search for Info documentation files. They are searched in the order they are given in the list. Therefore, the directory of Info files that come with Emacs @@ -18995,13 +19068,10 @@ first in this list. Once Info is started, the list of directories to search comes from the variable `Info-directory-list'. -This variable `Info-default-directory-list' is used as the default -for initializing `Info-directory-list' when Info is started, unless -the environment variable INFOPATH is set. -Although this is a customizable variable, that is mainly for technical -reasons. Normally, you should either set INFOPATH or customize -`Info-additional-directory-list', rather than changing this variable." :initialize #'custom-initialize-delay :type '(repeat directory)) +This variable is used as the default for initializing +`Info-directory-list' when Info is started, unless the +environment variable INFOPATH is set.") (custom-autoload 'Info-default-directory-list "info" t) @@ -19066,10 +19136,12 @@ Give an empty topic name to go to the Index node itself. \(fn TOPIC)" t nil) (autoload 'info-apropos "info" "\ -Grovel indices of all known Info files on your system for STRING. -Build a menu of the possible matches. +Search indices of all known Info files on your system for STRING. +If REGEXP (interactively, the prefix), use a regexp match. -\(fn STRING)" t nil) +Display a menu of the possible matches. + +\(fn STRING &optional REGEXP)" t nil) (autoload 'info-finder "info" "\ Display descriptions of the keywords in the Finder virtual manual. @@ -19213,7 +19285,10 @@ mode doesn't have any Info manuals known to Emacs, the command will prompt for MODE to use, with completion. With prefix arg, the command always prompts for MODE. -\(fn SYMBOL &optional MODE)" t nil) +Is SAME-WINDOW, try to reuse the current window instead of +popping up a new one. + +\(fn SYMBOL &optional MODE SAME-WINDOW)" t nil) (put 'info-lookup-file 'info-file "emacs") (autoload 'info-lookup-file "info-look" "\ @@ -19707,20 +19782,6 @@ available on the net." t nil) (autoload 'ispell-minor-mode "ispell" "\ Toggle last-word spell checking (Ispell minor mode). -This is a minor mode. If called interactively, toggle the `ISpell -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `ispell-minor-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Ispell minor mode is a buffer-local minor mode. When enabled, typing SPC or RET warns you if the previous word is incorrectly spelled. @@ -19732,6 +19793,20 @@ SPC. For spell-checking \"on the fly\", not just after typing SPC or RET, use `flyspell-mode'. +This is a minor mode. If called interactively, toggle the +`ISpell minor mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `ispell-minor-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'ispell-message "ispell" "\ @@ -20041,11 +20116,9 @@ and the return value is the length of the conversion. (global-set-key "\C-x\C-k" #'kmacro-keymap) (autoload 'kmacro-keymap "kmacro" "Keymap for keyboard macro commands." t 'keymap) -(autoload 'kmacro-exec-ring-item "kmacro" "\ +(define-obsolete-function-alias 'kmacro-exec-ring-item #'funcall "29.1" "\ Execute item ITEM from the macro ring. -ARG is the number of times to execute the item. - -\(fn ITEM ARG)" nil nil) +ARG is the number of times to execute the item.") (autoload 'kmacro-start-macro "kmacro" "\ Record subsequent keyboard input, defining a keyboard macro. @@ -20146,11 +20219,19 @@ If kbd macro currently being defined end it before activating it. \(fn EVENT)" t nil) +(autoload 'kmacro "kmacro" "\ +Create a `kmacro' for macro bound to symbol or key. +KEYS should be a vector or a string that obeys `key-valid-p'. + +\(fn KEYS &optional COUNTER FORMAT)" nil nil) + (autoload 'kmacro-lambda-form "kmacro" "\ -Create lambda form for macro bound to symbol or key. + \(fn MAC &optional COUNTER FORMAT)" nil nil) +(make-obsolete 'kmacro-lambda-form 'kmacro '"29.1") + (register-definition-prefixes "kmacro" '("kdb-macro-redisplay" "kmacro-")) ;;;*** @@ -20405,21 +20486,25 @@ sleep in seconds. (autoload 'linum-mode "linum" "\ Toggle display of line numbers in the left margin (Linum mode). -This is a minor mode. If called interactively, toggle the `Linum -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This mode has been largely replaced by `display-line-numbers-mode' +\(which is much faster and has fewer interaction problems with other +modes). -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +Linum mode is a buffer-local minor mode. + +This is a minor mode. If called interactively, toggle the `Linum +mode' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `linum-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Linum mode is a buffer-local minor mode. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -20811,7 +20896,7 @@ and then select the region of un-tablified names and use \(fn TOP BOTTOM &optional MACRO)" t nil) (define-key ctl-x-map "q" 'kbd-macro-query) -(register-definition-prefixes "macros" '("macros--insert-vector-macro")) +(register-definition-prefixes "macros" '("macro")) ;;;*** @@ -20997,25 +21082,25 @@ or call the function `mail-abbrevs-mode'.") (autoload 'mail-abbrevs-mode "mailabbrev" "\ Toggle abbrev expansion of mail aliases (Mail Abbrevs mode). -This is a minor mode. If called interactively, toggle the -`Mail-Abbrevs mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='mail-abbrevs-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Mail Abbrevs mode is a global minor mode. When enabled, abbrev-like expansion is performed when editing certain mail headers (those specified by `mail-abbrev-mode-regexp'), based on the entries in your `mail-personal-alias-file'. +This is a global minor mode. If called interactively, toggle the +`Mail-Abbrevs mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='mail-abbrevs-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'mail-abbrevs-setup "mailabbrev" "\ @@ -21390,20 +21475,6 @@ Populate MENU with commands that open a man page at point. (autoload 'master-mode "master" "\ Toggle Master mode. -This is a minor mode. If called interactively, toggle the `Master -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `master-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Master mode is enabled, you can scroll the slave buffer using the following commands: @@ -21413,6 +21484,20 @@ The slave buffer is stored in the buffer-local variable `master-of'. You can set this variable using `master-set-slave'. You can show yourself the value of `master-of' by calling `master-show-slave'. +This is a minor mode. If called interactively, toggle the +`Master mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `master-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "master" '("master-")) @@ -21435,26 +21520,26 @@ or call the function `minibuffer-depth-indicate-mode'.") (autoload 'minibuffer-depth-indicate-mode "mb-depth" "\ Toggle Minibuffer Depth Indication mode. -This is a minor mode. If called interactively, toggle the -`Minibuffer-Depth-Indicate mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable the -mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='minibuffer-depth-indicate-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Minibuffer Depth Indication mode is a global minor mode. When enabled, any recursive use of the minibuffer will show the recursion depth in the minibuffer prompt. This is only useful if `enable-recursive-minibuffers' is non-nil. +This is a global minor mode. If called interactively, toggle the +`Minibuffer-Depth-Indicate mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='minibuffer-depth-indicate-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "mb-depth" '("minibuffer-depth-")) @@ -21610,7 +21695,7 @@ Command to parse command line mailto: links. This is meant to be used for MIME handlers: Setting the handler for \"x-scheme-handler/mailto;\" to \"emacs -f message-mailto %u\" will then start up Emacs ready to compose mail. For emacsclient use - emacsclient -e '(message-mailto \"%u\")' + emacsclient -e \\='(message-mailto \"%u\")' \(fn &optional URL)" t nil) @@ -22004,19 +22089,19 @@ or call the function `midnight-mode'.") (autoload 'midnight-mode "midnight" "\ Non-nil means run `midnight-hook' at midnight. -This is a minor mode. If called interactively, toggle the `Midnight -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Midnight mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='midnight-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -22059,21 +22144,6 @@ or call the function `minibuffer-electric-default-mode'.") (autoload 'minibuffer-electric-default-mode "minibuf-eldef" "\ Toggle Minibuffer Electric Default mode. -This is a minor mode. If called interactively, toggle the -`Minibuffer-Electric-Default mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable the -mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='minibuffer-electric-default-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Minibuffer Electric Default mode is a global minor mode. When enabled, minibuffer prompts that show a default value only show the default when it's applicable -- that is, when hitting RET @@ -22081,6 +22151,21 @@ would yield the default value. If the user modifies the input such that hitting RET would enter a non-default value, the prompt is modified to remove the default indication. +This is a global minor mode. If called interactively, toggle the +`Minibuffer-Electric-Default mode' mode. If the prefix argument +is positive, enable the mode, and if it is zero or negative, +disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='minibuffer-electric-default-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "minibuf-eldef" '("minibuf")) @@ -22283,7 +22368,7 @@ Major mode for the mixal asm language. ;;;### (autoloads nil "mm-encode" "gnus/mm-encode.el" (0 0 0 0)) ;;; Generated autoloads from gnus/mm-encode.el -(define-obsolete-function-alias 'mm-default-file-encoding #'mm-default-file-type "future") +(define-obsolete-function-alias 'mm-default-file-encoding #'mm-default-file-type "28.1") (autoload 'mm-default-file-type "mm-encode" "\ Return a default content type for FILE. @@ -22646,22 +22731,22 @@ or call the function `msb-mode'.") (autoload 'msb-mode "msb" "\ Toggle Msb mode. -This is a minor mode. If called interactively, toggle the `Msb mode' -mode. If the prefix argument is positive, enable the mode, and if it -is zero or negative, disable the mode. +This mode overrides the binding(s) of `mouse-buffer-menu' to provide a +different buffer menu using the function `msb'. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a global minor mode. If called interactively, toggle the +`Msb mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='msb-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -This mode overrides the binding(s) of `mouse-buffer-menu' to provide a -different buffer menu using the function `msb'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -22998,19 +23083,19 @@ or call the function `mouse-wheel-mode'.") (autoload 'mouse-wheel-mode "mwheel" "\ Toggle mouse wheel support (Mouse Wheel mode). -This is a minor mode. If called interactively, toggle the -`Mouse-Wheel mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Mouse-Wheel mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='mouse-wheel-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -24267,7 +24352,7 @@ Coloring: ;;;### (autoloads nil "org" "org/org.el" (0 0 0 0)) ;;; Generated autoloads from org/org.el -(push (purecopy '(org 9 5 2)) package--builtin-versions) +(push (purecopy '(org 9 5 3)) package--builtin-versions) (autoload 'org-babel-do-load-languages "org" "\ Load the languages defined in `org-babel-load-languages'. @@ -24631,7 +24716,7 @@ is active. \(fn &optional TODO-ONLY STRING EDIT-AT)" t nil) (autoload 'org-todo-list "org-agenda" "\ -Show all (not done) TODO entries from all agenda file in a single list. +Show all (not done) TODO entries from all agenda files in a single list. The prefix arg can be used to select a specific TODO keyword and limit the list to these. When using `\\[universal-argument]', you will be prompted for a keyword. A numeric prefix directly selects the Nth keyword in @@ -24692,7 +24777,7 @@ Set restriction lock for agenda to current subtree or file. When in a restricted subtree, remove it. The restriction will span over the entire file if TYPE is `file', -or if type is '(4), or if the cursor is before the first headline +or if type is \\='(4), or if the cursor is before the first headline in the file. Otherwise, only apply the restriction to the current subtree. @@ -24945,21 +25030,21 @@ Turning on outline mode calls the value of `text-mode-hook' and then of (autoload 'outline-minor-mode "outline" "\ Toggle Outline minor mode. -This is a minor mode. If called interactively, toggle the `Outline -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +See the command `outline-mode' for more information on this mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a minor mode. If called interactively, toggle the +`Outline minor mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `outline-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -See the command `outline-mode' for more information on this mode. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -25153,6 +25238,15 @@ downloads in the background. \(fn &optional ASYNC)" t nil) +(autoload 'package-installed-p "package" "\ +Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed. +If PACKAGE is a symbol, it is the package name and MIN-VERSION +should be a version list. + +If PACKAGE is a `package-desc' object, MIN-VERSION is ignored. + +\(fn PACKAGE &optional MIN-VERSION)" nil nil) + (autoload 'package-install "package" "\ Install the package PKG. PKG can be a `package-desc' or a symbol naming one of the @@ -25171,6 +25265,11 @@ to install it but still mark it as selected. \(fn PKG &optional DONT-SELECT)" t nil) +(autoload 'package-update "package" "\ +Update package NAME if a newer version exists. + +\(fn NAME)" t nil) + (autoload 'package-install-from-buffer "package" "\ Install a package from the current buffer. The current buffer is assumed to be a single .el or .tar file or @@ -25501,7 +25600,7 @@ PATTERNS are normal `pcase' patterns, and VALUES are expression. Evaluation happens sequentially as in `setq' (not in parallel). -An example: (pcase-setq `((,a) [(,b)]) '((1) [(2)])) +An example: (pcase-setq \\=`((,a) [(,b)]) \\='((1) [(2)])) VAL is presumed to match PAT. Failure to match may signal an error or go undetected, binding variables to arbitrary values, such as nil. @@ -25995,19 +26094,19 @@ or call the function `pixel-scroll-mode'.") (autoload 'pixel-scroll-mode "pixel-scroll" "\ A minor mode to scroll text pixel-by-pixel. -This is a minor mode. If called interactively, toggle the -`Pixel-Scroll mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Pixel-Scroll mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='pixel-scroll-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -26023,23 +26122,24 @@ or call the function `pixel-scroll-precision-mode'.") (autoload 'pixel-scroll-precision-mode "pixel-scroll" "\ Toggle pixel scrolling. + When enabled, this minor mode allows to scroll the display precisely, according to the turning of the mouse wheel. -This is a minor mode. If called interactively, toggle the +This is a global minor mode. If called interactively, toggle the `Pixel-Scroll-Precision mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable the -mode. +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='pixel-scroll-precision-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -26724,8 +26824,12 @@ are both set to t. (autoload 'proced "proced" "\ Generate a listing of UNIX system processes. \\ -If invoked with optional ARG, do not select the window displaying -the process information. +If invoked with optional non-negative ARG, do not select the +window displaying the process information. + +If `proced-show-remote-processes' is non-nil or the command is +invoked with a negative ARG `\\[universal-argument] \\[negative-argument]', and `default-directory' +points to a remote host, the system processes of that host are shown. This function runs the normal hook `proced-post-display-hook'. @@ -26912,6 +27016,10 @@ command \\[fileloop-continue]. (autoload 'project-query-replace-regexp "project" "\ Query-replace REGEXP in all the files of the project. Stops when a match is found and prompts for whether to replace it. +At that prompt, the user must type a character saying what to do +with the match. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. If you exit the `query-replace', you can later continue the `query-replace' loop using the command \\[fileloop-continue]. @@ -26966,6 +27074,8 @@ is non-nil, the command will not ask the user for confirmation. NO-CONFIRM is always nil when the command is invoked interactively. +Also see the `project-kill-buffers-display-buffer-list' variable. + \(fn &optional NO-CONFIRM)" t nil) (autoload 'project-remember-project "project" "\ @@ -27425,8 +27535,8 @@ If it is nil, the current key is shown. DOCSTRING is the documentation string of this package. The command `describe-input-method' shows this string while replacing the form -\\=\\ in the string by the value of VAR. That value should be a -string. For instance, the form \\=\\ is +\\=\\=\\=\\ in the string by the value of VAR. That value should be a +string. For instance, the form \\=\\=\\=\\ is replaced by a description about how to select a translation from a list of candidates. @@ -27849,19 +27959,20 @@ or call the function `rcirc-track-minor-mode'.") (autoload 'rcirc-track-minor-mode "rcirc" "\ Global minor mode for tracking activity in rcirc buffers. -This is a minor mode. If called interactively, toggle the -`Rcirc-Track minor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Rcirc-Track minor mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='rcirc-track-minor-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -27909,20 +28020,6 @@ or call the function `recentf-mode'.") (autoload 'recentf-mode "recentf" "\ Toggle \"Open Recent\" menu (Recentf mode). -This is a minor mode. If called interactively, toggle the `Recentf -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='recentf-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Recentf mode is enabled, a \"Open Recent\" submenu is displayed in the \"File\" menu, containing a list of files that were operated on recently, in the most-recently-used order. @@ -27932,7 +28029,21 @@ to a file, and killing a buffer is counted as \"operating\" on the file. If instead you want to prioritize files that appear in buffers you switch to a lot, you can say something like the following: - (add-hook 'buffer-list-update-hook 'recentf-track-opened-file) + (add-hook \\='buffer-list-update-hook #\\='recentf-track-opened-file) + +This is a global minor mode. If called interactively, toggle the +`Recentf mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='recentf-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -28077,22 +28188,22 @@ with a prefix argument, prompt for START-AT and FORMAT. (autoload 'rectangle-mark-mode "rect" "\ Toggle the region as rectangular. +Activates the region if it's inactive and Transient Mark mode is +on. Only lasts until the region is next deactivated. + This is a minor mode. If called interactively, toggle the `Rectangle-Mark mode' mode. If the prefix argument is positive, enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `rectangle-mark-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Activates the region if it's inactive and Transient Mark mode is -on. Only lasts until the region is next deactivated. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -28120,20 +28231,6 @@ on. Only lasts until the region is next deactivated. (autoload 'refill-mode "refill" "\ Toggle automatic refilling (Refill mode). -This is a minor mode. If called interactively, toggle the `Refill -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `refill-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Refill mode is a buffer-local minor mode. When enabled, the current paragraph is refilled as you edit. Self-inserting characters only cause refilling if they would cause @@ -28141,6 +28238,20 @@ auto-filling. For true \"word wrap\" behavior, use `visual-line-mode' instead. +This is a minor mode. If called interactively, toggle the +`Refill mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `refill-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "refill" '("refill-")) @@ -28160,20 +28271,6 @@ Turn on RefTeX mode." nil nil) (autoload 'reftex-mode "reftex" "\ Minor mode with distinct support for \\label, \\ref and \\cite in LaTeX. -This is a minor mode. If called interactively, toggle the `Reftex -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `reftex-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - \\A Table of Contents of the entire (multifile) document with browsing capabilities is available with `\\[reftex-toc]'. @@ -28202,6 +28299,20 @@ on the menu bar. ------------------------------------------------------------------------------ +This is a minor mode. If called interactively, toggle the +`Reftex mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `reftex-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'reftex-reset-scanning-information "reftex" "\ @@ -28390,23 +28501,24 @@ or call the function `repeat-mode'.") (autoload 'repeat-mode "repeat" "\ Toggle Repeat mode. + When Repeat mode is enabled, and the command symbol has the property named `repeat-map', this map is activated temporarily for the next command. See `describe-repeat-maps' for a list of all repeatable commands. -This is a minor mode. If called interactively, toggle the `Repeat -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Repeat mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='repeat-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -28483,25 +28595,25 @@ report errors as appropriate for this kind of usage. (autoload 'reveal-mode "reveal" "\ Toggle uncloaking of invisible text near point (Reveal mode). -This is a minor mode. If called interactively, toggle the `Reveal -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `reveal-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Reveal mode is a buffer-local minor mode. When enabled, it reveals invisible text around point. Also see the `reveal-auto-hide' variable. +This is a minor mode. If called interactively, toggle the +`Reveal mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `reveal-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defvar global-reveal-mode nil "\ @@ -28516,21 +28628,22 @@ or call the function `global-reveal-mode'.") (autoload 'global-reveal-mode "reveal" "\ Toggle Reveal mode in all buffers (Global Reveal mode). + Reveal mode renders invisible text around point visible again. -This is a minor mode. If called interactively, toggle the `Global -Reveal mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Global Reveal mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='global-reveal-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -29271,20 +29384,6 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil." t nil) (autoload 'rng-validate-mode "rng-valid" "\ Minor mode performing continual validation against a RELAX NG schema. -This is a minor mode. If called interactively, toggle the -`Rng-Validate mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `rng-validate-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Checks whether the buffer is a well-formed XML 1.0 document, conforming to the XML Namespaces Recommendation and valid against a RELAX NG schema. The mode-line indicates whether it is or not. Any @@ -29305,6 +29404,20 @@ conventionally have a suffix of `.rnc'). The variable `rng-schema-locating-files' specifies files containing rules to use for finding the schema. +This is a minor mode. If called interactively, toggle the +`Rng-Validate mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `rng-validate-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "rng-valid" '("rng-")) @@ -29314,7 +29427,7 @@ to use for finding the schema. ;;;### (autoloads nil "rng-xsd" "nxml/rng-xsd.el" (0 0 0 0)) ;;; Generated autoloads from nxml/rng-xsd.el -(put 'http://www\.w3\.org/2001/XMLSchema-datatypes 'rng-dt-compile #'rng-xsd-compile) +(put 'http://www.w3.org/2001/XMLSchema-datatypes 'rng-dt-compile #'rng-xsd-compile) (autoload 'rng-xsd-compile "rng-xsd" "\ Provide W3C XML Schema as a RELAX NG datatypes library. @@ -29431,23 +29544,23 @@ highlighting. (autoload 'rst-minor-mode "rst" "\ Toggle ReST minor mode. -This is a minor mode. If called interactively, toggle the `Rst minor -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +When ReST minor mode is enabled, the ReST mode keybindings +are installed on top of the major mode bindings. Use this +for modes derived from Text mode, like Mail mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a minor mode. If called interactively, toggle the `Rst +minor mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `rst-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When ReST minor mode is enabled, the ReST mode keybindings -are installed on top of the major mode bindings. Use this -for modes derived from Text mode, like Mail mode. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -29491,18 +29604,18 @@ Use the command `ruler-mode' to change this variable.") Toggle display of ruler in header line (Ruler mode). This is a minor mode. If called interactively, toggle the `Ruler -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +mode' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `ruler-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -29771,20 +29884,6 @@ or call the function `savehist-mode'.") (autoload 'savehist-mode "savehist" "\ Toggle saving of minibuffer history (Savehist mode). -This is a minor mode. If called interactively, toggle the `Savehist -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='savehist-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Savehist mode is enabled, minibuffer history is saved to `savehist-file' periodically and when exiting Emacs. When Savehist mode is enabled for the first time in an Emacs session, @@ -29811,6 +29910,20 @@ This mode should normally be turned on from your Emacs init file. Calling it at any other time replaces your current minibuffer histories, which is probably undesirable. +This is a global minor mode. If called interactively, toggle the +`Savehist mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='savehist-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "savehist" '("savehist-")) @@ -29832,50 +29945,53 @@ or call the function `save-place-mode'.") (autoload 'save-place-mode "saveplace" "\ Non-nil means automatically save place in each file. + This means when you visit a file, point goes to the last place where it was when you previously visited the same file. -This is a minor mode. If called interactively, toggle the `Save-Place -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Save-Place mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='save-place-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) (autoload 'save-place-local-mode "saveplace" "\ Toggle whether to save your place in this file between sessions. + If this mode is enabled, point is recorded when you kill the buffer or exit Emacs. Visiting this file again will go to that position, even in a later Emacs session. -This is a minor mode. If called interactively, toggle the -`Save-Place-Local mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `save-place-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - To save places automatically in all files, put this in your init file: \(save-place-mode 1) +This is a minor mode. If called interactively, toggle the +`Save-Place-Local mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `save-place-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "saveplace" '("load-save-place-alist-from-file" "save-place")) @@ -29954,22 +30070,22 @@ or call the function `scroll-all-mode'.") (autoload 'scroll-all-mode "scroll-all" "\ Toggle shared scrolling in same-frame windows (Scroll-All mode). -This is a minor mode. If called interactively, toggle the `Scroll-All -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +When Scroll-All mode is enabled, scrolling commands invoked in +one window apply to all visible windows in the same frame. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a global minor mode. If called interactively, toggle the +`Scroll-All mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='scroll-all-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When Scroll-All mode is enabled, scrolling commands invoked in -one window apply to all visible windows in the same frame. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -29990,28 +30106,28 @@ one window apply to all visible windows in the same frame. (autoload 'scroll-lock-mode "scroll-lock" "\ Buffer-local minor mode for pager-like scrolling. -This is a minor mode. If called interactively, toggle the -`Scroll-Lock mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `scroll-lock-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When enabled, keys that normally move point by line or paragraph will scroll the buffer by the respective amount of lines instead and point will be kept vertically fixed relative to window boundaries during scrolling. -Note that the default key binding to Scroll_Lock will not work on +Note that the default key binding to `scroll' will not work on MS-Windows systems if `w32-scroll-lock-modifier' is non-nil. +This is a minor mode. If called interactively, toggle the +`Scroll-Lock mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `scroll-lock-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "scroll-lock" '("scroll-lock-")) @@ -30069,20 +30185,6 @@ or call the function `semantic-mode'.") (autoload 'semantic-mode "semantic" "\ Toggle parser features (Semantic mode). -This is a minor mode. If called interactively, toggle the `Semantic -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='semantic-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - In Semantic mode, Emacs parses the buffers you visit for their semantic content. This information is used by a variety of auxiliary minor modes, listed in `semantic-default-submodes'; @@ -30091,6 +30193,20 @@ Semantic mode. \\{semantic-mode-map} +This is a global minor mode. If called interactively, toggle the +`Semantic mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='semantic-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "semantic" '("bovinate" "semantic-")) @@ -30747,23 +30863,23 @@ or call the function `server-mode'.") (autoload 'server-mode "server" "\ Toggle Server mode. -This is a minor mode. If called interactively, toggle the `Server -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +Server mode runs a process that accepts commands from the +`emacsclient' program. See Info node `Emacs server' and +`server-start' for details. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a global minor mode. If called interactively, toggle the +`Server mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='server-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Server mode runs a process that accepts commands from the -`emacsclient' program. See Info node `Emacs server' and -`server-start' for details. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -31416,21 +31532,21 @@ buffer names. (autoload 'smerge-mode "smerge-mode" "\ Minor mode to simplify editing output from the diff3 program. -This is a minor mode. If called interactively, toggle the `SMerge -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +\\{smerge-mode-map} -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a minor mode. If called interactively, toggle the +`SMerge mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `smerge-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\\{smerge-mode-map} +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -31552,26 +31668,26 @@ Open the customization group `so-long'." t nil) (autoload 'so-long-minor-mode "so-long" "\ This is the minor mode equivalent of `so-long-mode'. -This is a minor mode. If called interactively, toggle the `So-Long -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `so-long-minor-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Any active minor modes listed in `so-long-minor-modes' are disabled for the current buffer, and buffer-local values are assigned to variables in accordance with `so-long-variable-overrides'. This minor mode is a standard `so-long-action' option. +This is a minor mode. If called interactively, toggle the +`So-Long minor mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `so-long-minor-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'so-long-mode "so-long" "\ @@ -31638,20 +31754,6 @@ or call the function `global-so-long-mode'.") (autoload 'global-so-long-mode "so-long" "\ Toggle automated performance mitigations for files with long lines. -This is a minor mode. If called interactively, toggle the `Global -So-Long mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='global-so-long-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Many Emacs modes struggle with buffers which contain excessively long lines, and may consequently cause unacceptable performance issues. @@ -31667,6 +31769,20 @@ Use \\[so-long-commentary] for more information. Use \\[so-long-customize] to open the customization group `so-long' to configure the behaviour. +This is a global minor mode. If called interactively, toggle the +`Global So-Long mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='global-so-long-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "so-long" '("so-long-" "turn-o")) @@ -31675,7 +31791,7 @@ configure the behaviour. ;;;### (autoloads nil "soap-client" "net/soap-client.el" (0 0 0 0)) ;;; Generated autoloads from net/soap-client.el -(push (purecopy '(soap-client 3 2 0)) package--builtin-versions) +(push (purecopy '(soap-client 3 2 1)) package--builtin-versions) (register-definition-prefixes "soap-client" '("soap-")) @@ -32699,6 +32815,38 @@ Major-mode for writing SRecode macros. (register-definition-prefixes "srecode/table" '("object-sort-list" "srecode-")) +;;;*** + +;;;### (autoloads nil "string-edit" "textmodes/string-edit.el" (0 +;;;;;; 0 0 0)) +;;; Generated autoloads from textmodes/string-edit.el + +(autoload 'string-edit "string-edit" "\ +Switch to a new buffer to edit STRING. +When the user finishes editing (with \\\\[string-edit-done]), SUCCESS-CALLBACK +is called with the resulting string. + +If the user aborts (with \\\\[string-edit-abort]), ABORT-CALLBACK (if any) is +called with no parameters. + +PROMPT will be inserted at the start of the buffer, but won't be +included in the resulting string. If PROMPT is nil, no help text +will be inserted. + +\(fn PROMPT STRING SUCCESS-CALLBACK &key ABORT-CALLBACK)" nil nil) + +(autoload 'read-string-from-buffer "string-edit" "\ +Switch to a new buffer to edit STRING in a recursive edit. +The user finishes editing with \\\\[string-edit-done], or aborts with \\\\[string-edit-abort]). + +PROMPT will be inserted at the start of the buffer, but won't be +included in the resulting string. If nil, no prompt will be +inserted in the buffer. + +\(fn PROMPT STRING)" nil nil) + +(register-definition-prefixes "string-edit" '("string-edit-")) + ;;;*** ;;;### (autoloads nil "strokes" "strokes.el" (0 0 0 0)) @@ -32779,20 +32927,6 @@ or call the function `strokes-mode'.") (autoload 'strokes-mode "strokes" "\ Toggle Strokes mode, a global minor mode. -This is a minor mode. If called interactively, toggle the `Strokes -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='strokes-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - \\ Strokes are pictographic mouse gestures which invoke commands. Strokes are invoked with \\[strokes-do-stroke]. You can define @@ -32806,6 +32940,20 @@ Encode/decode your strokes with \\[strokes-encode-buffer], \\{strokes-mode-map} +This is a global minor mode. If called interactively, toggle the +`Strokes mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='strokes-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'strokes-decode-buffer "strokes" "\ @@ -32843,38 +32991,6 @@ Studlify-case the current buffer." t nil) ;;;### (autoloads nil "subr-x" "emacs-lisp/subr-x.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/subr-x.el -(autoload 'if-let "subr-x" "\ -Bind variables according to SPEC and evaluate THEN or ELSE. -Evaluate each binding in turn, as in `let*', stopping if a -binding value is nil. If all are non-nil return the value of -THEN, otherwise the last form in ELSE. - -Each element of SPEC is a list (SYMBOL VALUEFORM) that binds -SYMBOL to the value of VALUEFORM. An element can additionally be -of the form (VALUEFORM), which is evaluated and checked for nil; -i.e. SYMBOL can be omitted if only the test result is of -interest. It can also be of the form SYMBOL, then the binding of -SYMBOL is checked for nil. - -As a special case, interprets a SPEC of the form (SYMBOL SOMETHING) -like ((SYMBOL SOMETHING)). This exists for backward compatibility -with an old syntax that accepted only one binding. - -\(fn SPEC THEN &rest ELSE)" nil t) - -(function-put 'if-let 'lisp-indent-function '2) - -(autoload 'when-let "subr-x" "\ -Bind variables according to SPEC and conditionally evaluate BODY. -Evaluate each binding in turn, stopping if a binding value is nil. -If all are non-nil, return the value of the last form in BODY. - -The variable list SPEC is the same as in `if-let'. - -\(fn SPEC &rest BODY)" nil t) - -(function-put 'when-let 'lisp-indent-function '1) - (autoload 'string-truncate-left "subr-x" "\ Truncate STRING to LENGTH, replacing initial surplus with \"...\". @@ -32888,27 +33004,6 @@ removed. \(fn STRING)" nil nil) -(autoload 'string-lines "subr-x" "\ -Split STRING into a list of lines. -If OMIT-NULLS, empty lines will be removed from the results. - -\(fn STRING &optional OMIT-NULLS)" nil nil) - -(autoload 'ensure-empty-lines "subr-x" "\ -Ensure that there are LINES number of empty lines before point. -If LINES is nil or omitted, ensure that there is a single empty -line before point. - -If called interactively, LINES is given by the prefix argument. - -If there are more than LINES empty lines before point, the number -of empty lines is reduced to LINES. - -If point is not at the beginning of a line, a newline character -is inserted before adjusting the number of empty lines. - -\(fn &optional LINES)" t nil) - (autoload 'string-pixel-width "subr-x" "\ Return the width of STRING in pixels. @@ -32935,7 +33030,7 @@ Query the user for a process and return the process object. \(fn PROMPT)" nil nil) -(register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let*" "internal--" "named-let" "replace-region-contents" "string-" "thread-" "when-let*" "with-memoization")) +(register-definition-prefixes "subr-x" '("hash-table-" "internal--thread-argument" "named-let" "replace-region-contents" "string-" "thread-" "with-")) ;;;*** @@ -32947,20 +33042,6 @@ Query the user for a process and return the process object. (autoload 'subword-mode "subword" "\ Toggle subword movement and editing (Subword mode). -This is a minor mode. If called interactively, toggle the `Subword -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `subword-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Subword mode is a buffer-local minor mode. Enabling it changes the definition of a word so that word-based commands stop inside symbols with mixed uppercase and lowercase letters, @@ -32979,6 +33060,20 @@ called a `subword'. Here are some examples: This mode changes the definition of a word so that word commands treat nomenclature boundaries as word boundaries. +This is a minor mode. If called interactively, toggle the +`Subword mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `subword-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (put 'global-subword-mode 'globalized-minor-mode t) @@ -33012,26 +33107,26 @@ See `subword-mode' for more information on Subword mode. (autoload 'superword-mode "subword" "\ Toggle superword movement and editing (Superword mode). -This is a minor mode. If called interactively, toggle the `Superword -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +Superword mode is a buffer-local minor mode. Enabling it changes +the definition of words such that characters which have symbol +syntax are treated as parts of words: e.g., in `superword-mode', +\"this_is_a_symbol\" counts as one word. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +\\{superword-mode-map} + +This is a minor mode. If called interactively, toggle the +`Superword mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `superword-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Superword mode is a buffer-local minor mode. Enabling it changes -the definition of words such that symbols characters are treated -as parts of words: e.g., in `superword-mode', -\"this_is_a_symbol\" counts as one word. - -\\{superword-mode-map} +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -33123,20 +33218,6 @@ or call the function `gpm-mouse-mode'.") (autoload 'gpm-mouse-mode "t-mouse" "\ Toggle mouse support in GNU/Linux consoles (GPM Mouse mode). -This is a minor mode. If called interactively, toggle the `Gpm-Mouse -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='gpm-mouse-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - This allows the use of the mouse when operating on a GNU/Linux console, in the same way as you can use the mouse under X11. It relies on the `gpm' daemon being activated. @@ -33145,6 +33226,20 @@ Note that when `gpm-mouse-mode' is enabled, you cannot use the mouse to transfer text between Emacs and other programs which use GPM. This is due to limitations in GPM and the Linux kernel. +This is a global minor mode. If called interactively, toggle the +`Gpm-Mouse mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='gpm-mouse-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "t-mouse" '("gpm-mouse-")) @@ -33157,19 +33252,19 @@ GPM. This is due to limitations in GPM and the Linux kernel. (autoload 'tab-line-mode "tab-line" "\ Toggle display of tab line in the windows displaying the current buffer. -This is a minor mode. If called interactively, toggle the `Tab-Line -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the +`Tab-Line mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `tab-line-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -33243,6 +33338,7 @@ The variable `tab-width' controls the spacing of tab stops. (autoload 'table-fixed-width-mode "table" "\ Cell width is fixed when this is non-nil. + Normally it should be nil for allowing automatic cell width expansion that widens a cell when it is necessary. When non-nil, typing in a cell does not automatically expand the cell width. A word that is too @@ -33252,18 +33348,19 @@ variable's value can be toggled by \\[table-fixed-width-mode] at run-time. This is a minor mode. If called interactively, toggle the -`Table-Fixed-Width mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Table-Fixed-Width mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `table-fixed-width-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -34570,7 +34667,7 @@ Compose Thai characters in the current buffer." t nil) (autoload 'forward-thing "thingatpt" "\ Move forward to the end of the Nth next THING. THING should be a symbol specifying a type of syntactic entity. -Possibilities include `symbol', `list', `sexp', `defun', +Possibilities include `symbol', `list', `sexp', `defun', `number', `filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'. @@ -34579,7 +34676,7 @@ Possibilities include `symbol', `list', `sexp', `defun', (autoload 'bounds-of-thing-at-point "thingatpt" "\ Determine the start and end buffer locations for the THING at point. THING should be a symbol specifying a type of syntactic entity. -Possibilities include `symbol', `list', `sexp', `defun', +Possibilities include `symbol', `list', `sexp', `defun', `number', `filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'. @@ -34823,20 +34920,6 @@ This function is meant to be used as a `post-self-insert-hook'." t nil) (autoload 'tildify-mode "tildify" "\ Adds electric behavior to space character. -This is a minor mode. If called interactively, toggle the `Tildify -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `tildify-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When space is inserted into a buffer in a position where hard space is required instead (determined by `tildify-space-pattern' and `tildify-space-predicates'), that space character is replaced by a hard space specified by @@ -34846,6 +34929,20 @@ When `tildify-mode' is enabled, if `tildify-string-alist' specifies a hard space representation for current major mode, the `tildify-space-string' buffer-local variable will be set to the representation. +This is a minor mode. If called interactively, toggle the +`Tildify mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `tildify-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "tildify" '("tildify-")) @@ -34881,26 +34978,26 @@ or call the function `display-time-mode'.") (autoload 'display-time-mode "time" "\ Toggle display of time, load level, and mail flag in mode lines. -This is a minor mode. If called interactively, toggle the -`Display-Time mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='display-time-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Display Time mode is enabled, it updates every minute (you can control the number of seconds between updates by customizing `display-time-interval'). If `display-time-day-and-date' is non-nil, the current day and date are displayed as well. This runs the normal hook `display-time-hook' after each update. +This is a global minor mode. If called interactively, toggle the +`Display-Time mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='display-time-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (define-obsolete-function-alias 'display-time-world #'world-clock "28.1") @@ -35020,6 +35117,10 @@ The \"%z\" specifier does not print anything. When it is used, specifiers must be given in order of decreasing size. To the left of \"%z\", nothing is output until the first non-zero unit is encountered. +The \"%x\" specifier does not print anything. When it is used, +specifiers must be given in order of decreasing size. To the +right of \"%x\", trailing zero units are not output. + \(fn STRING SECONDS)" nil nil) (autoload 'seconds-to-string "time-date" "\ @@ -35540,7 +35641,7 @@ like \"/sys\" or \"/C:\".") Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (when tramp-mode (let ((default-directory temporary-file-directory)) (when (bound-and-true-p tramp-archive-autoload) (load "tramp-archive" 'noerror 'nomessage)) (load "tramp" 'noerror 'nomessage))) (apply operation args)) (defun tramp-register-autoload-file-name-handlers nil "\ -Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp #'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler 'safe-magic t)) +Add Tramp file name handlers to `file-name-handler-alist' during autoload." (unless (rassq #'tramp-file-name-handler file-name-handler-alist) (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp #'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler 'safe-magic t))) (tramp-register-autoload-file-name-handlers) (defun tramp-unload-file-name-handlers nil "\ @@ -35579,10 +35680,10 @@ It must be supported by libarchive(3).") Regular expression matching archive file names." '(concat "\\`" "\\(" ".+" "\\." (regexp-opt tramp-archive-suffixes) "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'")) (defun tramp-archive-autoload-file-name-handler (operation &rest args) "\ -Load Tramp archive file name handler, and perform OPERATION." (defvar tramp-archive-autoload) (when tramp-archive-enabled (let ((default-directory temporary-file-directory) (tramp-archive-autoload t)) (apply #'tramp-autoload-file-name-handler operation args)))) +Load Tramp archive file name handler, and perform OPERATION." (defvar tramp-archive-autoload) (let ((default-directory temporary-file-directory) (tramp-archive-autoload tramp-archive-enabled)) (apply #'tramp-autoload-file-name-handler operation args))) (defun tramp-register-archive-file-name-handler nil "\ -Add archive file name handler to `file-name-handler-alist'." (when tramp-archive-enabled (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put #'tramp-archive-autoload-file-name-handler 'safe-magic t))) +Add archive file name handler to `file-name-handler-alist'." (when (and tramp-archive-enabled (not (rassq #'tramp-archive-file-name-handler file-name-handler-alist))) (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put #'tramp-archive-autoload-file-name-handler 'safe-magic t))) (add-hook 'after-init-hook #'tramp-register-archive-file-name-handler) @@ -35873,22 +35974,9 @@ or call the function `type-break-mode'.") (autoload 'type-break-mode "type-break" "\ Enable or disable typing-break mode. + This is a minor mode, but it is global to all buffers by default. -This is a minor mode. If called interactively, toggle the `Type-Break -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='type-break-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When this mode is enabled, the user is encouraged to take typing breaks at appropriate intervals; either after a specified amount of time or when the user has exceeded a keystroke threshold. When the time arrives, the user @@ -35956,6 +36044,20 @@ across Emacs sessions. This provides recovery of the break status between sessions and after a crash. Manual changes to the file may result in problems. +This is a global minor mode. If called interactively, toggle the +`Type-Break mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='type-break-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'type-break "type-break" "\ @@ -36310,7 +36412,7 @@ Handle file: and ftp: URLs. \(fn URL CALLBACK CBARGS)" nil nil) -(register-definition-prefixes "url-file" '("url-file-")) +(register-definition-prefixes "url-file" '("url-")) ;;;*** @@ -36367,29 +36469,30 @@ or call the function `url-handler-mode'.") (autoload 'url-handler-mode "url-handlers" "\ Handle URLs as if they were file names throughout Emacs. + After switching on this minor mode, Emacs file primitives handle URLs. For instance: -This is a minor mode. If called interactively, toggle the -`Url-Handler mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='url-handler-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - (file-exists-p \"https://www.gnu.org/\") => t and `C-x C-f https://www.gnu.org/ RET' will give you the HTML at that URL in a buffer. +This is a global minor mode. If called interactively, toggle the +`Url-Handler mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='url-handler-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'url-file-handler "url-handlers" "\ @@ -38566,20 +38669,6 @@ own View-like bindings. (autoload 'view-mode "view" "\ Toggle View mode, a minor mode for viewing text but not editing it. -This is a minor mode. If called interactively, toggle the `View mode' -mode. If the prefix argument is positive, enable the mode, and if it -is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `view-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When View mode is enabled, commands that do not change the buffer contents are available as usual. Kill commands save text but do not delete it from the buffer. Most other commands beep and @@ -38657,6 +38746,20 @@ then \\[View-leave], \\[View-quit] and \\[View-kill-and-leave] will return to th Entry to view-mode runs the normal hook `view-mode-hook'. +This is a minor mode. If called interactively, toggle the `View +mode' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `view-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'view-return-to-alist-update "view" "\ @@ -38767,17 +38870,10 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil) ;;;*** -;;;### (autoloads nil "vt-control" "vt-control.el" (0 0 0 0)) -;;; Generated autoloads from vt-control.el +;;;### (autoloads nil "vtable" "emacs-lisp/vtable.el" (0 0 0 0)) +;;; Generated autoloads from emacs-lisp/vtable.el -(register-definition-prefixes "vt-control" '("vt-")) - -;;;*** - -;;;### (autoloads nil "vt100-led" "vt100-led.el" (0 0 0 0)) -;;; Generated autoloads from vt100-led.el - -(register-definition-prefixes "vt100-led" '("led-")) +(register-definition-prefixes "vtable" '("vtable")) ;;;*** @@ -38948,23 +39044,23 @@ or call the function `which-function-mode'.") (autoload 'which-function-mode "which-func" "\ Toggle mode line display of current function (Which Function mode). -This is a minor mode. If called interactively, toggle the +Which Function mode is a global minor mode. When enabled, the +current function name is continuously displayed in the mode line, +in certain major modes. + +This is a global minor mode. If called interactively, toggle the `Which-Function mode' mode. If the prefix argument is positive, enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='which-function-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Which Function mode is a global minor mode. When enabled, the -current function name is continuously displayed in the mode line, -in certain major modes. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -38979,45 +39075,31 @@ in certain major modes. (autoload 'whitespace-mode "whitespace" "\ Toggle whitespace visualization (Whitespace mode). -This is a minor mode. If called interactively, toggle the `Whitespace -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `whitespace-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - See also `whitespace-style', `whitespace-newline' and `whitespace-display-mappings'. This mode uses a number of faces to visualize the whitespace; see the customization group `whitespace' for details. +This is a minor mode. If called interactively, toggle the +`Whitespace mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `whitespace-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'whitespace-newline-mode "whitespace" "\ Toggle newline visualization (Whitespace Newline mode). -This is a minor mode. If called interactively, toggle the -`Whitespace-Newline mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `whitespace-newline-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Use `whitespace-newline-mode' only for NEWLINE visualization exclusively. For other visualizations, including NEWLINE visualization together with (HARD) SPACEs and/or TABs, please, @@ -39025,6 +39107,21 @@ use `whitespace-mode'. See also `whitespace-newline' and `whitespace-display-mappings'. +This is a minor mode. If called interactively, toggle the +`Whitespace-Newline mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `whitespace-newline-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defvar global-whitespace-mode nil "\ @@ -39040,22 +39137,23 @@ or call the function `global-whitespace-mode'.") (autoload 'global-whitespace-mode "whitespace" "\ Toggle whitespace visualization globally (Global Whitespace mode). -This is a minor mode. If called interactively, toggle the `Global -Whitespace mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +See also `whitespace-style', `whitespace-newline' and +`whitespace-display-mappings'. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +This is a global minor mode. If called interactively, toggle the +`Global Whitespace mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='global-whitespace-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -See also `whitespace-style', `whitespace-newline' and -`whitespace-display-mappings'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -39072,20 +39170,6 @@ or call the function `global-whitespace-newline-mode'.") (autoload 'global-whitespace-newline-mode "whitespace" "\ Toggle global newline visualization (Global Whitespace Newline mode). -This is a minor mode. If called interactively, toggle the `Global -Whitespace-Newline mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='global-whitespace-newline-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Use `global-whitespace-newline-mode' only for NEWLINE visualization exclusively. For other visualizations, including NEWLINE visualization together with (HARD) SPACEs and/or TABs, @@ -39093,6 +39177,21 @@ please use `global-whitespace-mode'. See also `whitespace-newline' and `whitespace-display-mappings'. +This is a global minor mode. If called interactively, toggle the +`Global Whitespace-Newline mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='global-whitespace-newline-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'whitespace-toggle-options "whitespace" "\ @@ -39405,19 +39504,19 @@ Show widget browser for WIDGET in other window. (autoload 'widget-minor-mode "wid-browse" "\ Minor mode for traversing widgets. -This is a minor mode. If called interactively, toggle the `Widget -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the +`Widget minor mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `widget-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -39524,19 +39623,19 @@ for a description of this minor mode.") (autoload 'windmove-mode "windmove" "\ Global minor mode for default windmove commands. -This is a minor mode. If called interactively, toggle the `Windmove -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Windmove mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='windmove-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -39688,20 +39787,6 @@ or call the function `winner-mode'.") (autoload 'winner-mode "winner" "\ Toggle Winner mode on or off. -This is a minor mode. If called interactively, toggle the `Winner -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='winner-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Winner mode is a global minor mode that records the changes in the window configuration (i.e. how the frames are partitioned into windows) so that the changes can be \"undone\" using the @@ -39709,6 +39794,20 @@ command `winner-undo'. By default this one is bound to the key sequence `C-c '. If you change your mind (while undoing), you can press `C-c ' (calling `winner-redo'). +This is a global minor mode. If called interactively, toggle the +`Winner mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='winner-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "winner" '("winner-")) @@ -39761,6 +39860,65 @@ Default bookmark handler for Woman buffers. (register-definition-prefixes "woman" '("WoMan-" "menu-bar-manuals-menu" "set-woman-file-regexp" "woman")) +;;;*** + +;;;### (autoloads nil "word-wrap-mode" "textmodes/word-wrap-mode.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from textmodes/word-wrap-mode.el + +(autoload 'word-wrap-whitespace-mode "word-wrap-mode" "\ +Allow `word-wrap' to fold on all breaking whitespace characters. + +The characters to break on are defined by `word-wrap-whitespace-characters'. + +This is a minor mode. If called interactively, toggle the +`Word-Wrap-Whitespace mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable +the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `word-wrap-whitespace-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + +\(fn &optional ARG)" t nil) + +(put 'global-word-wrap-whitespace-mode 'globalized-minor-mode t) + +(defvar global-word-wrap-whitespace-mode nil "\ +Non-nil if Global Word-Wrap-Whitespace mode is enabled. +See the `global-word-wrap-whitespace-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `global-word-wrap-whitespace-mode'.") + +(custom-autoload 'global-word-wrap-whitespace-mode "word-wrap-mode" nil) + +(autoload 'global-word-wrap-whitespace-mode "word-wrap-mode" "\ +Toggle Word-Wrap-Whitespace mode in all buffers. +With prefix ARG, enable Global Word-Wrap-Whitespace mode if ARG is +positive; otherwise, disable it. + +If called from Lisp, toggle the mode if ARG is `toggle'. +Enable the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +Word-Wrap-Whitespace mode is enabled in all buffers where +`word-wrap-whitespace-mode' would do it. + +See `word-wrap-whitespace-mode' for more information on +Word-Wrap-Whitespace mode. + +\(fn &optional ARG)" t nil) + +(register-definition-prefixes "word-wrap-mode" '("word-wrap-whitespace-characters")) + ;;;*** ;;;### (autoloads nil "x-dnd" "x-dnd.el" (0 0 0 0)) @@ -39863,7 +40021,7 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT. ;;;### (autoloads nil "xref" "progmodes/xref.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/xref.el -(push (purecopy '(xref 1 3 2)) package--builtin-versions) +(push (purecopy '(xref 1 4 1)) package--builtin-versions) (autoload 'xref-find-backend "xref" nil nil nil) @@ -39882,6 +40040,13 @@ Whether the xref back-history is empty." nil nil) (autoload 'xref-forward-history-empty-p "xref" "\ Whether the xref forward-history is empty." nil nil) +(autoload 'xref-show-xrefs "xref" "\ +Display some Xref values produced by FETCHER using DISPLAY-ACTION. +The meanings of both arguments are the same as documented in +`xref-show-xrefs-function'. + +\(fn FETCHER DISPLAY-ACTION)" nil nil) + (autoload 'xref-find-definitions "xref" "\ Find the definition of the identifier at point. With prefix argument or when there's no identifier at point, @@ -40006,20 +40171,6 @@ or call the function `xterm-mouse-mode'.") (autoload 'xterm-mouse-mode "xt-mouse" "\ Toggle XTerm mouse mode. -This is a minor mode. If called interactively, toggle the -`Xterm-Mouse mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the -mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='xterm-mouse-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Turn it on to use Emacs mouse commands, and off to use xterm mouse commands. This works in terminal emulators compatible with xterm. It only works for simple uses of the mouse. Basically, only non-modified @@ -40027,6 +40178,20 @@ single clicks are supported. When turned on, the normal xterm mouse functionality for such clicks is still available by holding down the SHIFT key while pressing the mouse button. +This is a global minor mode. If called interactively, toggle the +`Xterm-Mouse mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='xterm-mouse-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (register-definition-prefixes "xt-mouse" '("turn-o" "xt-mouse-epoch" "xterm-mouse-")) @@ -40115,24 +40280,23 @@ Zone out, completely." t nil) ;;;### (autoloads nil nil ("abbrev.el" "bindings.el" "buff-menu.el" ;;;;;; "button.el" "calc/calc-aent.el" "calc/calc-embed.el" "calc/calc-misc.el" -;;;;;; "calc/calc-yank.el" "case-table.el" "cedet/ede/base.el" "cedet/ede/config.el" -;;;;;; "cedet/ede/cpp-root.el" "cedet/ede/custom.el" "cedet/ede/dired.el" -;;;;;; "cedet/ede/emacs.el" "cedet/ede/files.el" "cedet/ede/generic.el" -;;;;;; "cedet/ede/linux.el" "cedet/ede/locate.el" "cedet/ede/make.el" -;;;;;; "cedet/ede/shell.el" "cedet/ede/speedbar.el" "cedet/ede/system.el" -;;;;;; "cedet/ede/util.el" "cedet/semantic/analyze.el" "cedet/semantic/analyze/complete.el" -;;;;;; "cedet/semantic/analyze/refs.el" "cedet/semantic/bovine.el" -;;;;;; "cedet/semantic/bovine/c-by.el" "cedet/semantic/bovine/c.el" -;;;;;; "cedet/semantic/bovine/el.el" "cedet/semantic/bovine/gcc.el" -;;;;;; "cedet/semantic/bovine/make-by.el" "cedet/semantic/bovine/make.el" -;;;;;; "cedet/semantic/bovine/scm-by.el" "cedet/semantic/bovine/scm.el" -;;;;;; "cedet/semantic/complete.el" "cedet/semantic/ctxt.el" "cedet/semantic/db-file.el" -;;;;;; "cedet/semantic/db-find.el" "cedet/semantic/db-global.el" -;;;;;; "cedet/semantic/db-mode.el" "cedet/semantic/db-typecache.el" -;;;;;; "cedet/semantic/db.el" "cedet/semantic/debug.el" "cedet/semantic/decorate/include.el" -;;;;;; "cedet/semantic/decorate/mode.el" "cedet/semantic/dep.el" -;;;;;; "cedet/semantic/doc.el" "cedet/semantic/edit.el" "cedet/semantic/find.el" -;;;;;; "cedet/semantic/format.el" "cedet/semantic/grammar-wy.el" +;;;;;; "calc/calc-yank.el" "case-table.el" "cedet/ede/cpp-root.el" +;;;;;; "cedet/ede/custom.el" "cedet/ede/dired.el" "cedet/ede/emacs.el" +;;;;;; "cedet/ede/files.el" "cedet/ede/generic.el" "cedet/ede/linux.el" +;;;;;; "cedet/ede/locate.el" "cedet/ede/make.el" "cedet/ede/speedbar.el" +;;;;;; "cedet/ede/system.el" "cedet/ede/util.el" "cedet/semantic/analyze.el" +;;;;;; "cedet/semantic/analyze/complete.el" "cedet/semantic/analyze/refs.el" +;;;;;; "cedet/semantic/bovine.el" "cedet/semantic/bovine/c-by.el" +;;;;;; "cedet/semantic/bovine/c.el" "cedet/semantic/bovine/el.el" +;;;;;; "cedet/semantic/bovine/gcc.el" "cedet/semantic/bovine/make-by.el" +;;;;;; "cedet/semantic/bovine/make.el" "cedet/semantic/bovine/scm-by.el" +;;;;;; "cedet/semantic/bovine/scm.el" "cedet/semantic/complete.el" +;;;;;; "cedet/semantic/ctxt.el" "cedet/semantic/db-file.el" "cedet/semantic/db-find.el" +;;;;;; "cedet/semantic/db-global.el" "cedet/semantic/db-mode.el" +;;;;;; "cedet/semantic/db-typecache.el" "cedet/semantic/db.el" "cedet/semantic/debug.el" +;;;;;; "cedet/semantic/decorate/include.el" "cedet/semantic/decorate/mode.el" +;;;;;; "cedet/semantic/dep.el" "cedet/semantic/doc.el" "cedet/semantic/edit.el" +;;;;;; "cedet/semantic/find.el" "cedet/semantic/format.el" "cedet/semantic/grammar-wy.el" ;;;;;; "cedet/semantic/grm-wy-boot.el" "cedet/semantic/html.el" ;;;;;; "cedet/semantic/ia-sb.el" "cedet/semantic/ia.el" "cedet/semantic/idle.el" ;;;;;; "cedet/semantic/imenu.el" "cedet/semantic/lex-spp.el" "cedet/semantic/lex.el" @@ -40151,81 +40315,93 @@ Zone out, completely." t nil) ;;;;;; "cedet/srecode/insert.el" "cedet/srecode/java.el" "cedet/srecode/map.el" ;;;;;; "cedet/srecode/mode.el" "cedet/srecode/srt-wy.el" "cedet/srecode/srt.el" ;;;;;; "cedet/srecode/template.el" "cedet/srecode/texi.el" "composite.el" -;;;;;; "cus-face.el" "cus-start.el" "custom.el" "dired-aux.el" "dired-x.el" -;;;;;; "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el" +;;;;;; "cus-face.el" "cus-load.el" "cus-start.el" "custom.el" "dired-aux.el" +;;;;;; "dired-x.el" "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el" ;;;;;; "emacs-lisp/cl-extra.el" "emacs-lisp/cl-macs.el" "emacs-lisp/cl-preloaded.el" -;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/easymenu.el" "emacs-lisp/eieio-custom.el" -;;;;;; "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el" "emacs-lisp/lisp-mode.el" -;;;;;; "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" "emacs-lisp/map-ynp.el" -;;;;;; "emacs-lisp/nadvice.el" "emacs-lisp/shorthands.el" "emacs-lisp/syntax.el" -;;;;;; "emacs-lisp/timer.el" "env.el" "epa-hook.el" "erc/erc-autoaway.el" -;;;;;; "erc/erc-button.el" "erc/erc-capab.el" "erc/erc-compat.el" -;;;;;; "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" "erc/erc-ezbounce.el" -;;;;;; "erc/erc-fill.el" "erc/erc-identd.el" "erc/erc-imenu.el" -;;;;;; "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" "erc/erc-match.el" -;;;;;; "erc/erc-menu.el" "erc/erc-netsplit.el" "erc/erc-notify.el" -;;;;;; "erc/erc-page.el" "erc/erc-pcomplete.el" "erc/erc-replace.el" -;;;;;; "erc/erc-ring.el" "erc/erc-services.el" "erc/erc-sound.el" -;;;;;; "erc/erc-speedbar.el" "erc/erc-spelling.el" "erc/erc-stamp.el" -;;;;;; "erc/erc-status-sidebar.el" "erc/erc-track.el" "erc/erc-truncate.el" -;;;;;; "erc/erc-xdcc.el" "eshell/em-alias.el" "eshell/em-banner.el" -;;;;;; "eshell/em-basic.el" "eshell/em-cmpl.el" "eshell/em-dirs.el" -;;;;;; "eshell/em-glob.el" "eshell/em-hist.el" "eshell/em-ls.el" -;;;;;; "eshell/em-pred.el" "eshell/em-prompt.el" "eshell/em-rebind.el" -;;;;;; "eshell/em-script.el" "eshell/em-smart.el" "eshell/em-term.el" -;;;;;; "eshell/em-tramp.el" "eshell/em-unix.el" "eshell/em-xtra.el" -;;;;;; "faces.el" "files.el" "font-core.el" "font-lock.el" "format.el" -;;;;;; "frame.el" "help.el" "hfy-cmap.el" "ibuf-ext.el" "indent.el" -;;;;;; "international/characters.el" "international/charscript.el" -;;;;;; "international/cp51932.el" "international/emoji-zwj.el" "international/eucjp-ms.el" +;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/debug-early.el" "emacs-lisp/easymenu.el" +;;;;;; "emacs-lisp/eieio-custom.el" "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el" +;;;;;; "emacs-lisp/lisp-mode.el" "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" +;;;;;; "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" "emacs-lisp/oclosure.el" +;;;;;; "emacs-lisp/shorthands.el" "emacs-lisp/syntax.el" "emacs-lisp/timer.el" +;;;;;; "env.el" "epa-hook.el" "erc/erc-autoaway.el" "erc/erc-button.el" +;;;;;; "erc/erc-capab.el" "erc/erc-compat.el" "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" +;;;;;; "erc/erc-ezbounce.el" "erc/erc-fill.el" "erc/erc-identd.el" +;;;;;; "erc/erc-imenu.el" "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" +;;;;;; "erc/erc-match.el" "erc/erc-menu.el" "erc/erc-netsplit.el" +;;;;;; "erc/erc-notify.el" "erc/erc-page.el" "erc/erc-pcomplete.el" +;;;;;; "erc/erc-replace.el" "erc/erc-ring.el" "erc/erc-services.el" +;;;;;; "erc/erc-sound.el" "erc/erc-speedbar.el" "erc/erc-spelling.el" +;;;;;; "erc/erc-stamp.el" "erc/erc-status-sidebar.el" "erc/erc-track.el" +;;;;;; "erc/erc-truncate.el" "erc/erc-xdcc.el" "eshell/em-alias.el" +;;;;;; "eshell/em-banner.el" "eshell/em-basic.el" "eshell/em-cmpl.el" +;;;;;; "eshell/em-dirs.el" "eshell/em-elecslash.el" "eshell/em-glob.el" +;;;;;; "eshell/em-hist.el" "eshell/em-ls.el" "eshell/em-pred.el" +;;;;;; "eshell/em-prompt.el" "eshell/em-rebind.el" "eshell/em-script.el" +;;;;;; "eshell/em-smart.el" "eshell/em-term.el" "eshell/em-tramp.el" +;;;;;; "eshell/em-unix.el" "eshell/em-xtra.el" "eshell/esh-groups.el" +;;;;;; "faces.el" "files.el" "finder-inf.el" "font-core.el" "font-lock.el" +;;;;;; "format.el" "frame.el" "help.el" "hfy-cmap.el" "ibuf-ext.el" +;;;;;; "indent.el" "international/characters.el" "international/charprop.el" +;;;;;; "international/charscript.el" "international/cp51932.el" +;;;;;; "international/emoji-labels.el" "international/emoji-zwj.el" +;;;;;; "international/eucjp-ms.el" "international/idna-mapping.el" ;;;;;; "international/iso-transl.el" "international/mule-cmds.el" -;;;;;; "international/mule-conf.el" "international/mule.el" "isearch.el" -;;;;;; "jit-lock.el" "jka-cmpr-hook.el" "keymap.el" "language/burmese.el" -;;;;;; "language/cham.el" "language/chinese.el" "language/cyrillic.el" -;;;;;; "language/czech.el" "language/english.el" "language/ethiopic.el" -;;;;;; "language/european.el" "language/georgian.el" "language/greek.el" -;;;;;; "language/hebrew.el" "language/indian.el" "language/japanese.el" -;;;;;; "language/khmer.el" "language/korean.el" "language/lao.el" -;;;;;; "language/misc-lang.el" "language/romanian.el" "language/sinhala.el" -;;;;;; "language/slovak.el" "language/tai-viet.el" "language/thai.el" -;;;;;; "language/tibetan.el" "language/utf-8-lang.el" "language/vietnamese.el" -;;;;;; "ldefs-boot.el" "leim/ja-dic/ja-dic.el" "leim/leim-list.el" -;;;;;; "leim/quail/4Corner.el" "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" -;;;;;; "leim/quail/CTLau-b5.el" "leim/quail/CTLau.el" "leim/quail/ECDICT.el" -;;;;;; "leim/quail/ETZY.el" "leim/quail/PY-b5.el" "leim/quail/PY.el" -;;;;;; "leim/quail/Punct-b5.el" "leim/quail/Punct.el" "leim/quail/QJ-b5.el" -;;;;;; "leim/quail/QJ.el" "leim/quail/SW.el" "leim/quail/TONEPY.el" -;;;;;; "leim/quail/ZIRANMA.el" "leim/quail/ZOZY.el" "leim/quail/arabic.el" -;;;;;; "leim/quail/cham.el" "leim/quail/compose.el" "leim/quail/croatian.el" -;;;;;; "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el" "leim/quail/czech.el" -;;;;;; "leim/quail/emoji.el" "leim/quail/georgian.el" "leim/quail/greek.el" -;;;;;; "leim/quail/hanja-jis.el" "leim/quail/hanja.el" "leim/quail/hanja3.el" -;;;;;; "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" -;;;;;; "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" "leim/quail/latin-pre.el" -;;;;;; "leim/quail/persian.el" "leim/quail/programmer-dvorak.el" -;;;;;; "leim/quail/py-punct.el" "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" -;;;;;; "leim/quail/quick-cns.el" "leim/quail/rfc1345.el" "leim/quail/sami.el" -;;;;;; "leim/quail/sgml-input.el" "leim/quail/slovak.el" "leim/quail/symbol-ksc.el" -;;;;;; "leim/quail/tamil-dvorak.el" "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el" -;;;;;; "leim/quail/vntelex.el" "leim/quail/vnvni.el" "leim/quail/welsh.el" -;;;;;; "loadup.el" "mail/blessmail.el" "mail/undigest.el" "menu-bar.el" -;;;;;; "mh-e/mh-gnus.el" "minibuffer.el" "mouse.el" "newcomment.el" -;;;;;; "obarray.el" "org/ob-core.el" "org/ob-lob.el" "org/ob-matlab.el" -;;;;;; "org/ob-tangle.el" "org/ob.el" "org/ol-bbdb.el" "org/ol-irc.el" -;;;;;; "org/ol.el" "org/org-archive.el" "org/org-attach.el" "org/org-clock.el" -;;;;;; "org/org-colview.el" "org/org-compat.el" "org/org-datetree.el" -;;;;;; "org/org-duration.el" "org/org-element.el" "org/org-feed.el" -;;;;;; "org/org-footnote.el" "org/org-goto.el" "org/org-id.el" "org/org-indent.el" -;;;;;; "org/org-install.el" "org/org-keys.el" "org/org-lint.el" -;;;;;; "org/org-list.el" "org/org-macs.el" "org/org-mobile.el" "org/org-num.el" -;;;;;; "org/org-plot.el" "org/org-refile.el" "org/org-table.el" -;;;;;; "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el" "org/ox-html.el" -;;;;;; "org/ox-icalendar.el" "org/ox-latex.el" "org/ox-md.el" "org/ox-odt.el" -;;;;;; "org/ox-org.el" "org/ox-publish.el" "org/ox-texinfo.el" "org/ox.el" -;;;;;; "paren.el" "progmodes/elisp-mode.el" "progmodes/prog-mode.el" -;;;;;; "ps-mule.el" "register.el" "replace.el" "rfn-eshadow.el" -;;;;;; "select.el" "simple.el" "startup.el" "subdirs.el" "subr.el" -;;;;;; "tab-bar.el" "textmodes/fill.el" "textmodes/makeinfo.el" +;;;;;; "international/mule-conf.el" "international/mule.el" "international/uni-bidi.el" +;;;;;; "international/uni-brackets.el" "international/uni-category.el" +;;;;;; "international/uni-combining.el" "international/uni-comment.el" +;;;;;; "international/uni-confusable.el" "international/uni-decimal.el" +;;;;;; "international/uni-decomposition.el" "international/uni-digit.el" +;;;;;; "international/uni-lowercase.el" "international/uni-mirrored.el" +;;;;;; "international/uni-name.el" "international/uni-numeric.el" +;;;;;; "international/uni-old-name.el" "international/uni-scripts.el" +;;;;;; "international/uni-special-lowercase.el" "international/uni-special-titlecase.el" +;;;;;; "international/uni-special-uppercase.el" "international/uni-titlecase.el" +;;;;;; "international/uni-uppercase.el" "isearch.el" "jit-lock.el" +;;;;;; "jka-cmpr-hook.el" "keymap.el" "language/burmese.el" "language/cham.el" +;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el" +;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el" +;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el" +;;;;;; "language/indian.el" "language/japanese.el" "language/khmer.el" +;;;;;; "language/korean.el" "language/lao.el" "language/misc-lang.el" +;;;;;; "language/romanian.el" "language/sinhala.el" "language/slovak.el" +;;;;;; "language/tai-viet.el" "language/thai.el" "language/tibetan.el" +;;;;;; "language/utf-8-lang.el" "language/vietnamese.el" "ldefs-boot.el" +;;;;;; "leim/ja-dic/ja-dic.el" "leim/leim-list.el" "leim/quail/4Corner.el" +;;;;;; "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el" +;;;;;; "leim/quail/CTLau.el" "leim/quail/ECDICT.el" "leim/quail/ETZY.el" +;;;;;; "leim/quail/PY-b5.el" "leim/quail/PY.el" "leim/quail/Punct-b5.el" +;;;;;; "leim/quail/Punct.el" "leim/quail/QJ-b5.el" "leim/quail/QJ.el" +;;;;;; "leim/quail/SW.el" "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el" +;;;;;; "leim/quail/ZOZY.el" "leim/quail/arabic.el" "leim/quail/cham.el" +;;;;;; "leim/quail/compose.el" "leim/quail/croatian.el" "leim/quail/cyril-jis.el" +;;;;;; "leim/quail/cyrillic.el" "leim/quail/czech.el" "leim/quail/emoji.el" +;;;;;; "leim/quail/georgian.el" "leim/quail/greek.el" "leim/quail/hanja-jis.el" +;;;;;; "leim/quail/hanja.el" "leim/quail/hanja3.el" "leim/quail/hebrew.el" +;;;;;; "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" "leim/quail/latin-ltx.el" +;;;;;; "leim/quail/latin-post.el" "leim/quail/latin-pre.el" "leim/quail/persian.el" +;;;;;; "leim/quail/programmer-dvorak.el" "leim/quail/py-punct.el" +;;;;;; "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" "leim/quail/quick-cns.el" +;;;;;; "leim/quail/rfc1345.el" "leim/quail/sami.el" "leim/quail/sgml-input.el" +;;;;;; "leim/quail/slovak.el" "leim/quail/symbol-ksc.el" "leim/quail/tamil-dvorak.el" +;;;;;; "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el" "leim/quail/vntelex.el" +;;;;;; "leim/quail/vnvni.el" "leim/quail/welsh.el" "loadup.el" "mail/blessmail.el" +;;;;;; "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el" "minibuffer.el" +;;;;;; "mouse.el" "newcomment.el" "obarray.el" "org/ob-core.el" +;;;;;; "org/ob-lob.el" "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" +;;;;;; "org/ol-bbdb.el" "org/ol-irc.el" "org/ol.el" "org/org-archive.el" +;;;;;; "org/org-attach.el" "org/org-clock.el" "org/org-colview.el" +;;;;;; "org/org-compat.el" "org/org-datetree.el" "org/org-duration.el" +;;;;;; "org/org-element.el" "org/org-feed.el" "org/org-footnote.el" +;;;;;; "org/org-goto.el" "org/org-id.el" "org/org-indent.el" "org/org-install.el" +;;;;;; "org/org-keys.el" "org/org-lint.el" "org/org-list.el" "org/org-macs.el" +;;;;;; "org/org-mobile.el" "org/org-num.el" "org/org-plot.el" "org/org-refile.el" +;;;;;; "org/org-table.el" "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el" +;;;;;; "org/ox-html.el" "org/ox-icalendar.el" "org/ox-latex.el" +;;;;;; "org/ox-md.el" "org/ox-odt.el" "org/ox-org.el" "org/ox-publish.el" +;;;;;; "org/ox-texinfo.el" "org/ox.el" "paren.el" "progmodes/elisp-mode.el" +;;;;;; "progmodes/prog-mode.el" "ps-mule.el" "register.el" "replace.el" +;;;;;; "rfn-eshadow.el" "select.el" "simple.el" "startup.el" "subdirs.el" +;;;;;; "subr.el" "tab-bar.el" "textmodes/fill.el" "textmodes/makeinfo.el" ;;;;;; "textmodes/page.el" "textmodes/paragraphs.el" "textmodes/reftex-auc.el" ;;;;;; "textmodes/reftex-cite.el" "textmodes/reftex-dcr.el" "textmodes/reftex-global.el" ;;;;;; "textmodes/reftex-index.el" "textmodes/reftex-parse.el" "textmodes/reftex-ref.el" diff --git a/lisp/leim/quail/compose.el b/lisp/leim/quail/compose.el index 2aa8ae78fe7..60c73d7dff8 100644 --- a/lisp/leim/quail/compose.el +++ b/lisp/leim/quail/compose.el @@ -464,9 +464,9 @@ Examples: ("2^" ?²) ("^3" ?³) ("3^" ?³) - ("mu" ?µ) - ("/u" ?µ) - ("u/" ?µ) + ("mu" ?μ) + ("/u" ?μ) + ("u/" ?μ) ("^1" ?¹) ("1^" ?¹) ("^_o" ?º) diff --git a/lisp/leim/quail/indian.el b/lisp/leim/quail/indian.el index 23204c0cd3e..f2d5f9bad4a 100644 --- a/lisp/leim/quail/indian.el +++ b/lisp/leim/quail/indian.el @@ -171,7 +171,7 @@ clm) (with-temp-buffer (insert "\n") - (insert " +") + (insert "----+") (insert-char ?- 74) (insert "\n |") (setq clm 6) @@ -244,19 +244,27 @@ (insert "\n") (buffer-string)))) -(defvar quail-tamil-itrans-various-signs-and-digits-table +(defun quail-tamil-itrans-compute-signs-table (digitp) + "Compute the signs table for the tamil-itrans input method. +If DIGITP is non-nil, include the digits translation as well." (let ((various '((?ஃ . "H") ("ஸ்ரீ" . "srii") (?ௐ))) (digits "௦௧௨௩௪௫௬௭௮௯") (width 6) clm) (with-temp-buffer - (insert "\n" (make-string 18 ?-) "+" (make-string 60 ?-) "\n") + (insert "\n" (make-string 18 ?-) "+") + (when digitp (insert (make-string 60 ?-))) + (insert "\n") (insert (propertize "\t" 'display '(space :align-to 5)) "various" - (propertize "\t" 'display '(space :align-to 18)) "|" - (propertize "\t" 'display '(space :align-to 45)) "digits") - - (insert "\n" (make-string 18 ?-) "+" (make-string 60 ?-) "\n") - (setq clm 0 ) + (propertize "\t" 'display '(space :align-to 18)) "|") + (when digitp + (insert + (propertize "\t" 'display '(space :align-to 45)) "digits")) + (insert "\n" (make-string 18 ?-) "+") + (when digitp + (insert (make-string 60 ?-))) + (insert "\n") + (setq clm 0) (dotimes (i (length various)) (insert (propertize "\t" 'display (list 'space :align-to clm)) @@ -264,10 +272,11 @@ (setq clm (+ clm width))) (insert (propertize "\t" 'display '(space :align-to 18)) "|") (setq clm 20) - (dotimes (i 10) - (insert (propertize "\t" 'display (list 'space :align-to clm)) - (aref digits i)) - (setq clm (+ clm width))) + (when digitp + (dotimes (i 10) + (insert (propertize "\t" 'display (list 'space :align-to clm)) + (aref digits i)) + (setq clm (+ clm width)))) (insert "\n") (setq clm 0) (dotimes (i (length various)) @@ -276,13 +285,22 @@ (setq clm (+ clm width))) (insert (propertize "\t" 'display '(space :align-to 18)) "|") (setq clm 20) - (dotimes (i 10) - (insert (propertize "\t" 'display (list 'space :align-to clm)) - (format "%d" i)) - (setq clm (+ clm width))) - (insert "\n" (make-string 18 ?-) "+" (make-string 60 ?-) "\n") + (when digitp + (dotimes (i 10) + (insert (propertize "\t" 'display (list 'space :align-to clm)) + (format "%d" i)) + (setq clm (+ clm width)))) + (insert "\n" (make-string 18 ?-) "+") + (when digitp + (insert (make-string 60 ?-) "\n")) (buffer-string)))) +(defvar quail-tamil-itrans-various-signs-and-digits-table + (quail-tamil-itrans-compute-signs-table t)) + +(defvar quail-tamil-itrans-various-signs-table + (quail-tamil-itrans-compute-signs-table nil)) + (if nil (quail-define-package "tamil-itrans" "Tamil" "TmlIT" t "Tamil ITRANS")) (quail-define-indian-trans-package @@ -293,16 +311,39 @@ You can input characters using the following mapping tables. Example: To enter வணக்கம், type vaNakkam. ### Basic syllables (consonants + vowels) ### -\\ +\\=\\ -### Miscellaneous (various signs + digits) ### -\\ +### Miscellaneous (various signs) ### +\\=\\ ### Others (numerics + symbols) ### Characters below have no ITRANS method associated with them. Their descriptions are included for easy reference. -\\ +\\=\\ + +Full key sequences are listed below:") + +(if nil + (quail-define-package "tamil-itrans-digits" "Tamil" "TmlITD" t "Tamil ITRANS with digits")) +(quail-define-indian-trans-package + indian-tml-itrans-digits-v5-hash "tamil-itrans-digits" "Tamil" "TmlITD" + "Tamil transliteration by ITRANS method with Tamil digits support. + +You can input characters using the following mapping tables. + Example: To enter வணக்கம், type vaNakkam. + +### Basic syllables (consonants + vowels) ### +\\=\\ + +### Miscellaneous (various signs + digits) ### +\\=\\ + +### Others (numerics + symbols) ### + +Characters below have no ITRANS method associated with them. +Their descriptions are included for easy reference. +\\=\\ Full key sequences are listed below:") @@ -479,6 +520,13 @@ Full key sequences are listed below:") "tamil-inscript" "Tamil" "TmlIS" "Tamil keyboard Inscript.") +(if nil + (quail-define-package "tamil-inscript-digits" "Tamil" "TmlISD" t "Tamil keyboard Inscript with digits.")) +(quail-define-inscript-package + indian-tml-base-digits-table inscript-tml-keytable + "tamil-inscript-digits" "Tamil" "TmlISD" + "Tamil keyboard Inscript with Tamil digits support.") + ;; Probhat Input Method (quail-define-package "bengali-probhat" "Bengali" "BngPB" t @@ -648,4 +696,144 @@ Full key sequences are listed below:") (quail-defrule "|" ?‌) (quail-defrule "||" ?​) +(quail-define-package + "brahmi" "Brahmi" "𑀲" t "Brahmi phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("``" ?₹) + ("1" ?𑁧) + ("`1" ?1) + ("`!" ?𑁒) + ("2" ?𑁨) + ("`2" ?2) + ("`@" ?𑁓) + ("3" ?𑁩) + ("`3" ?3) + ("`#" ?𑁔) + ("4" ?𑁪) + ("`4" ?4) + ("`$" ?𑁕) + ("5" ?𑁫) + ("`5" ?5) + ("`%" ?𑁖) + ("6" ?𑁬) + ("`6" ?6) + ("`^" ?𑁗) + ("7" ?𑁭) + ("`7" ?7) + ("`&" ?𑁘) + ("8" ?𑁮) + ("`8" ?8) + ("`*" ?𑁙) + ("9" ?𑁯) + ("`9" ?9) + ("`\(" ?𑁚) + ("0" ?𑁦) + ("`0" ?0) + ("`\)" ?𑁛) + ("`-" ?𑁜) + ("`_" ?𑁝) + ("`=" ?𑁞) + ("`+" ?𑁟) + ("`\\" ?𑁇) + ("`|" ?𑁈) + ("`" ?𑀝) + ("q" ?𑀝) + ("Q" ?𑀞) + ("`q" ?𑀃) + ("`Q" ?𑁠) + ("w" ?𑀟) + ("W" ?𑀠) + ("`w" ?𑀄) + ("`W" ?𑁡) + ("e" ?𑁂) + ("E" ?𑁃) + ("`e" ?𑀏) + ("`E" ?𑀐) + ("r" ?𑀭) + ("R" ?𑀾) + ("`r" ?𑀋) + ("`R" ?𑀶) + ("t" ?𑀢) + ("T" ?𑀣) + ("`t" ?𑁢) + ("y" ?𑀬) + ("Y" ?𑁣) + ("`y" ?𑁤) + ("`Y" ?𑁥) + ("u" ?𑀼) + ("U" ?𑀽) + ("`u" ?𑀉) + ("`U" ?𑀊) + ("i" ?𑀺) + ("I" ?𑀻) + ("`i" ?𑀇) + ("`I" ?𑀈) + ("o" ?𑁄) + ("O" ?𑁅) + ("`o" ?𑀑) + ("`O" ?𑀒) + ("p" ?𑀧) + ("P" ?𑀨) + ("`p" ?𑁳) + ("`P" ?𑁱) + ("`\[" ?𑁴) + ("`\{" ?𑁲) + ("a" ?𑀸) + ("A" ?𑀆) + ("`a" ?𑀅) + ("`A" ?𑀹) + ("s" ?𑀲) + ("S" ?𑀰) + ("`s" ?𑀱) + ("d" ?𑀤) + ("D" ?𑀥) + ("`d" ?𑀶) + ("f" ?𑁆) + ("F" ?𑀿) + ("`f" ?𑀌) + ("`F" ?𑁰) + ("g" ?𑀕) + ("G" ?𑀖) + ("h" ?𑀳) + ("H" ?𑀂) + ("j" ?𑀚) + ("J" ?𑀛) + ("k" ?𑀓) + ("K" ?𑀔) + ("l" ?𑀮) + ("L" ?𑀴) + ("`l" ?𑀵) + ("`L" ?𑁵) + ("z" ?𑁀) + ("Z" ?𑀍) + ("`z" ?𑁁) + ("`Z" ?𑀎) + ("x" ?𑁉) + ("X" ?𑁊) + ("`x" ?𑁋) + ("`X" ?𑁌) + ("c" ?𑀘) + ("C" ?𑀙) + ("`c" #x200C) ; ZWNJ + ("`C" #x200D) ; ZWJ + ("v" ?𑀯) + ("V" ?𑀷) + ("b" ?𑀩) + ("B" ?𑀪) + ("n" ?𑀦) + ("N" ?𑀡) + ("`n" ?𑀗) + ("`N" ?𑀜) + ("m" ?𑀫) + ("M" ?𑀁) + ("`m" ?𑀀) + ("<" ?𑁍) + ("`/" ?𑁿) + ) + + ;;; indian.el ends here diff --git a/lisp/leim/quail/symbol-ksc.el b/lisp/leim/quail/symbol-ksc.el index 042465697a1..d440058902a 100644 --- a/lisp/leim/quail/symbol-ksc.el +++ b/lisp/leim/quail/symbol-ksc.el @@ -39,7 +39,7 @@ "한글심벌입력표: 【(】괄호열기【arrow】화살【sex】♂♀【index】첨자 【accent】악센트 【)】괄호닫기【music】음악【dot】점 【quote】따옴표【xtext】§※¶¡¿ - 【Unit】℃Å￠℉【math】수학기호【pic】상형문자【line】선문자 + 【Unit】℃Å￠℉【math】수학기호【pic】상형문자【line】선문자 【unit】단위 【frac】분수 【textline】­―∥＼∼ 【wn】㈜【ks】㉿【No】№【㏇】㏇ 【dag】† 【ddag】‡【percent】‰ 【am】㏂【pm】㏘【™】™【Tel】℡【won】￦ 【yen】￥ 【pound】￡ @@ -65,7 +65,7 @@ ("dot" "·‥…¨ː") ("quote" "、。〃‘’“”°′″´˝") ("textline" "­―∥＼∼") - ("Unit" "℃Å￠℉") + ("Unit" "℃Å￠℉") ("sex" "♂♀") ("accent" "～ˇ˘˚˙¸˛") ("percent" "‰") diff --git a/lisp/linum.el b/lisp/linum.el index e121618b69f..d491da52066 100644 --- a/lisp/linum.el +++ b/lisp/linum.el @@ -74,6 +74,9 @@ and you have to scroll or press \\[recenter-top-bottom] to update the numbers." ;;;###autoload (define-minor-mode linum-mode "Toggle display of line numbers in the left margin (Linum mode). +This mode has been largely replaced by `display-line-numbers-mode' +(which is much faster and has fewer interaction problems with other +modes). Linum mode is a buffer-local minor mode." :lighter "" ; for desktop.el diff --git a/lisp/loadup.el b/lisp/loadup.el index 81172c584d7..6ca699f9016 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -196,11 +196,10 @@ (setq definition-prefixes new)) (load "button") ;After loaddefs, because of define-minor-mode! -(load "emacs-lisp/nadvice") (load "emacs-lisp/cl-preloaded") +(load "emacs-lisp/oclosure") ;Used by cl-generic (load "obarray") ;abbrev.el is implemented in terms of obarrays. (load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table. -(load "simple") (load "help") @@ -251,6 +250,8 @@ (let ((max-specpdl-size (max max-specpdl-size 1800))) ;; A particularly demanding file to load; 1600 does not seem to be enough. (load "emacs-lisp/cl-generic")) +(load "simple") +(load "emacs-lisp/nadvice") (load "minibuffer") ;Needs cl-generic (and define-minor-mode). (load "frame") (load "startup") diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index 7a4be3c7e4c..33dd98ef8d2 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -891,7 +891,7 @@ All ls time options, namely c, t and u, are handled." nil) (defun ls-lisp--sanitize-switches (switches) - "Convert long options of GNU 'ls' to their short form. + "Convert long options of GNU \"ls\" to their short form. Conversion is done only for flags supported by ls-lisp. Long options not supported by ls-lisp are removed. Supported options are: A a B C c F G g h i n R r S s t U u v X. diff --git a/lisp/macros.el b/lisp/macros.el index 35d34d2e337..0baf3804332 100644 --- a/lisp/macros.el +++ b/lisp/macros.el @@ -46,6 +46,16 @@ " ") ?\])) +(defun macro--string-to-vector (str) + "Convert an old-style string key sequence to the vector form." + (let ((vec (string-to-vector str))) + (unless (multibyte-string-p str) + (dotimes (i (length vec)) + (let ((k (aref vec i))) + (when (> k 127) + (setf (aref vec i) (+ k ?\M-\C-@ -128)))))) + vec)) + ;;;###autoload (defun insert-kbd-macro (macroname &optional keys) "Insert in buffer the definition of kbd macro MACRONAME, as Lisp code. @@ -72,66 +82,31 @@ use this command, and then save the file." (setq macroname 'last-kbd-macro definition last-kbd-macro) (insert "(setq ")) (setq definition (symbol-function macroname)) - (insert "(fset '")) + ;; Prefer `defalias' over `fset' since it additionally keeps + ;; track of the file where the users added it, and it interacts + ;; better with `advice-add' (and hence things like ELP). + (insert "(defalias '")) (prin1 macroname (current-buffer)) (insert "\n ") - (if (stringp definition) - (let ((beg (point)) end) - (prin1 definition (current-buffer)) - (setq end (point-marker)) - (goto-char beg) - (while (< (point) end) - (let ((char (following-char))) - (cond ((= char 0) - (delete-region (point) (1+ (point))) - (insert "\\C-@")) - ((< char 27) - (delete-region (point) (1+ (point))) - (insert "\\C-" (+ 96 char))) - ((= char ?\C-\\) - (delete-region (point) (1+ (point))) - (insert "\\C-\\\\")) - ((< char 32) - (delete-region (point) (1+ (point))) - (insert "\\C-" (+ 64 char))) - ((< char 127) - (forward-char 1)) - ((= char 127) - (delete-region (point) (1+ (point))) - (insert "\\C-?")) - ((= char 128) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-@")) - ((= char (aref "\M-\C-\\" 0)) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-\\\\")) - ((< char 155) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-" (- char 32))) - ((< char 160) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-" (- char 64))) - ((= char (aref "\M-\\" 0)) - (delete-region (point) (1+ (point))) - (insert "\\M-\\\\")) - ((< char 255) - (delete-region (point) (1+ (point))) - (insert "\\M-" (- char 128))) - ((= char 255) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-?")))))) - (if (vectorp definition) - (macros--insert-vector-macro definition) - (pcase (kmacro-extract-lambda definition) - (`(,vecdef ,counter ,format) - (insert "(kmacro-lambda-form ") - (macros--insert-vector-macro vecdef) - (insert " ") - (prin1 counter (current-buffer)) - (insert " ") - (prin1 format (current-buffer)) - (insert ")")) - (_ (prin1 definition (current-buffer)))))) + (when (stringp definition) + (setq definition (macro--string-to-vector definition))) + (if (vectorp definition) + (setq definition (kmacro definition))) + (if (kmacro-p definition) + (let ((vecdef (kmacro--keys definition)) + (counter (kmacro--counter definition)) + (format (kmacro--format definition))) + (insert "(kmacro ") + (prin1 (key-description vecdef) (current-buffer)) + ;; FIXME: Do we really want to store the counter? + (unless (and (equal counter 0) (equal format "%d")) + (insert " ") + (prin1 counter (current-buffer)) + (insert " ") + (prin1 format (current-buffer))) + (insert ")")) + ;; FIXME: Shouldn't this signal an error? + (prin1 definition (current-buffer))) (insert ")\n") (if keys (let ((keys (or (and (symbol-function macroname) diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index 1bda609d105..8cb4a00009f 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -488,7 +488,14 @@ and send the mail again%s." Interactively, you will be prompted for SUBJECT and a patch FILE name (which will be attached to the mail). You will end up in a Message buffer where you can explain more about the patch." - (interactive "sThis patch is about: \nfPatch file name: ") + (interactive + (let* ((file (read-file-name "Patch file name: ")) + (guess (with-temp-buffer + (insert-file-contents file) + (mail-fetch-field "Subject")))) + (list (read-string (format-prompt "This patch is about" guess) + nil nil guess) + file))) (switch-to-buffer "*Patch Help*") (let ((inhibit-read-only t)) (erase-buffer) diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index 32edc292619..35e9f73f8cf 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -1317,7 +1317,7 @@ feedmail-queue-buffer-file-name is restored to nil. Example advice for mail-send: - (advice-add 'mail-send :around #'my-feedmail-mail-send-advice) + (advice-add \\='mail-send :around #\\='my-feedmail-mail-send-advice) (defun my-feedmail-mail-send-advice (orig-fun &rest args) (let ((feedmail-queue-buffer-file-name buffer-file-name) (buffer-file-name nil)) @@ -1742,7 +1742,7 @@ applied to a file after you've just read it from disk: for example, a feedmail FQM message file from a queue. You could use something like this: - (add-to-list 'auto-mode-alist \\='(\"\\\\.fqm\\\\\\='\" . feedmail-vm-mail-mode))" + (add-to-list \\='auto-mode-alist \\='(\"\\\\.fqm\\\\\\='\" . feedmail-vm-mail-mode))" (feedmail-say-debug ">in-> feedmail-vm-mail-mode") (let ((the-buf (current-buffer))) (vm-mail) diff --git a/lisp/mail/ietf-drums-date.el b/lisp/mail/ietf-drums-date.el index 6f64ae73377..ddef7f11b66 100644 --- a/lisp/mail/ietf-drums-date.el +++ b/lisp/mail/ietf-drums-date.el @@ -50,8 +50,8 @@ See the decoded-time defstruct.") '((0 60) (0 59) (0 23) (1 31) (1 12) (1 9999)) "Numeric slot ranges, for bounds checking. Note that RFC5322 explicitly requires that seconds go up to 60, -to allow for leap seconds (see Mills, D., 'Network Time -Protocol', STD 12, RFC 1119, September 1989).") +to allow for leap seconds (see Mills, D., \"Network Time +Protocol\", STD 12, RFC 1119, September 1989).") (defsubst ietf-drums-date--ignore-char-p (char) ;; Ignore whitespace and commas. diff --git a/lisp/mail/mail-parse.el b/lisp/mail/mail-parse.el index 23894e59b77..ec719850e2e 100644 --- a/lisp/mail/mail-parse.el +++ b/lisp/mail/mail-parse.el @@ -76,7 +76,8 @@ The return value is a list with mail/name pairs." (delq nil (mapcar (lambda (elem) - (or (mail-header-parse-address elem) + (or (ignore-errors + (mail-header-parse-address elem)) (mail-header-parse-address-lax elem))) (mail-header-parse-addresses string t)))) diff --git a/lisp/mail/rfc2047.el b/lisp/mail/rfc2047.el index b3c45100f6d..bb0d646346c 100644 --- a/lisp/mail/rfc2047.el +++ b/lisp/mail/rfc2047.el @@ -46,7 +46,7 @@ ("Followup-To" . nil) ("Message-ID" . nil) ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|\\(In-\\)?Reply-To\\|Sender\ -\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime) +\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\|Disposition-Notification-To\\)" . address-mime) (t . mime)) "Header/encoding method alist. The list is traversed sequentially. The keys can either be diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el index 76a32724c08..79f421bdcd6 100644 --- a/lisp/mail/rmailmm.el +++ b/lisp/mail/rmailmm.el @@ -796,17 +796,14 @@ directly." ((string-match "text/" content-type) (setq type 'text)) ((string-match "image/\\(.*\\)" content-type) - (setq type (image-type-from-file-name + (setq type (image-supported-file-p (concat "." (match-string 1 content-type)))) - (if (and (boundp 'image-types) - (memq type image-types) - (image-type-available-p type)) - (if (and rmail-mime-show-images - (not (eq rmail-mime-show-images 'button)) - (or (not (numberp rmail-mime-show-images)) - (< size rmail-mime-show-images))) - (setq to-show t)) - (setq type nil)))) + (when (and type + rmail-mime-show-images + (not (eq rmail-mime-show-images 'button)) + (or (not (numberp rmail-mime-show-images)) + (< size rmail-mime-show-images))) + (setq to-show t)))) (setcar bulk-data size) (setcdr bulk-data type) to-show)) diff --git a/lisp/mail/undigest.el b/lisp/mail/undigest.el index 03e77a83ce3..c6d29bc4e77 100644 --- a/lisp/mail/undigest.el +++ b/lisp/mail/undigest.el @@ -41,7 +41,8 @@ You may need to customize it for local needs." (defconst rmail-digest-methods - '(rmail-digest-parse-mime + '(rmail-digest-parse-mixed-mime + rmail-digest-parse-mime rmail-digest-parse-rfc1153strict rmail-digest-parse-rfc1153sloppy rmail-digest-parse-rfc934) @@ -52,6 +53,53 @@ A function returns nil if it cannot parse the digest. If it can, it returns a list of cons pairs containing the start and end positions of each undigestified message as markers.") +(defun rmail-content-type-boundary (type) + "If Content-type is of type TYPE, return its boundary; otherwise, return nil." + (goto-char (point-min)) + (let ((head-end (save-excursion (search-forward "\n\n" nil t) (point)))) + (when (re-search-forward + (concat "^Content-type: " type ";" + "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]") + head-end t) + (match-string 1)))) + +(defun rmail-digest-parse-mixed-mime () + "Like `rmail-digest-parse-mime', but for multipart/mixed messages." + (when-let ((boundary (rmail-content-type-boundary "multipart/mixed"))) + (let ((global-sep (concat "\n--" boundary)) + (digest (concat "^Content-type: multipart/digest;" + "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]")) + result) + (search-forward global-sep nil t) + (while (not (or result (eobp))) + ;; For each part, see if it is a multipart/digest. + (let* ((limit (save-excursion (search-forward global-sep nil 'move) + (point))) + (beg (and (re-search-forward digest limit t) + (match-beginning 0))) + digest-sep) + (when (and beg + (setq digest-sep (concat "\n--" (match-string 1))) + ;; Search for 1st sep. + (search-forward digest-sep nil t)) + ;; Skip body part headers. + (search-forward "\n\n" nil t) + ;; Push the 1st message. + (push (cons (copy-marker beg) (copy-marker (point-marker) t)) + result) + ;; Push the rest of the messages. + (let ((start (make-marker)) + done) + (while (and (search-forward digest-sep limit 'move) (not done)) + (move-marker start (match-beginning 0)) + (and (looking-at "--$") (setq done t)) + (search-forward "\n\n") + (push (cons (copy-marker start) + (copy-marker (point-marker) t)) + result)))) + (goto-char limit))) + (nreverse result)))) + (defun rmail-digest-parse-mime () (goto-char (point-min)) (when (let ((head-end (progn (search-forward "\n\n" nil t) (point)))) diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index ab64928fe76..9a3181afb8d 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -311,7 +311,7 @@ (isearch-update-ring string t) (re-search-backward string))) -;; The Edit->Search->Incremental Search menu +;; The Edit->Incremental Search menu (defvar menu-bar-i-search-menu (let ((menu (make-sparse-keymap "Incremental Search"))) (bindings--define-key menu [isearch-forward-symbol-at-point] @@ -339,12 +339,6 @@ (defvar menu-bar-search-menu (let ((menu (make-sparse-keymap "Search"))) - - (bindings--define-key menu [i-search] - `(menu-item "Incremental Search" ,menu-bar-i-search-menu)) - (bindings--define-key menu [separator-tag-isearch] - menu-bar-separator) - (bindings--define-key menu [tags-continue] '(menu-item "Continue Tags Search" fileloop-continue :enable (and (featurep 'fileloop) @@ -501,6 +495,9 @@ (bindings--define-key menu [replace] `(menu-item "Replace" ,menu-bar-replace-menu)) + (bindings--define-key menu [i-search] + `(menu-item "Incremental Search" ,menu-bar-i-search-menu)) + (bindings--define-key menu [search] `(menu-item "Search" ,menu-bar-search-menu)) @@ -606,7 +603,8 @@ "Insert the clipboard contents, or the last stretch of killed text." (interactive "*") (let ((select-enable-clipboard t) - ;; Ensure that we defeat the DWIM login in `gui-selection-value'. + ;; Ensure that we defeat the DWIM logic in `gui-selection-value' + ;; (i.e., that gui--clipboard-selection-unchanged-p returns nil). (gui--last-selected-text-clipboard nil)) (yank))) diff --git a/lisp/mh-e/mh-limit.el b/lisp/mh-e/mh-limit.el index a2ea7610139..3e731e22a1f 100644 --- a/lisp/mh-e/mh-limit.el +++ b/lisp/mh-e/mh-limit.el @@ -143,7 +143,7 @@ Use \\\\[mh-widen] to undo this command." ;;; Support Routines (defun mh-subject-to-sequence (all) - "Put all following messages with same subject in sequence 'subject. + "Put all following messages with same subject in sequence `subject'. If arg ALL is t, move to beginning of folder buffer to collect all messages. If arg ALL is nil, collect only messages from current one on forward. @@ -161,7 +161,7 @@ Return number of messages put in the sequence: (mh-subject-to-sequence-unthreaded all))) (defun mh-subject-to-sequence-threaded (all) - "Put all messages with the same subject in the 'subject sequence. + "Put all messages with the same subject in the `subject' sequence. This function works when the folder is threaded. In this situation the subject could get truncated and so the normal @@ -192,7 +192,7 @@ are taken into account." It would be desirable to avoid hard-coding this.") (defun mh-subject-to-sequence-unthreaded (all) - "Put all following messages with same subject in sequence 'subject. + "Put all following messages with same subject in sequence `subject'. This function only works with an unthreaded folder. If arg ALL is t, move to beginning of folder buffer to collect all messages. If diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index 98a20b7bb4f..d2e07977e5d 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -1764,7 +1764,7 @@ initialized. Always use the command `mh-have-file-command'.") ;;;###mh-autoload (defun mh-have-file-command () "Return t if `file' command is on the system. -'file -i' is used to get MIME type of composition insertion." +\"file -i\" is used to get MIME type of composition insertion." (when (eq mh-have-file-command 'undefined) (setq mh-have-file-command (and (executable-find "file") ; file command exists diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 36b8d808417..fb473cf71b0 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -864,7 +864,11 @@ Intended to be called via `clear-message-function'." (setq minibuffer-message-timer nil)) (when (overlayp minibuffer-message-overlay) (delete-overlay minibuffer-message-overlay) - (setq minibuffer-message-overlay nil)))) + (setq minibuffer-message-overlay nil))) + + ;; Return nil telling the caller that the message + ;; should be also handled by the caller. + nil) (setq clear-message-function 'clear-minibuffer-message) @@ -894,11 +898,23 @@ If the current buffer is not a minibuffer, erase its entire contents." (defcustom completion-auto-help t "Non-nil means automatically provide help for invalid completion input. -If the value is t the *Completions* buffer is displayed whenever completion +If the value is t, the *Completions* buffer is displayed whenever completion is requested but cannot be done. If the value is `lazy', the *Completions* buffer is only displayed after -the second failed attempt to complete." - :type '(choice (const nil) (const t) (const lazy))) +the second failed attempt to complete. +If the value is 'always', the *Completions* buffer is always shown +after a completion attempt, and the list of completions is updated if +already visible. +If the value is 'visible', the *Completions* buffer is displayed +whenever completion is requested but cannot be done for the first time, +but remains visible thereafter, and the list of completions in it is +updated for subsequent attempts to complete.." + :type '(choice (const :tag "Don't show" nil) + (const :tag "Show only when cannot complete" t) + (const :tag "Show after second failed completion attempt" lazy) + (const :tag + "Leave visible after first failed completion" visible) + (const :tag "Always visible" always))) (defvar completion-styles-alist '((emacs21 @@ -1124,6 +1140,7 @@ Moves point to the end of the new text." ;; The properties on `newtext' include things like the ;; `completions-first-difference' face, which we don't want to ;; include upon insertion. + (setq newtext (copy-sequence newtext)) ;Don't modify the arg by side-effect. (if minibuffer-allow-text-properties ;; If we're preserving properties, then just remove the faces ;; and other properties added by the completion machinery. @@ -1343,16 +1360,18 @@ when the buffer's text is already an exact match." (completion--cache-all-sorted-completions beg end comps) (minibuffer-force-complete beg end)) (completed - ;; We could also decide to refresh the completions, - ;; if they're displayed (and assuming there are - ;; completions left). - (minibuffer-hide-completions) - (if exact - ;; If completion did not put point at end of field, - ;; it's a sign that completion is not finished. - (completion--done completion - (if (< comp-pos (length completion)) - 'exact 'unknown)))) + (cond + ((pcase completion-auto-help + ('visible (get-buffer-window "*Completions*" 0)) + ('always t)) + (minibuffer-completion-help beg end)) + (t (minibuffer-hide-completions) + (when exact + ;; If completion did not put point at end of field, + ;; it's a sign that completion is not finished. + (completion--done completion + (if (< comp-pos (length completion)) + 'exact 'unknown)))))) ;; Show the completion table, if requested. ((not exact) (if (pcase completion-auto-help @@ -1396,18 +1415,26 @@ scroll the window of possible completions." ;; and this command is repeated, scroll that window. ((and (window-live-p minibuffer-scroll-window) (eq t (frame-visible-p (window-frame minibuffer-scroll-window)))) - (let ((window minibuffer-scroll-window) - (reverse (equal (this-command-keys) [backtab]))) + (let ((window minibuffer-scroll-window)) (with-current-buffer (window-buffer window) - (if (pos-visible-in-window-p (if reverse (point-min) (point-max)) window) - ;; If end or beginning is in view, scroll up to the - ;; beginning or end respectively. - (if reverse - (set-window-point window (point-max)) - (set-window-start window (point-min) nil)) - ;; Else scroll down one screen. - (with-selected-window window - (if reverse (scroll-down) (scroll-up)))) + (cond + ;; Here this is possible only when second-tab, so jump now. + (completion-auto-select + (switch-to-completions)) + ;; Reverse tab + ((equal (this-command-keys) [backtab]) + (if (pos-visible-in-window-p (point-min) window) + ;; If beginning is in view, scroll up to the end. + (set-window-point window (point-max)) + ;; Else scroll down one screen. + (with-selected-window window (scroll-down)))) + ;; Normal tab + (t + (if (pos-visible-in-window-p (point-max) window) + ;; If end is in view, scroll up to the end. + (set-window-start window (point-min) nil) + ;; Else scroll down one screen. + (with-selected-window window (scroll-up))))) nil))) ;; If we're cycling, keep on cycling. ((and completion-cycling completion-all-sorted-completions) @@ -1842,6 +1869,17 @@ Return nil if there is no valid completion, else t." This face is only used if the strings used for completions doesn't already specify a face.") +(defface completions-highlight + '((t :inherit highlight)) + "Default face for highlighting the current completion candidate." + :version "29.1") + +(defcustom completions-highlight-face 'completions-highlight + "A face name to highlight the current completion candidate. +If the value is nil, no highlighting is performed." + :type '(choice (const nil) face) + :version "29.1") + (defcustom completions-format 'horizontal "Define the appearance and sorting of completions. If the value is `vertical', display completions sorted vertically @@ -1861,6 +1899,15 @@ completions." :type 'boolean :version "28.1") +(defcustom completions-header-format + (propertize "%s possible completions:\n" 'face 'shadow) + "Format of completions header. +It may contain one %s to show the total count of completions. +When nil, no header is shown." + :type '(choice (const :tag "No header" nil) + (string :tag "Header format string")) + :version "29.1") + (defun completion--insert-strings (strings &optional group-fun) "Insert a list of STRINGS into the current buffer. The candidate strings are inserted into the buffer depending on the @@ -2000,7 +2047,8 @@ Runs of equal candidate strings are eliminated. GROUP-FUN is a (when title (insert (format completions-group-format title) "\n"))))) (completion--insert str group-fun) - (insert "\n"))))) + (insert "\n"))) + (delete-char -1))) (defun completion--insert (str group-fun) (if (not (consp str)) @@ -2012,7 +2060,7 @@ Runs of equal candidate strings are eliminated. GROUP-FUN is a (funcall group-fun str 'transform) str)) (point)) - `(mouse-face highlight completion--string ,str)) + `(mouse-face highlight cursor-face ,completions-highlight-face completion--string ,str)) ;; If `str' is a list that has 2 elements, ;; then the second element is a suffix annotation. ;; If `str' has 3 elements, then the second element @@ -2123,10 +2171,9 @@ candidates." (with-current-buffer standard-output (goto-char (point-max)) - (if (null completions) - (insert "There are no possible completions of what you have typed.") - (insert "Possible completions are:\n") - (completion--insert-strings completions group-fun)))) + (when completions-header-format + (insert (format completions-header-format (length completions)))) + (completion--insert-strings completions group-fun))) (run-hooks 'completion-setup-hook) nil) @@ -2198,6 +2245,19 @@ variables.") (equal pre-msg (and exit-fun (current-message)))) (completion--message message)))) +(defcustom completions-max-height nil + "Maximum height for *Completions* buffer window." + :type '(choice (const nil) natnum) + :version "29.1") + +(defun completions--fit-window-to-buffer (&optional win &rest _) + "Resize *Completions* buffer window." + (if temp-buffer-resize-mode + (let ((temp-buffer-max-height (or completions-max-height + temp-buffer-max-height))) + (resize-temp-buffer-window win)) + (fit-window-to-buffer win completions-max-height))) + (defun minibuffer-completion-help (&optional start end) "Display a list of possible completions of the current minibuffer contents." (interactive) @@ -2227,6 +2287,9 @@ variables.") (let* ((last (last completions)) (base-size (or (cdr last) 0)) (prefix (unless (zerop base-size) (substring string 0 base-size))) + (base-prefix (buffer-substring (minibuffer--completion-prompt-end) + (+ start base-size))) + (base-suffix (buffer-substring (point) (point-max))) (all-md (completion--metadata (buffer-substring-no-properties start (point)) base-size md @@ -2261,9 +2324,7 @@ variables.") ,(if (eq (selected-window) (minibuffer-window)) 'display-buffer-at-bottom 'display-buffer-below-selected)) - ,(if temp-buffer-resize-mode - '(window-height . resize-temp-buffer-window) - '(window-height . fit-window-to-buffer)) + (window-height . completions--fit-window-to-buffer) ,(when temp-buffer-resize-mode '(preserve-size . (nil . t))) (body-function @@ -2320,20 +2381,28 @@ variables.") ;; completion-all-completions does not give us the ;; necessary information. end)) + (setq-local completion-base-affixes + (list base-prefix base-suffix)) (setq-local completion-list-insert-choice-function (let ((ctable minibuffer-completion-table) (cpred minibuffer-completion-predicate) (cprops completion-extra-properties)) (lambda (start end choice) - (unless (or (zerop (length prefix)) - (equal prefix - (buffer-substring-no-properties - (max (point-min) - (- start (length prefix))) - start))) - (message "*Completions* out of date")) - ;; FIXME: Use `md' to do quoting&terminator here. - (completion--replace start end choice) + (if (and (stringp start) (stringp end)) + (progn + (delete-minibuffer-contents) + (insert start choice) + ;; Keep point after completion before suffix + (save-excursion (insert end))) + (unless (or (zerop (length prefix)) + (equal prefix + (buffer-substring-no-properties + (max (point-min) + (- start (length prefix))) + start))) + (message "*Completions* out of date")) + ;; FIXME: Use `md' to do quoting&terminator here. + (completion--replace start end choice)) (let* ((minibuffer-completion-table ctable) (minibuffer-completion-predicate cpred) (completion-extra-properties cprops) @@ -2354,6 +2423,7 @@ variables.") "Get rid of an out-of-date *Completions* buffer." ;; FIXME: We could/should use minibuffer-scroll-window here, but it ;; can also point to the minibuffer-parent-window, so it's a bit tricky. + (interactive) (let ((win (get-buffer-window "*Completions*" 0))) (if win (with-selected-window win (bury-buffer))))) @@ -2681,7 +2751,10 @@ The completion method is determined by `completion-at-point-functions'." "?" #'minibuffer-completion-help "" #'switch-to-completions "M-v" #'switch-to-completions - "M-g M-c" #'switch-to-completions) + "M-g M-c" #'switch-to-completions + "M-" #'minibuffer-previous-completion + "M-" #'minibuffer-next-completion + "M-RET" #'minibuffer-choose-completion) (defvar-keymap minibuffer-local-must-match-map :doc "Local keymap for minibuffer input with completion, for exact match." @@ -4033,7 +4106,7 @@ This turns into (prefix \"f\" any \"o\" any \"o\" any point) which is at the core of flex logic. The extra -'any' is optimized away later on." +`any' is optimized away later on." (mapcan (lambda (elem) (if (stringp elem) (mapcan (lambda (char) @@ -4177,6 +4250,7 @@ See `completing-read' for the meaning of the arguments." ;; override bindings in base-keymap. base-keymap))) (buffer (current-buffer)) + (c-i-c completion-ignore-case) (result (minibuffer-with-setup-hook (lambda () @@ -4186,7 +4260,9 @@ See `completing-read' for the meaning of the arguments." (setq-local minibuffer-completion-confirm (unless (eq require-match t) require-match)) (setq-local minibuffer--require-match require-match) - (setq-local minibuffer--original-buffer buffer)) + (setq-local minibuffer--original-buffer buffer) + ;; Copy the value from original buffer to the minibuffer. + (setq-local completion-ignore-case c-i-c)) (read-from-minibuffer prompt initial-input keymap nil hist def inherit-input-method)))) (when (and (equal result "") def) @@ -4271,6 +4347,66 @@ the minibuffer was activated, and execute the forms." (with-minibuffer-selected-window (scroll-other-window-down arg))) +(defmacro with-minibuffer-completions-window (&rest body) + "Execute the forms in BODY from the minibuffer in its completions window. +When used in a minibuffer window, select the window with completions, +and execute the forms." + (declare (indent 0) (debug t)) + `(let ((window (or (get-buffer-window "*Completions*" 0) + ;; Make sure we have a completions window. + (progn (minibuffer-completion-help) + (get-buffer-window "*Completions*" 0))))) + (when window + (with-selected-window window + ,@body)))) + +(defcustom minibuffer-completion-auto-choose t + "Non-nil means to automatically insert completions to the minibuffer. +When non-nil, then `minibuffer-next-completion' and +`minibuffer-previous-completion' will insert the completion +selected by these commands to the minibuffer." + :type 'boolean + :version "29.1") + +(defun minibuffer-next-completion (&optional n) + "Run `next-completion' from the minibuffer in its completions window. +When `minibuffer-completion-auto-choose' is non-nil, then also +insert the selected completion to the minibuffer." + (interactive "p") + (with-minibuffer-completions-window + (when completions-highlight-face + (setq-local cursor-face-highlight-nonselected-window t)) + (next-completion (or n 1)) + (when minibuffer-completion-auto-choose + (let ((completion-use-base-affixes t)) + (choose-completion nil t t))))) + +(defun minibuffer-previous-completion (&optional n) + "Run `previous-completion' from the minibuffer in its completions window. +When `minibuffer-completion-auto-choose' is non-nil, then also +insert the selected completion to the minibuffer." + (interactive "p") + (with-minibuffer-completions-window + (when completions-highlight-face + (setq-local cursor-face-highlight-nonselected-window t)) + (previous-completion (or n 1)) + (when minibuffer-completion-auto-choose + (let ((completion-use-base-affixes t)) + (choose-completion nil t t))))) + +(defun minibuffer-choose-completion (&optional no-exit no-quit) + "Run `choose-completion' from the minibuffer in its completions window. +With prefix argument NO-EXIT, insert the completion at point to the +minibuffer, but don't exit the minibuffer. When the prefix argument +is not provided, then whether to exit the minibuffer depends on the value +of `completion-no-auto-exit'. +If NO-QUIT is non-nil, insert the completion at point to the +minibuffer, but don't quit the completions window." + (interactive "P") + (with-minibuffer-completions-window + (let ((completion-use-base-affixes t)) + (choose-completion nil no-exit no-quit)))) + (defcustom minibuffer-default-prompt-format " (default %s)" "Format string used to output \"default\" values. When prompting for input, there will often be a default value, diff --git a/lisp/mouse.el b/lisp/mouse.el index 1e205283de2..0446bc6dd87 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -42,7 +42,9 @@ :group 'editing) (defcustom mouse-yank-at-point nil - "If non-nil, mouse yank commands yank at point instead of at click." + "If non-nil, mouse yank commands yank at point instead of at click. +This also allows yanking text into an isearch without moving the +mouse cursor to the echo area." :type 'boolean) (defcustom mouse-drag-copy-region nil @@ -97,6 +99,15 @@ point at the click position." :type 'boolean :version "22.1") +(defcustom mouse-drag-and-drop-region-scroll-margin nil + "If non-nil, the scroll margin inside a window when dragging text. +If the mouse moves this many lines close to the top or bottom of +a window while dragging text, then that window will be scrolled +down and up respectively." + :type '(choice (const :tag "Don't scroll during mouse movement") + (integer :tag "This many lines from window top or bottom")) + :version "29.1") + (defvar mouse--last-down nil) (defun mouse--down-1-maybe-follows-link (&optional _prompt) @@ -156,6 +167,17 @@ Expects to be bound to `(double-)mouse-1' in `key-translation-map'." (define-key key-translation-map [double-mouse-1] #'mouse--click-1-maybe-follows-link) +(defun mouse-double-click-time () + "Return a number for `double-click-time'. +In contrast to using the `double-click-time' variable directly, +which could be set to nil or t, this function is guaranteed to +always return a positive integer or zero." + (let ((ct double-click-time)) + (cond ((eq ct t) 10000) ; arbitrary number useful for sit-for + ((eq ct nil) 0) + ((and (numberp ct) (> ct 0)) ct) + (t 0)))) + ;; Provide a mode-specific menu on a mouse button. @@ -2974,6 +2996,11 @@ in addition, temporarily highlight the original region with the :type 'boolean :version "26.1") +(defcustom mouse-drag-and-drop-region-cross-program nil + "If non-nil, allow dragging text to other programs." + :type 'boolean + :version "29.1") + (defface mouse-drag-and-drop-region '((t :inherit region)) "Face to highlight original text during dragging. This face is used by `mouse-drag-and-drop-region' to temporarily @@ -2984,6 +3011,25 @@ highlight the original region when (declare-function rectangle-dimensions "rect" (start end)) (declare-function rectangle-position-as-coordinates "rect" (position)) (declare-function rectangle-intersect-p "rect" (pos1 size1 pos2 size2)) +(declare-function x-begin-drag "xfns.c") + +(defun mouse-drag-and-drop-region-display-tooltip (tooltip) + "Display TOOLTIP, a tooltip string, using `x-show-tip'. +Call `tooltip-show-help-non-mode' instead on non-graphical displays." + (if (display-graphic-p) + (x-show-tip tooltip) + (tooltip-show-help-non-mode tooltip))) + +(declare-function x-hide-tip "xfns.c") +(declare-function x-show-tip "xfns.c") + +(defun mouse-drag-and-drop-region-hide-tooltip () + "Hide any tooltip currently displayed. +Call `tooltip-show-help-non-mode' to clear the echo area message +instead on non-graphical displays." + (if (display-graphic-p) + (x-hide-tip) + (tooltip-show-help-non-mode nil))) (defun mouse-drag-and-drop-region (event) "Move text in the region to point where mouse is dragged to. @@ -3013,6 +3059,10 @@ is copied instead of being cut." (cdr bounds))) (region-bounds))) (region-noncontiguous (region-noncontiguous-p)) + ;; Whether or not some text was ``cut'' from Emacs to another + ;; program and the cleaanup code should not try modifying the + ;; region. + drag-was-cross-program point-to-paste point-to-paste-read-only window-to-paste @@ -3024,7 +3074,8 @@ is copied instead of being cut." value-selection ; This remains nil when event was "click". text-tooltip states - window-exempt) + window-exempt + drag-again-mouse-position) ;; STATES stores for each window on this frame its start and point ;; positions so we can restore them on all windows but for the one @@ -3046,117 +3097,235 @@ is copied instead of being cut." states)))) (ignore-errors - (track-mouse - (setq track-mouse 'dropping) - ;; When event was "click" instead of "drag", skip loop. - (while (progn - (setq event (read-key)) ; read-event or read-key - (or (mouse-movement-p event) - ;; Handle `mouse-autoselect-window'. - (memq (car event) '(select-window switch-frame)))) - ;; Obtain the dragged text in region. When the loop was - ;; skipped, value-selection remains nil. - (unless value-selection - (setq value-selection (funcall region-extract-function nil)) - (when mouse-drag-and-drop-region-show-tooltip - (let ((text-size mouse-drag-and-drop-region-show-tooltip)) - (setq text-tooltip - (if (and (integerp text-size) - (> (length value-selection) text-size)) - (concat - (substring value-selection 0 (/ text-size 2)) - "\n...\n" - (substring value-selection (- (/ text-size 2)) -1)) - value-selection)))) + (catch 'cross-program-drag + (track-mouse + (setq track-mouse (if mouse-drag-and-drop-region-cross-program + ;; When `track-mouse' is `drop', we + ;; get events with a posn-window of + ;; the grabbed frame even if some + ;; window is between that and the + ;; pointer. This makes dragging to a + ;; window on top of a frame + ;; impossible. With this value of + ;; `track-mouse', no frame is returned + ;; in that particular case. + 'drag-source + 'drop)) + ;; When event was "click" instead of "drag", skip loop. + (while (progn + (setq event (read-key)) ; read-event or read-key + (or (mouse-movement-p event) + ;; Handle `mouse-autoselect-window'. + (memq (car event) '(select-window switch-frame)))) + (catch 'drag-again + ;; If the mouse is in the drag scroll margin, scroll + ;; either up or down depending on which margin it is in. + (when mouse-drag-and-drop-region-scroll-margin + (let* ((row (cdr (posn-col-row (event-end event)))) + (window (when (windowp (posn-window (event-end event))) + (posn-window (event-end event)))) + (text-height (when window + (window-text-height window))) + ;; Make sure it's possible to scroll both up + ;; and down if the margin is too large for the + ;; window. + (margin (when text-height + (min (/ text-height 3) + mouse-drag-and-drop-region-scroll-margin)))) + (when (windowp window) + ;; At 2 lines, the window becomes too small for any + ;; meaningful scrolling. + (unless (<= text-height 2) + ;; We could end up at the beginning or end of the + ;; buffer. + (ignore-errors + (cond + ;; Inside the bottom scroll margin, scroll up. + ((> row (- text-height margin)) + (with-selected-window window + (scroll-up 1))) + ;; Inside the top scroll margin, scroll down. + ((< row margin) + (with-selected-window window + (scroll-down 1))))))))) - ;; Check if selected text is read-only. - (setq text-from-read-only - (or text-from-read-only - (catch 'loop - (dolist (bound (region-bounds)) - (when (text-property-not-all - (car bound) (cdr bound) 'read-only nil) - (throw 'loop t))))))) + ;; Obtain the dragged text in region. When the loop was + ;; skipped, value-selection remains nil. + (unless value-selection + (setq value-selection (funcall region-extract-function nil)) + (when mouse-drag-and-drop-region-show-tooltip + (let ((text-size mouse-drag-and-drop-region-show-tooltip)) + (setq text-tooltip + (if (and (integerp text-size) + (> (length value-selection) text-size)) + (concat + (substring value-selection 0 (/ text-size 2)) + "\n...\n" + (substring value-selection (- (/ text-size 2)) -1)) + value-selection)))) - (setq window-to-paste (posn-window (event-end event))) - (setq point-to-paste (posn-point (event-end event))) - ;; Set nil when target buffer is minibuffer. - (setq buffer-to-paste (let (buf) - (when (windowp window-to-paste) - (setq buf (window-buffer window-to-paste)) - (when (not (minibufferp buf)) - buf)))) - (setq cursor-in-text-area (and window-to-paste - point-to-paste - buffer-to-paste)) + ;; Check if selected text is read-only. + (setq text-from-read-only + (or text-from-read-only + (catch 'loop + (dolist (bound (region-bounds)) + (when (text-property-not-all + (car bound) (cdr bound) 'read-only nil) + (throw 'loop t))))))) - (when cursor-in-text-area - ;; Check if point under mouse is read-only. - (save-window-excursion - (select-window window-to-paste) - (setq point-to-paste-read-only - (or buffer-read-only - (get-text-property point-to-paste 'read-only)))) + (when (and mouse-drag-and-drop-region-cross-program + (display-graphic-p) + (fboundp 'x-begin-drag) + (or (and (framep (posn-window (event-end event))) + (let ((location (posn-x-y (event-end event))) + (frame (posn-window (event-end event)))) + (or (< (car location) 0) + (< (cdr location) 0) + (> (car location) + (frame-pixel-width frame)) + (> (cdr location) + (frame-pixel-height frame))))) + (and (or (not drag-again-mouse-position) + (let ((mouse-position (mouse-absolute-pixel-position))) + (or (< 5 (abs (- (car drag-again-mouse-position) + (car mouse-position)))) + (< 5 (abs (- (cdr drag-again-mouse-position) + (cdr mouse-position))))))) + (not (posn-window (event-end event)))))) + (setq drag-again-mouse-position nil) + (mouse-drag-and-drop-region-hide-tooltip) + (gui-set-selection 'XdndSelection value-selection) + (let ((drag-action-or-frame + (condition-case nil + (x-begin-drag '("UTF8_STRING" "text/plain" + "text/plain;charset=utf-8" + "STRING" "TEXT" "COMPOUND_TEXT") + (if mouse-drag-and-drop-region-cut-when-buffers-differ + 'XdndActionMove + 'XdndActionCopy) + (posn-window (event-end event)) 'now + ;; On platforms where we know + ;; `return-frame' doesn't + ;; work, allow dropping on + ;; the drop frame. + (eq window-system 'haiku)) + (quit nil)))) + (when (framep drag-action-or-frame) + ;; With some window managers `x-begin-drag' + ;; returns a frame sooner than `mouse-position' + ;; will return one, due to over-wide frame windows + ;; being drawn by the window manager. To avoid + ;; that, we just require the mouse move a few + ;; pixels before beginning another cross-program + ;; drag. + (setq drag-again-mouse-position + (mouse-absolute-pixel-position)) + (throw 'drag-again nil)) - ;; Check if "drag but negligible". Operation "drag but - ;; negligible" is defined as drag-and-drop the text to - ;; the original region. When modifier is pressed, the - ;; text will be inserted to inside of the original - ;; region. - ;; - ;; If the region is rectangular, check if the newly inserted - ;; rectangular text would intersect the already selected - ;; region. If it would, then set "drag-but-negligible" to t. - ;; As a special case, allow dragging the region freely anywhere - ;; to the left, as this will never trigger its contents to be - ;; inserted into the overlays tracking it. - (setq drag-but-negligible - (and (eq (overlay-buffer (car mouse-drag-and-drop-overlays)) - buffer-to-paste) - (if region-noncontiguous - (let ((dimensions (rectangle-dimensions start end)) - (start-coordinates - (rectangle-position-as-coordinates start)) - (point-to-paste-coordinates - (rectangle-position-as-coordinates - point-to-paste))) - (and (rectangle-intersect-p - start-coordinates dimensions - point-to-paste-coordinates dimensions) - (not (< (car point-to-paste-coordinates) - (car start-coordinates))))) - (and (<= (overlay-start - (car mouse-drag-and-drop-overlays)) - point-to-paste) - (<= point-to-paste - (overlay-end - (car mouse-drag-and-drop-overlays)))))))) + (let ((min-char (point))) + (when (eq drag-action-or-frame 'XdndActionMove) + ;; Remove the dragged text from source buffer like + ;; operation `cut'. + (dolist (overlay mouse-drag-and-drop-overlays) + (when (< min-char (min (overlay-start overlay) + (overlay-end overlay))) + (setq min-char (min (overlay-start overlay) + (overlay-end overlay)))) + (delete-region (overlay-start overlay) + (overlay-end overlay))) + (goto-char min-char) + (setq deactivate-mark t) + (setq drag-was-cross-program t))) - ;; Show a tooltip. - (if mouse-drag-and-drop-region-show-tooltip - (tooltip-show text-tooltip) - (tooltip-hide)) + (when (eq drag-action-or-frame 'XdndActionCopy) + ;; Set back the dragged text as region on source buffer + ;; like operation `copy'. + (activate-mark))) + (throw 'cross-program-drag nil)) - ;; Show cursor and highlight the original region. - (when mouse-drag-and-drop-region-show-cursor - ;; Modify cursor even when point is out of frame. - (setq cursor-type (cond - ((not cursor-in-text-area) - nil) - ((or point-to-paste-read-only - drag-but-negligible) - 'hollow) - (t - 'bar))) - (when cursor-in-text-area - (dolist (overlay mouse-drag-and-drop-overlays) - (overlay-put overlay - 'face 'mouse-drag-and-drop-region)) - (deactivate-mark) ; Maintain region in other window. - (mouse-set-point event))))) + (setq window-to-paste (posn-window (event-end event))) + (setq point-to-paste (posn-point (event-end event))) + ;; Set nil when target buffer is minibuffer. + (setq buffer-to-paste (let (buf) + (when (windowp window-to-paste) + (setq buf (window-buffer window-to-paste)) + (when (not (minibufferp buf)) + buf)))) + (setq cursor-in-text-area (and window-to-paste + point-to-paste + buffer-to-paste)) + + (when cursor-in-text-area + ;; Check if point under mouse is read-only. + (save-window-excursion + (select-window window-to-paste) + (setq point-to-paste-read-only + (or buffer-read-only + (get-text-property point-to-paste 'read-only)))) + + ;; Check if "drag but negligible". Operation "drag but + ;; negligible" is defined as drag-and-drop the text to + ;; the original region. When modifier is pressed, the + ;; text will be inserted to inside of the original + ;; region. + ;; + ;; If the region is rectangular, check if the newly inserted + ;; rectangular text would intersect the already selected + ;; region. If it would, then set "drag-but-negligible" to t. + ;; As a special case, allow dragging the region freely anywhere + ;; to the left, as this will never trigger its contents to be + ;; inserted into the overlays tracking it. + (setq drag-but-negligible + (and (eq (overlay-buffer (car mouse-drag-and-drop-overlays)) + buffer-to-paste) + (if region-noncontiguous + (let ((dimensions (rectangle-dimensions start end)) + (start-coordinates + (rectangle-position-as-coordinates start)) + (point-to-paste-coordinates + (rectangle-position-as-coordinates + point-to-paste))) + (and (rectangle-intersect-p + start-coordinates dimensions + point-to-paste-coordinates dimensions) + (not (< (car point-to-paste-coordinates) + (car start-coordinates))))) + (and (<= (overlay-start + (car mouse-drag-and-drop-overlays)) + point-to-paste) + (<= point-to-paste + (overlay-end + (car mouse-drag-and-drop-overlays)))))))) + + ;; Show a tooltip. + (if mouse-drag-and-drop-region-show-tooltip + ;; Don't use tooltip-show since it has side effects + ;; which change the text properties, and + ;; `text-tooltip' can potentially be the text which + ;; will be pasted. + (mouse-drag-and-drop-region-display-tooltip text-tooltip) + (mouse-drag-and-drop-region-hide-tooltip)) + + ;; Show cursor and highlight the original region. + (when mouse-drag-and-drop-region-show-cursor + ;; Modify cursor even when point is out of frame. + (setq cursor-type (cond + ((not cursor-in-text-area) + nil) + ((or point-to-paste-read-only + drag-but-negligible) + 'hollow) + (t + 'bar))) + (when cursor-in-text-area + (dolist (overlay mouse-drag-and-drop-overlays) + (overlay-put overlay + 'face 'mouse-drag-and-drop-region)) + (deactivate-mark) ; Maintain region in other window. + (mouse-set-point event))))))) ;; Hide a tooltip. - (when mouse-drag-and-drop-region-show-tooltip (tooltip-hide)) + (when mouse-drag-and-drop-region-show-tooltip (x-hide-tip)) ;; Check if modifier was pressed on drop. (setq no-modifier-on-drop @@ -3173,87 +3342,88 @@ is copied instead of being cut." ;; Do not modify any buffers when event is "click", ;; "drag but negligible", or "drag to read-only". - (let* ((mouse-drag-and-drop-region-cut-when-buffers-differ - (if no-modifier-on-drop - mouse-drag-and-drop-region-cut-when-buffers-differ - (not mouse-drag-and-drop-region-cut-when-buffers-differ))) - (wanna-paste-to-same-buffer (equal buffer-to-paste buffer)) - (wanna-cut-on-same-buffer (and wanna-paste-to-same-buffer - no-modifier-on-drop)) - (wanna-cut-on-other-buffer - (and (not wanna-paste-to-same-buffer) - mouse-drag-and-drop-region-cut-when-buffers-differ)) - (cannot-paste (or point-to-paste-read-only - (when (or wanna-cut-on-same-buffer - wanna-cut-on-other-buffer) - text-from-read-only)))) + (unless drag-was-cross-program + (let* ((mouse-drag-and-drop-region-cut-when-buffers-differ + (if no-modifier-on-drop + mouse-drag-and-drop-region-cut-when-buffers-differ + (not mouse-drag-and-drop-region-cut-when-buffers-differ))) + (wanna-paste-to-same-buffer (equal buffer-to-paste buffer)) + (wanna-cut-on-same-buffer (and wanna-paste-to-same-buffer + no-modifier-on-drop)) + (wanna-cut-on-other-buffer + (and (not wanna-paste-to-same-buffer) + mouse-drag-and-drop-region-cut-when-buffers-differ)) + (cannot-paste (or point-to-paste-read-only + (when (or wanna-cut-on-same-buffer + wanna-cut-on-other-buffer) + text-from-read-only)))) - (cond - ;; Move point within region. - (clicked - (deactivate-mark) - (mouse-set-point event)) - ;; Undo operation. Set back the original text as region. - ((or (and drag-but-negligible - no-modifier-on-drop) - cannot-paste) - ;; Inform user either source or destination buffer cannot be modified. - (when (and (not drag-but-negligible) - cannot-paste) - (message "Buffer is read-only")) + (cond + ;; Move point within region. + (clicked + (deactivate-mark) + (mouse-set-point event)) + ;; Undo operation. Set back the original text as region. + ((or (and drag-but-negligible + no-modifier-on-drop) + cannot-paste) + ;; Inform user either source or destination buffer cannot be modified. + (when (and (not drag-but-negligible) + cannot-paste) + (message "Buffer is read-only")) - ;; Select source window back and restore region. - ;; (set-window-point window point) - (select-window window) - (goto-char point) - (setq deactivate-mark nil) - (activate-mark) - (when region-noncontiguous - (rectangle-mark-mode))) - ;; Modify buffers. - (t - ;; * DESTINATION BUFFER:: - ;; Insert the text to destination buffer under mouse. - (select-window window-to-paste) - (setq window-exempt window-to-paste) - (goto-char point-to-paste) - (push-mark) - (insert-for-yank value-selection) - - ;; On success, set the text as region on destination buffer. - (when (not (equal (mark) (point))) + ;; Select source window back and restore region. + ;; (set-window-point window point) + (select-window window) + (goto-char point) (setq deactivate-mark nil) (activate-mark) (when region-noncontiguous (rectangle-mark-mode))) + ;; Modify buffers. + (t + ;; * DESTINATION BUFFER:: + ;; Insert the text to destination buffer under mouse. + (select-window window-to-paste) + (setq window-exempt window-to-paste) + (goto-char point-to-paste) + (push-mark) + (insert-for-yank value-selection) - ;; * SOURCE BUFFER:: - ;; Set back the original text as region or delete the original - ;; text, on source buffer. - (if wanna-paste-to-same-buffer - ;; When source buffer and destination buffer are the same, - ;; remove the original text. - (when no-modifier-on-drop - (let (deactivate-mark) + ;; On success, set the text as region on destination buffer. + (when (not (equal (mark) (point))) + (setq deactivate-mark nil) + (activate-mark) + (when region-noncontiguous + (rectangle-mark-mode))) + + ;; * SOURCE BUFFER:: + ;; Set back the original text as region or delete the original + ;; text, on source buffer. + (if wanna-paste-to-same-buffer + ;; When source buffer and destination buffer are the same, + ;; remove the original text. + (when no-modifier-on-drop + (let (deactivate-mark) + (dolist (overlay mouse-drag-and-drop-overlays) + (delete-region (overlay-start overlay) + (overlay-end overlay))))) + ;; When source buffer and destination buffer are different, + ;; keep (set back the original text as region) or remove the + ;; original text. + (select-window window) ; Select window with source buffer. + (goto-char point) ; Move point to the original text on source buffer. + + (if mouse-drag-and-drop-region-cut-when-buffers-differ + ;; Remove the dragged text from source buffer like + ;; operation `cut'. (dolist (overlay mouse-drag-and-drop-overlays) - (delete-region (overlay-start overlay) - (overlay-end overlay))))) - ;; When source buffer and destination buffer are different, - ;; keep (set back the original text as region) or remove the - ;; original text. - (select-window window) ; Select window with source buffer. - (goto-char point) ; Move point to the original text on source buffer. - - (if mouse-drag-and-drop-region-cut-when-buffers-differ - ;; Remove the dragged text from source buffer like - ;; operation `cut'. - (dolist (overlay mouse-drag-and-drop-overlays) (delete-region (overlay-start overlay) (overlay-end overlay))) - ;; Set back the dragged text as region on source buffer - ;; like operation `copy'. - (activate-mark)) - (select-window window-to-paste)))))) + ;; Set back the dragged text as region on source buffer + ;; like operation `copy'. + (activate-mark)) + (select-window window-to-paste))))))) ;; Clean up. (dolist (overlay mouse-drag-and-drop-overlays) diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index ef8527fadae..9937c022d9f 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -2554,7 +2554,7 @@ can parse the output from a DIR listing for a host of type TYPE.") FILE is the full name of the remote file, LSARGS is any args to pass to the `ls' command, and PARSE specifies that the output should be parsed and stored away in the internal cache." - (when (string-match "--" lsargs) + (while (string-match "--" lsargs) (require 'ls-lisp) (setq lsargs (ls-lisp--sanitize-switches lsargs))) ;; If parse is t, we assume that file is a directory. i.e. we only parse diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 6d28e318fff..66898d77073 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -728,9 +728,18 @@ Use variable `browse-url-filename-alist' to map filenames to URLs." browse-url-filename-alist)) (setq file (browse-url-url-encode-chars file "[*\"()',=;?% ]")) ;; Encode all other file names properly. - (setq file (mapconcat #'url-hexify-string - (file-name-split file) - "/"))) + (let ((bits (file-name-split file))) + (setq file + (string-join + ;; On Windows, the first bit here might be "c:" or the + ;; like, so don't encode the ":" in the first bit. + (cons (let ((url-unreserved-chars + (if (file-name-absolute-p file) + (cons ?: url-unreserved-chars) + url-unreserved-chars))) + (url-hexify-string (car bits))) + (mapcar #'url-hexify-string (cdr bits))) + "/")))) (dolist (map browse-url-filename-alist) (when (and map (string-match (car map) file)) (setq file (replace-match (cdr map) t nil file)))) @@ -851,7 +860,11 @@ If ARGS are omitted, the default is to pass ((featurep 'pgtk) (setq classname (pgtk-backend-display-class)) (if (equal classname "GdkWaylandDisplay") - (setenv "WAYLAND_DISPLAY" dpy) + (progn + ;; The `display' frame parameter is probably wrong. + ;; See bug#53969 for some context. + ;; (setenv "WAYLAND_DISPLAY" dpy) + ) (setenv "DISPLAY" dpy))) (t (setenv "DISPLAY" dpy))))) @@ -970,7 +983,13 @@ non-nil, or the same display as Emacs if different from the current environment, otherwise just use the current environment." (let ((display (or browse-url-browser-display (browse-url-emacs-display)))) (if display - (cons (concat "DISPLAY=" display) process-environment) + (cons (concat (if (and (eq window-system 'pgtk) + (equal (pgtk-backend-display-class) + "GdkWaylandDisplay")) + "WAYLAND_DISPLAY=" + "DISPLAY=") + display) + process-environment) process-environment))) (defun browse-url-emacs-display () diff --git a/lisp/net/dictionary-connection.el b/lisp/net/dictionary-connection.el index aef3c4efc74..a4afcd6647d 100644 --- a/lisp/net/dictionary-connection.el +++ b/lisp/net/dictionary-connection.el @@ -83,10 +83,10 @@ Return a data structure identifying the connection." "Return the status of the CONNECTION. Possible return values are the symbols: nil: argument is not a connection object - 'none: argument is not connected - 'up: connection is open and buffer is existing - 'down: connection is closed - 'alone: connection is not associated with a buffer" + `none': argument is not connected + `up': connection is open and buffer is existing + `down': connection is closed + `alone': connection is not associated with a buffer" (when (dictionary-connection-p connection) (let ((process (dictionary-connection-process connection)) (buffer (dictionary-connection-buffer connection))) diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 6a2cd13dd03..f543678fa2d 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -124,7 +124,7 @@ LABEL." (let (overlay (p (point)) prop val) - (insert label) + (insert (or label "")) (put-text-property p (point) 'face 'bold) (setq overlay (make-overlay p (point))) (overlay-put overlay 'mouse-face 'highlight) diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el index 3122b26cd81..90d89e87fba 100644 --- a/lisp/net/eudc-vars.el +++ b/lisp/net/eudc-vars.el @@ -42,7 +42,7 @@ A port number may be specified by appending a colon and a number to the name of the server. Use `localhost' if the directory server resides on your computer (BBDB backend). -To specify multiple servers, customize eudc-server-hotlist +To specify multiple servers, customize `eudc-server-hotlist' instead." :type '(choice (string :tag "Server") (const :tag "None" nil))) @@ -179,32 +179,63 @@ must be set in a protocol/server-local fashion, see `eudc-server-set' and (symbol :menu-tag "Other" :tag "Attribute name")))) :version "25.1") -;; Default to nil so that the most common use of eudc-expand-inline, -;; where replace is nil, does not affect the kill ring. -(defcustom eudc-expansion-overwrites-query nil - "If non-nil, expanding a query overwrites the query string." +(define-obsolete-variable-alias + 'eudc-expansion-overwrites-query + 'eudc-expansion-save-query-as-kill + "29.1") + +;; Default to nil so that the most common use of `eudc-expand-inline', +;; where `save-query-as-kill' is nil, does not affect the kill ring. +(defcustom eudc-expansion-save-query-as-kill nil + "If non-nil, expansion saves the query string to the kill ring." :type 'boolean :version "25.1") -(defcustom eudc-inline-expansion-format '("%s %s <%s>" firstname name email) - "A list specifying the format of the expansion of inline queries. -This variable controls what `eudc-expand-inline' actually inserts in -the buffer. First element is a string passed to `format'. Remaining -elements are symbols indicating attribute names; the corresponding values -are passed as additional arguments to `format'." - :type '(list - (string :tag "Format String") - (repeat :inline t - :tag "Attributes" - (choice - :tag "Attribute" - (const :menu-tag "First Name" :tag "First Name" firstname) - (const :menu-tag "Surname" :tag "Surname" name) - (const :menu-tag "Email Address" :tag "Email Address" email) - (const :menu-tag "Phone" :tag "Phone" phone) - (symbol :menu-tag "Other") - (symbol :tag "Attribute name")))) - :version "25.1") +(defcustom eudc-inline-expansion-format nil + "Specify the format of the expansion of inline queries. +This variable controls what `eudc-expand-inline' actually inserts +in the buffer. It is either a list, or a function. + +When set to a list, the expansion result will be formatted +according to the first element of the list, a string, which is +passed as the first argument to `format'. The remaining elements +of the list are symbols indicating attribute names; the +corresponding values are passed as additional arguments to +`format'. + +When set to nil, the expansion result will be formatted using +`eudc-rfc5322-make-address', and the PHRASE part will be +formatted according to \"firstname name\", quoting the result if +necessary. No COMMENT will be added in this case. + +When set to a function, the expansion result will be formatted +using `eudc-rfc5322-make-address', and the referenced function is +used to format the PHRASE, and COMMENT parts, respectively. It +receives a single argument, which is an alist of +protocol-specific attributes describing the recipient. To access +the alist elements using generic EUDC attribute names, such as +for example name, or email, use `eudc-translate-attribute-list'. +The function should return a list, which should contain two +elements. If the first element is a string, it will be used as +the PHRASE part, quoting it if necessary. If the second element +is a string, it will be used as the COMMENT part, unless it +contains characters not allowed in the COMMENT part by RFC 5322, +in which case the COMMENT part will be omitted." + :type '(choice (const :tag "RFC 5322 formatted \"first last
            \"" nil) + (function :tag "RFC 5322 phrase/comment formatting function") + (list :tag "Format string (deprecated)" + (string :tag "Format String") + (repeat :inline t + :tag "Attributes" + (choice + :tag "Attribute" + (const :menu-tag "First Name" :tag "First Name" firstname) + (const :menu-tag "Surname" :tag "Surname" name) + (const :menu-tag "Email Address" :tag "Email Address" email) + (const :menu-tag "Phone" :tag "Phone" phone) + (symbol :menu-tag "Other") + (symbol :tag "Attribute name"))))) + :version "29.1") (defcustom eudc-inline-expansion-servers 'server-then-hotlist "Which servers to contact for the expansion of inline queries. @@ -394,6 +425,15 @@ BBDB fields. SPECs are sexps which are evaluated: (symbol :tag "BBDB Field") (sexp :tag "Conversion Spec")))) +(defcustom eudc-ldap-no-wildcard-attributes + '(objectclass objectcategory) + "LDAP attributes which are always searched for without wildcard character. +This is the list of special dictionary-valued attributes, where +wildcarded search may fail. For example, it fails with +objectclass in Active Directory servers." + :type '(repeat (symbol :tag "Directory attribute"))) + + ;;}}} ;;{{{ BBDB Custom Group diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 6831c4ffe3d..808d2ca509c 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -162,6 +162,75 @@ Value is the new string." newtext))) (concat rtn-str (substring str start)))) + +(defconst eudc-rfc5322-atext-token "[:alpha:][:digit:]!#$%&'*+/=?^_`{|}~-" + "Printable US-ASCII characters not including specials. Used for atoms.") + +(defconst eudc-rfc5322-wsp-token " \t" + "Non-folding white space.") + +(defconst eudc-rfc5322-fwsp-token + (concat eudc-rfc5322-wsp-token "\n") + "Folding white space.") + +(defconst eudc-rfc5322-cctext-token "\u005D-\u007E\u002A-\u005B\u0021-\u0027" + "Printable US-ASCII characters not including \"(\", \")\", or \"\\\".") + +(defun eudc-rfc5322-quote-phrase (string) + "Quote STRING if it needs quoting as a phrase in a header." + (if (string-match + (concat "[^" eudc-rfc5322-wsp-token eudc-rfc5322-atext-token "]") + string) + (concat "\"" string "\"") + string)) + +(defun eudc-rfc5322-valid-comment-p (string) + "Check if STRING can be used as comment in a header." + (if (string-match + (concat "[^" eudc-rfc5322-cctext-token eudc-rfc5322-fwsp-token "]") + string) + nil + t)) + +(defun eudc-rfc5322-make-address (address &optional firstname name comment) + "Create a valid address specification according to RFC5322. +RFC5322 address specifications are used in message header fields +to indicate senders and recipients of messages. They generally +have one of the forms: + +ADDRESS +ADDRESS (COMMENT) +PHRASE
            +PHRASE
            (COMMENT) + +The arguments FIRSTNAME and NAME are combined to form PHRASE. +PHRASE is enclosed in double quotes if necessary. + +COMMENT is omitted if it contains any symbols outside the +permitted set `eudc-rfc5322-cctext-token'." + (if (and address + (not (string-blank-p address))) + (let ((result address) + (name-given (and name + (not (string-blank-p name)))) + (firstname-given (and firstname + (not (string-blank-p firstname)))) + (valid-comment-given (and comment + (not (string-blank-p comment)) + (eudc-rfc5322-valid-comment-p comment)))) + (if (or name-given firstname-given) + (let ((phrase (string-trim (concat firstname " " name)))) + (setq result + (concat + (eudc-rfc5322-quote-phrase phrase) + " <" result ">")))) + (if valid-comment-given + (setq result + (concat result " (" comment ")"))) + result) + ;; nil or empty address, nothing to return + nil)) + ;;}}} ;;{{{ Server and Protocol Variable Routines @@ -298,8 +367,8 @@ accordingly. Otherwise it is set to its EUDC default binding." ;;}}} -;; Add PROTOCOL to the list of supported protocols (defun eudc-register-protocol (protocol) + "Add PROTOCOL to the list of supported protocols." (unless (memq protocol eudc-supported-protocols) (setq eudc-supported-protocols (cons protocol eudc-supported-protocols)) @@ -741,9 +810,18 @@ If none try N - 1 and so forth." (setq n (1- n))) formats)) +;;;###autoload +(defun eudc-expand-try-all (&optional try-all-servers) + "Wrap `eudc-expand-inline' with a prefix argument. +If TRY-ALL-SERVERS -- the prefix argument when called +interactively -- is non-nil, collect results from all servers. +If TRY-ALL-SERVERS is nil, do not try subsequent servers after +one server returns any match." + (interactive "P") + (eudc-expand-inline (not eudc-expansion-save-query-as-kill) try-all-servers)) ;;;###autoload -(defun eudc-expand-inline (&optional replace) +(defun eudc-expand-inline (&optional save-query-as-kill try-all-servers) "Query the directory server, and expand the query string before point. The query string consists of the buffer substring from the point back to the preceding comma, colon or beginning of line. @@ -751,10 +829,12 @@ The variable `eudc-inline-query-format' controls how to associate the individual inline query words with directory attribute names. After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is inserted in the buffer at point. -If REPLACE is non-nil, then this expansion replaces the name in the buffer. -`eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE. +If SAVE-QUERY-AS-KILL is non-nil, then save the pre-expansion +text to the kill ring. `eudc-expansion-save-query-as-kill' being +non-nil inverts the meaning of SAVE-QUERY-AS-KILL. Multiple servers can be tried with the same query until one finds a match, -see `eudc-inline-expansion-servers'." +see `eudc-inline-expansion-servers'. If TRY-ALL-SERVERS is +non-nil, collect results from all servers." (interactive) (let* ((end (point)) (beg (save-excursion @@ -764,13 +844,13 @@ see `eudc-inline-expansion-servers'." (point))) (query-words (split-string (buffer-substring-no-properties beg end) "[ \t]+")) - (response-strings (eudc-query-with-words query-words))) + (response-strings (eudc-query-with-words query-words try-all-servers))) (if (null response-strings) (error "No match") (if (or - (and replace (not eudc-expansion-overwrites-query)) - (and (not replace) eudc-expansion-overwrites-query)) + (and save-query-as-kill (not eudc-expansion-save-query-as-kill)) + (and (not save-query-as-kill) eudc-expansion-save-query-as-kill)) (kill-ring-save beg end)) (cond ((or (= (length response-strings) 1) @@ -787,15 +867,65 @@ see `eudc-inline-expansion-servers'." (error "There is more than one match for the query")))))) ;;;###autoload -(defun eudc-query-with-words (query-words) +(defun eudc-format-inline-expansion-result (res query-attrs) + "Format a query result according to `eudc-inline-expansion-format'." + (cond + ;; format string + ((consp eudc-inline-expansion-format) + (string-trim (apply #'format + (car eudc-inline-expansion-format) + (mapcar + (lambda (field) + (or (cdr (assq field res)) + "")) + (eudc-translate-attribute-list + (cdr eudc-inline-expansion-format)))))) + + ;; formatting function + ((functionp eudc-inline-expansion-format) + (let ((addr (cdr (assq (nth 2 query-attrs) res))) + (ucontent (funcall eudc-inline-expansion-format res))) + (if (and ucontent + (listp ucontent)) + (let* ((phrase (car ucontent)) + (comment (cadr ucontent)) + (phrase-given + (and phrase + (stringp phrase) + (not (string-blank-p phrase)))) + (valid-comment-given + (and comment + (stringp comment) + (not (string-blank-p comment)) + (eudc-rfc5322-valid-comment-p + comment)))) + (eudc-rfc5322-make-address + addr nil + (if phrase-given phrase nil) + (if valid-comment-given comment nil))) + (progn + (error "Error: the function referenced by \ +`eudc-inline-expansion-format' is expected to return a list.") + nil)))) + + ;; fallback behaviour (nil function, or non-matching type) + (t + (let ((fname (cdr (assq (nth 0 query-attrs) res))) + (lname (cdr (assq (nth 1 query-attrs) res))) + (addr (cdr (assq (nth 2 query-attrs) res)))) + (eudc-rfc5322-make-address addr fname lname))))) + +;;;###autoload +(defun eudc-query-with-words (query-words &optional try-all-servers) "Query the directory server, and return the matching responses. The variable `eudc-inline-query-format' controls how to associate the individual QUERY-WORDS with directory attribute names. After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is applied to the -matches before returning them.inserted in the buffer at point. +matches before returning them. Multiple servers can be tried with the same query until one finds a match, -see `eudc-inline-expansion-servers'." +see `eudc-inline-expansion-servers'. When TRY-ALL-SERVERS is non-nil, +keep collecting results from subsequent servers after the first match." (cond ((eq eudc-inline-expansion-servers 'current-server) (or eudc-server @@ -812,6 +942,7 @@ see `eudc-inline-expansion-servers'." (error "Wrong value for `eudc-inline-expansion-servers': %S" eudc-inline-expansion-servers))) (let* (query-formats + response-strings (eudc-former-server eudc-server) (eudc-former-protocol eudc-protocol) ;; Prepare the list of servers to query @@ -823,7 +954,7 @@ see `eudc-inline-expansion-servers'." (if eudc-server (cons (cons eudc-server eudc-protocol) (delete (cons eudc-server eudc-protocol) - (copy-sequence eudc-server-hotlist))) + (copy-sequence eudc-server-hotlist))) eudc-server-hotlist)) ((eq eudc-inline-expansion-servers 'current-server) (list (cons eudc-server eudc-protocol)))))) @@ -833,46 +964,46 @@ see `eudc-inline-expansion-servers'." (setcdr (nthcdr (1- eudc-max-servers-to-query) servers) nil)) (unwind-protect - (let ((response - (catch 'found - ;; Loop on the servers - (dolist (server servers) - (eudc-set-server (car server) (cdr server) t) + (cl-flet + ((run-query + (query-formats) + (let* ((query-attrs (eudc-translate-attribute-list + (if (consp eudc-inline-expansion-format) + (cdr eudc-inline-expansion-format) + '(firstname name email)))) + (response + (eudc-query + (eudc-format-query query-words (car query-formats)) + query-attrs))) + (when response + ;; Format response. + (dolist (r response) + (let ((response-string + (eudc-format-inline-expansion-result r query-attrs))) + (if response-string + (cl-pushnew response-string response-strings + :test #'equal)))) + (when (not try-all-servers) + (throw 'found nil)))))) + (catch 'found + ;; Loop on the servers. + (dolist (server servers) + (eudc-set-server (car server) (cdr server) t) - ;; Determine which formats apply in the query-format list - (setq query-formats - (or - (eudc-extract-n-word-formats eudc-inline-query-format - (length query-words)) - (if (null eudc-protocol-has-default-query-attributes) - '(name)))) + ;; Determine which formats apply in the query-format list. + (setq query-formats + (or + (eudc-extract-n-word-formats eudc-inline-query-format + (length query-words)) + (if (null eudc-protocol-has-default-query-attributes) + '(name)))) - ;; Loop on query-formats - (while query-formats - (let ((response - (eudc-query - (eudc-format-query query-words (car query-formats)) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format))))) - (if response - (throw 'found response))) - (setq query-formats (cdr query-formats)))) - ;; No more servers to try... no match found - nil)) - (response-strings '())) - - ;; Process response through eudc-inline-expansion-format - (dolist (r response) - (let ((response-string - (apply #'format - (car eudc-inline-expansion-format) - (mapcar (lambda (field) - (or (cdr (assq field r)) - "")) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format)))))) - (if (> (length response-string) 0) - (push response-string response-strings)))) + ;; Loop on query-formats. + (while query-formats + (run-query query-formats) + (setq query-formats (cdr query-formats)))) + ;; No more servers to try... no match found. + nil) response-strings) (or (and (equal eudc-server eudc-former-server) (equal eudc-protocol eudc-former-protocol)) @@ -1052,6 +1183,8 @@ queries the server for the existing fields and displays a corresponding form." `(["---" nil nil] ["Query with Form" eudc-query-form :help "Display a form to query the directory server"] + ["Expand Inline Query Trying All Servers" eudc-expand-try-all + :help "Query all directory servers and expand the query string before point"] ["Expand Inline Query" eudc-expand-inline :help "Query the directory server, and expand the query string before point"] ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb @@ -1086,6 +1219,7 @@ queries the server for the existing fields and displays a corresponding form." :help "Set the directory server to SERVER using PROTOCOL"])) (defun eudc-menu () + "Return easy menu for EUDC." (let (command) (append '("Directory Servers") (list @@ -1117,6 +1251,7 @@ queries the server for the existing fields and displays a corresponding form." eudc-tail-menu))) (defun eudc-install-menu () + "Install EUDC menu." (define-key global-map [menu-bar tools directory-search] diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el index 365dace961a..1201c84f2d3 100644 --- a/lisp/net/eudcb-ldap.el +++ b/lisp/net/eudcb-ldap.el @@ -151,16 +151,20 @@ attribute names are returned. Default to `person'." (interactive) (or eudc-server (call-interactively 'eudc-set-server)) - (let ((ldap-host-parameters-alist - (list (cons eudc-server - '(scope subtree sizelimit 1))))) - (mapcar #'eudc-ldap-cleanup-record-filtering-addresses - (ldap-search - (eudc-ldap-format-query-as-rfc1558 - (list (cons "objectclass" - (or objectclass - "person")))) - eudc-server nil t)))) + (let ((plist (copy-sequence + (alist-get eudc-server ldap-host-parameters-alist + nil nil #'equal)))) + (plist-put plist 'scope 'subtree) + (plist-put plist 'sizelimit '1) + (let ((ldap-host-parameters-alist + (list (cons eudc-server plist)))) + (mapcar #'eudc-ldap-cleanup-record-filtering-addresses + (ldap-search + (eudc-ldap-format-query-as-rfc1558 + (list (cons 'objectclass + (or objectclass + "person")))) + eudc-server nil t))))) (defun eudc-ldap-escape-query-special-chars (string) "Value is STRING with characters forbidden in LDAP queries escaped." @@ -178,12 +182,17 @@ attribute names are returned. Default to `person'." (defun eudc-ldap-format-query-as-rfc1558 (query) "Format the EUDC QUERY list as a RFC1558 LDAP search filter." - (let ((formatter (lambda (item &optional wildcard) - (format "(%s=%s)" - (car item) - (concat - (eudc-ldap-escape-query-special-chars - (cdr item)) (if wildcard "*" "")))))) + (let ((formatter + (lambda (item &optional wildcard) + (format "(%s=%s)" + (car item) + (concat + (eudc-ldap-escape-query-special-chars + (cdr item)) + (if (and wildcard + (not (memq (car item) + eudc-ldap-no-wildcard-attributes))) + "*" "")))))) (format "(&%s)" (concat (mapconcat formatter (butlast query) "") diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 700a6c3e82f..57cb566c95d 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -311,7 +311,7 @@ parameter, and should return the (possibly) transformed URL." (defvar eww-accept-content-types "text/html, text/plain, text/sgml, text/css, application/xhtml+xml, */*;q=0.01" - "Value used for the HTTP 'Accept' header.") + "Value used for the HTTP \"Accept\" header.") (defvar-keymap eww-link-keymap :parent shr-map @@ -2053,7 +2053,9 @@ If CHARSET is nil then use UTF-8." (defun eww-write-bookmarks () (with-temp-file (expand-file-name "eww-bookmarks" eww-bookmarks-directory) (insert ";; Auto-generated file; don't edit -*- mode: lisp-data -*-\n") - (pp eww-bookmarks (current-buffer)))) + (let ((print-length nil) + (print-level nil)) + (pp eww-bookmarks (current-buffer))))) (defun eww-read-bookmarks (&optional error-out) "Read bookmarks from `eww-bookmarks'. diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index ce6c270e0bc..da45457891b 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -148,7 +148,7 @@ Valid properties include: "The name of the ldapsearch command line program." :type '(string :tag "`ldapsearch' Program")) -(defcustom ldap-ldapsearch-args '("-LL" "-tt") +(defcustom ldap-ldapsearch-args '("-LLL" "-tt") "A list of additional arguments to pass to `ldapsearch'." :type '(repeat :tag "`ldapsearch' Arguments" (string :tag "Argument"))) @@ -663,7 +663,7 @@ an alist of attribute/value pairs." (while (not (memq (process-status proc) '(exit signal))) (sit-for 0.1)) (let ((status (process-exit-status proc))) - (when (not (eq status 0)) + (when (not (memql status '(0 4))) ; 4 = Size limit exceeded ;; Handle invalid credentials exit status specially ;; for ldap-password-read. (if (eq status 49) @@ -682,7 +682,7 @@ an alist of attribute/value pairs." (while (re-search-forward (concat "[\t\n\f]+ \\|" ldap-ldapsearch-password-prompt-regexp) nil t) - (replace-match "" nil nil)) + (replace-match "")) (goto-char (point-min)) (if (looking-at "usage") @@ -691,7 +691,6 @@ an alist of attribute/value pairs." ;; Skip error message when retrieving attribute list (if (looking-at "Size limit exceeded") (forward-line 1)) - (if (looking-at "version:") (forward-line 1)) ;bug#12724. (while (progn (skip-chars-forward " \t\n") (not (eobp))) @@ -699,7 +698,7 @@ an alist of attribute/value pairs." (forward-line 1) (while (looking-at "^\\([A-Za-z][-A-Za-z0-9]*\ \\|[0-9]+\\(?:\\.[0-9]+\\)*\\)\\(;[-A-Za-z0-9]+\\)*[=:\t ]+\ -\\(<[\t ]*file://\\)\\(.*\\)$") +\\(<[\t ]*file://\\)?\\(.*\\)$") (setq name (match-string 1) value (match-string 4)) ;; Need to handle file:///D:/... as generated by OpenLDAP @@ -724,7 +723,6 @@ an alist of attribute/value pairs." (record (push (nreverse record) result))) (setq record nil) - (skip-chars-forward " \t\n") (message "Parsing results... %d" numres) (setq numres (1+ numres))) (message "Parsing results... done") diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 9d1600ed72f..0d30b349229 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -433,6 +433,20 @@ will be killed." :version "28.1" :type 'boolean) +(defcustom rcirc-cycle-completion-flag nil + "Non-nil means to use cycling for completion in rcirc buffers. +See the Info node `(emacs) Completion Options' for background on +what cycling completion means." + :version "29.1" + :set (lambda (sym val) + (dolist (buf (match-buffers '(major-mode . rcirc-mode))) + (with-current-buffer buf + (if val + (setq-local completion-cycle-threshold t) + (kill-local-variable 'completion-cycle-threshold)))) + (set-default sym val)) + :type 'boolean) + (defvar-local rcirc-nick nil "The nickname used for the current connection.") @@ -757,18 +771,26 @@ SERVER-PLIST is the property list for the server." (yes-or-no-p "Encrypt connection?")) 'tls 'plain)) +(defvar rcirc-reconnect-delay) (defun rcirc-keepalive () "Send keep alive pings to active rcirc processes. Kill processes that have not received a server message since the last ping." (if (rcirc-process-list) (mapc (lambda (process) - (with-rcirc-process-buffer process - (when (not rcirc-connecting) - (rcirc-send-ctcp process - rcirc-nick - (format "KEEPALIVE %f" - (float-time)))))) + (with-rcirc-process-buffer process + (when (not rcirc-connecting) + (condition-case nil + (rcirc-send-ctcp process + rcirc-nick + (format "KEEPALIVE %f" + (float-time))) + (rcirc-closed-connection + (if (zerop rcirc-reconnect-delay) + (message "rcirc: Connection to %s closed" + (process-name process)) + (rcirc-reconnect process)) + (message "")))))) (rcirc-process-list)) ;; no processes, clean up timer (when (timerp rcirc-keepalive-timer) @@ -1060,17 +1082,18 @@ Note that the messages are stored in reverse order.") ;; expression and `rcirc-process-regexp'. (error "Malformed tag %S" tag)) (cons (match-string 1 tag) - (replace-regexp-in-string - (rx (* ?\\ ?\\) ?\\ (any ?: ?s ?\\ ?r ?n)) - (lambda (rep) - (concat (substring rep 0 -2) - (cl-case (aref rep (1- (length rep))) - (?: ";") - (?s " ") - (?\\ "\\\\") - (?r "\r") - (?n "\n")))) - (match-string 2 tag)))) + (when (match-string 2 tag) + (replace-regexp-in-string + (rx (* ?\\ ?\\) ?\\ (any ?: ?s ?\\ ?r ?n)) + (lambda (rep) + (concat (substring rep 0 -2) + (cl-case (aref rep (1- (length rep))) + (?: ";") + (?s " ") + (?\\ "\\\\") + (?r "\r") + (?n "\n")))) + (match-string 2 tag))))) (split-string tag-data ";")))) rcirc-message-tags)) (user (match-string 3 text)) @@ -1122,6 +1145,8 @@ used as the message body." "Check if PROCESS is open or running." (memq (process-status process) '(run open))) +(define-error 'rcirc-closed-connection "Network connection not open") + (defun rcirc-send-string (process &rest parts) "Send PROCESS a PARTS plus a newline. PARTS may contain a `:' symbol, to designate that the next string @@ -1139,8 +1164,7 @@ element in PARTS is a list, append it to PARTS." rcirc-encode-coding-system) "\n"))) (unless (rcirc--connection-open-p process) - (error "Network connection to %s is not open" - (process-name process))) + (signal 'rcirc-closed-connection process)) (rcirc-debug process string) (process-send-string process string))) @@ -1434,7 +1458,8 @@ PROCESS is the process object used for communication. (add-hook 'completion-at-point-functions 'rcirc-completion-at-point nil 'local) - (setq-local completion-cycle-threshold t) + (when rcirc-cycle-completion-flag + (setq-local completion-cycle-threshold t)) (run-mode-hooks 'rcirc-mode-hook)) @@ -2592,15 +2617,22 @@ that, an interactive form can specified." (defun ,fn-name (,argument &optional process target) ,(concat documentation "\n\nNote: If PROCESS or TARGET are nil, the values given" - "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") - (interactive (list ,interactive-spec)) + "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") + (interactive ,(if (stringp interactive-spec) + ;; HACK: Necessary to wrap the result of + ;; the interactive spec in a list. + `(list (call-interactively + (lambda (&rest args) + (interactive ,interactive-spec) + args))) + `(list ,interactive-spec))) (unless (if (listp ,argument) (<= ,required (length ,argument) ,total) (string-match ,regexp ,argument)) (user-error "Malformed input (%s): %S" ',command ,argument)) (push ,(upcase (symbol-name command)) rcirc-pending-requests) (let ((process (or process (rcirc-buffer-process))) - (target (or target rcirc-target))) + (target (or target rcirc-target))) (ignore target process) (let (,@(cl-loop for i from 0 for arg in (delq '&optional arguments) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 386f1d6095d..43d34a9d4d1 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -228,6 +228,10 @@ temporarily blinks with this face." "Face for
            elements." :version "28.1") +(defface shr-code '((t :inherit fixed-pitch)) + "Face used for rendering blocks." + :version "29.1") + (defcustom shr-inhibit-images nil "If non-nil, inhibit loading images." :version "28.1" @@ -1410,7 +1414,7 @@ ones, in case fg and bg are nil." (shr-fontize-dom dom 'underline)) (defun shr-tag-code (dom) - (let ((shr-current-font 'fixed-pitch)) + (let ((shr-current-font 'shr-code)) (shr-generic dom))) (defun shr-tag-tt (dom) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index ce90943d9a6..251d5191cb2 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -159,6 +159,7 @@ It is used for TCP/IP devices." ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -168,6 +169,7 @@ It is used for TCP/IP devices." (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-adb-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . tramp-handle-process-attributes) (process-file . tramp-adb-handle-process-file) (rename-file . tramp-adb-handle-rename-file) (set-file-acl . ignore) @@ -546,28 +548,8 @@ Emacs dired can't find files." (defun tramp-adb-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (tramp-error v 'file-already-exists filename)) - - (let ((file-locked (eq (file-locked-p lockname) t)) - (curbuf (current-buffer)) - (tmpfile (tramp-compat-make-temp-file filename))) - - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) - + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (let ((tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok) (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) @@ -580,33 +562,7 @@ Emacs dired can't find files." (unless (tramp-adb-execute-adb-command v "push" tmpfile (tramp-compat-file-name-unquote localname)) (tramp-error v 'file-error "Cannot write: `%s'" filename)) - (delete-file tmpfile))) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) - - (unless (equal curbuf (current-buffer)) - (tramp-error - v 'file-error - "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) - - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime - (or (file-attribute-modification-time (file-attributes filename)) - (current-time)))) - - ;; Unlock file. - (when file-locked - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'unlock-file lockname)) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook)))) + (delete-file tmpfile)))))) (defun tramp-adb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." @@ -973,6 +929,7 @@ implementation will be used." (tramp-make-tramp-temp-file v)))) (remote-tmpstderr (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (orig-command command) (program (car command)) (args (cdr command)) (command @@ -1030,6 +987,9 @@ implementation will be used." (set-process-sentinel p sentinel)) (when filter (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property + p "remote-command" orig-command) ;; Set query flag and process marker for ;; this process. We ignore errors, because ;; the process could have finished already. @@ -1364,10 +1324,29 @@ connection if a previous connection has died for some reason." 'tramp-adb-connection-local-default-shell-profile tramp-adb-connection-local-default-shell-variables) +(defconst tramp-adb-connection-local-default-ps-variables + '((tramp-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ((user . string) + (pid . number) + (ppid . number) + (vsize . number) + (rss . number) + (wchan . string) ; ?? + (pc . string) ; ?? + (state . string) + (args . nil)))) + "Default connection-local ps variables for remote adb connections.") + +(connection-local-set-profile-variables + 'tramp-adb-connection-local-default-ps-profile + tramp-adb-connection-local-default-ps-variables) + (with-eval-after-load 'shell (connection-local-set-profiles `(:application tramp :protocol ,tramp-adb-method) - 'tramp-adb-connection-local-default-shell-profile)) + 'tramp-adb-connection-local-default-shell-profile + 'tramp-adb-connection-local-default-ps-profile)) ;; `shell-mode' tries to open remote files like "/adb::~/.history". ;; This fails, because the tilde cannot be expanded. Tell diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 788e4573679..4a020c7150f 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -267,6 +267,7 @@ It must be supported by libarchive(3).") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-archive-handle-insert-directory) (insert-file-contents . tramp-archive-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-archive-handle-load) (lock-file . ignore) (make-auto-save-file-name . ignore) @@ -276,6 +277,7 @@ It must be supported by libarchive(3).") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-archive-handle-not-implemented) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-archive-handle-not-implemented) (set-file-acl . ignore) @@ -360,21 +362,22 @@ arguments to pass to the OPERATION." (progn (defun tramp-archive-autoload-file-name-handler (operation &rest args) "Load Tramp archive file name handler, and perform OPERATION." (defvar tramp-archive-autoload) - (when tramp-archive-enabled - ;; We cannot use `tramp-compat-temporary-file-directory' here due - ;; to autoload. When installing Tramp's GNU ELPA package, there - ;; might be an older, incompatible version active. We try to - ;; overload this. - (let ((default-directory temporary-file-directory) - (tramp-archive-autoload t)) - (apply #'tramp-autoload-file-name-handler operation args))))) + (let (;; We cannot use `tramp-compat-temporary-file-directory' here + ;; due to autoload. When installing Tramp's GNU ELPA package, + ;; there might be an older, incompatible version active. We + ;; try to overload this. + (default-directory temporary-file-directory) + (tramp-archive-autoload tramp-archive-enabled)) + (apply #'tramp-autoload-file-name-handler operation args)))) (put #'tramp-archive-autoload-file-name-handler 'tramp-autoload t) ;;;###autoload (progn (defun tramp-register-archive-file-name-handler () "Add archive file name handler to `file-name-handler-alist'." - (when tramp-archive-enabled + (when (and tramp-archive-enabled + (not + (rassq #'tramp-archive-file-name-handler file-name-handler-alist))) (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index fb3ba08bb14..ca7bcf35ce4 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -209,6 +209,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-crypt-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-crypt-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -218,6 +219,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-crypt-handle-rename-file) (set-file-acl . ignore) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index d6120d2bee1..752dfdb068a 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -796,6 +796,7 @@ It has been changed in GVFS 1.14.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -805,6 +806,7 @@ It has been changed in GVFS 1.14.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-gvfs-handle-rename-file) (set-file-acl . ignore) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 3b2e7c0f916..b7f82770c40 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -303,6 +303,220 @@ NAME must be equal to `tramp-current-connection'." '(:application tramp) 'tramp-connection-local-default-shell-profile)) +;; Tested with FreeBSD 12.2. +(defconst tramp-bsd-process-attributes-ps-args + `("-acxww" + "-o" + ,(mapconcat + #'identity + '("pid" + "euid" + "user" + "egid" + "egroup" + "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + ",") + "-o" + ,(mapconcat + #'identity + '("state" + "ppid" + "pgid" + "sid" + "tty" + "tpgid" + "minflt" + "majflt" + "time" + "pri" + "nice" + "vsz" + "rss" + "etimes" + "pcpu" + "pmem" + "args") + ",")) + "List of arguments for \"ps\". +See `tramp-process-attributes-ps-args'.") + +(defconst tramp-bsd-process-attributes-ps-format + '((pid . number) + (euid . number) + (user . string) + (egid . number) + (group . string) + (comm . 52) + (state . string) + (ppid . number) + (pgrp . number) + (sess . number) + (ttname . string) + (tpgid . number) + (minflt . number) + (majflt . number) + (time . tramp-ps-time) + (pri . number) + (nice . number) + (vsize . number) + (rss . number) + (etime . number) + (pcpu . number) + (pmem . number) + (args . nil)) + "Alist of formats for \"ps\". +See `tramp-process-attributes-ps-format'.") + +(defconst tramp-connection-local-bsd-ps-variables + `((tramp-process-attributes-ps-args + . ,tramp-bsd-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ,tramp-bsd-process-attributes-ps-format)) + "Default connection-local ps variables for remote BSD connections.") + +(connection-local-set-profile-variables + 'tramp-connection-local-bsd-ps-profile + tramp-connection-local-bsd-ps-variables) + +;; Tested with BusyBox v1.24.1. +(defconst tramp-busybox-process-attributes-ps-args + `("-o" + ,(mapconcat + #'identity + '("pid" + "user" + "group" + "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + ",") + "-o" "stat=abcde" + "-o" + ,(mapconcat + #'identity + '("ppid" + "pgid" + "tty" + "time" + "nice" + "etime" + "args") + ",")) + "List of arguments for \"ps\". +See `tramp-process-attributes-ps-args'.") + +(defconst tramp-busybox-process-attributes-ps-format + '((pid . number) + (user . string) + (group . string) + (comm . 52) + (state . 5) + (ppid . number) + (pgrp . number) + (ttname . string) + (time . tramp-ps-time) + (nice . number) + (etime . tramp-ps-time) + (args . nil)) + "Alist of formats for \"ps\". +See `tramp-process-attributes-ps-format'.") + +(defconst tramp-connection-local-busybox-ps-variables + `((tramp-process-attributes-ps-args + . ,tramp-busybox-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ,tramp-busybox-process-attributes-ps-format)) + "Default connection-local ps variables for remote Busybox connections.") + +(connection-local-set-profile-variables + 'tramp-connection-local-busybox-ps-profile + tramp-connection-local-busybox-ps-variables) + +;; Darwin (macOS). +(defconst tramp-darwin-process-attributes-ps-args + `("-acxww" + "-o" + ,(mapconcat + #'identity + '("pid" + "uid" + "user" + "gid" + "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + ",") + "-o" "state=abcde" + "-o" + ,(mapconcat + #'identity + '("ppid" + "pgid" + "sess" + "tty" + "tpgid" + "minflt" + "majflt" + "time" + "pri" + "nice" + "vsz" + "rss" + "etime" + "pcpu" + "pmem" + "args") + ",")) + "List of arguments for \"ps\". +See `tramp-process-attributes-ps-args'.") + +(defconst tramp-darwin-process-attributes-ps-format + '((pid . number) + (euid . number) + (user . string) + (egid . number) + (comm . 52) + (state . 5) + (ppid . number) + (pgrp . number) + (sess . number) + (ttname . string) + (tpgid . number) + (minflt . number) + (majflt . number) + (time . tramp-ps-time) + (pri . number) + (nice . number) + (vsize . number) + (rss . number) + (etime . tramp-ps-time) + (pcpu . number) + (pmem . number) + (args . nil)) + "Alist of formats for \"ps\". +See `tramp-process-attributes-ps-format'.") + +(defconst tramp-connection-local-darwin-ps-variables + `((tramp-process-attributes-ps-args + . ,tramp-darwin-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ,tramp-darwin-process-attributes-ps-format)) + "Default connection-local ps variables for remote Darwin connections.") + +(connection-local-set-profile-variables + 'tramp-connection-local-darwin-ps-profile + tramp-connection-local-darwin-ps-variables) + +;; Preset default "ps" profile for local hosts, based on system type. + +(when-let ((local-profile + (cond ((eq system-type 'darwin) + 'tramp-connection-local-darwin-ps-profile) + ;; ... Add other system types here. + ))) + (connection-local-set-profiles + `(:application tramp :machine ,(system-name)) + local-profile) + (connection-local-set-profiles + '(:application tramp :machine "localhost") + local-profile)) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-integration 'force))) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 126b09fcbf3..bbc76851318 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -123,6 +123,7 @@ ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -132,6 +133,7 @@ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-rclone-handle-rename-file) (set-file-acl . ignore) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index c80190a67fb..ba4cdb0ab52 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1005,6 +1005,7 @@ Format specifiers \"%s\" are replaced before the script is used.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-sh-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -1014,6 +1015,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-sh-handle-make-process) (make-symbolic-link . tramp-sh-handle-make-symbolic-link) + (process-attributes . tramp-handle-process-attributes) (process-file . tramp-sh-handle-process-file) (rename-file . tramp-sh-handle-rename-file) (set-file-acl . tramp-sh-handle-set-file-acl) @@ -1203,12 +1205,18 @@ component is used as the target of the symlink." ;; The scripts could fail, for example with huge file size. (tramp-do-file-attributes-with-ls v localname id-format)))))))) +(defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11")) + "Regexp to determine remote SunOS.") + (defun tramp-sh--quoting-style-options (vec) "Quoting style options to be used for VEC." (or (tramp-get-ls-command-with vec "--quoting-style=literal --show-control-chars") - (tramp-get-ls-command-with vec "-w") + ;; ls on Solaris does not return an error in that case. We've got + ;; reports for "SunOS 5.11" so far. + (unless (tramp-check-remote-uname vec tramp-sunos-unames) + (tramp-get-ls-command-with vec "-w")) "")) (defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) @@ -2715,7 +2723,9 @@ The method used must be an out-of-band method." ;; Try to insert the amount of free space. (goto-char (point-min)) ;; First find the line to put it on. - (when (re-search-forward "^\\([[:space:]]*total\\)" nil t) + (when (and (re-search-forward "^\\([[:space:]]*total\\)" nil t) + ;; Emacs 29.1 or later. + (not (fboundp 'dired--insert-disk-space))) (when-let ((available (get-free-disk-space "."))) ;; Replace "total" with "total used", to avoid confusion. (replace-match "\\1 used in directory") @@ -2854,6 +2864,7 @@ implementation will be used." stderr (tramp-make-tramp-temp-name v))))) (remote-tmpstderr (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (orig-command command) (program (car command)) (args (cdr command)) ;; When PROGRAM matches "*sh", and the first arg is @@ -2865,8 +2876,10 @@ implementation will be used." (string-match-p "sh$" program) (= (length args) 2) (string-equal "-c" (car args)) - ;; Don't if there is a string. - (not (string-match-p "'\\|\"" (cadr args))))) + ;; Don't if there is a quoted string. + (not (string-match-p "'\\|\"" (cadr args))) + ;; Check, that /dev/tty is usable. + (tramp-get-remote-dev-tty v))) ;; When PROGRAM is nil, we just provide a tty. (args (if (not heredoc) args (let ((i 250)) @@ -3008,6 +3021,9 @@ implementation will be used." (set-process-sentinel p sentinel)) (when filter (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property + p "remote-command" orig-command) ;; Set query flag and process marker for this ;; process. We ignore errors, because the ;; process could have finished already. @@ -3312,251 +3328,197 @@ implementation will be used." (defun tramp-sh-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (tramp-error v 'file-already-exists filename)) + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (if (and (tramp-local-host-p v) + ;; `file-writable-p' calls `file-expand-file-name'. We + ;; cannot use `tramp-run-real-handler' therefore. + (file-writable-p (file-name-directory localname)) + (or (file-directory-p localname) + (file-writable-p localname))) + ;; Short track: if we are on the local host, we can run directly. + (let ((create-lockfiles (not file-locked))) + (write-region start end localname append 'no-message lockname)) - (let ((file-locked (eq (file-locked-p lockname) t)) - (uid (or (file-attribute-user-id (file-attributes filename 'integer)) - (tramp-get-remote-uid v 'integer))) - (gid (or (file-attribute-group-id (file-attributes filename 'integer)) - (tramp-get-remote-gid v 'integer)))) + (let* ((modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) + ;; We use this to save the value of + ;; `last-coding-system-used' after writing the tmp file. + ;; At the end of the function, we set + ;; `last-coding-system-used' to this saved value. This + ;; way, any intermediary coding systems used while + ;; talking to the remote shell or suchlike won't hose + ;; this variable. This approach was snarfed from + ;; ange-ftp.el. + coding-system-used + ;; Write region into a tmp file. This isn't really + ;; needed if we use an encoding function, but currently + ;; we use it always because this makes the logic simpler. + ;; We must also set `temporary-file-directory', because + ;; it could point to a remote directory. + (temporary-file-directory + tramp-compat-temporary-file-directory) + (tmpfile (or tramp-temp-buffer-file-name + (tramp-compat-make-temp-file filename)))) - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) + ;; If `append' is non-nil, we copy the file locally, and let + ;; the native `write-region' implementation do the job. + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok)) - (if (and (tramp-local-host-p v) - ;; `file-writable-p' calls `file-expand-file-name'. We - ;; cannot use `tramp-run-real-handler' therefore. - (file-writable-p (file-name-directory localname)) - (or (file-directory-p localname) - (file-writable-p localname))) - ;; Short track: if we are on the local host, we can run directly. - (let ((create-lockfiles (not file-locked))) - (write-region start end localname append 'no-message lockname)) + ;; We say `no-message' here because we don't want the visited + ;; file modtime data to be clobbered from the temp file. We + ;; call `set-visited-file-modtime' ourselves later on. We + ;; must ensure that `file-coding-system-alist' matches + ;; `tmpfile'. + (let ((file-coding-system-alist + (tramp-find-file-name-coding-system-alist filename tmpfile)) + create-lockfiles) + (condition-case err + (write-region start end tmpfile append 'no-message) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err)))) - (let* ((modes (tramp-default-file-modes - filename (and (eq mustbenew 'excl) 'nofollow))) - ;; We use this to save the value of - ;; `last-coding-system-used' after writing the tmp - ;; file. At the end of the function, we set - ;; `last-coding-system-used' to this saved value. This - ;; way, any intermediary coding systems used while - ;; talking to the remote shell or suchlike won't hose - ;; this variable. This approach was snarfed from - ;; ange-ftp.el. - coding-system-used - ;; Write region into a tmp file. This isn't really - ;; needed if we use an encoding function, but currently - ;; we use it always because this makes the logic - ;; simpler. We must also set `temporary-file-directory', - ;; because it could point to a remote directory. - (temporary-file-directory tramp-compat-temporary-file-directory) - (tmpfile (or tramp-temp-buffer-file-name - (tramp-compat-make-temp-file filename)))) + ;; Now, `last-coding-system-used' has the right value. + ;; Remember it. + (setq coding-system-used last-coding-system-used)) - ;; If `append' is non-nil, we copy the file locally, and let - ;; the native `write-region' implementation do the job. - (when (and append (file-exists-p filename)) - (copy-file filename tmpfile 'ok)) + ;; The permissions of the temporary file should be set. If + ;; FILENAME does not exist (eq modes nil) it has been renamed + ;; to the backup file. This case `save-buffer' handles + ;; permissions. Ensure that it is still readable. + (when modes + (set-file-modes tmpfile (logior (or modes 0) #o0400))) - ;; We say `no-message' here because we don't want the - ;; visited file modtime data to be clobbered from the temp - ;; file. We call `set-visited-file-modtime' ourselves later - ;; on. We must ensure that `file-coding-system-alist' - ;; matches `tmpfile'. - (let ((file-coding-system-alist - (tramp-find-file-name-coding-system-alist filename tmpfile)) - create-lockfiles) - (condition-case err - (write-region start end tmpfile append 'no-message) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Now, `last-coding-system-used' has the right value. Remember it. - (setq coding-system-used last-coding-system-used)) - - ;; The permissions of the temporary file should be set. If - ;; FILENAME does not exist (eq modes nil) it has been - ;; renamed to the backup file. This case `save-buffer' - ;; handles permissions. - ;; Ensure that it is still readable. - (when modes - (set-file-modes tmpfile (logior (or modes 0) #o0400))) - - ;; This is a bit lengthy due to the different methods - ;; possible for file transfer. First, we check whether the - ;; method uses an scp program. If so, we call it. - ;; Otherwise, both encoding and decoding command must be - ;; specified. However, if the method _also_ specifies an - ;; encoding function, then that is used for encoding the - ;; contents of the tmp file. - (let* ((size (file-attribute-size (file-attributes tmpfile))) - (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) - (loc-enc (tramp-get-inline-coding v "local-encoding" size))) - (cond - ;; `copy-file' handles direct copy and out-of-band methods. - ((or (tramp-local-host-p v) - (tramp-method-out-of-band-p v size)) - (if (and (not (stringp start)) - (= (or end (point-max)) (point-max)) - (= (or start (point-min)) (point-min)) - (tramp-get-method-parameter v 'tramp-copy-keep-tmpfile)) - (progn - (setq tramp-temp-buffer-file-name tmpfile) - (condition-case err - ;; We keep the local file for performance - ;; reasons, useful for "rsync". - (copy-file tmpfile filename t) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err))))) - (setq tramp-temp-buffer-file-name nil) - ;; Don't rename, in order to keep context in SELinux. - (unwind-protect - (copy-file tmpfile filename t) - (delete-file tmpfile)))) - - ;; Use inline file transfer. - (rem-dec - ;; Encode tmpfile. + ;; This is a bit lengthy due to the different methods possible + ;; for file transfer. First, we check whether the method uses + ;; an scp program. If so, we call it. Otherwise, both + ;; encoding and decoding command must be specified. However, + ;; if the method _also_ specifies an encoding function, then + ;; that is used for encoding the contents of the tmp file. + (let* ((size (file-attribute-size (file-attributes tmpfile))) + (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) + (loc-enc (tramp-get-inline-coding v "local-encoding" size))) + (cond + ;; `copy-file' handles direct copy and out-of-band methods. + ((or (tramp-local-host-p v) + (tramp-method-out-of-band-p v size)) + (if (and (not (stringp start)) + (= (or end (point-max)) (point-max)) + (= (or start (point-min)) (point-min)) + (tramp-get-method-parameter + v 'tramp-copy-keep-tmpfile)) + (progn + (setq tramp-temp-buffer-file-name tmpfile) + (condition-case err + ;; We keep the local file for performance + ;; reasons, useful for "rsync". + (copy-file tmpfile filename t) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err))))) + (setq tramp-temp-buffer-file-name nil) + ;; Don't rename, in order to keep context in SELinux. (unwind-protect - (with-temp-buffer - (set-buffer-multibyte nil) - ;; Use encoding function or command. - (with-tramp-progress-reporter - v 3 (format-message - "Encoding local file `%s' using `%s'" - tmpfile loc-enc) - (if (functionp loc-enc) - ;; The following `let' is a workaround for - ;; the base64.el that comes with pgnus-0.84. - ;; If both of the following conditions are - ;; satisfied, it tries to write to a local - ;; file in default-directory, but at this - ;; point, default-directory is remote. - ;; (`call-process-region' can't write to - ;; remote files, it seems.) The file in - ;; question is a tmp file anyway. - (let ((coding-system-for-read 'binary) - (default-directory - tramp-compat-temporary-file-directory)) - (insert-file-contents-literally tmpfile) - (funcall loc-enc (point-min) (point-max))) + (copy-file tmpfile filename t) + (delete-file tmpfile)))) - (unless (zerop (tramp-call-local-coding-command - loc-enc tmpfile t)) - (tramp-error - v 'file-error - (concat "Cannot write to `%s', " - "local encoding command `%s' failed") - filename loc-enc)))) + ;; Use inline file transfer. + (rem-dec + ;; Encode tmpfile. + (unwind-protect + (with-temp-buffer + (set-buffer-multibyte nil) + ;; Use encoding function or command. + (with-tramp-progress-reporter + v 3 (format-message + "Encoding local file `%s' using `%s'" + tmpfile loc-enc) + (if (functionp loc-enc) + ;; The following `let' is a workaround for the + ;; base64.el that comes with pgnus-0.84. If + ;; both of the following conditions are + ;; satisfied, it tries to write to a local + ;; file in default-directory, but at this + ;; point, default-directory is remote. + ;; (`call-process-region' can't write to + ;; remote files, it seems.) The file in + ;; question is a tmp file anyway. + (let ((coding-system-for-read 'binary) + (default-directory + tramp-compat-temporary-file-directory)) + (insert-file-contents-literally tmpfile) + (funcall loc-enc (point-min) (point-max))) - ;; Send buffer into remote decoding command which - ;; writes to remote file. Because this happens on - ;; the remote host, we cannot use the function. - (with-tramp-progress-reporter - v 3 (format-message - "Decoding remote file `%s' using `%s'" - filename rem-dec) - (goto-char (point-max)) - (unless (bolp) (newline)) - (tramp-send-command - v - (format - (concat rem-dec " <<'%s'\n%s%s") - (tramp-shell-quote-argument localname) - tramp-end-of-heredoc - (buffer-string) - tramp-end-of-heredoc)) - (tramp-barf-unless-okay - v nil - "Couldn't write region to `%s', decode using `%s' failed" - filename rem-dec) - ;; When `file-precious-flag' is set, the region is - ;; written to a temporary file. Check that the - ;; checksum is equal to that from the local tmpfile. - (when file-precious-flag - (erase-buffer) - (and - ;; cksum runs locally, if possible. - (zerop (tramp-call-process v "cksum" tmpfile t)) - ;; cksum runs remotely. - (tramp-send-command-and-check - v - (format - "cksum <%s" (tramp-shell-quote-argument localname))) - ;; ... they are different. - (not - (string-equal - (buffer-string) - (tramp-get-buffer-string (tramp-get-buffer v)))) - (tramp-error - v 'file-error - (concat "Couldn't write region to `%s'," - " decode using `%s' failed") - filename rem-dec))))) + (unless (zerop (tramp-call-local-coding-command + loc-enc tmpfile t)) + (tramp-error + v 'file-error + (concat "Cannot write to `%s', " + "local encoding command `%s' failed") + filename loc-enc)))) - ;; Save exit. - (delete-file tmpfile))) + ;; Send buffer into remote decoding command which + ;; writes to remote file. Because this happens on + ;; the remote host, we cannot use the function. + (with-tramp-progress-reporter + v 3 (format-message + "Decoding remote file `%s' using `%s'" + filename rem-dec) + (goto-char (point-max)) + (unless (bolp) (newline)) + (tramp-send-command + v + (format + (concat rem-dec " <<'%s'\n%s%s") + (tramp-shell-quote-argument localname) + tramp-end-of-heredoc + (buffer-string) + tramp-end-of-heredoc)) + (tramp-barf-unless-okay + v nil + "Couldn't write region to `%s', decode using `%s' failed" + filename rem-dec) + ;; When `file-precious-flag' is set, the region is + ;; written to a temporary file. Check that the + ;; checksum is equal to that from the local tmpfile. + (when file-precious-flag + (erase-buffer) + (and + ;; cksum runs locally, if possible. + (zerop (tramp-call-process v "cksum" tmpfile t)) + ;; cksum runs remotely. + (tramp-send-command-and-check + v + (format + "cksum <%s" + (tramp-shell-quote-argument localname))) + ;; ... they are different. + (not + (string-equal + (buffer-string) + (tramp-get-buffer-string (tramp-get-buffer v)))) + (tramp-error + v 'file-error + "Couldn't write region to `%s', decode using `%s' failed" + filename rem-dec))))) - ;; That's not expected. - (t - (tramp-error - v 'file-error - (concat "Method `%s' should specify both encoding and " - "decoding command or an scp program") - method)))) + ;; Save exit. + (delete-file tmpfile))) - ;; Make `last-coding-system-used' have the right value. - (when coding-system-used - (setq last-coding-system-used coding-system-used)))) + ;; That's not expected. + (t + (tramp-error + v 'file-error + (concat "Method `%s' should specify both encoding and " + "decoding command or an scp program") + method)))) - (tramp-flush-file-properties v localname) - - ;; We must protect `last-coding-system-used', now we have set it - ;; to its correct value. - (let (last-coding-system-used (need-chown t)) - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (let ((file-attr (file-attributes filename 'integer))) - (set-visited-file-modtime - ;; We must pass modtime explicitly, because FILENAME can - ;; be different from (buffer-file-name), f.e. if - ;; `file-precious-flag' is set. - (or (file-attribute-modification-time file-attr) - (current-time))) - (when (and (= (file-attribute-user-id file-attr) uid) - (= (file-attribute-group-id file-attr) gid)) - (setq need-chown nil)))) - - ;; Set the ownership. - (when need-chown - (tramp-set-file-uid-gid filename uid gid)) - - ;; Unlock file. - (when file-locked - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'unlock-file lockname)) - - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))))) + ;; Make `last-coding-system-used' have the right value. + (when coding-system-used + (setq last-coding-system-used coding-system-used)))))) (defvar tramp-vc-registered-file-names nil "List used to collect file names, which are checked during `vc-registered'.") @@ -4026,9 +3988,6 @@ Returns the exit code of the `test' program." switch (tramp-shell-quote-argument localname))))) -(defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11")) - "Regexp to determine remote SunOS.") - (defun tramp-find-executable (vec progname dirlist &optional ignore-tilde ignore-path) "Search for PROGNAME in $PATH and all directories mentioned in DIRLIST. @@ -4134,13 +4093,10 @@ file exists and nonzero exit status otherwise." ;; The algorithm is as follows: we try a list of several commands. ;; For each command, we first run `$cmd /' -- this should return ;; true, as the root directory always exists. And then we run - ;; `$cmd /this\ file\ does\ not\ exist ', hoping that the file indeed - ;; does not exist. This should return false. We use the first - ;; command we find that seems to work. + ;; `$cmd /\ this\ file\ does\ not\ exist\ ', hoping that the file + ;; indeed does not exist. This should return false. We use the + ;; first command we find that seems to work. ;; The list of commands to try is as follows: - ;; `ls -d' This works on most systems, but NetBSD 1.4 - ;; has a bug: `ls' always returns zero exit - ;; status, even for files which don't exist. ;; `test -e' Some Bourne shells have a `test' builtin ;; which does not know the `-e' option. ;; `/bin/test -e' For those, the `test' binary on disk normally @@ -4148,6 +4104,10 @@ file exists and nonzero exit status otherwise." ;; is sometimes `/bin/test' and sometimes it's ;; `/usr/bin/test'. ;; `/usr/bin/test -e' In case `/bin/test' does not exist. + ;; `ls -d' This works on most systems, but NetBSD 1.4 + ;; has a bug: `ls' always returns zero exit + ;; status, even for files which don't exist. + (unless (or (ignore-errors (and (setq result (format "%s -e" (tramp-get-test-command vec))) @@ -4872,7 +4832,8 @@ Goes through the list `tramp-inline-compress-commands'." "\\(illegal\\|unknown\\) option -- R" nil 'noerror))))) ;; Check, that RemoteCommand is not used. - (with-tramp-connection-property (tramp-get-process vec1) "remote-command" + (with-tramp-connection-property + (tramp-get-process vec1) "ssh-remote-command" (let ((command `("ssh" "-G" ,(tramp-file-name-host vec1)))) (with-temp-buffer (tramp-call-process @@ -4952,6 +4913,7 @@ connection if a previous connection has died for some reason." ;; If Tramp opens the same connection within a short time frame, ;; there is a problem. We shall signal this. (unless (or (process-live-p p) + (and (processp p) (not non-essential)) (not (tramp-file-name-equal-p vec (car tramp-current-connection))) (time-less-p @@ -5932,6 +5894,12 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." command)) (delete-file tmpfile))))) +(defun tramp-get-remote-dev-tty (vec) + "Check, whether remote /dev/tty is usable." + (with-tramp-connection-property vec "dev-tty" + (tramp-send-command-and-check + vec "echo = emacs-major-version 27) '(:extend t)))) "Face used for text inside various blocks. @@ -459,7 +455,7 @@ verse and quote blocks are fontified using the `org-verse' and "Face used for the line delimiting the end of source blocks." :group 'org-faces) -(defface org-verbatim '((t (:inherit (fixed-pitch shadow)))) +(defface org-verbatim '((t (:inherit shadow))) "Face for fixed-with text like code snippets." :group 'org-faces :version "22.1") diff --git a/lisp/org/org-macro.el b/lisp/org/org-macro.el index bb8a95065b3..0921f3aa27c 100644 --- a/lisp/org/org-macro.el +++ b/lisp/org/org-macro.el @@ -378,7 +378,7 @@ Return value as a string." (buffer-substring (point) (line-end-position))))) (when (cl-some #'identity time) - (setq date (encode-time time)))))))) + (setq date (apply #'encode-time time)))))))) (let ((proc (get-buffer-process buf))) (while (and proc (accept-process-output proc .5 nil t))))) (kill-buffer buf)) diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el index 6f038f026bf..bb0562dde06 100644 --- a/lisp/org/org-macs.el +++ b/lisp/org/org-macs.el @@ -37,6 +37,7 @@ (declare-function org-mode "org" ()) (declare-function org-show-context "org" (&optional key)) (declare-function org-string-collate-lessp "org-compat" (s1 s2 &optional locale ignore-case)) +(declare-function org-time-convert-to-integer "org-compat" (time)) (defvar org-ts-regexp0) (defvar ffap-url-regexp) @@ -257,15 +258,16 @@ ignored in this case." (defun org-file-newer-than-p (file time) "Non-nil if FILE is newer than TIME. -FILE is a filename, as a string, TIME is a list of integers, as +FILE is a filename, as a string, TIME is a Lisp time value, as returned by, e.g., `current-time'." (and (file-exists-p file) ;; Only compare times up to whole seconds as some file-systems ;; (e.g. HFS+) do not retain any finer granularity. As ;; a consequence, make sure we return non-nil when the two ;; times are equal. - (not (time-less-p (cl-subseq (nth 5 (file-attributes file)) 0 2) - (cl-subseq time 0 2))))) + (not (time-less-p (org-time-convert-to-integer + (nth 5 (file-attributes file))) + (org-time-convert-to-integer time))))) (defun org-compile-file (source process ext &optional err-msg log-buf spec) "Compile a SOURCE file using PROCESS. @@ -1185,7 +1187,7 @@ nil, just return 0." ((numberp s) s) ((stringp s) (condition-case nil - (float-time (encode-time (org-parse-time-string s))) + (float-time (apply #'encode-time (org-parse-time-string s))) (error 0))) (t 0))) @@ -1252,7 +1254,7 @@ following special strings: \"\", \"\", \"\", and \"\". Return 0. if S is not recognized as a valid value." - (let ((today (float-time (encode-time + (let ((today (float-time (apply #'encode-time (append '(0 0 0) (nthcdr 3 (decode-time))))))) (save-match-data (cond diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el index 8d5be425453..a590ff87f24 100644 --- a/lisp/org/org-mouse.el +++ b/lisp/org/org-mouse.el @@ -208,7 +208,7 @@ this function is called. Otherwise, the current major mode menu is used." (interactive "@e \nP") (if (and (= (event-click-count event) 1) (or (not mark-active) - (sit-for (/ double-click-time 1000.0)))) + (sit-for (/ (mouse-double-click-time) 1000.0)))) (progn (select-window (posn-window (event-start event))) (when (not (org-mouse-mark-active)) @@ -295,7 +295,7 @@ nor a function, elements of KEYWORDS are used directly." ((functionp itemformat) (funcall itemformat keyword)) ((stringp itemformat) (format itemformat keyword)) (t keyword)) - (list 'funcall function keyword) + `(funcall #',function ,keyword) :style (cond ((null selected) t) ((functionp selected) 'toggle) diff --git a/lisp/org/org-plot.el b/lisp/org/org-plot.el index bf84c99e042..4507fbe7ddc 100644 --- a/lisp/org/org-plot.el +++ b/lisp/org/org-plot.el @@ -280,7 +280,7 @@ When NORMALISE is non-nil, the count is divided by the number of values." collect (cons n (/ (length m) normaliser))))) (defun org--plot/prime-factors (value) - "Return the prime decomposition of VALUE, e.g. for 12, '(3 2 2)." + "Return the prime decomposition of VALUE, e.g. for 12, \\='(3 2 2)." (let ((factors '(1)) (i 1)) (while (/= 1 value) (setq i (1+ i)) diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 58707eae440..c301bc6af1a 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -462,14 +462,14 @@ This may be useful when columns have been shrunk." (when pos (goto-char pos)) (goto-char (line-beginning-position)) (let ((end (line-end-position)) str) - (backward-char) + (goto-char (1- pos)) (while (progn (forward-char 1) (< (point) end)) (let ((ov (car (overlays-at (point))))) (if (not ov) (push (char-to-string (char-after)) str) (push (overlay-get ov 'display) str) (goto-char (1- (overlay-end ov)))))) - (format "%s" (mapconcat #'identity (reverse str) ""))))) + (format "|%s" (mapconcat #'identity (reverse str) ""))))) (defvar-local org-table-header-overlay nil) (defun org-table-header-set-header () @@ -2606,7 +2606,7 @@ location of point." (format-time-string (org-time-stamp-format (string-match-p "[0-9]\\{1,2\\}:[0-9]\\{2\\}" ts)) - (encode-time + (apply #'encode-time (save-match-data (org-parse-time-string ts)))))) form t t)) @@ -5465,7 +5465,7 @@ The table is taken from the parameter TXT, or from the buffer at point." (nreverse table))))) (defun org-table-collapse-header (table &optional separator max-header-lines) - "Collapse the lines before 'hline into a single header. + "Collapse the lines before `hline' into a single header. The given TABLE is a list of lists as returned by `org-table-to-lisp'. The leading lines before the first `hline' symbol are considered diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el index a38b79304ef..dc689662b7d 100644 --- a/lisp/org/org-version.el +++ b/lisp/org/org-version.el @@ -5,13 +5,13 @@ (defun org-release () "The release version of Org. Inserted by installing Org mode or when a release is made." - (let ((org-release "9.5.2")) + (let ((org-release "9.5.3")) org-release)) ;;;###autoload (defun org-git-version () "The Git version of Org mode. Inserted by installing Org or when a release is made." - (let ((org-git-version "release_9.5.2-24-g668205")) + (let ((org-git-version "release_9.5.3-3-gd54104")) org-git-version)) (provide 'org-version) diff --git a/lisp/org/org.el b/lisp/org/org.el index 67c8f1cedf7..1fc4251a340 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -9,7 +9,7 @@ ;; Homepage: https://orgmode.org ;; Package-Requires: ((emacs "25.1")) -;; Version: 9.5.2 +;; Version: 9.5.3 ;; This file is part of GNU Emacs. ;; @@ -199,6 +199,7 @@ Stars are put in group 1 and the trimmed body in group 2.") (declare-function org-update-radio-target-regexp "ol" ()) (defvar org-element-paragraph-separate) +(defvar org-element--timestamp-regexp) (defvar org-indent-indentation-per-level) (defvar org-radio-target-regexp) (defvar org-target-link-regexp) @@ -13986,7 +13987,7 @@ user." (when (< (nth 2 org-defdecode) org-extend-today-until) (setf (nth 2 org-defdecode) -1) (setf (nth 1 org-defdecode) 59) - (setq org-def (encode-time org-defdecode)) + (setq org-def (apply #'encode-time org-defdecode)) (setq org-defdecode (decode-time org-def))) (let* ((timestr (format-time-string (if org-with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") @@ -14470,7 +14471,7 @@ The command returns the inserted time stamp." time (org-fix-decoded-time t1) str (org-add-props (format-time-string - (substring tf 1 -1) (encode-time time)) + (substring tf 1 -1) (apply 'encode-time time)) nil 'mouse-face 'highlight)) (put-text-property beg end 'display str))) @@ -14725,7 +14726,7 @@ days in order to avoid rounding problems." (defun org-time-string-to-time (s) "Convert timestamp string S into internal time." - (encode-time (org-parse-time-string s))) + (apply #'encode-time (org-parse-time-string s))) (defun org-time-string-to-seconds (s) "Convert a timestamp string S into a number of seconds." @@ -15011,16 +15012,24 @@ value is equivalent to `inactive'. When at a timestamp, return the position of the point as a symbol among `bracket', `after', `year', `month', `hour', `minute', `day' or a number of character from the last know part of the -time stamp. +time stamp. If diary sexp timestamps, any point inside the timestamp +is considered `day' (i.e. only `bracket', `day', and `after' return +values are possible). When matching, the match groups are the following: - group 1: year - group 2: month - group 3: day number - group 4: day name + group 1: year, if any + group 2: month, if any + group 3: day number, if any + group 4: day name, if any group 5: hours, if any group 6: minutes, if any" - (let* ((regexp (if extended org-ts-regexp3 org-ts-regexp2)) + (let* ((regexp + (if extended + (if (eq extended 'agenda) + (rx (or (regexp org-ts-regexp3) + (regexp org-element--timestamp-regexp))) + org-ts-regexp3) + org-ts-regexp2)) (pos (point)) (match? (let ((boundaries (org-in-regexp regexp))) @@ -15051,7 +15060,8 @@ When matching, the match groups are the following: ((org-pos-in-match-range pos 8) 'minute) ((or (org-pos-in-match-range pos 4) (org-pos-in-match-range pos 5)) 'day) - ((and (> pos (or (match-end 8) (match-end 5))) + ((and (or (match-end 8) (match-end 5)) + (> pos (or (match-end 8) (match-end 5))) (< pos (match-end 0))) (- pos (or (match-end 8) (match-end 5)))) (t 'day)))) @@ -15155,7 +15165,7 @@ When SUPPRESS-TMP-DELAY is non-nil, suppress delays like (setcar time0 (or (car time0) 0)) (setcar (nthcdr 1 time0) (or (nth 1 time0) 0)) (setcar (nthcdr 2 time0) (or (nth 2 time0) 0)) - (setq time (encode-time time0)))) + (setq time (apply 'encode-time time0)))) ;; Insert the new time-stamp, and ensure point stays in the same ;; category as before (i.e. not after the last position in that ;; category). diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el index 5de0b5d675c..9cf9125aebd 100644 --- a/lisp/org/ox-html.el +++ b/lisp/org/ox-html.el @@ -442,7 +442,7 @@ property on the headline itself.") { font-size: 10px; font-weight: bold; white-space: nowrap; } .org-info-js_search-highlight { background-color: #ffff00; color: #000000; font-weight: bold; } - .org-svg { width: 90%; } + .org-svg { } " "The default style specification for exported HTML files. You can use `org-html-head' and `org-html-head-extra' to add to @@ -2909,7 +2909,7 @@ Starred and \"displaymath\" environments are not numbered." (defun org-html--unlabel-latex-environment (latex-frag) "Change environment in LATEX-FRAG string to an unnumbered one. -For instance, change an 'equation' environment to 'equation*'." +For instance, change an `equation' environment to `equation*'." (replace-regexp-in-string "\\`[ \t]*\\\\begin{\\([^*]+?\\)}" "\\1*" diff --git a/lisp/org/ox-publish.el b/lisp/org/ox-publish.el index 636bd0d2ae3..51e2352b4e8 100644 --- a/lisp/org/ox-publish.el +++ b/lisp/org/ox-publish.el @@ -839,7 +839,7 @@ in `org-export-options-alist' or in export back-ends. In the latter case, optional argument BACKEND has to be set to the back-end where the option is defined, e.g., - (org-publish-find-property file :subtitle 'latex) + (org-publish-find-property file :subtitle \\='latex) Return value may be a string or a list, depending on the type of PROPERTY, i.e. \"behavior\" parameter from `org-export-options-alist'." diff --git a/lisp/outline.el b/lisp/outline.el index 696d109f1ee..7fd43195cc0 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -178,13 +178,22 @@ in the file it applies to.") map)) (defcustom outline-minor-mode-cycle-filter nil - "Filter out positions on the heading available for cycling." + "Control where on a heading the visibility-cycling commands are bound to keys. +This option controls, in Outline minor mode, where on a heading typing +the key sequences bound to visibility-cycling commands like `outline-cycle' +and `outline-cycle-buffer' will invoke those commands. By default, you can +invoke these commands by typing `TAB' and `S-TAB' anywhere on a heading line, +but customizing this option can make those bindings be in effect only at +specific positions on the heading, like only at the line's beginning or +line's end. This allows these keys to be bound to their usual commands, +as determined by the major mode, elsewhere on the heading lines. +This option is only in effect when `outline-minor-mode-cycle' is non-nil." :type '(choice (const :tag "Everywhere" nil) (const :tag "At line beginning" bolp) (const :tag "Not at line beginning" (lambda () (not (bolp)))) (const :tag "At line end" eolp) - (function :tag "Custom filter")) + (function :tag "Custom filter function")) :version "28.1") (defvar outline-minor-mode-cycle) @@ -371,28 +380,33 @@ After that, changing the prefix key requires manipulating keymaps." (set-default sym val))) (defcustom outline-minor-mode-cycle nil - "Enable cycling of headings in `outline-minor-mode'. -When enabled, it puts a keymap with cycling keys on heading lines. -When point is on a heading line, then typing `TAB' cycles between `hide all', -`headings only' and `show all' (`outline-cycle'). Typing `S-TAB' on -a heading line cycles the whole buffer (`outline-cycle-buffer'). -Typing these keys anywhere outside heading lines uses their default bindings." + "Enable visibility-cycling commands on headings in `outline-minor-mode'. +If enabled, typing `TAB' on a heading line cycles the visibility +state of that heading's body between `hide all', `headings only' +and `show all' (`outline-cycle'), and typing `S-TAB' on a heading +line likewise cycles the visibility state of the whole buffer +\(`outline-cycle-buffer'). +Typing these keys anywhere outside heading lines invokes their default +bindings, per the current major mode." :type 'boolean :safe #'booleanp :version "28.1") (defcustom outline-minor-mode-highlight nil - "Highlight headings in `outline-minor-mode' using font-lock keywords. -Non-nil value works well only when outline font-lock keywords -don't conflict with the major mode's font-lock keywords. -When t, it puts outline faces only if there are no major mode's faces -on headings. When `override', it completely overwrites major mode's -faces with outline faces. When `append', it tries to append outline -faces to major mode's faces." - :type '(choice (const :tag "No highlighting" nil) - (const :tag "Overwrite major mode faces" override) - (const :tag "Append outline faces to major mode faces" append) - (const :tag "Highlight separately from major mode faces" t)) + "Whether to highlight headings in `outline-minor-mode' using font-lock keywords. +This option controles whether `outline-minor-mode' will use its font-lock +keywords to highlight headings, which could potentially conflict with +font-lock faces defined by the major mode. Thus, a non-nil value will +work well only when there's no such conflict. +If the value is t, use outline faces only if there are no major mode's +font-lock faces on headings. When `override', completely overwrite major +mode's font-lock faces with outline faces. When `append', try to append +outline font-lock faces to those of major mode." + :type '(choice (const :tag "Do not use outline font-lock highlighting" nil) + (const :tag "Overwrite major mode font-lock faces" override) + (const :tag "Append outline font-lock faces to major mode's" + append) + (const :tag "Highlight with outline font-lock faces only if major mode doesn't" t)) :safe #'symbolp :version "28.1") @@ -1488,7 +1502,7 @@ LEVEL, decides of subtree visibility according to (defun outline--cycle-state () "Return the cycle state of current heading. -Return either 'hide-all, 'headings-only, or 'show-all." +Return either `hide-all', `headings-only', or `show-all'." (save-excursion (let (start end ov-list heading-end) (outline-back-to-heading) @@ -1521,11 +1535,14 @@ Return either 'hide-all, 'headings-only, or 'show-all." (save-excursion (outline-end-of-subtree) (point))))) (defun outline-cycle () - "Cycle between `hide all', `headings only' and `show all'. + "Cycle visibility state of the current heading line's body. -`Hide all' means hide all subheadings and their bodies. -`Headings only' means show sub headings but not their bodies. -`Show all' means show all subheadings and their bodies." +This cycles the visibility of the current heading line's subheadings +and body between `hide all', `headings only' and `show all'. + +`Hide all' means hide all the subheadings and their bodies. +`Headings only' means show the subheadings, but not their bodies. +`Show all' means show all the subheadings and their bodies." (interactive) (condition-case nil (pcase (outline--cycle-state) @@ -1547,7 +1564,15 @@ Return either 'hide-all, 'headings-only, or 'show-all." "Internal variable used for tracking buffer cycle state.") (defun outline-cycle-buffer () - "Cycle the whole buffer like in `outline-cycle'." + "Cycle visibility state of the body lines of the whole buffer. + +This cycles the visibility of all the subheadings and bodies of all +the heading lines in the buffer. It cycles them between `hide all', +`headings only' and `show all'. + +`Hide all' means hide all the buffer's subheadings and their bodies. +`Headings only' means show all the subheadings, but not their bodies. +`Show all' means show all the buffer's subheadings and their bodies." (interactive) (let (has-top-level) (save-excursion diff --git a/lisp/paren.el b/lisp/paren.el index 4e67a4ea4f7..4c268dbf771 100644 --- a/lisp/paren.el +++ b/lisp/paren.el @@ -225,6 +225,13 @@ It is the default value of `show-paren-data-function'." (let* ((temp (show-paren--locate-near-paren)) (dir (car temp)) (outside (cdr temp)) + ;; If we're inside a comment, then we probably want to blink + ;; a matching parentheses in the comment. So don't ignore + ;; comments in that case. + (parse-sexp-ignore-comments + (if (ppss-comment-depth (syntax-ppss)) + nil + parse-sexp-ignore-comments)) pos mismatch here-beg here-end) ;; ;; Find the other end of the sexp. diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 289312e0bbc..a1492af89d2 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -189,6 +189,16 @@ and how is entirely up to the behavior of the `pcomplete-parse-arguments-function'." :type 'boolean) +(defvar pcomplete-allow-modifications nil + "If non-nil, allow effects in `pcomplete-parse-arguments-function'. +For the `pcomplete' command, it was common for functions in +`pcomplete-parse-arguments-function' to make modifications to the +buffer, like expanding variables are such. +For `completion-at-point-functions', this is not an option any more, so +this variable is used to tell `pcomplete-parse-arguments-function' +whether it can do the modifications like it used to, or whether +it should refrain from doing so.") + (defcustom pcomplete-parse-arguments-function #'pcomplete-parse-buffer-arguments "A function to call to parse the current line's arguments. @@ -392,6 +402,9 @@ Same as `pcomplete' but using the standard completion UI." ;; imposing the pcomplete UI over the standard UI. (catch 'pcompleted (let* ((pcomplete-stub) + (buffer-read-only + ;; Make sure the function obeys `pcomplete-allow-modifications'. + (if pcomplete-allow-modifications buffer-read-only t)) pcomplete-seen pcomplete-norm-func pcomplete-args pcomplete-last pcomplete-index (pcomplete-autolist pcomplete-autolist) @@ -526,6 +539,7 @@ completion functions list (it should occur fairly early in the list)." pcomplete-last-completion-raw nil) (catch 'pcompleted (let* ((pcomplete-stub) + (pcomplete-allow-modifications t) pcomplete-seen pcomplete-norm-func pcomplete-args pcomplete-last pcomplete-index (pcomplete-autolist pcomplete-autolist) @@ -551,7 +565,8 @@ completion functions list (it should occur fairly early in the list)." "Expand the textual value of the current argument. This will modify the current buffer." (interactive) - (let ((pcomplete-expand-before-complete t)) + (let ((pcomplete-expand-before-complete t) + (pcomplete-allow-modifications t)) (with-suppressed-warnings ((obsolete pcomplete)) (pcomplete)))) @@ -569,6 +584,7 @@ This will modify the current buffer." This will modify the current buffer." (interactive) (let ((pcomplete-expand-before-complete t) + (pcomplete-allow-modifications t) (pcomplete-expand-only-p t)) (with-suppressed-warnings ((obsolete pcomplete)) (pcomplete)) diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index bfe48ef1f90..b0fe2f56c03 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -90,6 +90,7 @@ (require 'mwheel) (require 'subr-x) (require 'ring) +(require 'cua-base) (defvar pixel-wait 0 "Idle time on each step of pixel scroll specified in second. @@ -213,6 +214,14 @@ This is only effective when `pixel-scroll-precision-mode' is enabled." :type 'boolean :version "29.1") +(defcustom pixel-scroll-precision-interpolate-mice t + "Whether or not to interpolate scrolling from a mouse. +If non-nil, scrolling from the mouse wheel of an actual mouse (as +opposed to a touchpad) will cause Emacs to interpolate the scroll." + :group 'scrolling + :type 'boolean + :version "29.1") + (defun pixel-scroll-in-rush-p () "Return non-nil if next scroll should be non-smooth. When scrolling request is delivered soon after the previous one, @@ -680,16 +689,20 @@ wheel." (if (> (abs delta) (window-text-height window t)) (mwheel-scroll event nil) (with-selected-window window - (if (and pixel-scroll-precision-large-scroll-height - (> (abs delta) - pixel-scroll-precision-large-scroll-height) - (let* ((kin-state (pixel-scroll-kinetic-state)) - (ring (aref kin-state 0)) - (time (aref kin-state 1))) - (or (null time) - (> (- (float-time) time) 1.0) - (and (consp ring) - (ring-empty-p ring))))) + (if (or (and pixel-scroll-precision-interpolate-mice + (eq (device-class last-event-frame + last-event-device) + 'mouse)) + (and pixel-scroll-precision-large-scroll-height + (> (abs delta) + pixel-scroll-precision-large-scroll-height) + (let* ((kin-state (pixel-scroll-kinetic-state)) + (ring (aref kin-state 0)) + (time (aref kin-state 1))) + (or (null time) + (> (- (float-time) time) 1.0) + (and (consp ring) + (ring-empty-p ring)))))) (progn (let ((kin-state (pixel-scroll-kinetic-state))) (aset kin-state 0 (make-ring 30)) @@ -803,14 +816,14 @@ It is a vector of the form [ VELOCITY TIME SIGN ]." (interactive) (if pixel-scroll-precision-interpolate-page (pixel-scroll-precision-interpolate (- (window-text-height nil t))) - (scroll-up))) + (cua-scroll-up))) (defun pixel-scroll-interpolate-up () "Interpolate a scroll upwards by one page." (interactive) (if pixel-scroll-precision-interpolate-page (pixel-scroll-precision-interpolate (window-text-height nil t)) - (scroll-down))) + (cua-scroll-down))) ;;;###autoload (define-minor-mode pixel-scroll-precision-mode diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el index 7f821bf4cf4..bb3369de5fc 100644 --- a/lisp/play/decipher.el +++ b/lisp/play/decipher.el @@ -978,13 +978,14 @@ if it can't, it signals an error." decipher-stats-buffer) ;; Create a new buffer if requested: (create - (let ((stats-name (concat "*" (buffer-name) "*"))) + (let* ((stats-name (concat "*" (buffer-name) "*")) + (buf (get-buffer stats-name))) (setq decipher-stats-buffer - (if (eq 'decipher-stats-mode - (buffer-local-value 'major-mode - (get-buffer stats-name))) - ;; We just lost track of the statistics buffer: - (get-buffer stats-name) + (if (and (bufferp buf) + (eq 'decipher-stats-mode + (buffer-local-value 'major-mode buf))) + buf + ;; We just lost track of the statistics buffer: (generate-new-buffer stats-name)))) (with-current-buffer decipher-stats-buffer (decipher-stats-mode)) diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el index 07f27374df7..b859176bb47 100644 --- a/lisp/play/dunnet.el +++ b/lisp/play/dunnet.el @@ -898,7 +898,7 @@ Regular objects have whole numbers lower than 255. Objects that cannot be taken but might move and are described during room description are negative. Stuff that is described and might change are 255, and are -handled specially by 'dun-describe-room.") +handled specially by `dun-describe-room'.") (defconst dun-room-silents (list nil (list obj-tree obj-coconut) ;; dead-end diff --git a/lisp/proced.el b/lisp/proced.el index c1d599afc4a..a27638d3679 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -29,10 +29,6 @@ ;; ;; To do: ;; - Interactive temporary customizability of flags in `proced-grammar-alist' -;; - Allow "sudo kill PID", "sudo renice PID" -;; `proced-send-signal' operates on multiple processes one by one. -;; With "sudo" we want to execute one "kill" or "renice" command -;; for all marked processes. Is there a `sudo-call-process'? ;; ;; Thoughts and Ideas ;; - Currently, `process-attributes' returns the list of @@ -55,12 +51,19 @@ :group 'unix :prefix "proced-") +(defcustom proced-show-remote-processes nil + "Whether processes of the remote host shall be shown. +This happens only when `default-directory' is remote." + :version "29.1" + :type 'boolean) + (defcustom proced-signal-function #'signal-process "Name of signal function. It can be an elisp function (usually `signal-process') or a string specifying the external command (usually \"kill\")." :type '(choice (function :tag "function") (string :tag "command"))) +(make-obsolete-variable 'proced-signal-function "no longer used." "29.1") (defcustom proced-renice-command "renice" "Name of renice command." @@ -275,8 +278,8 @@ It can also be a list of keys appearing in `proced-grammar-alist'." ;; FIXME: is there a better name for filter `user' that does not coincide ;; with an attribute key? (defcustom proced-filter-alist - `((user (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'"))) - (user-running (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'")) + `((user (user . proced-user-name)) + (user-running (user . proced-user-name) (state . "\\`[Rr]\\'")) (all) (all-running (state . "\\`[Rr]\\'")) @@ -366,7 +369,7 @@ May be used to revert the process listing." ;; Internal variables -(defvar proced-available (not (null (list-system-processes))) +(defvar proced-available t;(not (null (list-system-processes))) "Non-nil means Proced is known to work on this system.") (defvar-local proced-process-alist nil @@ -565,6 +568,12 @@ Important: the match ends just after the marker.") :help "Renice Marked Processes"])) ;; helper functions +(defun proced-user-name (user) + "Check the `user' attribute with user name `proced' is running for." + (string-equal user (if (file-remote-p default-directory) + (file-remote-p default-directory 'user) + (user-real-login-name)))) + (defun proced-marker-regexp () "Return regexp matching `proced-marker-char'." ;; `proced-marker-char' must appear in column zero @@ -626,6 +635,7 @@ Return nil if point is not on a process line." Type \\[proced] to start a Proced session. In a Proced buffer type \\\\[proced-mark] to mark a process for later commands. Type \\[proced-send-signal] to send signals to marked processes. +Type \\[proced-renice] to renice marked processes. The initial content of a listing is defined by the variable `proced-filter' and the variable `proced-format'. @@ -677,8 +687,13 @@ After displaying or updating a Proced buffer, Proced runs the normal hook (defun proced (&optional arg) "Generate a listing of UNIX system processes. \\ -If invoked with optional ARG, do not select the window displaying -the process information. +If invoked with optional non-negative ARG, do not select the +window displaying the process information. + +If `proced-show-remote-processes' is non-nil or the command is +invoked with a negative ARG `\\[universal-argument] \\[negative-argument]', \ +and `default-directory' +points to a remote host, the system processes of that host are shown. This function runs the normal hook `proced-post-display-hook'. @@ -689,6 +704,11 @@ Proced buffers." (error "Proced is not available on this system")) (let ((buffer (get-buffer-create "*Proced*")) new) (set-buffer buffer) + (when (and (file-remote-p default-directory) + (not + (or proced-show-remote-processes + (eq arg '-)))) + (setq default-directory temporary-file-directory)) (setq new (zerop (buffer-size))) (when new (proced-mode) @@ -1406,7 +1426,7 @@ Replace newline characters by \"^J\" (two characters)." ;; If none of the alternatives is non-nil, the attribute is ignored ;; in the listing. (let ((standard-attributes - (car (proced-process-attributes (list (emacs-pid))))) + (car (proced-process-attributes (list-system-processes)))) new-format fmi) (if (and proced-tree-flag (assq 'ppid standard-attributes)) @@ -1821,7 +1841,8 @@ supported but discouraged. It will be removed in a future version of Emacs." (dolist (process process-alist) (condition-case err (unless (zerop (funcall - proced-signal-function (car process) signal)) + proced-signal-function (car process) signal + (file-remote-p default-directory))) (proced-log "%s\n" (cdr process)) (push (cdr process) failures)) (error ; catch errors from failed signals @@ -1833,7 +1854,7 @@ supported but discouraged. It will be removed in a future version of Emacs." (dolist (process process-alist) (with-temp-buffer (condition-case nil - (unless (zerop (call-process + (unless (zerop (process-file proced-signal-function nil t nil signal (number-to-string (car process)))) (proced-log (current-buffer)) @@ -1875,7 +1896,7 @@ the normal hook `proced-after-send-signal-hook'." (dolist (process process-alist) (with-temp-buffer (condition-case nil - (unless (zerop (call-process + (unless (zerop (process-file proced-renice-command nil t nil priority (number-to-string (car process)))) (proced-log (current-buffer)) diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el index 8298d5fef04..e14f5b9058f 100644 --- a/lisp/progmodes/cc-align.el +++ b/lisp/progmodes/cc-align.el @@ -202,6 +202,58 @@ Works with: arglist-cont-nonempty, arglist-close." (skip-chars-forward " \t")) (vector (current-column))))))) +(defun c-lineup-argcont-1 (elem) + ;; Move to the start of the current arg and return non-nil, otherwise + ;; return nil. + (beginning-of-line) + + (when (eq (car elem) 'arglist-cont-nonempty) + ;; Our argument list might not be the innermost one. If it + ;; isn't, go back to the first position in it. We do this by + ;; stepping back over open parens until we get to the open paren + ;; of our argument list. + (let ((open-paren (c-langelem-2nd-pos c-syntactic-element)) + (paren-state (c-parse-state))) + (while (not (eq (car paren-state) open-paren)) + (unless (consp (car paren-state)) ;; ignore matched braces + (goto-char (car paren-state))) + (setq paren-state (cdr paren-state))))) + + (let ((start (point)) c) + + (when (bolp) + ;; Previous line ending in a comma means we're the start of an + ;; argument. This should quickly catch most cases not for us. + ;; This case is only applicable if we're the innermost arglist. + (c-backward-syntactic-ws) + (setq c (char-before))) + + (unless (eq c ?,) + ;; In a gcc asm, ":" on the previous line means the start of an + ;; argument. And lines starting with ":" are not for us, don't + ;; want them to indent to the preceding operand. + (let ((gcc-asm (save-excursion + (goto-char start) + (c-in-gcc-asm-p)))) + (unless (and gcc-asm + (or (eq c ?:) + (save-excursion + (goto-char start) + (looking-at "[ \t]*:")))) + + (c-lineup-argcont-scan (if gcc-asm ?:)) + t))))) + +(defun c-lineup-argcont-scan (&optional other-match) + ;; Find the start of an argument, for `c-lineup-argcont'. + (when (zerop (c-backward-token-2 1 t)) + (let ((c (char-after))) + (if (or (eq c ?,) (eq c other-match)) + (progn + (forward-char) + (c-forward-syntactic-ws)) + (c-lineup-argcont-scan other-match))))) + ;; Contributed by Kevin Ryde . (defun c-lineup-argcont (elem) "Line up a continued argument. @@ -217,56 +269,30 @@ but of course only between operand specifications, not in the expressions for the operands. Works with: arglist-cont, arglist-cont-nonempty." - (save-excursion - (beginning-of-line) + (when (c-lineup-argcont-1 elem) + (vector (current-column))))) - (when (eq (car elem) 'arglist-cont-nonempty) - ;; Our argument list might not be the innermost one. If it - ;; isn't, go back to the last position in it. We do this by - ;; stepping back over open parens until we get to the open paren - ;; of our argument list. - (let ((open-paren (c-langelem-2nd-pos c-syntactic-element)) - (paren-state (c-parse-state))) - (while (not (eq (car paren-state) open-paren)) - (unless (consp (car paren-state)) ;; ignore matched braces - (goto-char (car paren-state))) - (setq paren-state (cdr paren-state))))) +(defun c-lineup-argcont-+ (langelem) + "Indent an argument continuation `c-basic-offset' in from the first argument. - (let ((start (point)) c) +This first argument is that on a previous line at the same level of nesting. - (when (bolp) - ;; Previous line ending in a comma means we're the start of an - ;; argument. This should quickly catch most cases not for us. - ;; This case is only applicable if we're the innermost arglist. - (c-backward-syntactic-ws) - (setq c (char-before))) +foo (xyz, uvw, aaa + bbb + ccc + + ddd + eee + fff); <- c-lineup-argcont-+ + <--> c-basic-offset - (unless (eq c ?,) - ;; In a gcc asm, ":" on the previous line means the start of an - ;; argument. And lines starting with ":" are not for us, don't - ;; want them to indent to the preceding operand. - (let ((gcc-asm (save-excursion - (goto-char start) - (c-in-gcc-asm-p)))) - (unless (and gcc-asm - (or (eq c ?:) - (save-excursion - (goto-char start) - (looking-at "[ \t]*:")))) +Only continuation lines like this are touched, nil being returned +on lines which are the start of an argument. - (c-lineup-argcont-scan (if gcc-asm ?:)) - (vector (current-column)))))))) - -(defun c-lineup-argcont-scan (&optional other-match) - ;; Find the start of an argument, for `c-lineup-argcont'. - (when (zerop (c-backward-token-2 1 t)) - (let ((c (char-after))) - (if (or (eq c ?,) (eq c other-match)) - (progn - (forward-char) - (c-forward-syntactic-ws)) - (c-lineup-argcont-scan other-match))))) +Works with: arglist-cont, arglist-cont-nonempty." + (save-excursion + (when (c-lineup-argcont-1 langelem) ; Check we've got a continued argument... + ;; ... but ignore the position found. + (goto-char (c-langelem-2nd-pos c-syntactic-element)) + (forward-char) + (c-forward-syntactic-ws) + (vector (+ (current-column) c-basic-offset))))) (defun c-lineup-arglist-intro-after-paren (_langelem) "Line up a line to just after the open paren of the surrounding paren diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index e9237bb01e2..f1f61f7e087 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -5026,18 +5026,6 @@ If a fill prefix is specified, it overrides all the above." (defalias 'c-comment-line-break-function 'c-indent-new-comment-line) (make-obsolete 'c-comment-line-break-function 'c-indent-new-comment-line "21.1") -;; Advice for Emacsen older than 21.1 (!), released 2001/10 -(unless (boundp 'comment-line-break-function) - (defvar c-inside-line-break-advice nil) - (defadvice indent-new-comment-line (around c-line-break-advice - activate preactivate) - "Call `c-indent-new-comment-line' if in CC Mode." - (if (or c-inside-line-break-advice - (not c-buffer-is-cc-mode)) - ad-do-it - (let ((c-inside-line-break-advice t)) - (c-indent-new-comment-line (ad-get-arg 0)))))) - (defun c-context-line-break () "Do a line break suitable to the context. diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index ebc1ef43010..b2fa9e06911 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -6139,7 +6139,7 @@ comment at the start of cc-engine.el for more info." (setq s (cons -1 (cdr s)))) ((and (equal match ",") (eq (car s) -1))) ; at "," in "class foo : bar, ..." - ((member match '(";" "*" "," "(")) + ((member match '(";" "*" "," ")")) (when (and s (cdr s) (<= (car s) 0)) (setq s (cdr s)))) ((c-keyword-member kwd-sym 'c-flat-decl-block-kwds) diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el index 8fe8402b1d8..1cf14d52d55 100644 --- a/lisp/progmodes/cc-styles.el +++ b/lisp/progmodes/cc-styles.el @@ -180,6 +180,7 @@ (inclass . +) (inline-open . 0)))) ("linux" + (indent-tabs-mode . t) (c-basic-offset . 8) (c-comment-only-line-offset . 0) (c-hanging-braces-alist . ((brace-list-open) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index e75a44b6537..2c5f4687ac7 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -1520,7 +1520,8 @@ to `compilation-error-regexp-alist' if RULES is nil." ;; FIXME-omake: Doing it here seems wrong, at least it should depend on ;; whether or not omake's own error messages are recognized. (cond - ((not omake-included) nil) + ((or (not omake-included) (not pat)) + nil) ((string-match "\\`\\([^^]\\|\\^\\( \\*\\|\\[\\)\\)" pat) nil) ;; Not anchored or anchored but already allows empty spaces. (t (setq pat (concat "^\\(?: \\)?" (substring pat 1))))) @@ -1539,7 +1540,7 @@ to `compilation-error-regexp-alist' if RULES is nil." (error "HYPERLINK should be an integer: %s" (nth 5 item))) (goto-char start) - (while (re-search-forward pat end t) + (while (and pat (re-search-forward pat end t)) (when (setq props (compilation-error-properties file line end-line col end-col (or type 2) fmt rule)) @@ -1752,6 +1753,13 @@ If nil, ask to kill it." :type 'boolean :version "24.3") +(defcustom compilation-max-output-line-length 400 + "Output lines that are longer than this value will be hidden. +If nil, don't hide anything." + :type '(choice (const :tag "Hide nothing" nil) + integer) + :version "29.1") + (defun compilation--update-in-progress-mode-line () ;; `compilation-in-progress' affects the mode-line of all ;; buffers when it changes from nil to non-nil or vice-versa. @@ -2426,13 +2434,16 @@ and runs `compilation-filter-hook'." ;; We used to use `insert-before-markers', so that windows with ;; point at `process-mark' scroll along with the output, but we ;; now use window-point-insertion-type instead. - (insert string) + (if (not compilation-max-output-line-length) + (insert string) + (dolist (line (string-lines string nil t)) + (compilation--insert-abbreviated-line + line compilation-max-output-line-length))) (unless comint-inhibit-carriage-motion (comint-carriage-motion (process-mark proc) (point))) (set-marker (process-mark proc) (point)) ;; Update the number of errors in compilation-mode-line-errors (compilation--ensure-parse (point)) - ;; (setq-local compilation-buffer-modtime (current-time)) (run-hooks 'compilation-filter-hook)) (goto-char pos) (narrow-to-region min max) @@ -2440,6 +2451,40 @@ and runs `compilation-filter-hook'." (set-marker min nil) (set-marker max nil)))))) +(defun compilation--insert-abbreviated-line (string width) + (if (and (> (current-column) 0) + (get-text-property (1- (point)) 'button)) + ;; We already have an abbreviation; just add the string to it. + (let ((beg (point))) + (insert string) + (add-text-properties + beg + ;; Don't make the final newline invisible. + (if (= (aref string (1- (length string))) ?\n) + (1- (point)) + (point)) + (text-properties-at (1- beg)))) + (insert string) + ;; If we exceeded the limit, hide the last portion of the line. + (when (> (current-column) width) + (let ((start (save-excursion + (move-to-column width) + (point)))) + (buttonize-region + start (point) + (lambda (start) + (let ((inhibit-read-only t)) + (remove-text-properties start (save-excursion + (goto-char start) + (line-end-position)) + (text-properties-at start))))) + (put-text-property + start (if (= (aref string (1- (length string))) ?\n) + ;; Don't hide the final newline. + (1- (point)) + (point)) + 'display (if (char-displayable-p ?…) "[…]" "[...]")))))) + (defsubst compilation-buffer-internal-p () "Test if inside a compilation buffer." (local-variable-p 'compilation-locs)) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 94ecc45b15f..3742286e5d3 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -64,7 +64,7 @@ ;; This mode supports font-lock, imenu and mode-compile. In the ;; hairy version font-lock is on, but you should activate imenu ;; yourself (note that mode-compile is not standard yet). Well, you -;; can use imenu from keyboard anyway (M-x imenu), but it is better +;; can use imenu from keyboard anyway (M-g i), but it is better ;; to bind it like that: ;; (define-key global-map [M-S-down-mouse-3] 'imenu) diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index 17cc537e38e..16069f75aeb 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -3633,7 +3633,12 @@ If regular expression is nil, repeat last search." ;;;###autoload (defun ebrowse-tags-query-replace (from to) "Query replace FROM with TO in all files of a class tree. -With prefix arg, process files of marked classes only." +With prefix arg, process files of marked classes only. + +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time." (interactive "sTree query replace (regexp): \nsTree query replace %s by: ") (setq ebrowse-tags-loop-call diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 0dfff32f20d..775b6ebab47 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -237,6 +237,26 @@ Comments in the form will be lost." (if (bolp) (delete-char -1)) (indent-region start (point))))) +(defun elisp-mode-syntax-propertize (start end) + (goto-char start) + (let ((case-fold-search nil)) + (funcall + (syntax-propertize-rules + ;; Empty symbol. + ("##" (0 (unless (nth 8 (syntax-ppss)) + (string-to-syntax "_")))) + ;; Unicode character names. (The longest name is 88 characters + ;; long.) + ("\\?\\\\N{[-A-Za-z0-9 ]\\{,100\\}}" + (0 (unless (nth 8 (syntax-ppss)) + (string-to-syntax "_")))) + ((rx "#" (or (seq (group-n 1 "&" (+ digit)) ?\") ; Bool-vector. + (seq (group-n 1 "s") "(") ; Record. + (seq (group-n 1 (+ "^")) "["))) ; Char-table. + (1 (unless (save-excursion (nth 8 (syntax-ppss (match-beginning 0)))) + (string-to-syntax "'"))))) + start end))) + (defcustom emacs-lisp-mode-hook nil "Hook run when entering Emacs Lisp mode." :options '(eldoc-mode imenu-add-menubar-index checkdoc-minor-mode) @@ -310,6 +330,7 @@ be used instead. #'elisp-eldoc-var-docstring nil t) (add-hook 'xref-backend-functions #'elisp--xref-backend nil t) (setq-local project-vc-external-roots-function #'elisp-load-path-roots) + (setq-local syntax-propertize-function #'elisp-mode-syntax-propertize) (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil 'local) (add-hook 'flymake-diagnostic-functions #'elisp-flymake-checkdoc nil t) @@ -779,7 +800,7 @@ functions are annotated with \"\" via the (defun elisp--xref-make-xref (type symbol file &optional summary) "Return an xref for TYPE SYMBOL in FILE. TYPE must be a type in `find-function-regexp-alist' (use nil for -'defun). If SUMMARY is non-nil, use it for the summary; +`defun'). If SUMMARY is non-nil, use it for the summary; otherwise build the summary from TYPE and SYMBOL." (xref-make (or summary (format elisp--xref-format (or type 'defun) symbol)) @@ -1614,8 +1635,6 @@ Return the result of evaluation." ;; printing, not while evaluating. (defvar elisp--eval-defun-result) (let ((debug-on-error eval-expression-debug-on-error) - (print-length eval-expression-print-length) - (print-level eval-expression-print-level) elisp--eval-defun-result) (save-excursion ;; Arrange for eval-region to "read" the (possibly) altered form. @@ -1630,10 +1649,17 @@ Return the result of evaluation." (setq beg (point)) (setq form (funcall load-read-function (current-buffer))) (setq end (point))) - ;; Alter the form if necessary. - (let ((form (eval-sexp-add-defvars - (elisp--eval-defun-1 - (macroexpand form))))) + ;; Alter the form if necessary. We bind `print-level' (etc.) + ;; in the form itself, because we want evalling the form to + ;; use the original values, while we want the printing to use + ;; `eval-expression-print-length' (etc.). + (let ((form `(let ((print-level ,print-level) + (print-length ,print-length)) + ,(eval-sexp-add-defvars + (elisp--eval-defun-1 + (macroexpand form))))) + (print-length eval-expression-print-length) + (print-level eval-expression-print-level)) (eval-region beg end standard-output (lambda (_ignore) ;; Skipping to the end of the specified region @@ -2083,7 +2109,7 @@ current buffer state and calls REPORT-FN when done." :connection-type 'pipe :sentinel (lambda (proc _event) - (when (eq (process-status proc) 'exit) + (unless (process-live-p proc) (unwind-protect (cond ((not (and (buffer-live-p source-buffer) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index e1b1e67dbcf..7766694edff 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -1839,7 +1839,13 @@ Also see the documentation of the `tags-file-name' variable." Third arg DELIMITED (prefix arg) means replace only word-delimited matches. If you exit (\\[keyboard-quit], RET or q), you can resume the query replace with the command \\[fileloop-continue]. -For non-interactive use, superseded by `fileloop-initialize-replace'." + +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. + +For non-interactive use, this is superseded by `fileloop-initialize-replace'." (declare (advertised-calling-convention (from to &optional delimited) "27.1")) (interactive (query-replace-read-args "Tags query replace (regexp)" t t)) (fileloop-initialize-replace diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 83d7bc8641c..b5f4fff3c31 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -1358,6 +1358,11 @@ This is a suitable place for placing the `flymake-error-counter', Separating each of these with space is not necessary." :type '(repeat (choice string symbol))) +(defcustom flymake-mode-line-lighter "Flymake" + "The string to use in the Flymake mode line." + :type 'string + :version "29.1") + (defvar flymake-mode-line-title '(:eval (flymake--mode-line-title)) "Mode-line construct to show Flymake's mode name and menu.") @@ -1386,7 +1391,7 @@ correctly.") (defun flymake--mode-line-title () `(:propertize - "Flymake" + ,flymake-mode-line-lighter mouse-face mode-line-highlight help-echo ,(lambda (&rest _) @@ -1637,6 +1642,8 @@ buffer." (defun flymake-show-buffer-diagnostics () "Show a list of Flymake diagnostics for current buffer." (interactive) + (unless flymake-mode + (user-error "Flymake mode is not enabled in the current buffer")) (let* ((name (flymake--diagnostics-buffer-name)) (source (current-buffer)) (target (or (get-buffer name) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index a35a7deb4b1..089c273bc6d 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -1581,7 +1581,7 @@ Buffer mode and name are selected according to buffer type. If buffer has trigger associated with it in `gdb-buffer-rules', this trigger is subscribed to `gdb-buf-publisher' and called with -'update argument." +`update' argument." (or (gdb-get-buffer buffer-type thread) (let ((rules (assoc buffer-type gdb-buffer-rules)) (new (generate-new-buffer "limbo"))) diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index ccc58e6773c..7620536b4b6 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -48,8 +48,8 @@ to avoid computing them again.") "Set SYMBOL to VALUE, and update `grep-host-defaults-alist'. SYMBOL should be one of `grep-command', `grep-template', `grep-use-null-device', `grep-find-command' `grep-find-template', -`grep-find-use-xargs', `grep-use-null-filename-separator', or -`grep-highlight-matches'." +`grep-find-use-xargs', `grep-use-null-filename-separator', +`grep-highlight-matches', or `grep-quoting-style'." (when grep-host-defaults-alist (let* ((host-id (intern (or (file-remote-p default-directory) "localhost"))) @@ -202,6 +202,9 @@ by `grep-compute-defaults'; to change the default value, use :set #'grep-apply-setting :version "22.1") +(defvar grep-quoting-style nil + "Whether to use POSIX-like shell argument quoting.") + (defcustom grep-files-aliases '(("all" . "* .*") ("el" . "*.el") @@ -269,16 +272,16 @@ See `compilation-error-screen-columns'." (defvar grep-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map compilation-minor-mode-map) - (define-key map " " 'scroll-up-command) - (define-key map [?\S-\ ] 'scroll-down-command) - (define-key map "\^?" 'scroll-down-command) - (define-key map "\C-c\C-f" 'next-error-follow-minor-mode) + (define-key map " " #'scroll-up-command) + (define-key map [?\S-\ ] #'scroll-down-command) + (define-key map "\^?" #'scroll-down-command) + (define-key map "\C-c\C-f" #'next-error-follow-minor-mode) - (define-key map "\r" 'compile-goto-error) ;; ? - (define-key map "{" 'compilation-previous-file) - (define-key map "}" 'compilation-next-file) - (define-key map "\t" 'compilation-next-error) - (define-key map [backtab] 'compilation-previous-error) + (define-key map "\r" #'compile-goto-error) ;; ? + (define-key map "{" #'compilation-previous-file) + (define-key map "}" #'compilation-next-file) + (define-key map "\t" #'compilation-next-error) + (define-key map [backtab] #'compilation-previous-error) map) "Keymap for grep buffers. `compilation-minor-mode-map' is a cdr of this.") @@ -322,24 +325,24 @@ See `compilation-error-screen-columns'." ;; FIXME: Nowadays the last button is not "help" but "search"! (help (last tool-bar-map))) ;; Keep Help last in tool bar (tool-bar-local-item - "left-arrow" 'previous-error-no-select 'previous-error-no-select map + "left-arrow" #'previous-error-no-select #'previous-error-no-select map :rtl "right-arrow" :help "Goto previous match") (tool-bar-local-item - "right-arrow" 'next-error-no-select 'next-error-no-select map + "right-arrow" #'next-error-no-select #'next-error-no-select map :rtl "left-arrow" :help "Goto next match") (tool-bar-local-item - "cancel" 'kill-compilation 'kill-compilation map + "cancel" #'kill-compilation #'kill-compilation map :enable '(let ((buffer (compilation-find-buffer))) (get-buffer-process buffer)) :help "Stop grep") (tool-bar-local-item - "refresh" 'recompile 'recompile map + "refresh" #'recompile #'recompile map :help "Restart grep") (append map help)))) -(defalias 'kill-grep 'kill-compilation) +(defalias 'kill-grep #'kill-compilation) ;; override compilation-last-buffer (defvar grep-last-buffer nil @@ -443,9 +446,9 @@ buffer `default-directory'." (defvar grep-find-abbreviate-properties (let ((ellipsis (if (char-displayable-p ?…) "[…]" "[...]")) (map (make-sparse-keymap))) - (define-key map [down-mouse-2] 'mouse-set-point) - (define-key map [mouse-2] 'grep-find-toggle-abbreviation) - (define-key map "\C-m" 'grep-find-toggle-abbreviation) + (define-key map [down-mouse-2] #'mouse-set-point) + (define-key map [mouse-2] #'grep-find-toggle-abbreviation) + (define-key map "\C-m" #'grep-find-toggle-abbreviation) `(face nil display ,ellipsis mouse-face highlight help-echo "RET, mouse-2: show unabbreviated command" keymap ,map abbreviated-command t)) @@ -453,7 +456,7 @@ buffer `default-directory'." (defvar grep-mode-font-lock-keywords '(;; Command output lines. - (": \\(.+\\): \\(?:Permission denied\\|No such \\(?:file or directory\\|device or address\\)\\)$" + (": \\(.\\{,200\\}\\): \\(?:Permission denied\\|No such \\(?:file or directory\\|device or address\\)\\)$" 1 grep-error-face) ;; remove match from grep-regexp-alist before fontifying ("^Grep[/a-zA-Z]* started.*" @@ -616,8 +619,8 @@ This function is called from `compilation-filter-hook'." "Compute the defaults for the `grep' command. The value depends on `grep-command', `grep-template', `grep-use-null-device', `grep-find-command', `grep-find-template', -`grep-use-null-filename-separator', `grep-find-use-xargs' and -`grep-highlight-matches'." +`grep-use-null-filename-separator', `grep-find-use-xargs', +`grep-highlight-matches', and `grep-quoting-style'." ;; Keep default values. (unless grep-host-defaults-alist (add-to-list @@ -631,13 +634,14 @@ The value depends on `grep-command', `grep-template', (grep-use-null-filename-separator ,grep-use-null-filename-separator) (grep-find-use-xargs ,grep-find-use-xargs) - (grep-highlight-matches ,grep-highlight-matches))))) - (let* ((host-id - (intern (or (file-remote-p default-directory) "localhost"))) + (grep-highlight-matches ,grep-highlight-matches) + (grep-quoting-style ,grep-quoting-style))))) + (let* ((remote (file-remote-p default-directory)) + (host-id (intern (or remote "localhost"))) (host-defaults (assq host-id grep-host-defaults-alist)) (defaults (assq nil grep-host-defaults-alist)) - (quot-braces (shell-quote-argument "{}")) - (quot-scolon (shell-quote-argument ";"))) + (quot-braces (shell-quote-argument "{}" remote)) + (quot-scolon (shell-quote-argument ";" remote))) ;; There are different defaults on different hosts. They must be ;; computed for every host once. (dolist (setting '(grep-command grep-template @@ -791,8 +795,11 @@ The value depends on `grep-command', `grep-template', find-program gcmd null quot-braces)) (t (format "%s -H -type f -print | \"%s\" %s" - find-program xargs-program gcmd)))))))) - ;; Save defaults for this host. + find-program xargs-program gcmd)))))) + + (setq grep-quoting-style (and remote 'posix)))) + + ;; Save defaults for this host. (setq grep-host-defaults-alist (delete (assq host-id grep-host-defaults-alist) grep-host-defaults-alist)) @@ -807,7 +814,8 @@ The value depends on `grep-command', `grep-template', (grep-use-null-filename-separator ,grep-use-null-filename-separator) (grep-find-use-xargs ,grep-find-use-xargs) - (grep-highlight-matches ,grep-highlight-matches)))))) + (grep-highlight-matches ,grep-highlight-matches) + (grep-quoting-style ,grep-quoting-style)))))) (defun grep-tag-default () (or (and transient-mark-mode mark-active @@ -820,7 +828,8 @@ The value depends on `grep-command', `grep-template', (defun grep-default-command () "Compute the default grep command for \\[universal-argument] \\[grep] to offer." - (let ((tag-default (shell-quote-argument (grep-tag-default))) + (let ((tag-default + (shell-quote-argument (grep-tag-default) grep-quoting-style)) ;; This a regexp to match single shell arguments. ;; Could someone please add comments explaining it? (sh-arg-re @@ -952,8 +961,7 @@ easily repeat a find command." (grep command-args)))) ;;;###autoload -(defalias 'find-grep 'grep-find) - +(defalias 'find-grep #'grep-find) ;; User-friendly interactive API. @@ -963,7 +971,7 @@ easily repeat a find command." ("" . files) ("" . (null-device)) ("" . excl) - ("" . (shell-quote-argument (or regexp "")))) + ("" . (shell-quote-argument (or regexp "") grep-quoting-style))) "List of substitutions performed by `grep-expand-template'. If car of an element matches, the cdr is evalled in order to get the substitution string. @@ -1010,7 +1018,7 @@ these include `opts', `dir', `files', `null-device', `excl' and ;; Instead of a `grep-read-files-function' variable, we used to lookup ;; mode-specific functions in the major mode's symbol properties, so preserve ;; this behavior for backward compatibility. - (let ((old-function (get major-mode 'grep-read-files))) ;Obsolete since 28.1 + (let ((old-function (get major-mode #'grep-read-files))) ;Obsolete since 28.1 (if old-function (funcall old-function) (let ((file-name-at-point @@ -1112,6 +1120,9 @@ command before it's run." (when (and (stringp regexp) (> (length regexp) 0)) (unless (and dir (file-accessible-directory-p dir)) (setq dir default-directory)) + (unless (string-equal (file-remote-p dir) (file-remote-p default-directory)) + (let ((default-directory dir)) + (grep-compute-defaults))) (let ((command regexp)) (if (null files) (if (string= command grep-command) @@ -1134,11 +1145,13 @@ command before it's run." (mapconcat (lambda (ignore) (cond ((stringp ignore) - (shell-quote-argument ignore)) + (shell-quote-argument + ignore grep-quoting-style)) ((consp ignore) (and (funcall (car ignore) dir) (shell-quote-argument - (cdr ignore)))))) + (cdr ignore) + grep-quoting-style))))) grep-find-ignored-files " --exclude="))) (and (eq grep-use-directories-skip t) @@ -1158,7 +1171,7 @@ command before it's run." (if (and grep-use-null-device null-device (null-device)) (concat command " " (null-device)) command) - 'grep-mode)) + #'grep-mode)) ;; Set default-directory if we started lgrep in the *grep* buffer. (if (eq next-error-last-buffer (current-buffer)) (setq default-directory dir)))))) @@ -1210,11 +1223,14 @@ command before it's run." (when (and (stringp regexp) (> (length regexp) 0)) (unless (and dir (file-accessible-directory-p dir)) (setq dir default-directory)) + (unless (string-equal (file-remote-p dir) (file-remote-p default-directory)) + (let ((default-directory dir)) + (grep-compute-defaults))) (if (null files) (if (not (string= regexp (if (consp grep-find-command) (car grep-find-command) grep-find-command))) - (compilation-start regexp 'grep-mode)) + (compilation-start regexp #'grep-mode)) (setq dir (file-name-as-directory (expand-file-name dir))) (let ((command (rgrep-default-command regexp files nil))) (when command @@ -1225,7 +1241,7 @@ command before it's run." (add-to-history 'grep-find-history command)) (grep--save-buffers) (let ((default-directory dir)) - (compilation-start command 'grep-mode)) + (compilation-start command #'grep-mode)) ;; Set default-directory if we started rgrep in the *grep* buffer. (if (eq next-error-last-buffer (current-buffer)) (setq default-directory dir))))))) @@ -1245,44 +1261,46 @@ command before it's run." (grep-expand-template grep-find-template regexp - (concat (shell-quote-argument "(") + (concat (shell-quote-argument "(" grep-quoting-style) " " find-name-arg " " (mapconcat - #'shell-quote-argument + (lambda (x) (shell-quote-argument x grep-quoting-style)) (split-string files) (concat " -o " find-name-arg " ")) " " - (shell-quote-argument ")")) + (shell-quote-argument ")" grep-quoting-style)) dir (concat (and grep-find-ignored-directories (concat "-type d " - (shell-quote-argument "(") + (shell-quote-argument "(" grep-quoting-style) ;; we should use shell-quote-argument here " -path " - (mapconcat (lambda (d) (shell-quote-argument (concat "*/" d))) - (rgrep-find-ignored-directories dir) - " -o -path ") + (mapconcat + (lambda (d) + (shell-quote-argument (concat "*/" d) grep-quoting-style)) + (rgrep-find-ignored-directories dir) + " -o -path ") " " - (shell-quote-argument ")") + (shell-quote-argument ")" grep-quoting-style) " -prune -o ")) (and grep-find-ignored-files - (concat (shell-quote-argument "!") " -type d " - (shell-quote-argument "(") + (concat (shell-quote-argument "!" grep-quoting-style) " -type d " + (shell-quote-argument "(" grep-quoting-style) ;; we should use shell-quote-argument here " -name " (mapconcat (lambda (ignore) (cond ((stringp ignore) - (shell-quote-argument ignore)) + (shell-quote-argument ignore grep-quoting-style)) ((consp ignore) (and (funcall (car ignore) dir) (shell-quote-argument - (cdr ignore)))))) + (cdr ignore) grep-quoting-style))))) grep-find-ignored-files " -o -name ") " " - (shell-quote-argument ")") + (shell-quote-argument ")" grep-quoting-style) " -prune -o "))))) (defun grep-find-toggle-abbreviation () @@ -1352,7 +1370,7 @@ The returned file name is relative." (caar (compilation--loc->file-struct loc)))) ;;;###autoload -(defalias 'rzgrep 'zrgrep) +(defalias 'rzgrep #'zrgrep) (provide 'grep) diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index 91307f6c09f..1a1dc3aee9a 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -889,7 +889,7 @@ Makefile mode can be configured by modifying the following variables: (setq-local comment-start-skip "#+[ \t]*") ;; Make sure TAB really inserts \t. - (setq-local indent-line-function 'indent-to-left-margin) + (setq-local indent-line-function #'insert-tab) ;; Real TABs are important in makefiles (setq indent-tabs-mode t)) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index daaf86f3277..6c50135358f 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1076,6 +1076,10 @@ command \\[fileloop-continue]." (defun project-query-replace-regexp (from to) "Query-replace REGEXP in all the files of the project. Stops when a match is found and prompts for whether to replace it. +At that prompt, the user must type a character saying what to do +with the match. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. If you exit the `query-replace', you can later continue the `query-replace' loop using the command \\[fileloop-continue]." (interactive @@ -1201,18 +1205,22 @@ displayed." (display-buffer-other-frame buffer-or-name)) (defcustom project-kill-buffer-conditions - '(buffer-file-name ; All file-visiting buffers are included. + `(buffer-file-name ; All file-visiting buffers are included. ;; Most of the temp buffers in the background: - (major-mode . fundamental-mode) + ,(lambda (buf) + (not (eq (buffer-local-value 'major-mode buf) + 'fundamental-mode))) ;; non-text buffer such as xref, occur, vc, log, ... - (and (derived-mode . special-mode) - (not (major-mode . help-mode))) - (derived-mode . compilation-mode) - (derived-mode . dired-mode) - (derived-mode . diff-mode) - (derived-mode . comint-mode) - (derived-mode . eshell-mode) - (derived-mode . change-log-mode)) + (and (major-mode . special-mode) + ,(lambda (buf) + (not (eq (buffer-local-value 'major-mode buf) + 'help-mode)))) + (major-mode . compilation-mode) + (major-mode . dired-mode) + (major-mode . diff-mode) + (major-mode . comint-mode) + (major-mode . eshell-mode) + (major-mode . change-log-mode)) "List of conditions to kill buffers related to a project. This list is used by `project-kill-buffers'. Each condition is either: @@ -1222,10 +1230,11 @@ Each condition is either: - a cons-cell, where the car describes how to interpret the cdr. The car can be one of the following: * `major-mode': the buffer is killed if the buffer's major - mode is eq to the cons-cell's cdr - * `derived-mode': the buffer is killed if the buffer's major mode is derived from the major mode denoted by the cons-cell's - cdr + cdr. + * `derived-mode': the buffer is killed if the buffer's major + mode is eq to the cons-cell's cdr (this is deprecated and will + result in a warning if used). * `not': the cdr is interpreted as a negation of a condition. * `and': the cdr is a list of recursive conditions, that all have to be met. @@ -1285,10 +1294,13 @@ form of CONDITIONS." (string-match-p c (buffer-name buf))) ((symbolp c) (funcall c buf)) - ((eq (car-safe c) 'major-mode) - (eq (buffer-local-value 'major-mode buf) - (cdr c))) ((eq (car-safe c) 'derived-mode) + (warn "The use of `derived-mode' in \ +`project--buffer-check' is deprecated.") + (provided-mode-derived-p + (buffer-local-value 'major-mode buf) + (cdr c))) + ((eq (car-safe c) 'major-mode) (provided-mode-derived-p (buffer-local-value 'major-mode buf) (cdr c))) @@ -1322,7 +1334,9 @@ identical. Only the buffers that match a condition in `project-kill-buffer-conditions' will be killed. If NO-CONFIRM is non-nil, the command will not ask the user for confirmation. NO-CONFIRM is always nil when the command is invoked -interactively." +interactively. + +Also see the `project-kill-buffers-display-buffer-list' variable." (interactive) (let* ((pr (project-current t)) (bufs (project--buffers-to-kill pr)) diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index d83290fe457..11ed732d282 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -563,6 +563,8 @@ class declarations.") ;; Python 3.5+ PEP492 (and "async" (+ space) (or "def" "for" "with")) "await" + ;; Python 3.10+ + "match" "case" ;; Extra: "self") symbol-end) @@ -704,7 +706,8 @@ avoid '==' being treated as an assignment." ;; [a] = 5 ;; [*a] = 5, 6 (,(python-font-lock-assignment-matcher - (python-rx (or "[" "(") (* space) + (python-rx (or line-start ?\;) (* space) + (or "[" "(") (* space) grouped-assignment-target (* space) (or ")" "]") (* space) assignment-operator)) @@ -1626,23 +1629,20 @@ of the statement." ;; are somehow out of whack. This has been ;; observed when using `syntax-ppss' during ;; narrowing. - (cl-assert (>= string-start last-string-end) - :show-args - "\ -Overlapping strings detected (start=%d, last-end=%d)") - (goto-char string-start) - (if (python-syntax-context 'paren) - ;; Ended up inside a paren, roll again. - (python-nav-end-of-statement t) - ;; This is not inside a paren, move to the - ;; end of this string. - (goto-char (+ (point) - (python-syntax-count-quotes - (char-after (point)) (point)))) - (setq last-string-end - (or (re-search-forward - (rx (syntax string-delimiter)) nil t) - (goto-char (point-max)))))) + (when (>= string-start last-string-end) + (goto-char string-start) + (if (python-syntax-context 'paren) + ;; Ended up inside a paren, roll again. + (python-nav-end-of-statement t) + ;; This is not inside a paren, move to the + ;; end of this string. + (goto-char (+ (point) + (python-syntax-count-quotes + (char-after (point)) (point)))) + (setq last-string-end + (or (re-search-forward + (rx (syntax string-delimiter)) nil t) + (goto-char (point-max))))))) ((python-syntax-context 'paren) ;; The statement won't end before we've escaped ;; at least one level of parenthesis. @@ -3292,22 +3292,25 @@ the python shell: (goto-char start) (python-util-forward-comment 1) (current-indentation)))) - (fillstr (and (not no-cookie) - (not starts-at-point-min-p) - (concat - (format "# -*- coding: %s -*-\n" encoding) - (make-string - ;; Subtract 2 because of the coding cookie. - (- (line-number-at-pos start) 2) ?\n))))) + (fillstr (cond (starts-at-point-min-p + nil) + ((not no-cookie) + (concat + (format "# -*- coding: %s -*-\n" encoding) + (make-string + ;; Subtract 2 because of the coding cookie. + (- (line-number-at-pos start) 2) ?\n))) + (t + (make-string (- (line-number-at-pos start) 1) ?\n))))) (with-temp-buffer (python-mode) (when fillstr (insert fillstr)) - (insert substring) - (goto-char (point-min)) (when (not toplevel-p) - (insert "if True:") + (forward-line -1) + (insert "if True:\n") (delete-region (point) (line-end-position))) + (insert substring) (when nomain (let* ((if-name-main-start-end (and nomain diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index eb54ffe05a8..a1977246341 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -70,7 +70,7 @@ "Regexp to match modifiers.") (defconst ruby-block-mid-keywords - '("then" "else" "elsif" "when" "rescue" "ensure") + '("then" "else" "elsif" "when" "in" "rescue" "ensure") "Keywords where the indentation gets shallower in middle of block statements.") (defconst ruby-block-mid-re @@ -369,7 +369,9 @@ This only affects the output of the command `ruby-toggle-block'." (for-body (for-head ";" insts)) (for-head (id "in" exp)) (cases (exp "then" insts) - (cases "when" cases) (insts "else" insts)) + (cases "when" cases) + (cases "in" cases) + (insts "else" insts)) (expseq (exp) );;(expseq "," expseq) (hashvals (exp1 "=>" exp1) (hashvals "," hashvals)) (insts-rescue-insts (insts) @@ -380,7 +382,7 @@ This only affects the output of the command `ruby-toggle-block'." (if-body (ielsei) (if-body "elsif" if-body))) '((nonassoc "in") (assoc ";") (right " @ ") (assoc ",") (right "=")) - '((assoc "when")) + '((assoc "when" "in")) '((assoc "elsif")) '((assoc "rescue" "ensure")) '((assoc ","))) @@ -506,7 +508,7 @@ This only affects the output of the command `ruby-toggle-block'." ((member tok '("unless" "if" "while" "until")) (if (save-excursion (forward-word-strictly -1) (ruby-smie--bosp)) tok "iuwu-mod")) - ((string-match-p "\\`|[*&]?\\'" tok) + ((string-match-p "\\`|[*&]*\\'" tok) (forward-char (- 1 (length tok))) (setq tok "|") (cond @@ -559,7 +561,7 @@ This only affects the output of the command `ruby-toggle-block'." ((ruby-smie--closing-pipe-p) "closing-|") (t tok))) ((string-match-p "\\`[^|]+|\\'" tok) "closing-|") - ((string-match-p "\\`|[*&]\\'" tok) + ((string-match-p "\\`|[*&]*\\'" tok) (forward-char 1) (substring tok 1)) ((and (equal tok "") (eq ?\\ (char-before)) (looking-at "\n")) @@ -595,7 +597,7 @@ This only affects the output of the command `ruby-toggle-block'." (cond ((smie-rule-parent-p "def" "begin" "do" "class" "module" "for" "while" "until" "unless" - "if" "then" "elsif" "else" "when" + "if" "then" "elsif" "else" "when" "in" "rescue" "ensure" "{") (smie-rule-parent ruby-indent-level)) ;; For (invalid) code between switch and case. @@ -659,7 +661,7 @@ This only affects the output of the command `ruby-toggle-block'." ruby-indent-level)))) (`(:before . ,(or "else" "then" "elsif" "rescue" "ensure")) (smie-rule-parent)) - ('(:before . "when") + (`(:before . ,(or "when" "in")) ;; Align to the previous `when', but look up the virtual ;; indentation of `case'. (if (smie-rule-sibling-p) 0 (smie-rule-parent))) diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index 592e2d50570..cd397733d2d 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -562,10 +562,20 @@ indentation." (lisp-indent-specform 2 state indent-point normal-indent) (lisp-indent-specform 1 state indent-point normal-indent))) -;; (put 'begin 'scheme-indent-function 0), say, causes begin to be indented -;; like defun if the first form is placed on the next line, otherwise -;; it is indented like any other form (i.e. forms line up under first). - +;; See `scheme-indent-function' (the function) for what these do. +;; In a nutshell: +;; . for forms with no `scheme-indent-function' property the 2nd +;; and subsequent lines will be indented with one space; +;; . if the value of the property is zero, then when the first form +;; is on a separate line, the next lines will be indented with 2 +;; spaces instead of the default one space; +;; . if the value is a positive integer N, the first N lines after +;; the first one will be indented with 4 spaces, and the rest +;; will be indented with 2 spaces; +;; . if the value is `defun', the indentation is like for `defun'; +;; . if the value is a function, it will be called to produce the +;; required indentation. +;; See also http://community.schemewiki.org/?emacs-indentation. (put 'begin 'scheme-indent-function 0) (put 'case 'scheme-indent-function 1) (put 'delay 'scheme-indent-function 0) @@ -576,12 +586,16 @@ indentation." (put 'letrec 'scheme-indent-function 1) (put 'let-values 'scheme-indent-function 1) ; SRFI 11 (put 'let*-values 'scheme-indent-function 1) ; SRFI 11 +(put 'and-let* 'scheme-indent-function 1) ; SRFI 2 (put 'sequence 'scheme-indent-function 0) ; SICP, not r4rs (put 'let-syntax 'scheme-indent-function 1) (put 'letrec-syntax 'scheme-indent-function 1) (put 'syntax-rules 'scheme-indent-function 1) (put 'syntax-case 'scheme-indent-function 2) ; not r5rs +(put 'with-syntax 'scheme-indent-function 1) (put 'library 'scheme-indent-function 1) ; R6RS +;; Part of at least Guile, Chez Scheme, Chicken +(put 'eval-when 'scheme-indent-function 1) (put 'call-with-input-file 'scheme-indent-function 1) (put 'call-with-port 'scheme-indent-function 1) @@ -605,6 +619,14 @@ indentation." ;; SRFI-8 (put 'receive 'scheme-indent-function 2) +;; SRFI-204 (withdrawn, but provided in many implementations, see the SRFI text) +(put 'match 'scheme-indent-function 1) +(put 'match-lambda 'scheme-indent-function 0) +(put 'match-lambda* 'scheme-indent-function 0) +(put 'match-let 'scheme-indent-function 'scheme-let-indent) +(put 'match-let* 'scheme-indent-function 1) +(put 'match-letrec 'scheme-indent-function 1) + ;;;; MIT Scheme specific indentation. (if scheme-mit-dialect diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 8dc55621438..9151fd0a340 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1549,7 +1549,7 @@ with your script for an edit-interpret-debug cycle." ;; Checks that use `buffer-file-name' follow. ((string-match "\\.m?spec\\'" buffer-file-name) "rpm") ((string-match "[.]sh\\>" buffer-file-name) "sh") - ((string-match "[.]bash\\>" buffer-file-name) "bash") + ((string-match "[.]bash\\(rc\\)?\\>" buffer-file-name) "bash") ((string-match "[.]ksh\\>" buffer-file-name) "ksh") ((string-match "[.]mkshrc\\>" buffer-file-name) "mksh") ((string-match "[.]t?csh\\(rc\\)?\\>" buffer-file-name) "csh") diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 69d16a4357e..979b743a65d 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -3216,7 +3216,7 @@ For both `:file' and `:completion', there can also be a (cond ((plist-member plist :file) (let ((file-name - (read-file-name prompt + (read-file-name prompt-def (file-name-directory last-value) default (if (plist-member plist :must-match) @@ -3246,7 +3246,7 @@ For both `:file' and `:completion', there can also be a default)) ((plist-get plist :number) - (read-number prompt (or default last-value 0))) + (read-number (concat prompt ": ") (or default last-value 0))) (t (read-string prompt-def last-value history-var default)))))) @@ -3318,7 +3318,7 @@ function like this: (sql-get-login \\='user \\='password \\='database)." (sql-get-login-ext 'sql-server "Server" 'sql-server-history plist)) ('database - (sql-get-login-ext 'sql-database "Database: " + (sql-get-login-ext 'sql-database "Database" 'sql-database-history plist)) ('port @@ -3648,94 +3648,69 @@ Allows the suppression of continuation prompts.") (defvar sql-preoutput-hold nil) -(defun sql-starts-with-prompt-re () - "Anchor the prompt expression at the beginning of the output line. -Remove the start of line regexp." - (concat "\\`" comint-prompt-regexp)) - -(defun sql-ends-with-prompt-re () - "Anchor the prompt expression at the end of the output line. -Match a SQL prompt or a password prompt." - (concat "\\(?:\\(?:" sql-prompt-regexp "\\)\\|" - "\\(?:" comint-password-prompt-regexp "\\)\\)\\'")) - (defun sql-interactive-remove-continuation-prompt (oline) "Strip out continuation prompts out of the OLINE. Added to the `comint-preoutput-filter-functions' hook in a SQL -interactive buffer. If `sql-output-newline-count' is greater than -zero, then an output line matching the continuation prompt is filtered -out. If the count is zero, then a newline is inserted into the output -to force the output from the query to appear on a new line. +interactive buffer. The complication to this filter is that the +continuation prompts may arrive in multiple chunks. If they do, +then the function saves any unfiltered output in a buffer and +prepends that buffer to the next chunk to properly match the +broken-up prompt. -The complication to this filter is that the continuation prompts -may arrive in multiple chunks. If they do, then the function -saves any unfiltered output in a buffer and prepends that buffer -to the next chunk to properly match the broken-up prompt. - -If the filter gets confused, it should reset and stop filtering -to avoid deleting non-prompt output." - - ;; continue gathering lines of text iff - ;; + we know what a prompt looks like, and - ;; + there is held text, or - ;; + there are continuation prompt yet to come, or - ;; + not just a prompt string +The filter goes into play only if something is already +accumulated, or we're waiting for continuation +prompts (`sql-output-newline-count' is positive). In this case: +- Accumulate process output into `sql-preoutput-hold'. +- Remove any complete prompts / continuation prompts that we're waiting + for. +- In case we're expecting more prompts - return all currently + accumulated _complete_ lines, leaving the rest for the next + invocation. They will appear in the output immediately. This way we + don't accumulate large chunks of data for no reason. +- If we found all expected prompts - just return all current accumulated + data." (when (and comint-prompt-regexp - (or (> (length (or sql-preoutput-hold "")) 0) - (> (or sql-output-newline-count 0) 0) - (not (or (string-match sql-prompt-regexp oline) - (and sql-prompt-cont-regexp - (string-match sql-prompt-cont-regexp oline)))))) - + ;; We either already have something held, or expect + ;; prompts + (or sql-preoutput-hold + (and sql-output-newline-count + (> sql-output-newline-count 0)))) (save-match-data - (let (prompt-found last-nl) + ;; Add this text to what's left from the last pass + (setq oline (concat sql-preoutput-hold oline) + sql-preoutput-hold nil) - ;; Add this text to what's left from the last pass - (setq oline (concat sql-preoutput-hold oline) - sql-preoutput-hold "") + ;; If we are looking for prompts + (when (and sql-output-newline-count + (> sql-output-newline-count 0)) + ;; Loop thru each starting prompt and remove it + (while (and (not (string-empty-p oline)) + (> sql-output-newline-count 0) + (string-match comint-prompt-regexp oline)) + (setq oline (replace-match "" nil nil oline) + sql-output-newline-count (1- sql-output-newline-count))) - ;; If we are looking for multiple prompts - (when (and (integerp sql-output-newline-count) - (>= sql-output-newline-count 1)) - ;; Loop thru each starting prompt and remove it - (let ((start-re (sql-starts-with-prompt-re))) - (while (and (not (string= oline "")) - (> sql-output-newline-count 0) - (string-match start-re oline)) - (setq oline (replace-match "" nil nil oline) - sql-output-newline-count (1- sql-output-newline-count) - prompt-found t))) + ;; If we've found all the expected prompts, stop looking + (if (= sql-output-newline-count 0) + (setq sql-output-newline-count nil) + ;; Still more possible prompts, leave them for the next pass + (setq sql-preoutput-hold oline + oline ""))) - ;; If we've found all the expected prompts, stop looking - (if (= sql-output-newline-count 0) - (setq sql-output-newline-count nil) - - ;; Still more possible prompts, leave them for the next pass - (setq sql-preoutput-hold oline - oline ""))) - - ;; If no prompts were found, stop looking - (unless prompt-found - (setq sql-output-newline-count nil - oline (concat oline sql-preoutput-hold) - sql-preoutput-hold "")) - - ;; Break up output by physical lines if we haven't hit the final prompt - (let ((end-re (sql-ends-with-prompt-re))) - (unless (and (not (string= oline "")) - (string-match end-re oline) - (>= (match-end 0) (length oline))) - ;; Find everything upto the last nl - (setq last-nl 0) - (while (string-match "\n" oline last-nl) - (setq last-nl (match-end 0))) - ;; Hold after the last nl, return upto last nl - (setq sql-preoutput-hold (concat (substring oline last-nl) - sql-preoutput-hold) - oline (substring oline 0 last-nl))))))) + ;; Lines that are now complete may be passed further + (when sql-preoutput-hold + (let ((last-nl 0)) + (while (string-match "\n" sql-preoutput-hold last-nl) + (setq last-nl (match-end 0))) + ;; Return up to last nl, hold after the last nl + (setq oline (substring sql-preoutput-hold 0 last-nl) + sql-preoutput-hold (substring sql-preoutput-hold last-nl)) + (when (string-empty-p sql-preoutput-hold) + (setq sql-preoutput-hold nil)))))) oline) + ;;; Sending the region to the SQLi buffer. (defvar sql-debug-send nil "Display text sent to SQL process pragmatically.") @@ -4195,7 +4170,18 @@ must tell Emacs. Here's how to do that in your init file: nil))) ;; Propertize rules to not have /- and -* start comments. ("\\(/-\\)" (1 ".")) - ("\\(-\\*\\)" (1 ".")))) + ("\\(-\\*\\)" + (1 + (if (save-excursion + (not (ppss-comment-depth + (syntax-ppss (match-beginning 1))))) + ;; If we're outside a comment, we don't let -* + ;; start a comment. + (string-to-syntax ".") + ;; Inside a comment, ignore it to avoid -*/ not + ;; being intepreted as a comment end. + (forward-char -1) + nil))))) ;; Set syntax and font-face highlighting ;; Catch changes to sql-product and highlight accordingly (sql-set-product (or sql-product 'ansi)) ; Fixes bug#13591 @@ -4633,6 +4619,9 @@ the call to \\[sql-product-interactive] with (setq sql-buffer (buffer-name new-sqli-buffer)) (run-hooks 'sql-set-sqli-hook))) + ;; Also set the global value. + (setq-default sql-buffer (buffer-name new-sqli-buffer)) + ;; Make sure the connection is complete ;; (Sometimes start up can be slow) ;; and call the login hook diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el index ed6dce02c03..8c179879ce2 100644 --- a/lisp/progmodes/tcl.el +++ b/lisp/progmodes/tcl.el @@ -344,7 +344,7 @@ information): Add functions to the hook with `add-hook': - (add-hook 'tcl-mode-hook #'tcl-guess-application)") + (add-hook \\='tcl-mode-hook #\\='tcl-guess-application)") (defvar tcl-proc-list diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index edce3fef6cf..31d50a1882e 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -3622,10 +3622,10 @@ is 0. Meaning of *single* declaration: E.g. In a module's port-list - module test(input clk, rst, x, output [1:0] y); - Here 'input clk, rst, x' is 1 *single* declaration statement, -and 'output [1:0] y' is the other single declaration. In the 1st single -declaration, POINT is moved to start of 'clk'. And in the 2nd declaration, -POINT is moved to 'y'." + Here `input clk, rst, x' is 1 *single* declaration statement, +and `output [1:0] y' is the other single declaration. In the 1st single +declaration, POINT is moved to start of `clk'. And in the 2nd declaration, +POINT is moved to `y'." (let (maxpoint old-point) diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index c6693b4de53..cdc8aeb1763 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -8396,30 +8396,30 @@ buffer." ((visible-list (vhdl-get-visible-signals)) ;; define syntactic regions where signals are read (scan-regions-list - '(;; right-hand side of signal/variable assignment + `(;; right-hand side of signal/variable assignment ;; (special case: "<=" is relational operator in a condition) - ((vhdl-re-search-forward "[<:]=" proc-end t) - (vhdl-re-search-forward ";\\|\\<\\(then\\|loop\\|report\\|severity\\|is\\)\\>" proc-end t)) + ((vhdl-re-search-forward "[<:]=" ,proc-end t) + (vhdl-re-search-forward ";\\|\\<\\(then\\|loop\\|report\\|severity\\|is\\)\\>" ,proc-end t)) ;; if condition - ((vhdl-re-search-forward "^\\s-*if\\>" proc-end t) - (vhdl-re-search-forward "\\" proc-end t)) + ((vhdl-re-search-forward "^\\s-*if\\>" ,proc-end t) + (vhdl-re-search-forward "\\" ,proc-end t)) ;; elsif condition - ((vhdl-re-search-forward "\\" proc-end t) - (vhdl-re-search-forward "\\" proc-end t)) + ((vhdl-re-search-forward "\\" ,proc-end t) + (vhdl-re-search-forward "\\" ,proc-end t)) ;; while loop condition - ((vhdl-re-search-forward "^\\s-*while\\>" proc-end t) - (vhdl-re-search-forward "\\" proc-end t)) + ((vhdl-re-search-forward "^\\s-*while\\>" ,proc-end t) + (vhdl-re-search-forward "\\" ,proc-end t)) ;; exit/next condition - ((vhdl-re-search-forward "\\<\\(exit\\|next\\)\\s-+\\w+\\s-+when\\>" proc-end t) - (vhdl-re-search-forward ";" proc-end t)) + ((vhdl-re-search-forward "\\<\\(exit\\|next\\)\\s-+\\w+\\s-+when\\>" ,proc-end t) + (vhdl-re-search-forward ";" ,proc-end t)) ;; assert condition - ((vhdl-re-search-forward "\\" proc-end t) - (vhdl-re-search-forward "\\(\\\\|\\\\|;\\)" proc-end t)) + ((vhdl-re-search-forward "\\" ,proc-end t) + (vhdl-re-search-forward "\\(\\\\|\\\\|;\\)" ,proc-end t)) ;; case expression - ((vhdl-re-search-forward "^\\s-*case\\>" proc-end t) - (vhdl-re-search-forward "\\" proc-end t)) + ((vhdl-re-search-forward "^\\s-*case\\>" ,proc-end t) + (vhdl-re-search-forward "\\" ,proc-end t)) ;; parameter list of procedure call, array index - ((and (re-search-forward "^\\s-*\\(\\w\\|\\.\\)+[ \t\n\r\f]*(" proc-end t) + ((and (re-search-forward "^\\s-*\\(\\w\\|\\.\\)+[ \t\n\r\f]*(" ,proc-end t) (1- (point))) (progn (backward-char) (forward-sexp) (while (looking-at "(") (forward-sexp)) (point))))) @@ -8785,7 +8785,10 @@ project is defined." (defun vhdl-electric-period (count) "`..' --> ` => '" (interactive "p") (if (and vhdl-stutter-mode (= count 1) (not (vhdl-in-literal))) - (cond ((= (preceding-char) vhdl-last-input-event) + ;; We use this-command-keys below to account for translation of + ;; kp-decimal into '.'; vhdl-last-input-event doesn't catch + ;; that. + (cond ((eq (preceding-char) (aref (this-command-keys) 0)) (progn (delete-char -1) (unless (eq (preceding-char) ? ) (insert " ")) (insert "=> "))) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index a5e6edf951d..6e763eef018 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -227,7 +227,7 @@ This behavior is new in Emacs 28.") "A match xref item describes a search result." length) -(cl-defgeneric xref-match-length ((item xref-match-item)) +(cl-defmethod xref-match-length ((item xref-match-item)) "Return the length of the match." (xref-match-item-length item)) @@ -381,7 +381,8 @@ elements is negated: these commands will NOT prompt." (defcustom xref-after-jump-hook '(recenter xref-pulse-momentarily) - "Functions called after jumping to an xref." + "Functions called after jumping to an xref. +Also see `xref-current-item'." :type 'hook) (defcustom xref-after-return-hook '(xref-pulse-momentarily) @@ -490,7 +491,9 @@ To undo, use \\[xref-go-forward]." 'xref-current-item "29.1") -(defvar xref-current-item nil) +(defvar xref-current-item nil + "Dynamically bound to the current item being processed. +This can be used from `xref-after-jump-hook', for instance.") (defun xref-pulse-momentarily () (pcase-let ((`(,beg . ,end) @@ -747,7 +750,12 @@ references displayed in the current *xref* buffer. When called interactively, it uses '.*' as FROM, which means replace the whole name. Unless called with prefix argument, in -which case the user is prompted for both FROM and TO." +which case the user is prompted for both FROM and TO. + +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time." (interactive (let* ((fr (if current-prefix-arg @@ -957,8 +965,8 @@ beginning of the line." (defvar xref--button-map (let ((map (make-sparse-keymap))) - (define-key map [mouse-1] #'xref-goto-xref) - (define-key map [mouse-2] #'xref-select-and-show-xref) + (define-key map [follow-link] 'mouse-face) + (define-key map [mouse-2] #'xref-goto-xref) map)) (defun xref-select-and-show-xref (event) @@ -1715,7 +1723,8 @@ IGNORES is a list of glob patterns for files to ignore." . ;; '!*/' is there to filter out dirs (e.g. submodules). "xargs -0 rg --null -nH --no-heading --no-messages -g '!*/' -e " - )) + ) + (ugrep . "xargs -0 ugrep --null -ns -e ")) "Associative list mapping program identifiers to command templates. Program identifier should be a symbol, named after the search program. @@ -1744,6 +1753,7 @@ utility function used by commands like `dired-do-find-regexp' and :type '(choice (const :tag "Use Grep" grep) (const :tag "Use ripgrep" ripgrep) + (const :tag "Use ugrep" ugrep) (symbol :tag "User defined")) :version "28.1" :package-version '(xref . "1.0.4")) @@ -1863,7 +1873,7 @@ to control which program to use when looking for matches." (xref--find-ignores-arguments ignores dir))) (defun xref--find-ignores-arguments (ignores dir) - "Convert IGNORES and DIR to a list of arguments for 'find'. + "Convert IGNORES and DIR to a list of arguments for `find'. IGNORES is a list of glob patterns. DIR is an absolute directory, used as the root of the ignore globs." (cl-assert (not (string-match-p "\\`~" dir))) diff --git a/lisp/recentf.el b/lisp/recentf.el index 5e2f2218614..2de98311540 100644 --- a/lisp/recentf.el +++ b/lisp/recentf.el @@ -1353,7 +1353,7 @@ to a file, and killing a buffer is counted as \"operating\" on the file. If instead you want to prioritize files that appear in buffers you switch to a lot, you can say something like the following: - (add-hook 'buffer-list-update-hook 'recentf-track-opened-file)" + (add-hook \\='buffer-list-update-hook #\\='recentf-track-opened-file)" :global t :group 'recentf :keymap recentf-mode-map diff --git a/lisp/replace.el b/lisp/replace.el index 06be5978554..81282deb140 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -365,11 +365,33 @@ should a regexp." (unless noerror (barf-if-buffer-read-only)) (save-mark-and-excursion - (let* ((from (query-replace-read-from prompt regexp-flag)) + (let* ((delimited-flag (and current-prefix-arg + (not (eq current-prefix-arg '-)))) + (from (minibuffer-with-setup-hook + (minibuffer-lazy-highlight-setup + :case-fold case-fold-search + :filter (when (use-region-p) + (replace--region-filter + (funcall region-extract-function 'bounds))) + :highlight query-replace-lazy-highlight + :regexp regexp-flag + :regexp-function (or replace-regexp-function + delimited-flag + (and replace-char-fold + (not regexp-flag) + #'char-fold-to-regexp)) + :transform (lambda (string) + (let* ((split (query-replace--split-string string)) + (from-string (if (consp split) (car split) split))) + (when (and case-fold-search search-upper-case) + (setq isearch-case-fold-search + (isearch-no-upper-case-p from-string regexp-flag))) + from-string))) + (query-replace-read-from prompt regexp-flag))) (to (if (consp from) (prog1 (cdr from) (setq from (car from))) (query-replace-read-to from prompt regexp-flag)))) (list from to - (or (and current-prefix-arg (not (eq current-prefix-arg '-))) + (or delimited-flag (and (plist-member (text-properties-at 0 from) 'isearch-regexp-function) (get-text-property 0 'isearch-regexp-function from))) (and current-prefix-arg (eq current-prefix-arg '-)))))) @@ -377,7 +399,9 @@ should a regexp." (defun query-replace (from-string to-string &optional delimited start end backward region-noncontiguous-p) "Replace some occurrences of FROM-STRING with TO-STRING. As each match is found, the user must type a character saying -what to do with it. For directions, type \\[help-command] at that time. +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. In Transient Mark mode, if the mark is active, operate on the contents of the region. Otherwise, operate from point to the end of the buffer's @@ -447,7 +471,9 @@ To customize possible responses, change the bindings in `query-replace-map'." (defun query-replace-regexp (regexp to-string &optional delimited start end backward region-noncontiguous-p) "Replace some things after point matching REGEXP with TO-STRING. As each match is found, the user must type a character saying -what to do with it. For directions, type \\[help-command] at that time. +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. In Transient Mark mode, if the mark is active, operate on the contents of the region. Otherwise, operate from point to the end of the buffer's @@ -544,7 +570,9 @@ Interactive use of this function is deprecated in favor of the using `search-forward-regexp' and `replace-match' is preferred. As each match is found, the user must type a character saying -what to do with it. For directions, type \\[help-command] at that time. +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. TO-EXPR is a Lisp expression evaluated to compute each replacement. It may reference `replace-count' to get the number of replacements already made. @@ -630,6 +658,11 @@ Use \\\\[next-history-element] \ to pull the last incremental search regexp to the minibuffer that reads REGEXP. +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. + A prefix argument N says to use each replacement string N times before rotating to the next. Fourth and fifth arg START and END specify the region to operate on. @@ -2685,6 +2718,11 @@ to a regexp that is actually used for the search.") (or (if regexp-flag replace-re-search-function replace-search-function) + ;; `isearch-search-fun' can't be used here because + ;; when buffer-local `isearch-search-fun-function' + ;; searches e.g. the minibuffer history, then + ;; `query-replace' should not operate on the whole + ;; history, but only on the minibuffer contents. (isearch-search-fun-default)))) (funcall search-function search-string limit t))) @@ -2773,6 +2811,26 @@ to a regexp that is actually used for the search.") ,search-str ,next-replace) ,stack)) +(defun replace--region-filter (bounds) + "Return a function that decides if a region is inside BOUNDS. +BOUNDS is a list of cons cells of the form (START . END). The +returned function takes as argument two buffer positions, START +and END." + (let ((region-bounds + (mapcar (lambda (position) + (cons (copy-marker (car position)) + (copy-marker (cdr position)))) + bounds))) + (lambda (start end) + (delq nil (mapcar + (lambda (bounds) + (and + (>= start (car bounds)) + (<= start (cdr bounds)) + (>= end (car bounds)) + (<= end (cdr bounds)))) + region-bounds))))) + (defun perform-replace (from-string replacements query-flag regexp-flag delimited-flag &optional repeat-count map start end backward region-noncontiguous-p) @@ -2857,22 +2915,9 @@ characters." ;; Unless a single contiguous chunk is selected, operate on multiple chunks. (when region-noncontiguous-p - (let ((region-bounds - (mapcar (lambda (position) - (cons (copy-marker (car position)) - (copy-marker (cdr position)))) - (funcall region-extract-function 'bounds)))) - (setq region-filter - (lambda (start end) - (delq nil (mapcar - (lambda (bounds) - (and - (>= start (car bounds)) - (<= start (cdr bounds)) - (>= end (car bounds)) - (<= end (cdr bounds)))) - region-bounds)))) - (add-function :after-while isearch-filter-predicate region-filter))) + (setq region-filter (replace--region-filter + (funcall region-extract-function 'bounds))) + (add-function :after-while isearch-filter-predicate region-filter)) ;; If region is active, in Transient Mark mode, operate on region. (if backward diff --git a/lisp/select.el b/lisp/select.el index 42b50c44e6c..3646a28b9b4 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -25,9 +25,10 @@ ;; Based partially on earlier release by Lucid. ;; The functionality here is divided in two parts: -;; - Low-level: gui-get-selection, gui-set-selection, gui-selection-owner-p, -;; gui-selection-exists-p are the backend-dependent functions meant to access -;; various kinds of selections (CLIPBOARD, PRIMARY, SECONDARY). +;; - Low-level: gui-backend-get-selection, gui-backend-set-selection, +;; gui-backend-selection-owner-p, gui-backend-selection-exists-p are +;; the backend-dependent functions meant to access various kinds of +;; selections (CLIPBOARD, PRIMARY, SECONDARY). ;; - Higher-level: gui-select-text and gui-selection-value go together to ;; access the general notion of "GUI selection" for interoperation with other ;; applications. This can use either the clipboard or the primary selection, @@ -108,9 +109,10 @@ E.g. it doesn't exist under MS-Windows." :group 'killing :version "25.1") -;; We keep track of the last text selected here, so we can check the -;; current selection against it, and avoid passing back our own text -;; from gui-selection-value. We track both +;; We keep track of the last selection here, so we can check the +;; current selection against it, and avoid passing back with +;; gui-selection-value the same text we previously killed or +;; yanked. We track both ;; separately in case another X application only sets one of them ;; we aren't fooled by the PRIMARY or CLIPBOARD selection staying the same. @@ -119,22 +121,68 @@ E.g. it doesn't exist under MS-Windows." (defvar gui--last-selected-text-primary nil "The value of the PRIMARY selection last seen.") +(defvar gui--last-selection-timestamp-clipboard nil + "The timestamp of the CLIPBOARD selection last seen.") +(defvar gui--last-selection-timestamp-primary nil + "The timestamp of the PRIMARY selection last seen.") + +(defun gui--set-last-clipboard-selection (text) + "Save last clipboard selection. +Save the selected text, passed as argument, and for window +systems that support it, save the selection timestamp too." + (setq gui--last-selected-text-clipboard text) + (when (eq window-system 'x) + (setq gui--last-selection-timestamp-clipboard + (gui-backend-get-selection 'CLIPBOARD 'TIMESTAMP)))) + +(defun gui--set-last-primary-selection (text) + "Save last primary selection. +Save the selected text, passed as argument, and for window +systems that support it, save the selection timestamp too." + (setq gui--last-selected-text-primary text) + (when (eq window-system 'x) + (setq gui--last-selection-timestamp-primary + (gui-backend-get-selection 'PRIMARY 'TIMESTAMP)))) + +(defun gui--clipboard-selection-unchanged-p (text) + "Check whether the clipboard selection has changed. +Compare the selection text, passed as argument, with the text +from the last saved selection. For window systems that support +it, compare the selection timestamp too." + (and + (equal text gui--last-selected-text-clipboard) + (or (not (eq window-system 'x)) + (eq gui--last-selection-timestamp-clipboard + (gui-backend-get-selection 'CLIPBOARD 'TIMESTAMP))))) + +(defun gui--primary-selection-unchanged-p (text) + "Check whether the primary selection has changed. +Compare the selection text, passed as argument, with the text +from the last saved selection. For window systems that support +it, compare the selection timestamp too." + (and + (equal text gui--last-selected-text-primary) + (or (not (eq window-system 'x)) + (eq gui--last-selection-timestamp-primary + (gui-backend-get-selection 'PRIMARY 'TIMESTAMP))))) + + (defun gui-select-text (text) "Select TEXT, a string, according to the window system. -if `select-enable-clipboard' is non-nil, copy TEXT to the system's clipboard. +If `select-enable-clipboard' is non-nil, copy TEXT to the system's clipboard. If `select-enable-primary' is non-nil, put TEXT in the primary selection. MS-Windows does not have a \"primary\" selection." (when select-enable-primary (gui-set-selection 'PRIMARY text) - (setq gui--last-selected-text-primary text)) + (gui--set-last-primary-selection text)) (when select-enable-clipboard ;; When cutting, the selection is cleared and PRIMARY ;; set to the empty string. Prevent that, PRIMARY ;; should not be reset by cut (Bug#16382). (setq saved-region-selection text) (gui-set-selection 'CLIPBOARD text) - (setq gui--last-selected-text-clipboard text))) + (gui--set-last-clipboard-selection text))) (define-obsolete-function-alias 'x-select-text 'gui-select-text "25.1") (defcustom x-select-request-type nil @@ -175,6 +223,7 @@ decoded. If `gui-get-selection' signals an error, return nil." ;; some other window systems. (memq window-system '(x haiku)) (eq type 'CLIPBOARD) + ;; Should we unify this with gui--clipboard-selection-unchanged-p? (gui-backend-selection-owner-p type)) (let ((request-type (if (memq window-system '(x pgtk haiku)) (or x-select-request-type @@ -197,19 +246,17 @@ decoded. If `gui-get-selection' signals an error, return nil." (let ((text (gui--selection-value-internal 'CLIPBOARD))) (when (string= text "") (setq text nil)) - ;; When `select-enable-clipboard' is non-nil, - ;; killing/copying text (with, say, `C-w') will push the - ;; text to the clipboard (and store it in - ;; `gui--last-selected-text-clipboard'). We check - ;; whether the text on the clipboard is identical to this - ;; text, and if so, we report that the clipboard is - ;; empty. See (bug#27442) for further discussion about - ;; this DWIM action, and possible ways to make this check - ;; less fragile, if so desired. - (prog1 - (unless (equal text gui--last-selected-text-clipboard) - text) - (setq gui--last-selected-text-clipboard text))))) + ;; Check the CLIPBOARD selection for 'newness', i.e., + ;; whether it is different from the last time we did a + ;; yank operation or whether it was set by Emacs itself + ;; with a kill operation, since in both cases the text + ;; will already be in the kill ring. See (bug#27442) and + ;; (bug#53894) for further discussion about this DWIM + ;; action, and possible ways to make this check less + ;; fragile, if so desired. + (unless (gui--clipboard-selection-unchanged-p text) + (gui--set-last-clipboard-selection text) + text)))) (primary-text (when select-enable-primary (let ((text (gui--selection-value-internal 'PRIMARY))) @@ -217,10 +264,9 @@ decoded. If `gui-get-selection' signals an error, return nil." ;; Check the PRIMARY selection for 'newness', is it different ;; from what we remembered them to be last time we did a ;; cut/paste operation. - (prog1 - (unless (equal text gui--last-selected-text-primary) - text) - (setq gui--last-selected-text-primary text)))))) + (unless (gui--primary-selection-unchanged-p text) + (gui--set-last-primary-selection text) + text))))) ;; As we have done one selection, clear this now. (setq next-selection-coding-system nil) @@ -235,11 +281,11 @@ decoded. If `gui-get-selection' signals an error, return nil." ;; something like the following has happened since the last time ;; we looked at the selections: Application X set all the ;; selections, then Application Y set only one of them. - ;; In this case since we don't have - ;; timestamps there is no way to know what the 'correct' value to - ;; return is. The nice thing to do would be to tell the user we - ;; saw multiple possible selections and ask the user which was the - ;; one they wanted. + ;; In this case, for systems that support selection timestamps, we + ;; could return the newer. For systems that don't, there is no + ;; way to know what the 'correct' value to return is. The nice + ;; thing to do would be to tell the user we saw multiple possible + ;; selections and ask the user which was the one they wanted. (or clip-text primary-text) )) @@ -350,10 +396,10 @@ the formats available in the clipboard if TYPE is `CLIPBOARD'." (defun gui-set-selection (type data) "Make an X selection of type TYPE and value DATA. The argument TYPE (nil means `PRIMARY') says which selection, and -DATA specifies the contents. TYPE must be a symbol. \(It can also -be a string, which stands for the symbol with that name, but this -is considered obsolete.) DATA may be a string, a symbol, an -integer (or a cons of two integers or list of two integers). +DATA specifies the contents. TYPE must be a symbol. \(It can +also be a string, which stands for the symbol with that name, but +this is considered obsolete.) DATA may be a string, a symbol, or +an integer. The selection may also be a cons of two markers pointing to the same buffer, or an overlay. In these cases, the selection is considered to be the text @@ -485,7 +531,8 @@ two markers or an overlay. Otherwise, it is nil." (if eight-bit 'C_STRING 'STRING)))))))) (cond - ((eq type 'UTF8_STRING) + ((or (eq type 'UTF8_STRING) + (eq type 'text/plain\;charset=utf-8)) (if (or (not coding) (not (eq (coding-system-type coding) 'utf-8))) (setq coding 'utf-8)) @@ -497,6 +544,12 @@ two markers or an overlay. Otherwise, it is nil." (setq coding 'iso-8859-1)) (setq str (encode-coding-string str coding))) + ((eq type 'text/plain) + (if (or (not coding) + (not (eq (coding-system-type coding) 'charset))) + (setq coding 'ascii)) + (setq str (encode-coding-string str coding))) + ((eq type 'COMPOUND_TEXT) (if (or (not coding) (not (eq (coding-system-type coding) 'iso-2022))) @@ -539,31 +592,36 @@ two markers or an overlay. Otherwise, it is nil." (if len (xselect--int-to-cons len)))) -(defun xselect-convert-to-targets (_selection _type _value) - ;; return a vector of atoms, but remove duplicates first. - (let* ((all (cons 'TIMESTAMP - (cons 'MULTIPLE - (mapcar 'car selection-converter-alist)))) - (rest all)) - (while rest - (cond ((memq (car rest) (cdr rest)) - (setcdr rest (delq (car rest) (cdr rest)))) - ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret - (setcdr rest (cdr (cdr rest)))) - (t - (setq rest (cdr rest))))) - (apply 'vector all))) +(defun xselect-convert-to-targets (selection _type value) + ;; Return a vector of atoms, but remove duplicates first. + (apply #'vector + (delete-dups + `( TIMESTAMP MULTIPLE + . ,(delq '_EMACS_INTERNAL + (mapcar (lambda (conv) + (if (or (not (consp (cdr conv))) + (funcall (cadr conv) selection + (car conv) value)) + (car conv) + '_EMACS_INTERNAL)) + selection-converter-alist)))))) (defun xselect-convert-to-delete (selection _type _value) - (gui-backend-set-selection selection nil) + ;; This should be handled by the caller of `x-begin-drag'. + (unless (eq selection 'XdndSelection) + (gui-backend-set-selection selection nil)) ;; A return value of nil means that we do not know how to do this conversion, ;; and replies with an "error". A return value of NULL means that we have ;; done the conversion (and any side-effects) but have no value to return. 'NULL) -(defun xselect-convert-to-filename (_selection _type value) - (when (setq value (xselect--selection-bounds value)) - (xselect--encode-string 'TEXT (buffer-file-name (nth 2 value))))) +(defun xselect-convert-to-filename (selection _type value) + (if (not (eq selection 'XdndSelection)) + (when (setq value (xselect--selection-bounds value)) + (xselect--encode-string 'TEXT (buffer-file-name (nth 2 value)))) + (when (and (stringp value) + (file-exists-p value)) + (xselect--encode-string 'C_STRING value)))) (defun xselect-convert-to-charpos (_selection _type value) (when (setq value (xselect--selection-bounds value)) @@ -625,11 +683,50 @@ This function returns the string \"emacs\"." (when (eq selection 'CLIPBOARD) 'NULL)) +(defun xselect-convert-to-username (_selection _type _value) + (user-real-login-name)) + +(defun xselect-convert-to-text-uri-list (_selection _type value) + (when (and (stringp value) + (file-exists-p value)) + (concat (url-encode-url + ;; Uncomment the following code code in a better world where + ;; people write correct code that adds the hostname to the URI. + ;; Since most programs don't implement this properly, we omit the + ;; hostname so that copying files actually works. Most properly + ;; written programs will look at WM_CLIENT_MACHINE to determine + ;; the hostname anyway. (format "file://%s%s\n" (system-name) + ;; (expand-file-name value)) + (concat "file://" (expand-file-name value))) + "\n"))) + +(defun xselect-convert-to-xm-file (selection _type value) + (when (and (stringp value) + (file-exists-p value) + (eq selection 'XdndSelection)) + (xselect--encode-string 'C_STRING + (concat value [0])))) + +(defun xselect-uri-list-available-p (selection _type value) + "Return whether or not `text/uri-list' is a valid target for SELECTION. +VALUE is the local selection value of SELECTION." + (and (eq selection 'XdndSelection) + (stringp value) + (file-exists-p value))) + +(defun xselect-convert-xm-special (_selection _type _value) + "") + (setq selection-converter-alist '((TEXT . xselect-convert-to-string) (COMPOUND_TEXT . xselect-convert-to-string) (STRING . xselect-convert-to-string) (UTF8_STRING . xselect-convert-to-string) + (text/plain . xselect-convert-to-string) + (text/plain\;charset=utf-8 . xselect-convert-to-string) + (text/uri-list . (xselect-uri-list-available-p . xselect-convert-to-text-uri-list)) + (text/x-xdnd-username . xselect-convert-to-username) + (FILE . (xselect-uri-list-available-p . xselect-convert-to-xm-file)) (TARGETS . xselect-convert-to-targets) (LENGTH . xselect-convert-to-length) (DELETE . xselect-convert-to-delete) @@ -645,7 +742,9 @@ This function returns the string \"emacs\"." (ATOM . xselect-convert-to-atom) (INTEGER . xselect-convert-to-integer) (SAVE_TARGETS . xselect-convert-to-save-targets) - (_EMACS_INTERNAL . xselect-convert-to-identity))) + (_EMACS_INTERNAL . xselect-convert-to-identity) + (XmTRANSFER_SUCCESS . xselect-convert-xm-special) + (XmTRANSFER_FAILURE . xselect-convert-xm-special))) (provide 'select) diff --git a/lisp/server.el b/lisp/server.el index da60f1cda77..763cf27f7ac 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -779,7 +779,8 @@ by the current Emacs process, use the `server-process' variable." (condition-case nil (if server-use-tcp (with-temp-buffer - (insert-file-contents-literally (expand-file-name name server-auth-dir)) + (setq default-directory server-auth-dir) + (insert-file-contents-literally (expand-file-name name)) (or (and (looking-at "127\\.0\\.0\\.1:[0-9]+ \\([0-9]+\\)") (assq 'comm (process-attributes diff --git a/lisp/ses.el b/lisp/ses.el index 45e323e8051..7a9b35d749a 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -84,17 +84,14 @@ (defcustom ses-initial-size '(1 . 1) "Initial size of a new spreadsheet, as a cons (NUMROWS . NUMCOLS)." - :group 'ses :type '(cons (integer :tag "numrows") (integer :tag "numcols"))) (defcustom ses-initial-column-width 7 "Initial width of columns in a new spreadsheet." - :group 'ses :type '(integer :match (lambda (widget value) (> value 0)))) (defcustom ses-initial-default-printer "%.7g" "Initial default printer for a new spreadsheet." - :group 'ses :type '(choice string (list :tag "Parenthesized string" string) function)) @@ -103,15 +100,30 @@ "Things to do after entering a value into a cell. An abnormal hook that usually runs a cursor-movement function. Each function is called with ARG=1." - :group 'ses :type 'hook :options '(forward-char backward-char next-line previous-line)) (defcustom ses-mode-hook nil "Hook functions to be run upon entering SES mode." - :group 'ses :type 'hook) +(defcustom ses-jump-cell-name-function #'upcase + "Function to process the string passed to function ‘ses-jump’. +Set it to 'identity to make no change. +Set it to 'upcase to make cell name change case isensitive. + + May return + +* a string, in this case this must be a cell name. +* a (row . col) cons cell, in this case that must be valid cell coordinates." + :type 'function) + +(defcustom ses-jump-prefix-function #'ses-jump-prefix + "Function that takes the prefix argument passed to function ‘ses-jump’. +It may return the same sort of thing as ‘ses-jump-cell-name-function’." + :type 'function) + + ;;---------------------------------------------------------------------------- ;; Global variables and constants @@ -233,7 +245,7 @@ Used for listing local printers or renamed cells.") (suppress-keymap newmap t) ;;These keys insert themselves as the beginning of a numeric value (dotimes (x (length numeric)) - (define-key newmap (substring numeric x (1+ x)) 'ses-read-cell)) + (define-key newmap (substring numeric x (1+ x)) #'ses-read-cell)) (define-key newmap [remap clipboard-kill-region] #'ses-kill-override) (define-key newmap [remap end-of-line] #'ses-end-of-line) (define-key newmap [remap kill-line] #'ses-delete-row) @@ -345,7 +357,7 @@ printer and then modify its output.") (t (error "Unexpected elements `%S' in list `ses-localvars'" x))))) ;;; This variable is documented as being permitted in file-locals: -(put 'ses--symbolic-formulas 'safe-local-variable 'consp) +(put 'ses--symbolic-formulas 'safe-local-variable #'consp) (defconst ses-paramlines-plist '(ses--col-widths -5 ses--col-printers -4 ses--default-printer -3 @@ -1056,8 +1068,7 @@ the old and FORCE is nil." (defcustom ses-self-reference-early-detection nil "Non-nil if cycle detection is early for cells that refer to themselves." :version "24.1" - :type 'boolean - :group 'ses) + :type 'boolean) (defun ses-update-cells (list &optional force) "Recalculate cells in LIST, checking for dependency loops. @@ -2064,8 +2075,8 @@ formula: ;; Not to use tab characters for safe (tabs may do bad for column ;; calculation). indent-tabs-mode nil) - (1value (add-hook 'change-major-mode-hook 'ses-cleanup nil t)) - (1value (add-hook 'kill-buffer-hook 'ses-killbuffer-hook nil t)) + (1value (add-hook 'change-major-mode-hook #'ses-cleanup nil t)) + (1value (add-hook 'kill-buffer-hook #'ses-killbuffer-hook nil t)) (cl-pushnew (current-buffer) ses--ses-buffer-list :test 'eq) ;; This makes revert impossible if the buffer is read-only. ;; (1value (add-hook 'before-revert-hook 'ses-cleanup nil t)) @@ -2116,8 +2127,8 @@ formula: ;; find-alternate-file, post-command-hook doesn't get run for some reason, ;; so use an idle timer to make sure. (setq ses--deferred-narrow 'ses-mode) - (1value (add-hook 'post-command-hook 'ses-command-hook nil t)) - (run-with-idle-timer 0.01 nil 'ses-command-hook) + (1value (add-hook 'post-command-hook #'ses-command-hook nil t)) + (run-with-idle-timer 0.01 nil #'ses-command-hook) (run-mode-hooks 'ses-mode-hook))) (put 'ses-mode 'mode-class 'special) @@ -2233,24 +2244,43 @@ Based on the current set of columns and `window-hscroll' position." ;;---------------------------------------------------------------------------- ;; Redisplay and recalculation ;;---------------------------------------------------------------------------- +(defun ses-jump-prefix (prefix-int) + "Convert an integer (unversal prefix) into a (ROW . COL). +Does it by numbering cells starting from 0 from top left to bottom right, +going row by row." + (and (>= prefix-int 0) + (< prefix-int (* ses--numcols ses--numrows)) + (cons (/ prefix-int ses--numcols) (% prefix-int ses--numcols)))) -(defun ses-jump (sym) + +(defun ses-jump (&optional sym) "Move point to cell SYM." - (interactive (let* (names - (s (completing-read - "Jump to cell: " - (and ses--named-cell-hashmap - (progn (maphash (lambda (key _val) - (push (symbol-name key) names)) - ses--named-cell-hashmap) - names))))) - (if (string= s "") - (user-error "Invalid cell name") - (list (intern s))))) - (let ((rowcol (ses-sym-rowcol sym))) + (interactive "P") + (setq sym + (if current-prefix-arg + (funcall ses-jump-prefix-function (prefix-numeric-value sym)) + (or sym + (completing-read + "Jump to cell: " + (and ses--named-cell-hashmap + (let (names) + (maphash (lambda (key _val) + (push (symbol-name key) names)) + ses--named-cell-hashmap) + names)))))) + (and (stringp sym) + (not (and ses--named-cell-hashmap (gethash (intern sym) ses--named-cell-hashmap))) + (setq sym (funcall ses-jump-cell-name-function sym))) + (if (stringp sym) + (if (string= sym "") + (user-error "Empty cell name") + (setq sym (intern sym)))) + (let ((rowcol (if (consp sym) + (prog1 sym (setq sym (ses-cell-symbol (car sym) (cdr sym)))) + (ses-sym-rowcol sym)))) (or rowcol (error "Invalid cell name")) (if (eq (symbol-value sym) '*skip*) - (error "Cell is covered by preceding cell")) + (error "Cell is covered by preceding cell")) (ses-goto-print (car rowcol) (cdr rowcol)))) (defun ses-jump-safe (cell) @@ -2301,7 +2331,7 @@ Narrow to print area if optional argument NONARROW is nil." "Recalculate and reprint the current cell or range. If CURCELL is non nil use it as current cell or range -without any check, otherwise function (ses-check-curcell 'range) +without any check, otherwise function (ses-check-curcell \\='range) is called. For an individual cell, shows the error if the formula or printer @@ -2507,7 +2537,7 @@ Return nil if cell formula was unsafe and user declined confirmation." ;; Position cursor inside close-quote. (setq initial (cons initial (length initial)))) (dolist (key ses-completion-keys) - (define-key ses-mode-edit-map key 'ses-edit-cell-complete-symbol)) + (define-key ses-mode-edit-map key #'ses-edit-cell-complete-symbol)) ;; make it globally visible, so that it can be visible from the minibuffer. (setq ses--completion-table ses--named-cell-hashmap) (list row col @@ -2604,8 +2634,9 @@ With prefix, deletes several cells." ;;---------------------------------------------------------------------------- (defun ses-read-printer-complete-symbol () (interactive) - (let ((completion-at-point-functions (cons 'ses--read-printer-completion-at-point-function - completion-at-point-functions))) + (let ((completion-at-point-functions + (cons #'ses--read-printer-completion-at-point-function + completion-at-point-functions))) (completion-at-point))) (defun ses--read-printer-completion-at-point-function () @@ -2647,7 +2678,7 @@ canceled." (setq default "") (setq prompt (format-prompt prompt default))) (dolist (key ses-completion-keys) - (define-key ses-mode-edit-map key 'ses-read-printer-complete-symbol)) + (define-key ses-mode-edit-map key #'ses-read-printer-complete-symbol)) ;; make it globally visible, so that it can be visible from the minibuffer. (setq ses--completion-table ses--local-printer-hashmap) (let ((new (read-from-minibuffer prompt @@ -3743,15 +3774,15 @@ DEFINITION shall be either a string formatter, e.g.: \"%.2f\" or (\"%.2f\") for left alignment. or a lambda expression, e.g. for formatting in ISO format dates -created with a '(calcFunc-date YEAR MONTH DAY)' formula: +created with a `(calcFunc-date YEAR MONTH DAY)' formula: (lambda (x) (cond ((null val) \"\") - ((eq (car-safe x) 'date) - (let ((calc-format-date '(X YYYY \"-\" MM \"-\" DD))) + ((eq (car-safe x) \\='date) + (let ((calc-format-date \\='(X YYYY \"-\" MM \"-\" DD))) (math-format-date x))) - (t (ses-center-span val ?# 'ses-prin1)))) + (t (ses-center-span val ?# \\='ses-prin1)))) If NAME is already used to name a local printer function, then the current definition is proposed as default value, and the @@ -4079,17 +4110,19 @@ SPAN indicates how many rightward columns to include in width (default = 0)." (ses-center value span ?- printer)) (defun ses-dashfill-span (value &optional printer) - "Print VALUE, centered using dashes within the span that starts in the -current column and continues until the next nonblank column." + "Print VALUE, centered using dashes. +Centers within the span that starts in the current column and continues +until the next nonblank column." (ses-center-span value ?- printer)) (defun ses-tildefill-span (value &optional printer) - "Print VALUE, centered using tildes within the span that starts in the -current column and continues until the next nonblank column." + "Print VALUE, centered using tildes. +Centers within the span that starts in the current column and continues +until the next nonblank column." (ses-center-span value ?~ printer)) (defun ses-prin1 (value) - "Shorthand for '(prin1-to-string VALUE t)'. + "Shorthand for `(prin1-to-string VALUE t)'. Useful to handle the default behavior in custom lambda based printer functions." (prin1-to-string value t)) diff --git a/lisp/shell.el b/lisp/shell.el index 6198214abee..47887433d9f 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -98,6 +98,7 @@ (require 'comint) (require 'pcomplete) (eval-when-compile (require 'files-x)) ;with-connection-local-variables +(require 'subr-x) ;;; Customization and Buffer Variables @@ -527,7 +528,7 @@ Shell buffers. It implements `shell-completion-execonly' for the shell. This is useful for entering passwords. Or, add the function `comint-watch-for-password-prompt' to `comint-output-filter-functions'. -If you want to make multiple shell buffers, rename the `*shell*' buffer +If you want to make multiple shell buffers, rename the \"*shell*\" buffer using \\[rename-buffer] or \\[rename-uniquely] and start a new shell. If you want to make shell buffers limited in length, add the function @@ -570,7 +571,14 @@ the initialization of the input ring history, and history expansion. Variables `comint-output-filter-functions', a hook, and `comint-scroll-to-bottom-on-input' and `comint-scroll-to-bottom-on-output' control whether input and output cause the window to scroll to the end of the -buffer." +buffer. + +By default, shell mode does nothing special when it receives a +\"bell\" character (C-g or ^G). If you + (add-hook \\='comint-output-filter-functions #\\='shell-filter-ring-bell nil t) +from `shell-mode-hook', Emacs will call the `ding' function +whenever it receives the bell character in output from a +command." :interactive nil (setq comint-prompt-regexp shell-prompt-pattern) (shell-completion-vars) @@ -681,6 +689,13 @@ This function can be put on `comint-preoutput-filter-functions'." (replace-regexp-in-string "[\C-a\C-b]" "" string t t) string)) +(defun shell-filter-ring-bell (string) + "Call `ding' if STRING contains a \"^G\" character. +This function can be put on `comint-output-filter-functions'." + (when (string-search "\a" string) + (ding)) + string) + (defun shell-write-history-on-exit (process event) "Called when the shell process is stopped. @@ -783,17 +798,26 @@ Make the shell buffer the current buffer, and return it. (getenv "ESHELL") shell-file-name)) (name (file-name-nondirectory prog)) (startfile (concat "~/.emacs_" name)) - (xargs-name (intern-soft (concat "explicit-" name "-args")))) + (xargs-name (intern-soft (concat "explicit-" name "-args"))) + (start-point (point))) (unless (file-exists-p startfile) (setq startfile (locate-user-emacs-file (concat "init_" name ".sh")))) (setq-local shell--start-prog (file-name-nondirectory prog)) (apply #'make-comint-in-buffer "shell" buffer prog - (if (file-exists-p startfile) startfile) + nil (if (and xargs-name (boundp xargs-name)) (symbol-value xargs-name) '("-i"))) - (shell-mode)))) + (shell-mode) + (when (file-exists-p startfile) + ;; Wait until the prompt has appeared. + (while (= start-point (point)) + (sleep-for 0.1)) + (shell-eval-command + (with-temp-buffer + (insert-file-contents startfile) + (buffer-string))))))) buffer) ;;; Directory tracking @@ -1009,7 +1033,9 @@ Environment variables are expanded, see function `substitute-in-file-name'." "Toggle directory tracking in this shell buffer (Shell Dirtrack mode). The `dirtrack' package provides an alternative implementation of -this feature; see the function `dirtrack-mode'." +this feature; see the function `dirtrack-mode'. Also see +`comint-osc-directory-tracker' for an escape-sequence based +solution." :lighter nil (setq list-buffers-directory (if shell-dirtrack-mode default-directory)) (if shell-dirtrack-mode @@ -1026,77 +1052,45 @@ this feature; see the function `dirtrack-mode'." "Resync the buffer's idea of the current directory stack. This command queries the shell with the command bound to `shell-dirstack-query' (default \"dirs\"), reads the next -line output and parses it to form the new directory stack. -DON'T issue this command unless the buffer is at a shell prompt. -Also, note that if some other subprocess decides to do output -immediately after the query, its output will be taken as the -new directory stack -- you lose. If this happens, just do the -command again." +line output and parses it to form the new directory stack." (interactive) - (let* ((proc (get-buffer-process (current-buffer))) - (pmark (process-mark proc)) - (started-at-pmark (= (point) (marker-position pmark)))) - (save-excursion - (goto-char pmark) - ;; If the process echoes commands, don't insert a fake command in - ;; the buffer or it will appear twice. - (unless comint-process-echoes - (insert shell-dirstack-query) (insert "\n")) - (sit-for 0) ; force redisplay - (comint-send-string proc shell-dirstack-query) - (comint-send-string proc "\n") - (set-marker pmark (point)) - (let ((pt (point)) - (regexp - (concat - (if comint-process-echoes - ;; Skip command echo if the process echoes - (concat "\\(" (regexp-quote shell-dirstack-query) "\n\\)") - "\\(\\)") - "\\(.+\n\\)"))) - ;; This extra newline prevents the user's pending input from spoofing us. - (insert "\n") (backward-char 1) - ;; Wait for one line. - (while (not (looking-at regexp)) - (accept-process-output proc) - (goto-char pt))) - (goto-char pmark) (delete-char 1) ; remove the extra newline - ;; That's the dirlist. Grab it & parse it. - (let* ((dls (buffer-substring-no-properties - (match-beginning 0) (1- (match-end 0)))) - (dlsl nil) - (pos 0) - (ds nil)) - ;; Split the dirlist into whitespace and non-whitespace chunks. - ;; dlsl will be a reversed list of tokens. - (while (string-match "\\(\\S-+\\|\\s-+\\)" dls pos) - (push (match-string 1 dls) dlsl) - (setq pos (match-end 1))) + (let* ((dls (car + (last + (string-lines + (string-chop-newline + (shell-eval-command (concat shell-dirstack-query "\n"))))))) + (dlsl nil) + (pos 0) + (ds nil)) + ;; Split the dirlist into whitespace and non-whitespace chunks. + ;; dlsl will be a reversed list of tokens. + (while (string-match "\\(\\S-+\\|\\s-+\\)" dls pos) + (push (match-string 1 dls) dlsl) + (setq pos (match-end 1))) - ;; Prepend trailing entries until they form an existing directory, - ;; whitespace and all. Discard the next whitespace and repeat. - (while dlsl - (let ((newelt "") - tem1 tem2) - (while newelt - ;; We need tem1 because we don't want to prepend - ;; `comint-file-name-prefix' repeatedly into newelt via tem2. - (setq tem1 (pop dlsl) - tem2 (concat comint-file-name-prefix tem1 newelt)) - (cond ((file-directory-p tem2) - (push tem2 ds) - (when (string= " " (car dlsl)) - (pop dlsl)) - (setq newelt nil)) - (t - (setq newelt (concat tem1 newelt))))))) + ;; Prepend trailing entries until they form an existing directory, + ;; whitespace and all. Discard the next whitespace and repeat. + (while dlsl + (let ((newelt "") + tem1 tem2) + (while newelt + ;; We need tem1 because we don't want to prepend + ;; `comint-file-name-prefix' repeatedly into newelt via tem2. + (setq tem1 (pop dlsl) + tem2 (concat comint-file-name-prefix tem1 newelt)) + (cond ((file-directory-p tem2) + (push tem2 ds) + (when (string= " " (car dlsl)) + (pop dlsl)) + (setq newelt nil)) + (t + (setq newelt (concat tem1 newelt))))))) - (with-demoted-errors "Couldn't cd: %s" - (shell-cd (car ds)) - (setq shell-dirstack (cdr ds) - shell-last-dir (car shell-dirstack)) - (shell-dirstack-message)))) - (if started-at-pmark (goto-char (marker-position pmark))))) + (with-demoted-errors "Couldn't cd: %s" + (shell-cd (car ds)) + (setq shell-dirstack (cdr ds) + shell-last-dir (car shell-dirstack)) + (shell-dirstack-message)))) ;; For your typing convenience: (defalias 'dirs 'shell-resync-dirs) @@ -1431,6 +1425,36 @@ Returns t if successful." (point-max) (shell--prompt-begin-position)))))) +(defun shell-eval-command (command) + "Eval COMMAND in the current shell process and return the result." + (let* ((proc (get-buffer-process (current-buffer))) + (old-filter (process-filter proc)) + (result "") + prev) + (unwind-protect + (progn + (set-process-filter + proc + (lambda (_proc string) + (setq result (concat result string)))) + (process-send-string proc command) + ;; Wait until we get a prompt (which will be a line without + ;; a newline). This is far from fool-proof -- if something + ;; outputs incomplete data and then sleeps, we'll think + ;; we've received the prompt. + (while (not (let* ((lines (string-lines result)) + (last (car (last lines)))) + (and (length> lines 0) + (not (equal last "")) + (or (not prev) + (not (equal last prev))) + (setq prev last)))) + (accept-process-output proc 0 100))) + ;; Restore old filter. + (set-process-filter proc old-filter)) + ;; Remove the prompt. + (replace-regexp-in-string "\n.*\\'" "\n" result))) + (provide 'shell) ;;; shell.el ends here diff --git a/lisp/simple.el b/lisp/simple.el index accc119e2b3..861d9eefde9 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -222,7 +222,7 @@ rejected, and the function returns nil." (defcustom next-error-find-buffer-function #'ignore "Function called to find a `next-error' capable buffer. -This functions takes the same three arguments as the function +This function takes the same three arguments as the function `next-error-find-buffer', and should return the buffer to be used by the subsequent invocation of the command `next-error' and `previous-error'. @@ -2357,6 +2357,49 @@ maps." (with-suppressed-warnings ((interactive-only execute-extended-command)) (execute-extended-command prefixarg command-name typed))) +(cl-defgeneric function-documentation (function) + "Extract the raw docstring info from FUNCTION. +FUNCTION is expected to be a function value rather than, say, a mere symbol. +This is intended to be specialized via `cl-defmethod' but not called directly: +if you need a function's documentation use `documentation' which will call this +function as needed." + (let ((docstring-p (lambda (doc) + ;; A docstring can be either a string or a reference + ;; into either the `etc/DOC' or a `.elc' file. + (or (stringp doc) + (fixnump doc) (fixnump (cdr-safe doc)))))) + (pcase function + ((pred byte-code-function-p) + (when (> (length function) 4) + (let ((doc (aref function 4))) + (when (funcall docstring-p doc) doc)))) + ((or (pred stringp) (pred vectorp)) "Keyboard macro.") + (`(keymap . ,_) + "Prefix command (definition is a keymap associating keystrokes with commands).") + ((or `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body) + `(autoload ,_file . ,body)) + (let ((doc (car body))) + (when (and (funcall docstring-p doc) + ;; Handle a doc reference--but these never come last + ;; in the function body, so reject them if they are last. + (or (cdr body) (eq 'autoload (car-safe function)))) + doc))) + (_ (signal 'invalid-function (list function)))))) + +(cl-defmethod function-documentation ((function accessor)) + (oclosure--accessor-docstring function)) ;; FIXME: η-reduce! + +;; This should be in `oclosure.el' but that file is loaded before `cl-generic'. +(cl-defgeneric oclosure-interactive-form (_function) + "Return the interactive form of FUNCTION or nil if none. +This is called by `interactive-form' when invoked on OClosures. +It should return either nil or a two-element list of the form (interactive FORM) +where FORM is like the first arg of the `interactive' special form. +Add your methods to this generic function, but always call `interactive-form' +instead." + ;; (interactive-form function) + nil) + (defun command-execute (cmd &optional record-flag keys special) ;; BEWARE: Called directly from the C code. "Execute CMD as an editor command. @@ -2840,6 +2883,7 @@ Intended to be added to `minibuffer-setup-hook'." #'minibuffer-history-isearch-wrap) (setq-local isearch-push-state-function #'minibuffer-history-isearch-push-state) + (setq-local isearch-lazy-count nil) (add-hook 'isearch-mode-end-hook 'minibuffer-history-isearch-end nil t)) (defun minibuffer-history-isearch-end () @@ -2975,12 +3019,12 @@ the minibuffer contents." (defconst undo-equiv-table (make-hash-table :test 'eq :weakness t) "Table mapping redo records to the corresponding undo one. -A redo record for an undo in region maps to 'undo-in-region. +A redo record for an undo in region maps to `undo-in-region'. A redo record for ordinary undo maps to the following (earlier) undo. A redo record that undoes to the beginning of the undo list maps to t. In the rare case where there are (erroneously) consecutive nil's in `buffer-undo-list', `undo' maps the previous valid undo record to -'empty, if the previous record is a redo record, `undo' doesn't change +`empty', if the previous record is a redo record, `undo' doesn't change its mapping. To be clear, a redo record is just an undo record, the only difference @@ -3890,7 +3934,10 @@ to the end of the list of defaults just after the default value." (defvar minibuffer-local-shell-command-map (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) - (define-key map "\t" 'completion-at-point) + (define-key map "\t" #'completion-at-point) + (define-key map [M-up] #'minibuffer-previous-completion) + (define-key map [M-down] #'minibuffer-next-completion) + (define-key map [?\M-\r] #'minibuffer-choose-completion) map) "Keymap used for completing shell commands in minibuffer.") @@ -4260,25 +4307,21 @@ impose the use of a shell (with its need to quote arguments)." (cond ((eq async-shell-command-buffer 'confirm-kill-process) ;; If will kill a process, query first. - (if (yes-or-no-p "A command is running in the default buffer. Kill it? ") - (kill-process proc) - (user-error "Shell command in progress"))) + (shell-command--same-buffer-confirm "Kill it") + (kill-process proc)) ((eq async-shell-command-buffer 'confirm-new-buffer) ;; If will create a new buffer, query first. - (if (yes-or-no-p "A command is running in the default buffer. Use a new buffer? ") - (setq buffer (generate-new-buffer bname)) - (user-error "Shell command in progress"))) + (shell-command--same-buffer-confirm "Use a new buffer") + (setq buffer (generate-new-buffer bname))) ((eq async-shell-command-buffer 'new-buffer) ;; It will create a new buffer. (setq buffer (generate-new-buffer bname))) ((eq async-shell-command-buffer 'confirm-rename-buffer) ;; If will rename the buffer, query first. - (if (yes-or-no-p "A command is running in the default buffer. Rename it? ") - (progn - (with-current-buffer buffer - (rename-uniquely)) - (setq buffer (get-buffer-create bname))) - (user-error "Shell command in progress"))) + (shell-command--same-buffer-confirm "Rename it") + (with-current-buffer buffer + (rename-uniquely)) + (setq buffer (get-buffer-create bname))) ((eq async-shell-command-buffer 'rename-buffer) ;; It will rename the buffer. (with-current-buffer buffer @@ -4326,6 +4369,24 @@ impose the use of a shell (with its need to quote arguments)." (shell-command-on-region (point) (point) command output-buffer nil error-buffer))))))) +(defun shell-command--same-buffer-confirm (action) + (let ((help-form + (format + "There's a command already running in the default buffer, +so we can't start a new one in the same one. + +Answering \"yes\" will %s. + +Answering \"no\" will exit without doing anything, and won't +start the new command. + +Also see the `async-shell-command-buffer' variable." + (downcase action)))) + (unless (yes-or-no-p + (format "A command is running in the default buffer. %s? " + action)) + (user-error "Shell command in progress")))) + (defun max-mini-window-lines (&optional frame) "Compute maximum number of lines for echo area in FRAME. As defined by `max-mini-window-height'. FRAME defaults to the @@ -5253,7 +5314,7 @@ If `kill-append-merge-undo' is non-nil, remove the last undo boundary in the current buffer." (let ((cur (car kill-ring))) (kill-new (if before-p (concat string cur) (concat cur string)) - (or (string= cur "") + (or (= (length cur) 0) (null (get-text-property 0 'yank-handler cur))))) (when (and kill-append-merge-undo (not buffer-read-only)) (let ((prev buffer-undo-list) @@ -5421,7 +5482,7 @@ This command's old key binding has been given to `kill-ring-save'." (let ((str (if region (funcall region-extract-function nil) (filter-buffer-substring beg end)))) - (if (eq last-command 'kill-region) + (if (eq last-command 'kill-region) (kill-append str (< end beg)) (kill-new str))) (setq deactivate-mark t) @@ -6482,27 +6543,38 @@ An example is a rectangular region handled as a list of separate contiguous regions for each line." (cdr (region-bounds))) +(defun redisplay--unhighlight-overlay-function (rol) + "If ROL is an overlay, call `delete-overlay'." + (when (overlayp rol) (delete-overlay rol))) + (defvar redisplay-unhighlight-region-function - (lambda (rol) (when (overlayp rol) (delete-overlay rol)))) + #'redisplay--unhighlight-overlay-function + "Function to remove the region-highlight overlay.") + +(defun redisplay--highlight-overlay-function (start end window rol &optional face) + "Update the overlay ROL in WINDOW with FACE in range START-END." + (unless face (setq face 'region)) + (if (not (overlayp rol)) + (let ((nrol (make-overlay start end))) + (funcall redisplay-unhighlight-region-function rol) + (overlay-put nrol 'window window) + (overlay-put nrol 'face face) + ;; Normal priority so that a large region doesn't hide all the + ;; overlays within it, but high secondary priority so that if it + ;; ends/starts in the middle of a small overlay, that small overlay + ;; won't hide the region's boundaries. + (overlay-put nrol 'priority '(nil . 100)) + nrol) + (unless (eq (overlay-get rol 'face) face) + (overlay-put rol 'face face)) + (unless (and (eq (overlay-buffer rol) (current-buffer)) + (eq (overlay-start rol) start) + (eq (overlay-end rol) end)) + (move-overlay rol start end (current-buffer))) + rol)) (defvar redisplay-highlight-region-function - (lambda (start end window rol) - (if (not (overlayp rol)) - (let ((nrol (make-overlay start end))) - (funcall redisplay-unhighlight-region-function rol) - (overlay-put nrol 'window window) - (overlay-put nrol 'face 'region) - ;; Normal priority so that a large region doesn't hide all the - ;; overlays within it, but high secondary priority so that if it - ;; ends/starts in the middle of a small overlay, that small overlay - ;; won't hide the region's boundaries. - (overlay-put nrol 'priority '(nil . 100)) - nrol) - (unless (and (eq (overlay-buffer rol) (current-buffer)) - (eq (overlay-start rol) start) - (eq (overlay-end rol) end)) - (move-overlay rol start end (current-buffer))) - rol)) + #'redisplay--highlight-overlay-function "Function to move the region-highlight overlay. This function is called with four parameters, START, END, WINDOW and OVERLAY. If OVERLAY is nil, a new overlay is created. In @@ -6527,8 +6599,33 @@ The overlay is returned by the function.") (funcall redisplay-highlight-region-function start end window rol))) (unless (equal new rol) - (set-window-parameter window 'internal-region-overlay - new)))))) + (set-window-parameter window 'internal-region-overlay new)))))) + +(defcustom cursor-face-highlight-nonselected-window nil + "Non-nil means highlight text with `cursor-face' even in nonselected windows. +This variable is similar to `highlight-nonselected-windows'." + :local t + :type 'boolean + :version "29.1") + +(defun redisplay--update-cursor-face-highlight (window) + "Highlights the overlay used to highlight text with cursor-face." + (let ((rol (window-parameter window 'internal-cursor-face-overlay))) + (if-let* (((or cursor-face-highlight-nonselected-window + (eq window (selected-window)) + (and (window-minibuffer-p) + (eq window (minibuffer-selected-window))))) + (pt (window-point window)) + (cursor-face (get-text-property pt 'cursor-face))) + (let* ((start (previous-single-property-change + (1+ pt) 'cursor-face nil (point-min))) + (end (next-single-property-change + pt 'cursor-face nil (point-max))) + (new (redisplay--highlight-overlay-function + start end window rol cursor-face))) + (unless (equal new rol) + (set-window-parameter window 'internal-cursor-face-overlay new))) + (redisplay--unhighlight-overlay-function rol)))) (defvar pre-redisplay-functions (list #'redisplay--update-region-highlight) "Hook run just before redisplay. @@ -6536,6 +6633,15 @@ It is called in each window that is to be redisplayed. It takes one argument, which is the window that will be redisplayed. When run, the `current-buffer' is set to the buffer displayed in that window.") +(define-minor-mode cursor-face-highlight-mode + "When enabled, respect the cursor-face property." + :global nil + (if cursor-face-highlight-mode + (add-hook 'pre-redisplay-functions + #'redisplay--update-cursor-face-highlight nil t) + (remove-hook 'pre-redisplay-functions + #'redisplay--update-cursor-face-highlight t))) + (defun redisplay--pre-redisplay-functions (windows) (with-demoted-errors "redisplay--pre-redisplay-functions: %S" (if (null windows) @@ -6545,9 +6651,11 @@ is set to the buffer displayed in that window.") (with-current-buffer (window-buffer win) (run-hook-with-args 'pre-redisplay-functions win)))))) -(add-function :before pre-redisplay-function - #'redisplay--pre-redisplay-functions) - +(when (eq pre-redisplay-function #'ignore) + ;; Override the default set in the C code. + ;; This is not done using `add-function' so as to loosen the bootstrap + ;; dependencies. + (setq pre-redisplay-function #'redisplay--pre-redisplay-functions)) (defvar-local mark-ring nil "The list of former marks of the current buffer, most recent first.") @@ -9071,6 +9179,16 @@ Its value is a list of the form (START END) where START is the place where the completion should be inserted and END (if non-nil) is the end of the text to replace. If END is nil, point is used instead.") +(defvar completion-base-affixes nil + "Base context of the text corresponding to the shown completions. +This variable is used in the *Completions* buffer. +Its value is a list of the form (PREFIX SUFFIX) where PREFIX is the text +before the place where completion should be inserted, and SUFFIX is the text +after the completion.") + +(defvar completion-use-base-affixes nil + "Non-nil means to restore original prefix and suffix in the minibuffer.") + (defvar completion-list-insert-choice-function #'completion--replace "Function to use to insert the text chosen in *Completions*. Called with three arguments (BEG END TEXT), it should replace the text @@ -9096,72 +9214,114 @@ This affects the commands `next-completion' and :version "29.1" :group 'completion) +(defcustom completion-auto-select nil + "Non-nil means to automatically select the *Completions* buffer. +When the value is t, pressing TAB will switch to the completion list +buffer when Emacs pops up a window showing that buffer. +If the value is `second-tab', then the first TAB will pop up the +window shwoing the completions list buffer, and the next TAB will +switch to that window. +See `completion-auto-help' for controlling when the window showing +the completions is popped up and down." + :type '(choice (const :tag "Don't auto-select completions window" nil) + (const :tag "Select completions window on first TAB" t) + (const :tag + "Select completions window on second TAB" second-tab)) + :version "29.1" + :group 'completion) + (defun previous-completion (n) "Move to the previous item in the completion list. With prefix argument N, move back N items (negative N means move -forward)." +forward). + +Also see the `completion-wrap-movement' variable." (interactive "p") (next-completion (- n))) (defun next-completion (n) "Move to the next item in the completion list. With prefix argument N, move N items (negative N means move -backward)." +backward). + +Also see the `completion-wrap-movement' variable." (interactive "p") - (let ((beg (point-min)) (end (point-max))) + (let ((prev (previous-single-property-change (point) 'mouse-face))) + (goto-char (cond + ((not prev) + (1- (next-single-property-change (point) 'mouse-face))) + ((/= prev (point)) + (point)) + (t prev)))) + + (let ((beg (point-min)) + (end (point-max)) + (tabcommand (member (this-command-keys) '("\t" [backtab]))) + prop) (catch 'bound (while (> n 0) ;; If in a completion, move to the end of it. (when (get-text-property (point) 'mouse-face) (goto-char (next-single-property-change (point) 'mouse-face nil end))) ;; If at the last completion option, wrap or skip to the - ;; minibuffer, if requested. - (when (and completion-wrap-movement (eobp)) - (if (and (member (this-command-keys) '("\t" [backtab])) - completion-auto-select) + ;; minibuffer, if requested. We can't use (eobp) because some + ;; extra text may be after the last candidate: ex: when + ;; completion-detailed + (setq prop (next-single-property-change (point) 'mouse-face nil end)) + (when (and completion-wrap-movement (eq end prop)) + (if (and completion-auto-select tabcommand) (throw 'bound nil) (goto-char (point-min)))) ;; Move to start of next one. (unless (get-text-property (point) 'mouse-face) (goto-char (next-single-property-change (point) 'mouse-face nil end))) (setq n (1- n))) - (while (< n 0) - (let ((prop (get-text-property (1- (point)) 'mouse-face))) - ;; If in a completion, move to the start of it. - (when (and prop (eq prop (get-text-property (point) 'mouse-face))) - (goto-char (previous-single-property-change - (point) 'mouse-face nil beg))) - ;; Move to end of the previous completion. - (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face)) - (goto-char (previous-single-property-change - (point) 'mouse-face nil beg))) - ;; If at the first completion option, wrap or skip to the - ;; minibuffer, if requested. - (when (and completion-wrap-movement (bobp)) - (if (and (member (this-command-keys) '("\t" [backtab])) - completion-auto-select) - (progn - (goto-char (next-single-property-change (point) 'mouse-face nil end)) - (throw 'bound nil)) - (goto-char (point-max)))) - ;; Move to the start of that one. + + (while (and (< n 0) (not (bobp))) + (setq prop (get-text-property (1- (point)) 'mouse-face)) + ;; If in a completion, move to the start of it. + (when (and prop (eq prop (get-text-property (point) 'mouse-face))) (goto-char (previous-single-property-change - (point) 'mouse-face nil beg)) - (setq n (1+ n))))) + (point) 'mouse-face nil beg))) + ;; Move to end of the previous completion. + (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face)) + (goto-char (previous-single-property-change + (point) 'mouse-face nil beg))) + ;; If at the first completion option, wrap or skip to the + ;; minibuffer, if requested. + (setq prop (previous-single-property-change (point) 'mouse-face nil beg)) + (when (and completion-wrap-movement (eq beg prop)) + (if (and completion-auto-select tabcommand) + (progn + (goto-char (next-single-property-change (point) 'mouse-face nil end)) + (throw 'bound nil)) + (goto-char (point-max)))) + ;; Move to the start of that one. + (goto-char (previous-single-property-change + (point) 'mouse-face nil beg)) + (setq n (1+ n)))) (when (/= 0 n) (switch-to-minibuffer)))) -(defun choose-completion (&optional event) +(defun choose-completion (&optional event no-exit no-quit) "Choose the completion at point. -If EVENT, use EVENT's position to determine the starting position." - (interactive (list last-nonmenu-event)) +If EVENT, use EVENT's position to determine the starting position. +With prefix argument NO-EXIT, insert the completion at point to the +minibuffer, but don't exit the minibuffer. When the prefix argument +is not provided, then whether to exit the minibuffer depends on the value +of `completion-no-auto-exit'. +If NO-QUIT is non-nil, insert the completion at point to the +minibuffer, but don't quit the completions window." + (interactive (list last-nonmenu-event current-prefix-arg)) ;; In case this is run via the mouse, give temporary modes such as ;; isearch a chance to turn off. (run-hooks 'mouse-leave-buffer-hook) (with-current-buffer (window-buffer (posn-window (event-start event))) (let ((buffer completion-reference-buffer) (base-position completion-base-position) + (base-affixes completion-base-affixes) (insert-function completion-list-insert-choice-function) + (completion-no-auto-exit (if no-exit t completion-no-auto-exit)) (choice (save-excursion (goto-char (posn-point (event-start event))) @@ -9179,12 +9339,14 @@ If EVENT, use EVENT's position to determine the starting position." (unless (buffer-live-p buffer) (error "Destination buffer is dead")) - (quit-window nil (posn-window (event-start event))) + (unless no-quit + (quit-window nil (posn-window (event-start event)))) (with-current-buffer buffer (choose-completion-string choice buffer - (or base-position + (or (and completion-use-base-affixes base-affixes) + base-position ;; If all else fails, just guess. (list (choose-completion-guess-base-position choice))) insert-function))))) @@ -9317,12 +9479,6 @@ Called from `temp-buffer-show-hook'." :version "22.1" :group 'completion) -(defcustom completion-auto-select nil - "Non-nil means to automatically select the *Completions* buffer." - :type 'boolean - :version "29.1" - :group 'completion) - ;; This function goes in completion-setup-hook, so that it is called ;; after the text of the completion list buffer is written. (defun completion-setup-function () @@ -9344,14 +9500,19 @@ Called from `temp-buffer-show-hook'." (buffer-substring (minibuffer-prompt-end) (point))))))) (with-current-buffer standard-output (let ((base-position completion-base-position) + (base-affixes completion-base-affixes) (insert-fun completion-list-insert-choice-function)) (completion-list-mode) (setq-local completion-base-position base-position) + (setq-local completion-base-affixes base-affixes) (setq-local completion-list-insert-choice-function insert-fun)) (setq-local completion-reference-buffer mainbuf) (if base-dir (setq default-directory base-dir)) (when completion-tab-width (setq tab-width completion-tab-width)) + ;; Maybe enable cursor completions-highlight. + (when completions-highlight-face + (cursor-face-highlight-mode 1)) ;; Maybe insert help string. (when completion-show-help (goto-char (point-min)) @@ -9360,7 +9521,7 @@ Called from `temp-buffer-show-hook'." (insert (substitute-command-keys "In this buffer, type \\[choose-completion] to \ select the completion near point.\n\n"))))) - (when completion-auto-select + (when (eq completion-auto-select t) (switch-to-completions))) (add-hook 'completion-setup-hook #'completion-setup-function) @@ -9368,22 +9529,18 @@ select the completion near point.\n\n"))))) (defun switch-to-completions () "Select the completion list window." (interactive) - (let ((window (or (get-buffer-window "*Completions*" 0) - ;; Make sure we have a completions window. - (progn (minibuffer-completion-help) - (get-buffer-window "*Completions*" 0))))) - (when window - (select-window window) + (when-let ((window (or (get-buffer-window "*Completions*" 0) + ;; Make sure we have a completions window. + (progn (minibuffer-completion-help) + (get-buffer-window "*Completions*" 0))))) + (select-window window) + (when (bobp) (cond ((and (memq this-command '(completion-at-point minibuffer-complete)) - (equal (this-command-keys) [backtab]) - (bobp)) + (equal (this-command-keys) [backtab])) (goto-char (point-max)) (previous-completion 1)) - ;; In the new buffer, go to the first completion. - ;; FIXME: Perhaps this should be done in `minibuffer-completion-help'. - ((bobp) - (next-completion 1)))))) + (t (next-completion 1)))))) (defun read-expression-switch-to-completions () "Select the completion list window while reading an expression." @@ -9909,7 +10066,7 @@ warning using STRING as the message.") (and list (boundp symbol) (or (eq symbol t) - (and (stringp (setq symbol (eval symbol))) + (and (stringp (setq symbol (symbol-value symbol))) (string-match-p (nth 2 list) symbol))) (display-warning package (nth 3 list) :warning))) (error nil))) @@ -10056,6 +10213,17 @@ This is an integer indicating the UTC offset in seconds, i.e., the number of seconds east of Greenwich.") ) +(defun scratch-buffer () + "Switch to the \*scratch\* buffer. +If the buffer doesn't exist, create it first." + (interactive) + (if (get-buffer "*scratch*") + (pop-to-buffer-same-window "*scratch*") + (pop-to-buffer-same-window (get-buffer-create "*scratch*")) + (when initial-scratch-message + (insert initial-scratch-message)) + (funcall initial-major-mode))) + (provide 'simple) diff --git a/lisp/sort.el b/lisp/sort.el index 90eee01caf4..d04f075abd1 100644 --- a/lisp/sort.el +++ b/lisp/sort.el @@ -29,6 +29,8 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) + (defgroup sort nil "Commands to sort text in an Emacs buffer." :group 'data) @@ -111,7 +113,8 @@ as start and end positions), and with `string<' otherwise." (lambda (a b) (string< (car a) (car b))))))) (if reverse (setq sort-lists (nreverse sort-lists))) (if messages (message "Reordering buffer...")) - (sort-reorder-buffer sort-lists old))) + (with-buffer-unmodified-if-unchanged + (sort-reorder-buffer sort-lists old)))) (if messages (message "Reordering buffer... Done")))) nil) diff --git a/lisp/startup.el b/lisp/startup.el index 9f0b23c904b..0b7d90ecf2b 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1044,7 +1044,11 @@ init-file, or to a default value if loading is not possible." (debug-on-error-initial (if (eq init-file-debug t) 'startup - init-file-debug))) + init-file-debug)) + ;; The init file might contain byte-code with embedded NULs, + ;; which can cause problems when read back, so disable nul + ;; byte detection. (Bug#52554) + (inhibit-null-byte-detection t)) (let ((debug-on-error debug-on-error-initial)) (condition-case-unless-debug error (when init-file-user @@ -1232,6 +1236,14 @@ please check its value") (t (setq argval nil argi orig-argi))))) + + ;; We handle "-scripteval" further down, but we have to + ;; inhibit loading the user init file first. (This is for + ;; "emacs -x" handling.) + (when (equal argi "-scripteval") + (setq init-file-user nil + noninteractive t)) + (cond ;; The --display arg is handled partly in C, partly in Lisp. ;; When it shows up here, we just put it back to be handled @@ -1287,12 +1299,16 @@ please check its value") (setcdr command-line-args args))) ;; Re-evaluate predefined variables whose initial value depends on - ;; the runtime context. - (when (listp custom-delayed-init-variables) - (mapc #'custom-reevaluate-setting - ;; Initialize them in the same order they were loaded, in - ;; case there are dependencies between them. - (reverse custom-delayed-init-variables))) + ;; the runtime context. But delay the warning about + ;; `user-emacs-directory' being inaccessible until after processing + ;; the init file and the command-line arguments, in case the user + ;; customized `user-emacs-directory-warning' to nil via those. + (let ((user-emacs-directory-warning nil)) + (when (listp custom-delayed-init-variables) + (mapc #'custom-reevaluate-setting + ;; Initialize them in the same order they were loaded, in + ;; case there are dependencies between them. + (reverse custom-delayed-init-variables)))) (setq custom-delayed-init-variables t) ;; Warn for invalid user name. @@ -1553,9 +1569,21 @@ please check its value") (list 'error (substitute-command-keys "Memory exhausted--use \\[save-some-buffers] then exit and restart Emacs"))) + ;; Reevaluate `user-emacs-directory-warning' before processing + ;; '--eval' arguments, so that the user could override the default + ;; value in the '--eval' forms. + (custom-reevaluate-setting 'user-emacs-directory-warning) + ;; Process the remaining args. (command-line-1 (cdr command-line-args)) + ;; Check if `user-emacs-directory' is accessible and warn if it + ;; isn't, unless `user-emacs-directory-warning' was customized to + ;; disable that warning. + (when (and user-emacs-directory-warning + (not (file-accessible-directory-p user-emacs-directory))) + (locate-user-emacs-file "")) + ;; This is a problem because, e.g. if emacs.d/gnus.el exists, ;; trying to load gnus could load the wrong file. ;; OK, it would not matter if .emacs.d were at the end of load-path. @@ -2660,7 +2688,7 @@ nil default-directory" name) ;; This is used to handle -script. It's not clear ;; we need to document it (it is totally internal). - ((member argi '("-scriptload")) + ((member argi '("-scriptload" "-scripteval")) (let* ((file (command-line-normalize-file-name (or argval (pop command-line-args-left)))) ;; Take file from default dir. @@ -2673,7 +2701,10 @@ nil default-directory" name) ;; actually exist on some systems. (when (file-exists-p truename) (setq file-ex truename)) - (command-line--load-script file-ex))) + (if (equal argi "-scripteval") + ;; This will kill Emacs. + (command-line--eval-script file-ex) + (command-line--load-script file-ex)))) ((equal argi "-insert") (setq inhibit-startup-screen t) @@ -2875,6 +2906,22 @@ nil default-directory" name) (delete-line)) (eval-buffer buffer nil file nil t))))) +(defun command-line--eval-script (file) + (load-with-code-conversion + file file nil t + (lambda (buffer _) + (with-current-buffer buffer + (goto-char (point-min)) + (when (looking-at "#!") + (forward-line)) + (let (value form) + (while (ignore-error 'end-of-file + (setq form (read (current-buffer)))) + (setq value (eval form t))) + (kill-emacs (if (numberp value) + value + 0))))))) + (defun command-line-normalize-file-name (file) "Collapse multiple slashes to one, to handle non-Emacs file names." (save-match-data diff --git a/lisp/subr.el b/lisp/subr.el index 2321765f953..5af802fa18d 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -207,6 +207,39 @@ Also see `local-variable-p'." (:success t) (void-variable nil))) +(defmacro buffer-local-set-state (&rest pairs) + "Like `setq-local', but allow restoring the previous state of locals later. +This macro returns an object that can be passed to `buffer-local-restore-state' +in order to restore the state of the local variables set via this macro. + +\(fn [VARIABLE VALUE]...)" + (declare (debug setq)) + (unless (zerop (mod (length pairs) 2)) + (error "PAIRS must have an even number of variable/value members")) + `(prog1 + (buffer-local-set-state--get ',pairs) + (setq-local ,@pairs))) + +(defun buffer-local-set-state--get (pairs) + (let ((states nil)) + (while pairs + (push (list (car pairs) + (and (boundp (car pairs)) + (local-variable-p (car pairs))) + (and (boundp (car pairs)) + (symbol-value (car pairs)))) + states) + (setq pairs (cddr pairs))) + (nreverse states))) + +(defun buffer-local-restore-state (states) + "Restore values of buffer-local variables recorded in STATES. +STATES should be an object returned by `buffer-local-set-state'." + (pcase-dolist (`(,variable ,local ,value) states) + (if local + (set variable value) + (kill-local-variable variable)))) + (defmacro push (newelt place) "Add NEWELT to the list stored in the generalized variable PLACE. This is morally equivalent to (setf PLACE (cons NEWELT PLACE)), @@ -243,18 +276,14 @@ change the list." (defmacro when (cond &rest body) "If COND yields non-nil, do BODY, else return nil. When COND yields non-nil, eval BODY forms sequentially and return -value of last one, or nil if there are none. - -\(fn COND BODY...)" +value of last one, or nil if there are none." (declare (indent 1) (debug t)) (list 'if cond (cons 'progn body))) (defmacro unless (cond &rest body) "If COND yields nil, do BODY, else return nil. When COND yields nil, eval BODY forms sequentially and return -value of last one, or nil if there are none. - -\(fn COND BODY...)" +value of last one, or nil if there are none." (declare (indent 1) (debug t)) (cons 'if (cons cond (cons nil body)))) @@ -945,6 +974,20 @@ Here's some example key sequences: For an approximate inverse of this, see `key-description'." (declare (pure t) (side-effect-free t)) (let ((res (key-parse keys))) + ;; For historical reasons, parse "C-x ( C-d C-x )" as "C-d", since + ;; `kbd' used to be a wrapper around `read-kbd-macro'. + (when (and (>= (length res) 4) + (eq (aref res 0) ?\C-x) + (eq (aref res 1) ?\() + (eq (aref res (- (length res) 2)) ?\C-x) + (eq (aref res (- (length res) 1)) ?\))) + (setq res (apply #'vector (let ((lres (append res nil))) + ;; Remove the first and last two elements. + (setq lres (cddr lres)) + (setq lres (nreverse lres)) + (setq lres (cddr lres)) + (nreverse lres))))) + (if (not (memq nil (mapcar (lambda (ch) (and (numberp ch) (<= 0 ch 127))) @@ -2371,6 +2414,102 @@ Affects only hooks run in the current buffer." (let ((delay-mode-hooks t)) ,@body))) +;;; `when-let' and friends. + +(defun internal--build-binding (binding prev-var) + "Check and build a single BINDING with PREV-VAR." + (setq binding + (cond + ((symbolp binding) + (list binding binding)) + ((null (cdr binding)) + (list (make-symbol "s") (car binding))) + (t binding))) + (when (> (length binding) 2) + (signal 'error + (cons "`let' bindings can have only one value-form" binding))) + (let ((var (car binding))) + `(,var (and ,prev-var ,(cadr binding))))) + +(defun internal--build-bindings (bindings) + "Check and build conditional value forms for BINDINGS." + (let ((prev-var t)) + (mapcar (lambda (binding) + (let ((binding (internal--build-binding binding prev-var))) + (setq prev-var (car binding)) + binding)) + bindings))) + +(defmacro if-let* (varlist then &rest else) + "Bind variables according to VARLIST and evaluate THEN or ELSE. +This is like `if-let' but doesn't handle a VARLIST of the form +\(SYMBOL SOMETHING) specially." + (declare (indent 2) + (debug ((&rest [&or symbolp (symbolp form) (form)]) + body))) + (if varlist + `(let* ,(setq varlist (internal--build-bindings varlist)) + (if ,(caar (last varlist)) + ,then + ,@else)) + `(let* () ,then))) + +(defmacro when-let* (varlist &rest body) + "Bind variables according to VARLIST and conditionally evaluate BODY. +This is like `when-let' but doesn't handle a VARLIST of the form +\(SYMBOL SOMETHING) specially." + (declare (indent 1) (debug if-let*)) + (list 'if-let* varlist (macroexp-progn body))) + +(defmacro and-let* (varlist &rest body) + "Bind variables according to VARLIST and conditionally evaluate BODY. +Like `when-let*', except if BODY is empty and all the bindings +are non-nil, then the result is non-nil." + (declare (indent 1) (debug if-let*)) + (let (res) + (if varlist + `(let* ,(setq varlist (internal--build-bindings varlist)) + (when ,(setq res (caar (last varlist))) + ,@(or body `(,res)))) + `(let* () ,@(or body '(t)))))) + +(defmacro if-let (spec then &rest else) + "Bind variables according to SPEC and evaluate THEN or ELSE. +Evaluate each binding in turn, as in `let*', stopping if a +binding value is nil. If all are non-nil return the value of +THEN, otherwise the last form in ELSE. + +Each element of SPEC is a list (SYMBOL VALUEFORM) that binds +SYMBOL to the value of VALUEFORM. An element can additionally be +of the form (VALUEFORM), which is evaluated and checked for nil; +i.e. SYMBOL can be omitted if only the test result is of +interest. It can also be of the form SYMBOL, then the binding of +SYMBOL is checked for nil. + +As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) +like \((SYMBOL SOMETHING)). This exists for backward compatibility +with an old syntax that accepted only one binding." + (declare (indent 2) + (debug ([&or (symbolp form) ; must be first, Bug#48489 + (&rest [&or symbolp (symbolp form) (form)])] + body))) + (when (and (<= (length spec) 2) + (not (listp (car spec)))) + ;; Adjust the single binding case + (setq spec (list spec))) + (list 'if-let* spec then (macroexp-progn else))) + +(defmacro when-let (spec &rest body) + "Bind variables according to SPEC and conditionally evaluate BODY. +Evaluate each binding in turn, stopping if a binding value is nil. +If all are non-nil, return the value of the last form in BODY. + +The variable list SPEC is the same as in `if-let'." + (declare (indent 1) (debug if-let)) + (list 'if-let spec (macroexp-progn body))) + + + ;; PUBLIC: find if the current mode derives from another. (defun provided-mode-derived-p (mode &rest modes) @@ -2719,7 +2858,8 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'." (defun memory-limit () "Return an estimate of Emacs virtual memory usage, divided by 1024." - (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0)) + (let ((default-directory temporary-file-directory)) + (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0))) ;;;; Input and display facilities. @@ -3118,7 +3258,7 @@ If there is a natural number at point, use it as default." (make-hash-table :test 'equal)) (defun read-char-from-minibuffer-insert-char () - "Insert the character you type in the minibuffer and exit. + "Insert the character you type into the minibuffer and exit minibuffer. Discard all previous input before inserting and exiting the minibuffer." (interactive) (when (minibufferp) @@ -3127,9 +3267,11 @@ Discard all previous input before inserting and exiting the minibuffer." (exit-minibuffer))) (defun read-char-from-minibuffer-insert-other () - "Handle inserting of a character other than allowed. -Display an error on trying to insert a disallowed character. -Also discard all previous input in the minibuffer." + "Reject a disallowed character typed into the minibuffer. +This command is intended to be bound to keys that users are not +allowed to type into the minibuffer. When the user types any +such key, this command discard all minibuffer input and displays +an error message." (interactive) (when (minibufferp) (delete-minibuffer-contents) @@ -3758,14 +3900,18 @@ Note: :data and :device are currently not supported on Windows." (declare-function w32-shell-dos-semantics "w32-fns" nil) -(defun shell-quote-argument (argument) +(defun shell-quote-argument (argument &optional posix) "Quote ARGUMENT for passing as argument to an inferior shell. This function is designed to work with the syntax of your system's standard shell, and might produce incorrect results with unusual shells. -See Info node `(elisp)Security Considerations'." - (cond - ((eq system-type 'ms-dos) +See Info node `(elisp)Security Considerations'. + +If the optional POSIX argument is non-nil, ARGUMENT is quoted +according to POSIX shell quoting rules, regardless of the +system's shell." +(cond + ((and (not posix) (eq system-type 'ms-dos)) ;; Quote using double quotes, but escape any existing quotes in ;; the argument with backslashes. (let ((result "") @@ -3780,7 +3926,7 @@ See Info node `(elisp)Security Considerations'." start (1+ end)))) (concat "\"" result (substring argument start) "\""))) - ((and (eq system-type 'windows-nt) (w32-shell-dos-semantics)) + ((and (not posix) (eq system-type 'windows-nt) (w32-shell-dos-semantics)) ;; First, quote argument so that CommandLineToArgvW will ;; understand it. See @@ -6613,4 +6759,122 @@ OBJECT if it is readable." (forward-line 1) (point)))) +(defun ensure-empty-lines (&optional lines) + "Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. + +If called interactively, LINES is given by the prefix argument. + +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. + +If point is not at the beginning of a line, a newline character +is inserted before adjusting the number of empty lines." + (interactive "p") + (unless (bolp) + (insert "\n")) + (let ((lines (or lines 1)) + (start (save-excursion + (if (re-search-backward "[^\n]" nil t) + (+ (point) 2) + (point-min))))) + (cond + ((> (- (point) start) lines) + (delete-region (point) (- (point) (- (point) start lines)))) + ((< (- (point) start) lines) + (insert (make-string (- lines (- (point) start)) ?\n)))))) + +(defun string-lines (string &optional omit-nulls keep-newlines) + "Split STRING into a list of lines. +If OMIT-NULLS, empty lines will be removed from the results. +If KEEP-NEWLINES, don't strip trailing newlines from the result +lines." + (if (equal string "") + (if omit-nulls + nil + (list "")) + (let ((lines nil) + (start 0)) + (while (< start (length string)) + (let ((newline (string-search "\n" string start))) + (if newline + (progn + (when (or (not omit-nulls) + (not (= start newline))) + (let ((line (substring string start + (if keep-newlines + (1+ newline) + newline)))) + (when (not (and keep-newlines omit-nulls + (equal line "\n"))) + (push line lines)))) + (setq start (1+ newline))) + ;; No newline in the remaining part. + (if (zerop start) + ;; Avoid a string copy if there are no newlines at all. + (push string lines) + (push (substring string start) lines)) + (setq start (length string))))) + (nreverse lines)))) + +(defun buffer-match-p (condition buffer-or-name &optional arg) + "Return non-nil if BUFFER-OR-NAME matches CONDITION. +CONDITION is either: +- a regular expression, to match a buffer name, +- a predicate function that takes a buffer object and ARG as + arguments, and returns non-nil if the buffer matches, +- a cons-cell, where the car describes how to interpret the cdr. + The car can be one of the following: + * `major-mode': the buffer matches if the buffer's major + mode is derived from the major mode denoted by the cons-cell's + cdr + * `not': the cdr is interpreted as a negation of a condition. + * `and': the cdr is a list of recursive conditions, that all have + to be met. + * `or': the cdr is a list of recursive condition, of which at + least one has to be met." + (letrec + ((buffer (get-buffer buffer-or-name)) + (match + (lambda (conditions) + (catch 'match + (dolist (condition conditions) + (when (cond + ((stringp condition) + (string-match-p condition (buffer-name buffer))) + ((functionp condition) + (if (eq 1 (cdr (func-arity condition))) + (funcall condition buffer) + (funcall condition buffer arg))) + ((eq (car-safe condition) 'major-mode) + (provided-mode-derived-p + (buffer-local-value 'major-mode buffer) + (cdr condition))) + ((eq (car-safe condition) 'not) + (not (funcall match (cdr condition)))) + ((eq (car-safe condition) 'or) + (funcall match (cdr condition))) + ((eq (car-safe condition) 'and) + (catch 'fail + (dolist (c (cdr conditions)) + (unless (funcall match c) + (throw 'fail nil))) + t))) + (throw 'match t))))))) + (funcall match (list condition)))) + +(defun match-buffers (condition &optional buffers arg) + "Return a list of buffers that match CONDITION. +See `buffer-match' for details on CONDITION. By default all +buffers are checked, this can be restricted by passing an +optional argument BUFFERS, set to a list of buffers to check. +ARG is passed to `buffer-match', for predicate conditions in +CONDITION." + (let (bufs) + (dolist (buf (or buffers (buffer-list))) + (when (buffer-match-p condition (get-buffer buf) arg) + (push buf bufs))) + bufs)) + ;;; subr.el ends here diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 245a55a671f..42c4b822bc6 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -229,7 +229,7 @@ a list of frames to update." (defun tab-bar--key-to-number (key) "Return the tab number represented by KEY. -If KEY is a symbol 'tab-N', where N is a tab number, the value is N. +If KEY is a symbol `tab-N', where N is a tab number, the value is N. If KEY is \\='current-tab, the value is nil. For any other value of KEY, the value is t." (cond @@ -426,7 +426,7 @@ on each new frame when the global `tab-bar-mode' is disabled, or if you want to disable the tab bar individually on each new frame when the global `tab-bar-mode' is enabled, by using - (add-hook 'after-make-frame-functions 'toggle-frame-tab-bar)" + (add-hook \\='after-make-frame-functions #\\='toggle-frame-tab-bar)" (interactive) (set-frame-parameter frame 'tab-bar-lines (if (> (frame-parameter frame 'tab-bar-lines) 0) 0 1)) @@ -915,8 +915,8 @@ when the tab is current. Return the result as a keymap." (let* ((rest (cdr (memq 'tab-bar-format-align-right tab-bar-format))) (rest (tab-bar-format-list rest)) (rest (mapconcat (lambda (item) (nth 2 item)) rest "")) - (hpos (length rest)) - (str (propertize " " 'display `(space :align-to (- right ,hpos))))) + (hpos (string-pixel-width (propertize rest 'face 'tab-bar))) + (str (propertize " " 'display `(space :align-to (- right (,hpos)))))) `((align-right menu-item ,str ignore)))) (defun tab-bar-format-global () @@ -926,7 +926,7 @@ When `tab-bar-format-global' is added to `tab-bar-format' then modes that display information on the mode line using `global-mode-string' will display the same text on the tab bar instead." - `((global menu-item ,(string-trim-right (format-mode-line global-mode-string)) ignore))) + `((global menu-item ,(format-mode-line global-mode-string) ignore))) (defun tab-bar-format-list (format-list) (let ((i 0)) @@ -1384,7 +1384,8 @@ After the tab is created, the hooks in (split-window) (delete-window)))) (let ((buffer - (if (functionp tab-bar-new-tab-choice) + (if (and (functionp tab-bar-new-tab-choice) + (not (memq tab-bar-new-tab-choice '(clone window)))) (funcall tab-bar-new-tab-choice) (if (stringp tab-bar-new-tab-choice) (or (get-buffer tab-bar-new-tab-choice) @@ -1658,9 +1659,10 @@ happens interactively)." (setq index (max 0 (min index (length tabs)))) (cl-pushnew tab (nthcdr index tabs)) (when (eq index 0) - ;; pushnew handles the head of tabs but not frame-parameter + ;; `pushnew' handles the head of tabs but not frame-parameter (tab-bar-tabs-set tabs)) - (tab-bar-select-tab (1+ index)))) + (tab-bar-select-tab (1+ index))) + (tab-bar--update-tab-bar-lines)) (message "No more closed tabs to undo"))) diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el index 7a48fc04c6c..6f1e322aba5 100644 --- a/lisp/term/common-win.el +++ b/lisp/term/common-win.el @@ -65,7 +65,6 @@ (cons 4 'ns-drag-file) (cons 5 'ns-drag-color) (cons 6 'ns-drag-text) - (cons 7 'ns-change-font) (cons 8 'ns-open-file-line) ;;; (cons 9 'ns-insert-working-text) ;;; (cons 10 'ns-delete-working-text) @@ -419,6 +418,16 @@ the operating system.") (setq defined-colors (cons this-color defined-colors)))) defined-colors))) +;;;; Session management. + +(defvar emacs-save-session-functions nil + "Special hook run when a save-session event occurs. +The functions do not get any argument. +Functions can return non-nil to inform the session manager that the +window system shutdown should be aborted. + +See also `emacs-session-save'.") + (provide 'term/common-win) ;;; common-win.el ends here diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index c4810f116d2..5f020877325 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -44,14 +44,115 @@ (defvar x-command-line-resources) (defvar haiku-initialized) +(defvar haiku-signal-invalid-refs) +(defvar haiku-drag-track-function) +(defvar haiku-allowed-ui-colors) + +(defvar haiku-dnd-selection-value nil + "The local value of the special `XdndSelection' selection.") + +(defvar haiku-dnd-selection-converters '((STRING . haiku-dnd-convert-string) + (text/uri-list . haiku-dnd-convert-uri-list)) + "Alist of X selection types to functions that act as selection converters. +The functions should accept a single argument VALUE, describing +the value of the drag-and-drop selection, and return a list of +two elements TYPE and DATA, where TYPE is a string containing the +MIME type of DATA, and DATA is a unibyte string, or nil if the +data could not be converted. + +DATA can optionally have a text property `type', which specifies +the type of DATA inside the system message (see the doc string of +`haiku-drag-message' for more details).") + +(defvar haiku-normal-selection-encoders '(haiku-select-encode-xstring + haiku-select-encode-utf-8-string + haiku-select-encode-file-name) + "List of functions which act as selection encoders. +These functions accept two arguments SELECTION and VALUE, and +return an association appropriate for a serialized system +message (or nil if VALUE is not applicable to the encoder) that +will be put into the system selection SELECTION. VALUE is the +content that is being put into the selection by +`gui-set-selection'. See the doc string of `haiku-drag-message' +for more details on the structure of the associations.") + +;; This list has to be set correctly, otherwise Emacs will crash upon +;; encountering an invalid color. +(setq haiku-allowed-ui-colors + ["B_PANEL_BACKGROUND_COLOR" "B_MENU_BACKGROUND_COLOR" + "B_WINDOW_TAB_COLOR" "B_KEYBOARD_NAVIGATION_COLOR" + "B_DESKTOP_COLOR" "B_MENU_SELECTED_BACKGROUND_COLOR" + "B_MENU_ITEM_TEXT_COLOR" "B_MENU_SELECTED_ITEM_TEXT_COLOR" + "B_MENU_SELECTED_BORDER_COLOR" "B_PANEL_TEXT_COLOR" + "B_DOCUMENT_BACKGROUND_COLOR" "B_DOCUMENT_TEXT_COLOR" + "B_CONTROL_BACKGROUND_COLOR" "B_CONTROL_TEXT_COLOR" + "B_CONTROL_BORDER_COLOR" "B_CONTROL_HIGHLIGHT_COLOR" + "B_NAVIGATION_PULSE_COLOR" "B_SHINE_COLOR" + "B_SHADOW_COLOR" "B_TOOLTIP_BACKGROUND_COLOR" + "B_TOOLTIP_TEXT_COLOR" "B_WINDOW_TEXT_COLOR" + "B_WINDOW_INACTIVE_TAB_COLOR" "B_WINDOW_INACTIVE_TEXT_COLOR" + "B_WINDOW_BORDER_COLOR" "B_WINDOW_INACTIVE_BORDER_COLOR" + "B_CONTROL_MARK_COLOR" "B_LIST_BACKGROUND_COLOR" + "B_LIST_SELECTED_BACKGROUND_COLOR" "B_LIST_ITEM_TEXT_COLOR" + "B_LIST_SELECTED_ITEM_TEXT_COLOR" "B_SCROLL_BAR_THUMB_COLOR" + "B_LINK_TEXT_COLOR" "B_LINK_HOVER_COLOR" + "B_LINK_VISITED_COLOR" "B_LINK_ACTIVE_COLOR" + "B_STATUS_BAR_COLOR" "B_SUCCESS_COLOR" "B_FAILURE_COLOR"]) + +;; Also update `x-colors' to take that into account. +(setq x-colors (append haiku-allowed-ui-colors x-colors)) + +(defun haiku-selection-bounds (value) + "Return bounds of selection value VALUE. +The return value is a list (BEG END BUF) if VALUE is a cons of +two markers or an overlay. Otherwise, it is nil." + (cond ((bufferp value) + (with-current-buffer value + (when (mark t) + (list (mark t) (point) value)))) + ((and (consp value) + (markerp (car value)) + (markerp (cdr value))) + (when (and (marker-buffer (car value)) + (buffer-name (marker-buffer (car value))) + (eq (marker-buffer (car value)) + (marker-buffer (cdr value)))) + (list (marker-position (car value)) + (marker-position (cdr value)) + (marker-buffer (car value))))) + ((overlayp value) + (when (overlay-buffer value) + (list (overlay-start value) + (overlay-end value) + (overlay-buffer value)))))) + +(defun haiku-dnd-convert-string (value) + "Convert VALUE to a UTF-8 string and appropriate MIME type. +Return a list of the appropriate MIME type, and UTF-8 data of +VALUE as a unibyte string, or nil if VALUE was not a string." + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) + (when (stringp value) + (list "text/plain" (string-to-unibyte + (encode-coding-string value 'utf-8))))) + +(defun haiku-dnd-convert-uri-list (value) + "Convert VALUE to a file system reference if it is a file name." + (when (and (stringp value) + (file-exists-p value)) + (list "refs" (propertize (expand-file-name value) 'type 'ref)))) (declare-function x-open-connection "haikufns.c") (declare-function x-handle-args "common-win") (declare-function haiku-selection-data "haikuselect.c") (declare-function haiku-selection-put "haikuselect.c") -(declare-function haiku-selection-targets "haikuselect.c") (declare-function haiku-selection-owner-p "haikuselect.c") (declare-function haiku-put-resource "haikufns.c") +(declare-function haiku-drag-message "haikuselect.c") (defun haiku--handle-x-command-line-resources (command-line-resources) "Handle command line X resources specified with the option `-xrm'. @@ -92,16 +193,66 @@ If TYPE is nil, return \"text/plain\"." ((symbolp type) (symbol-name type)) (t "text/plain"))) +(defun haiku-selection-targets (clipboard) + "Find the types of data available from CLIPBOARD. +CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or +`CLIPBOARD'. Return the available types as a list of strings." + (mapcar #'car (haiku-selection-data clipboard nil))) + +(defun haiku-select-encode-xstring (_selection value) + "Convert VALUE to a system message association. +VALUE will be encoded as Latin-1 (like on X Windows) and stored +under the type `text/plain;charset=iso-8859-1'." + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) + (when (and (stringp value) (not (string-empty-p value))) + (list "text/plain;charset=iso-8859-1" 1296649541 + (encode-coding-string value 'iso-latin-1)))) + +(defun haiku-select-encode-utf-8-string (_selection value) + "Convert VALUE to a system message association. +VALUE will be encoded as UTF-8 and stored under the type +`text/plain'." + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) + (when (and (stringp value) (not (string-empty-p value))) + (list "text/plain" 1296649541 + (encode-coding-string value 'utf-8-unix)))) + +(defun haiku-select-encode-file-name (_selection value) + "Convert VALUE to a system message association. +This takes the file name of VALUE's buffer (if it is an overlay +or a pair of markers) and turns it into a file system reference." + (when (setq value (xselect--selection-bounds value)) + (list "refs" 'ref (buffer-file-name (nth 2 value))))) + (cl-defmethod gui-backend-get-selection (type data-type &context (window-system haiku)) (if (eq data-type 'TARGETS) (apply #'vector (mapcar #'intern (haiku-selection-targets type))) - (haiku-selection-data type (haiku--selection-type-to-mime data-type)))) + (if (eq type 'XdndSelection) + haiku-dnd-selection-value + (haiku-selection-data type (haiku--selection-type-to-mime data-type))))) (cl-defmethod gui-backend-set-selection (type value &context (window-system haiku)) - (haiku-selection-put type "text/plain" value t)) + (if (eq type 'XdndSelection) + (setq haiku-dnd-selection-value value) + (let ((message nil)) + (dolist (encoder haiku-normal-selection-encoders) + (let ((result (funcall encoder type value))) + (when result + (push result message)))) + (haiku-selection-put type message)))) (cl-defmethod gui-backend-selection-exists-p (selection &context (window-system haiku)) @@ -122,20 +273,40 @@ If TYPE is nil, return \"text/plain\"." (or dir (and default-filename (file-name-directory default-filename))) mustmatch only-dir-p - (file-name-nondirectory default-filename)) + (and default-filename + (file-name-nondirectory default-filename))) (error "x-file-dialog on a tty frame"))) -(defun haiku-dnd-handle-drag-n-drop-event (event) +(defun haiku-drag-and-drop (event) "Handle specified drag-n-drop EVENT." (interactive "e") (let* ((string (caddr event)) (window (posn-window (event-start event)))) - (with-selected-window window - (raise-frame) - (dnd-handle-one-url window 'private (concat "file:" string))))) + (if (eq string 'lambda) ; This means the mouse moved. + (dnd-handle-movement (event-start event)) + (cond + ((assoc "refs" string) + (with-selected-window window + (raise-frame) + (dolist (filename (cddr (assoc "refs" string))) + (dnd-handle-one-url window 'private + (concat "file:" filename))))) + ((assoc "text/plain" string) + (with-selected-window window + (raise-frame) + (dolist (text (cddr (assoc "text/plain" string))) + (goto-char (posn-point (event-start event))) + (dnd-insert-text window 'private + (if (multibyte-string-p text) + text + (decode-coding-string text 'undecided)))))) + ((not (eq (cdr (assq 'type string)) + 3003)) ; Type of the placeholder message Emacs uses + ; to cancel a drop on C-g. + (message "Don't know how to drop any of: %s" + (mapcar #'car string))))))) -(define-key special-event-map [drag-n-drop] - 'haiku-dnd-handle-drag-n-drop-event) +(define-key special-event-map [drag-n-drop] 'haiku-drag-and-drop) (defvaralias 'haiku-use-system-tooltips 'use-system-tooltips) @@ -145,8 +316,81 @@ This is necessary because on Haiku `use-system-tooltip' doesn't take effect on menu items until the menu bar is updated again." (force-mode-line-update t)) +;; Note that `mouse-position' can't return the actual frame the mouse +;; pointer is under, so this only works for the frame where the drop +;; started. +(defun haiku-dnd-drag-handler () + "Handle mouse movement during drag-and-drop." + (let ((track-mouse 'drag-source) + (mouse-position (mouse-pixel-position))) + (when (car mouse-position) + (dnd-handle-movement (posn-at-x-y (cadr mouse-position) + (cddr mouse-position) + (car mouse-position))) + (redisplay)))) + +(setq haiku-drag-track-function #'haiku-dnd-drag-handler) + +(defun x-begin-drag (targets &optional action frame _return-frame allow-current-frame) + "SKIP: real doc in xfns.c." + (unless haiku-dnd-selection-value + (error "No local value for XdndSelection")) + (let ((message nil) + (mouse-highlight nil) + (haiku-signal-invalid-refs nil)) + (dolist (target targets) + (let ((selection-converter (cdr (assoc (intern target) + haiku-dnd-selection-converters)))) + (when selection-converter + (let ((selection-result + (funcall selection-converter + haiku-dnd-selection-value))) + (when selection-result + (let ((field (cdr (assoc (car selection-result) message)))) + (unless (cadr field) + ;; Add B_MIME_TYPE to the message if the type was not + ;; previously specified, or the type if it was. + (push (or (get-text-property 0 'type + (cadr selection-result)) + 1296649541) + (alist-get (car selection-result) message + nil nil #'equal)))) + (push (cadr selection-result) + (cdr (alist-get (car selection-result) message + nil nil #'equal)))))))) + (prog1 (or (and (symbolp action) + action) + 'XdndActionCopy) + (haiku-drag-message (or frame (selected-frame)) + message allow-current-frame)))) + (add-variable-watcher 'use-system-tooltips #'haiku-use-system-tooltips-watcher) + +;;;; Session management. + +(declare-function haiku-save-session-reply "haikufns.c") + +(defun emacs-session-save () + "SKIP: real doc in x-win.el." + (with-temp-buffer ; Saving sessions is not yet supported. + (condition-case nil + ;; A return of t means cancel the shutdown. + (run-hook-with-args-until-success + 'emacs-save-session-functions) + (error t)))) + +(defun handle-save-session (_event) + "SKIP: real doc in xsmfns.c." + (interactive "e") + (let ((cancel-shutdown t)) + (unwind-protect + (setq cancel-shutdown (emacs-session-save)) + (haiku-save-session-reply (not cancel-shutdown))) + ;; The App Server will kill Emacs after receiving the reply, but + ;; the Deskbar will not, so kill ourself here. + (unless cancel-shutdown (kill-emacs)))) + (provide 'haiku-win) (provide 'term/haiku-win) diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index da6c5adee22..6a414d83f18 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -176,7 +176,6 @@ The properties returned may include `top', `left', `height', and `width'." (define-key global-map [ns-power-off] 'save-buffers-kill-emacs) (define-key global-map [ns-open-file] 'ns-find-file) (define-key global-map [ns-open-temp-file] [ns-open-file]) -(define-key global-map [ns-change-font] 'ns-respond-to-change-font) (define-key global-map [ns-open-file-line] 'ns-open-file-select-line) (define-key global-map [ns-spi-service-call] 'ns-spi-service-call) (define-key global-map [ns-new-frame] 'make-frame) @@ -508,25 +507,28 @@ unless the current buffer is a scratch buffer." Switch to a buffer editing the last file dropped, or insert the string dropped into the current buffer." (interactive "e") - (let* ((window (posn-window (event-start event))) - (arg (car (cdr (cdr event)))) - (type (car arg)) - (operations (car (cdr arg))) - (objects (cdr (cdr arg))) - (string (mapconcat 'identity objects "\n"))) - (set-frame-selected-window nil window) - (raise-frame) - (setq window (selected-window)) - (cond ((or (memq 'ns-drag-operation-generic operations) - (memq 'ns-drag-operation-copy operations)) - ;; Perform the default/copy action. - (dolist (data objects) - (dnd-handle-one-url window 'private (if (eq type 'file) - (concat "file:" data) - data)))) - (t - ;; Insert the text as is. - (dnd-insert-text window 'private string))))) + (if (eq (car-safe (cdr-safe (cdr-safe event))) 'lambda) + (dnd-handle-movement (event-start event)) + (let* ((window (posn-window (event-start event))) + (arg (car (cdr (cdr event)))) + (type (car arg)) + (operations (car (cdr arg))) + (objects (cdr (cdr arg))) + (string (mapconcat 'identity objects "\n"))) + (set-frame-selected-window nil window) + (raise-frame) + (setq window (selected-window)) + (goto-char (posn-point (event-start event))) + (cond ((or (memq 'ns-drag-operation-generic operations) + (memq 'ns-drag-operation-copy operations)) + ;; Perform the default/copy action. + (dolist (data objects) + (dnd-handle-one-url window 'private (if (eq type 'file) + (concat "file:" data) + data)))) + (t + ;; Insert the text as is. + (dnd-insert-text window 'private string)))))) (global-set-key [drag-n-drop] 'ns-drag-n-drop) @@ -620,34 +622,6 @@ If FRAME is nil, the change applies to the selected frame." ;; Needed for font listing functions under both backend and normal (setq scalable-fonts-allowed t) -;; Set to use font panel instead -(declare-function ns-popup-font-panel "nsfns.m" (&optional frame)) -(defalias 'x-select-font 'ns-popup-font-panel "Pop up the font panel. -This function has been overloaded in Nextstep.") -(defalias 'mouse-set-font 'ns-popup-font-panel "Pop up the font panel. -This function has been overloaded in Nextstep.") - -;; nsterm.m -(defvar ns-input-font) -(defvar ns-input-fontsize) - -(defun ns-respond-to-change-font () - "Set the font chosen in the font-picker panel. -Respond to changeFont: event, expecting ns-input-font and -ns-input-fontsize of new font." - (interactive) - (let ((face 'default)) - (set-face-attribute face t - :family ns-input-font - :height (* 10 ns-input-fontsize)) - (set-face-attribute face (selected-frame) - :family ns-input-font - :height (* 10 ns-input-fontsize)) - (let ((spec (list (list t (face-attr-construct 'default))))) - (put face 'customized-face spec) - (custom-push-theme 'theme-face face 'user 'set spec) - (put face 'face-modified nil)))) - ;; Default fontset for macOS. This is mainly here to show how a fontset ;; can be set up manually. Ordinarily, fontsets are auto-created whenever ;; a font is chosen by diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el index 327d51f2759..514267a52d6 100644 --- a/lisp/term/pc-win.el +++ b/lisp/term/pc-win.el @@ -246,6 +246,14 @@ Consult the selection. Treat empty strings as if they were unset." ;; if it does not exist, or exists and compares ;; equal with the last text we've put into the ;; Windows clipboard. + ;; NOTE: that variable is actually the last text any program + ;; (not just Emacs) has put into the windows clipboard (up + ;; until the last time Emacs read or set the clipboard), so + ;; it's not suitable for checking actual selection + ;; ownership. This should not result in a bug for the current + ;; uses of gui-backend-selection-owner however, since they + ;; don't actually care about selection ownership, but about + ;; the selected text having changed. (cond ((not text) t) ((equal text gui--last-selected-text-clipboard) text) diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el index 8e17864284e..5317f6ba01a 100644 --- a/lisp/term/pgtk-win.el +++ b/lisp/term/pgtk-win.el @@ -1,4 +1,4 @@ -;;; xterm.el --- define function key sequences and standard colors for xterm -*- lexical-binding: t -*- +;;; pgtk-win.el --- parse relevant switches and set up for Pure-GTK -*- lexical-binding: t -*- ;; Copyright (C) 1995, 2001-2020, 2022 Free Software Foundation, Inc. @@ -23,10 +23,11 @@ ;;; Commentary: ;;; Code: + (eval-when-compile (require 'cl-lib)) -(or (featurep 'pgtk) - (error "%s: Loading pgtk-win.el but not compiled for pure Gtk+-3." - invocation-name)) +(unless (featurep 'pgtk) + (error "%s: Loading pgtk-win.el but not compiled with PGTK." + invocation-name)) ;; Documentation-purposes only: actually loaded in loadup.el. (require 'term/common-win) @@ -38,39 +39,14 @@ (require 'fontset) (require 'dnd) -(defgroup pgtk nil - "Pure-GTK specific features." - :group 'environment) - -;;;; Command line argument handling. - (defvar x-invocation-args) -;; Set in term/common-win.el; currently unused by Gtk's x-open-connection. (defvar x-command-line-resources) - -;; pgtkterm.c. (defvar pgtk-input-file) - -(declare-function pgtk-use-im-context "pgtkim.c") (defvar pgtk-use-im-context-on-new-connection) -(defun pgtk-handle-nxopen (_switch &optional temp) - (setq unread-command-events (append unread-command-events - (if temp '(pgtk-open-temp-file) - '(pgtk-open-file))) - pgtk-input-file (append pgtk-input-file (list (pop x-invocation-args))))) - -(defun pgtk-handle-nxopentemp (switch) - (pgtk-handle-nxopen switch t)) - -(defun pgtk-ignore-1-arg (_switch) - (setq x-invocation-args (cdr x-invocation-args))) - -;;;; File handling. - +(declare-function pgtk-use-im-context "pgtkim.c") (declare-function pgtk-hide-emacs "pgtkfns.c" (on)) - (defun pgtk-drag-n-drop (event &optional new-frame force-text) "Edit the files listed in the drag-n-drop EVENT. Switch to a buffer editing the last file dropped." @@ -91,7 +67,6 @@ Switch to a buffer editing the last file dropped." (dnd-insert-text window 'private data) (dnd-handle-one-url window 'private url-or-string)))) - (defun pgtk-drag-n-drop-other-frame (event) "Edit the files listed in the drag-n-drop EVENT, in other frames. May create new frames, or reuse existing ones. The frame editing @@ -110,132 +85,12 @@ the last file dropped is selected." (pgtk-drag-n-drop event t t)) (global-set-key [drag-n-drop] 'pgtk-drag-n-drop) -(global-set-key [C-drag-n-drop] 'pgtk-drag-n-drop-other-frame) -(global-set-key [M-drag-n-drop] 'pgtk-drag-n-drop-as-text) -(global-set-key [C-M-drag-n-drop] 'pgtk-drag-n-drop-as-text-other-frame) - -;;;; Frame-related functions. - -;; pgtkterm.c -(defvar pgtk-alternate-modifier) -(defvar pgtk-right-alternate-modifier) -(defvar pgtk-right-command-modifier) -(defvar pgtk-right-control-modifier) - -;; You say tomAYto, I say tomAHto.. -(with-no-warnings - (defvaralias 'pgtk-option-modifier 'pgtk-alternate-modifier) - (defvaralias 'pgtk-right-option-modifier 'pgtk-right-alternate-modifier)) - -(defun pgtk-do-hide-emacs () - (interactive) - (pgtk-hide-emacs t)) - -(declare-function pgtk-hide-others "pgtkfns.c" ()) - -(defun pgtk-do-hide-others () - (interactive) - (pgtk-hide-others)) - -(declare-function pgtk-emacs-info-panel "pgtkfns.c" ()) - -(defun pgtk-do-emacs-info-panel () - (interactive) - (pgtk-emacs-info-panel)) - -(defun pgtk-next-frame () - "Switch to next visible frame." - (interactive) - (other-frame 1)) - -(defun pgtk-prev-frame () - "Switch to previous visible frame." - (interactive) - (other-frame -1)) - -;; Frame will be focused anyway, so select it -;; (if this is not done, mode line is dimmed until first interaction) -;; FIXME: Sounds like we're working around a bug in the underlying code. -(add-hook 'after-make-frame-functions 'select-frame) - -(defvar tool-bar-mode) -(declare-function tool-bar-mode "tool-bar" (&optional arg)) - -;; Based on a function by David Reitter ; -;; see https://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html . -(defun pgtk-toggle-toolbar (&optional frame) - "Switches the tool bar on and off in frame FRAME. - If FRAME is nil, the change applies to the selected frame." - (interactive) - (modify-frame-parameters - frame (list (cons 'tool-bar-lines - (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0) - 0 1)) )) - (if (not tool-bar-mode) (tool-bar-mode t))) - - -;;;; Dialog-related functions. - -;; Ask user for confirm before printing. Due to Kevin Rodgers. -(defun pgtk-print-buffer () - "Interactive front-end to `print-buffer': asks for user confirmation first." - (interactive) - (if (and (called-interactively-p 'interactive) - (or (listp last-nonmenu-event) - (and (char-or-string-p (event-basic-type last-command-event)) - (memq 'super (event-modifiers last-command-event))))) - (let ((last-nonmenu-event (if (listp last-nonmenu-event) - last-nonmenu-event - ;; Fake it: - `(mouse-1 POSITION 1)))) - (if (y-or-n-p (format "Print buffer %s? " (buffer-name))) - (print-buffer) - (error "Canceled"))) - (print-buffer))) - -;;;; Font support. - -;; Needed for font listing functions under both backend and normal -(setq scalable-fonts-allowed t) - -;; Default fontset. This is mainly here to show how a fontset -;; can be set up manually. Ordinarily, fontsets are auto-created whenever -;; a font is chosen by -(defvar pgtk-standard-fontset-spec - ;; Only some code supports this so far, so use uglier XLFD version - ;; "-pgtk-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai" - (mapconcat 'identity - '("-*-Monospace-*-*-*-*-10-*-*-*-*-*-fontset-standard" - "latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1") - ",") - "String of fontset spec of the standard fontset. -This defines a fontset consisting of the Courier and other fonts. -See the documentation of `create-fontset-from-fontset-spec' for the format.") - - -;;;; Pasteboard support. - -(define-obsolete-function-alias 'pgtk-store-cut-buffer-internal - 'gui-set-selection "24.1") - - -(defun pgtk-copy-including-secondary () - (interactive) - (call-interactively 'kill-ring-save) - (gui-set-selection 'SECONDARY (buffer-substring (point) (mark t)))) - -(defun pgtk-paste-secondary () - (interactive) - (insert (gui-get-selection 'SECONDARY))) - (defun pgtk-suspend-error () - ;; Don't allow suspending if any of the frames are PGTK frames. + "Don't allow suspending if any of the frames are PGTK frames." (if (memq 'pgtk (mapcar 'window-system (frame-list))) (error "Cannot suspend Emacs while a PGTK GUI frame exists"))) - - (defvar pgtk-initialized nil "Non-nil if pure-GTK windowing has been initialized.") @@ -244,31 +99,34 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") (display &optional xrm-string must-succeed)) (declare-function pgtk-set-resource "pgtkfns.c" (owner name value)) -;; Do the actual pure-GTK Windows setup here; the above code just -;; defines functions and variables that we use now. +;; Do the actual window system setup here; the above code just defines +;; functions and variables that we use now. (cl-defmethod window-system-initialization (&context (window-system pgtk) &optional display) - "Initialize Emacs for pure-GTK windowing." + "Initialize the PGTK window system. +WINDOW-SYSTEM is, aptly, `pgtk'. +DISPLAY is the name of the display Emacs should connect to." (cl-assert (not pgtk-initialized)) ;; PENDING: not needed? (setq command-line-args (x-handle-args command-line-args)) ;; Make sure we have a valid resource name. - (or (stringp x-resource-name) + (when (boundp 'x-resource-name) + (unless (stringp x-resource-name) (let (i) (setq x-resource-name (copy-sequence invocation-name)) ;; Change any . or * characters in x-resource-name to hyphens, ;; so as not to choke when we use it in X resource queries. (while (setq i (string-match "[.*]" x-resource-name)) - (aset x-resource-name i ?-)))) + (aset x-resource-name i ?-))))) ;; Setup the default fontset. (create-default-fontset) ;; Create the standard fontset. (condition-case err - (create-fontset-from-fontset-spec pgtk-standard-fontset-spec t) + (create-fontset-from-fontset-spec standard-fontset-spec t) (error (display-warning 'initialization (format "Creation of the standard fontset failed: %s" err) @@ -358,14 +216,12 @@ EVENT is a `preedit-text-event'." (define-key special-event-map [preedit-text] 'pgtk-preedit-text) -(add-hook 'after-init-hook - (function - (lambda () - (when (eq window-system 'pgtk) - (pgtk-use-im-context pgtk-use-im-context-on-new-connection))))) +(defun pgtk-use-im-context-handler () + "Set up input context usage after Emacs initialization." + (when (eq window-system 'pgtk) + (pgtk-use-im-context pgtk-use-im-context-on-new-connection))) - -;;; +(add-hook 'after-init-hook #'pgtk-use-im-context-handler) (defcustom x-gtk-stock-map (mapcar (lambda (arg) @@ -511,6 +367,27 @@ This uses `icon-map-list' to map icon file names to stock icon names." (t (popup-menu (mouse-menu-bar-map) last-nonmenu-event)))) +(defun pgtk-device-class (name) + "Return the device class of NAME. +Users should not call this function; see `device-class' instead." + (cond + ((string-match-p "XTEST" name) 'test) + ((string= "Virtual core pointer" name) 'core-pointer) + ((string= "Virtual core keyboard" name) 'core-keyboard) + (t (let ((number (ignore-errors + (string-to-number name)))) + (when number + (cl-case number + (0 'mouse) + (1 'pen) + (2 'eraser) + (3 'puck) + (4 'keyboard) + (5 'touchscreen) + (6 'touchpad) + (7 'trackpoint) + (8 'pad))))))) + (defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips) (provide 'pgtk-win) diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 4ed01de9aef..7eaa6047763 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -275,6 +275,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(gif "libgif-5.dll" "giflib4.dll" "libungif4.dll" "libungif.dll"))) '(svg "librsvg-2-2.dll") '(webp "libwebp-7.dll" "libwebp.dll") + '(webpdemux "libwebpdemux-2.dll" "libwebpdemux.dll") '(sqlite3 "libsqlite3-0.dll") '(gdk-pixbuf "libgdk_pixbuf-2.0-0.dll") '(glib "libglib-2.0-0.dll") diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index 9ae238661e0..ca38a0a8c92 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -85,6 +85,8 @@ (defvar x-selection-timeout) (defvar x-session-id) (defvar x-session-previous-id) +(defvar x-dnd-movement-function) +(defvar x-dnd-unsupported-drop-function) (defun x-handle-no-bitmap-icon (_switch) (setq default-frame-alist (cons '(icon-type) default-frame-alist))) @@ -107,14 +109,6 @@ (setq x-session-previous-id (car x-invocation-args) x-invocation-args (cdr x-invocation-args))) -(defvar emacs-save-session-functions nil - "Special hook run when a save-session event occurs. -The functions do not get any argument. -Functions can return non-nil to inform the session manager that the -window system shutdown should be aborted. - -See also `emacs-session-save'.") - (defun emacs-session-filename (session-id) "Construct a filename to save the session in based on SESSION-ID. Return a filename in `user-emacs-directory', unless the session file @@ -1576,6 +1570,53 @@ frames on all displays." (add-variable-watcher 'x-gtk-use-native-input #'x-gtk-use-native-input-watcher) +(defun x-dnd-movement (_frame position) + "Handle movement to POSITION during drag-and-drop." + (dnd-handle-movement position) + (redisplay)) + +(defun x-device-class (name) + "Return the device class of NAME. +Users should not call this function; see `device-class' instead." + (let ((downcased-name (downcase name))) + (cond + ((string-match-p "XTEST" name) 'test) + ((string= "Virtual core pointer" name) 'core-pointer) + ((string= "Virtual core keyboard" name) 'core-keyboard) + ((string-match-p "eraser" downcased-name) 'eraser) + ((string-match-p " pad" downcased-name) 'pad) + ((or (or (string-match-p "wacom" downcased-name) + (string-match-p "pen" downcased-name)) + (string-match-p "stylus" downcased-name)) + 'pen) + ((or (string-prefix-p "xwayland-touch:" name) + (string-match-p "touchscreen" downcased-name)) + 'touchscreen) + ((or (string-match-p "trackpoint" downcased-name) + (string-match-p "stick" downcased-name)) + 'trackpoint) + ((or (string-match-p "mouse" downcased-name) + (string-match-p "optical" downcased-name) + (string-match-p "pointer" downcased-name)) + 'mouse) + ((string-match-p "cursor" downcased-name) 'puck) + ((or (string-match-p "keyboard" downcased-name) + ;; One of my cheap keyboards is really named this... + (string= name "USB USB Keykoard")) + 'keyboard) + ((string-match-p "button" downcased-name) 'power-button) + ((string-match-p "touchpad" downcased-name) 'touchpad) + ((or (string-match-p "midi" downcased-name) + (string-match-p "piano" downcased-name)) + 'piano) + ((or (string-match-p "wskbd" downcased-name) ; NetBSD/OpenBSD + (and (string-match-p "/dev" downcased-name) + (string-match-p "kbd" downcased-name))) + 'keyboard)))) + +(setq x-dnd-movement-function #'x-dnd-movement) +(setq x-dnd-unsupported-drop-function #'x-dnd-handle-unsupported-drop) + (provide 'x-win) (provide 'term/x-win) diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index e37b0d988ab..686d5f494c9 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -1371,8 +1371,11 @@ Keymap summary (t ;; Turn mode on (artist-mode-init) - (let ((font (face-attribute 'default :font))) - (when (and (fontp font) (not (font-get font :spacing))) + (let* ((font (face-attribute 'default :font)) + (spacing-prop (if (fontp font) + (font-get font :spacing) + t))) + (when (or (null spacing-prop) (eq spacing-prop 0)) (message "The default font isn't monospaced, so the drawings in this buffer may look odd")))))) ;; Init and exit diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index ab6a907c52d..62a4af13774 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -764,6 +764,20 @@ for a new entry." ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4) ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5) ("url") ("urldate"))) + ("Conference" "Article in Conference Proceedings" ; same as InProceedings + (("author") + ("title" "Title of the article in proceedings (BibTeX converts it to lowercase)")) + (("booktitle" "Name of the conference proceedings") + ("year")) + (("editor") + ("volume" "Volume of the conference proceedings in the series") + ("number" "Number of the conference proceedings in a small series (overwritten by volume)") + ("series" "Series in which the conference proceedings appeared") + ("pages" "Pages in the conference proceedings") + ("month") ("address") + ("organization" "Sponsoring organization of the conference") + ("publisher" "Publishing company, its location") + ("note"))) ("Reference" "Single-Volume Work of Reference" ; same as @collection (("editor") ("title") ("date" nil nil 1) ("year" nil nil -1)) nil @@ -848,6 +862,15 @@ for a new entry." (("type" "Type of the PhD thesis") ("address" "Address of the school (if not part of field \"school\") or country") ("month") ("note"))) + ("MastersThesis" "Master's Thesis" + (("author") + ("title" "Title of the master's thesis (BibTeX converts it to lowercase)") + ("school" "School where the master's thesis was written") + ("year")) + nil + (("type" "Type of the master's thesis (if other than \"Master's thesis\")") + ("address" "Address of the school (if not part of field \"school\") or country") + ("month") ("note"))) ("TechReport" "Technical Report" (("author") ("title" "Title of the technical report (BibTeX converts it to lowercase)") @@ -2275,11 +2298,17 @@ is non-nil, FUN is not called for @String entries." (set-marker-insertion-type end-marker t) (save-excursion (goto-char (point-min)) - (while (setq found (bibtex-skip-to-valid-entry)) - (set-marker end-marker (cdr found)) - (looking-at bibtex-any-entry-maybe-empty-head) - (funcall fun (bibtex-key-in-head "") (car found) end-marker) - (goto-char end-marker))))) + (let ((prev (point))) + (while (setq found (bibtex-skip-to-valid-entry)) + ;; If we have invalid entries, ensure that we have forward + ;; progress so that we don't infloop. + (if (= (point) prev) + (forward-line 1) + (setq prev (point)) + (set-marker end-marker (cdr found)) + (looking-at bibtex-any-entry-maybe-empty-head) + (funcall fun (bibtex-key-in-head "") (car found) end-marker) + (goto-char end-marker))))))) (defun bibtex-progress-message (&optional flag interval) "Echo a message about progress of current buffer. @@ -5010,7 +5039,7 @@ on the value of `bibtex-entry-format'. If the reference key of the entry is empty or a prefix argument is given, calculate a new reference key. (Note: this works only if fields in entry begin on separate lines prior to calling `bibtex-clean-entry' or if -'realign is contained in `bibtex-entry-format'.) +`realign' is contained in `bibtex-entry-format'.) Don't call `bibtex-clean-entry' on @Preamble entries. At end of the cleaning process, the functions in `bibtex-clean-entry-hook' are called with region narrowed to entry." diff --git a/lisp/textmodes/emacs-news-mode.el b/lisp/textmodes/emacs-news-mode.el new file mode 100644 index 00000000000..fdb3cb86284 --- /dev/null +++ b/lisp/textmodes/emacs-news-mode.el @@ -0,0 +1,224 @@ +;;; emacs-news-mode.el --- major mode to edit and view the NEWS file -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Keywords: tools + +;; 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 . + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +(defgroup emacs-news-mode nil + "Major mode for editing and viewing the Emacs NEWS file." + :group 'lisp) + +(defface emacs-news-is-documented + '((t :inherit font-lock-type-face)) + "Face used for displaying the \"is documented\" tag." + :version "29.1") + +(defface emacs-news-does-not-need-documentation + '((t :inherit font-lock-preprocessor-face)) + "Face used for displaying the \"does not need documentation\" tag." + :version "29.1") + +(defvar-keymap emacs-news-mode-map + "C-c C-s" #'emacs-news-next-untagged-entry + "C-c C-r" #'emacs-news-previous-untagged-entry + "C-c C-g" #'emacs-news-goto-section + "C-c C-f" #'emacs-news-find-heading + "C-c C-n" #'emacs-news-count-untagged-entries) + +(defvar emacs-news-mode-font-lock-keywords + `(("^---$" 0 'emacs-news-does-not-need-documentation) + ("^\\+\\+\\+$" 0 'emacs-news-is-documented))) + +(defun emacs-news--mode-common () + (setq-local font-lock-defaults '(emacs-news-mode-font-lock-keywords t)) + (setq-local outline-regexp "\\*+ " + outline-minor-mode-cycle t + ;; We subtract one from the level, because we have a + ;; space after the asterisks. + outline-level (lambda () (1- (length (match-string 0)))) + outline-minor-mode-highlight 'append) + (outline-minor-mode)) + +;;;###autoload +(define-derived-mode emacs-news-mode text-mode "NEWS" + "Major mode for editing the Emacs NEWS file." + (setq-local fill-paragraph-function #'emacs-news--fill-paragraph) + (emacs-news--mode-common)) + +;;;###autoload +(define-derived-mode emacs-news-view-mode special-mode "NEWS" + "Major mode for viewing the Emacs NEWS file." + (setq buffer-read-only t) + (emacs-news--buttonize) + (button-mode) + (emacs-news--mode-common)) + +(defun emacs-news--fill-paragraph (&optional justify) + (cond + ;; We're in a heading -- do nothing. + ((save-excursion + (beginning-of-line) + (looking-at "\\*+ ")) + ) + ;; We're in a news item -- exclude the heading before filling. + ((and (save-excursion + (re-search-backward (concat "^\\(?:" paragraph-start "\\|\\*+ \\)") + nil t)) + (= (char-after (match-beginning 0)) ?*)) + (save-restriction + (narrow-to-region (save-excursion + (goto-char (match-beginning 0)) + (forward-line 1) + (point)) + (point-max)) + (fill-paragraph justify))) + ;; Fill normally. + (t + (fill-paragraph justify)))) + +(defun emacs-news-next-untagged-entry (&optional reverse) + "Go to the next untagged NEWS entry. +If REVERSE (interactively, the prefix), go to the previous +untagged NEWS entry." + (interactive "P" emacs-news-mode) + (let ((start (point)) + (found nil)) + ;; Don't consider the current line, because that would stop + ;; progress if calling this command repeatedly. + (unless reverse + (forward-line 1)) + (while (and (not found) + (funcall (if reverse #'re-search-backward + #'re-search-forward) + "^\\(\\*+\\) " nil t)) + (when (and (not (save-excursion + (forward-line -1) + (looking-at "---$\\|\\+\\+\\+$"))) + ;; We have an entry without a tag before it, but + ;; check whether it's a heading (which we can + ;; determine if the next entry has more asterisks). + (not (emacs-news--heading-p))) + ;; It wasn't a sub-heading, so we've found one. + (setq found t))) + (if found + (progn + (push-mark start) + (message "Untagged entry") + (beginning-of-line) + t) + (message "No further untagged entries") + (goto-char start) + nil))) + +(defun emacs-news--heading-p () + (save-excursion + (beginning-of-line) + ;; A heading starts with * characters, and then a blank line, and + ;; then paragraphs with more * characters than in the heading. + (and (looking-at "\\(\\*+\\) ") + (let ((level (length (match-string 1)))) + (forward-line 1) + (and (looking-at "$") + (re-search-forward "^\\(\\*+\\) " nil t) + (> (length (match-string 1)) level)))))) + +(defun emacs-news-previous-untagged-entry () + "Go to the previous untagged NEWS entry." + (interactive nil emacs-news-mode) + (emacs-news-next-untagged-entry t)) + +(defun emacs-news-count-untagged-entries () + "Say how many untagged entries there are in the current NEWS buffer." + (interactive nil emacs-news-mode) + (save-excursion + (goto-char (point-min)) + (let ((i 0)) + (while (emacs-news-next-untagged-entry) + (setq i (1+ i))) + (message (if (= i 1) + "There's 1 untagged entry" + (format "There are %s untagged entries" i)))))) + +(defun emacs-news--buttonize () + "Make manual and symbol references into buttons." + (save-excursion + (with-silent-modifications + (let ((inhibit-read-only t)) + ;; Do functions and variables. + (goto-char (point-min)) + (search-forward "\f" nil t) + (while (re-search-forward "'\\([^-][^ \t\n]+\\)'" nil t) + ;; Filter out references to key sequences. + (let ((string (match-string 1))) + (when-let ((symbol (intern-soft string))) + (when (or (boundp symbol) + (fboundp symbol)) + (buttonize-region (match-beginning 1) (match-end 1) + (lambda (symbol) + (describe-symbol symbol)) + symbol))))) + ;; Do manual references. + (goto-char (point-min)) + (search-forward "\f" nil t) + (while (re-search-forward "\"\\(([a-z0-9]+)[ \n][^\"]\\{1,80\\}\\)\"" + nil t) + (buttonize-region (match-beginning 1) (match-end 1) + (lambda (node) (info node)) + (match-string 1))))))) + +(defun emacs-news--sections (regexp) + (let ((sections nil)) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward (concat "^" regexp "\\(.*\\)") nil t) + (when (save-match-data (emacs-news--heading-p)) + (push (buffer-substring-no-properties + (match-beginning 1) (match-end 1)) + sections)))) + (nreverse sections))) + +(defun emacs-news-goto-section (section) + "Go to SECTION in the Emacs NEWS file." + (interactive (list + (completing-read "Goto section: " (emacs-news--sections "\\* ") + nil t)) + emacs-news-mode) + (goto-char (point-min)) + (when (search-forward (concat "\n* " section) nil t) + (beginning-of-line))) + +(defun emacs-news-find-heading (heading) + "Go to HEADING in the Emacs NEWS file." + (interactive (list + (completing-read "Goto heading: " + (emacs-news--sections "\\*\\*\\*? ") + nil t)) + emacs-news-mode) + (goto-char (point-min)) + (when (re-search-forward (concat "^*+ " (regexp-quote heading)) nil t) + (beginning-of-line))) + +(provide 'emacs-news-mode) + +;;; emacs-news-mode.el ends here diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index d3c832a40da..88a8395c88a 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -29,6 +29,8 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) + (defgroup fill nil "Indenting and filling text." :link '(custom-manual "(emacs)Filling") @@ -839,75 +841,67 @@ region, instead of just filling the current paragraph." (interactive (progn (barf-if-buffer-read-only) (list (if current-prefix-arg 'full) t))) - (let ((hash (and (not (buffer-modified-p)) - (buffer-hash)))) - (prog1 - (or - ;; 1. Fill the region if it is active when called interactively. - (and region transient-mark-mode mark-active - (not (eq (region-beginning) (region-end))) - (or (fill-region (region-beginning) (region-end) justify) t)) - ;; 2. Try fill-paragraph-function. - (and (not (eq fill-paragraph-function t)) - (or fill-paragraph-function - (and (minibufferp (current-buffer)) - (= 1 (point-min)))) - (let ((function (or fill-paragraph-function - ;; In the minibuffer, don't count - ;; the width of the prompt. - 'fill-minibuffer-function)) - ;; If fill-paragraph-function is set, it probably - ;; takes care of comments and stuff. If not, it - ;; will have to set fill-paragraph-handle-comment - ;; back to t explicitly or return nil. - (fill-paragraph-handle-comment nil) - (fill-paragraph-function t)) - (funcall function justify))) - ;; 3. Try our syntax-aware filling code. - (and fill-paragraph-handle-comment - ;; Our code only handles \n-terminated comments right now. - comment-start (equal comment-end "") - (let ((fill-paragraph-handle-comment nil)) - (fill-comment-paragraph justify))) - ;; 4. If it all fails, default to the good ol' text paragraph filling. - (let ((before (point)) - (paragraph-start paragraph-start) - ;; Fill prefix used for filling the paragraph. - fill-pfx) - ;; Try to prevent code sections and comment sections from being - ;; filled together. - (when (and fill-paragraph-handle-comment comment-start-skip) - (setq paragraph-start - (concat paragraph-start "\\|[ \t]*\\(?:" - comment-start-skip "\\)"))) - (save-excursion - ;; To make sure the return value of forward-paragraph is - ;; meaningful, we have to start from the beginning of - ;; line, otherwise skipping past the last few chars of a - ;; paragraph-separator would count as a paragraph (and - ;; not skipping any chars at EOB would not count as a - ;; paragraph even if it is). - (move-to-left-margin) - (if (not (zerop (fill-forward-paragraph 1))) - ;; There's no paragraph at or after point: give up. - (setq fill-pfx "") - (let ((end (point)) - (beg (progn (fill-forward-paragraph -1) (point)))) - (goto-char before) - (setq fill-pfx - (if use-hard-newlines - ;; Can't use fill-region-as-paragraph, since this - ;; paragraph may still contain hard newlines. See - ;; fill-region. - (fill-region beg end justify) - (fill-region-as-paragraph beg end justify)))))) - fill-pfx)) - ;; If we didn't change anything in the buffer (and the buffer - ;; was previously unmodified), then flip the modification status - ;; back to "unchanged". - (when (and hash - (equal hash (buffer-hash))) - (set-buffer-modified-p nil))))) + (with-buffer-unmodified-if-unchanged + (or + ;; 1. Fill the region if it is active when called interactively. + (and region transient-mark-mode mark-active + (not (eq (region-beginning) (region-end))) + (or (fill-region (region-beginning) (region-end) justify) t)) + ;; 2. Try fill-paragraph-function. + (and (not (eq fill-paragraph-function t)) + (or fill-paragraph-function + (and (minibufferp (current-buffer)) + (= 1 (point-min)))) + (let ((function (or fill-paragraph-function + ;; In the minibuffer, don't count + ;; the width of the prompt. + 'fill-minibuffer-function)) + ;; If fill-paragraph-function is set, it probably + ;; takes care of comments and stuff. If not, it + ;; will have to set fill-paragraph-handle-comment + ;; back to t explicitly or return nil. + (fill-paragraph-handle-comment nil) + (fill-paragraph-function t)) + (funcall function justify))) + ;; 3. Try our syntax-aware filling code. + (and fill-paragraph-handle-comment + ;; Our code only handles \n-terminated comments right now. + comment-start (equal comment-end "") + (let ((fill-paragraph-handle-comment nil)) + (fill-comment-paragraph justify))) + ;; 4. If it all fails, default to the good ol' text paragraph filling. + (let ((before (point)) + (paragraph-start paragraph-start) + ;; Fill prefix used for filling the paragraph. + fill-pfx) + ;; Try to prevent code sections and comment sections from being + ;; filled together. + (when (and fill-paragraph-handle-comment comment-start-skip) + (setq paragraph-start + (concat paragraph-start "\\|[ \t]*\\(?:" + comment-start-skip "\\)"))) + (save-excursion + ;; To make sure the return value of forward-paragraph is + ;; meaningful, we have to start from the beginning of + ;; line, otherwise skipping past the last few chars of a + ;; paragraph-separator would count as a paragraph (and + ;; not skipping any chars at EOB would not count as a + ;; paragraph even if it is). + (move-to-left-margin) + (if (not (zerop (fill-forward-paragraph 1))) + ;; There's no paragraph at or after point: give up. + (setq fill-pfx "") + (let ((end (point)) + (beg (progn (fill-forward-paragraph -1) (point)))) + (goto-char before) + (setq fill-pfx + (if use-hard-newlines + ;; Can't use fill-region-as-paragraph, since this + ;; paragraph may still contain hard newlines. See + ;; fill-region. + (fill-region beg end justify) + (fill-region-as-paragraph beg end justify)))))) + fill-pfx)))) (declare-function comment-search-forward "newcomment" (limit &optional noerror)) (declare-function comment-string-strip "newcomment" (str beforep afterp)) diff --git a/lisp/textmodes/page.el b/lisp/textmodes/page.el index 3fc18323349..5d6f017eb99 100644 --- a/lisp/textmodes/page.el +++ b/lisp/textmodes/page.el @@ -35,11 +35,18 @@ A page boundary is any line whose beginning matches the regexp (interactive "p") (or count (setq count 1)) (while (and (> count 0) (not (eobp))) - ;; In case the page-delimiter matches the null string, - ;; don't find a match without moving. - (if (bolp) (forward-char 1)) - (unless (re-search-forward page-delimiter nil t) - (goto-char (point-max))) + (if (and (looking-at page-delimiter) + (> (match-end 0) (point))) + ;; If we're standing at the page delimiter, then just skip to + ;; the end of it. (But only if it's not a zero-length + ;; delimiter, because then we wouldn't have forward progress.) + (goto-char (match-end 0)) + ;; In case the page-delimiter matches the null string, + ;; don't find a match without moving. + (when (bolp) + (forward-char 1)) + (unless (re-search-forward page-delimiter nil t) + (goto-char (point-max)))) (setq count (1- count))) (while (and (< count 0) (not (bobp))) ;; In case the page-delimiter matches the null string, diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el index 2dbb4484a71..062cea9c505 100644 --- a/lisp/textmodes/reftex-global.el +++ b/lisp/textmodes/reftex-global.el @@ -88,6 +88,12 @@ No active TAGS table is required." (defun reftex-query-replace-document (&optional from to delimited) "Do `query-replace-regexp' of FROM with TO over the entire document. Third arg DELIMITED (prefix arg) means replace only word-delimited matches. + +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. + If you exit (\\[keyboard-quit], RET or q), you can resume the query replace with the command \\[tags-loop-continue]. No active TAGS table is required." diff --git a/lisp/textmodes/reftex-parse.el b/lisp/textmodes/reftex-parse.el index 016c9cf3990..49cef297882 100644 --- a/lisp/textmodes/reftex-parse.el +++ b/lisp/textmodes/reftex-parse.el @@ -370,13 +370,18 @@ of master file." docstruct)) (defun reftex-using-biblatex-p () - "Return non-nil if we are using biblatex rather than bibtex." + "Return non-nil if we are using biblatex or other specific cite package. +biblatex and other similar packages like multibib allow multiple macro +calls to load a bibliography file. This function should be able to +detect those packages." (if (boundp 'TeX-active-styles) ;; the sophisticated AUCTeX way - (member "biblatex" TeX-active-styles) + (or (member "biblatex" TeX-active-styles) + (member "multibib" TeX-active-styles)) ;; poor-man's check... (save-excursion - (re-search-forward "^[^%\n]*?\\\\usepackage.*{biblatex}" nil t)))) + (re-search-forward + "^[^%\n]*?\\\\usepackage\\(\\[[^]]*\\]\\)?{biblatex\\|multibib}" nil t)))) ;;;###autoload (defun reftex-locate-bibliography-files (master-dir &optional files) @@ -384,7 +389,7 @@ of master file." (unless files (save-excursion (goto-char (point-min)) - ;; when biblatex is used, multiple \bibliography or + ;; when biblatex or multibib are used, multiple \bibliography or ;; \addbibresource macros are allowed. With plain bibtex, only ;; the first is used. (let ((using-biblatex (reftex-using-biblatex-p)) @@ -392,7 +397,7 @@ of master file." (while (and again (re-search-forward (concat - ;; "\\(\\`\\|[\n\r]\\)[^%]*\\\\\\(" + ;; "\\(\\`\\|[\n\r]\\)[^%]*\\\\\\(" "\\(^\\)[^%\n\r]*\\\\\\(" (mapconcat #'identity reftex-bibliography-commands "\\|") "\\)\\(\\[.+?\\]\\)?{[ \t]*\\([^}]+\\)") @@ -415,7 +420,7 @@ of master file." ;; find the file (reftex-locate-file x "bib" master-dir))) files)) - (delq nil files))) + (delq nil (delete-dups files)))) (defun reftex-replace-label-list-segment (old insert &optional entirely) "Replace the segment in OLD which corresponds to INSERT. diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el index 9d3e9effe6e..6a91cef1d94 100644 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@ -2351,7 +2351,7 @@ If user selects bullets or #, it's just added with position arranged by `rst-insert-list-new-tag'. If user selects enumerations, a further prompt is given. User need to -input a starting item, for example 'e' for 'A)' style. The position is +input a starting item, for example `e' for `A)' style. The position is also arranged by `rst-insert-list-new-tag'." (let* ((itemstyle (completing-read (format-prompt "Select preferred item style" "#.") diff --git a/lisp/textmodes/string-edit.el b/lisp/textmodes/string-edit.el new file mode 100644 index 00000000000..ab0b3b3bd7c --- /dev/null +++ b/lisp/textmodes/string-edit.el @@ -0,0 +1,129 @@ +;;; string-edit.el --- editing long strings -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org + +;; 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 . + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) + +(defface string-edit-prompt + '((t (:inherit font-lock-comment-face))) + "Face used on `string-edit' help text." + :group 'text + :version "29.1") + +(defvar string-edit--success-callback) +(defvar string-edit--abort-callback) + +;;;###autoload +(cl-defun string-edit (prompt string success-callback + &key abort-callback) + "Switch to a new buffer to edit STRING. +When the user finishes editing (with \\\\[string-edit-done]), SUCCESS-CALLBACK +is called with the resulting string. + +If the user aborts (with \\\\[string-edit-abort]), ABORT-CALLBACK (if any) is +called with no parameters. + +PROMPT will be inserted at the start of the buffer, but won't be +included in the resulting string. If PROMPT is nil, no help text +will be inserted." + (pop-to-buffer-same-window (generate-new-buffer "*edit string*")) + (when prompt + (let ((inhibit-read-only t)) + (insert prompt) + (ensure-empty-lines 0) + (add-text-properties (point-min) (point) + (list 'intangible t + 'face 'string-edit-prompt + 'read-only t)) + (insert (propertize (make-separator-line) 'rear-nonsticky t)) + (add-text-properties (point-min) (point) + (list 'string-edit--prompt t)))) + (let ((start (point))) + (insert string) + (goto-char start)) + (set-buffer-modified-p nil) + (setq buffer-undo-list nil) + (string-edit-mode) + (setq-local string-edit--success-callback success-callback) + (when abort-callback + (setq-local string-edit--abort-callback abort-callback)) + (setq-local header-line-format + (substitute-command-keys + "Type \\\\[string-edit-done] when you've finished editing or \\[string-edit-abort] to abort")) + (message "%s" (substitute-command-keys + "Type \\\\[string-edit-done] when you've finished editing"))) + +;;;###autoload +(defun read-string-from-buffer (prompt string) + "Switch to a new buffer to edit STRING in a recursive edit. +The user finishes editing with \\\\[string-edit-done], or aborts with \\\\[string-edit-abort]). + +PROMPT will be inserted at the start of the buffer, but won't be +included in the resulting string. If nil, no prompt will be +inserted in the buffer." + (string-edit + prompt + string + (lambda (edited) + (setq string edited) + (exit-recursive-edit)) + :abort-callback (lambda () + (exit-recursive-edit) + (error "Aborted edit"))) + (recursive-edit) + string) + +(defvar-keymap string-edit-mode-map + "C-c C-c" #'string-edit-done + "C-c C-k" #'string-edit-abort) + +(define-derived-mode string-edit-mode text-mode "String" + "Mode for editing strings." + :interactive nil) + +(defun string-edit-done () + "Finish editing the string and call the callback function. +This will kill the current buffer." + (interactive) + (goto-char (point-min)) + ;; Skip past the help text. + (when-let ((match (text-property-search-forward + 'string-edit--prompt nil t))) + (goto-char (prop-match-beginning match))) + (let ((string (buffer-substring (point) (point-max))) + (callback string-edit--success-callback)) + (kill-buffer (current-buffer)) + (funcall callback string))) + +(defun string-edit-abort () + "Abort editing the current string." + (interactive) + (let ((callback string-edit--abort-callback)) + (kill-buffer (current-buffer)) + (when callback + (funcall callback)))) + +(provide 'string-edit) + +;;; string-edit.el ends here diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index ab94036d01d..da4d7cc442d 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -2989,13 +2989,7 @@ There might be text before point." (put-text-property (1- (match-beginning 1)) (match-beginning 1) 'syntax-table - (if (= (1+ (line-beginning-position)) (match-beginning 1)) - ;; The `%' is a single-char comment, which Emacs - ;; syntax-table can't deal with. We could turn it - ;; into a non-comment, or use `\n%' or `%^' as the comment. - ;; Instead, we include it in the ^^A comment. - (string-to-syntax "< b") - (string-to-syntax ">"))) + (string-to-syntax ">")) (let ((end (line-end-position))) (if (< end (point-max)) (put-text-property @@ -3018,8 +3012,9 @@ There might be text before point." (defconst doctex-syntax-propertize-rules (syntax-propertize-precompile-rules latex-syntax-propertize-rules - ;; For DocTeX comment-in-doc. - ("\\(\\^\\)\\^A" (1 (doctex-font-lock-^^A)))))) + ;; For DocTeX comment-in-doc (DocTeX ≥3 also allows ^^X). + ;; We make the comment start on the second char because of bug#35140. + ("\\^\\(\\^\\)[AX]" (1 (doctex-font-lock-^^A)))))) (defvar doctex-font-lock-keywords (append tex-font-lock-keywords @@ -3568,28 +3563,122 @@ There might be text before point." ("\\ordmasculine" . ?º) ("\\lambdabar" . ?ƛ) ("\\celsius" . ?℃) + ;; Text symbols formerly part of textcomp package: + ("\\textdollar" . ?$) + ("\\textborn" . ?*) + ("\\textless" . ?<) + ("\\textgreater" . ?>) + ("\\textbackslash" . ?\\) + ("\\textasciicircum" . ?^) + ("\\textunderscore" . ?_) + ("\\textbraceleft" . ?\{) + ("\\textbar" . ?|) + ("\\textbraceright" . ?\}) + ("\\textasciitilde" . ?~) + ("\\textexclamdown" . ?¡) + ("\\textcent" . ?¢) + ("\\textsterling" . ?£) + ("\\textcurrency" . ?¤) + ("\\textyen" . ?¥) + ("\\textbrokenbar" . ?¦) + ("\\textsection" . ?§) + ("\\textasciidieresis" . ?¨) + ("\\textcopyright" . ?©) + ("\\textordfeminine" . ?ª) + ("\\guillemetleft" . ?«) + ("\\guillemotleft" . ?«) + ("\\textlnot" . ?¬) + ("\\textregistered" . ?®) + ("\\textasciimacron" . ?¯) + ("\\textdegree" . ?°) + ("\\textpm" . ?±) + ("\\texttwosuperior" . ?²) + ("\\textthreesuperior" . ?³) + ("\\textasciiacute" . ?´) ("\\textmu" . ?µ) - ("\\textfractionsolidus" . ?⁄) - ("\\textbigcircle" . ?⃝) - ("\\textmusicalnote" . ?♪) - ("\\textdied" . ?✝) - ("\\textcolonmonetary" . ?₡) - ("\\textwon" . ?₩) - ("\\textnaira" . ?₦) - ("\\textpeso" . ?₱) - ("\\textlira" . ?₤) - ("\\textrecipe" . ?℞) - ("\\textinterrobang" . ?‽) - ("\\textpertenthousand" . ?‱) + ("\\textparagraph" . ?¶) + ("\\textpilcrow" . ?¶) + ("\\textperiodcentered" . ?·) + ("\\textonesuperior" . ?¹) + ("\\textordmasculine" . ?º) + ("\\guillemetright" . ?») + ("\\guillemotright" . ?») + ("\\textonequarter" . ?¼) + ("\\textonehalf" . ?½) + ("\\textthreequarters" . ?¾) + ("\\textquestiondown" . ?¿) + ("\\texttimes" . ?×) + ("\\textdiv" . ?÷) + ("\\textflorin" . ?ƒ) + ("\\textasciicaron" . ?ˇ) + ("\\textasciibreve" . ?˘) + ("\\textacutedbl" . ?˝) + ("\\textgravedbl" . 757) + ("\\texttildelow" . 759) ("\\textbaht" . ?฿) - ("\\textnumero" . ?№) + ("\\textendash" . ?–) + ("\\textemdash" . ?—) + ("\\textbardbl" . ?‖) + ("\\textquoteleft" . 8216) + ("\\textquoteright" . 8217) + ("\\quotesinglbase" . 8218) + ("\\textquotedblleft" . 8220) + ("\\textquotedblright" . 8221) + ("\\quotedblbase" . 8222) + ;; \textdagger and \textdied are replaced with DAGGER (#x2020) and + ;; not with LATIN CROSS (#x271d) + ("\\textdagger" . ?†) + ("\\textdied" . ?†) + ("\\textdaggerdbl" . ?‡) + ("\\textbullet" . ?•) + ("\\textellipsis" . ?…) + ("\\textperthousand" . ?‰) + ("\\textpertenthousand" . ?‱) + ("\\guilsinglleft" . ?‹) + ("\\guilsinglright" . ?›) + ("\\textreferencemark" . ?※) + ("\\textinterrobang" . ?‽) + ("\\textfractionsolidus" . ?⁄) + ("\\textlquill" . 8261) ; Literal ?⁅ breaks indentation + ("\\textrquill" . 8262) ; Literal ?⁆ breaks indentation ("\\textdiscount" . ?⁒) - ("\\textestimated" . ?℮) - ("\\textopenbullet" . ?◦) - ("\\textlquill" . 8261) ; Literal ?⁅ breaks indentation. - ("\\textrquill" . 8262) ; Literal ?⁆ breaks indentation. + ("\\textcolonmonetary" . ?₡) + ("\\textlira" . ?₤) + ("\\textnaira" . ?₦) + ("\\textwon" . ?₩) + ("\\textdong" . ?₫) + ("\\texteuro" . ?€) + ("\\textpeso" . ?₱) + ("\\textguarani" . ?₲) + ("\\textcelsius" . ?℃) + ("\\textnumero" . ?№) ("\\textcircledP" . ?℗) - ("\\textreferencemark" . ?※)) + ("\\textrecipe" . ?℞) + ("\\textservicemark" . ?℠) + ("\\texttrademark" . ?™) + ("\\textohm" . ?Ω) + ("\\textmho" . ?℧) + ("\\textestimated" . ?℮) + ("\\textleftarrow" . ?←) + ("\\textuparrow" . ?↑) + ("\\textrightarrow" . ?→) + ("\\textdownarrow" . ?↓) + ("\\textminus" . ?−) + ("\\textsurd" . ?√) + ("\\textlangle" . 9001) ; Literal ?〈 breaks indentation + ("\\textrangle" . 9002) ; Literal ?〉 breaks indentation + ("\\textblank" . ?␢) + ("\\textvisiblespace" . ?␣) + ("\\textopenbullet" . ?◦) + ;; \textbigcircle is replaced with LARGE CIRCLE (#x25ef) and not + ;; with COMBINING ENCLOSING CIRCLE (#x20dd) + ("\\textbigcircle" . ?◯) + ("\\textmusicalnote" . ?♪) + ("\\textmarried" . ?⚭) + ("\\textdivorced" . ?⚮) + ("\\textlbrackdbl" . 10214) ; Literal ?⟦ breaks indentation + ("\\textrbrackdbl" . 10215) ; Literal ?⟧ breaks indentation + ("\\textinterrobangdown" . ?⸘)) "A `prettify-symbols-alist' usable for (La)TeX modes.") (defun tex--prettify-symbols-compose-p (_start end _match) diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el index 7f6ed3d1da9..71b8d82ed96 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -31,6 +31,16 @@ ;;; Code: +(eval-when-compile (require 'cl-lib) + (require 'flymake) + (require 'rx)) +(declare-function flymake-diag-region "flymake" + (buffer line &optional col)) +(declare-function flymake-make-diagnostic "flymake" + ( locus beg end type text + &optional data overlay-properties)) +(declare-function flymake--log-1 (level sublog msg &rest args)) + (eval-when-compile (require 'tex-mode)) (declare-function tex-buffer "tex-mode" ()) (declare-function tex-region "tex-mode" (beg end)) @@ -335,6 +345,69 @@ Subexpression 1 is what goes into the corresponding `@end' statement.") (if (re-search-backward "^@node[ \t]+\\([^,\n]+\\)" nil t) (match-string-no-properties 1)))) +;;; Flymake support +(defvar-local texinfo--flymake-proc nil) +(defun texinfo-flymake (report-fn &rest _) + "Texinfo checking for Flymake. + +REPORT-FN is the callback function." + (let ((executable (or (executable-find "makeinfo") + (executable-find "texi2any"))) + (source (current-buffer))) + + (unless executable + (error "Flymake for Texinfo requires `makeinfo' or `texi2any'")) + + (when (process-live-p texinfo--flymake-proc) + (kill-process texinfo--flymake-proc)) + + (save-restriction + (widen) + (setq texinfo--flymake-proc + (make-process + :name "texinfo-flymake" + :noquery t + :connection-type 'pipe + :buffer (generate-new-buffer " *texinfo-flymake*") + :command `(,executable "-o" ,null-device "-") + :sentinel + (lambda (proc _event) + (when (memq (process-status proc) '(exit signal)) + (unwind-protect + (if (eq (buffer-local-value 'texinfo--flymake-proc + source) + proc) + (with-current-buffer (process-buffer proc) + (goto-char (point-min)) + (cl-loop + while (search-forward-regexp + (rx line-start + "-:" + (group-n 1 (0+ digit)) ; Line + (optional ":" (group-n 2 (0+ digit))) ; col + ": " + (optional (group-n 3 "warning: ")) ; warn + (group-n 4 (0+ nonl)) ; Message + line-end) + nil t) + for msg = (match-string 4) + for (beg . end) = (flymake-diag-region + source + (string-to-number (match-string 1))) + for type = (if (match-string 3) + :warning + :error) + collect (flymake-make-diagnostic + source beg end type msg) + into diags + finally (funcall report-fn diags))) + (flymake-log :warning "Cancelling obsolete check %s" + proc)) + (kill-buffer (process-buffer proc))))))) + (process-send-region texinfo--flymake-proc (point-min) (point-max)) + (process-send-eof texinfo--flymake-proc)))) + + ;;; Texinfo mode ;;;###autoload @@ -454,7 +527,10 @@ value of `texinfo-mode-hook'." (let ((prevent-filling "^@\\(def\\|multitable\\)")) (if (null auto-fill-inhibit-regexp) prevent-filling - (concat auto-fill-inhibit-regexp "\\|" prevent-filling))))) + (concat auto-fill-inhibit-regexp "\\|" prevent-filling)))) + + ;; Set up Flymake support. + (add-hook 'flymake-diagnostic-functions #'texinfo-flymake nil t)) (defvar texinfo-fillable-commands '("@noindent") "A list of commands that can be filled.") diff --git a/lisp/textmodes/word-wrap-mode.el b/lisp/textmodes/word-wrap-mode.el new file mode 100644 index 00000000000..c354fc773a7 --- /dev/null +++ b/lisp/textmodes/word-wrap-mode.el @@ -0,0 +1,80 @@ +;;; word-wrap-mode.el --- minor mode for `word-wrap' tweaks -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org + +;; 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 . + +;;; Commentary: + +;;; Code: + +;; The list below lists all characters that have a general-category of +;; Zs, but with the ones we don't want to add here commented out. +(defcustom word-wrap-whitespace-characters + '(;;?\N{SPACE} + ;;?\N{NO-BREAK SPACE} + ?\N{OGHAM SPACE MARK} + ?\N{EN QUAD} + ?\N{EM QUAD} + ?\N{EN SPACE} + ?\N{EM SPACE} + ?\N{THREE-PER-EM SPACE} + ?\N{FOUR-PER-EM SPACE} + ?\N{SIX-PER-EM SPACE} + ?\N{FIGURE SPACE} + ?\N{PUNCTUATION SPACE} + ?\N{THIN SPACE} + ?\N{HAIR SPACE} + ;;?\N{NARROW NO-BREAK SPACE} + ?\N{MEDIUM MATHEMATICAL SPACE} + ?\N{IDEOGRAPHIC SPACE} + ;; Not in the Zs category: + ?\N{ZERO WIDTH SPACE}) + "Characters that `word-wrap-whitespace-mode' should add to `word-wrap'." + :version "29.1" + :type '(repeat character) + :group 'display) + +(defvar word-wrap-mode--previous-state) + +;;;###autoload +(define-minor-mode word-wrap-whitespace-mode + "Allow `word-wrap' to fold on all breaking whitespace characters. +The characters to break on are defined by `word-wrap-whitespace-characters'." + :group 'display + (if word-wrap-whitespace-mode + (progn + (setq-local word-wrap-mode--previous-state + (cons (category-table) + (buffer-local-set-state + word-wrap-by-category t + word-wrap t))) + (set-category-table (copy-category-table)) + (dolist (char word-wrap-whitespace-characters) + (modify-category-entry char ?|))) + (set-category-table (car word-wrap-mode--previous-state)) + (buffer-local-restore-state (cdr word-wrap-mode--previous-state)))) + +;;;###autoload +(define-globalized-minor-mode global-word-wrap-whitespace-mode + word-wrap-whitespace-mode word-wrap-whitespace-mode + :group 'display) + +(provide 'word-wrap-mode) + +;;; word-wrap-mode.el ends here diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 5f9ccc094af..b3dca5890f1 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -82,7 +82,7 @@ question. (defun forward-thing (thing &optional n) "Move forward to the end of the Nth next THING. THING should be a symbol specifying a type of syntactic entity. -Possibilities include `symbol', `list', `sexp', `defun', +Possibilities include `symbol', `list', `sexp', `defun', `number', `filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'." (let ((forward-op (or (get thing 'forward-op) @@ -97,7 +97,7 @@ Possibilities include `symbol', `list', `sexp', `defun', (defun bounds-of-thing-at-point (thing) "Determine the start and end buffer locations for the THING at point. THING should be a symbol specifying a type of syntactic entity. -Possibilities include `symbol', `list', `sexp', `defun', +Possibilities include `symbol', `list', `sexp', `defun', `number', `filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'. @@ -732,6 +732,7 @@ Signal an error if the entire string was not used." "Return the symbol at point, or nil if none is found." (let ((thing (thing-at-point 'symbol))) (if thing (intern thing)))) + ;;;###autoload (defun number-at-point () "Return the number at point, or nil if none is found. @@ -746,7 +747,9 @@ like \"0xBEEF09\" or \"#xBEEF09\", are recognized." (string-to-number (buffer-substring (match-beginning 0) (match-end 0)))))) +(put 'number 'forward-op 'forward-word) (put 'number 'thing-at-point 'number-at-point) + ;;;###autoload (defun list-at-point (&optional ignore-comment-or-string) "Return the Lisp list at point, or nil if none is found. diff --git a/lisp/thumbs.el b/lisp/thumbs.el index 695fa8a8562..3bf08dd6a58 100644 --- a/lisp/thumbs.el +++ b/lisp/thumbs.el @@ -296,7 +296,8 @@ smaller according to whether INCREMENT is 1 or -1." (defun thumbs-file-size (img) (let ((i (image-size - (find-image `((:type ,(image-type-from-file-name img) :file ,img))) t))) + (find-image `((:type ,(image-supported-file-p img) :file ,img))) + t))) (concat (number-to-string (round (car i))) "x" (number-to-string (round (cdr i)))))) @@ -399,7 +400,7 @@ and SAME-WINDOW to show thumbs in the same window." thumbs-image-num (or num 0)) (delete-region (point-min)(point-max)) (save-excursion - (thumbs-insert-image img (image-type-from-file-name img) 0))))) + (thumbs-insert-image img (image-supported-file-p img) 0))))) (defun thumbs-find-image-at-point (&optional img otherwin) "Display image IMG for thumbnail at point. @@ -533,7 +534,7 @@ Open another window." " - " (number-to-string num))) (let ((inhibit-read-only t)) (erase-buffer) - (thumbs-insert-image img (image-type-from-file-name img) 0) + (thumbs-insert-image img (image-supported-file-p img) 0) (goto-char (point-min)))) (setq thumbs-image-num num thumbs-current-image-filename img)))) @@ -765,7 +766,7 @@ ACTION and ARG should be a valid convert command." (define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot) (define-obsolete-function-alias 'thumbs-image-type - #'image-type-from-file-name "29.1") + #'image-supported-file-p "29.1") (provide 'thumbs) diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el index 7ec5c0beccc..82b458e0107 100644 --- a/lisp/tool-bar.el +++ b/lisp/tool-bar.el @@ -89,15 +89,29 @@ functions.") (declare-function image-mask-p "image.c" (spec &optional frame)) -(defconst tool-bar-keymap-cache (make-hash-table :weakness t :test 'equal)) +(defconst tool-bar-keymap-cache (make-hash-table :test #'equal)) + +(defun tool-bar--cache-key () + (cons (frame-terminal) (sxhash-eq tool-bar-map))) + +(defun tool-bar--flush-cache () + "Remove all cached entries that refer to the current `tool-bar-map'." + (let ((id (sxhash-eq tool-bar-map)) + (entries nil)) + (maphash (lambda (k _) + (when (equal (cdr k) id) + (push k entries))) + tool-bar-keymap-cache) + (dolist (k entries) + (remhash k tool-bar-keymap-cache)))) (defun tool-bar-make-keymap (&optional _ignore) "Generate an actual keymap from `tool-bar-map'. Its main job is to figure out which images to use based on the display's color capability and based on the available image libraries." - (let ((key (cons (frame-terminal) tool-bar-map))) - (or (gethash key tool-bar-keymap-cache) - (puthash key (tool-bar-make-keymap-1) tool-bar-keymap-cache)))) + (or (gethash (tool-bar--cache-key) tool-bar-keymap-cache) + (setf (gethash (tool-bar--cache-key) tool-bar-keymap-cache) + (tool-bar-make-keymap-1)))) (defun tool-bar-make-keymap-1 () "Generate an actual keymap from `tool-bar-map', without caching." @@ -139,7 +153,8 @@ ICON.xbm, using `find-image'. Use this function only to make bindings in the global value of `tool-bar-map'. To define items in any other map, use `tool-bar-local-item'." - (apply #'tool-bar-local-item icon def key tool-bar-map props)) + (apply #'tool-bar-local-item icon def key tool-bar-map props) + (tool-bar--flush-cache)) (defun tool-bar--image-expression (icon) "Return an expression that evaluates to an image spec for ICON." @@ -177,6 +192,7 @@ ICON.xbm, using `find-image'." (let* ((image-exp (tool-bar--image-expression icon))) (define-key-after map (vector key) `(menu-item ,(symbol-name key) ,def :image ,image-exp ,@props)) + (tool-bar--flush-cache) (force-mode-line-update))) ;;;###autoload @@ -243,6 +259,7 @@ holds a keymap." (setq rest (cdr rest))) (append `(menu-item ,(car defn) ,rest) (list :image image-exp) props)))) + (tool-bar--flush-cache) (force-mode-line-update)))) ;;; Set up some global items. Additions/deletions up for grabs. diff --git a/lisp/tooltip.el b/lisp/tooltip.el index 0ee3c38e26d..e24d03b8e87 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -377,7 +377,11 @@ It is also called if Tooltip mode is on, for text-only displays." (defun tooltip-show-help (msg) "Function installed as `show-help-function'. MSG is either a help string to display, or nil to cancel the display." - (if (and (display-graphic-p)) + (if (and (display-graphic-p) + ;; Tooltips can't be displayed on top of the global menu + ;; bar on NS. + (or (not (eq window-system 'ns)) + (not (menu-or-popup-active-p)))) (let ((previous-help tooltip-help-message)) (setq tooltip-help-message msg) (cond ((null msg) diff --git a/lisp/transient.el b/lisp/transient.el index 0d7f9d0317b..13e8de258bd 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -1384,7 +1384,7 @@ The optional argument COMMAND is intended for internal use. If you are contemplating using it in your own code, then you should probably use this instead: - (get COMMAND 'transient--suffix)" + (get COMMAND \\='transient--suffix)" (when command (cl-check-type command command)) (if (or transient--prefix diff --git a/lisp/tutorial.el b/lisp/tutorial.el index 2d313076e3a..0f3a1506d6b 100644 --- a/lisp/tutorial.el +++ b/lisp/tutorial.el @@ -385,7 +385,7 @@ correspond to what the tutorial says.\n\n") "Find the key bindings used in the tutorial that have changed. Return a list with elements of the form - '(KEY DEF-FUN DEF-FUN-TXT WHERE REMARK QUIET) + (KEY DEF-FUN DEF-FUN-TXT WHERE REMARK QUIET) where diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el index dd658b1b68b..53cefb46e4b 100644 --- a/lisp/url/url-auth.el +++ b/lisp/url/url-auth.el @@ -307,8 +307,8 @@ object." (defun url-digest-auth-build-response (key url realm attrs) "Compute authorization string for the given challenge using KEY. -The string looks like 'Digest username=\"John\", realm=\"The -Realm\", ...' +The string looks like \"Digest username=\"John\", realm=\"The +Realm\", ...\" Part of the challenge is already solved in a pre-computed KEY which is list of a realm (or a directory), user name, and hash diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index daeba17031d..b950a8994fb 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -36,6 +36,7 @@ (defvar url-current-object) (defvar url-http-after-change-function) (defvar url-http-chunked-counter) +(defvar url-http-chunked-last-crlf-missing) (defvar url-http-chunked-length) (defvar url-http-chunked-start) (defvar url-http-connection-opened) @@ -332,7 +333,10 @@ Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')." (if (and using-proxy ;; Bug#35969. (not (equal "https" (url-type url-http-target-url)))) - (url-recreate-url url-http-target-url) real-fname)) + (let ((url (copy-sequence url-http-target-url))) + (setf (url-host url) (puny-encode-domain (url-host url))) + (url-recreate-url url)) + real-fname)) " HTTP/" url-http-version "\r\n" ;; Version of MIME we speak "MIME-Version: 1.0\r\n" @@ -1068,90 +1072,105 @@ the callback to be triggered." Cannot give a sophisticated percentage, but we need a different function to look for the special 0-length chunk that signifies the end of the document." - (save-excursion - (goto-char st) - (let ((read-next-chunk t) - (case-fold-search t) - (regexp nil) - (no-initial-crlf nil)) - ;; We need to loop thru looking for more chunks even within - ;; one after-change-function call. - (while read-next-chunk - (setq no-initial-crlf (= 0 url-http-chunked-counter)) - (if url-http-content-type + (if url-http-chunked-last-crlf-missing + (progn + (goto-char url-http-chunked-last-crlf-missing) + (if (not (looking-at "\r\n")) + (url-http-debug + "Still spinning for the terminator of last chunk...") + (url-http-debug "Saw the last CRLF.") + (delete-region (match-beginning 0) (match-end 0)) + (when (url-http-parse-headers) + (url-http-activate-callback)))) + (save-excursion + (goto-char st) + (let ((read-next-chunk t) + (case-fold-search t) + (regexp nil) + (no-initial-crlf nil)) + ;; We need to loop thru looking for more chunks even within + ;; one after-change-function call. + (while read-next-chunk + (setq no-initial-crlf (= 0 url-http-chunked-counter)) + (if url-http-content-type + (url-display-percentage nil + "Reading [%s]... chunk #%d" + url-http-content-type url-http-chunked-counter) (url-display-percentage nil - "Reading [%s]... chunk #%d" - url-http-content-type url-http-chunked-counter) - (url-display-percentage nil - "Reading... chunk #%d" - url-http-chunked-counter)) - (url-http-debug "Reading chunk %d (%d %d %d)" - url-http-chunked-counter st nd length) - (setq regexp (if no-initial-crlf - "\\([0-9a-z]+\\).*\r?\n" - "\r?\n\\([0-9a-z]+\\).*\r?\n")) + "Reading... chunk #%d" + url-http-chunked-counter)) + (url-http-debug "Reading chunk %d (%d %d %d)" + url-http-chunked-counter st nd length) + (setq regexp (if no-initial-crlf + "\\([0-9a-z]+\\).*\r?\n" + "\r?\n\\([0-9a-z]+\\).*\r?\n")) - (if url-http-chunked-start - ;; We know how long the chunk is supposed to be, skip over - ;; leading crap if possible. - (if (> nd (+ url-http-chunked-start url-http-chunked-length)) - (progn - (url-http-debug "Got to the end of chunk #%d!" - url-http-chunked-counter) - (goto-char (+ url-http-chunked-start - url-http-chunked-length))) - (url-http-debug "Still need %d bytes to hit end of chunk" - (- (+ url-http-chunked-start - url-http-chunked-length) - nd)) - (setq read-next-chunk nil))) - (if (not read-next-chunk) - (url-http-debug "Still spinning for next chunk...") - (if no-initial-crlf (skip-chars-forward "\r\n")) - (if (not (looking-at regexp)) - (progn - ;; Must not have received the entirety of the chunk header, - ;; need to spin some more. - (url-http-debug "Did not see start of chunk @ %d!" (point)) - (setq read-next-chunk nil)) - ;; The data we got may have started in the middle of the - ;; initial chunk header, so move back to the start of the - ;; line and re-compute. - (when (= url-http-chunked-counter 0) - (beginning-of-line) - (looking-at regexp)) - (add-text-properties (match-beginning 0) (match-end 0) - (list 'chunked-encoding t - 'face 'cursor - 'invisible t)) - (setq url-http-chunked-length (string-to-number (buffer-substring - (match-beginning 1) - (match-end 1)) - 16) - url-http-chunked-counter (1+ url-http-chunked-counter) - url-http-chunked-start (set-marker - (or url-http-chunked-start - (make-marker)) - (match-end 0))) - (delete-region (match-beginning 0) (match-end 0)) - (url-http-debug "Saw start of chunk %d (length=%d, start=%d" - url-http-chunked-counter url-http-chunked-length - (marker-position url-http-chunked-start)) - (if (= 0 url-http-chunked-length) - (progn - ;; Found the end of the document! Wheee! - (url-http-debug "Saw end of stream chunk!") - (setq read-next-chunk nil) - (url-display-percentage nil nil) - ;; Every chunk, even the last 0-length one, is - ;; terminated by CRLF. Skip it. - (when (looking-at "\r?\n") - (url-http-debug "Removing terminator of last chunk") - (delete-region (match-beginning 0) (match-end 0))) - (if (re-search-forward "^\r?\n" nil t) - (url-http-debug "Saw end of trailers...")) - (if (url-http-parse-headers) - (url-http-activate-callback)))))))))) + (if url-http-chunked-start + ;; We know how long the chunk is supposed to be, skip over + ;; leading crap if possible. + (if (> nd (+ url-http-chunked-start url-http-chunked-length)) + (progn + (url-http-debug "Got to the end of chunk #%d!" + url-http-chunked-counter) + (goto-char (+ url-http-chunked-start + url-http-chunked-length))) + (url-http-debug "Still need %d bytes to hit end of chunk" + (- (+ url-http-chunked-start + url-http-chunked-length) + nd)) + (setq read-next-chunk nil))) + (if (not read-next-chunk) + (url-http-debug "Still spinning for next chunk...") + (if no-initial-crlf (skip-chars-forward "\r\n")) + (if (not (looking-at regexp)) + (progn + ;; Must not have received the entirety of the chunk header, + ;; need to spin some more. + (url-http-debug "Did not see start of chunk @ %d!" (point)) + (setq read-next-chunk nil)) + ;; The data we got may have started in the middle of the + ;; initial chunk header, so move back to the start of the + ;; line and re-compute. + (when (= url-http-chunked-counter 0) + (beginning-of-line) + (looking-at regexp)) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'chunked-encoding t + 'face 'cursor + 'invisible t)) + (setq url-http-chunked-length + (string-to-number (buffer-substring (match-beginning 1) + (match-end 1)) + 16) + url-http-chunked-counter (1+ url-http-chunked-counter) + url-http-chunked-start (set-marker + (or url-http-chunked-start + (make-marker)) + (match-end 0))) + (delete-region (match-beginning 0) (match-end 0)) + (url-http-debug "Saw start of chunk %d (length=%d, start=%d" + url-http-chunked-counter url-http-chunked-length + (marker-position url-http-chunked-start)) + (if (= 0 url-http-chunked-length) + (progn + ;; Found the end of the document! Wheee! + (url-http-debug "Saw end of stream chunk!") + (setq read-next-chunk nil) + (url-display-percentage nil nil) + ;; Every chunk, even the last 0-length one, is + ;; terminated by CRLF. Skip it. + (if (not (looking-at "\r?\n")) + (progn + (url-http-debug + "Spinning for the terminator of last chunk...") + (setq url-http-chunked-last-crlf-missing + (point))) + (url-http-debug "Removing terminator of last chunk") + (delete-region (match-beginning 0) (match-end 0)) + (when (re-search-forward "^\r?\n" nil t) + (url-http-debug "Saw end of trailers...")) + (when (url-http-parse-headers) + (url-http-activate-callback)))))))))))) (defun url-http-wait-for-headers-change-function (_st nd _length) ;; This will wait for the headers to arrive and then splice in the @@ -1335,6 +1354,7 @@ The return value of this function is the retrieval buffer." url-http-after-change-function url-http-response-version url-http-response-status + url-http-chunked-last-crlf-missing url-http-chunked-length url-http-chunked-counter url-http-chunked-start @@ -1359,6 +1379,7 @@ The return value of this function is the retrieval buffer." url-http-noninteractive url-request-noninteractive url-http-data url-request-data url-http-process connection + url-http-chunked-last-crlf-missing nil url-http-chunked-length nil url-http-chunked-start nil url-http-chunked-counter 0 @@ -1405,10 +1426,10 @@ The return value of this function is the retrieval buffer." (and proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n"))) "\r\n") - (url-host url-current-object) + (puny-encode-domain (url-host url-current-object)) (or (url-port url-current-object) url-https-default-port) - (url-host url-current-object)))) + (puny-encode-domain (url-host url-current-object))))) (defun url-https-proxy-after-change-function (_st _nd _length) (let* ((process-buffer (current-buffer)) @@ -1430,12 +1451,12 @@ The return value of this function is the retrieval buffer." (condition-case e (let ((tls-connection (gnutls-negotiate :process proc - :hostname (url-host url-current-object) + :hostname (puny-encode-domain (url-host url-current-object)) :verify-error nil))) ;; check certificate validity (setq tls-connection (nsm-verify-connection tls-connection - (url-host url-current-object) + (puny-encode-domain (url-host url-current-object)) (url-port url-current-object))) (with-current-buffer process-buffer (erase-buffer)) (set-process-buffer tls-connection process-buffer) diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el index 07a638f1ccd..922f26d65bc 100644 --- a/lisp/url/url-vars.el +++ b/lisp/url/url-vars.el @@ -1,7 +1,6 @@ ;;; url-vars.el --- Variables for Uniform Resource Locator tool -*- lexical-binding:t -*- -;; Copyright (C) 1996-1999, 2001, 2004-2022 Free Software Foundation, -;; Inc. +;; Copyright (C) 1996-2022 Free Software Foundation, Inc. ;; Keywords: comm, data, processes, hypermedia @@ -131,7 +130,7 @@ Samples: This variable controls several other variables and is _NOT_ automatically updated. Call the function `url-setup-privacy-info' after modifying this variable." - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (url-setup-privacy-info)) :type '(radio (const :tag "None (you believe in the basic goodness of humanity)" :value none) @@ -204,10 +203,9 @@ from the ACCESS_proxy environment variables." :type 'boolean :group 'url-cache) -(defvar url-mime-separator-chars (mapcar 'identity - (concat "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "abcdefghijklmnopqrstuvwxyz" - "0123456789'()+_,-./=?")) +(defvar url-mime-separator-chars (append "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "abcdefghijklmnopqrstuvwxyz" + "0123456789'()+_,-./=?") "Characters allowable in a MIME multipart separator.") (defcustom url-bad-port-list @@ -254,7 +252,7 @@ Generated according to current coding system priorities." (push (car elt) accum))) (nreverse accum))))) (concat (format "%s;q=1, " (pop ordered)) - (mapconcat 'symbol-name ordered ";q=0.5, ") + (mapconcat #'symbol-name ordered ";q=0.5, ") ";q=0.5"))) (defvar url-mime-charset-string nil @@ -425,7 +423,7 @@ This should be set, e.g. by mail user agents rendering HTML to avoid `bugs' which call home.") (defun url-interactive-p () - "Say whether the current request is from a interactive context." + "Non-nil when the current request is from an interactive context." (not (or url-request-noninteractive (bound-and-true-p url-http-noninteractive)))) @@ -435,5 +433,4 @@ This should be set, e.g. by mail user agents rendering HTML to avoid (make-obsolete-variable 'url-version 'emacs-version "28.1") (provide 'url-vars) - ;;; url-vars.el ends here diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 511cc89778d..5c13c7fc389 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -2634,42 +2634,55 @@ fixed, visit it in a buffer." (binary (concat "Binary files " file4 " and " file5 " \\(?7:differ\\)\n")) - (horb (concat "\\(?:" header "\\|" binary "\\)"))) + (horb (concat "\\(?:" header "\\|" binary "\\)?"))) (concat "diff.*?\\(?: a/\\(.*?\\) b/\\(.*\\)\\)?\n" - "\\(?:\\(?:old\\|new\\) mode .*\n\\)*" "\\(?:" ;; For new/deleted files, there might be no ;; header (and no hunk) if the file is/was empty. - "\\(?3:new\\(?6:\\)\\|deleted\\) file.*\n" - index "\\(?:" horb "\\)?" - ;; Normal case. - "\\|" index horb "\\)"))))) + "\\(?3:new\\(?6:\\)\\|deleted\\) file mode \\(?10:[0-7]\\{6\\}\\)\n" + index horb + ;; Normal case. There might be no header + ;; (and no hunk) if only the file mode + ;; changed. + "\\|" + "\\(?:old mode \\(?8:[0-7]\\{6\\}\\)\n\\)?" + "\\(?:new mode \\(?9:[0-7]\\{6\\}\\)\n\\)?" + index horb "\\)"))))) ;; The file names can be extracted either from the `diff' line ;; or from the two header lines. Prefer the header line info if ;; available since the `diff' line is ambiguous in case the ;; file names include " b/" or " a/". ;; FIXME: This prettification throws away all the information - ;; about file modes (and the index hashes). + ;; about the index hashes. (let ((oldfile (or (match-string 4) (match-string 1))) (newfile (or (match-string 5) (match-string 2))) (kind (if (match-beginning 7) " BINARY" - (unless (or (match-beginning 4) (match-beginning 5)) - " empty")))) + (unless (or (match-beginning 4) + (match-beginning 5) + (not (match-beginning 3))) + " empty"))) + (filemode + (cond + ((match-beginning 10) + (concat " file with mode " (match-string 10) " ")) + ((and (match-beginning 8) (match-beginning 9)) + (concat " file (mode changed from " + (match-string 8) " to " (match-string 9) ") ")) + (t " file ")))) (add-text-properties (match-beginning 0) (1- (match-end 0)) (list 'display (propertize (cond ((match-beginning 3) - (concat (capitalize (match-string 3)) kind " file" - " " + (concat (capitalize (match-string 3)) kind filemode (if (match-beginning 6) newfile oldfile))) - ((null (match-string 4)) - (concat "New" kind " file " newfile)) + ((and (null (match-string 4)) (match-string 5)) + (concat "New " kind filemode newfile)) ((null (match-string 2)) - (concat "Deleted" kind " file " oldfile)) + (concat "Deleted" kind filemode oldfile)) (t - (concat "Modified" kind " file " oldfile))) + (concat "Modified" kind filemode oldfile))) 'face '(diff-file-header diff-header)) 'font-lock-multiline t)))))) nil) diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el index 4abcf6c15a7..926993eebb7 100644 --- a/lisp/vc/diff.el +++ b/lisp/vc/diff.el @@ -52,6 +52,12 @@ set (`vc-git-diff-switches' for git, for instance), and "The command to use to run diff." :type 'string) +(defcustom diff-entire-buffers t + "If non-nil, diff the entire buffers, not just the visible part. +If nil, only use the narrowed-to parts of the buffers." + :type 'boolean + :version "29.1") + ;; prompt if prefix arg present (defun diff-switches () (if current-prefix-arg @@ -119,7 +125,9 @@ temporary file with the buffer's contents." (if (bufferp file-or-buf) (with-current-buffer file-or-buf (let ((tempfile (make-temp-file "buffer-content-"))) - (write-region nil nil tempfile nil 'nomessage) + (if diff-entire-buffers + (write-region nil nil tempfile nil 'nomessage) + (write-region (point-min) (point-max) tempfile nil 'nomessage)) tempfile)) (file-local-copy file-or-buf))) @@ -274,7 +282,9 @@ interactively for diff switches. Otherwise, the switches specified in the variable `diff-switches' are passed to the diff command. -OLD and NEW may each be a buffer or a buffer name." +OLD and NEW may each be a buffer or a buffer name. + +Also see the `diff-entire-buffers' variable." (interactive (let ((newb (read-buffer "Diff new buffer" (current-buffer) t)) (oldb (read-buffer "Diff original buffer" diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index 9952345db50..415b1564eda 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -134,11 +134,7 @@ "n" #'log-view-msg-next "p" #'log-view-msg-prev "TAB" #'log-view-msg-next - "" #'log-view-msg-prev - "N" #'log-view-file-next - "P" #'log-view-file-prev - "M-n" #'log-view-file-next - "M-p" #'log-view-file-prev) + "" #'log-view-msg-prev) (easy-menu-define log-view-mode-menu log-view-mode-map "Log-View Display Menu." @@ -166,9 +162,15 @@ ["Previous Log Entry" log-view-msg-prev :help "Go to the previous count'th log message"] ["Next File" log-view-file-next - :help "Go to the next count'th file"] + :help "Go to the next count'th file" + :active (derived-mode-p vc-cvs-log-view-mode + vc-rcs-log-view-mode + vc-sccs-log-view-mode)] ["Previous File" log-view-file-prev - :help "Go to the previous count'th file"])) + :help "Go to the previous count'th file" + :active (derived-mode-p vc-cvs-log-view-mode + vc-rcs-log-view-mode + vc-sccs-log-view-mode)])) (defvar log-view-mode-hook nil "Hook run at the end of `log-view-mode'.") diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index 836630acb5d..ee394a93af4 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -640,7 +640,7 @@ Returns nil if unable to find this information." ;; Could run `bzr status' in the directory and see if it succeeds, but ;; that's relatively expensive. (defalias 'vc-bzr-responsible-p #'vc-bzr-root - "Return non-nil if FILE is (potentially) controlled by bzr. + "Return the directory if FILE is (potentially) controlled by bzr. The criterion is that there is a `.bzr' directory in the same or a superior directory.") diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index e234b9a0447..1f81ff2e0fe 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -26,6 +26,7 @@ (require 'vc-rcs) (eval-when-compile (require 'vc)) +(require 'log-view) (declare-function vc-checkout "vc" (file &optional rev)) (declare-function vc-expand-dirs "vc" (file-or-dir-list backend)) @@ -308,7 +309,7 @@ to the CVS command." (vc-switches 'CVS 'register))) (defun vc-cvs-responsible-p (file) - "Return non-nil if CVS thinks it is responsible for FILE." + "Return the directory if CVS thinks it is responsible for FILE." (let ((dir (if (file-directory-p file) file (file-name-directory file)))) @@ -1257,6 +1258,14 @@ ignore file." (if sort (sort-lines nil (point-min) (point-max))) (save-buffer))))) +(defvar-keymap vc-cvs-log-view-mode-map + "N" #'log-view-file-next + "P" #'log-view-file-prev + "M-n" #'log-view-file-next + "M-p" #'log-view-file-prev) + +(define-derived-mode vc-cvs-log-view-mode log-view-mode "CVS-Log-View") + (provide 'vc-cvs) ;;; vc-cvs.el ends here diff --git a/lisp/vc/vc-dav.el b/lisp/vc/vc-dav.el index 61e2cd23900..94621599e4a 100644 --- a/lisp/vc/vc-dav.el +++ b/lisp/vc/vc-dav.el @@ -137,9 +137,9 @@ It should return a status of either 0 (no differences found), or ) (defun vc-dav-responsible-p (url) - "Return non-nil if DAV considers itself `responsible' for URL." + "Return the URL if DAV considers itself `responsible' for URL." ;; Check for DAV support on the web server. - (and t url)) + url) ;;; Unimplemented functions ;; diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 0d750515c3d..2e9de587bf9 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -933,6 +933,12 @@ To continue searching for next match, use command \\[tags-loop-continue]." "Do `query-replace-regexp' of FROM with TO, on all marked files. If a directory is marked, then use the files displayed for that directory. Third arg DELIMITED (prefix arg) means replace only word-delimited matches. + +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. + If you exit (\\[keyboard-quit], RET or q), you can resume the query replace with the command \\[tags-loop-continue]." ;; FIXME: this is almost a copy of `dired-do-query-replace-regexp'. This diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 20f3b1fba71..0a2b8fa53c3 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -40,6 +40,7 @@ (eval-when-compile (require 'cl-lib) (require 'vc)) +(require 'log-view) (declare-function vc-read-revision "vc" (prompt &optional files backend default initial-input)) @@ -288,7 +289,7 @@ to the RCS command." (match-string 1)))))) (defun vc-rcs-responsible-p (file) - "Return non-nil if RCS thinks it would be responsible for registering FILE." + "Return the directory if RCS thinks it would be responsible for FILE." ;; TODO: check for all the patterns in vc-rcs-master-templates (let ((dir (if (file-directory-p file) file @@ -1062,9 +1063,9 @@ file." (defun vc-rcs-consult-headers (file) "Search for RCS headers in FILE, and set properties accordingly. -Returns: nil if no headers were found - 'rev if a workfile revision was found - 'rev-and-lock if revision and lock info was found" +Returns: nil if no headers were found + `rev' if a workfile revision was found + `rev-and-lock' if revision and lock info was found" (cond ((not (get-file-buffer file)) nil) ((let (status version) @@ -1456,6 +1457,14 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." `((headers ,desc ,@headers) (revisions ,@revs))))) +(defvar-keymap vc-rcs-log-view-mode-map + "N" #'log-view-file-next + "P" #'log-view-file-prev + "M-n" #'log-view-file-next + "M-p" #'log-view-file-prev) + +(define-derived-mode vc-rcs-log-view-mode log-view-mode "RCS-Log-View") + (provide 'vc-rcs) ;;; vc-rcs.el ends here diff --git a/lisp/vc/vc-sccs.el b/lisp/vc/vc-sccs.el index 4bbf92b3274..9622bf5e097 100644 --- a/lisp/vc/vc-sccs.el +++ b/lisp/vc/vc-sccs.el @@ -27,6 +27,7 @@ (eval-when-compile (require 'vc)) +(require 'log-view) ;;; ;;; Customization options @@ -212,7 +213,7 @@ to the SCCS command." (vc-sccs-do-command nil 0 "get" (vc-master-name file))))) (defun vc-sccs-responsible-p (file) - "Return non-nil if SCCS thinks it would be responsible for registering FILE." + "Return the directory if SCCS thinks it would be responsible for FILE." ;; TODO: check for all the patterns in vc-sccs-master-templates (or (and (file-directory-p (expand-file-name "SCCS" (file-name-directory file))) @@ -518,6 +519,14 @@ If NAME is nil or a revision number string it's just passed through." (file-name-directory (vc-master-name file)))) (vc-parse-buffer (concat name "\t:\t" file "\t\\(.+\\)") 1)))) +(defvar-keymap vc-sccs-log-view-mode-map + "N" #'log-view-file-next + "P" #'log-view-file-prev + "M-n" #'log-view-file-next + "M-p" #'log-view-file-prev) + +(define-derived-mode vc-sccs-log-view-mode log-view-mode "SCCS-Log-View") + (provide 'vc-sccs) ;;; vc-sccs.el ends here diff --git a/lisp/vc/vc-src.el b/lisp/vc/vc-src.el index 1c1a7b5d139..5a252c55cb2 100644 --- a/lisp/vc/vc-src.el +++ b/lisp/vc/vc-src.el @@ -242,11 +242,13 @@ This function differs from vc-do-command in that it invokes `vc-src-program'." (vc-src-command nil files "add")) (defun vc-src-responsible-p (file) - "Return non-nil if SRC thinks it would be responsible for registering FILE." - (file-directory-p (expand-file-name ".src" - (if (file-directory-p file) - file - (file-name-directory file))))) + "Return the directory if SRC thinks it would be responsible for FILE." + (let ((dir (expand-file-name ".src" + (if (file-directory-p file) + file + (file-name-directory file))))) + (and (file-directory-p dir) + dir))) (defun vc-src-checkin (files comment &optional _rev) "SRC-specific version of `vc-backend-checkin'. diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index a6124acadd2..3508f684c49 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -220,7 +220,7 @@ ;; ;; - responsible-p (file) ;; -;; Return non-nil if this backend considers itself "responsible" for +;; Return the directory if this backend considers itself "responsible" for ;; FILE, which can also be a directory. This function is used to find ;; out what backend to use for registration of new files and for things ;; like change log generation. The default implementation always diff --git a/lisp/wdired.el b/lisp/wdired.el index ab3b91bbe55..d2a6bad0f28 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -155,6 +155,11 @@ nonexistent directory will fail." :version "26.1" :type 'boolean) +(defcustom wdired-search-replace-filenames t + "Non-nil to search and replace in file names only." + :version "29.1" + :type 'boolean) + (defvar-keymap wdired-mode-map :doc "Keymap used in `wdired-mode'." "C-x C-s" #'wdired-finish-edit @@ -217,6 +222,7 @@ symbolic link targets, and filenames permission." (error "This mode can be enabled only by `wdired-change-to-wdired-mode'")) (put 'wdired-mode 'mode-class 'special) +(declare-function dired-isearch-search-filenames "dired-aux") ;;;###autoload (defun wdired-change-to-wdired-mode () @@ -237,9 +243,16 @@ See `wdired-mode'." (dired-remember-marks (point-min) (point-max))) (setq-local wdired--old-point (point)) (wdired--set-permission-bounds) - (setq-local query-replace-skip-read-only t) - (add-function :after-while (local 'isearch-filter-predicate) - #'wdired-isearch-filter-read-only) + (when wdired-search-replace-filenames + (add-function :around (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames + '((isearch-message-prefix . "filename "))) + (setq-local replace-search-function + (setq-local replace-re-search-function + (funcall isearch-search-fun-function))) + ;; Original dired hook removes dired-isearch-search-filenames that + ;; is needed outside isearch for lazy-highlighting in query-replace. + (remove-hook 'isearch-mode-hook #'dired-isearch-filenames-setup t)) (use-local-map wdired-mode-map) (force-mode-line-update) (setq buffer-read-only nil) @@ -319,11 +332,6 @@ or \\[wdired-abort-changes] to abort changes"))) ;; Is this good enough? Assumes no extra white lines from dired. (put-text-property (1- (point-max)) (point-max) 'read-only t))))))) -(defun wdired-isearch-filter-read-only (beg end) - "Skip matches that have a read-only property." - (not (text-property-not-all (min beg end) (max beg end) - 'read-only nil))) - ;; Protect the buffer so only the filenames can be changed, and put ;; properties so filenames (old and new) can be easily found. (defun wdired--preprocess-files () @@ -438,8 +446,13 @@ non-nil means return old filename." (remove-text-properties (point-min) (point-max) '(front-sticky nil rear-nonsticky nil read-only nil keymap nil))) - (remove-function (local 'isearch-filter-predicate) - #'wdired-isearch-filter-read-only) + (when wdired-search-replace-filenames + (remove-function (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames) + (kill-local-variable 'replace-search-function) + (kill-local-variable 'replace-re-search-function) + ;; Restore dired hook + (add-hook 'isearch-mode-hook #'dired-isearch-filenames-setup nil t)) (use-local-map dired-mode-map) (force-mode-line-update) (setq buffer-read-only t) diff --git a/lisp/window.el b/lisp/window.el index 54c9eee5f32..9f787846124 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -2496,7 +2496,7 @@ unless DEDICATED is non-nil, so if all windows are dedicated, the value is nil. Avoid returning the selected window if possible. Optional argument NOT-SELECTED non-nil means never return the selected window. Optional argument NO-OTHER non-nil means to -never return a window whose 'no-other-window' parameter is +never return a window whose `no-other-window' parameter is non-nil. The following non-nil values of the optional argument ALL-FRAMES @@ -2538,7 +2538,7 @@ never a candidate unless DEDICATED is non-nil, so if all windows are dedicated, the value is nil. Optional argument NOT-SELECTED non-nil means never return the selected window. Optional argument NO-OTHER non-nil means to never return a window whose -'no-other-window' parameter is non-nil. +`no-other-window' parameter is non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -2574,7 +2574,7 @@ never a candidate unless DEDICATED is non-nil, so if all windows are dedicated, the value is nil. Optional argument NOT-SELECTED non-nil means never return the selected window. Optional argument NO-OTHER non-nil means to never return a window whose -'no-other-window' parameter is non-nil. +`no-other-window' parameter is non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -5007,7 +5007,11 @@ minibuffer window or is dedicated to its buffer." BUFFER-OR-NAME may be a buffer or the name of an existing buffer and defaults to the current buffer. -Interactively, prompt for the buffer. +Interactively, this command will prompt for the buffer name. A +prefix argument of 0 (zero) means that only windows in the +current terminal's frames will be deleted. Any other prefix +argument means that only windows in the current frame will be +deleted. The following non-nil values of the optional argument FRAME have special meanings: @@ -5044,7 +5048,21 @@ If the buffer specified by BUFFER-OR-NAME is shown in a minibuffer window, do nothing for that window. For any window that does not show that buffer, remove the buffer from that window's lists of previous and next buffers." - (interactive "bDelete windows on (buffer):\nP") + (interactive + (let ((frame (cond + ((and (numberp current-prefix-arg) + (zerop current-prefix-arg)) + 0) + (current-prefix-arg t)))) + (list (read-buffer "Delete windows on (buffer): " + nil nil + (lambda (buf) + (get-buffer-window + (if (consp buf) (car buf) buf) + (cond + ((null frame) t) + ((numberp frame) frame))))) + frame))) (let ((buffer (window-normalize-buffer buffer-or-name)) ;; Handle the "inverted" meaning of the FRAME argument wrt other ;; `window-list-1' based function. @@ -5117,7 +5135,7 @@ parameter to nil. See Info node `(elisp) Quitting Windows' for more details. If WINDOW's dedicated flag is t, try to delete WINDOW. If it -equals the value 'side', restore that value when WINDOW is not +equals the value `side', restore that value when WINDOW is not deleted. Optional second argument BURY-OR-KILL tells how to proceed with @@ -5698,12 +5716,12 @@ right, if any." ;;; Balancing windows. ;; The following routine uses the recycled code from an old version of -;; `window--resize-child-windows'. It's not very pretty, but coding it the way the -;; new `window--resize-child-windows' code does would hardly make it any shorter or -;; more readable (FWIW we'd need three loops - one to calculate the -;; minimum sizes per window, one to enlarge or shrink windows until the -;; new parent-size matches, and one where we shrink the largest/enlarge -;; the smallest window). +;; `window--resize-child-windows'. It's not very pretty, but coding it +;; the way the new `window--resize-child-windows' code does would hardly +;; make it any shorter or more readable (FWIW we'd need three loops - +;; one to calculate the minimum sizes per window, one to enlarge or +;; shrink windows until the new parent-size matches, and one where we +;; shrink the largest/enlarge the smallest window). (defun balance-windows-2 (window horizontal) "Subroutine of `balance-windows-1'. WINDOW must be a vertical combination (horizontal if HORIZONTAL @@ -5714,9 +5732,10 @@ is non-nil)." (first (window-child window)) (sub first) (number-of-children 0) + (rest 0) (parent-size (window-new-pixel window)) (total-sum parent-size) - failed size sub-total sub-delta sub-amount rest) + failed size sub-total sub-delta sub-amount) (while sub (if (window-size-fixed-p sub horizontal) (progn @@ -7439,9 +7458,9 @@ Its value takes effect before processing the ACTION argument of If non-nil, this is an alist of elements (CONDITION . ACTION), where: - CONDITION is either a regexp matching buffer names, or a - function that takes two arguments - a buffer name and the - ACTION argument of `display-buffer' - and returns a boolean. + CONDITION is passed to `buffer-match-p', along with the buffer + that is to be displayed and the ACTION argument of + `display-buffer', to check if ACTION should be used. ACTION is a cons cell (FUNCTIONS . ALIST), where FUNCTIONS is an action function or a list of action functions and ALIST is an @@ -7494,22 +7513,16 @@ all fail. It should never be set by programs or users. See `display-buffer'.") (put 'display-buffer-fallback-action 'risky-local-variable t) -(defun display-buffer-assq-regexp (buffer-name alist action) - "Retrieve ALIST entry corresponding to BUFFER-NAME. -This returns the cdr of the alist entry ALIST if either its key -is a string that matches BUFFER-NAME, as reported by -`string-match-p'; or if the key is a function that returns -non-nil when called with three arguments: the ALIST key, -BUFFER-NAME and ACTION. ACTION should have the form of the -action argument passed to `display-buffer'." +(defun display-buffer-assq-regexp (buffer-or-name alist action) + "Retrieve ALIST entry corresponding to buffer specified by BUFFER-OR-NAME. +This returns the cdr of the alist entry ALIST if the entry's +key (its car) and BUFFER-OR-NAME satisfy `buffer-match-p', using +the key as CONDITION argument of `buffer-match-p'. ACTION should +have the form of the action argument passed to `display-buffer'." (catch 'match (dolist (entry alist) - (let ((key (car entry))) - (when (or (and (stringp key) - (string-match-p key buffer-name)) - (and (functionp key) - (funcall key buffer-name action))) - (throw 'match (cdr entry))))))) + (when (buffer-match-p (car entry) buffer-or-name action) + (throw 'match (cdr entry)))))) (defvar display-buffer--same-window-action '(display-buffer-same-window @@ -7554,7 +7567,7 @@ to an expression containing one of these \"action\" functions: For instance: - (setq display-buffer-alist '((\".*\" display-buffer-at-bottom))) + (setq display-buffer-alist \\='((\".*\" display-buffer-at-bottom))) Buffer display can be further customized to a very high degree; the rest of this docstring explains some of the many @@ -7609,7 +7622,7 @@ Action alist entries are: the window specified in frame lines), a floating point number (the fraction of its total height with respect to the total height of the frame's root window), a cons cell whose - car is 'body-lines' and whose cdr is an integer that + car is `body-lines' and whose cdr is an integer that specifies the height of the window's body in frame lines, or a function to be called with one argument - the chosen window. That function is supposed to adjust the height of @@ -7620,7 +7633,7 @@ Action alist entries are: the window specified in frame lines), a floating point number (the fraction of its total width with respect to the width of the frame's root window), a cons cell whose car is - 'body-columns' and whose cdr is an integer that specifies the + `body-columns' and whose cdr is an integer that specifies the width of the window's body in frame columns, or a function to be called with one argument - the chosen window. That function is supposed to adjust the width of the window. @@ -7628,7 +7641,7 @@ Action alist entries are: alone on their frame and specifies the desired size of that window either as a cons of integers (the total width and height of the window on that frame), a cons cell whose car is - 'body-chars' and whose cdr is a cons of integers (the desired + `body-chars' and whose cdr is a cons of integers (the desired width and height of the window's body in columns and lines of its frame), or a function to be called with one argument - the chosen window. That function is supposed to adjust the @@ -7678,7 +7691,7 @@ specified by the ACTION argument." ;; Otherwise, use the defined actions. (let* ((user-action (display-buffer-assq-regexp - (buffer-name buffer) display-buffer-alist action)) + buffer display-buffer-alist action)) (special-action (display-buffer--special-action buffer)) ;; Extra actions from the arguments to this function: (extra-action @@ -10080,6 +10093,24 @@ If ARG is the atom `-', scroll upward by nearly full screen." (put 'scroll-down-command 'scroll-command t) +(defun scroll-other-window (&optional lines) + "Scroll next window upward LINES lines; or near full screen if no ARG. +See `scroll-up-command' for details." + (interactive "P") + (with-selected-window (other-window-for-scrolling) + (funcall (or (command-remapping #'scroll-up-command) + #'scroll-up-command) + lines))) + +(defun scroll-other-window-down (&optional lines) + "Scroll next window downward LINES lines; or near full screen if no ARG. +See `scroll-down-command' for details." + (interactive "P") + (with-selected-window (other-window-for-scrolling) + (funcall (or (command-remapping #'scroll-down-command) + #'scroll-down-command) + lines))) + ;;; Scrolling commands which scroll a line instead of full screen. (defun scroll-up-line (&optional arg) @@ -10467,6 +10498,55 @@ displaying that processes's buffer." (put 'shrink-window-horizontally 'repeat-map 'resize-window-repeat-map) (put 'shrink-window 'repeat-map 'resize-window-repeat-map) +(defun window-char-pixel-width (&optional window face) + "Return average character width for the font of FACE used in WINDOW. +WINDOW must be a live window and defaults to the selected one. + +If FACE is nil or omitted, the default face is used. If FACE is +remapped (see `face-remapping-alist'), the function returns the +information for the remapped face." + (with-selected-window (window-normalize-window window t) + (let* ((info (font-info (face-font (or face 'default)))) + (width (aref info 11))) + (if (> width 0) + width + (aref info 10))))) + +(defun window-char-pixel-height (&optional window face) + "Return character height for the font of FACE used in WINDOW. +WINDOW must be a live window and defaults to the selected one. + +If FACE is nil or omitted, the default face is used. If FACE is +remapped (see `face-remapping-alist'), the function returns the +information for the remapped face." + (with-selected-window (window-normalize-window window t) + (aref (font-info (face-font (or face 'default))) 3))) + +(defun window-max-characters-per-line (&optional window face) + "Return the number of characters that can be displayed on one line in WINDOW. +WINDOW must be a live window and defaults to the selected one. + +The character width of FACE is used for the calculation. If FACE +is nil or omitted, the default face is used. If FACE is +remapped (see `face-remapping-alist'), the function uses the +remapped face. + +This function is different from `window-body-width' in two +ways. First, it accounts for the portions of the line reserved +for the continuation glyph. Second, it accounts for the size of +the font, which may have been adjusted, e.g., using +`text-scale-increase')." + (with-selected-window (window-normalize-window window t) + (let* ((window-width (window-body-width window t)) + (font-width (window-char-pixel-width window face)) + (ncols (/ window-width font-width))) + (if (and (display-graphic-p) + overflow-newline-into-fringe + (/= (frame-parameter nil 'left-fringe) 0) + (/= (frame-parameter nil 'right-fringe) 0)) + ncols + (1- ncols))))) + (provide 'window) ;;; window.el ends here diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index 559679131bd..47d8ae14cfc 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -115,6 +115,17 @@ the type we want for the drop, the action we want for the drop, any protocol specific data.") +(declare-function x-get-selection-internal "xselect.c" + (selection-symbol target-type &optional time-stamp terminal)) + +(defconst x-dnd-xdnd-to-action + '(("XdndActionPrivate" . private) + ("XdndActionCopy" . copy) + ("XdndActionMove" . move) + ("XdndActionLink" . link) + ("XdndActionAsk" . ask)) + "Mapping from XDND action types to Lisp symbols.") + (defvar x-dnd-empty-state [nil nil nil nil nil nil nil]) (declare-function x-register-dnd-atom "xselect.c") @@ -336,21 +347,41 @@ nil if not." Currently XDND, Motif and old KDE 1.x protocols are recognized." (interactive "e") (let* ((client-message (car (cdr (cdr event)))) - (window (posn-window (event-start event))) - (message-atom (aref client-message 0)) - (frame (aref client-message 1)) - (format (aref client-message 2)) - (data (aref client-message 3))) + (window (posn-window (event-start event)))) + (if (eq (and (consp client-message) + (car client-message)) + 'XdndSelection) + ;; This is an internal Emacs message caused by something being + ;; dropped on top of a frame. + (progn + (let ((action (cdr (assoc (symbol-name (cadr client-message)) + x-dnd-xdnd-to-action))) + (targets (cddr client-message))) + (x-dnd-save-state window nil nil + (apply #'vector targets)) + (x-dnd-maybe-call-test-function window action) + (unwind-protect + (x-dnd-drop-data event (if (framep window) window + (window-frame window)) + window + (x-get-selection-internal + 'XdndSelection + (intern (x-dnd-current-type window))) + (x-dnd-current-type window)) + (x-dnd-forget-drop window)))) + (let ((message-atom (aref client-message 0)) + (frame (aref client-message 1)) + (format (aref client-message 2)) + (data (aref client-message 3))) + (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x. + (x-dnd-handle-old-kde event frame window message-atom format data)) - (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x. - (x-dnd-handle-old-kde event frame window message-atom format data)) + ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif + (x-dnd-handle-motif event frame window message-atom format data)) - ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif - (x-dnd-handle-motif event frame window message-atom format data)) - - ((and (> (length message-atom) 4) ; XDND protocol. - (equal "Xdnd" (substring message-atom 0 4))) - (x-dnd-handle-xdnd event frame window message-atom format data))))) + ((and (> (length message-atom) 4) ; XDND protocol. + (equal "Xdnd" (substring message-atom 0 4))) + (x-dnd-handle-xdnd event frame window message-atom format data))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -371,14 +402,6 @@ Currently XDND, Motif and old KDE 1.x protocols are recognized." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; XDND protocol. -(defconst x-dnd-xdnd-to-action - '(("XdndActionPrivate" . private) - ("XdndActionCopy" . copy) - ("XdndActionMove" . move) - ("XdndActionLink" . link) - ("XdndActionAsk" . ask)) - "Mapping from XDND action types to Lisp symbols.") - (declare-function x-change-window-property "xfns.c" (prop value &optional frame type format outer-P)) @@ -425,8 +448,6 @@ otherwise return the frame coordinates." (declare-function x-get-atom-name "xselect.c" (value &optional frame)) (declare-function x-send-client-message "xselect.c" (display dest from message-type format values)) -(declare-function x-get-selection-internal "xselect.c" - (selection-symbol target-type &optional time-stamp terminal)) (defun x-dnd-version-from-flags (flags) "Return the version byte from the 32 bit FLAGS in an XDndEnter message." @@ -446,7 +467,6 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (version (x-dnd-version-from-flags flags)) (more-than-3 (x-dnd-more-than-3-from-flags flags)) (dnd-source (aref data 0))) - (message "%s %s" version more-than-3) (if version ;; If flags is bad, version will be nil. (x-dnd-save-state window nil nil @@ -479,7 +499,7 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." ))) (x-send-client-message frame dnd-source frame "XdndStatus" 32 list-to-send) - )) + (dnd-handle-movement (event-start event)))) ((equal "XdndLeave" message) (x-dnd-forget-drop window)) @@ -583,178 +603,195 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (2 . private)) ; Motif does not have private, so use copy for private. "Mapping from number to operation for Motif DND.") -(defun x-dnd-handle-motif (event frame window message-atom _format data) - (let* ((message-type (cdr (assoc (aref data 0) x-dnd-motif-message-types))) +(defun x-dnd-handle-motif (event frame window _message-atom _format data) + (let* ((message-type (cdr (assoc (logand (aref data 0) #x3f) + x-dnd-motif-message-types))) + (initiator-p (eq (lsh (aref data 0) -7) 0)) (source-byteorder (aref data 1)) (my-byteorder (byteorder)) (source-flags (x-dnd-get-motif-value data 2 2 source-byteorder)) (source-action (cdr (assoc (logand ?\xF source-flags) x-dnd-motif-to-action)))) - (cond ((eq message-type 'XmTOP_LEVEL_ENTER) - (let* ((dnd-source (x-dnd-get-motif-value - data 8 4 source-byteorder)) - (selection-atom (x-dnd-get-motif-value - data 12 4 source-byteorder)) - (atom-name (x-get-atom-name selection-atom)) - (types (when atom-name - (x-get-selection-internal (intern atom-name) - 'TARGETS)))) - (x-dnd-forget-drop frame) - (when types (x-dnd-save-state window nil nil - types - dnd-source)))) + (when initiator-p + (cond ((eq message-type 'XmTOP_LEVEL_ENTER) + (let* ((dnd-source (x-dnd-get-motif-value + data 8 4 source-byteorder)) + (selection-atom (x-dnd-get-motif-value + data 12 4 source-byteorder)) + (atom-name (x-get-atom-name selection-atom)) + (types (when atom-name + (x-get-selection-internal (intern atom-name) + 'TARGETS)))) + (x-dnd-forget-drop frame) + (when types (x-dnd-save-state window nil nil + types + dnd-source)))) - ;; Can not forget drop here, LEAVE comes before DROP_START and - ;; we need the state in DROP_START. - ((eq message-type 'XmTOP_LEVEL_LEAVE) - nil) + ;; Can not forget drop here, LEAVE comes before DROP_START and + ;; we need the state in DROP_START. + ((eq message-type 'XmTOP_LEVEL_LEAVE) + nil) - ((eq message-type 'XmDRAG_MOTION) - (let* ((state (x-dnd-get-state-for-frame frame)) - (timestamp (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 4 4 - source-byteorder) - 4 my-byteorder)) - (x (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 8 2 source-byteorder) + ((eq message-type 'XmDRAG_MOTION) + (let* ((state (x-dnd-get-state-for-frame frame)) + (timestamp (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 4 4 + source-byteorder) + 4 my-byteorder)) + (x (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 8 2 source-byteorder) + 2 my-byteorder)) + (y (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 10 2 source-byteorder) + 2 my-byteorder)) + (dnd-source (aref state 6)) + (first-move (not (aref state 3))) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + ?\x30) ; 30: drop site, but noop. 2 my-byteorder)) - (y (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 10 2 source-byteorder) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + (if first-move + 3 ; First time, reply is SITE_ENTER. + 2)) ; Not first time, reply is DRAG_MOTION. + my-byteorder) + reply-flags + timestamp + x + y))) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply) + (dnd-handle-movement (event-start event)))) + + ((eq message-type 'XmOPERATION_CHANGED) + (let* ((state (x-dnd-get-state-for-frame frame)) + (timestamp (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 4 4 source-byteorder) + 4 my-byteorder)) + (dnd-source (aref state 6)) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + ?\x30) ; 30: drop site, but noop 2 my-byteorder)) - (dnd-source (aref state 6)) - (first-move (not (aref state 3))) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - ?\x30) ; 30: drop site, but noop. - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - (if first-move - 3 ; First time, reply is SITE_ENTER. - 2)) ; Not first time, reply is DRAG_MOTION. - my-byteorder) - reply-flags - timestamp - x - y))) - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply))) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + 8) ; 8 is OPERATION_CHANGED + my-byteorder) + reply-flags + timestamp))) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply))) - ((eq message-type 'XmOPERATION_CHANGED) - (let* ((state (x-dnd-get-state-for-frame frame)) - (timestamp (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 4 4 source-byteorder) - 4 my-byteorder)) - (dnd-source (aref state 6)) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - ?\x30) ; 30: drop site, but noop - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - 8) ; 8 is OPERATION_CHANGED - my-byteorder) - reply-flags - timestamp))) - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply))) - - ((eq message-type 'XmDROP_START) - (let* ((x (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 8 2 source-byteorder) + ((eq message-type 'XmDROP_START) + (let* ((x (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 8 2 source-byteorder) + 2 my-byteorder)) + (y (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 10 2 source-byteorder) + 2 my-byteorder)) + (selection-atom (x-dnd-get-motif-value + data 12 4 source-byteorder)) + (atom-name (x-get-atom-name selection-atom)) + (dnd-source (x-dnd-get-motif-value + data 16 4 source-byteorder)) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + (+ ?\x30 ; 30: drop site, but noop. + ?\x200)) ; 200: drop cancel. 2 my-byteorder)) - (y (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 10 2 source-byteorder) - 2 my-byteorder)) - (selection-atom (x-dnd-get-motif-value - data 12 4 source-byteorder)) - (atom-name (x-get-atom-name selection-atom)) - (dnd-source (x-dnd-get-motif-value - data 16 4 source-byteorder)) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - (+ ?\x30 ; 30: drop site, but noop. - ?\x200)) ; 200: drop cancel. - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - 5) ; DROP_START. - my-byteorder) - reply-flags - x - y)) - (timestamp (x-dnd-get-motif-value - data 4 4 source-byteorder)) - action) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + 5) ; DROP_START. + my-byteorder) + reply-flags + x + y)) + (timestamp (x-dnd-get-motif-value + data 4 4 source-byteorder)) + action) - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply) - (setq action - (when (and reply-action atom-name) - (let* ((value (x-get-selection-internal - (intern atom-name) - (intern (x-dnd-current-type window))))) - (when value - (condition-case info - (x-dnd-drop-data event frame window value - (x-dnd-current-type window)) - (error - (message "Error: %s" info) - nil)))))) - (x-get-selection-internal - (intern atom-name) - (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE) - timestamp) - (x-dnd-forget-drop frame))) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply) + (setq action + (when (and reply-action atom-name) + (let* ((value (x-get-selection-internal + (intern atom-name) + (intern (x-dnd-current-type window))))) + (when value + (condition-case info + (x-dnd-drop-data event frame window value + (x-dnd-current-type window)) + (error + (message "Error: %s" info) + nil)))))) + (x-get-selection-internal + (intern atom-name) + (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE) + timestamp) + (x-dnd-forget-drop frame))) - (t (error "Unknown Motif DND message %s %s" message-atom data))))) + (t (message "Unknown Motif drag-and-drop message: %s" (logand (aref data 0) #x3f))))))) ;;; + + +;;; Handling drops. + +(defun x-dnd-handle-unsupported-drop (targets _x _y action _window-id _frame) + "Return non-nil if the drop described by TARGETS and ACTION should not proceeed." + (not (and (or (eq action 'XdndActionCopy) + (eq action 'XdndActionMove)) + (or (member "STRING" targets) + (member "UTF8_STRING" targets) + (member "COMPOUND_TEXT" targets) + (member "TEXT" targets))))) + (provide 'x-dnd) ;;; x-dnd.el ends here diff --git a/lwlib/lwlib.c b/lwlib/lwlib.c index 30546b60e51..863f65c915f 100644 --- a/lwlib/lwlib.c +++ b/lwlib/lwlib.c @@ -1324,10 +1324,14 @@ lw_separator_p (const char *label, enum menu_separator *type, int motif_p) { /* Old-style separator, maybe. It's a separator if it contains only dashes. */ - while (*label == '-') - ++label; - separator_p = *label == 0; - *type = SEPARATOR_SHADOW_ETCHED_IN; + if (*label == '-') + { + while (*label == '-') + ++label; + separator_p = *label == 0; + + *type = SEPARATOR_SHADOW_ETCHED_IN; + } } return separator_p; diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index c5ced04f181..30911d1581a 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -1,4 +1,4 @@ -# gnulib-common.m4 serial 72 +# gnulib-common.m4 serial 73 dnl Copyright (C) 2007-2022 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -106,6 +106,10 @@ AC_DEFUN([gl_COMMON_BODY], [ #endif #ifdef __has_c_attribute +# if ((defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) <= 201710 \ + && _GL_GNUC_PREREQ (4, 6)) +# pragma GCC diagnostic ignored "-Wpedantic" +# endif # define _GL_HAS_C_ATTRIBUTE(attr) __has_c_attribute (__##attr##__) #else # define _GL_HAS_C_ATTRIBUTE(attr) 0 diff --git a/msdos/sed1v2.inp b/msdos/sed1v2.inp index cc29ad02819..b7818f8b21e 100644 --- a/msdos/sed1v2.inp +++ b/msdos/sed1v2.inp @@ -117,6 +117,10 @@ s/ *@WEBP_LIBS@// /^XFIXES_CFLAGS *=/s/@XFIXES_CFLAGS@// /^XDBE_LIBS *=/s/@XDBE_LIBS@// /^XDBE_CFLAGS *=/s/@XDBE_CFLAGS@// +/^XCOMPOSITE_LIBS *=/s/@XCOMPOSITE_LIBS@// +/^XCOMPOSITE_CFLAGS *=/s/@XCOMPOSITE_CFLAGS@// +/^XSHAPE_LIBS *=/s/@XSHAPE_LIBS@// +/^XSHAPE_CFLAGS *=/s/@XSHAPE_CFLAGS@// /^XINPUT_LIBS *=/s/@XINPUT_LIBS@// /^XINPUT_CFLAGS *=/s/@XINPUT_CFLAGS@// /^XSYNC_LIBS *=/s/@XSYNC_LIBS@// @@ -194,6 +198,8 @@ s/ *@WEBP_LIBS@// /^PAXCTL_dumped *=/s/=.*$/=/ /^PAXCTL_notdumped *=/s/=.*$/=/ /^DUMPING *=/s/@DUMPING@/unexec/ +/^[ \t]*MAKE_PDUMPER_FINGERPRINT = *$/c\ +MAKE_PDUMPER_FINGERPRINT = /^lisp\.mk:/,/^$/c\ lisp.mk: $(lispsource)/loadup.el\ @rm -f $@\ @@ -205,6 +211,10 @@ lisp.mk: $(lispsource)/loadup.el\ /^ [ ]*\$(AM_V_at)\$(libsrc)\/make-docfile -d/s!make-docfile!make-docfile -o $(etc)/DOC! / > \$(etc)\/DOC *$/s/ >.*$// +/^\$(etc)\/DOC/,/^$/{ + /^$/i\ + cd ../src +} /^ [ ]*\$(AM_V_GLOBALS)\$(libsrc)\/make-docfile.*>.*globals.tmp/s!make-docfile!make-docfile -o globals.tmp! /^ [ ]*\$(AM_V_GLOBALS)\$(libsrc)\/make-doc/s!>.*$!! /^\$(libsrc)\/make-docfile\$(EXEEXT): /i\ diff --git a/msdos/sedlibmk.inp b/msdos/sedlibmk.inp index 45e03621ce3..302fefe19f0 100644 --- a/msdos/sedlibmk.inp +++ b/msdos/sedlibmk.inp @@ -180,11 +180,14 @@ s/@PACKAGE@/emacs/ /^GL_GNULIB_ENVIRON *=/s/@GL_GNULIB_ENVIRON@/1/ /^GL_GNULIB_FDATASYNC *=/s/@GL_GNULIB_FDATASYNC@/1/ /^GL_GNULIB_GETLOADAVG *=/s/@GL_GNULIB_GETLOADAVG@/1/ +/^GL_GNULIB_GETRANDOM *=/s/@GL_GNULIB_GETRANDOM@/1/ /^GL_GNULIB_UNISTD_H_GETOPT *=/s/@GL_GNULIB_UNISTD_H_GETOPT@/1/ +/^GL_GNULIB_MEMMEM *=/s/@GL_GNULIB_MEMMEM@/1/ /^GL_GNULIB_MEMRCHR *=/s/@GL_GNULIB_MEMRCHR@/1/ /^GL_GNULIB_MEMPCPY *=/s/@GL_GNULIB_MEMPCPY@/1/ /^GL_GNULIB_MKOSTEMP *=/s/@GL_GNULIB_MKOSTEMP@/1/ /^GL_GNULIB_MKTIME *=/s/@GL_GNULIB_MKTIME@/1/ +/^GL_GNULIB_SIGDESCR_NP *=/s/@GL_GNULIB_SIGDESCR_NP@/1/ /^GL_GNULIB_TIME_R *=/s/@GL_GNULIB_TIME_R@/1/ /^GL_GNULIB_TIMEGM *=/s/@GL_GNULIB_TIMEGM@/1/ /^GL_GNULIB_TIME_RZ *=/s/@GL_GNULIB_TIME_RZ@/1/ diff --git a/nt/inc/ms-w32.h b/nt/inc/ms-w32.h index 3f4b2f34892..2dd9a9a476c 100644 --- a/nt/inc/ms-w32.h +++ b/nt/inc/ms-w32.h @@ -295,6 +295,7 @@ extern int sys_unlink (const char *); #undef umask #define umask sys_umask extern int sys_umask (int); +#define clock sys_clock /* Subprocess calls that are emulated. */ #define spawnve sys_spawnve diff --git a/oldXMenu/XMenuInt.h b/oldXMenu/XMenuInt.h index 86b8e057cd5..5d5365ad8f2 100644 --- a/oldXMenu/XMenuInt.h +++ b/oldXMenu/XMenuInt.h @@ -37,6 +37,8 @@ without express or implied warranty. #include +#include + /* Avoid warnings about redefining NULL by including first; the other file which wants to define it ( on Ultrix systems) can deal if NULL is already defined, but can't. */ diff --git a/src/Makefile.in b/src/Makefile.in index 6ae55b19e16..a21af42c0b9 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -271,6 +271,12 @@ XSYNC_CFLAGS = @XSYNC_CFLAGS@ XDBE_LIBS = @XDBE_LIBS@ XDBE_CFLAGS = @XDBE_CFLAGS@ +XCOMPOSITE_LIBS = @XCOMPOSITE_LIBS@ +XCOMPOSITE_CFLAGS = @XCOMPOSITE_CFLAGS@ + +XSHAPE_LIBS = @XSHAPE_LIBS@ +XSHAPE_CFLAGS = @XSHAPE_CFLAGS@ + ## widget.o if USE_X_TOOLKIT, otherwise empty. WIDGET_OBJ=@WIDGET_OBJ@ @@ -406,7 +412,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ $(HARFBUZZ_CFLAGS) $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) $(XSYNC_CFLAGS) $(TREE_SITTER_CFLAGS) \ $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ - $(WERROR_CFLAGS) $(HAIKU_CFLAGS) + $(WERROR_CFLAGS) $(HAIKU_CFLAGS) $(XCOMPOSITE_CFLAGS) $(XSHAPE_CFLAGS) ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) ALL_OBJC_CFLAGS = $(EMACS_CFLAGS) \ $(filter-out $(NON_OBJC_CFLAGS),$(WARN_CFLAGS)) $(CFLAGS) \ @@ -432,7 +438,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ minibuf.o fileio.o dired.o \ cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \ alloc.o pdumper.o data.o doc.o editfns.o callint.o \ - eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \ + eval.o floatfns.o fns.o sort.o font.o print.o lread.o $(MODULES_OBJ) \ syntax.o $(UNEXEC_OBJ) bytecode.o comp.o $(DYNLIB_OBJ) \ process.o gnutls.o callproc.o \ region-cache.o sound.o timefns.o atimer.o \ @@ -563,7 +569,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(PGTK_LIBS) $(LIBX_BASE) $(LIBIMAGE $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT_LIBS) $(XINPUT_LIBS) $(HAIKU_LIBS) \ - $(TREE_SITTER_LIBS) $(SQLITE3_LIBS) + $(TREE_SITTER_LIBS) $(SQLITE3_LIBS) $(XCOMPOSITE_LIBS) $(XSHAPE_LIBS) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/alloc.c b/src/alloc.c index e7603fac37a..40a3e235eab 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -449,26 +449,11 @@ static void compact_small_strings (void); static void free_large_strings (void); extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE; -/* Forward declare mark accessor functions: they're used all over the - place. */ - -inline static bool vector_marked_p (const struct Lisp_Vector *v); -inline static void set_vector_marked (struct Lisp_Vector *v); - -inline static bool vectorlike_marked_p (const union vectorlike_header *v); -inline static void set_vectorlike_marked (union vectorlike_header *v); - -inline static bool cons_marked_p (const struct Lisp_Cons *c); -inline static void set_cons_marked (struct Lisp_Cons *c); - -inline static bool string_marked_p (const struct Lisp_String *s); -inline static void set_string_marked (struct Lisp_String *s); - -inline static bool symbol_marked_p (const struct Lisp_Symbol *s); -inline static void set_symbol_marked (struct Lisp_Symbol *s); - -inline static bool interval_marked_p (INTERVAL i); -inline static void set_interval_marked (INTERVAL i); +static bool vector_marked_p (struct Lisp_Vector const *); +static bool vectorlike_marked_p (union vectorlike_header const *); +static void set_vectorlike_marked (union vectorlike_header *); +static bool interval_marked_p (INTERVAL); +static void set_interval_marked (INTERVAL); /* When scanning the C stack for live Lisp objects, Emacs keeps track of what memory allocated via lisp_malloc and lisp_align_malloc is intended @@ -4941,7 +4926,7 @@ mark_maybe_pointer (void *p, bool symbol_only) /* Mark Lisp objects referenced from the address range START..END or END..START. */ -static void ATTRIBUTE_NO_SANITIZE_ADDRESS +void ATTRIBUTE_NO_SANITIZE_ADDRESS mark_memory (void const *start, void const *end) { char const *pp; @@ -5010,7 +4995,7 @@ marking. Emacs has determined that the method it uses to do the\n\ marking will likely work on your system, but this isn't sure.\n\ \n\ If you are a system-programmer, or can get the help of a local wizard\n\ -who is, please take a look at the function mark_stack in alloc.c, and\n\ +who is, please take a look at the function mark_c_stack in alloc.c, and\n\ verify that the methods used are appropriate for your system.\n\ \n\ Please mail the result to .\n\ @@ -5023,7 +5008,7 @@ marking. Emacs has determined that the default method it uses to do the\n\ marking will not work on your system. We will need a system-dependent\n\ solution for your system.\n\ \n\ -Please take a look at the function mark_stack in alloc.c, and\n\ +Please take a look at the function mark_c_stack in alloc.c, and\n\ try to find a way to make it work on your system.\n\ \n\ Note that you may get false negatives, depending on the compiler.\n\ @@ -5165,7 +5150,7 @@ typedef union from the stack start. */ void -mark_stack (char const *bottom, char const *end) +mark_c_stack (char const *bottom, char const *end) { /* This assumes that the stack is a contiguous region in memory. If that's not the case, something has to be done here to iterate @@ -6113,6 +6098,8 @@ maybe_garbage_collect (void) garbage_collect (); } +static inline bool mark_stack_empty_p (void); + /* Subroutine of Fgarbage_collect that does most of the work. */ void garbage_collect (void) @@ -6128,6 +6115,8 @@ garbage_collect (void) if (garbage_collection_inhibited) return; + eassert(mark_stack_empty_p ()); + /* Record this function, so it appears on the profiler's backtraces. */ record_in_backtrace (QAutomatic_GC, 0, 0); @@ -6220,6 +6209,10 @@ garbage_collect (void) mark_fringe_data (); #endif +#ifdef HAVE_X_WINDOWS + mark_xterm (); +#endif + /* Everything is now marked, except for the data in font caches, undo lists, and finalizers. The first two are compacted by removing an items which aren't reachable otherwise. */ @@ -6250,6 +6243,8 @@ garbage_collect (void) mark_and_sweep_weak_table_contents (); eassert (weak_hash_tables == NULL); + eassert (mark_stack_empty_p ()); + gc_sweep (); unmark_main_thread (); @@ -6423,15 +6418,25 @@ mark_glyph_matrix (struct glyph_matrix *matrix) } } +/* Whether to remember a few of the last marked values for debugging. */ +#define GC_REMEMBER_LAST_MARKED 0 + +#if GC_REMEMBER_LAST_MARKED enum { LAST_MARKED_SIZE = 1 << 9 }; /* Must be a power of 2. */ Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE; static int last_marked_index; +#endif +/* Whether to enable the mark_object_loop_halt debugging feature. */ +#define GC_CDR_COUNT 0 + +#if GC_CDR_COUNT /* For debugging--call abort when we cdr down this many links of a list, in mark_object. In debugging, the call to abort will hit a breakpoint. Normally this is zero and the check never goes off. */ ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE; +#endif static void mark_vectorlike (union vectorlike_header *header) @@ -6485,19 +6490,6 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype) } } -NO_INLINE /* To reduce stack depth in mark_object. */ -static Lisp_Object -mark_compiled (struct Lisp_Vector *ptr) -{ - int i, size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK; - - set_vector_marked (ptr); - for (i = 0; i < size; i++) - if (i != COMPILED_CONSTANTS) - mark_object (ptr->contents[i]); - return size > COMPILED_CONSTANTS ? ptr->contents[COMPILED_CONSTANTS] : Qnil; -} - /* Mark the chain of overlays starting at PTR. */ static void @@ -6650,110 +6642,160 @@ mark_window (struct Lisp_Vector *ptr) (w, mark_discard_killed_buffers (w->next_buffers)); } -static void -mark_hash_table (struct Lisp_Vector *ptr) +/* Entry of the mark stack. */ +struct mark_entry { - struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr; + ptrdiff_t n; /* number of values, or 0 if a single value */ + union { + Lisp_Object value; /* when n = 0 */ + Lisp_Object *values; /* when n > 0 */ + } u; +}; - mark_vectorlike (&h->header); - mark_object (h->test.name); - mark_object (h->test.user_hash_function); - mark_object (h->test.user_cmp_function); - /* If hash table is not weak, mark all keys and values. For weak - tables, mark only the vector and not its contents --- that's what - makes it weak. */ - if (NILP (h->weak)) - mark_object (h->key_and_value); - else +/* This stack is used during marking for traversing data structures without + using C recursion. */ +struct mark_stack +{ + struct mark_entry *stack; /* base of stack */ + ptrdiff_t size; /* allocated size in entries */ + ptrdiff_t sp; /* current number of entries */ +}; + +static struct mark_stack mark_stk = {NULL, 0, 0}; + +static inline bool +mark_stack_empty_p (void) +{ + return mark_stk.sp <= 0; +} + +/* Pop and return a value from the mark stack (which must be nonempty). */ +static inline Lisp_Object +mark_stack_pop (void) +{ + eassume (!mark_stack_empty_p ()); + struct mark_entry *e = &mark_stk.stack[mark_stk.sp - 1]; + if (e->n == 0) /* single value */ { - eassert (h->next_weak == NULL); - h->next_weak = weak_hash_tables; - weak_hash_tables = h; - set_vector_marked (XVECTOR (h->key_and_value)); + --mark_stk.sp; + return e->u.value; } + /* Array of values: pop them left to right, which seems to be slightly + faster than right to left. */ + e->n--; + if (e->n == 0) + --mark_stk.sp; /* last value consumed */ + return (++e->u.values)[-1]; } -void -mark_objects (Lisp_Object *obj, ptrdiff_t n) +NO_INLINE static void +grow_mark_stack (void) { - for (ptrdiff_t i = 0; i < n; i++) - mark_object (obj[i]); + struct mark_stack *ms = &mark_stk; + eassert (ms->sp == ms->size); + ptrdiff_t min_incr = ms->sp == 0 ? 8192 : 1; + ms->stack = xpalloc (ms->stack, &ms->size, min_incr, -1, sizeof *ms->stack); + eassert (ms->sp < ms->size); } -/* Determine type of generic Lisp_Object and mark it accordingly. - - This function implements a straightforward depth-first marking - algorithm and so the recursion depth may be very high (a few - tens of thousands is not uncommon). To minimize stack usage, - a few cold paths are moved out to NO_INLINE functions above. - In general, inlining them doesn't help you to gain more speed. */ - -void -mark_object (Lisp_Object arg) +/* Push VALUE onto the mark stack. */ +static inline void +mark_stack_push_value (Lisp_Object value) +{ + if (mark_stk.sp >= mark_stk.size) + grow_mark_stack (); + mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = 0, .u.value = value}; +} + +/* Push the N values at VALUES onto the mark stack. */ +static inline void +mark_stack_push_values (Lisp_Object *values, ptrdiff_t n) +{ + eassume (n >= 0); + if (n == 0) + return; + if (mark_stk.sp >= mark_stk.size) + grow_mark_stack (); + mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = n, + .u.values = values}; +} + +/* Traverse and mark objects on the mark stack above BASE_SP. + + Traversal is depth-first using the mark stack for most common + object types. Recursion is used for other types, in the hope that + they are rare enough that C stack usage is kept low. */ +static void +process_mark_stack (ptrdiff_t base_sp) { - register Lisp_Object obj; - void *po; #if GC_CHECK_MARKED_OBJECTS struct mem_node *m = NULL; #endif +#if GC_CDR_COUNT ptrdiff_t cdr_count = 0; +#endif - obj = arg; - loop: + eassume (mark_stk.sp >= base_sp && base_sp >= 0); - po = XPNTR (obj); - if (PURE_P (po)) - return; + while (mark_stk.sp > base_sp) + { + Lisp_Object obj = mark_stack_pop (); + mark_obj: ; + void *po = XPNTR (obj); + if (PURE_P (po)) + continue; - last_marked[last_marked_index++] = obj; - last_marked_index &= LAST_MARKED_SIZE - 1; +#if GC_REMEMBER_LAST_MARKED + last_marked[last_marked_index++] = obj; + last_marked_index &= LAST_MARKED_SIZE - 1; +#endif - /* Perform some sanity checks on the objects marked here. Abort if - we encounter an object we know is bogus. This increases GC time - by ~80%. */ + /* Perform some sanity checks on the objects marked here. Abort if + we encounter an object we know is bogus. This increases GC time + by ~80%. */ #if GC_CHECK_MARKED_OBJECTS - /* Check that the object pointed to by PO is known to be a Lisp - structure allocated from the heap. */ + /* Check that the object pointed to by PO is known to be a Lisp + structure allocated from the heap. */ #define CHECK_ALLOCATED() \ - do { \ - if (pdumper_object_p (po)) \ - { \ - if (!pdumper_object_p_precise (po)) \ - emacs_abort (); \ - break; \ - } \ - m = mem_find (po); \ - if (m == MEM_NIL) \ - emacs_abort (); \ - } while (0) + do { \ + if (pdumper_object_p (po)) \ + { \ + if (!pdumper_object_p_precise (po)) \ + emacs_abort (); \ + break; \ + } \ + m = mem_find (po); \ + if (m == MEM_NIL) \ + emacs_abort (); \ + } while (0) - /* Check that the object pointed to by PO is live, using predicate - function LIVEP. */ -#define CHECK_LIVE(LIVEP, MEM_TYPE) \ - do { \ - if (pdumper_object_p (po)) \ - break; \ - if (! (m->type == MEM_TYPE && LIVEP (m, po))) \ - emacs_abort (); \ - } while (0) + /* Check that the object pointed to by PO is live, using predicate + function LIVEP. */ +#define CHECK_LIVE(LIVEP, MEM_TYPE) \ + do { \ + if (pdumper_object_p (po)) \ + break; \ + if (! (m->type == MEM_TYPE && LIVEP (m, po))) \ + emacs_abort (); \ + } while (0) - /* Check both of the above conditions, for non-symbols. */ -#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \ - do { \ - CHECK_ALLOCATED (); \ - CHECK_LIVE (LIVEP, MEM_TYPE); \ - } while (false) + /* Check both of the above conditions, for non-symbols. */ +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \ + do { \ + CHECK_ALLOCATED (); \ + CHECK_LIVE (LIVEP, MEM_TYPE); \ + } while (false) - /* Check both of the above conditions, for symbols. */ -#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \ - do { \ - if (!c_symbol_p (ptr)) \ - { \ - CHECK_ALLOCATED (); \ - CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \ - } \ - } while (false) + /* Check both of the above conditions, for symbols. */ +#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \ + do { \ + if (!c_symbol_p (ptr)) \ + { \ + CHECK_ALLOCATED (); \ + CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \ + } \ + } while (false) #else /* not GC_CHECK_MARKED_OBJECTS */ @@ -6762,199 +6804,220 @@ mark_object (Lisp_Object arg) #endif /* not GC_CHECK_MARKED_OBJECTS */ - switch (XTYPE (obj)) - { - case Lisp_String: - { - register struct Lisp_String *ptr = XSTRING (obj); - if (string_marked_p (ptr)) - break; - CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING); - set_string_marked (ptr); - mark_interval_tree (ptr->u.s.intervals); + switch (XTYPE (obj)) + { + case Lisp_String: + { + register struct Lisp_String *ptr = XSTRING (obj); + if (string_marked_p (ptr)) + break; + CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING); + set_string_marked (ptr); + mark_interval_tree (ptr->u.s.intervals); #ifdef GC_CHECK_STRING_BYTES - /* Check that the string size recorded in the string is the - same as the one recorded in the sdata structure. */ - string_bytes (ptr); + /* Check that the string size recorded in the string is the + same as the one recorded in the sdata structure. */ + string_bytes (ptr); #endif /* GC_CHECK_STRING_BYTES */ - } - break; - - case Lisp_Vectorlike: - { - register struct Lisp_Vector *ptr = XVECTOR (obj); - - if (vector_marked_p (ptr)) + } break; - enum pvec_type pvectype - = PSEUDOVECTOR_TYPE (ptr); + case Lisp_Vectorlike: + { + register struct Lisp_Vector *ptr = XVECTOR (obj); + + if (vector_marked_p (ptr)) + break; + + enum pvec_type pvectype + = PSEUDOVECTOR_TYPE (ptr); #ifdef GC_CHECK_MARKED_OBJECTS - if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po)) - { - m = mem_find (po); - if (m == MEM_NIL) - emacs_abort (); - if (m->type == MEM_TYPE_VECTORLIKE) - CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE); - else - CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK); - } -#endif - - switch (pvectype) - { - case PVEC_BUFFER: - mark_buffer ((struct buffer *) ptr); - break; - - case PVEC_COMPILED: - /* Although we could treat this just like a vector, mark_compiled - returns the COMPILED_CONSTANTS element, which is marked at the - next iteration of goto-loop here. This is done to avoid a few - recursive calls to mark_object. */ - obj = mark_compiled (ptr); - if (!NILP (obj)) - goto loop; - break; - - case PVEC_FRAME: - mark_frame (ptr); - break; - - case PVEC_WINDOW: - mark_window (ptr); - break; - - case PVEC_HASH_TABLE: - mark_hash_table (ptr); - break; - - case PVEC_CHAR_TABLE: - case PVEC_SUB_CHAR_TABLE: - mark_char_table (ptr, (enum pvec_type) pvectype); - break; - - case PVEC_BOOL_VECTOR: - /* bool vectors in a dump are permanently "marked", since - they're in the old section and don't have mark bits. - If we're looking at a dumped bool vector, we should - have aborted above when we called vector_marked_p, so - we should never get here. */ - eassert (!pdumper_object_p (ptr)); - set_vector_marked (ptr); - break; - - case PVEC_OVERLAY: - mark_overlay (XOVERLAY (obj)); - break; - - case PVEC_SUBR: -#ifdef HAVE_NATIVE_COMP - if (SUBR_NATIVE_COMPILEDP (obj)) + if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po)) { - set_vector_marked (ptr); - struct Lisp_Subr *subr = XSUBR (obj); - mark_object (subr->native_intspec); - mark_object (subr->native_comp_u); - mark_object (subr->lambda_list); - mark_object (subr->type); + m = mem_find (po); + if (m == MEM_NIL) + emacs_abort (); + if (m->type == MEM_TYPE_VECTORLIKE) + CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE); + else + CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK); } #endif - break; - case PVEC_FREE: - emacs_abort (); + switch (pvectype) + { + case PVEC_BUFFER: + mark_buffer ((struct buffer *) ptr); + break; - default: - /* A regular vector, or a pseudovector needing no special - treatment. */ - mark_vectorlike (&ptr->header); + case PVEC_FRAME: + mark_frame (ptr); + break; + + case PVEC_WINDOW: + mark_window (ptr); + break; + + case PVEC_HASH_TABLE: + { + struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *)ptr; + ptrdiff_t size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK; + set_vector_marked (ptr); + mark_stack_push_values (ptr->contents, size); + mark_stack_push_value (h->test.name); + mark_stack_push_value (h->test.user_hash_function); + mark_stack_push_value (h->test.user_cmp_function); + if (NILP (h->weak)) + mark_stack_push_value (h->key_and_value); + else + { + /* For weak tables, mark only the vector and not its + contents --- that's what makes it weak. */ + eassert (h->next_weak == NULL); + h->next_weak = weak_hash_tables; + weak_hash_tables = h; + set_vector_marked (XVECTOR (h->key_and_value)); + } + break; + } + + case PVEC_CHAR_TABLE: + case PVEC_SUB_CHAR_TABLE: + mark_char_table (ptr, (enum pvec_type) pvectype); + break; + + case PVEC_BOOL_VECTOR: + /* bool vectors in a dump are permanently "marked", since + they're in the old section and don't have mark bits. + If we're looking at a dumped bool vector, we should + have aborted above when we called vector_marked_p, so + we should never get here. */ + eassert (!pdumper_object_p (ptr)); + set_vector_marked (ptr); + break; + + case PVEC_OVERLAY: + mark_overlay (XOVERLAY (obj)); + break; + + case PVEC_SUBR: +#ifdef HAVE_NATIVE_COMP + if (SUBR_NATIVE_COMPILEDP (obj)) + { + set_vector_marked (ptr); + struct Lisp_Subr *subr = XSUBR (obj); + mark_stack_push_value (subr->intspec.native); + mark_stack_push_value (subr->command_modes); + mark_stack_push_value (subr->native_comp_u); + mark_stack_push_value (subr->lambda_list); + mark_stack_push_value (subr->type); + } +#endif + break; + + case PVEC_FREE: + emacs_abort (); + + default: + { + /* A regular vector or pseudovector needing no special + treatment. */ + ptrdiff_t size = ptr->header.size; + if (size & PSEUDOVECTOR_FLAG) + size &= PSEUDOVECTOR_SIZE_MASK; + set_vector_marked (ptr); + mark_stack_push_values (ptr->contents, size); + } + break; + } } - } - break; - - case Lisp_Symbol: - { - struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj); - nextsym: - if (symbol_marked_p (ptr)) - break; - CHECK_ALLOCATED_AND_LIVE_SYMBOL (); - set_symbol_marked (ptr); - /* Attempt to catch bogus objects. */ - eassert (valid_lisp_object_p (ptr->u.s.function)); - mark_object (ptr->u.s.function); - mark_object (ptr->u.s.plist); - switch (ptr->u.s.redirect) - { - case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break; - case SYMBOL_VARALIAS: - { - Lisp_Object tem; - XSETSYMBOL (tem, SYMBOL_ALIAS (ptr)); - mark_object (tem); - break; - } - case SYMBOL_LOCALIZED: - mark_localized_symbol (ptr); - break; - case SYMBOL_FORWARDED: - /* If the value is forwarded to a buffer or keyboard field, - these are marked when we see the corresponding object. - And if it's forwarded to a C variable, either it's not - a Lisp_Object var, or it's staticpro'd already. */ - break; - default: emacs_abort (); - } - if (!PURE_P (XSTRING (ptr->u.s.name))) - set_string_marked (XSTRING (ptr->u.s.name)); - mark_interval_tree (string_intervals (ptr->u.s.name)); - /* Inner loop to mark next symbol in this bucket, if any. */ - po = ptr = ptr->u.s.next; - if (ptr) - goto nextsym; - } - break; - - case Lisp_Cons: - { - struct Lisp_Cons *ptr = XCONS (obj); - if (cons_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS); - set_cons_marked (ptr); - /* If the cdr is nil, avoid recursion for the car. */ - if (NILP (ptr->u.s.u.cdr)) + + case Lisp_Symbol: { - obj = ptr->u.s.car; - cdr_count = 0; - goto loop; + struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj); + nextsym: + if (symbol_marked_p (ptr)) + break; + CHECK_ALLOCATED_AND_LIVE_SYMBOL (); + set_symbol_marked (ptr); + /* Attempt to catch bogus objects. */ + eassert (valid_lisp_object_p (ptr->u.s.function)); + mark_stack_push_value (ptr->u.s.function); + mark_stack_push_value (ptr->u.s.plist); + switch (ptr->u.s.redirect) + { + case SYMBOL_PLAINVAL: + mark_stack_push_value (SYMBOL_VAL (ptr)); + break; + case SYMBOL_VARALIAS: + { + Lisp_Object tem; + XSETSYMBOL (tem, SYMBOL_ALIAS (ptr)); + mark_stack_push_value (tem); + break; + } + case SYMBOL_LOCALIZED: + mark_localized_symbol (ptr); + break; + case SYMBOL_FORWARDED: + /* If the value is forwarded to a buffer or keyboard field, + these are marked when we see the corresponding object. + And if it's forwarded to a C variable, either it's not + a Lisp_Object var, or it's staticpro'd already. */ + break; + default: emacs_abort (); + } + if (!PURE_P (XSTRING (ptr->u.s.name))) + set_string_marked (XSTRING (ptr->u.s.name)); + mark_interval_tree (string_intervals (ptr->u.s.name)); + /* Inner loop to mark next symbol in this bucket, if any. */ + po = ptr = ptr->u.s.next; + if (ptr) + goto nextsym; } - mark_object (ptr->u.s.car); - obj = ptr->u.s.u.cdr; - cdr_count++; - if (cdr_count == mark_object_loop_halt) + break; + + case Lisp_Cons: + { + struct Lisp_Cons *ptr = XCONS (obj); + if (cons_marked_p (ptr)) + break; + CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS); + set_cons_marked (ptr); + /* Avoid growing the stack if the cdr is nil. + In any case, make sure the car is expanded first. */ + if (!NILP (ptr->u.s.u.cdr)) + { + mark_stack_push_value (ptr->u.s.u.cdr); +#if GC_CDR_COUNT + cdr_count++; + if (cdr_count == mark_object_loop_halt) + emacs_abort (); +#endif + } + /* Speedup hack for the common case (successive list elements). */ + obj = ptr->u.s.car; + goto mark_obj; + } + + case Lisp_Float: + CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT); + /* Do not mark floats stored in a dump image: these floats are + "cold" and do not have mark bits. */ + if (pdumper_object_p (XFLOAT (obj))) + eassert (pdumper_cold_object_p (XFLOAT (obj))); + else if (!XFLOAT_MARKED_P (XFLOAT (obj))) + XFLOAT_MARK (XFLOAT (obj)); + break; + + case_Lisp_Int: + break; + + default: emacs_abort (); - goto loop; - } - - case Lisp_Float: - CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT); - /* Do not mark floats stored in a dump image: these floats are - "cold" and do not have mark bits. */ - if (pdumper_object_p (XFLOAT (obj))) - eassert (pdumper_cold_object_p (XFLOAT (obj))); - else if (!XFLOAT_MARKED_P (XFLOAT (obj))) - XFLOAT_MARK (XFLOAT (obj)); - break; - - case_Lisp_Int: - break; - - default: - emacs_abort (); + } } #undef CHECK_LIVE @@ -6962,6 +7025,22 @@ mark_object (Lisp_Object arg) #undef CHECK_ALLOCATED_AND_LIVE } +void +mark_object (Lisp_Object obj) +{ + ptrdiff_t sp = mark_stk.sp; + mark_stack_push_value (obj); + process_mark_stack (sp); +} + +void +mark_objects (Lisp_Object *objs, ptrdiff_t n) +{ + ptrdiff_t sp = mark_stk.sp; + mark_stack_push_values (objs, n); + process_mark_stack (sp); +} + /* Mark the Lisp pointers in the terminal objects. Called by Fgarbage_collect. */ @@ -7413,6 +7492,37 @@ arenas. */) } #endif +#ifdef HAVE_MALLOC_TRIM +DEFUN ("malloc-trim", Fmalloc_trim, Smalloc_trim, 0, 1, "", + doc: /* Release free heap memory to the OS. +This function asks libc to return unused heap memory back to the operating +system. This function isn't guaranteed to do anything, and is mainly +meant as a debugging tool. + +If LEAVE_PADDING is given, ask the system to leave that much unused +space in the heap of the Emacs process. This should be an integer, and if +not given, it defaults to 0. + +This function returns nil if no memory could be returned to the +system, and non-nil if some memory could be returned. */) + (Lisp_Object leave_padding) +{ + int pad = 0; + + if (! NILP (leave_padding)) + { + CHECK_FIXNAT (leave_padding); + pad = XFIXNUM (leave_padding); + } + + /* 1 means that memory was released to the system. */ + if (malloc_trim (pad) == 1) + return Qt; + else + return Qnil; +} +#endif + static bool symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj) { @@ -7763,6 +7873,9 @@ N should be nonnegative. */); (__GLIBC__ > 2 || __GLIBC_MINOR__ >= 10) defsubr (&Smalloc_info); +#endif +#ifdef HAVE_MALLOC_TRIM + defsubr (&Smalloc_trim); #endif defsubr (&Ssuspicious_object); @@ -7771,14 +7884,14 @@ N should be nonnegative. */); static union Aligned_Lisp_Subr Swatch_gc_cons_threshold = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_threshold }, - 4, 4, "watch_gc_cons_threshold", {0}, 0}}; + 4, 4, "watch_gc_cons_threshold", {0}, lisp_h_Qnil}}; XSETSUBR (watcher, &Swatch_gc_cons_threshold.s); Fadd_variable_watcher (Qgc_cons_threshold, watcher); static union Aligned_Lisp_Subr Swatch_gc_cons_percentage = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_percentage }, - 4, 4, "watch_gc_cons_percentage", {0}, 0}}; + 4, 4, "watch_gc_cons_percentage", {0}, lisp_h_Qnil}}; XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); Fadd_variable_watcher (Qgc_cons_percentage, watcher); } diff --git a/src/bidi.c b/src/bidi.c index 44b7422bdc6..4d2c74b17cd 100644 --- a/src/bidi.c +++ b/src/bidi.c @@ -2927,8 +2927,11 @@ bidi_resolve_brackets (struct bidi_it *bidi_it) else if (bidi_it->bracket_enclosed_type == STRONG_L /* N0c, N0d */ || bidi_it->bracket_enclosed_type == STRONG_R) { - eassert (bidi_it->prev_for_neutral.type != UNKNOWN_BT); - switch (bidi_it->prev_for_neutral.type) + bidi_type_t prev_type_for_neutral = bidi_it->prev_for_neutral.type; + + if (prev_type_for_neutral == UNKNOWN_BT) + prev_type_for_neutral = embedding_type; + switch (prev_type_for_neutral) { case STRONG_R: case WEAK_EN: diff --git a/src/bignum.c b/src/bignum.c index cb5322f291a..e4e4d45d686 100644 --- a/src/bignum.c +++ b/src/bignum.c @@ -476,3 +476,96 @@ check_int_nonnegative (Lisp_Object x) CHECK_INTEGER (x); return NILP (Fnatnump (x)) ? 0 : check_integer_range (x, 0, INT_MAX); } + +/* Return a random mp_limb_t. */ + +static mp_limb_t +get_random_limb (void) +{ + if (GMP_NUMB_BITS <= ULONG_WIDTH) + return get_random_ulong (); + + /* Work around GCC -Wshift-count-overflow false alarm. */ + int shift = GMP_NUMB_BITS <= ULONG_WIDTH ? 0 : ULONG_WIDTH; + + /* This is in case someone builds GMP with unusual definitions for + MINI_GMP_LIMB_TYPE or _LONG_LONG_LIMB. */ + mp_limb_t r = 0; + for (int i = 0; i < GMP_NUMB_BITS; i += ULONG_WIDTH) + r = (r << shift) | get_random_ulong (); + return r; +} + +/* Return a random mp_limb_t I in the range 0 <= I < LIM. + If LIM is zero, simply return a random mp_limb_t. */ + +static mp_limb_t +get_random_limb_lim (mp_limb_t lim) +{ + /* Return the remainder of a random mp_limb_t R divided by LIM, + except reject the rare case where R is so close to the maximum + mp_limb_t that the remainder isn't random. */ + mp_limb_t difflim = - lim, diff, remainder; + do + { + mp_limb_t r = get_random_limb (); + if (lim == 0) + return r; + remainder = r % lim; + diff = r - remainder; + } + while (difflim < diff); + + return remainder; +} + +/* Return a random Lisp integer I in the range 0 <= I < LIMIT, + where LIMIT is a positive bignum. */ + +Lisp_Object +get_random_bignum (struct Lisp_Bignum const *limit) +{ + mpz_t const *lim = bignum_val (limit); + mp_size_t nlimbs = mpz_size (*lim); + eassume (0 < nlimbs); + mp_limb_t *r_limb = mpz_limbs_write (mpz[0], nlimbs); + mp_limb_t const *lim_limb = mpz_limbs_read (*lim); + mp_limb_t limhi = lim_limb[nlimbs - 1]; + eassert (limhi); + bool edgy; + + do + { + /* Generate the result one limb at a time, most significant first. + Choose the most significant limb RHI randomly from 0..LIMHI, + where LIMHI is the LIM's first limb, except choose from + 0..(LIMHI-1) if there is just one limb. RHI == LIMHI is an + unlucky edge case as later limbs might cause the result to be + exceed or equal LIM; if this happens, it causes another + iteration in the outer loop. */ + + mp_limb_t rhi = get_random_limb_lim (limhi + (1 < nlimbs)); + edgy = rhi == limhi; + r_limb[nlimbs - 1] = rhi; + + for (mp_size_t i = nlimbs - 1; 0 < i--; ) + { + /* get_random_limb_lim (edgy ? limb_lim[i] + 1 : 0) + would be wrong here, as the full mp_limb_t range is + needed in later limbs for the edge case to have the + proper weighting. */ + mp_limb_t ri = get_random_limb (); + if (edgy) + { + if (lim_limb[i] < ri) + break; + edgy = lim_limb[i] == ri; + } + r_limb[i] = ri; + } + } + while (edgy); + + mpz_limbs_finish (mpz[0], nlimbs); + return make_integer_mpz (); +} diff --git a/src/bignum.h b/src/bignum.h index 5f94ce850cf..de9ee17c027 100644 --- a/src/bignum.h +++ b/src/bignum.h @@ -51,6 +51,7 @@ extern void emacs_mpz_mul_2exp (mpz_t, mpz_t const, EMACS_INT) extern void emacs_mpz_pow_ui (mpz_t, mpz_t const, unsigned long) ARG_NONNULL ((1, 2)); extern double mpz_get_d_rounded (mpz_t const) ATTRIBUTE_CONST; +extern Lisp_Object get_random_bignum (struct Lisp_Bignum const *); INLINE_HEADER_BEGIN diff --git a/src/buffer.c b/src/buffer.c index 91ff6b946f7..f8a7a4f5109 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -1159,11 +1159,9 @@ is first appended to NAME, to speed up finding a non-existent buffer. */) else { char number[sizeof "-999999"]; - - /* Use XFIXNUM instead of XFIXNAT to work around GCC bug 80776. */ - int i = XFIXNUM (Frandom (make_fixnum (1000000))); - eassume (0 <= i && i < 1000000); - + EMACS_INT r = get_random (); + eassume (0 <= r); + int i = r % 1000000; AUTO_STRING_WITH_LEN (lnumber, number, sprintf (number, "-%d", i)); genbase = concat2 (name, lnumber); if (NILP (Fget_buffer (genbase))) diff --git a/src/bytecode.c b/src/bytecode.c index 96f1f905812..74b7d16affd 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -21,6 +21,7 @@ along with GNU Emacs. If not, see . */ #include "lisp.h" #include "blockinput.h" +#include "sysstdio.h" #include "character.h" #include "buffer.h" #include "keyboard.h" @@ -186,6 +187,7 @@ DEFINE (Bfollowing_char, 0147) \ DEFINE (Bpreceding_char, 0150) \ DEFINE (Bcurrent_column, 0151) \ DEFINE (Bindent_to, 0152) \ +/* 0153 was Bscan_buffer in v17. */ \ DEFINE (Beolp, 0154) \ DEFINE (Beobp, 0155) \ DEFINE (Bbolp, 0156) \ @@ -193,6 +195,7 @@ DEFINE (Bbobp, 0157) \ DEFINE (Bcurrent_buffer, 0160) \ DEFINE (Bset_buffer, 0161) \ DEFINE (Bsave_current_buffer_1, 0162) /* Replacing Bsave_current_buffer. */ \ +/* 0163 was Bset_mark in v17. */ \ DEFINE (Binteractive_p, 0164) /* Obsolete since Emacs-24.1. */ \ \ DEFINE (Bforward_char, 0165) \ @@ -253,11 +256,7 @@ DEFINE (Brem, 0246) \ DEFINE (Bnumberp, 0247) \ DEFINE (Bintegerp, 0250) \ \ -DEFINE (BRgoto, 0252) \ -DEFINE (BRgotoifnil, 0253) \ -DEFINE (BRgotoifnonnil, 0254) \ -DEFINE (BRgotoifnilelsepop, 0255) \ -DEFINE (BRgotoifnonnilelsepop, 0256) \ +/* 0252-0256 were relative jumps, apparently never used. */ \ \ DEFINE (BlistN, 0257) \ DEFINE (BconcatN, 0260) \ @@ -277,11 +276,6 @@ enum byte_code_op #define DEFINE(name, value) name = value, BYTE_CODES #undef DEFINE - -#if BYTE_CODE_SAFE - Bscan_buffer = 0153, /* No longer generated as of v18. */ - Bset_mark = 0163, /* this loser is no longer generated as of v18 */ -#endif }; /* Fetch the next byte from the bytecode stream. */ @@ -291,7 +285,7 @@ enum byte_code_op /* Fetch two bytes from the bytecode stream and make a 16-bit number out of them. */ -#define FETCH2 (op = FETCH, op + (FETCH << 8)) +#define FETCH2 (op = FETCH, op | (FETCH << 8)) /* Push X onto the execution stack. The expression X should not contain TOP, to avoid competing side effects. */ @@ -331,9 +325,8 @@ If the third argument is incorrect, Emacs may crash. */) the original unibyte form. */ bytestr = Fstring_as_unibyte (bytestr); } - pin_string (bytestr); // Bytecode must be immovable. - - return exec_byte_code (bytestr, vector, maxdepth, 0, 0, NULL); + Lisp_Object fun = CALLN (Fmake_byte_code, Qnil, bytestr, vector, maxdepth); + return exec_byte_code (fun, 0, 0, NULL); } static void @@ -342,48 +335,186 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } -/* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and - MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect, - emacs may crash!). ARGS_TEMPLATE is the function arity encoded as an - integer, and ARGS, of size NARGS, should be a vector of the actual - arguments. The arguments in ARGS are pushed on the stack according - to ARGS_TEMPLATE before executing BYTESTR. */ +/* The bytecode stack size in bytes. + This is a fairly generous amount, but: + - if users need more, we could allocate more, or just reserve the address + space and allocate on demand + - if threads are used more, then it might be a good idea to reduce the + per-thread overhead in time and space + - for maximum flexibility but a small runtime penalty, we could allocate + the stack in smaller chunks as needed +*/ +#define BC_STACK_SIZE (512 * 1024 * sizeof (Lisp_Object)) + +/* Bytecode interpreter stack: + + |--------------| -- + |fun | | ^ stack growth + |saved_pc | | | direction + |saved_top ------- | + fp--->|saved_fp ---- | | current frame + |--------------| | | | (called from bytecode in this example) + | (free) | | | | + top-->| ...stack... | | | | + : ... : | | | + |incoming args | | | | + |--------------| | | -- + |fun | | | | + |saved_pc | | | | + |saved_top | | | | + |saved_fp |<- | | previous frame + |--------------| | | + | (free) | | | + | ...stack... |<---- | + : ... : | + |incoming args | | + |--------------| -- + : : +*/ + +/* bytecode stack frame header (footer, actually) */ +struct bc_frame { + struct bc_frame *saved_fp; /* previous frame pointer, + NULL if bottommost frame */ + + /* In a frame called directly from C, the following two members are NULL. */ + Lisp_Object *saved_top; /* previous stack pointer */ + const unsigned char *saved_pc; /* previous program counter */ + + Lisp_Object fun; /* current function object */ + + Lisp_Object next_stack[]; /* data stack of next frame */ +}; + +void +init_bc_thread (struct bc_thread_state *bc) +{ + bc->stack = xmalloc (BC_STACK_SIZE); + bc->stack_end = bc->stack + BC_STACK_SIZE; + /* Put a dummy header at the bottom to indicate the first free location. */ + bc->fp = (struct bc_frame *)bc->stack; + memset (bc->fp, 0, sizeof *bc->fp); +} + +void +free_bc_thread (struct bc_thread_state *bc) +{ + xfree (bc->stack); +} + +void +mark_bytecode (struct bc_thread_state *bc) +{ + struct bc_frame *fp = bc->fp; + Lisp_Object *top = NULL; /* stack pointer of topmost frame not known */ + for (;;) + { + struct bc_frame *next_fp = fp->saved_fp; + /* Only the dummy frame at the bottom has saved_fp = NULL. */ + if (!next_fp) + break; + mark_object (fp->fun); + Lisp_Object *frame_base = next_fp->next_stack; + if (top) + { + /* The stack pointer of a frame is known: mark the part of the stack + above it conservatively. This includes any outgoing arguments. */ + mark_memory (top + 1, fp); + /* Mark the rest of the stack precisely. */ + mark_objects (frame_base, top + 1 - frame_base); + } + else + { + /* The stack pointer is unknown -- mark everything conservatively. */ + mark_memory (frame_base, fp); + } + top = fp->saved_top; + fp = next_fp; + } +} + +DEFUN ("internal-stack-stats", Finternal_stack_stats, Sinternal_stack_stats, + 0, 0, 0, + doc: /* internal */) + (void) +{ + struct bc_thread_state *bc = ¤t_thread->bc; + int nframes = 0; + int nruns = 0; + for (struct bc_frame *fp = bc->fp; fp; fp = fp->saved_fp) + { + nframes++; + if (fp->saved_top == NULL) + nruns++; + } + fprintf (stderr, "%d stack frames, %d runs\n", nframes, nruns); + return Qnil; +} + +/* Whether a stack pointer is valid in the current frame. */ +static bool +valid_sp (struct bc_thread_state *bc, Lisp_Object *sp) +{ + struct bc_frame *fp = bc->fp; + return sp < (Lisp_Object *)fp && sp + 1 >= fp->saved_fp->next_stack; +} + +/* Execute the byte-code in FUN. ARGS_TEMPLATE is the function arity + encoded as an integer (the one in FUN is ignored), and ARGS, of + size NARGS, should be a vector of the actual arguments. The + arguments in ARGS are pushed on the stack according to + ARGS_TEMPLATE before executing FUN. */ Lisp_Object -exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, - ptrdiff_t args_template, ptrdiff_t nargs, Lisp_Object *args) +exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, + ptrdiff_t nargs, Lisp_Object *args) { #ifdef BYTE_CODE_METER int volatile this_op = 0; #endif + unsigned char quitcounter = 1; + struct bc_thread_state *bc = ¤t_thread->bc; + /* Values used for the first stack record when called from C. */ + Lisp_Object *top = NULL; + unsigned char const *pc = NULL; + + Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); + + setup_frame: ; eassert (!STRING_MULTIBYTE (bytestr)); eassert (string_immovable_p (bytestr)); + /* FIXME: in debug mode (!NDEBUG, BYTE_CODE_SAFE or enabled checking), + save the specpdl index on function entry and check that it is the same + when returning, to detect unwind imbalances. This would require adding + a field to the frame header. */ + Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); + Lisp_Object maxdepth = AREF (fun, COMPILED_STACK_DEPTH); ptrdiff_t const_length = ASIZE (vector); ptrdiff_t bytestr_length = SCHARS (bytestr); Lisp_Object *vectorp = XVECTOR (vector)->contents; - unsigned char quitcounter = 1; - /* Allocate two more slots than required, because... */ - EMACS_INT stack_items = XFIXNAT (maxdepth) + 2; - USE_SAFE_ALLOCA; - void *alloc; - SAFE_ALLOCA_LISP (alloc, stack_items); - Lisp_Object *stack_base = alloc; - /* ... we plonk BYTESTR and VECTOR there to ensure that they survive - GC (bug#33014), since these variables aren't used directly beyond - the interpreter prologue and wouldn't be found in the stack frame - otherwise. */ - stack_base[0] = bytestr; - stack_base[1] = vector; - Lisp_Object *top = stack_base + 1; - Lisp_Object *stack_lim = top + stack_items; + EMACS_INT max_stack = XFIXNAT (maxdepth); + Lisp_Object *frame_base = bc->fp->next_stack; + struct bc_frame *fp = (struct bc_frame *)(frame_base + max_stack); + + if ((char *)fp->next_stack > bc->stack_end) + error ("Bytecode stack overflow"); + + /* Save the function object so that the bytecode and vector are + held from removal by the GC. */ + fp->fun = fun; + /* Save previous stack pointer and pc in the new frame. If we came + directly from outside, these will be NULL. */ + fp->saved_top = top; + fp->saved_pc = pc; + fp->saved_fp = bc->fp; + bc->fp = fp; + + top = frame_base - 1; unsigned char const *bytestr_data = SDATA (bytestr); - unsigned char const *pc = bytestr_data; -#if BYTE_CODE_SAFE || !defined NDEBUG - specpdl_ref count = SPECPDL_INDEX (); -#endif + pc = bytestr_data; /* ARGS_TEMPLATE is composed of bit fields: bits 0..6 minimum number of arguments @@ -410,7 +541,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, int op; enum handlertype type; - if (BYTE_CODE_SAFE && ! (stack_base <= top && top < stack_lim)) + if (BYTE_CODE_SAFE && !valid_sp (bc, top)) emacs_abort (); #ifdef BYTE_CODE_METER @@ -642,39 +773,45 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, error ("Lisp nesting exceeds `max-lisp-eval-depth'"); } - ptrdiff_t numargs = op; - Lisp_Object fun = TOP; - Lisp_Object *args = &TOP + 1; + ptrdiff_t call_nargs = op; + Lisp_Object call_fun = TOP; + Lisp_Object *call_args = &TOP + 1; - specpdl_ref count1 = record_in_backtrace (fun, args, numargs); + specpdl_ref count1 = record_in_backtrace (call_fun, + call_args, call_nargs); maybe_gc (); if (debug_on_next_call) do_debug_on_call (Qlambda, count1); - Lisp_Object original_fun = fun; - if (SYMBOLP (fun)) - fun = XSYMBOL (fun)->u.s.function; + Lisp_Object original_fun = call_fun; + if (SYMBOLP (call_fun)) + call_fun = XSYMBOL (call_fun)->u.s.function; Lisp_Object template; Lisp_Object bytecode; - Lisp_Object val; - if (COMPILEDP (fun) + if (COMPILEDP (call_fun) // Lexical binding only. - && (template = AREF (fun, COMPILED_ARGLIST), + && (template = AREF (call_fun, COMPILED_ARGLIST), FIXNUMP (template)) // No autoloads. - && (bytecode = AREF (fun, COMPILED_BYTECODE), + && (bytecode = AREF (call_fun, COMPILED_BYTECODE), !CONSP (bytecode))) - val = exec_byte_code (bytecode, - AREF (fun, COMPILED_CONSTANTS), - AREF (fun, COMPILED_STACK_DEPTH), - XFIXNUM (template), numargs, args); - else if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) - val = funcall_subr (XSUBR (fun), numargs, args); + { + fun = call_fun; + bytestr = bytecode; + args_template = XFIXNUM (template); + nargs = call_nargs; + args = call_args; + goto setup_frame; + } + + Lisp_Object val; + if (SUBRP (call_fun) && !SUBR_NATIVE_COMPILED_DYNP (call_fun)) + val = funcall_subr (XSUBR (call_fun), call_nargs, call_args); else - val = funcall_general (original_fun, numargs, args); + val = funcall_general (original_fun, call_nargs, call_args); lisp_eval_depth--; - if (backtrace_debug_on_exit (specpdl_ref_to_ptr (count1))) + if (backtrace_debug_on_exit (specpdl_ptr - 1)) val = call_debugger (list2 (Qexit, val)); specpdl_ptr--; @@ -705,7 +842,6 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, op = FETCH2; op_branch: op -= pc - bytestr_data; - op_relative_branch: if (BYTE_CODE_SAFE && ! (bytestr_data - pc <= op && op < bytestr_data + bytestr_length - pc)) @@ -740,38 +876,41 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, DISCARD (1); NEXT; - CASE (BRgoto): - op = FETCH - 128; - goto op_relative_branch; - - CASE (BRgotoifnil): - op = FETCH - 128; - if (NILP (POP)) - goto op_relative_branch; - NEXT; - - CASE (BRgotoifnonnil): - op = FETCH - 128; - if (!NILP (POP)) - goto op_relative_branch; - NEXT; - - CASE (BRgotoifnilelsepop): - op = FETCH - 128; - if (NILP (TOP)) - goto op_relative_branch; - DISCARD (1); - NEXT; - - CASE (BRgotoifnonnilelsepop): - op = FETCH - 128; - if (!NILP (TOP)) - goto op_relative_branch; - DISCARD (1); - NEXT; - CASE (Breturn): - goto exit; + { + Lisp_Object *saved_top = bc->fp->saved_top; + if (saved_top) + { + Lisp_Object val = TOP; + + lisp_eval_depth--; + if (backtrace_debug_on_exit (specpdl_ptr - 1)) + val = call_debugger (list2 (Qexit, val)); + specpdl_ptr--; + + top = saved_top; + pc = bc->fp->saved_pc; + struct bc_frame *fp = bc->fp->saved_fp; + bc->fp = fp; + + Lisp_Object fun = fp->fun; + Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); + Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); + bytestr_data = SDATA (bytestr); + vectorp = XVECTOR (vector)->contents; + if (BYTE_CODE_SAFE) + { + /* Only required for checking, not for execution. */ + const_length = ASIZE (vector); + bytestr_length = SCHARS (bytestr); + } + + TOP = val; + NEXT; + } + else + goto exit; + } CASE (Bdiscard): DISCARD (1); @@ -826,9 +965,23 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (sys_setjmp (c->jmp)) { struct handler *c = handlerlist; + handlerlist = c->next; top = c->bytecode_top; op = c->bytecode_dest; - handlerlist = c->next; + struct bc_frame *fp = bc->fp; + + Lisp_Object fun = fp->fun; + Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); + Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); + bytestr_data = SDATA (bytestr); + vectorp = XVECTOR (vector)->contents; + if (BYTE_CODE_SAFE) + { + /* Only required for checking, not for execution. */ + const_length = ASIZE (vector); + bytestr_length = SCHARS (bytestr); + } + pc = bytestr_data; PUSH (c->val); goto op_branch; } @@ -1467,19 +1620,6 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, TOP = INTEGERP (TOP) ? Qt : Qnil; NEXT; -#if BYTE_CODE_SAFE - /* These are intentionally written using 'case' syntax, - because they are incompatible with the threaded - interpreter. */ - - case Bset_mark: - error ("set-mark is an obsolete bytecode"); - break; - case Bscan_buffer: - error ("scan-buffer is an obsolete bytecode"); - break; -#endif - CASE_ABORT: /* Actually this is Bstack_ref with offset 0, but we use Bdup for that instead. */ @@ -1580,20 +1720,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, exit: -#if BYTE_CODE_SAFE || !defined NDEBUG - if (!specpdl_ref_eq (SPECPDL_INDEX (), count)) - { - /* Binds and unbinds are supposed to be compiled balanced. */ - if (specpdl_ref_lt (count, SPECPDL_INDEX ())) - unbind_to (count, Qnil); - error ("binding stack not balanced (serious byte compiler bug)"); - } -#endif - /* The byte code should have been properly pinned. */ - eassert (SDATA (bytestr) == bytestr_data); + bc->fp = bc->fp->saved_fp; Lisp_Object result = TOP; - SAFE_FREE (); return result; } @@ -1615,6 +1744,7 @@ void syms_of_bytecode (void) { defsubr (&Sbyte_code); + defsubr (&Sinternal_stack_stats); #ifdef BYTE_CODE_METER diff --git a/src/callint.c b/src/callint.c index 31919d6bb81..92bfaf8d397 100644 --- a/src/callint.c +++ b/src/callint.c @@ -315,7 +315,7 @@ invoke it (via an `interactive' spec that contains, for instance, an Lisp_Object up_event = Qnil; /* Set SPECS to the interactive form, or barf if not interactive. */ - Lisp_Object form = Finteractive_form (function); + Lisp_Object form = call1 (Qinteractive_form, function); if (! CONSP (form)) wrong_type_argument (Qcommandp, function); Lisp_Object specs = Fcar (XCDR (form)); diff --git a/src/callproc.c b/src/callproc.c index 018c9ce6909..dd162f36a6c 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -85,6 +85,10 @@ extern char **environ; #include "nsterm.h" #endif +#ifdef HAVE_PGTK +#include "pgtkterm.h" +#endif + /* Pattern used by call-process-region to make temp files. */ static Lisp_Object Vtemp_file_name_pattern; @@ -1335,7 +1339,8 @@ emacs_posix_spawn_init_actions (posix_spawn_file_actions_t *actions, } static int -emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes) +emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes, + const sigset_t *oldset) { int error = posix_spawnattr_init (attributes); if (error != 0) @@ -1377,11 +1382,7 @@ emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes) goto out; /* Stop blocking SIGCHLD in the child. */ - sigset_t oldset; - error = pthread_sigmask (SIG_SETMASK, NULL, &oldset); - if (error != 0) - goto out; - error = posix_spawnattr_setsigmask (attributes, &oldset); + error = posix_spawnattr_setsigmask (attributes, oldset); if (error != 0) goto out; @@ -1392,23 +1393,6 @@ emacs_posix_spawn_init_attributes (posix_spawnattr_t *attributes) return error; } -static int -emacs_posix_spawn_init (posix_spawn_file_actions_t *actions, - posix_spawnattr_t *attributes, int std_in, - int std_out, int std_err, const char *cwd) -{ - int error = emacs_posix_spawn_init_actions (actions, std_in, - std_out, std_err, cwd); - if (error != 0) - return error; - - error = emacs_posix_spawn_init_attributes (attributes); - if (error != 0) - return error; - - return 0; -} - #endif /* Start a new asynchronous subprocess. If successful, return zero @@ -1443,9 +1427,12 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err, if (use_posix_spawn) { /* Initialize optional attributes before blocking. */ - int error - = emacs_posix_spawn_init (&actions, &attributes, std_in, - std_out, std_err, cwd); + int error = emacs_posix_spawn_init_actions (&actions, std_in, + std_out, std_err, cwd); + if (error != 0) + return error; + + error = emacs_posix_spawn_init_attributes (&attributes, oldset); if (error != 0) return error; } @@ -1704,6 +1691,7 @@ getenv_internal (const char *var, ptrdiff_t varlen, char **value, /* For DISPLAY try to get the values from the frame or the initial env. */ if (strcmp (var, "DISPLAY") == 0) { +#ifndef HAVE_PGTK Lisp_Object display = Fframe_parameter (NILP (frame) ? selected_frame : frame, Qdisplay); if (STRINGP (display)) @@ -1712,6 +1700,7 @@ getenv_internal (const char *var, ptrdiff_t varlen, char **value, *valuelen = SBYTES (display); return 1; } +#endif /* If still not found, Look for DISPLAY in Vinitial_environment. */ if (getenv_internal_1 (var, varlen, value, valuelen, Vinitial_environment)) @@ -1829,6 +1818,18 @@ make_environment_block (Lisp_Object current_dir) if (NILP (display)) { Lisp_Object tmp = Fframe_parameter (selected_frame, Qdisplay); + +#ifdef HAVE_PGTK + /* The only time GDK actually returns correct information is + when it's running under X Windows. DISPLAY shouldn't be + set to a Wayland display either, since that's an X specific + variable. */ + if (FRAME_WINDOW_P (SELECTED_FRAME ()) + && strcmp (G_OBJECT_TYPE_NAME (FRAME_X_DISPLAY (SELECTED_FRAME ())), + "GdkX11Display")) + tmp = Qnil; +#endif + if (!STRINGP (tmp) && CONSP (Vinitial_environment)) /* If still not found, Look for DISPLAY in Vinitial_environment. */ tmp = Fgetenv_internal (build_string ("DISPLAY"), diff --git a/src/charset.c b/src/charset.c index d0cfe60952e..9edbd4c8c84 100644 --- a/src/charset.c +++ b/src/charset.c @@ -793,16 +793,21 @@ map_charset_chars (void (*c_function)(Lisp_Object, Lisp_Object), Lisp_Object fun DEFUN ("map-charset-chars", Fmap_charset_chars, Smap_charset_chars, 2, 5, 0, doc: /* Call FUNCTION for all characters in CHARSET. -FUNCTION is called with an argument RANGE and the optional 3rd -argument ARG. +Optional 3rd argument ARG is an additional argument to be passed +to FUNCTION, see below. +Optional 4th and 5th arguments FROM-CODE and TO-CODE specify the +range of code points (in CHARSET) of target characters on which to +map the FUNCTION. Note that these are not character codes, but code +points of CHARSET; for the difference see `decode-char' and +`list-charset-chars'. If FROM-CODE is nil or imitted, it stands for +the first code point of CHARSET; if TO-CODE is nil or omitted, it +stands for the last code point of CHARSET. -RANGE is a cons (FROM . TO), where FROM and TO indicate a range of -characters contained in CHARSET. - -The optional 4th and 5th arguments FROM-CODE and TO-CODE specify the -range of code points (in CHARSET) of target characters. Note that -these are not character codes, but code points in CHARSET; for the -difference see `decode-char' and `list-charset-chars'. */) +FUNCTION will be called with two arguments: RANGE and ARG. +RANGE is a cons (FROM . TO), where FROM and TO specify a range of +characters that belong to CHARSET on which FUNCTION should do its +job. FROM and TO are Emacs character codes, unlike FROM-CODE and +TO-CODE, which are CHARSET code points. */) (Lisp_Object function, Lisp_Object charset, Lisp_Object arg, Lisp_Object from_code, Lisp_Object to_code) { struct charset *cs; diff --git a/src/coding.c b/src/coding.c index c16598d275d..2bed293d571 100644 --- a/src/coding.c +++ b/src/coding.c @@ -1131,7 +1131,6 @@ detect_coding_utf_8 (struct coding_system *coding, ptrdiff_t consumed_chars = 0; bool bom_found = 0; ptrdiff_t nchars = coding->head_ascii; - int eol_seen = coding->eol_seen; detect_info->checked |= CATEGORY_MASK_UTF_8; /* A coding system of this category is always ASCII compatible. */ @@ -1161,15 +1160,10 @@ detect_coding_utf_8 (struct coding_system *coding, { if (src < src_end && *src == '\n') { - eol_seen |= EOL_SEEN_CRLF; src++; nchars++; } - else - eol_seen |= EOL_SEEN_CR; } - else if (c == '\n') - eol_seen |= EOL_SEEN_LF; continue; } ONE_MORE_BYTE (c1); diff --git a/src/comp.c b/src/comp.c index 6449eedb278..66a7ab789a8 100644 --- a/src/comp.c +++ b/src/comp.c @@ -447,7 +447,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "4" +#define ABI_VERSION "5" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 @@ -516,8 +516,6 @@ typedef struct { ptrdiff_t size; } f_reloc_t; -sigset_t saved_sigset; - static f_reloc_t freloc; #define NUM_CAST_TYPES 15 @@ -648,7 +646,7 @@ typedef struct { static comp_t comp; -FILE *logfile = NULL; +static FILE *logfile; /* This is used for serialized objects by the reload mechanism. */ typedef struct { @@ -666,16 +664,16 @@ typedef struct { Helper functions called by the run-time. */ -void helper_unwind_protect (Lisp_Object handler); -Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); -Lisp_Object helper_unbind_n (Lisp_Object n); -void helper_save_restriction (void); -bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); -struct Lisp_Symbol_With_Pos *helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a); +static void helper_unwind_protect (Lisp_Object); +static Lisp_Object helper_unbind_n (Lisp_Object); +static void helper_save_restriction (void); +static bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object, enum pvec_type); +static struct Lisp_Symbol_With_Pos * +helper_GET_SYMBOL_WITH_POSITION (Lisp_Object); /* Note: helper_link_table must match the list created by `declare_runtime_imported_funcs'. */ -void *helper_link_table[] = +static void *helper_link_table[] = { wrong_type_argument, helper_PSEUDOVECTOR_TYPEP_XUNTAG, pure_write_error, @@ -4971,12 +4969,11 @@ unknown (before GCC version 10). */) /******************************************************************************/ /* Helper functions called from the run-time. */ -/* These can't be statics till shared mechanism is used to solve relocations. */ /* Note: this are all potentially definable directly to gcc and are here just */ /* for laziness. Change this if a performance impact is measured. */ /******************************************************************************/ -void +static void helper_unwind_protect (Lisp_Object handler) { /* Support for a function here is new in 24.4. */ @@ -4984,28 +4981,20 @@ helper_unwind_protect (Lisp_Object handler) handler); } -Lisp_Object -helper_temp_output_buffer_setup (Lisp_Object x) -{ - CHECK_STRING (x); - temp_output_buffer_setup (SSDATA (x)); - return Vstandard_output; -} - -Lisp_Object +static Lisp_Object helper_unbind_n (Lisp_Object n) { return unbind_to (specpdl_ref_add (SPECPDL_INDEX (), -XFIXNUM (n)), Qnil); } -void +static void helper_save_restriction (void) { record_unwind_protect (save_restriction_restore, save_restriction_save ()); } -bool +static bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) { return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, @@ -5013,7 +5002,7 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) code); } -struct Lisp_Symbol_With_Pos * +static struct Lisp_Symbol_With_Pos * helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a) { if (!SYMBOL_WITH_POS_P (a)) @@ -5032,6 +5021,12 @@ return_nil (Lisp_Object arg) { return Qnil; } + +static Lisp_Object +directory_files_matching (Lisp_Object name, Lisp_Object match) +{ + return Fdirectory_files (name, Qt, match, Qnil, Qnil); +} #endif /* Windows does not let us delete a .eln file that is currently loaded @@ -5049,11 +5044,11 @@ eln_load_path_final_clean_up (void) FOR_EACH_TAIL (dir_tail) { Lisp_Object files_in_dir = - internal_condition_case_5 (Fdirectory_files, + internal_condition_case_2 (directory_files_matching, Fexpand_file_name (Vcomp_native_version_dir, XCAR (dir_tail)), - Qt, build_string ("\\.eln\\.old\\'"), Qnil, - Qnil, Qt, return_nil); + build_string ("\\.eln\\.old\\'"), + Qt, return_nil); FOR_EACH_TAIL (files_in_dir) internal_delete_file (XCAR (files_in_dir)); } @@ -5411,7 +5406,7 @@ native_function_doc (Lisp_Object function) static Lisp_Object make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx, - Lisp_Object intspec, Lisp_Object comp_u) + Lisp_Object intspec, Lisp_Object command_modes, Lisp_Object comp_u) { struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); dynlib_handle_ptr handle = cu->handle; @@ -5444,7 +5439,8 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = xstrdup (SSDATA (symbol_name)); - x->s.native_intspec = intspec; + x->s.intspec.native = intspec; + x->s.command_modes = command_modes; x->s.doc = XFIXNUM (doc_idx); #ifdef HAVE_NATIVE_COMP x->s.native_comp_u = comp_u; @@ -5467,12 +5463,15 @@ This gets called by top_level_run during the load phase. */) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); + Lisp_Object command_modes = THIRD (rest); + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); if (cu->loaded_once) return Qnil; Lisp_Object tem = - make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec, comp_u); + make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec, + command_modes, comp_u); /* We must protect it against GC because the function is not reachable through symbols. */ @@ -5497,9 +5496,11 @@ This gets called by top_level_run during the load phase. */) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); + Lisp_Object command_modes = THIRD (rest); + Lisp_Object tem = make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx, - intspec, comp_u); + intspec, command_modes, comp_u); defalias (name, tem); diff --git a/src/comp.h b/src/comp.h index 40f1e9b979c..da53f32971e 100644 --- a/src/comp.h +++ b/src/comp.h @@ -53,6 +53,8 @@ struct Lisp_Native_Comp_Unit #ifdef HAVE_NATIVE_COMP +INLINE_HEADER_BEGIN + INLINE bool NATIVE_COMP_UNITP (Lisp_Object a) { @@ -99,6 +101,8 @@ void unload_comp_unit (struct Lisp_Native_Comp_Unit *cu) extern void syms_of_comp (void); +INLINE_HEADER_END + #endif /* #ifdef HAVE_NATIVE_COMP */ #endif /* #ifndef COMP_H */ diff --git a/src/composite.c b/src/composite.c index 3659de8900c..c2ade90d54a 100644 --- a/src/composite.c +++ b/src/composite.c @@ -704,8 +704,8 @@ DEFUN ("clear-composition-cache", Fclear_composition_cache, Clear composition cache. */) (void) { - Lisp_Object args[] = {QCtest, Qequal, QCsize, make_fixnum (311)}; - gstring_hash_table = CALLMANY (Fmake_hash_table, args); + gstring_hash_table = CALLN (Fmake_hash_table, QCtest, Qequal, + QCsize, make_fixnum (311)); /* Fixme: We call Fclear_face_cache to force complete re-building of display glyphs. But, it may be better to call this function from Fclear_face_cache instead. */ diff --git a/src/data.c b/src/data.c index 9c711d20212..a28bf414147 100644 --- a/src/data.c +++ b/src/data.c @@ -211,6 +211,7 @@ for example, (type-of 1) returns `integer'. */) return Qcons; case Lisp_Vectorlike: + /* WARNING!! Keep 'cl--typeof-types' in sync with this code!! */ switch (PSEUDOVECTOR_TYPE (XVECTOR (object))) { case PVEC_NORMAL_VECTOR: return Qvector; @@ -1076,6 +1077,7 @@ Value, if non-nil, is a list (interactive SPEC). */) (Lisp_Object cmd) { Lisp_Object fun = indirect_function (cmd); /* Check cycles. */ + bool genfun = false; if (NILP (fun)) return Qnil; @@ -1094,10 +1096,10 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { - if (SUBR_NATIVE_COMPILEDP (fun) && !NILP (XSUBR (fun)->native_intspec)) - return XSUBR (fun)->native_intspec; + if (SUBR_NATIVE_COMPILEDP (fun) && !NILP (XSUBR (fun)->intspec.native)) + return XSUBR (fun)->intspec.native; - const char *spec = XSUBR (fun)->intspec; + const char *spec = XSUBR (fun)->intspec.string; if (spec) return list2 (Qinteractive, (*spec != '(') ? build_string (spec) : @@ -1108,15 +1110,17 @@ Value, if non-nil, is a list (interactive SPEC). */) if (PVSIZE (fun) > COMPILED_INTERACTIVE) { Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); - if (VECTORP (form)) - /* The vector form is the new form, where the first - element is the interactive spec, and the second is the - command modes. */ - return list2 (Qinteractive, AREF (form, 0)); - else - /* Old form -- just the interactive spec. */ - return list2 (Qinteractive, form); + /* The vector form is the new form, where the first + element is the interactive spec, and the second is the + command modes. */ + return list2 (Qinteractive, VECTORP (form) ? AREF (form, 0) : form); } + else if (PVSIZE (fun) > COMPILED_DOC_STRING) + { + Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING); + /* An invalid "docstring" is a sign that we have an OClosure. */ + genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc)); + } } #ifdef HAVE_MODULES else if (MODULE_FUNCTIONP (fun)) @@ -1139,13 +1143,21 @@ Value, if non-nil, is a list (interactive SPEC). */) if (EQ (funcar, Qclosure)) form = Fcdr (form); Lisp_Object spec = Fassq (Qinteractive, form); - if (NILP (Fcdr (Fcdr (spec)))) + if (NILP (spec) && VALID_DOCSTRING_P (CAR_SAFE (form))) + /* A "docstring" is a sign that we may have an OClosure. */ + genfun = true; + else if (NILP (Fcdr (Fcdr (spec)))) return spec; else return list2 (Qinteractive, Fcar (Fcdr (spec))); } } - return Qnil; + if (genfun + /* Avoid burping during bootstrap. */ + && !NILP (Fsymbol_function (Qoclosure_interactive_form))) + return call1 (Qoclosure_interactive_form, fun); + else + return Qnil; } DEFUN ("command-modes", Fcommand_modes, Scommand_modes, 1, 1, 0, @@ -1171,7 +1183,11 @@ The value, if non-nil, is a list of mode name symbols. */) fun = Fsymbol_function (fun); } - if (COMPILEDP (fun)) + if (SUBRP (fun)) + { + return XSUBR (fun)->command_modes; + } + else if (COMPILEDP (fun)) { if (PVSIZE (fun) <= COMPILED_INTERACTIVE) return Qnil; @@ -2817,6 +2833,9 @@ DEFUN ("<", Flss, Slss, 1, MANY, 0, usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) < XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_LESS); } @@ -2825,6 +2844,9 @@ DEFUN (">", Fgtr, Sgtr, 1, MANY, 0, usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) > XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_GRTR); } @@ -2833,6 +2855,9 @@ DEFUN ("<=", Fleq, Sleq, 1, MANY, 0, usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) <= XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL); } @@ -2841,6 +2866,9 @@ DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0, usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1])) + return XFIXNUM (args[0]) >= XFIXNUM (args[1]) ? Qt : Qnil; + return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL); } @@ -2972,6 +3000,29 @@ cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max) return val; } +/* Render NUMBER in decimal into BUFFER which ends right before END. + Return the start of the string; the end is always at END. + The string is not null-terminated. */ +char * +fixnum_to_string (EMACS_INT number, char *buffer, char *end) +{ + EMACS_INT x = number; + bool negative = x < 0; + if (negative) + x = -x; + char *p = end; + do + { + eassume (p > buffer && p - 1 < end); + *--p = '0' + x % 10; + x /= 10; + } + while (x); + if (negative) + *--p = '-'; + return p; +} + DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0, doc: /* Return the decimal representation of NUMBER as a string. Uses a minus sign if negative. @@ -2979,19 +3030,22 @@ NUMBER may be an integer or a floating point number. */) (Lisp_Object number) { char buffer[max (FLOAT_TO_STRING_BUFSIZE, INT_BUFSIZE_BOUND (EMACS_INT))]; - int len; - CHECK_NUMBER (number); + if (FIXNUMP (number)) + { + char *end = buffer + sizeof buffer; + char *p = fixnum_to_string (XFIXNUM (number), buffer, end); + return make_unibyte_string (p, end - p); + } if (BIGNUMP (number)) return bignum_to_string (number, 10); if (FLOATP (number)) - len = float_to_string (buffer, XFLOAT_DATA (number)); - else - len = sprintf (buffer, "%"pI"d", XFIXNUM (number)); + return make_unibyte_string (buffer, + float_to_string (buffer, XFLOAT_DATA (number))); - return make_unibyte_string (buffer, len); + wrong_type_argument (Qnumberp, number); } DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0, @@ -4085,6 +4139,7 @@ syms_of_data (void) DEFSYM (Qchar_table_p, "char-table-p"); DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p"); DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p"); + DEFSYM (Qoclosure_interactive_form, "oclosure-interactive-form"); DEFSYM (Qsubrp, "subrp"); DEFSYM (Qunevalled, "unevalled"); diff --git a/src/decompress.c b/src/decompress.c index ddd8abbf27c..dbdc9104a37 100644 --- a/src/decompress.c +++ b/src/decompress.c @@ -67,8 +67,9 @@ init_zlib_functions (void) #endif /* WINDOWSNT */ +#ifdef HAVE_NATIVE_COMP -#define MD5_BLOCKSIZE 32768 /* From md5.c */ +# define MD5_BLOCKSIZE 32768 /* From md5.c */ static char acc_buff[2 * MD5_BLOCKSIZE]; static size_t acc_size; @@ -106,7 +107,7 @@ md5_gz_stream (FILE *source, void *resblock) unsigned char in[MD5_BLOCKSIZE]; unsigned char out[MD5_BLOCKSIZE]; -#ifdef WINDOWSNT +# ifdef WINDOWSNT if (!zlib_initialized) zlib_initialized = init_zlib_functions (); if (!zlib_initialized) @@ -114,7 +115,7 @@ md5_gz_stream (FILE *source, void *resblock) message1 ("zlib library not found"); return -1; } -#endif +# endif eassert (!acc_size); @@ -164,7 +165,8 @@ md5_gz_stream (FILE *source, void *resblock) return 0; } -#undef MD5_BLOCKSIZE +# undef MD5_BLOCKSIZE +#endif diff --git a/src/deps.mk b/src/deps.mk index deffab93eca..39edd5c1dd3 100644 --- a/src/deps.mk +++ b/src/deps.mk @@ -279,7 +279,7 @@ eval.o: eval.c commands.h keyboard.h blockinput.h atimer.h systime.h frame.h \ dispextern.h lisp.h globals.h $(config_h) coding.h composite.h xterm.h \ msdos.h floatfns.o: floatfns.c syssignal.h lisp.h globals.h $(config_h) -fns.o: fns.c commands.h lisp.h $(config_h) frame.h buffer.h character.h \ +fns.o: fns.c sort.c commands.h lisp.h $(config_h) frame.h buffer.h character.h \ keyboard.h keymap.h window.h $(INTERVALS_H) coding.h ../lib/md5.h \ ../lib/sha1.h ../lib/sha256.h ../lib/sha512.h blockinput.h atimer.h \ systime.h xterm.h ../lib/unistd.h globals.h diff --git a/src/dispextern.h b/src/dispextern.h index b7cfde70339..e9b19a7f135 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -3460,6 +3460,8 @@ extern Lisp_Object handle_tab_bar_click (struct frame *, int, int, bool, int); extern void handle_tool_bar_click (struct frame *, int, int, bool, int); +extern void handle_tool_bar_click_with_device (struct frame *, int, int, bool, + int, Lisp_Object); extern void expose_frame (struct frame *, int, int, int, int); extern bool gui_intersect_rectangles (const Emacs_Rectangle *, diff --git a/src/dispnew.c b/src/dispnew.c index 0d959047f3a..1dd64be4ead 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -3928,9 +3928,13 @@ update_text_area (struct window *w, struct glyph_row *updated_row, int vpos) However, it causes excessive flickering when mouse is moved across the mode line. Luckily, turning it off for the mode line doesn't seem to hurt anything. -- cyd. - But it is still needed for the header line. -- kfs. */ + But it is still needed for the header line. -- kfs. + The header line vpos is 1 if a tab line is enabled. (18th + Apr 2022) */ || (current_row->mouse_face_p - && !(current_row->mode_line_p && vpos > 0)) + && !(current_row->mode_line_p + && (vpos > (w->current_matrix->tab_line_p + && w->current_matrix->header_line_p)))) || current_row->x != desired_row->x) { output_cursor_to (w, vpos, 0, desired_row->y, desired_row->x); @@ -6717,6 +6721,10 @@ See `buffer-display-table' for more information. */); beginning of the next redisplay). */ redisplay_dont_pause = true; + DEFVAR_LISP ("x-show-tooltip-timeout", Vx_show_tooltip_timeout, + doc: /* The default timeout (in seconds) for `x-show-tip'. */); + Vx_show_tooltip_timeout = make_fixnum (5); + DEFVAR_LISP ("tab-bar-position", Vtab_bar_position, doc: /* Specify on which side from the tool bar the tab bar shall be. Possible values are t (below the tool bar), nil (above the tool bar). diff --git a/src/doc.c b/src/doc.c index a9f77b25bfa..71e66853b08 100644 --- a/src/doc.c +++ b/src/doc.c @@ -341,56 +341,8 @@ string is passed through `substitute-command-keys'. */) else if (MODULE_FUNCTIONP (fun)) doc = module_function_documentation (XMODULE_FUNCTION (fun)); #endif - else if (COMPILEDP (fun)) - { - if (PVSIZE (fun) <= COMPILED_DOC_STRING) - return Qnil; - else - { - Lisp_Object tem = AREF (fun, COMPILED_DOC_STRING); - if (STRINGP (tem)) - doc = tem; - else if (FIXNATP (tem) || CONSP (tem)) - doc = tem; - else - return Qnil; - } - } - else if (STRINGP (fun) || VECTORP (fun)) - { - return build_string ("Keyboard macro."); - } - else if (CONSP (fun)) - { - Lisp_Object funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - xsignal1 (Qinvalid_function, fun); - else if (EQ (funcar, Qkeymap)) - return build_string ("Prefix command (definition is a keymap associating keystrokes with commands)."); - else if (EQ (funcar, Qlambda) - || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1)) - || EQ (funcar, Qautoload)) - { - Lisp_Object tem1 = Fcdr (Fcdr (fun)); - Lisp_Object tem = Fcar (tem1); - if (STRINGP (tem)) - doc = tem; - /* Handle a doc reference--but these never come last - in the function body, so reject them if they are last. */ - else if ((FIXNATP (tem) || (CONSP (tem) && FIXNUMP (XCDR (tem)))) - && !NILP (XCDR (tem1))) - doc = tem; - else - return Qnil; - } - else - goto oops; - } else - { - oops: - xsignal1 (Qinvalid_function, fun); - } + doc = call1 (intern ("function-documentation"), fun); /* If DOC is 0, it's typically because of a dumped file missing from the DOC file (bug in src/Makefile.in). */ @@ -514,11 +466,17 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) { /* This bytecode object must have a slot for the docstring, since we've found a docstring for it. */ - if (PVSIZE (fun) > COMPILED_DOC_STRING) + if (PVSIZE (fun) > COMPILED_DOC_STRING + /* Don't overwrite a non-docstring value placed there, + * such as the symbols used for Oclosures. */ + && VALID_DOCSTRING_P (AREF (fun, COMPILED_DOC_STRING))) ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset)); else { - AUTO_STRING (format, "No docstring slot for %s"); + AUTO_STRING (format, + (PVSIZE (fun) > COMPILED_DOC_STRING + ? "Docstring slot busy for %s" + : "No docstring slot for %s")); CALLN (Fmessage, format, (SYMBOLP (obj) ? SYMBOL_NAME (obj) diff --git a/src/dynlib.c b/src/dynlib.c index 8cb9a233745..e2c71f14489 100644 --- a/src/dynlib.c +++ b/src/dynlib.c @@ -279,11 +279,13 @@ dynlib_open (const char *path) return dlopen (path, RTLD_LAZY | RTLD_GLOBAL); } +# ifdef HAVE_NATIVE_COMP dynlib_handle_ptr dynlib_open_for_eln (const char *path) { return dlopen (path, RTLD_LAZY); } +# endif void * dynlib_sym (dynlib_handle_ptr h, const char *sym) @@ -313,11 +315,13 @@ dynlib_error (void) return dlerror (); } +# ifdef HAVE_NATIVE_COMP int dynlib_close (dynlib_handle_ptr h) { return dlclose (h) == 0; } +# endif #else diff --git a/src/emacs-module.c b/src/emacs-module.c index 0974a199e5e..0d3cce0276b 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -955,11 +955,9 @@ single memcpy to convert the magnitude. This way we largely avoid the import/export overhead on most platforms. */ -enum -{ - /* Documented maximum count of magnitude elements. */ - module_bignum_count_max = min (SIZE_MAX, PTRDIFF_MAX) / sizeof (emacs_limb_t) -}; +/* Documented maximum count of magnitude elements. */ +#define module_bignum_count_max \ + ((ptrdiff_t) min (SIZE_MAX, PTRDIFF_MAX) / sizeof (emacs_limb_t)) /* Verify that emacs_limb_t indeed has unique object representations. */ diff --git a/src/emacs.c b/src/emacs.c index 9a14e103759..9f20a1597c9 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -144,6 +144,10 @@ extern char etext; #include "fingerprint.h" #include "epaths.h" +/* Include these only because of INLINE. */ +#include "comp.h" +#include "thread.h" + static const char emacs_version[] = PACKAGE_VERSION; static const char emacs_copyright[] = COPYRIGHT; static const char emacs_bugreport[] = PACKAGE_BUGREPORT; @@ -159,6 +163,10 @@ Lisp_Object empty_unibyte_string, empty_multibyte_string; #ifdef WINDOWSNT /* Cache for externally loaded libraries. */ Lisp_Object Vlibrary_cache; +/* Original command line string as received from the OS. */ +static char *initial_cmdline; +/* Original working directory when invoked. */ +static const char *initial_wd; #endif struct gflags gflags; @@ -229,6 +237,7 @@ HANDLE w32_daemon_event; /* Save argv and argc. */ char **initial_argv; int initial_argc; +static char *initial_emacs_executable = NULL; /* The name of the working directory, or NULL if this info is unavailable. */ char const *emacs_wd; @@ -291,7 +300,10 @@ Initialization options:\n\ -q --no-site-file --no-site-lisp --no-splash\n\ --no-x-resources\n\ --script FILE run FILE as an Emacs Lisp script\n\ ---terminal, -t DEVICE use DEVICE for terminal I/O\n\ +-x to be used in #!/usr/bin/emacs -x\n\ + and has approximately the same meaning\n\ + as -Q --script\n\ +--terminal, -t DEVICE use DEVICE for terminal I/O\n \ --user, -u USER load ~USER/.emacs instead of your own\n\ \n\ ", @@ -427,7 +439,7 @@ terminate_due_to_signal (int sig, int backtrace_limit) don't care about the message stack. */ if (sig == SIGINT && noninteractive) clear_message_stack (); - Fkill_emacs (make_fixnum (sig)); + Fkill_emacs (make_fixnum (sig), Qnil); } shut_down_emacs (sig, Qnil); @@ -710,34 +722,6 @@ argmatch (char **argv, int argc, const char *sstr, const char *lstr, } } -#ifdef HAVE_PDUMPER - -static const char * -dump_error_to_string (int result) -{ - switch (result) - { - case PDUMPER_LOAD_SUCCESS: - return "success"; - case PDUMPER_LOAD_OOM: - return "out of memory"; - case PDUMPER_NOT_LOADED: - return "not loaded"; - case PDUMPER_LOAD_FILE_NOT_FOUND: - return "could not open file"; - case PDUMPER_LOAD_BAD_FILE_TYPE: - return "not a dump file"; - case PDUMPER_LOAD_FAILED_DUMP: - return "dump file is result of failed dump attempt"; - case PDUMPER_LOAD_VERSION_MISMATCH: - return "not built for this Emacs executable"; - default: - return (result <= PDUMPER_LOAD_ERROR - ? "generic error" - : strerror (result - PDUMPER_LOAD_ERROR)); - } -} - /* Find a name (absolute or relative) of the Emacs executable whose name (as passed into this program) is ARGV0. Called early in initialization by portable dumper loading code, so avoid Lisp and @@ -746,7 +730,7 @@ dump_error_to_string (int result) if not found. Store into *CANDIDATE_SIZE a lower bound on the size of any heap allocation. */ static char * -load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) +find_emacs_executable (char const *argv0, ptrdiff_t *candidate_size) { *candidate_size = 0; @@ -837,7 +821,36 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) #endif /* !WINDOWSNT */ } -static void +#ifdef HAVE_PDUMPER + +static const char * +dump_error_to_string (int result) +{ + switch (result) + { + case PDUMPER_LOAD_SUCCESS: + return "success"; + case PDUMPER_LOAD_OOM: + return "out of memory"; + case PDUMPER_NOT_LOADED: + return "not loaded"; + case PDUMPER_LOAD_FILE_NOT_FOUND: + return "could not open file"; + case PDUMPER_LOAD_BAD_FILE_TYPE: + return "not a dump file"; + case PDUMPER_LOAD_FAILED_DUMP: + return "dump file is result of failed dump attempt"; + case PDUMPER_LOAD_VERSION_MISMATCH: + return "not built for this Emacs executable"; + default: + return (result <= PDUMPER_LOAD_ERROR + ? "generic error" + : strerror (result - PDUMPER_LOAD_ERROR)); + } +} + +/* This function returns the Emacs executable. */ +static char * load_pdump (int argc, char **argv) { const char *const suffix = ".pdmp"; @@ -886,7 +899,7 @@ load_pdump (int argc, char **argv) #ifndef NS_SELF_CONTAINED ptrdiff_t exec_bufsize; #endif - emacs_executable = load_pdump_find_executable (argv[0], &bufsize); + emacs_executable = find_emacs_executable (argv[0], &bufsize); #ifndef NS_SELF_CONTAINED exec_bufsize = bufsize; #endif @@ -903,7 +916,7 @@ load_pdump (int argc, char **argv) if (result != PDUMPER_LOAD_SUCCESS) fatal ("could not load dump file \"%s\": %s", dump_file, dump_error_to_string (result)); - return; + return emacs_executable; } /* Look for a dump file in the same directory as the executable; it @@ -1028,7 +1041,8 @@ load_pdump (int argc, char **argv) out: xfree (dump_file); - xfree (emacs_executable); + + return emacs_executable; } #endif /* HAVE_PDUMPER */ @@ -1319,6 +1333,7 @@ main (int argc, char **argv) } } init_heap (use_dynamic_heap); + initial_cmdline = GetCommandLine (); #endif #if defined WINDOWSNT || defined HAVE_NTGUI /* Set global variables used to detect Windows version. Do this as @@ -1341,7 +1356,10 @@ main (int argc, char **argv) #ifdef HAVE_PDUMPER if (attempt_load_pdump) - load_pdump (argc, argv); + initial_emacs_executable = load_pdump (argc, argv); +#else + ptrdiff_t bufsize; + initial_emacs_executable = find_emacs_executable (argv[0], &bufsize); #endif argc = maybe_disable_address_randomization (argc, argv); @@ -1465,6 +1483,9 @@ main (int argc, char **argv) #endif emacs_wd = emacs_get_current_dir_name (); +#ifdef WINDOWSNT + initial_wd = emacs_wd; +#endif #ifdef HAVE_PDUMPER if (dumped_with_pdumper_p ()) pdumper_record_wd (emacs_wd); @@ -1734,12 +1755,25 @@ main (int argc, char **argv) sockfd = SD_LISTEN_FDS_START; #endif /* HAVE_LIBSYSTEMD */ -#ifdef USE_GTK + /* On X, the bug happens because we call abort to avoid GLib + crashes upon a longjmp in our X error handler. + + On PGTK, GTK calls exit in its own error handlers for either + X or Wayland. Display different messages depending on the + window system to avoid referring users to the wrong GTK bug + report. */ +#ifdef HAVE_PGTK + fputs ("Due to a limitation in GTK 3, Emacs built with PGTK will simply exit when a\n" + "display connection is closed. The problem is especially difficult to fix,\n" + "such that Emacs on Wayland with multiple displays is unlikely ever to be able\n" + "to survive disconnects.\n", + stderr); +#elif defined USE_GTK fputs ("\nWarning: due to a long standing Gtk+ bug\nhttps://gitlab.gnome.org/GNOME/gtk/issues/221\n\ Emacs might crash when run in daemon mode and the X11 connection is unexpectedly lost.\n\ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem.\n", stderr); -#endif /* USE_GTK */ +#endif if (daemon_type == 2) { @@ -2036,6 +2070,16 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem no_site_lisp = 1; } + if (argmatch (argv, argc, "-x", 0, 1, &junk, &skip_args)) + { + noninteractive = 1; + no_site_lisp = 1; + /* This is picked up in startup.el. */ + argv[skip_args - 1] = (char *) "-scripteval"; + skip_args -= 1; + sort_args (argc, argv); + } + /* Don't actually discard this arg. */ skip_args = count_before; } @@ -2480,6 +2524,7 @@ static const struct standard_args standard_args[] = /* (Note that to imply -nsl, -Q is partially handled here.) */ { "-Q", "--quick", 55, 0 }, { "-quick", 0, 55, 0 }, + { "-x", 0, 55, 0 }, { "-q", "--no-init-file", 50, 0 }, { "-no-init-file", 0, 50, 0 }, { "-init-directory", "--init-directory", 30, 1 }, @@ -2730,24 +2775,47 @@ sort_args (int argc, char **argv) xfree (priority); } -DEFUN ("kill-emacs", Fkill_emacs, Skill_emacs, 0, 1, "P", +DEFUN ("kill-emacs", Fkill_emacs, Skill_emacs, 0, 2, "P", doc: /* Exit the Emacs job and kill it. If ARG is an integer, return ARG as the exit program code. If ARG is a string, stuff it as keyboard input. Any other value of ARG, or ARG omitted, means return an exit code that indicates successful program termination. +If RESTART is non-nil, instead of just exiting at the end, start a new +Emacs process, using the same command line arguments as the currently +running Emacs process. + This function is called upon receipt of the signals SIGTERM or SIGHUP, and upon SIGINT in batch mode. -The value of `kill-emacs-hook', if not void, -is a list of functions (of no args), -all of which are called before Emacs is actually killed. */ +The value of `kill-emacs-hook', if not void, is a list of functions +(of no args), all of which are called before Emacs is actually +killed. */ attributes: noreturn) - (Lisp_Object arg) + (Lisp_Object arg, Lisp_Object restart) { int exit_code; +#ifndef WINDOWSNT + /* Do some checking before shutting down Emacs, because errors + can't be meaningfully reported afterwards. */ + if (!NILP (restart)) + { + /* This is very unlikely, but it's possible to execute a binary + (on some systems) with no argv. */ + if (initial_argc < 1) + error ("No command line arguments known; unable to re-execute Emacs"); + + /* Check that the binary hasn't gone away. */ + if (!initial_emacs_executable) + error ("Unknown Emacs executable"); + + if (!file_access_p (initial_emacs_executable, F_OK)) + error ("Emacs executable \"%s\" can't be found", initial_argv[0]); + } +#endif + #ifdef HAVE_LIBSYSTEMD /* Notify systemd we are shutting down, but only if we have notified it about startup. */ @@ -2791,6 +2859,17 @@ all of which are called before Emacs is actually killed. */ eln_load_path_final_clean_up (); #endif + if (!NILP (restart)) + { +#ifdef WINDOWSNT + if (w32_reexec_emacs (initial_cmdline, initial_wd) < 0) +#else + initial_argv[0] = initial_emacs_executable; + if (execvp (*initial_argv, initial_argv) < 1) +#endif + emacs_perror ("Unable to re-execute Emacs"); + } + if (FIXNUMP (arg)) exit_code = (XFIXNUM (arg) < 0 ? XFIXNUM (arg) | INT_MIN @@ -2821,9 +2900,6 @@ shut_down_emacs (int sig, Lisp_Object stuff) /* Don't update display from now on. */ Vinhibit_redisplay = Qt; -#ifdef HAVE_HAIKU - be_app_quit (); -#endif /* If we are controlling the terminal, reset terminal modes. */ #ifndef DOS_NT pid_t tpgrp = tcgetpgrp (STDIN_FILENO); @@ -3084,6 +3160,9 @@ decode_env_path (const char *evarname, const char *defalt, bool empty) { const char *path, *p; Lisp_Object lpath, element, tem; +#ifdef NS_SELF_CONTAINED + void *autorelease = NULL; +#endif /* Default is to use "." for empty path elements. But if argument EMPTY is true, use nil instead. */ Lisp_Object empty_element = empty ? Qnil : build_string ("."); @@ -3111,6 +3190,8 @@ decode_env_path (const char *evarname, const char *defalt, bool empty) if (!path) { #ifdef NS_SELF_CONTAINED + /* ns_relocate needs a valid autorelease pool around it. */ + autorelease = ns_alloc_autorelease_pool (); path = ns_relocate (defalt); #else path = defalt; @@ -3213,6 +3294,11 @@ decode_env_path (const char *evarname, const char *defalt, bool empty) else break; } + +#ifdef NS_SELF_CONTAINED + if (autorelease) + ns_release_autorelease_pool (autorelease); +#endif return Fnreverse (lpath); } diff --git a/src/eval.c b/src/eval.c index ecf57efb92d..3ec03de1376 100644 --- a/src/eval.c +++ b/src/eval.c @@ -223,8 +223,8 @@ init_eval_once_for_pdumper (void) { enum { size = 50 }; union specbinding *pdlvec = malloc ((size + 1) * sizeof *specpdl); - specpdl_size = size; specpdl = specpdl_ptr = pdlvec + 1; + specpdl_end = specpdl + size; } void @@ -267,8 +267,6 @@ restore_stack_limits (Lisp_Object data) integer_to_intmax (XCDR (data), &max_lisp_eval_depth); } -static void grow_specpdl (void); - /* Call the Lisp debugger, giving it argument ARG. */ Lisp_Object @@ -561,6 +559,10 @@ usage: (function ARG) */) { /* Handle the special (:documentation
            ) to build the docstring dynamically. */ Lisp_Object docstring = eval_sub (Fcar (XCDR (tmp))); + if (SYMBOLP (docstring) && !NILP (docstring)) + /* Hack for OClosures: Allow the docstring to be a symbol + * (the OClosure's type). */ + docstring = Fsymbol_name (docstring); CHECK_STRING (docstring); cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr)))); } @@ -1235,6 +1237,7 @@ unwind_to_catch (struct handler *catch, enum nonlocal_exit type, eassert (handlerlist == catch); lisp_eval_depth = catch->f_lisp_eval_depth; + set_act_rec (current_thread, catch->act_rec); sys_longjmp (catch->jmp, 1); } @@ -1502,90 +1505,6 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), } } -/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3 as - its arguments. */ - -Lisp_Object -internal_condition_case_3 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, - Lisp_Object), - Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object handlers, - Lisp_Object (*hfun) (Lisp_Object)) -{ - struct handler *c = push_handler (handlers, CONDITION_CASE); - if (sys_setjmp (c->jmp)) - { - Lisp_Object val = handlerlist->val; - clobbered_eassert (handlerlist == c); - handlerlist = handlerlist->next; - return hfun (val); - } - else - { - Lisp_Object val = bfun (arg1, arg2, arg3); - eassert (handlerlist == c); - handlerlist = c->next; - return val; - } -} - -/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, ARG4 as - its arguments. */ - -Lisp_Object -internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, - Lisp_Object, Lisp_Object), - Lisp_Object arg1, Lisp_Object arg2, - Lisp_Object arg3, Lisp_Object arg4, - Lisp_Object handlers, - Lisp_Object (*hfun) (Lisp_Object)) -{ - struct handler *c = push_handler (handlers, CONDITION_CASE); - if (sys_setjmp (c->jmp)) - { - Lisp_Object val = handlerlist->val; - clobbered_eassert (handlerlist == c); - handlerlist = handlerlist->next; - return hfun (val); - } - else - { - Lisp_Object val = bfun (arg1, arg2, arg3, arg4); - eassert (handlerlist == c); - handlerlist = c->next; - return val; - } -} - -/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, - ARG4, ARG5 as its arguments. */ - -Lisp_Object -internal_condition_case_5 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, - Lisp_Object, Lisp_Object, - Lisp_Object), - Lisp_Object arg1, Lisp_Object arg2, - Lisp_Object arg3, Lisp_Object arg4, - Lisp_Object arg5, Lisp_Object handlers, - Lisp_Object (*hfun) (Lisp_Object)) -{ - struct handler *c = push_handler (handlers, CONDITION_CASE); - if (sys_setjmp (c->jmp)) - { - Lisp_Object val = handlerlist->val; - clobbered_eassert (handlerlist == c); - handlerlist = handlerlist->next; - return hfun (val); - } - else - { - Lisp_Object val = bfun (arg1, arg2, arg3, arg4, arg5); - eassert (handlerlist == c); - handlerlist = c->next; - return val; - } -} - /* Like internal_condition_case but call BFUN with NARGS as first, and ARGS as second argument. */ @@ -1675,6 +1594,7 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype) c->next = handlerlist; c->f_lisp_eval_depth = lisp_eval_depth; c->pdlcount = SPECPDL_INDEX (); + c->act_rec = get_act_rec (current_thread); c->poll_suppress_count = poll_suppress_count; c->interrupt_input_blocked = interrupt_input_blocked; handlerlist = c; @@ -1693,7 +1613,7 @@ process_quit_flag (void) Lisp_Object flag = Vquit_flag; Vquit_flag = Qnil; if (EQ (flag, Qkill_emacs)) - Fkill_emacs (Qnil); + Fkill_emacs (Qnil, Qnil); if (EQ (Vthrow_on_input, flag)) Fthrow (Vthrow_on_input, Qt); quit (); @@ -1773,7 +1693,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit) && ! NILP (error_symbol) /* Don't try to call a lisp function if we've already overflowed the specpdl stack. */ - && specpdl_ptr < specpdl + specpdl_size) + && specpdl_ptr < specpdl_end) { /* Edebug takes care of restoring these variables when it exits. */ max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 20); @@ -2125,8 +2045,7 @@ then strings and vectors are not accepted. */) (Lisp_Object function, Lisp_Object for_call_interactively) { register Lisp_Object fun; - register Lisp_Object funcar; - Lisp_Object if_prop = Qnil; + bool genfun = false; /* If true, we should consult `interactive-form'. */ fun = function; @@ -2134,6 +2053,70 @@ then strings and vectors are not accepted. */) if (NILP (fun)) return Qnil; + /* Emacs primitives are interactive if their DEFUN specifies an + interactive spec. */ + if (SUBRP (fun)) + { + if (XSUBR (fun)->intspec.string) + return Qt; + } + /* Bytecode objects are interactive if they are long enough to + have an element whose index is COMPILED_INTERACTIVE, which is + where the interactive spec is stored. */ + else if (COMPILEDP (fun)) + { + if (PVSIZE (fun) > COMPILED_INTERACTIVE) + return Qt; + else if (PVSIZE (fun) > COMPILED_DOC_STRING) + { + Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING); + /* An invalid "docstring" is a sign that we have an OClosure. */ + genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc)); + } + } + +#ifdef HAVE_MODULES + /* Module functions are interactive if their `interactive_form' + field is non-nil. */ + else if (MODULE_FUNCTIONP (fun)) + { + if (!NILP (module_function_interactive_form (XMODULE_FUNCTION (fun)))) + return Qt; + } +#endif + + /* Strings and vectors are keyboard macros. */ + else if (STRINGP (fun) || VECTORP (fun)) + return (NILP (for_call_interactively) ? Qt : Qnil); + + /* Lists may represent commands. */ + else if (!CONSP (fun)) + return Qnil; + else + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qautoload)) + { + if (!NILP (Fcar (Fcdr (Fcdr (XCDR (fun)))))) + return Qt; + } + else + { + Lisp_Object body = CDR_SAFE (XCDR (fun)); + if (EQ (funcar, Qclosure)) + body = CDR_SAFE (body); + else if (!EQ (funcar, Qlambda)) + return Qnil; + if (!NILP (Fassq (Qinteractive, body))) + return Qt; + else if (VALID_DOCSTRING_P (CAR_SAFE (body))) + /* A "docstring" is a sign that we may have an OClosure. */ + genfun = true; + } + } + + /* By now, if it's not a function we already returned nil. */ + /* Check an `interactive-form' property if present, analogous to the function-documentation property. */ fun = function; @@ -2141,45 +2124,18 @@ then strings and vectors are not accepted. */) { Lisp_Object tmp = Fget (fun, Qinteractive_form); if (!NILP (tmp)) - if_prop = Qt; + error ("Found an 'interactive-form' property!"); fun = Fsymbol_function (fun); } - /* Emacs primitives are interactive if their DEFUN specifies an - interactive spec. */ - if (SUBRP (fun)) - return XSUBR (fun)->intspec ? Qt : if_prop; - - /* Bytecode objects are interactive if they are long enough to - have an element whose index is COMPILED_INTERACTIVE, which is - where the interactive spec is stored. */ - else if (COMPILEDP (fun)) - return (PVSIZE (fun) > COMPILED_INTERACTIVE ? Qt : if_prop); - -#ifdef HAVE_MODULES - /* Module functions are interactive if their `interactive_form' - field is non-nil. */ - else if (MODULE_FUNCTIONP (fun)) - return NILP (module_function_interactive_form (XMODULE_FUNCTION (fun))) - ? if_prop - : Qt; -#endif - - /* Strings and vectors are keyboard macros. */ - if (STRINGP (fun) || VECTORP (fun)) - return (NILP (for_call_interactively) ? Qt : Qnil); - - /* Lists may represent commands. */ - if (!CONSP (fun)) - return Qnil; - funcar = XCAR (fun); - if (EQ (funcar, Qclosure)) - return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))))) - ? Qt : if_prop); - else if (EQ (funcar, Qlambda)) - return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop; - else if (EQ (funcar, Qautoload)) - return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop; + /* If there's no immediate interactive form but it's an OClosure, + then delegate to the generic-function in case it has + a type-specific interactive-form. */ + if (genfun) + { + Lisp_Object iform = call1 (Qinteractive_form, fun); + return NILP (iform) ? Qnil : Qt; + } else return Qnil; } @@ -2333,62 +2289,29 @@ alist mapping symbols to their value. */) return unbind_to (count, eval_sub (form)); } -static void +void grow_specpdl_allocation (void) { - eassert (specpdl_ptr == specpdl + specpdl_size); + eassert (specpdl_ptr == specpdl_end); specpdl_ref count = SPECPDL_INDEX (); ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX - 1000); union specbinding *pdlvec = specpdl - 1; - ptrdiff_t pdlvecsize = specpdl_size + 1; - if (max_size <= specpdl_size) + ptrdiff_t size = specpdl_end - specpdl; + ptrdiff_t pdlvecsize = size + 1; + if (max_size <= size) { if (max_specpdl_size < 400) max_size = max_specpdl_size = 400; - if (max_size <= specpdl_size) + if (max_size <= size) xsignal0 (Qexcessive_variable_binding); } pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl); specpdl = pdlvec + 1; - specpdl_size = pdlvecsize - 1; + specpdl_end = specpdl + pdlvecsize - 1; specpdl_ptr = specpdl_ref_to_ptr (count); } -/* Grow the specpdl stack by one entry. - The caller should have already initialized the entry. - Signal an error on stack overflow. - - Make sure that there is always one unused entry past the top of the - stack, so that the just-initialized entry is safely unwound if - memory exhausted and an error is signaled here. Also, allocate a - never-used entry just before the bottom of the stack; sometimes its - address is taken. */ - -INLINE void -grow_specpdl (void) -{ - specpdl_ptr++; - if (specpdl_ptr == specpdl + specpdl_size) - grow_specpdl_allocation (); -} - -specpdl_ref -record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) -{ - specpdl_ref count = SPECPDL_INDEX (); - - eassert (nargs >= UNEVALLED); - specpdl_ptr->bt.kind = SPECPDL_BACKTRACE; - specpdl_ptr->bt.debug_on_exit = false; - specpdl_ptr->bt.function = function; - current_thread->stack_top = specpdl_ptr->bt.args = args; - specpdl_ptr->bt.nargs = nargs; - grow_specpdl (); - - return count; -} - /* Eval a sub-expression of the current expression (i.e. in the same lexical scope). */ Lisp_Object @@ -2892,76 +2815,6 @@ apply1 (Lisp_Object fn, Lisp_Object arg) return NILP (arg) ? Ffuncall (1, &fn) : CALLN (Fapply, fn, arg); } -/* Call function fn on no arguments. */ -Lisp_Object -call0 (Lisp_Object fn) -{ - return Ffuncall (1, &fn); -} - -/* Call function fn with 1 argument arg1. */ -Lisp_Object -call1 (Lisp_Object fn, Lisp_Object arg1) -{ - return CALLN (Ffuncall, fn, arg1); -} - -/* Call function fn with 2 arguments arg1, arg2. */ -Lisp_Object -call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) -{ - return CALLN (Ffuncall, fn, arg1, arg2); -} - -/* Call function fn with 3 arguments arg1, arg2, arg3. */ -Lisp_Object -call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3); -} - -/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */ -Lisp_Object -call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4); -} - -/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */ -Lisp_Object -call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5); -} - -/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */ -Lisp_Object -call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6); -} - -/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */ -Lisp_Object -call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7); -} - -/* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5, - arg6, arg7, arg8. */ -Lisp_Object -call8 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7, - Lisp_Object arg8) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); -} - DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, doc: /* Return t if OBJECT is a function. */) (Lisp_Object object) @@ -3153,10 +3006,7 @@ fetch_and_exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, if (CONSP (AREF (fun, COMPILED_BYTECODE))) Ffetch_bytecode (fun); - return exec_byte_code (AREF (fun, COMPILED_BYTECODE), - AREF (fun, COMPILED_CONSTANTS), - AREF (fun, COMPILED_STACK_DEPTH), - args_template, nargs, args); + return exec_byte_code (fun, args_template, nargs, args); } static Lisp_Object @@ -3625,6 +3475,20 @@ record_unwind_protect_ptr (void (*function) (void *), void *arg) specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR; specpdl_ptr->unwind_ptr.func = function; specpdl_ptr->unwind_ptr.arg = arg; + specpdl_ptr->unwind_ptr.mark = NULL; + grow_specpdl (); +} + +/* Like `record_unwind_protect_ptr', but also specifies a function + for GC-marking Lisp objects only reachable through ARG. */ +void +record_unwind_protect_ptr_mark (void (*function) (void *), void *arg, + void (*mark) (void *)) +{ + specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR; + specpdl_ptr->unwind_ptr.func = function; + specpdl_ptr->unwind_ptr.arg = arg; + specpdl_ptr->unwind_ptr.mark = mark; grow_specpdl (); } @@ -3668,6 +3532,7 @@ record_unwind_protect_module (enum specbind_tag kind, void *ptr) specpdl_ptr->kind = kind; specpdl_ptr->unwind_ptr.func = NULL; specpdl_ptr->unwind_ptr.arg = ptr; + specpdl_ptr->unwind_ptr.mark = NULL; grow_specpdl (); } @@ -3796,6 +3661,7 @@ set_unwind_protect_ptr (specpdl_ref count, void (*func) (void *), void *arg) p->unwind_ptr.kind = SPECPDL_UNWIND_PTR; p->unwind_ptr.func = func; p->unwind_ptr.arg = arg; + p->unwind_ptr.mark = NULL; } /* Pop and execute entries from the unwind-protect stack until the @@ -4229,6 +4095,10 @@ mark_specpdl (union specbinding *first, union specbinding *ptr) break; case SPECPDL_UNWIND_PTR: + if (pdl->unwind_ptr.mark) + pdl->unwind_ptr.mark (pdl->unwind_ptr.arg); + break; + case SPECPDL_UNWIND_INT: case SPECPDL_UNWIND_INTMAX: case SPECPDL_UNWIND_VOID: diff --git a/src/fileio.c b/src/fileio.c index 243a87a4821..c418036fc6e 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -2505,6 +2505,8 @@ With a prefix argument, TRASH is nil. */) return Qnil; } +#if defined HAVE_NATIVE_COMP && defined WINDOWSNT + static Lisp_Object internal_delete_file_1 (Lisp_Object ignore) { @@ -2523,6 +2525,8 @@ internal_delete_file (Lisp_Object filename) Qt, internal_delete_file_1); return NILP (tem); } + +#endif /* Return -1 if FILE is a case-insensitive file name, 0 if not, and a positive errno value if the result cannot be determined. */ @@ -5519,7 +5523,10 @@ DEFUN ("car-less-than-car", Fcar_less_than_car, Scar_less_than_car, 2, 2, 0, doc: /* Return t if (car A) is numerically less than (car B). */) (Lisp_Object a, Lisp_Object b) { - return arithcompare (Fcar (a), Fcar (b), ARITH_LESS); + Lisp_Object ca = Fcar (a), cb = Fcar (b); + if (FIXNUMP (ca) && FIXNUMP (cb)) + return XFIXNUM (ca) < XFIXNUM (cb) ? Qt : Qnil; + return arithcompare (ca, cb, ARITH_LESS); } /* Build the complete list of annotations appropriate for writing out @@ -5973,7 +5980,8 @@ A non-nil CURRENT-ONLY argument means save only current buffer. */) bool old_message_p = 0; struct auto_save_unwind auto_save_unwind; - intmax_t sum = INT_ADD_WRAPV (specpdl_size, 40, &sum) ? INTMAX_MAX : sum; + intmax_t sum = INT_ADD_WRAPV (specpdl_end - specpdl, 40, &sum) + ? INTMAX_MAX : sum; if (max_specpdl_size < sum) max_specpdl_size = sum; diff --git a/src/filelock.c b/src/filelock.c index 4fdad8d8560..a657cc4582c 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -413,14 +413,20 @@ create_lock_file (char *lfname, char *lock_info_str, bool force) Return 0 if successful, an error number on failure. */ static int -lock_file_1 (char *lfname, bool force) +lock_file_1 (Lisp_Object lfname, bool force) { - /* Call this first because it can GC. */ intmax_t boot = get_boot_time (); - Lisp_Object luser_name = Fuser_login_name (Qnil); - char const *user_name = STRINGP (luser_name) ? SSDATA (luser_name) : ""; Lisp_Object lhost_name = Fsystem_name (); + + /* Protect against the extremely unlikely case of the host name + containing an @ character. */ + if (!NILP (lhost_name) && strchr (SSDATA (lhost_name), '@')) + lhost_name = CALLN (Ffuncall, intern ("string-replace"), + build_string ("@"), build_string ("-"), + lhost_name); + + char const *user_name = STRINGP (luser_name) ? SSDATA (luser_name) : ""; char const *host_name = STRINGP (lhost_name) ? SSDATA (lhost_name) : ""; char lock_info_str[MAX_LFINFO + 1]; intmax_t pid = getpid (); @@ -439,7 +445,7 @@ lock_file_1 (char *lfname, bool force) user_name, host_name, pid)) return ENAMETOOLONG; - return create_lock_file (lfname, lock_info_str, force); + return create_lock_file (SSDATA (lfname), lock_info_str, force); } /* Return true if times A and B are no more than one second apart. */ @@ -511,7 +517,7 @@ enum or an errno value if something is wrong with the locking mechanism. */ static int -current_lock_owner (lock_info_type *owner, char *lfname) +current_lock_owner (lock_info_type *owner, Lisp_Object lfname) { lock_info_type local_owner; ptrdiff_t lfinfolen; @@ -524,7 +530,7 @@ current_lock_owner (lock_info_type *owner, char *lfname) owner = &local_owner; /* If nonexistent lock file, all is well; otherwise, got strange error. */ - lfinfolen = read_lock_data (lfname, owner->user); + lfinfolen = read_lock_data (SSDATA (lfname), owner->user); if (lfinfolen < 0) return errno == ENOENT || errno == ENOTDIR ? 0 : errno; if (MAX_LFINFO < lfinfolen) @@ -584,6 +590,12 @@ current_lock_owner (lock_info_type *owner, char *lfname) .#test.txt -> larsi@.118961:1646577954) is an empty string. */ if (NILP (system_name)) system_name = build_string (""); + /* Protect against the extremely unlikely case of the host name + containing an @ character. */ + else if (strchr (SSDATA (system_name), '@')) + system_name = CALLN (Ffuncall, intern ("string-replace"), + build_string ("@"), build_string ("-"), + system_name); /* On current host? */ if (STRINGP (system_name) && dot - (at + 1) == SBYTES (system_name) @@ -600,7 +612,7 @@ current_lock_owner (lock_info_type *owner, char *lfname) /* The owner process is dead or has a strange pid, so try to zap the lockfile. */ else - return unlink (lfname) < 0 ? errno : 0; + return unlink (SSDATA (lfname)) < 0 ? errno : 0; } else { /* If we wanted to support the check for stale locks on remote machines, @@ -617,7 +629,7 @@ current_lock_owner (lock_info_type *owner, char *lfname) Return errno value if cannot lock for any other reason. */ static int -lock_if_free (lock_info_type *clasher, char *lfname) +lock_if_free (lock_info_type *clasher, Lisp_Object lfname) { int err; while ((err = lock_file_1 (lfname, 0)) == EEXIST) @@ -636,10 +648,14 @@ lock_if_free (lock_info_type *clasher, char *lfname) return err; } +/* Return the encoded name of the lock file for FN, or nil if none. */ + static Lisp_Object make_lock_file_name (Lisp_Object fn) { - return call1 (Qmake_lock_file_name, Fexpand_file_name (fn, Qnil)); + Lisp_Object lock_file_name = call1 (Qmake_lock_file_name, + Fexpand_file_name (fn, Qnil)); + return !NILP (lock_file_name) ? ENCODE_FILE (lock_file_name) : Qnil; } /* lock_file locks file FN, @@ -663,7 +679,6 @@ make_lock_file_name (Lisp_Object fn) static Lisp_Object lock_file (Lisp_Object fn) { - char *lfname = NULL; lock_info_type lock_info; /* Don't do locking while dumping Emacs. @@ -672,13 +687,13 @@ lock_file (Lisp_Object fn) if (will_dump_p ()) return Qnil; + Lisp_Object lfname = Qnil; if (create_lockfiles) { /* Create the name of the lock-file for file fn */ - Lisp_Object lock_filename = make_lock_file_name (fn); - if (NILP (lock_filename)) + lfname = make_lock_file_name (fn); + if (NILP (lfname)) return Qnil; - lfname = SSDATA (ENCODE_FILE (lock_filename)); } /* See if this file is visited and has changed on disk since it was @@ -687,14 +702,14 @@ lock_file (Lisp_Object fn) if (!NILP (subject_buf) && NILP (Fverify_visited_file_modtime (subject_buf)) && !NILP (Ffile_exists_p (fn)) - && !(lfname && (current_lock_owner (NULL, lfname) == I_OWN_IT))) + && !(!NILP (lfname) && current_lock_owner (NULL, lfname) == I_OWN_IT)) call1 (intern ("userlock--ask-user-about-supersession-threat"), fn); /* Don't do locking if the user has opted out. */ - if (lfname) + if (!NILP (lfname)) { /* Try to lock the lock. FIXME: This ignores errors when - lock_if_free returns a positive errno value. */ + lock_if_free returns an errno value. */ if (lock_if_free (&lock_info, lfname) == ANOTHER_OWNS_IT) { /* Someone else has the lock. Consider breaking it. */ @@ -719,17 +734,14 @@ lock_file (Lisp_Object fn) static Lisp_Object unlock_file (Lisp_Object fn) { - char *lfname; - - Lisp_Object lock_filename = make_lock_file_name (fn); - if (NILP (lock_filename)) + Lisp_Object lfname = make_lock_file_name (fn); + if (NILP (lfname)) return Qnil; - lfname = SSDATA (ENCODE_FILE (lock_filename)); int err = current_lock_owner (0, lfname); if (! (err == 0 || err == ANOTHER_OWNS_IT || (err == I_OWN_IT - && (unlink (lfname) == 0 || (err = errno) == ENOENT)))) + && (unlink (SSDATA (lfname)) == 0 || (err = errno) == ENOENT)))) report_file_errno ("Unlocking file", fn, err); return Qnil; @@ -871,10 +883,9 @@ t if it is locked by you, else a string saying which user has locked it. */) return call2 (handler, Qfile_locked_p, filename); } - Lisp_Object lock_filename = make_lock_file_name (filename); - if (NILP (lock_filename)) + Lisp_Object lfname = make_lock_file_name (filename); + if (NILP (lfname)) return Qnil; - char *lfname = SSDATA (ENCODE_FILE (lock_filename)); owner = current_lock_owner (&locker, lfname); switch (owner) @@ -900,8 +911,8 @@ syms_of_filelock (void) DEFVAR_BOOL ("create-lockfiles", create_lockfiles, doc: /* Non-nil means use lockfiles to avoid editing collisions. -The name of the (per-buffer) lockfile is constructed by prepending a -'.#' to the name of the file being locked. See also `lock-buffer' and +The name of the (per-buffer) lockfile is constructed by prepending +".#" to the name of the file being locked. See also `lock-buffer' and Info node `(emacs)Interlocking'. */); create_lockfiles = true; diff --git a/src/fns.c b/src/fns.c index 06a64563806..4673fde28c7 100644 --- a/src/fns.c +++ b/src/fns.c @@ -39,9 +39,6 @@ along with GNU Emacs. If not, see . */ #include "puresize.h" #include "gnutls.h" -static void sort_vector_copy (Lisp_Object pred, ptrdiff_t len, - Lisp_Object src[restrict VLA_ELEMS (len)], - Lisp_Object dest[restrict VLA_ELEMS (len)]); enum equal_kind { EQUAL_NO_QUIT, EQUAL_PLAIN, EQUAL_INCLUDING_PROPERTIES }; static bool internal_equal (Lisp_Object, Lisp_Object, enum equal_kind, int, Lisp_Object); @@ -55,49 +52,24 @@ DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, return argument; } +/* Return a random Lisp fixnum I in the range 0 <= I < LIM, + where LIM is taken from a positive fixnum. */ static Lisp_Object -ccall2 (Lisp_Object (f) (ptrdiff_t nargs, Lisp_Object *args), - Lisp_Object arg1, Lisp_Object arg2) +get_random_fixnum (EMACS_INT lim) { - Lisp_Object args[2] = {arg1, arg2}; - return f (2, args); -} - -static Lisp_Object -get_random_bignum (Lisp_Object limit) -{ - /* This is a naive transcription into bignums of the fixnum algorithm. - I'd be quite surprised if that's anywhere near the best algorithm - for it. */ - while (true) + /* Return the remainder of a random integer R (in range 0..INTMASK) + divided by LIM, except reject the rare case where R is so close + to INTMASK that the remainder isn't random. */ + EMACS_INT difflim = INTMASK - lim + 1, diff, remainder; + do { - Lisp_Object val = make_fixnum (0); - Lisp_Object lim = limit; - int bits = 0; - int bitsperiteration = FIXNUM_BITS - 1; - do - { - /* Shift by one so it is a valid positive fixnum. */ - EMACS_INT rand = get_random () >> 1; - Lisp_Object lrand = make_fixnum (rand); - bits += bitsperiteration; - val = ccall2 (Flogior, - Fash (val, make_fixnum (bitsperiteration)), - lrand); - lim = Fash (lim, make_fixnum (- bitsperiteration)); - } - while (!EQ (lim, make_fixnum (0))); - /* Return the remainder, except reject the rare case where - get_random returns a number so close to INTMASK that the - remainder isn't random. */ - Lisp_Object remainder = Frem (val, limit); - if (!NILP (ccall2 (Fleq, - ccall2 (Fminus, val, remainder), - ccall2 (Fminus, - Fash (make_fixnum (1), make_fixnum (bits)), - limit)))) - return remainder; + EMACS_INT r = get_random (); + remainder = r % lim; + diff = r - remainder; } + while (difflim < diff); + + return make_fixnum (remainder); } DEFUN ("random", Frandom, Srandom, 0, 1, 0, @@ -111,32 +83,26 @@ With a string argument, set the seed based on the string's contents. See Info node `(elisp)Random Numbers' for more details. */) (Lisp_Object limit) { - EMACS_INT val; - if (EQ (limit, Qt)) init_random (); else if (STRINGP (limit)) seed_random (SSDATA (limit), SBYTES (limit)); - if (BIGNUMP (limit)) + else if (FIXNUMP (limit)) { - if (0 > mpz_sgn (*xbignum_val (limit))) - xsignal2 (Qwrong_type_argument, Qnatnump, limit); - return get_random_bignum (limit); + EMACS_INT lim = XFIXNUM (limit); + if (lim <= 0) + xsignal1 (Qargs_out_of_range, limit); + return get_random_fixnum (lim); + } + else if (BIGNUMP (limit)) + { + struct Lisp_Bignum *lim = XBIGNUM (limit); + if (mpz_sgn (*bignum_val (lim)) <= 0) + xsignal1 (Qargs_out_of_range, limit); + return get_random_bignum (lim); } - val = get_random (); - if (FIXNUMP (limit) && 0 < XFIXNUM (limit)) - while (true) - { - /* Return the remainder, except reject the rare case where - get_random returns a number so close to INTMASK that the - remainder isn't random. */ - EMACS_INT remainder = val % XFIXNUM (limit); - if (val - remainder <= INTMASK - XFIXNUM (limit) + 1) - return make_fixnum (remainder); - val = get_random (); - } - return make_ufixnum (val); + return make_ufixnum (get_random ()); } /* Random data-structure functions. */ @@ -475,15 +441,24 @@ Symbols are also allowed; their print names are used instead. */) { if (SYMBOLP (string1)) string1 = SYMBOL_NAME (string1); + else + CHECK_STRING (string1); if (SYMBOLP (string2)) string2 = SYMBOL_NAME (string2); - CHECK_STRING (string1); - CHECK_STRING (string2); + else + CHECK_STRING (string2); + + ptrdiff_t n = min (SCHARS (string1), SCHARS (string2)); + if (!STRING_MULTIBYTE (string1) && !STRING_MULTIBYTE (string2)) + { + /* Both arguments are unibyte (hot path). */ + int d = memcmp (SSDATA (string1), SSDATA (string2), n); + return d < 0 || (d == 0 && n < SCHARS (string2)) ? Qt : Qnil; + } ptrdiff_t i1 = 0, i1_byte = 0, i2 = 0, i2_byte = 0; - ptrdiff_t end = min (SCHARS (string1), SCHARS (string2)); - while (i1 < end) + while (i1 < n) { /* When we find a mismatch, we must compare the characters, not just the bytes. */ @@ -516,37 +491,9 @@ Symbols are also allowed; their print names are used instead. */) string2 = SYMBOL_NAME (string2); CHECK_STRING (string1); CHECK_STRING (string2); - return string_version_cmp (string1, string2) < 0 ? Qt : Qnil; -} - -/* Return negative, 0, positive if STRING1 is <, =, > STRING2 as per - string-version-lessp. */ -int -string_version_cmp (Lisp_Object string1, Lisp_Object string2) -{ - char *p1 = SSDATA (string1); - char *p2 = SSDATA (string2); - char *lim1 = p1 + SBYTES (string1); - char *lim2 = p2 + SBYTES (string2); - int cmp; - - while ((cmp = filevercmp (p1, p2)) == 0) - { - /* If the strings are identical through their first null bytes, - skip past identical prefixes and try again. */ - ptrdiff_t size = strlen (p1) + 1; - eassert (size == strlen (p2) + 1); - p1 += size; - p2 += size; - bool more1 = p1 <= lim1; - bool more2 = p2 <= lim2; - if (!more1) - return more2; - if (!more2) - return -1; - } - - return cmp; + int cmp = filenvercmp (SSDATA (string1), SBYTES (string1), + SSDATA (string2), SBYTES (string2)); + return cmp < 0 ? Qt : Qnil; } DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0, @@ -2166,8 +2113,11 @@ See also the function `nreverse', which is used more often. */) return new; } -/* Sort LIST using PREDICATE, preserving original order of elements - considered as equal. */ + +/* Stably sort LIST ordered by PREDICATE using the TIMSORT + algorithm. This converts the list to a vector, sorts the vector, + and returns the result converted back to a list. The input list is + destructively reused to hold the sorted result. */ static Lisp_Object sort_list (Lisp_Object list, Lisp_Object predicate) @@ -2175,112 +2125,43 @@ sort_list (Lisp_Object list, Lisp_Object predicate) ptrdiff_t length = list_length (list); if (length < 2) return list; - - Lisp_Object tem = Fnthcdr (make_fixnum (length / 2 - 1), list); - Lisp_Object back = Fcdr (tem); - Fsetcdr (tem, Qnil); - - return merge (Fsort (list, predicate), Fsort (back, predicate), predicate); -} - -/* Using PRED to compare, return whether A and B are in order. - Compare stably when A appeared before B in the input. */ -static bool -inorder (Lisp_Object pred, Lisp_Object a, Lisp_Object b) -{ - return NILP (call2 (pred, b, a)); -} - -/* Using PRED to compare, merge from ALEN-length A and BLEN-length B - into DEST. Argument arrays must be nonempty and must not overlap, - except that B might be the last part of DEST. */ -static void -merge_vectors (Lisp_Object pred, - ptrdiff_t alen, Lisp_Object const a[restrict VLA_ELEMS (alen)], - ptrdiff_t blen, Lisp_Object const b[VLA_ELEMS (blen)], - Lisp_Object dest[VLA_ELEMS (alen + blen)]) -{ - eassume (0 < alen && 0 < blen); - Lisp_Object const *alim = a + alen; - Lisp_Object const *blim = b + blen; - - while (true) - { - if (inorder (pred, a[0], b[0])) - { - *dest++ = *a++; - if (a == alim) - { - if (dest != b) - memcpy (dest, b, (blim - b) * sizeof *dest); - return; - } - } - else - { - *dest++ = *b++; - if (b == blim) - { - memcpy (dest, a, (alim - a) * sizeof *dest); - return; - } - } - } -} - -/* Using PRED to compare, sort LEN-length VEC in place, using TMP for - temporary storage. LEN must be at least 2. */ -static void -sort_vector_inplace (Lisp_Object pred, ptrdiff_t len, - Lisp_Object vec[restrict VLA_ELEMS (len)], - Lisp_Object tmp[restrict VLA_ELEMS (len >> 1)]) -{ - eassume (2 <= len); - ptrdiff_t halflen = len >> 1; - sort_vector_copy (pred, halflen, vec, tmp); - if (1 < len - halflen) - sort_vector_inplace (pred, len - halflen, vec + halflen, vec); - merge_vectors (pred, halflen, tmp, len - halflen, vec + halflen, vec); -} - -/* Using PRED to compare, sort from LEN-length SRC into DST. - Len must be positive. */ -static void -sort_vector_copy (Lisp_Object pred, ptrdiff_t len, - Lisp_Object src[restrict VLA_ELEMS (len)], - Lisp_Object dest[restrict VLA_ELEMS (len)]) -{ - eassume (0 < len); - ptrdiff_t halflen = len >> 1; - if (halflen < 1) - dest[0] = src[0]; else { - if (1 < halflen) - sort_vector_inplace (pred, halflen, src, dest); - if (1 < len - halflen) - sort_vector_inplace (pred, len - halflen, src + halflen, dest); - merge_vectors (pred, halflen, src, len - halflen, src + halflen, dest); + Lisp_Object *result; + USE_SAFE_ALLOCA; + SAFE_ALLOCA_LISP (result, length); + Lisp_Object tail = list; + for (ptrdiff_t i = 0; i < length; i++) + { + result[i] = Fcar (tail); + tail = XCDR (tail); + } + tim_sort (predicate, result, length); + + ptrdiff_t i = 0; + tail = list; + while (CONSP (tail)) + { + XSETCAR (tail, result[i]); + tail = XCDR (tail); + i++; + } + SAFE_FREE (); + return list; } } -/* Sort VECTOR in place using PREDICATE, preserving original order of - elements considered as equal. */ +/* Stably sort VECTOR ordered by PREDICATE using the TIMSORT + algorithm. */ static void sort_vector (Lisp_Object vector, Lisp_Object predicate) { - ptrdiff_t len = ASIZE (vector); - if (len < 2) + ptrdiff_t length = ASIZE (vector); + if (length < 2) return; - ptrdiff_t halflen = len >> 1; - Lisp_Object *tmp; - USE_SAFE_ALLOCA; - SAFE_ALLOCA_LISP (tmp, halflen); - for (ptrdiff_t i = 0; i < halflen; i++) - tmp[i] = make_fixnum (0); - sort_vector_inplace (predicate, len, XVECTOR (vector)->contents, tmp); - SAFE_FREE (); + + tim_sort (predicate, XVECTOR (vector)->contents, length); } DEFUN ("sort", Fsort, Ssort, 2, 2, 0, @@ -2326,7 +2207,7 @@ merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred) } Lisp_Object tem; - if (inorder (pred, Fcar (l1), Fcar (l2))) + if (!NILP (call2 (pred, Fcar (l1), Fcar (l2)))) { tem = l1; l1 = Fcdr (l1); @@ -3034,6 +2915,9 @@ it does up to one space will be removed. The user must confirm the answer with RET, and can edit it until it has been confirmed. +If the `use-short-answers' variable is non-nil, instead of asking for +\"yes\" or \"no\", this function will ask for \"y\" or \"n\". + If dialog boxes are supported, a dialog box will be used if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */) (Lisp_Object prompt) @@ -4273,7 +4157,7 @@ hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h) /* Ignore HT and return a hash code for KEY which uses 'equal' to compare keys. The hash code is at most INTMASK. */ -Lisp_Object +static Lisp_Object hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h) { return make_ufixnum (sxhash (key)); @@ -4282,7 +4166,7 @@ hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h) /* Ignore HT and return a hash code for KEY which uses 'eql' to compare keys. The hash code is at most INTMASK. */ -Lisp_Object +static Lisp_Object hashfn_eql (Lisp_Object key, struct Lisp_Hash_Table *h) { return (FLOATP (key) || BIGNUMP (key) ? hashfn_equal : hashfn_eq) (key, h); diff --git a/src/font.c b/src/font.c index 7e0219181c9..6297452d3e0 100644 --- a/src/font.c +++ b/src/font.c @@ -4237,26 +4237,33 @@ merge_font_spec (Lisp_Object from, Lisp_Object to) DEFUN ("font-get", Ffont_get, Sfont_get, 2, 2, 0, doc: /* Return the value of FONT's property KEY. FONT is a font-spec, a font-entity, or a font-object. -KEY is any symbol, but these are reserved for specific meanings: - :family, :weight, :slant, :width, :foundry, :adstyle, :registry, - :size, :name, :script, :otf +KEY can be any symbol, but these are reserved for specific meanings: + :foundry, :family, :adstyle, :registry, :weight, :slant, :width, + :size, :dpi, :spacing, :avgwidth, :script, :lang, :otf See the documentation of `font-spec' for their meanings. -In addition, if FONT is a font-entity or a font-object, values of -:script and :otf are different from those of a font-spec as below: -The value of :script may be a list of scripts that are supported by the font. +If FONT is a font-entity or a font-object, then values of +:script and :otf properties are different from those of a font-spec +as below: -The value of :otf is a cons (GSUB . GPOS) where GSUB and GPOS are lists -representing the OpenType features supported by the font by this form: - ((SCRIPT (LANGSYS FEATURE ...) ...) ...) -SCRIPT, LANGSYS, and FEATURE are all symbols representing OpenType -Layout tags. + The value of :script may be a list of scripts that are supported by + the font. + + The value of :otf is a cons (GSUB . GPOS) where GSUB and GPOS are + lists representing the OpenType features supported by the font, of + this form: ((SCRIPT (LANGSYS FEATURE ...) ...) ...), where + SCRIPT, LANGSYS, and FEATURE are all symbols representing OpenType + Layout tags. See `otf-script-alist' for the OpenType script tags. In addition to the keys listed above, the following keys are reserved for the specific meanings as below: -The value of :combining-capability is non-nil if the font-backend of -FONT supports rendering of combining characters for non-OTF fonts. */) + The value of :type is a symbol that identifies the font backend to be + used, such as `ftcrhb' or `xfthb' on X , `harfbuzz' or `uniscribe' on + MS-Windows, `ns' on Cocoa/GNUstep, etc. + + The value of :combining-capability is non-nil if the font-backend of + FONT supports rendering of combining characters for non-OTF fonts. */) (Lisp_Object font, Lisp_Object key) { int idx; @@ -4384,7 +4391,9 @@ accepted by the function `font-spec' (which see), VAL must be what allowed in `font-spec'. If FONT is a font-entity or a font-object, KEY must not be the one -accepted by `font-spec'. */) +accepted by `font-spec'. + +See also `font-get' for KEYs that have special meanings. */) (Lisp_Object font, Lisp_Object prop, Lisp_Object val) { int idx; diff --git a/src/font.h b/src/font.h index 424616a4a1e..06bd297ccb2 100644 --- a/src/font.h +++ b/src/font.h @@ -155,8 +155,9 @@ enum font_property_index /* In a font-spec, the value is an alist of extra information of a font such as name, OpenType features, and language coverage. In addition, in a font-entity, the value may contain a pair - (font-entity . INFO) where INFO is extra information to identify - a font (font-driver dependent). */ + (font-entity . INFO) where INFO is extra information to + identify a font (font-driver dependent). In a font-entity, + this holds font driver-specific information. */ FONT_EXTRA_INDEX, /* alist alist */ /* This value is the length of font-spec vector. */ diff --git a/src/fontset.c b/src/fontset.c index eb563a69e2b..1793715450e 100644 --- a/src/fontset.c +++ b/src/fontset.c @@ -1450,28 +1450,30 @@ static void update_auto_fontset_alist (Lisp_Object, Lisp_Object); DEFUN ("set-fontset-font", Fset_fontset_font, Sset_fontset_font, 3, 5, 0, doc: /* -Modify fontset NAME to use FONT-SPEC for TARGET characters. +Modify FONTSET to use font specification in FONT-SPEC for displaying CHARACTERS. -NAME is a fontset name (a string), nil for the fontset of FRAME, -or t for the default fontset. +FONTSET should be a fontset name (a string); or nil, meaning the +fontset of FRAME; or t, meaning the default fontset. -TARGET may be a single character to use FONT-SPEC for. +CHARACTERS may be a single character to use FONT-SPEC for. -TARGET may be a cons (FROM . TO), where FROM and TO are characters. +CHARACTERS may be a cons (FROM . TO), where FROM and TO are characters. In that case, use FONT-SPEC for all the characters in the range between FROM and TO (inclusive). -TARGET may be a script symbol. In that case, use FONT-SPEC for +CHARACTERS may be a script symbol. In that case, use FONT-SPEC for all the characters that belong to the script. See the variable -`script-representative-chars' for the list of known scripts. +`script-representative-chars' for the list of known scripts, and +see the variable `char-script-table' for the script of any specific +character. -TARGET may be a charset. In that case, use FONT-SPEC for all -the characters in the charset. See `list-character-sets' and +CHARACTERS may be a charset symbol. In that case, use FONT-SPEC for +all the characters in the charset. See `list-character-sets' and `list-charset-chars' for the list of character sets and their characters. -TARGET may be nil. In that case, use FONT-SPEC for any character for -which no font-spec is specified. +CHARACTERS may be nil. In that case, use FONT-SPEC for any +character for which no font-spec is specified in FONTSET. FONT-SPEC may one of these: * A font-spec object made by the function `font-spec' (which see). @@ -1479,25 +1481,28 @@ FONT-SPEC may one of these: REGISTRY is a font registry name. FAMILY may contain foundry name, and REGISTRY may contain encoding name. * A font name string. - * nil, which explicitly specifies that there's no font for TARGET. + * nil, which explicitly specifies that there's no font for CHARACTERS. -Optional 4th argument FRAME is a frame, or nil for the selected frame, -to be considered in the case that NAME is nil. +Optional 4th argument FRAME is a frame whose fontset should be modified; +it is used if FONTSET is nil. If FONTSET is nil and FRAME is omitted +or nil, that stands for the fontset of the selected frame. Optional 5th argument ADD, if non-nil, specifies how to add FONT-SPEC -to the previously set font specifications for TARGET. If it is -`prepend', FONT-SPEC is prepended. If it is `append', FONT-SPEC is -appended. By default, FONT-SPEC overrides the previous settings. */) - (Lisp_Object name, Lisp_Object target, Lisp_Object font_spec, Lisp_Object frame, Lisp_Object add) +to the previously set font specifications for CHARACTERS. If it is +`prepend', FONT-SPEC is prepended to the existing font specifications. +If it is `append', FONT-SPEC is appended. By default, FONT-SPEC +overwrites the previous settings. */) + (Lisp_Object fontset, Lisp_Object characters, Lisp_Object font_spec, + Lisp_Object frame, Lisp_Object add) { - Lisp_Object fontset; + Lisp_Object fontset_obj; Lisp_Object font_def, registry, family; Lisp_Object range_list; struct charset *charset = NULL; Lisp_Object fontname; bool ascii_changed = 0; - fontset = check_fontset_name (name, &frame); + fontset_obj = check_fontset_name (fontset, &frame); fontname = Qnil; if (CONSP (font_spec)) @@ -1555,18 +1560,18 @@ appended. By default, FONT-SPEC overrides the previous settings. */) else font_def = Qnil; - if (CHARACTERP (target)) + if (CHARACTERP (characters)) { - if (XFIXNAT (target) < 0x80) + if (XFIXNAT (characters) < 0x80) error ("Can't set a font for partial ASCII range"); - range_list = list1 (Fcons (target, target)); + range_list = list1 (Fcons (characters, characters)); } - else if (CONSP (target)) + else if (CONSP (characters)) { Lisp_Object from, to; - from = Fcar (target); - to = Fcdr (target); + from = Fcar (characters); + to = Fcdr (characters); CHECK_CHARACTER (from); CHECK_CHARACTER (to); if (XFIXNAT (from) < 0x80) @@ -1575,38 +1580,38 @@ appended. By default, FONT-SPEC overrides the previous settings. */) error ("Can't set a font for partial ASCII range"); ascii_changed = 1; } - range_list = list1 (target); + range_list = list1 (characters); } - else if (SYMBOLP (target) && !NILP (target)) + else if (SYMBOLP (characters) && !NILP (characters)) { Lisp_Object script_list; Lisp_Object val; range_list = Qnil; script_list = XCHAR_TABLE (Vchar_script_table)->extras[0]; - if (! NILP (Fmemq (target, script_list))) + if (! NILP (Fmemq (characters, script_list))) { - if (EQ (target, Qlatin)) + if (EQ (characters, Qlatin)) ascii_changed = 1; - val = list1 (target); + val = list1 (characters); map_char_table (accumulate_script_ranges, Qnil, Vchar_script_table, val); range_list = Fnreverse (XCDR (val)); } - if (CHARSETP (target)) + if (CHARSETP (characters)) { - CHECK_CHARSET_GET_CHARSET (target, charset); + CHECK_CHARSET_GET_CHARSET (characters, charset); if (charset->ascii_compatible_p) ascii_changed = 1; } else if (NILP (range_list)) error ("Invalid script or charset name: %s", - SDATA (SYMBOL_NAME (target))); + SDATA (SYMBOL_NAME (characters))); } - else if (NILP (target)) + else if (NILP (characters)) range_list = list1 (Qnil); else - error ("Invalid target for setting a font"); + error ("Invalid second argument for setting a font in a fontset"); if (ascii_changed) { @@ -1614,7 +1619,7 @@ appended. By default, FONT-SPEC overrides the previous settings. */) if (NILP (font_spec)) error ("Can't set ASCII font to nil"); - val = CHAR_TABLE_REF (fontset, 0); + val = CHAR_TABLE_REF (fontset_obj, 0); if (! NILP (val) && EQ (add, Qappend)) /* We are going to change just an additional font for ASCII. */ ascii_changed = 0; @@ -1622,7 +1627,7 @@ appended. By default, FONT-SPEC overrides the previous settings. */) if (charset) { - Lisp_Object arg = CALLN (Fvector, fontset, font_def, add, + Lisp_Object arg = CALLN (Fvector, fontset_obj, font_def, add, ascii_changed ? Qt : Qnil, range_list); map_charset_chars (set_fontset_font, Qnil, arg, charset, @@ -1631,15 +1636,15 @@ appended. By default, FONT-SPEC overrides the previous settings. */) range_list = AREF (arg, 4); } for (; CONSP (range_list); range_list = XCDR (range_list)) - FONTSET_ADD (fontset, XCAR (range_list), font_def, add); + FONTSET_ADD (fontset_obj, XCAR (range_list), font_def, add); if (ascii_changed) { Lisp_Object tail, fr; - int fontset_id = XFIXNUM (FONTSET_ID (fontset)); + int fontset_id = XFIXNUM (FONTSET_ID (fontset_obj)); - set_fontset_ascii (fontset, fontname); - name = FONTSET_NAME (fontset); + set_fontset_ascii (fontset_obj, fontname); + fontset = FONTSET_NAME (fontset_obj); FOR_EACH_FRAME (tail, fr) { struct frame *f = XFRAME (fr); @@ -1657,17 +1662,17 @@ appended. By default, FONT-SPEC overrides the previous settings. */) font_object = font_open_by_spec (f, font_spec); if (! NILP (font_object)) { - update_auto_fontset_alist (font_object, fontset); - AUTO_FRAME_ARG (arg, Qfont, Fcons (name, font_object)); + update_auto_fontset_alist (font_object, fontset_obj); + AUTO_FRAME_ARG (arg, Qfont, Fcons (fontset, font_object)); Fmodify_frame_parameters (fr, arg); } } } - /* Free all realized fontsets whose base is FONTSET. This way, the + /* Free all realized fontsets whose base is FONTSET_OBJ. This way, the specified character(s) are surely redisplayed by a correct font. */ - free_realized_fontsets (fontset); + free_realized_fontsets (fontset_obj); return Qnil; } diff --git a/src/frame.c b/src/frame.c index b3990ae2aa5..93028aa8958 100644 --- a/src/frame.c +++ b/src/frame.c @@ -335,7 +335,7 @@ DEFUN ("frame-windows-min-size", Fframe_windows_min_size, * additionally limit the minimum frame height to a value large enough * to support menu bar, tab bar, mode line and echo area. */ -int +static int frame_windows_min_size (Lisp_Object frame, Lisp_Object horizontal, Lisp_Object ignore, Lisp_Object pixelwise) { @@ -1987,6 +1987,14 @@ delete_frame (Lisp_Object frame, Lisp_Object force) else error ("Attempt to delete the only frame"); } +#ifdef HAVE_X_WINDOWS + else if (x_dnd_in_progress && f == x_dnd_frame) + error ("Attempt to delete the drop source frame"); +#endif +#ifdef HAVE_HAIKU + else if (f == haiku_dnd_frame) + error ("Attempt to delete the drop source frame"); +#endif XSETFRAME (frame, f); @@ -2505,9 +2513,12 @@ vertical offset, measured in units of the frame's default character size. If Emacs is running on a mouseless terminal or hasn't been programmed to read the mouse position, it returns the selected frame for FRAME and nil for X and Y. -If `mouse-position-function' is non-nil, `mouse-position' calls it, -passing the normal return value to that function as an argument, -and returns whatever that function returns. */) + +FRAME might be nil if `track-mouse' is set to `drag-source'. This +means there is no frame under the mouse. If `mouse-position-function' +is non-nil, `mouse-position' calls it, passing the normal return value +to that function as an argument, and returns whatever that function +returns. */) (void) { return mouse_position (true); @@ -2534,7 +2545,7 @@ mouse_position (bool call_mouse_position_function) &time_dummy); } - if (! NILP (x)) + if (! NILP (x) && f) { int col = XFIXNUM (x); int row = XFIXNUM (y); @@ -2542,7 +2553,10 @@ mouse_position (bool call_mouse_position_function) XSETINT (x, col); XSETINT (y, row); } - XSETFRAME (lispy_dummy, f); + if (f) + XSETFRAME (lispy_dummy, f); + else + lispy_dummy = Qnil; retval = Fcons (lispy_dummy, Fcons (x, y)); if (call_mouse_position_function && !NILP (Vmouse_position_function)) retval = call1 (Vmouse_position_function, retval); @@ -2555,9 +2569,11 @@ DEFUN ("mouse-pixel-position", Fmouse_pixel_position, The position is given in pixel units, where (0, 0) is the upper-left corner of the frame, X is the horizontal offset, and Y is the vertical offset. -If Emacs is running on a mouseless terminal or hasn't been programmed -to read the mouse position, it returns the selected frame for FRAME -and nil for X and Y. */) +FRAME might be nil if `track-mouse' is set to `drag-source'. This +means there is no frame under the mouse. If Emacs is running on a +mouseless terminal or hasn't been programmed to read the mouse +position, it returns the selected frame for FRAME and nil for X and +Y. */) (void) { struct frame *f; @@ -2578,7 +2594,11 @@ and nil for X and Y. */) &time_dummy); } - XSETFRAME (lispy_dummy, f); + if (f) + XSETFRAME (lispy_dummy, f); + else + lispy_dummy = Qnil; + retval = Fcons (lispy_dummy, Fcons (x, y)); if (!NILP (Vmouse_position_function)) retval = call1 (Vmouse_position_function, retval); @@ -3495,7 +3515,10 @@ DEFUN ("frame-native-width", Fframe_native_width, Sframe_native_width, 0, 1, 0, doc: /* Return FRAME's native width in pixels. For a terminal frame, the result really gives the width in characters. -If FRAME is omitted or nil, the selected frame is used. */) +If FRAME is omitted or nil, the selected frame is used. + +If you're interested only in the width of the text portion of the +frame, see `frame-text-width' instead. */) (Lisp_Object frame) { struct frame *f = decode_any_frame (frame); @@ -3519,6 +3542,9 @@ minibuffer or echo area), mode line, and header line. It does not include the tool bar or menu bar. With other graphical versions, it may also include the tool bar and the menu bar. +If you're interested only in the height of the text portion of the +frame, see `frame-text-height' instead. + For a text terminal, it includes the menu bar. In this case, the result is really in characters rather than pixels (i.e., is identical to `frame-height'). */) @@ -6270,7 +6296,7 @@ Setting this variable does not affect existing frames, only new ones. */); DEFVAR_BOOL ("scroll-bar-adjust-thumb-portion", scroll_bar_adjust_thumb_portion_p, - doc: /* Adjust thumb for overscrolling for Gtk+ and MOTIF. + doc: /* Adjust scroll bars for overscrolling for Gtk+, Motif and Haiku. Non-nil means adjust the thumb in the scroll bar so it can be dragged downwards even if the end of the buffer is shown (i.e. overscrolling). Set to nil if you want the thumb to be at the bottom when the end of the buffer diff --git a/src/frame.h b/src/frame.h index 5d5f2122fbb..4942e640d27 100644 --- a/src/frame.h +++ b/src/frame.h @@ -102,6 +102,10 @@ struct frame Lisp_Object parent_frame; #endif /* HAVE_WINDOW_SYSTEM */ + /* Last device to move over this frame. Any value that isn't a + string means the "Virtual core pointer". */ + Lisp_Object last_mouse_device; + /* The frame which should receive keystrokes that occur in this frame, or nil if they should go to the frame itself. This is usually nil, but if the frame is minibufferless, we can use this @@ -1338,8 +1342,6 @@ extern bool frame_inhibit_resize (struct frame *, bool, Lisp_Object); extern void adjust_frame_size (struct frame *, int, int, int, bool, Lisp_Object); extern Lisp_Object mouse_position (bool); -extern int frame_windows_min_size (Lisp_Object, Lisp_Object, Lisp_Object, - Lisp_Object); extern void frame_size_history_plain (struct frame *, Lisp_Object); extern void frame_size_history_extra (struct frame *, Lisp_Object, int, int, int, int, int, int); diff --git a/src/fringe.c b/src/fringe.c index bc4e0f1f136..bf0b5fde761 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -30,7 +30,9 @@ along with GNU Emacs. If not, see . */ #include "termhooks.h" #include "pdumper.h" -#include "pgtkterm.h" +#ifdef HAVE_PGTK +# include "pgtkterm.h" +#endif /* Fringe bitmaps are represented in three different ways: diff --git a/src/gnutls.c b/src/gnutls.c index 09590ca005c..0e1e63e157a 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -1521,7 +1521,7 @@ returned as the :certificate entry. */) /* Initialize global GnuTLS state to defaults. Call 'gnutls-global-deinit' when GnuTLS usage is no longer needed. Return zero on success. */ -Lisp_Object +static Lisp_Object emacs_gnutls_global_init (void) { int ret = GNUTLS_E_SUCCESS; diff --git a/src/gnutls.h b/src/gnutls.h index 791e5340c2d..19d3d3f5bc6 100644 --- a/src/gnutls.h +++ b/src/gnutls.h @@ -90,7 +90,6 @@ extern void emacs_gnutls_transport_set_errno (gnutls_session_t state, int err); extern int w32_gnutls_rnd (gnutls_rnd_level_t, void *, size_t); #endif extern Lisp_Object emacs_gnutls_deinit (Lisp_Object); -extern Lisp_Object emacs_gnutls_global_init (void); extern int gnutls_try_handshake (struct Lisp_Process *p); extern Lisp_Object gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist); diff --git a/src/gtkutil.c b/src/gtkutil.c index 1b4ecaf9492..a2ab01d02c5 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -142,7 +142,7 @@ struct xg_frame_tb_info bool xg_gtk_initialized; /* Used to make sure xwidget calls are possible */ #endif -static GtkWidget * xg_get_widget_from_map (ptrdiff_t idx); +static GtkWidget *xg_get_widget_from_map (ptrdiff_t idx, Display *dpy); @@ -1061,6 +1061,7 @@ xg_set_geometry (struct frame *f) /* Handle negative positions without consulting gtk_window_parse_geometry (Bug#25851). The position will be off by scrollbar width + window manager decorations. */ +#ifndef HAVE_PGTK if (f->size_hint_flags & XNegative) f->left_pos = (x_display_pixel_width (FRAME_DISPLAY_INFO (f)) - FRAME_PIXEL_WIDTH (f) + f->left_pos); @@ -1068,6 +1069,15 @@ xg_set_geometry (struct frame *f) if (f->size_hint_flags & YNegative) f->top_pos = (x_display_pixel_height (FRAME_DISPLAY_INFO (f)) - FRAME_PIXEL_HEIGHT (f) + f->top_pos); +#else + if (f->size_hint_flags & XNegative) + f->left_pos = (pgtk_display_pixel_width (FRAME_DISPLAY_INFO (f)) + - FRAME_PIXEL_WIDTH (f) + f->left_pos); + + if (f->size_hint_flags & YNegative) + f->top_pos = (pgtk_display_pixel_height (FRAME_DISPLAY_INFO (f)) + - FRAME_PIXEL_HEIGHT (f) + f->top_pos); +#endif /* GTK works in scaled pixels, so convert from X pixels. */ gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), @@ -1182,7 +1192,7 @@ xg_frame_set_char_size (struct frame *f, int width, int height) outer_height /= xg_get_scale (f); outer_width /= xg_get_scale (f); - x_wm_set_size_hint (f, 0, 0); + xg_wm_set_size_hint (f, 0, 0); /* Resize the top level widget so rows and columns remain constant. @@ -1612,10 +1622,7 @@ xg_create_frame_widgets (struct frame *f) with regular X drawing primitives, so from a GTK/GDK point of view, the widget is totally blank. When an expose comes, this will make the widget blank, and then Emacs redraws it. This flickers - a lot, so we turn off double buffering. - FIXME: gtk_widget_set_double_buffered is deprecated and might stop - working in the future. We need to migrate away from combining - X and GTK+ drawing to a pure GTK+ build. */ + a lot, so we turn off double buffering. */ #ifndef HAVE_PGTK gtk_widget_set_double_buffered (wfixed, FALSE); @@ -1901,7 +1908,7 @@ xg_free_frame_widgets (struct frame *f) flag (this is useful when FLAGS is 0). */ void -x_wm_set_size_hint (struct frame *f, long int flags, bool user_position) +xg_wm_set_size_hint (struct frame *f, long int flags, bool user_position) { /* Must use GTK routines here, otherwise GTK resets the size hints to its own defaults. */ @@ -2041,8 +2048,8 @@ xg_set_background_color (struct frame *f, unsigned long bg) !NILP (bar); bar = XSCROLL_BAR (bar)->next) { - GtkWidget *scrollbar = - xg_get_widget_from_map (XSCROLL_BAR (bar)->x_window); + GtkWidget *scrollbar = xg_get_widget_from_map (XSCROLL_BAR (bar)->x_window, + FRAME_X_DISPLAY (f)); GtkWidget *webox = gtk_widget_get_parent (scrollbar); xg_set_widget_bg (f, webox, FRAME_BACKGROUND_PIXEL (f)); } @@ -4267,6 +4274,8 @@ bool xg_ignore_gtk_scrollbar; static int scroll_bar_width_for_theme; static int scroll_bar_height_for_theme; +#if defined HAVE_PGTK || !defined HAVE_GTK3 + /* Xlib's `Window' fits in 32 bits. But we want to store pointers, and they may be larger than 32 bits. Keep a mapping from integer index to widget pointers to get around the 32 bit limitation. */ @@ -4338,7 +4347,7 @@ xg_remove_widget_from_map (ptrdiff_t idx) /* Get the widget pointer at IDX from id_to_widget. */ static GtkWidget * -xg_get_widget_from_map (ptrdiff_t idx) +xg_get_widget_from_map (ptrdiff_t idx, Display *dpy) { if (idx < id_to_widget.max_size && id_to_widget.widgets[idx] != 0) return id_to_widget.widgets[idx]; @@ -4346,6 +4355,42 @@ xg_get_widget_from_map (ptrdiff_t idx) return 0; } +#else +static void +find_scrollbar_cb (GtkWidget *widget, gpointer user_data) +{ + GtkWidget **scroll_bar = user_data; + + if (GTK_IS_SCROLLBAR (widget)) + *scroll_bar = widget; +} + +static GtkWidget * +xg_get_widget_from_map (ptrdiff_t window, Display *dpy) +{ + GtkWidget *gwdesc, *scroll_bar = NULL; + GdkWindow *gdkwin; + + gdkwin = gdk_x11_window_lookup_for_display (gdk_x11_lookup_xdisplay (dpy), + (Window) window); + if (gdkwin) + { + GdkEvent event; + event.any.window = gdkwin; + event.any.type = GDK_NOTHING; + gwdesc = gtk_get_event_widget (&event); + + if (gwdesc && GTK_IS_EVENT_BOX (gwdesc)) + gtk_container_forall (GTK_CONTAINER (gwdesc), + find_scrollbar_cb, &scroll_bar); + } + else + return NULL; + + return scroll_bar; +} +#endif + static void update_theme_scrollbar_width (void) { @@ -4405,7 +4450,7 @@ xg_get_default_scrollbar_height (struct frame *f) return scroll_bar_width_for_theme * xg_get_scale (f); } -#ifndef HAVE_PGTK +#ifndef HAVE_GTK3 /* Return the scrollbar id for X Window WID on display DPY. Return -1 if WID not in id_to_widget. */ @@ -4432,12 +4477,40 @@ xg_get_scroll_id_for_window (Display *dpy, Window wid) DATA is the index into id_to_widget for WIDGET. We free pointer to last scroll bar values here and remove the index. */ +#if !defined HAVE_GTK3 || defined HAVE_PGTK static void xg_gtk_scroll_destroy (GtkWidget *widget, gpointer data) { intptr_t id = (intptr_t) data; xg_remove_widget_from_map (id); } +#endif + +#if defined HAVE_GTK3 && !defined HAVE_PGTK +static void +xg_scroll_bar_size_allocate_cb (GtkWidget *widget, + GdkRectangle *allocation, + gpointer user_data) +{ + GdkEvent *event = gtk_get_current_event (); + GdkEvent dummy; + + if (event && event->any.type == GDK_CONFIGURE) + x_scroll_bar_configure (event); + else + { + /* These are the only fields used by x_scroll_bar_configure. */ + dummy.configure.send_event = FALSE; + dummy.configure.x = allocation->x; + dummy.configure.y = allocation->y; + dummy.configure.width = allocation->width; + dummy.configure.height = allocation->height; + dummy.configure.window = gtk_widget_get_window (widget); + + x_scroll_bar_configure (&dummy); + } +} +#endif static void xg_finish_scroll_bar_creation (struct frame *f, @@ -4448,19 +4521,32 @@ xg_finish_scroll_bar_creation (struct frame *f, const char *scroll_bar_name) { GtkWidget *webox = gtk_event_box_new (); +#ifdef HAVE_GTK3 + GtkCssProvider *foreground_provider; + GtkCssProvider *background_provider; +#endif gtk_widget_set_name (wscroll, scroll_bar_name); #ifndef HAVE_GTK3 gtk_range_set_update_policy (GTK_RANGE (wscroll), GTK_UPDATE_CONTINUOUS); #endif - g_object_set_data (G_OBJECT (wscroll), XG_FRAME_DATA, (gpointer)f); + g_object_set_data (G_OBJECT (wscroll), XG_FRAME_DATA, (gpointer) f); +#if defined HAVE_GTK3 && !defined HAVE_PGTK + g_signal_connect (G_OBJECT (webox), "size-allocate", + G_CALLBACK (xg_scroll_bar_size_allocate_cb), + NULL); +#endif + +#if defined HAVE_PGTK || !defined HAVE_GTK3 ptrdiff_t scroll_id = xg_store_widget_in_map (wscroll); g_signal_connect (G_OBJECT (wscroll), "destroy", G_CALLBACK (xg_gtk_scroll_destroy), (gpointer) scroll_id); +#endif + g_signal_connect (G_OBJECT (wscroll), "change-value", scroll_callback, @@ -4488,27 +4574,35 @@ xg_finish_scroll_bar_creation (struct frame *f, gtk_widget_realize (webox); #ifdef HAVE_PGTK gtk_widget_show_all (webox); -#endif -#ifndef HAVE_PGTK +#elif defined HAVE_GTK3 + bar->x_window = GTK_WIDGET_TO_X_WIN (webox); + gtk_widget_show_all (webox); +#else GTK_WIDGET_TO_X_WIN (webox); #endif /* Set the cursor to an arrow. */ xg_set_cursor (webox, FRAME_DISPLAY_INFO (f)->xg_cursor); -#ifdef HAVE_PGTK +#ifdef HAVE_GTK3 GtkStyleContext *ctxt = gtk_widget_get_style_context (wscroll); - gtk_style_context_add_provider (ctxt, - GTK_STYLE_PROVIDER (FRAME_OUTPUT_DATA (f)-> - scrollbar_foreground_css_provider), + foreground_provider = FRAME_OUTPUT_DATA (f)->scrollbar_foreground_css_provider; + background_provider = FRAME_OUTPUT_DATA (f)->scrollbar_background_css_provider; + + gtk_style_context_add_provider (ctxt, GTK_STYLE_PROVIDER (foreground_provider), GTK_STYLE_PROVIDER_PRIORITY_USER); - gtk_style_context_add_provider (ctxt, - GTK_STYLE_PROVIDER (FRAME_OUTPUT_DATA (f)-> - scrollbar_background_css_provider), + gtk_style_context_add_provider (ctxt, GTK_STYLE_PROVIDER (background_provider), GTK_STYLE_PROVIDER_PRIORITY_USER); + +#ifndef HAVE_PGTK + gtk_widget_add_events (webox, GDK_STRUCTURE_MASK); + gtk_widget_set_double_buffered (wscroll, FALSE); +#endif #endif +#if defined HAVE_PGTK || !defined HAVE_GTK3 bar->x_window = scroll_id; +#endif } /* Create a scroll bar widget for frame F. Store the scroll bar @@ -4582,7 +4676,8 @@ xg_create_horizontal_scroll_bar (struct frame *f, void xg_remove_scroll_bar (struct frame *f, ptrdiff_t scrollbar_id) { - GtkWidget *w = xg_get_widget_from_map (scrollbar_id); + GtkWidget *w = xg_get_widget_from_map (scrollbar_id, + FRAME_X_DISPLAY (f)); if (w) { GtkWidget *wparent = gtk_widget_get_parent (w); @@ -4605,11 +4700,15 @@ xg_update_scrollbar_pos (struct frame *f, int width, int height) { - GtkWidget *wscroll = xg_get_widget_from_map (scrollbar_id); + GtkWidget *wscroll = xg_get_widget_from_map (scrollbar_id, + FRAME_X_DISPLAY (f)); if (wscroll) { GtkWidget *wfixed = f->output_data.xp->edit_widget; GtkWidget *wparent = gtk_widget_get_parent (wscroll); +#if !defined HAVE_PGTK && defined HAVE_GTK3 + GdkWindow *wdesc = gtk_widget_get_window (wparent); +#endif gint msl; int scale = xg_get_scale (f); @@ -4642,6 +4741,16 @@ xg_update_scrollbar_pos (struct frame *f, { gtk_widget_show_all (wparent); gtk_widget_set_size_request (wscroll, width, height); + +#if !defined HAVE_PGTK && defined HAVE_GTK3 + if (wdesc) + { + gdk_window_move_resize (wdesc, left, top, width, height); +#if GTK_CHECK_VERSION (3, 20, 0) + gtk_widget_queue_allocate (wparent); +#endif + } +#endif } if (oldx != -1 && oldw > 0 && oldh > 0) @@ -4658,7 +4767,8 @@ xg_update_scrollbar_pos (struct frame *f, if (!hidden) { - GtkWidget *scrollbar = xg_get_widget_from_map (scrollbar_id); + GtkWidget *scrollbar = xg_get_widget_from_map (scrollbar_id, + FRAME_X_DISPLAY (f)); GtkWidget *webox = gtk_widget_get_parent (scrollbar); #ifndef HAVE_PGTK @@ -4697,12 +4807,16 @@ xg_update_horizontal_scrollbar_pos (struct frame *f, int width, int height) { - GtkWidget *wscroll = xg_get_widget_from_map (scrollbar_id); + GtkWidget *wscroll = xg_get_widget_from_map (scrollbar_id, + FRAME_X_DISPLAY (f)); if (wscroll) { GtkWidget *wfixed = f->output_data.xp->edit_widget; GtkWidget *wparent = gtk_widget_get_parent (wscroll); +#if !defined HAVE_PGTK && defined HAVE_GTK3 + GdkWindow *wdesc = gtk_widget_get_window (wparent); +#endif gint msl; int scale = xg_get_scale (f); @@ -4734,6 +4848,16 @@ xg_update_horizontal_scrollbar_pos (struct frame *f, { gtk_widget_show_all (wparent); gtk_widget_set_size_request (wscroll, width, height); + +#if !defined HAVE_PGTK && defined HAVE_GTK3 + if (wdesc) + { + gdk_window_move_resize (wdesc, left, top, width, height); +#if GTK_CHECK_VERSION (3, 20, 0) + gtk_widget_queue_allocate (wparent); +#endif + } +#endif } if (oldx != -1 && oldw > 0 && oldh > 0) /* Clear under old scroll bar position. */ @@ -4749,7 +4873,7 @@ xg_update_horizontal_scrollbar_pos (struct frame *f, { GtkWidget *scrollbar = - xg_get_widget_from_map (scrollbar_id); + xg_get_widget_from_map (scrollbar_id, FRAME_X_DISPLAY (f)); GtkWidget *webox = gtk_widget_get_parent (scrollbar); #ifndef HAVE_PGTK @@ -4789,9 +4913,10 @@ xg_set_toolkit_scroll_bar_thumb (struct scroll_bar *bar, int position, int whole) { - GtkWidget *wscroll = xg_get_widget_from_map (bar->x_window); - struct frame *f = XFRAME (WINDOW_FRAME (XWINDOW (bar->window))); + GtkWidget *wscroll = xg_get_widget_from_map (bar->x_window, + FRAME_X_DISPLAY (f)); + if (wscroll && bar->dragging == -1) { @@ -4876,7 +5001,9 @@ xg_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar, int position, int whole) { - GtkWidget *wscroll = xg_get_widget_from_map (bar->x_window); + struct frame *f = XFRAME (WINDOW_FRAME (XWINDOW (bar->window))); + GtkWidget *wscroll = xg_get_widget_from_map (bar->x_window, + FRAME_X_DISPLAY (f)); if (wscroll && bar->dragging == -1) { @@ -6055,8 +6182,10 @@ xg_initialize (void) xg_menu_cb_list.prev = xg_menu_cb_list.next = xg_menu_item_cb_list.prev = xg_menu_item_cb_list.next = 0; +#if defined HAVE_PGTK || !defined HAVE_GTK3 id_to_widget.max_size = id_to_widget.used = 0; id_to_widget.widgets = 0; +#endif settings = gtk_settings_get_for_screen (gdk_display_get_default_screen (gdk_display_get_default ())); @@ -6155,6 +6284,10 @@ xg_im_context_commit (GtkIMContext *imc, gchar *str, { struct frame *f = user_data; struct input_event ie; +#ifdef HAVE_XINPUT2 + struct xi_device_t *source; + struct x_display_info *dpyinfo; +#endif EVENT_INIT (ie); /* This used to use g_utf8_to_ucs4_fast, which led to bad results @@ -6173,6 +6306,22 @@ xg_im_context_commit (GtkIMContext *imc, gchar *str, make_fixnum (SCHARS (ie.arg)), Qcoding, Qt, ie.arg); +#ifdef HAVE_XINPUT2 + dpyinfo = FRAME_DISPLAY_INFO (f); + + /* There is no timestamp associated with commit events, so use the + device that sent the last event to be filtered. */ + if (dpyinfo->pending_keystroke_time) + { + dpyinfo->pending_keystroke_time = 0; + source = xi_device_from_id (dpyinfo, + dpyinfo->pending_keystroke_source); + + if (source) + ie.device = source->name; + } +#endif + XSETFRAME (ie.frame_or_window, f); ie.modifiers = 0; ie.timestamp = 0; @@ -6228,6 +6377,10 @@ xg_widget_key_press_event_cb (GtkWidget *widget, GdkEvent *event, guint keysym = event->key.keyval; unsigned int xstate; gunichar uc; +#ifdef HAVE_XINPUT2 + Time pending_keystroke_time; + struct xi_device_t *source; +#endif FOR_EACH_FRAME (tail, tem) { @@ -6242,6 +6395,14 @@ xg_widget_key_press_event_cb (GtkWidget *widget, GdkEvent *event, if (!f) return true; +#ifdef HAVE_XINPUT2 + pending_keystroke_time + = FRAME_DISPLAY_INFO (f)->pending_keystroke_time; + + if (event->key.time >= pending_keystroke_time) + FRAME_DISPLAY_INFO (f)->pending_keystroke_time = 0; +#endif + if (!x_gtk_use_native_input && !FRAME_DISPLAY_INFO (f)->prefer_native_input) return true; @@ -6256,6 +6417,17 @@ xg_widget_key_press_event_cb (GtkWidget *widget, GdkEvent *event, |= x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), xstate); inev.ie.timestamp = event->key.time; +#ifdef HAVE_XINPUT2 + if (event->key.time == pending_keystroke_time) + { + source = xi_device_from_id (FRAME_DISPLAY_INFO (f), + FRAME_DISPLAY_INFO (f)->pending_keystroke_source); + + if (source) + inev.ie.device = source->name; + } +#endif + if (event->key.is_modifier) goto done; diff --git a/src/gtkutil.h b/src/gtkutil.h index 63ecac07907..190d6628314 100644 --- a/src/gtkutil.h +++ b/src/gtkutil.h @@ -153,6 +153,8 @@ extern bool xg_event_is_for_scrollbar (struct frame *, const EVENT *, extern int xg_get_default_scrollbar_width (struct frame *f); extern int xg_get_default_scrollbar_height (struct frame *f); +extern void xg_wm_set_size_hint (struct frame *, long int, bool); + extern void update_frame_tool_bar (struct frame *f); extern void free_frame_tool_bar (struct frame *f); extern void xg_change_toolbar_position (struct frame *f, Lisp_Object pos); @@ -222,7 +224,7 @@ extern bool xg_is_menu_window (Display *dpy, Window); extern bool xg_filter_key (struct frame *frame, XEvent *xkey); #endif -/* Mark all callback data that are Lisp_object:s during GC. */ +/* Mark all callback data that are Lisp_Objects during GC. */ extern void xg_mark_data (void); /* Initialize GTK specific parts. */ diff --git a/src/haiku_draw_support.cc b/src/haiku_draw_support.cc index f8df298958f..a8d46d000a3 100644 --- a/src/haiku_draw_support.cc +++ b/src/haiku_draw_support.cc @@ -468,16 +468,6 @@ BView_FillTriangle (void *view, int x1, int y1, BPoint (x3, y3)); } -void -BView_SetHighColorForVisibleBell (void *view, uint32_t color) -{ - BView *vw = (BView *) view; - rgb_color col; - rgb32_to_rgb_color (color, &col); - - vw->SetHighColor (col); -} - void BView_InvertRect (void *view, int x, int y, int width, int height) { diff --git a/src/haiku_font_support.cc b/src/haiku_font_support.cc index 549c54d8649..ca6aaf71204 100644 --- a/src/haiku_font_support.cc +++ b/src/haiku_font_support.cc @@ -27,15 +27,111 @@ along with GNU Emacs. If not, see . */ #include "haiku_support.h" +/* Cache used during font lookup. It contains an opened font object + we can look inside, and some previously determined information. */ +struct font_object_cache_bucket +{ + struct font_object_cache_bucket *next; + unsigned int hash; + + BFont *font_object; +}; + +static struct font_object_cache_bucket *font_object_cache[2048]; + /* Haiku doesn't expose font language data in BFont objects. Thus, we select a few representative characters for each supported `:lang' (currently Chinese, Korean and Japanese,) and test for those instead. */ -static uint32_t language_code_points[MAX_LANGUAGE][4] = - {{20154, 20754, 22996, 0}, /* Chinese. */ - {51312, 49440, 44544, 0}, /* Korean. */ - {26085, 26412, 12371, 0}, /* Japanese. */}; +static int language_code_points[MAX_LANGUAGE][3] = + {{20154, 20754, 22996}, /* Chinese. */ + {51312, 49440, 44544}, /* Korean. */ + {26085, 26412, 12371}, /* Japanese. */}; + +static unsigned int +hash_string (const char *name_or_style) +{ + unsigned int i; + + i = 3323198485ul; + for (; *name_or_style; ++name_or_style) + { + i ^= *name_or_style; + i *= 0x5bd1e995; + i ^= i >> 15; + } + return i; +} + +static struct font_object_cache_bucket * +cache_font_object_data (const char *family, const char *style, + BFont *font_object) +{ + uint32_t hash; + struct font_object_cache_bucket *bucket, *next; + + hash = hash_string (family) ^ hash_string (style); + bucket = font_object_cache[hash % 2048]; + + for (next = bucket; next; next = next->next) + { + if (next->hash == hash) + { + delete next->font_object; + next->font_object = font_object; + + return next; + } + } + + next = new struct font_object_cache_bucket; + next->font_object = font_object; + next->hash = hash; + next->next = bucket; + font_object_cache[hash % 2048] = next; + return next; +} + +static struct font_object_cache_bucket * +lookup_font_object_data (const char *family, const char *style) +{ + uint32_t hash; + struct font_object_cache_bucket *bucket, *next; + + hash = hash_string (family) ^ hash_string (style); + bucket = font_object_cache[hash % 2048]; + + for (next = bucket; next; next = next->next) + { + if (next->hash == hash) + return next; + } + + return NULL; +} + +static bool +font_object_has_chars (struct font_object_cache_bucket *cached, + int *chars, int nchars, bool just_one_of) +{ + int i; + + for (i = 0; i < nchars; ++i) + { + if (just_one_of + && cached->font_object->IncludesBlock (chars[i], + chars[i])) + return true; + + if (!just_one_of + && !cached->font_object->IncludesBlock (chars[i], + chars[i])) + return false; + } + + return !just_one_of; +} static void estimate_font_ascii (BFont *font, int *max_width, @@ -85,9 +181,9 @@ BFont_close (void *font) } void -BFont_dat (void *font, int *px_size, int *min_width, int *max_width, - int *avg_width, int *height, int *space_width, int *ascent, - int *descent, int *underline_position, int *underline_thickness) +BFont_metrics (void *font, int *px_size, int *min_width, int *max_width, + int *avg_width, int *height, int *space_width, int *ascent, + int *descent, int *underline_position, int *underline_thickness) { BFont *ft = (BFont *) font; struct font_height fheight; @@ -196,18 +292,21 @@ font_style_to_flags (char *st, struct haiku_font_pattern *pattern) { char *style = strdup (st); char *token; - pattern->weight = -1; + int tok = 0; + + if (!style) + return; + + pattern->weight = NO_WEIGHT; pattern->width = NO_WIDTH; pattern->slant = NO_SLANT; - int tok = 0; while ((token = std::strtok (!tok ? style : NULL, " ")) && tok < 3) { if (token && !strcmp (token, "Thin")) pattern->weight = HAIKU_THIN; - else if (token && !strcmp (token, "UltraLight")) - pattern->weight = HAIKU_ULTRALIGHT; - else if (token && !strcmp (token, "ExtraLight")) + else if (token && (!strcmp (token, "UltraLight") + || !strcmp (token, "ExtraLight"))) pattern->weight = HAIKU_EXTRALIGHT; else if (token && !strcmp (token, "Light")) pattern->weight = HAIKU_LIGHT; @@ -221,7 +320,7 @@ font_style_to_flags (char *st, struct haiku_font_pattern *pattern) if (pattern->width == NO_WIDTH) pattern->width = NORMAL_WIDTH; - if (pattern->weight == -1) + if (pattern->weight == NO_WEIGHT) pattern->weight = HAIKU_REGULAR; } else if (token && (!strcmp (token, "SemiBold") @@ -230,12 +329,11 @@ font_style_to_flags (char *st, struct haiku_font_pattern *pattern) pattern->weight = HAIKU_SEMI_BOLD; else if (token && !strcmp (token, "Bold")) pattern->weight = HAIKU_BOLD; - else if (token && (!strcmp (token, "ExtraBold") || + else if (token && (!strcmp (token, "ExtraBold") /* This has actually been seen in the wild. */ - !strcmp (token, "Extrabold"))) + || !strcmp (token, "Extrabold") + || !strcmp (token, "UltraBold"))) pattern->weight = HAIKU_EXTRA_BOLD; - else if (token && !strcmp (token, "UltraBold")) - pattern->weight = HAIKU_ULTRA_BOLD; else if (token && !strcmp (token, "Book")) pattern->weight = HAIKU_BOOK; else if (token && !strcmp (token, "Heavy")) @@ -274,7 +372,7 @@ font_style_to_flags (char *st, struct haiku_font_pattern *pattern) tok++; } - if (pattern->weight != -1) + if (pattern->weight != NO_WEIGHT) pattern->specified |= FSPEC_WEIGHT; if (pattern->slant != NO_SLANT) pattern->specified |= FSPEC_SLANT; @@ -289,6 +387,7 @@ font_style_to_flags (char *st, struct haiku_font_pattern *pattern) pattern->specified |= FSPEC_STYLE; std::strncpy ((char *) &pattern->style, st, sizeof pattern->style - 1); + pattern->style[sizeof pattern->style - 1] = '\0'; } free (style); @@ -298,54 +397,86 @@ static bool font_check_wanted_chars (struct haiku_font_pattern *pattern, font_family family, char *style) { - BFont ft; + BFont *ft; + static struct font_object_cache_bucket *cached; + unicode_block wanted_block; - if (ft.SetFamilyAndStyle (family, style) != B_OK) - return false; + cached = lookup_font_object_data (family, style); + if (cached) + ft = cached->font_object; + else + { + ft = new BFont; - for (int i = 0; i < pattern->want_chars_len; ++i) - if (!ft.IncludesBlock (pattern->wanted_chars[i], - pattern->wanted_chars[i])) - return false; + if (ft->SetFamilyAndStyle (family, style) != B_OK) + { + delete ft; + return false; + } - return true; + cached = cache_font_object_data (family, style, ft); + } + + return font_object_has_chars (cached, pattern->wanted_chars, + pattern->want_chars_len, false); } static bool font_check_one_of (struct haiku_font_pattern *pattern, font_family family, char *style) { - BFont ft; + BFont *ft; + static struct font_object_cache_bucket *cached; + unicode_block wanted_block; - if (ft.SetFamilyAndStyle (family, style) != B_OK) - return false; + cached = lookup_font_object_data (family, style); + if (cached) + ft = cached->font_object; + else + { + ft = new BFont; - for (int i = 0; i < pattern->need_one_of_len; ++i) - if (ft.IncludesBlock (pattern->need_one_of[i], - pattern->need_one_of[i])) - return true; + if (ft->SetFamilyAndStyle (family, style) != B_OK) + { + delete ft; + return false; + } - return false; + cached = cache_font_object_data (family, style, ft); + } + + return font_object_has_chars (cached, pattern->need_one_of, + pattern->need_one_of_len, true); } static bool font_check_language (struct haiku_font_pattern *pattern, font_family family, char *style) { - BFont ft; + BFont *ft; + static struct font_object_cache_bucket *cached; - if (ft.SetFamilyAndStyle (family, style) != B_OK) - return false; + cached = lookup_font_object_data (family, style); + if (cached) + ft = cached->font_object; + else + { + ft = new BFont; + + if (ft->SetFamilyAndStyle (family, style) != B_OK) + { + delete ft; + return false; + } + + cached = cache_font_object_data (family, style, ft); + } if (pattern->language == MAX_LANGUAGE) return false; - for (uint32_t *ch = (uint32_t *) - &language_code_points[pattern->language]; *ch; ch++) - if (!ft.IncludesBlock (*ch, *ch)) - return false; - - return true; + return font_object_has_chars (cached, language_code_points[pattern->language], + 3, false); } static bool @@ -359,16 +490,20 @@ font_family_style_matches_p (font_family family, char *style, uint32_t flags, if (style) font_style_to_flags (style, &m); - if ((pattern->specified & FSPEC_FAMILY) && - strcmp ((char *) &pattern->family, family)) + if ((pattern->specified & FSPEC_FAMILY) + && strcmp ((char *) &pattern->family, family)) return false; - if (!ignore_flags_p && (pattern->specified & FSPEC_SPACING) && - !(pattern->mono_spacing_p) != !(flags & B_IS_FIXED)) + if (!ignore_flags_p && (pattern->specified & FSPEC_SPACING) + && !(pattern->mono_spacing_p) != !(flags & B_IS_FIXED)) return false; if (pattern->specified & FSPEC_STYLE) return style && !strcmp (style, pattern->style); + /* Don't allow matching fonts with an adstyle if no style was + specified in the query pattern. */ + else if (m.specified & FSPEC_STYLE) + return false; if ((pattern->specified & FSPEC_WEIGHT) && (pattern->weight @@ -377,7 +512,8 @@ font_family_style_matches_p (font_family family, char *style, uint32_t flags, if ((pattern->specified & FSPEC_SLANT) && (pattern->slant - != ((m.specified & FSPEC_SLANT) ? m.slant : SLANT_REGULAR))) + != (m.specified & FSPEC_SLANT + ? m.slant : SLANT_REGULAR))) return false; if ((pattern->specified & FSPEC_WANTED) @@ -385,8 +521,9 @@ font_family_style_matches_p (font_family family, char *style, uint32_t flags, return false; if ((pattern->specified & FSPEC_WIDTH) - && (pattern->width != - ((m.specified & FSPEC_WIDTH) ? m.width : NORMAL_WIDTH))) + && (pattern->width + != (m.specified & FSPEC_WIDTH + ? m.width : NORMAL_WIDTH))) return false; if ((pattern->specified & FSPEC_NEED_ONE_OF) @@ -411,6 +548,7 @@ haiku_font_fill_pattern (struct haiku_font_pattern *pattern, pattern->specified |= FSPEC_FAMILY; std::strncpy (pattern->family, family, sizeof pattern->family - 1); + pattern->family[sizeof pattern->family - 1] = '\0'; pattern->specified |= FSPEC_SPACING; pattern->mono_spacing_p = flags & B_IS_FIXED; } @@ -436,18 +574,21 @@ BFont_find (struct haiku_font_pattern *pt) font_family name; font_style sname; uint32 flags; - int sty_count; - int fam_count = count_font_families (); + int sty_count, fam_count, si, fi; + struct haiku_font_pattern *p, *head, *n; + bool oblique_seen_p; - for (int fi = 0; fi < fam_count; ++fi) + fam_count = count_font_families (); + + for (fi = 0; fi < fam_count; ++fi) { if (get_font_family (fi, &name, &flags) == B_OK) { sty_count = count_font_styles (name); - if (!sty_count && - font_family_style_matches_p (name, NULL, flags, pt)) + if (!sty_count + && font_family_style_matches_p (name, NULL, flags, pt)) { - struct haiku_font_pattern *p = new struct haiku_font_pattern; + p = new struct haiku_font_pattern; p->specified = 0; p->oblique_seen_p = 1; haiku_font_fill_pattern (p, name, NULL, flags); @@ -460,11 +601,11 @@ BFont_find (struct haiku_font_pattern *pt) } else if (sty_count) { - for (int si = 0; si < sty_count; ++si) + for (si = 0; si < sty_count; ++si) { - int oblique_seen_p = 0; - struct haiku_font_pattern *head = r; - struct haiku_font_pattern *p = NULL; + oblique_seen_p = 0; + head = r; + p = NULL; if (get_font_style (name, si, &sname, &flags) == B_OK) { @@ -473,8 +614,18 @@ BFont_find (struct haiku_font_pattern *pt) p = new struct haiku_font_pattern; p->specified = 0; haiku_font_fill_pattern (p, name, (char *) &sname, flags); - if (p->specified & FSPEC_SLANT && - ((p->slant == SLANT_OBLIQUE) || (p->slant == SLANT_ITALIC))) + + /* Add the indices to this font now so we + won't have to loop over each font in + order to open it later. */ + + p->specified |= FSPEC_INDICES; + p->family_index = fi; + p->style_index = si; + + if (p->specified & FSPEC_SLANT + && (p->slant == SLANT_OBLIQUE + || p->slant == SLANT_ITALIC)) oblique_seen_p = 1; p->next = r; @@ -489,9 +640,7 @@ BFont_find (struct haiku_font_pattern *pt) p->last = NULL; for (; head; head = head->last) - { - head->oblique_seen_p = oblique_seen_p; - } + head->oblique_seen_p = oblique_seen_p; } } } @@ -504,13 +653,18 @@ BFont_find (struct haiku_font_pattern *pt) if (!(pt->specified & FSPEC_SLANT)) { /* r->last is invalid from here onwards. */ - for (struct haiku_font_pattern *p = r; p;) + for (p = r; p;) { if (!p->oblique_seen_p) { - struct haiku_font_pattern *n = new haiku_font_pattern; + n = new haiku_font_pattern; *n = *p; + n->slant = SLANT_OBLIQUE; + + /* Opening a font by its indices doesn't provide enough + information to synthesize the oblique font later. */ + n->specified &= ~FSPEC_INDICES; p->next = n; p = p->next_family; } @@ -522,24 +676,68 @@ BFont_find (struct haiku_font_pattern *pt) return r; } +/* Find and open a font with the family at FAMILY and the style at + STYLE, and set its size to SIZE. Value is NULL if opening the font + failed. */ +void * +be_open_font_at_index (int family, int style, float size) +{ + font_family family_name; + font_style style_name; + uint32 flags; + status_t rc; + BFont *font; + + rc = get_font_family (family, &family_name, &flags); + + if (rc != B_OK) + return NULL; + + rc = get_font_style (family_name, style, &style_name, &flags); + + if (rc != B_OK) + return NULL; + + font = new BFont; + + rc = font->SetFamilyAndStyle (family_name, style_name); + + if (rc != B_OK) + { + delete font; + return NULL; + } + + font->SetSize (size); + font->SetEncoding (B_UNICODE_UTF8); + font->SetSpacing (B_BITMAP_SPACING); + return font; +} + /* Find and open a font matching the pattern PAT, which must have its family set. */ int BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size) { - int sty_count; + int sty_count, si, code; font_family name; font_style sname; + BFont *ft; uint32 flags = 0; + struct haiku_font_pattern copy; + if (!(pat->specified & FSPEC_FAMILY)) return 1; + strncpy (name, pat->family, sizeof name - 1); + name[sizeof name - 1] = '\0'; + sty_count = count_font_styles (name); - if (!sty_count && - font_family_style_matches_p (name, NULL, flags, pat, 1)) + if (!sty_count + && font_family_style_matches_p (name, NULL, flags, pat, 1)) { - BFont *ft = new BFont; + ft = new BFont; ft->SetSize (size); ft->SetEncoding (B_UNICODE_UTF8); ft->SetSpacing (B_BITMAP_SPACING); @@ -554,12 +752,13 @@ BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size) } else if (sty_count) { - for (int si = 0; si < sty_count; ++si) + for (si = 0; si < sty_count; ++si) { - if (get_font_style (name, si, &sname, &flags) == B_OK && - font_family_style_matches_p (name, (char *) &sname, flags, pat)) + if (get_font_style (name, si, &sname, &flags) == B_OK + && font_family_style_matches_p (name, (char *) &sname, + flags, pat)) { - BFont *ft = new BFont; + ft = new BFont; ft->SetSize (size); ft->SetEncoding (B_UNICODE_UTF8); ft->SetSpacing (B_BITMAP_SPACING); @@ -569,6 +768,7 @@ BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size) delete ft; return 1; } + *font = (void *) ft; return 0; } @@ -577,12 +777,14 @@ BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size) if (pat->specified & FSPEC_SLANT && pat->slant == SLANT_OBLIQUE) { - struct haiku_font_pattern copy = *pat; + copy = *pat; copy.slant = SLANT_REGULAR; - int code = BFont_open_pattern (©, font, size); + code = BFont_open_pattern (©, font, size); + if (code) return code; - BFont *ft = (BFont *) *font; + + ft = (BFont *) *font; /* XXX Font measurements don't respect shear. Haiku bug? This apparently worked in BeOS. ft->SetShear (100.0); */ @@ -603,6 +805,7 @@ BFont_populate_fixed_family (struct haiku_font_pattern *ptn) ptn->specified |= FSPEC_FAMILY; strncpy (ptn->family, f, sizeof ptn->family - 1); + ptn->family[sizeof ptn->family - 1] = '\0'; } void @@ -614,12 +817,7 @@ BFont_populate_plain_family (struct haiku_font_pattern *ptn) ptn->specified |= FSPEC_FAMILY; strncpy (ptn->family, f, sizeof ptn->family - 1); -} - -int -BFont_string_width (void *font, const char *utf8) -{ - return ((BFont *) font)->StringWidth (utf8); + ptn->family[sizeof ptn->family - 1] = '\0'; } haiku_font_family_or_style * @@ -645,3 +843,76 @@ be_list_font_families (size_t *length) return array; } + +void +be_init_font_data (void) +{ + memset (&font_object_cache, 0, sizeof font_object_cache); +} + +/* Free the font object cache. This is called every 50 updates of a + frame. */ +void +be_evict_font_cache (void) +{ + struct font_object_cache_bucket *bucket, *last; + int i; + + for (i = 0; i < 2048; ++i) + { + bucket = font_object_cache[i]; + + while (bucket) + { + last = bucket; + bucket = bucket->next; + delete last->font_object; + delete last; + } + + font_object_cache[i] = NULL; + } +} + +void +be_font_style_to_flags (char *style, struct haiku_font_pattern *pattern) +{ + pattern->specified = 0; + + font_style_to_flags (style, pattern); +} + +int +be_find_font_indices (struct haiku_font_pattern *pattern, + int *family_index, int *style_index) +{ + int32 i, j, n_families, n_styles; + font_family family; + font_style style; + uint32 flags; + + n_families = count_font_families (); + + for (i = 0; i < n_families; ++i) + { + if (get_font_family (i, &family, &flags) == B_OK) + { + n_styles = count_font_styles (family); + + for (j = 0; j < n_styles; ++j) + { + if (get_font_style (family, j, &style, &flags) == B_OK + && font_family_style_matches_p (family, style, + flags, pattern)) + { + *family_index = i; + *style_index = j; + + return 0; + } + } + } + } + + return 1; +} diff --git a/src/haiku_io.c b/src/haiku_io.c index ff684df4337..5d0031ef712 100644 --- a/src/haiku_io.c +++ b/src/haiku_io.c @@ -40,10 +40,15 @@ port_id port_application_to_emacs; thread to Emacs. */ port_id port_popup_menu_to_emacs; +/* The port used to send replies to the application after a session + management event. */ +port_id port_emacs_to_session_manager; + void haiku_io_init (void) { port_application_to_emacs = create_port (PORT_CAP, "application emacs port"); + port_emacs_to_session_manager = create_port (1, "session manager port"); } static ssize_t @@ -79,19 +84,19 @@ haiku_len (enum haiku_event_type type) return sizeof (struct haiku_wheel_move_event); case MENU_BAR_RESIZE: return sizeof (struct haiku_menu_bar_resize_event); + case MENU_BAR_CLICK: + return sizeof (struct haiku_menu_bar_click_event); case MENU_BAR_OPEN: case MENU_BAR_CLOSE: return sizeof (struct haiku_menu_bar_state_event); case MENU_BAR_SELECT_EVENT: return sizeof (struct haiku_menu_bar_select_event); - case FILE_PANEL_EVENT: - return sizeof (struct haiku_file_panel_event); case MENU_BAR_HELP_EVENT: return sizeof (struct haiku_menu_bar_help_event); case ZOOM_EVENT: return sizeof (struct haiku_zoom_event); - case REFS_EVENT: - return sizeof (struct haiku_refs_event); + case DRAG_AND_DROP_EVENT: + return sizeof (struct haiku_drag_and_drop_event); case APP_QUIT_REQUESTED_EVENT: return sizeof (struct haiku_app_quit_requested_event); case DUMMY_EVENT: @@ -145,7 +150,7 @@ haiku_read (enum haiku_event_type *type, void *buf, ssize_t len) Input is blocked when an attempt to read is in progress. */ int haiku_read_with_timeout (enum haiku_event_type *type, void *buf, ssize_t len, - time_t timeout, bool popup_menu_p) + bigtime_t timeout, bool popup_menu_p) { int32 typ; port_id from = (popup_menu_p @@ -202,24 +207,3 @@ haiku_io_init_in_app_thread (void) if (pthread_sigmask (SIG_BLOCK, &set, NULL)) perror ("pthread_sigmask"); } - -/* Record an unwind protect from C++ code. */ -void -record_c_unwind_protect_from_cxx (void (*fn) (void *), void *r) -{ - record_unwind_protect_ptr (fn, r); -} - -/* SPECPDL_IDX that is safe from C++ code. */ -specpdl_ref -c_specpdl_idx_from_cxx (void) -{ - return SPECPDL_INDEX (); -} - -/* unbind_to (IDX, Qnil), but safe from C++ code. */ -void -c_unbind_to_nil_from_cxx (specpdl_ref idx) -{ - unbind_to (idx, Qnil); -} diff --git a/src/haiku_select.cc b/src/haiku_select.cc index 011ad58036f..a26a0049cbf 100644 --- a/src/haiku_select.cc +++ b/src/haiku_select.cc @@ -19,13 +19,15 @@ along with GNU Emacs. If not, see . */ #include #include +#include +#include +#include #include #include #include "haikuselect.h" - static BClipboard *primary = NULL; static BClipboard *secondary = NULL; static BClipboard *system_clipboard = NULL; @@ -33,8 +35,6 @@ static int64 count_clipboard = -1; static int64 count_primary = -1; static int64 count_secondary = -1; -int selection_state_flag; - static char * BClipboard_find_data (BClipboard *cb, const char *type, ssize_t *len) { @@ -61,9 +61,17 @@ BClipboard_find_data (BClipboard *cb, const char *type, ssize_t *len) if (len) *len = bt; - cb->Unlock (); + void *data = malloc (bt); - return strndup (ptr, bt); + if (!data) + { + cb->Unlock (); + return NULL; + } + + memcpy (data, ptr, bt); + cb->Unlock (); + return (char *) data; } static void @@ -257,3 +265,217 @@ init_haiku_select (void) primary = new BClipboard ("primary"); secondary = new BClipboard ("secondary"); } + +int +be_enum_message (void *message, int32 *tc, int32 index, + int32 *count, const char **name_return) +{ + BMessage *msg = (BMessage *) message; + type_code type; + char *name; + status_t rc; + + rc = msg->GetInfo (B_ANY_TYPE, index, &name, &type, count); + + if (rc != B_OK) + return 1; + + *tc = type; + *name_return = name; + return 0; +} + +int +be_get_refs_data (void *message, const char *name, + int32 index, char **path_buffer) +{ + status_t rc; + BEntry entry; + BPath path; + entry_ref ref; + BMessage *msg; + + msg = (BMessage *) message; + rc = msg->FindRef (name, index, &ref); + + if (rc != B_OK) + return 1; + + rc = entry.SetTo (&ref, 0); + + if (rc != B_OK) + return 1; + + rc = entry.GetPath (&path); + + if (rc != B_OK) + return 1; + + *path_buffer = strdup (path.Path ()); + return 0; +} + +int +be_get_point_data (void *message, const char *name, + int32 index, float *x, float *y) +{ + status_t rc; + BMessage *msg; + BPoint point; + + msg = (BMessage *) message; + rc = msg->FindPoint (name, index, &point); + + if (rc != B_OK) + return 1; + + *x = point.x; + *y = point.y; + + return 0; +} + +int +be_get_message_data (void *message, const char *name, + int32 type_code, int32 index, + const void **buf_return, + ssize_t *size_return) +{ + BMessage *msg = (BMessage *) message; + + return msg->FindData (name, type_code, + index, buf_return, size_return) != B_OK; +} + +uint32 +be_get_message_type (void *message) +{ + BMessage *msg = (BMessage *) message; + + return msg->what; +} + +void +be_set_message_type (void *message, uint32 what) +{ + BMessage *msg = (BMessage *) message; + + msg->what = what; +} + +void * +be_get_message_message (void *message, const char *name, + int32 index) +{ + BMessage *msg = (BMessage *) message; + BMessage *out = new (std::nothrow) BMessage; + + if (!out) + return NULL; + + if (msg->FindMessage (name, index, out) != B_OK) + { + delete out; + return NULL; + } + + return out; +} + +void * +be_create_simple_message (void) +{ + return new BMessage (B_SIMPLE_DATA); +} + +int +be_add_message_data (void *message, const char *name, + int32 type_code, const void *buf, + ssize_t buf_size) +{ + BMessage *msg = (BMessage *) message; + + return msg->AddData (name, type_code, buf, buf_size) != B_OK; +} + +int +be_add_refs_data (void *message, const char *name, + const char *filename) +{ + BEntry entry (filename); + entry_ref ref; + BMessage *msg = (BMessage *) message; + + if (entry.InitCheck () != B_OK) + return 1; + + if (entry.GetRef (&ref) != B_OK) + return 1; + + return msg->AddRef (name, &ref) != B_OK; +} + +int +be_add_point_data (void *message, const char *name, + float x, float y) +{ + BMessage *msg = (BMessage *) message; + + return msg->AddPoint (name, BPoint (x, y)) != B_OK; +} + +int +be_add_message_message (void *message, const char *name, + void *data) +{ + BMessage *msg = (BMessage *) message; + BMessage *data_message = (BMessage *) data; + + if (msg->AddMessage (name, data_message) != B_OK) + return 1; + + return 0; +} + +int +be_lock_clipboard_message (enum haiku_clipboard clipboard, + void **message_return, bool clear) +{ + BClipboard *board; + + if (clipboard == CLIPBOARD_PRIMARY) + board = primary; + else if (clipboard == CLIPBOARD_SECONDARY) + board = secondary; + else + board = system_clipboard; + + if (!board->Lock ()) + return 1; + + if (clear) + board->Clear (); + + *message_return = board->Data (); + return 0; +} + +void +be_unlock_clipboard (enum haiku_clipboard clipboard, bool discard) +{ + BClipboard *board; + + if (clipboard == CLIPBOARD_PRIMARY) + board = primary; + else if (clipboard == CLIPBOARD_SECONDARY) + board = secondary; + else + board = system_clipboard; + + if (discard) + board->Revert (); + else + board->Commit (); + + board->Unlock (); +} diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 2f2adfd8f8a..5dfb25d6dd7 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -37,6 +37,14 @@ along with GNU Emacs. If not, see . */ #include #include #include +#include +#include +#include +#include +#include +#include +#include +#include #include @@ -53,6 +61,7 @@ along with GNU Emacs. If not, see . */ #include #include #include +#include #include #include @@ -80,7 +89,71 @@ along with GNU Emacs. If not, see . */ #include "haiku_support.h" -#define SCROLL_BAR_UPDATE 3000 +/* Some messages that Emacs sends to itself. */ +enum + { + SCROLL_BAR_UPDATE = 3000, + WAIT_FOR_RELEASE = 3001, + RELEASE_NOW = 3002, + CANCEL_DROP = 3003, + SHOW_MENU_BAR = 3004, + BE_MENU_BAR_OPEN = 3005, + QUIT_APPLICATION = 3006, + REPLAY_MENU_BAR = 3007, + FONT_FAMILY_SELECTED = 3008, + FONT_STYLE_SELECTED = 3009, + FILE_PANEL_SELECTION = 3010, + QUIT_PREVIEW_DIALOG = 3011, + SET_FONT_INDICES = 3012, + SET_PREVIEW_DIALOG = 3013, + UPDATE_PREVIEW_DIALOG = 3014, + }; + +/* X11 keysyms that we use. */ +enum + { + KEY_BACKSPACE = 0xff08, + KEY_TAB = 0xff09, + KEY_RETURN = 0xff0d, + KEY_PAUSE = 0xff13, + KEY_ESCAPE = 0xff1b, + KEY_DELETE = 0xffff, + KEY_HOME = 0xff50, + KEY_LEFT_ARROW = 0xff51, + KEY_UP_ARROW = 0xff52, + KEY_RIGHT_ARROW = 0xff53, + KEY_DOWN_ARROW = 0xff54, + KEY_PAGE_UP = 0xff55, + KEY_PAGE_DOWN = 0xff56, + KEY_END = 0xff57, + KEY_PRINT = 0xff61, + KEY_INSERT = 0xff63, + /* This is used to indicate the first function key. */ + KEY_F1 = 0xffbe, + /* These are found on some multilingual keyboards. */ + KEY_HANGUL = 0xff31, + KEY_HANGUL_HANJA = 0xff34, + KEY_HIRIGANA_KATAGANA = 0xff27, + KEY_ZENKAKU_HANKAKU = 0xff2a, + }; + +struct font_selection_dialog_message +{ + /* Whether or not font selection was cancelled. */ + bool_bf cancel : 1; + + /* Whether or not a size was explictly specified. */ + bool_bf size_specified : 1; + + /* The index of the selected font family. */ + int family_idx; + + /* The index of the selected font style. */ + int style_idx; + + /* The selected font size. */ + int size; +}; static color_space dpy_color_space = B_NO_COLOR_SPACE; static key_map *key_map = NULL; @@ -116,18 +189,40 @@ static BLocker movement_locker; static BMessage volatile *popup_track_message; static int32 volatile alert_popup_value; +static int current_window_id; + +static void *grab_view = NULL; +static BLocker grab_view_locker; +static bool drag_and_drop_in_progress; + +/* Many places require us to lock the child frame data, and then lock + the locker of some random window. Unfortunately, locking such a + window might be delayed due to an arriving message, which then + calls a callback inside that window that tries to lock the child + frame data but doesn't finish since the child frame lock is already + held, not letting the code that held the child frame lock proceed, + thereby causing a deadlock. + + Rectifying that problem is simple: all code in a looper callback + must lock the child frame data with this macro instead. + + IOW, if some other code is already running with the child frame + lock held, don't interfere: wait until it's finished before + continuing. */ +#define CHILD_FRAME_LOCK_INSIDE_LOOPER_CALLBACK \ + if (child_frame_lock.LockWithTimeout (200) != B_OK) \ + { \ + /* The Haiku equivalent of XPutBackEvent. */ \ + if (CurrentMessage ()) \ + PostMessage (CurrentMessage ()); \ + } \ + else /* This could be a private API, but it's used by (at least) the Qt port, so it's probably here to stay. */ extern status_t get_subpixel_antialiasing (bool *); -extern "C" -{ - extern _Noreturn void emacs_abort (void); - /* Also defined in haikuterm.h. */ - extern void be_app_quit (void); -} - +/* The ID of the thread the BApplication is running in. */ static thread_id app_thread; _Noreturn void @@ -137,7 +232,7 @@ gui_abort (const char *msg) fprintf (stderr, "Under Haiku, Emacs cannot recover from errors in GUI code\n"); fprintf (stderr, "App Server disconnects usually manifest as bitmap " "initialization failures or lock failures."); - emacs_abort (); + abort (); } struct be_popup_menu_data @@ -181,65 +276,78 @@ keysym_from_raw_char (int32 raw, int32 key, unsigned *code) switch (raw) { case B_BACKSPACE: - *code = XK_BackSpace; + *code = KEY_BACKSPACE; break; case B_RETURN: - *code = XK_Return; + *code = KEY_RETURN; break; case B_TAB: - *code = XK_Tab; + *code = KEY_TAB; break; case B_ESCAPE: - *code = XK_Escape; + *code = KEY_ESCAPE; break; case B_LEFT_ARROW: - *code = XK_Left; + *code = KEY_LEFT_ARROW; break; case B_RIGHT_ARROW: - *code = XK_Right; + *code = KEY_RIGHT_ARROW; break; case B_UP_ARROW: - *code = XK_Up; + *code = KEY_UP_ARROW; break; case B_DOWN_ARROW: - *code = XK_Down; + *code = KEY_DOWN_ARROW; break; case B_INSERT: - *code = XK_Insert; + *code = KEY_INSERT; break; case B_DELETE: - *code = XK_Delete; + *code = KEY_DELETE; break; case B_HOME: - *code = XK_Home; + *code = KEY_HOME; break; case B_END: - *code = XK_End; + *code = KEY_END; break; case B_PAGE_UP: - *code = XK_Page_Up; + *code = KEY_PAGE_UP; break; case B_PAGE_DOWN: - *code = XK_Page_Down; + *code = KEY_PAGE_DOWN; break; case B_FUNCTION_KEY: - *code = XK_F1 + key - 2; + *code = KEY_F1 + key - 2; - if (*code - XK_F1 == 12) - *code = XK_Print; - else if (*code - XK_F1 == 13) + if (*code - KEY_F1 == 12) + *code = KEY_PRINT; + else if (*code - KEY_F1 == 13) /* Okay, Scroll Lock is a bit too much: keyboard.c doesn't know about it yet, and it shouldn't, since that's a modifier key. - *code = XK_Scroll_Lock; */ + *code = KEY_SCROLL_LOCK; */ return -1; - else if (*code - XK_F1 == 14) - *code = XK_Pause; + else if (*code - KEY_F1 == 14) + *code = KEY_PAUSE; break; + case B_HANGUL: + *code = KEY_HANGUL; + break; + case B_HANGUL_HANJA: + *code = KEY_HANGUL_HANJA; + break; + case B_KATAKANA_HIRAGANA: + *code = KEY_HIRIGANA_KATAGANA; + break; + case B_HANKAKU_ZENKAKU: + *code = KEY_ZENKAKU_HANKAKU; + break; + default: return 0; } @@ -378,39 +486,27 @@ class Emacs : public BApplication QuitRequested (void) { struct haiku_app_quit_requested_event rq; + struct haiku_session_manager_reply reply; + int32 reply_type; + haiku_write (APP_QUIT_REQUESTED_EVENT, &rq); - return 0; + + if (read_port (port_emacs_to_session_manager, + &reply_type, &reply, sizeof reply) < B_OK) + /* Return true so the system kills us, since there's no real + alternative if this read fails. */ + return true; + + return reply.quit_reply; } void - RefsReceived (BMessage *msg) + MessageReceived (BMessage *msg) { - struct haiku_refs_event rq; - entry_ref ref; - BEntry entry; - BPath path; - int32 cookie = 0; - int32 x, y; - void *window; - - if ((msg->FindPointer ("window", 0, &window) != B_OK) - || (msg->FindInt32 ("x", 0, &x) != B_OK) - || (msg->FindInt32 ("y", 0, &y) != B_OK)) - return; - - rq.window = window; - rq.x = x; - rq.y = y; - - while (msg->FindRef ("refs", cookie++, &ref) == B_OK) - { - if (entry.SetTo (&ref, 0) == B_OK - && entry.GetPath (&path) == B_OK) - { - rq.ref = strdup (path.Path ()); - haiku_write (REFS_EVENT, &rq); - } - } + if (msg->what == QUIT_APPLICATION) + Quit (); + else + BApplication::MessageReceived (msg); } }; @@ -429,23 +525,29 @@ class EmacsWindow : public BWindow BRect pre_zoom_rect; int x_before_zoom = INT_MIN; int y_before_zoom = INT_MIN; - int fullscreen_p = 0; - int zoomed_p = 0; - int shown_flag = 0; + bool fullscreen_p = false; + bool zoomed_p = false; + bool shown_flag = false; volatile int was_shown_p = 0; bool menu_bar_active_p = false; bool override_redirect_p = false; window_look pre_override_redirect_look; window_feel pre_override_redirect_feel; uint32 pre_override_redirect_workspaces; - pthread_mutex_t menu_update_mutex = PTHREAD_MUTEX_INITIALIZER; - pthread_cond_t menu_update_cv = PTHREAD_COND_INITIALIZER; - bool menu_updated_p = false; + int window_id; + bool *menus_begun = NULL; + enum haiku_z_group z_group; + bool tooltip_p = false; EmacsWindow () : BWindow (BRect (0, 0, 0, 0), "", B_TITLED_WINDOW_LOOK, B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS) { + window_id = current_window_id++; + z_group = Z_GROUP_NONE; + /* This pulse rate is used by scroll bars for repeating a button + action while a button is held down. */ + SetPulseRate (30000); } ~EmacsWindow () @@ -466,9 +568,90 @@ class EmacsWindow : public BWindow if (this->parent) UnparentAndUnlink (); child_frame_lock.Unlock (); + } - pthread_cond_destroy (&menu_update_cv); - pthread_mutex_destroy (&menu_update_mutex); + void + RecomputeFeel (void) + { + if (override_redirect_p || tooltip_p) + SetFeel (kMenuWindowFeel); + else if (parent) + SetFeel (B_FLOATING_SUBSET_WINDOW_FEEL); + else if (z_group == Z_GROUP_ABOVE) + SetFeel (B_FLOATING_ALL_WINDOW_FEEL); + else + SetFeel (B_NORMAL_WINDOW_FEEL); + } + + BRect + CalculateZoomRect (void) + { + BScreen screen (this); + BDeskbar deskbar; + BRect screen_frame; + BRect frame; + BRect deskbar_frame; + BRect window_frame; + BRect decorator_frame; + + if (!screen.IsValid ()) + gui_abort ("Failed to calculate screen rect"); + + screen_frame = frame = screen.Frame (); + deskbar_frame = deskbar.Frame (); + + if (!(modifiers () & B_SHIFT_KEY) && !deskbar.IsAutoHide ()) + { + switch (deskbar.Location ()) + { + case B_DESKBAR_TOP: + frame.top = deskbar_frame.bottom + 2; + break; + + case B_DESKBAR_BOTTOM: + case B_DESKBAR_LEFT_BOTTOM: + case B_DESKBAR_RIGHT_BOTTOM: + frame.bottom = deskbar_frame.top - 2; + break; + + case B_DESKBAR_LEFT_TOP: + if (!deskbar.IsExpanded ()) + frame.top = deskbar_frame.bottom + 2; + else if (!deskbar.IsAlwaysOnTop () + && !deskbar.IsAutoRaise ()) + frame.left = deskbar_frame.right + 2; + break; + + default: + if (deskbar.IsExpanded () + && !deskbar.IsAlwaysOnTop () + && !deskbar.IsAutoRaise ()) + frame.right = deskbar_frame.left - 2; + } + } + + window_frame = Frame (); + decorator_frame = DecoratorFrame (); + + frame.top += (window_frame.top + - decorator_frame.top); + frame.bottom -= (decorator_frame.bottom + - window_frame.bottom); + frame.left += (window_frame.left + - decorator_frame.left); + frame.right -= (decorator_frame.right + - window_frame.right); + + if (frame.top > deskbar_frame.bottom + || frame.bottom < deskbar_frame.top) + { + frame.left = screen_frame.left + (window_frame.left + - decorator_frame.left); + frame.right = screen_frame.right - (decorator_frame.right + - window_frame.right); + } + + return frame; } void @@ -518,12 +701,17 @@ class EmacsWindow : public BWindow void Unparent (void) { + EmacsWindow *parent; + if (!child_frame_lock.Lock ()) gui_abort ("Failed to lock child frame state lock"); - this->SetFeel (B_NORMAL_WINDOW_FEEL); + + parent = this->parent; + this->parent = NULL; + RecomputeFeel (); UpwardsUnSubsetChildren (parent); this->RemoveFromSubset (this); - this->parent = NULL; + if (fullscreen_p) { fullscreen_p = 0; @@ -574,7 +762,7 @@ class EmacsWindow : public BWindow UnparentAndUnlink (); this->parent = window; - this->SetFeel (B_FLOATING_SUBSET_WINDOW_FEEL); + RecomputeFeel (); this->AddToSubset (this); if (!IsHidden () && this->parent) UpwardsSubsetChildren (parent); @@ -661,26 +849,27 @@ class EmacsWindow : public BWindow void MessageReceived (BMessage *msg) { - int32 old_what = 0; - if (msg->WasDropped ()) { - entry_ref ref; BPoint whereto; + int32 windowid; + struct haiku_drag_and_drop_event rq; - if (msg->FindRef ("refs", &ref) == B_OK) - { - msg->what = B_REFS_RECEIVED; - msg->AddPointer ("window", this); - if (msg->FindPoint ("_drop_point_", &whereto) == B_OK) - { - this->ConvertFromScreen (&whereto); - msg->AddInt32 ("x", whereto.x); - msg->AddInt32 ("y", whereto.y); - } - be_app->PostMessage (msg); - msg->SendReply (B_OK); - } + if (msg->FindInt32 ("emacs:window_id", &windowid) == B_OK + && !msg->IsSourceRemote () + && windowid == this->window_id) + return; + + whereto = msg->DropPoint (); + + this->ConvertFromScreen (&whereto); + + rq.window = this; + rq.message = DetachCurrentMessage (); + rq.x = whereto.x; + rq.y = whereto.y; + + haiku_write (DRAG_AND_DROP_EVENT, &rq); } else if (msg->GetPointer ("menuptr")) { @@ -691,47 +880,6 @@ class EmacsWindow : public BWindow haiku_write (MENU_BAR_SELECT_EVENT, &rq); } - else if (msg->what == 'FPSE' - || ((msg->FindInt32 ("old_what", &old_what) == B_OK - && old_what == 'FPSE'))) - { - struct haiku_file_panel_event rq; - BEntry entry; - BPath path; - entry_ref ref; - - rq.ptr = NULL; - - if (msg->FindRef ("refs", &ref) == B_OK && - entry.SetTo (&ref, 0) == B_OK && - entry.GetPath (&path) == B_OK) - { - const char *str_path = path.Path (); - if (str_path) - rq.ptr = strdup (str_path); - } - - if (msg->FindRef ("directory", &ref), - entry.SetTo (&ref, 0) == B_OK && - entry.GetPath (&path) == B_OK) - { - const char *name = msg->GetString ("name"); - const char *str_path = path.Path (); - - if (name) - { - char str_buf[std::strlen (str_path) - + std::strlen (name) + 2]; - snprintf ((char *) &str_buf, - std::strlen (str_path) - + std::strlen (name) + 2, "%s/%s", - str_path, name); - rq.ptr = strdup (str_buf); - } - } - - haiku_write (FILE_PANEL_EVENT, &rq); - } else BWindow::MessageReceived (msg); } @@ -839,39 +987,16 @@ class EmacsWindow : public BWindow } void - MenusBeginning () + MenusBeginning (void) { struct haiku_menu_bar_state_event rq; - int lock_count = 0; - thread_id current_thread = find_thread (NULL); - thread_id window_thread = Thread (); + rq.window = this; - rq.no_lock = false; + if (!menus_begun) + haiku_write (MENU_BAR_OPEN, &rq); + else + *menus_begun = true; - if (window_thread != current_thread) - rq.no_lock = true; - - haiku_write (MENU_BAR_OPEN, &rq); - - if (!rq.no_lock) - { - while (IsLocked ()) - { - ++lock_count; - UnlockLooper (); - } - pthread_mutex_lock (&menu_update_mutex); - while (!menu_updated_p) - pthread_cond_wait (&menu_update_cv, - &menu_update_mutex); - menu_updated_p = false; - pthread_mutex_unlock (&menu_update_mutex); - for (; lock_count; --lock_count) - { - if (!LockLooper ()) - gui_abort ("Failed to lock after cv signal denoting menu update"); - } - } menu_bar_active_p = true; } @@ -907,25 +1032,28 @@ class EmacsWindow : public BWindow haiku_write (MOVE_EVENT, &rq); - if (!child_frame_lock.Lock ()) - gui_abort ("Failed to lock child frame state lock"); - for (struct child_frame *f = subset_windows; - f; f = f->next) - DoMove (f); - child_frame_lock.Unlock (); + CHILD_FRAME_LOCK_INSIDE_LOOPER_CALLBACK + { + for (struct child_frame *f = subset_windows; + f; f = f->next) + DoMove (f); + child_frame_lock.Unlock (); - BWindow::FrameMoved (newPosition); + BWindow::FrameMoved (newPosition); + } } void WorkspacesChanged (uint32_t old, uint32_t n) { - if (!child_frame_lock.Lock ()) - gui_abort ("Failed to lock child frames for changing workspaces"); - for (struct child_frame *f = subset_windows; - f; f = f->next) - DoUpdateWorkspace (f); - child_frame_lock.Unlock (); + CHILD_FRAME_LOCK_INSIDE_LOOPER_CALLBACK + { + for (struct child_frame *f = subset_windows; + f; f = f->next) + DoUpdateWorkspace (f); + + child_frame_lock.Unlock (); + } } void @@ -953,12 +1081,13 @@ class EmacsWindow : public BWindow void Minimize (bool minimized_p) { - BWindow::Minimize (minimized_p); struct haiku_iconification_event rq; + rq.window = this; rq.iconified_p = !parent && minimized_p; - haiku_write (ICONIFICATION, &rq); + + BWindow::Minimize (minimized_p); } void @@ -1010,33 +1139,29 @@ class EmacsWindow : public BWindow Zoom (BPoint o, float w, float h) { struct haiku_zoom_event rq; + BRect rect; rq.window = this; - rq.x = o.x; - rq.y = o.y; - - rq.width = w + 1; - rq.height = h + 1; - if (fullscreen_p) MakeFullscreen (0); - if (o.x != x_before_zoom || - o.y != y_before_zoom) + if (!zoomed_p) { - x_before_zoom = Frame ().left; - y_before_zoom = Frame ().top; pre_zoom_rect = Frame (); - zoomed_p = 1; - haiku_write (ZOOM_EVENT, &rq); + zoomed_p = true; + rect = CalculateZoomRect (); } else { - zoomed_p = 0; - x_before_zoom = y_before_zoom = INT_MIN; + zoomed_p = false; + rect = pre_zoom_rect; } - BWindow::Zoom (o, w, h); + rq.zoomed = zoomed_p; + haiku_write (ZOOM_EVENT, &rq); + + BWindow::Zoom (rect.LeftTop (), BE_RECT_WIDTH (rect) - 1, + BE_RECT_HEIGHT (rect) - 1); } void @@ -1044,11 +1169,8 @@ class EmacsWindow : public BWindow { if (!zoomed_p) return; - zoomed_p = 0; - EmacsMoveTo (pre_zoom_rect.left, pre_zoom_rect.top); - ResizeTo (BE_RECT_WIDTH (pre_zoom_rect) - 1, - BE_RECT_HEIGHT (pre_zoom_rect) - 1); + BWindow::Zoom (); } void @@ -1104,6 +1226,8 @@ class EmacsWindow : public BWindow if (!screen.IsValid ()) gui_abort ("Trying to make a window fullscreen without a screen"); + UnZoom (); + if (make_fullscreen_p == fullscreen_p) return; @@ -1144,6 +1268,8 @@ class EmacsWindow : public BWindow class EmacsMenuBar : public BMenuBar { + bool tracking_p; + public: EmacsMenuBar () : BMenuBar (BRect (0, 0, 0, 0), NULL) { @@ -1162,13 +1288,29 @@ class EmacsMenuBar : public BMenuBar { struct haiku_menu_bar_resize_event rq; rq.window = this->Window (); - rq.height = std::lrint (newHeight); - rq.width = std::lrint (newWidth); + rq.height = std::lrint (newHeight + 1); + rq.width = std::lrint (newWidth + 1); haiku_write (MENU_BAR_RESIZE, &rq); BMenuBar::FrameResized (newWidth, newHeight); } + void + MouseDown (BPoint point) + { + struct haiku_menu_bar_click_event rq; + EmacsWindow *ew = (EmacsWindow *) Window (); + + rq.window = ew; + rq.x = std::lrint (point.x); + rq.y = std::lrint (point.y); + + if (!ew->menu_bar_active_p) + haiku_write (MENU_BAR_CLICK, &rq); + else + BMenuBar::MouseDown (point); + } + void MouseMoved (BPoint point, uint32 transit, const BMessage *msg) { @@ -1189,6 +1331,53 @@ class EmacsMenuBar : public BMenuBar BMenuBar::MouseMoved (point, transit, msg); } + + void + MessageReceived (BMessage *msg) + { + BRect frame; + BPoint pt, l; + EmacsWindow *window; + bool menus_begun; + + if (msg->what == SHOW_MENU_BAR) + { + window = (EmacsWindow *) Window (); + frame = Frame (); + pt = frame.LeftTop (); + l = pt; + menus_begun = false; + Parent ()->ConvertToScreen (&pt); + + window->menus_begun = &menus_begun; + set_mouse_position (pt.x, pt.y); + BMenuBar::MouseDown (l); + window->menus_begun = NULL; + + if (!menus_begun) + msg->SendReply (msg); + else + msg->SendReply (BE_MENU_BAR_OPEN); + } + else if (msg->what == REPLAY_MENU_BAR) + { + window = (EmacsWindow *) Window (); + menus_begun = false; + window->menus_begun = &menus_begun; + + if (msg->FindPoint ("emacs:point", &pt) == B_OK) + BMenuBar::MouseDown (pt); + + window->menus_begun = NULL; + + if (!menus_begun) + msg->SendReply (msg); + else + msg->SendReply (BE_MENU_BAR_OPEN); + } + else + BMenuBar::MessageReceived (msg); + } }; class EmacsView : public BView @@ -1210,8 +1399,7 @@ class EmacsView : public BView #endif BPoint tt_absl_pos; - - color_space cspace; + BMessage *wait_for_release_message = NULL; EmacsView () : BView (BRect (0, 0, 0, 0), "Emacs", B_FOLLOW_NONE, B_WILL_DRAW) { @@ -1220,13 +1408,49 @@ class EmacsView : public BView ~EmacsView () { + if (wait_for_release_message) + { + wait_for_release_message->SendReply (wait_for_release_message); + delete wait_for_release_message; + } + TearDownDoubleBuffering (); + + if (!grab_view_locker.Lock ()) + gui_abort ("Couldn't lock grab view locker"); + if (grab_view == this) + grab_view = NULL; + grab_view_locker.Unlock (); } void - AttachedToWindow (void) + MessageReceived (BMessage *msg) { - cspace = B_RGBA32; + uint32 buttons; + BLooper *looper = Looper (); + + if (msg->what == WAIT_FOR_RELEASE) + { + if (wait_for_release_message) + gui_abort ("Wait for release message already exists"); + + GetMouse (NULL, &buttons, false); + + if (!buttons) + msg->SendReply (msg); + else + wait_for_release_message = looper->DetachCurrentMessage (); + } + else if (msg->what == RELEASE_NOW) + { + if (wait_for_release_message) + wait_for_release_message->SendReply (msg); + + delete wait_for_release_message; + wait_for_release_message = NULL; + } + else + BView::MessageReceived (msg); } #ifdef USE_BE_CAIRO @@ -1310,7 +1534,7 @@ class EmacsView : public BView #endif offscreen_draw_view->RemoveSelf (); delete offscreen_draw_bitmap_1; - offscreen_draw_bitmap_1 = new BBitmap (Frame (), cspace, 1); + offscreen_draw_bitmap_1 = new BBitmap (Frame (), B_RGBA32, 1); if (offscreen_draw_bitmap_1->InitCheck () != B_OK) gui_abort ("Offscreen draw bitmap initialization failed"); @@ -1418,7 +1642,7 @@ class EmacsView : public BView if (offscreen_draw_view) gui_abort ("Failed to lock offscreen view setting up double buffering"); - offscreen_draw_bitmap_1 = new BBitmap (Frame (), cspace, 1); + offscreen_draw_bitmap_1 = new BBitmap (Frame (), B_RGBA32, 1); if (offscreen_draw_bitmap_1->InitCheck () != B_OK) gui_abort ("Failed to init offscreen bitmap"); #ifdef USE_BE_CAIRO @@ -1439,20 +1663,42 @@ class EmacsView : public BView } void - MouseMoved (BPoint point, uint32 transit, const BMessage *msg) + MouseMoved (BPoint point, uint32 transit, const BMessage *drag_msg) { struct haiku_mouse_motion_event rq; + int32 windowid; + EmacsWindow *window; + window = (EmacsWindow *) Window (); rq.just_exited_p = transit == B_EXITED_VIEW; rq.x = point.x; rq.y = point.y; - rq.window = this->Window (); + rq.window = window; rq.time = system_time (); + if (drag_msg && (drag_msg->IsSourceRemote () + || drag_msg->FindInt32 ("emacs:window_id", + &windowid) != B_OK + || windowid != window->window_id)) + rq.dnd_message = true; + else + rq.dnd_message = false; + if (ToolTip ()) ToolTip ()->SetMouseRelativeLocation (BPoint (-(point.x - tt_absl_pos.x), -(point.y - tt_absl_pos.y))); + if (!grab_view_locker.Lock ()) + gui_abort ("Couldn't lock grab view locker"); + + if (grab_view && this != grab_view) + { + grab_view_locker.Unlock (); + return; + } + + grab_view_locker.Unlock (); + if (movement_locker.Lock ()) { haiku_write (MOUSE_MOTION, &rq); @@ -1468,18 +1714,26 @@ class EmacsView : public BView this->GetMouse (&point, &buttons, false); - rq.window = this->Window (); - rq.btn_no = 0; + if (!grab_view_locker.Lock ()) + gui_abort ("Couldn't lock grab view locker"); + if (buttons) + grab_view = this; + grab_view_locker.Unlock (); - if (!(previous_buttons & B_PRIMARY_MOUSE_BUTTON) && - (buttons & B_PRIMARY_MOUSE_BUTTON)) + rq.window = this->Window (); + + if (!(previous_buttons & B_PRIMARY_MOUSE_BUTTON) + && (buttons & B_PRIMARY_MOUSE_BUTTON)) rq.btn_no = 0; - else if (!(previous_buttons & B_SECONDARY_MOUSE_BUTTON) && - (buttons & B_SECONDARY_MOUSE_BUTTON)) + else if (!(previous_buttons & B_SECONDARY_MOUSE_BUTTON) + && (buttons & B_SECONDARY_MOUSE_BUTTON)) rq.btn_no = 2; - else if (!(previous_buttons & B_TERTIARY_MOUSE_BUTTON) && - (buttons & B_TERTIARY_MOUSE_BUTTON)) + else if (!(previous_buttons & B_TERTIARY_MOUSE_BUTTON) + && (buttons & B_TERTIARY_MOUSE_BUTTON)) rq.btn_no = 1; + else + return; + previous_buttons = buttons; rq.x = point.x; @@ -1500,7 +1754,8 @@ class EmacsView : public BView if (mods & B_OPTION_KEY) rq.modifiers |= HAIKU_MODIFIER_SUPER; - SetMouseEventMask (B_POINTER_EVENTS, B_LOCK_WINDOW_FOCUS); + SetMouseEventMask (B_POINTER_EVENTS, (B_LOCK_WINDOW_FOCUS + | B_NO_POINTER_HISTORY)); rq.time = system_time (); haiku_write (BUTTON_DOWN, &rq); @@ -1514,8 +1769,23 @@ class EmacsView : public BView this->GetMouse (&point, &buttons, false); + if (!grab_view_locker.Lock ()) + gui_abort ("Couldn't lock grab view locker"); + if (!buttons) + grab_view = NULL; + grab_view_locker.Unlock (); + + if (!buttons && wait_for_release_message) + { + wait_for_release_message->SendReply (wait_for_release_message); + delete wait_for_release_message; + wait_for_release_message = NULL; + + previous_buttons = buttons; + return; + } + rq.window = this->Window (); - rq.btn_no = 0; if ((previous_buttons & B_PRIMARY_MOUSE_BUTTON) && !(buttons & B_PRIMARY_MOUSE_BUTTON)) @@ -1526,6 +1796,9 @@ class EmacsView : public BView else if ((previous_buttons & B_TERTIARY_MOUSE_BUTTON) && !(buttons & B_TERTIARY_MOUSE_BUTTON)) rq.btn_no = 1; + else + return; + previous_buttons = buttons; rq.x = point.x; @@ -1563,6 +1836,17 @@ class EmacsScrollBar : public BScrollBar float old_value; scroll_bar_info info; + /* True if button events should be passed to the parent. */ + bool handle_button = false; + bool in_overscroll = false; + bool can_overscroll = false; + bool maybe_overscroll = false; + BPoint last_overscroll; + int last_reported_overscroll_value; + int max_value, real_max_value; + int overscroll_start_value; + bigtime_t repeater_start; + EmacsScrollBar (int x, int y, int x1, int y1, bool horizontal_p) : BScrollBar (BRect (x, y, x1, y1), NULL, NULL, 0, 0, horizontal_p ? B_HORIZONTAL : B_VERTICAL) @@ -1571,26 +1855,106 @@ class EmacsScrollBar : public BScrollBar vw->SetResizingMode (B_FOLLOW_NONE); horizontal = horizontal_p; get_scroll_bar_info (&info); + SetSteps (5000, 10000); } void MessageReceived (BMessage *msg) { + int32 portion, range, dragging, value; + float proportion; + if (msg->what == SCROLL_BAR_UPDATE) { - old_value = msg->GetInt32 ("emacs:units", 0); - this->SetRange (0, msg->GetInt32 ("emacs:range", 0)); - this->SetValue (msg->GetInt32 ("emacs:units", 0)); + portion = msg->GetInt32 ("emacs:portion", 0); + range = msg->GetInt32 ("emacs:range", 0); + dragging = msg->GetInt32 ("emacs:dragging", 0); + proportion = ((range <= 0 || portion <= 0) + ? 1.0f : (float) portion / range); + value = msg->GetInt32 ("emacs:units", 0); + can_overscroll = msg->GetBool ("emacs:overscroll", false); + + if (value < 0) + value = 0; + + if (dragging != 1) + { + if (in_overscroll || dragging != -1) + { + /* Set the value to the smallest possible one. + Otherwise, the call to SetRange could lead to + spurious updates. */ + old_value = 0; + SetValue (0); + + /* Unlike on Motif, PORTION isn't included in the total + range of the scroll bar. */ + + SetRange (0, range - portion); + SetProportion (proportion); + max_value = range - portion; + real_max_value = range; + + if (in_overscroll || value > max_value) + value = max_value; + + old_value = roundf (value); + SetValue (old_value); + } + else + { + value = Value (); + + old_value = 0; + SetValue (0); + SetRange (0, range - portion); + SetProportion (proportion); + old_value = value; + SetValue (value); + max_value = range - portion; + real_max_value = range; + } + } } BScrollBar::MessageReceived (msg); } + void + Pulse (void) + { + struct haiku_scroll_bar_part_event rq; + BPoint point; + uint32 buttons; + + if (!dragging) + { + SetFlags (Flags () & ~B_PULSE_NEEDED); + return; + } + + if (repeater_start < system_time ()) + { + GetMouse (&point, &buttons, false); + + if (ButtonRegionFor (current_part).Contains (point)) + { + rq.scroll_bar = this; + rq.window = Window (); + rq.part = current_part; + haiku_write (SCROLL_BAR_PART_EVENT, &rq); + } + } + + BScrollBar::Pulse (); + } + void ValueChanged (float new_value) { struct haiku_scroll_bar_value_event rq; - struct haiku_scroll_bar_part_event part; + + new_value = Value (); if (dragging) { @@ -1599,11 +1963,7 @@ class EmacsScrollBar : public BScrollBar if (dragging > 1) { SetValue (old_value); - - part.scroll_bar = this; - part.window = Window (); - part.part = current_part; - haiku_write (SCROLL_BAR_PART_EVENT, &part); + SetFlags (Flags () | B_PULSE_NEEDED); } else dragging++; @@ -1612,11 +1972,15 @@ class EmacsScrollBar : public BScrollBar return; } - rq.scroll_bar = this; - rq.window = Window (); - rq.position = new_value; + if (new_value != old_value) + { + rq.scroll_bar = this; + rq.window = Window (); + rq.position = new_value; + old_value = new_value; - haiku_write (SCROLL_BAR_VALUE_EVENT, &rq); + haiku_write (SCROLL_BAR_VALUE_EVENT, &rq); + } } BRegion @@ -1685,9 +2049,11 @@ class EmacsScrollBar : public BScrollBar BRegion r; BLooper *looper; BMessage *message; - int32 buttons; + int32 buttons, mods; + BView *parent; looper = Looper (); + message = NULL; if (!looper) GetMouse (&pt, (uint32 *) &buttons, false); @@ -1699,6 +2065,20 @@ class EmacsScrollBar : public BScrollBar GetMouse (&pt, (uint32 *) &buttons, false); } + if (message && (message->FindInt32 ("modifiers", &mods) + == B_OK) + && mods & B_CONTROL_KEY) + { + /* Allow C-mouse-3 to split the window on a scroll bar. */ + handle_button = true; + parent = Parent (); + parent->MouseDown (ConvertToParent (pt)); + + return; + } + + repeater_start = system_time () + 300000; + if (buttons == B_PRIMARY_MOUSE_BUTTON) { r = ButtonRegionFor (HAIKU_SCROLL_BAR_UP_BUTTON); @@ -1725,15 +2105,26 @@ class EmacsScrollBar : public BScrollBar dragging = 1; current_part = HAIKU_SCROLL_BAR_DOWN_BUTTON; + if (Value () == max_value) + { + SetFlags (Flags () | B_PULSE_NEEDED); + dragging = 2; + } + haiku_write (SCROLL_BAR_PART_EVENT, &part); goto out; } + + maybe_overscroll = true; } rq.dragging_p = 1; rq.window = Window (); rq.scroll_bar = this; + SetMouseEventMask (B_POINTER_EVENTS, (B_SUSPEND_VIEW_FOCUS + | B_LOCK_WINDOW_FOCUS)); + haiku_write (SCROLL_BAR_DRAG_EVENT, &rq); out: @@ -1744,12 +2135,26 @@ class EmacsScrollBar : public BScrollBar MouseUp (BPoint pt) { struct haiku_scroll_bar_drag_event rq; + BView *parent; + + in_overscroll = false; + maybe_overscroll = false; + + if (handle_button) + { + handle_button = false; + parent = Parent (); + parent->MouseUp (ConvertToParent (pt)); + + return; + } + rq.dragging_p = 0; rq.scroll_bar = this; rq.window = Window (); haiku_write (SCROLL_BAR_DRAG_EVENT, &rq); - dragging = false; + dragging = 0; BScrollBar::MouseUp (pt); } @@ -1758,7 +2163,13 @@ class EmacsScrollBar : public BScrollBar MouseMoved (BPoint point, uint32 transit, const BMessage *msg) { struct haiku_menu_bar_left_event rq; + struct haiku_scroll_bar_value_event value_event; + int range, diff, value, trough_size; + BRect bounds; BPoint conv; + uint32 buttons; + + GetMouse (NULL, &buttons, false); if (transit == B_EXITED_VIEW) { @@ -1775,6 +2186,72 @@ class EmacsScrollBar : public BScrollBar } } + if (in_overscroll) + { + if (horizontal) + diff = point.x - last_overscroll.x; + else + diff = point.y - last_overscroll.y; + + if (diff < 0) + { + in_overscroll = false; + goto allow; + } + + range = real_max_value; + bounds = Bounds (); + bounds.InsetBy (1.0, 1.0); + value = overscroll_start_value; + trough_size = (horizontal + ? BE_RECT_WIDTH (bounds) + : BE_RECT_HEIGHT (bounds)); + trough_size -= (horizontal + ? BE_RECT_HEIGHT (bounds) + : BE_RECT_WIDTH (bounds)) / 2; + if (info.double_arrows) + trough_size -= (horizontal + ? BE_RECT_HEIGHT (bounds) + : BE_RECT_WIDTH (bounds)) / 2; + + value += ((double) range / trough_size) * diff; + + if (value != last_reported_overscroll_value) + { + last_reported_overscroll_value = value; + + value_event.scroll_bar = this; + value_event.window = Window (); + value_event.position = value; + + haiku_write (SCROLL_BAR_VALUE_EVENT, &value_event); + return; + } + } + else if (can_overscroll + && (buttons == B_PRIMARY_MOUSE_BUTTON) + && maybe_overscroll) + { + value = Value (); + + if (value >= max_value) + { + BScrollBar::MouseMoved (point, transit, msg); + + if (value == Value ()) + { + overscroll_start_value = value; + in_overscroll = true; + last_overscroll = point; + last_reported_overscroll_value = value; + + MouseMoved (point, transit, msg); + return; + } + } + } + + allow: BScrollBar::MouseMoved (point, transit, msg); } }; @@ -1794,7 +2271,7 @@ class EmacsTitleMenuItem : public BMenuItem menu->PushState (); menu->SetFont (be_bold_font); - BView_SetHighColorForVisibleBell (menu, 0); + menu->SetHighColor (ui_color (B_MENU_ITEM_TEXT_COLOR)); BMenuItem::DrawContent (); menu->PopState (); } @@ -1922,16 +2399,715 @@ class EmacsPopUpMenu : public BPopUpMenu } }; +class EmacsFontPreviewDialog : public BWindow +{ + BStringView text_view; + BMessenger preview_source; + BFont *current_font; + bool is_visible; + + void + DoLayout (void) + { + float width, height; + + text_view.GetPreferredSize (&width, &height); + text_view.ResizeTo (width - 1, height - 1); + + SetSizeLimits (width, width, height, height); + ResizeTo (width - 1, height - 1); + } + + bool + QuitRequested (void) + { + preview_source.SendMessage (QUIT_PREVIEW_DIALOG); + + return false; + } + + void + MessageReceived (BMessage *message) + { + int32 family, style; + uint32 flags; + font_family name; + font_style sname; + status_t rc; + const char *size_name; + int size; + + if (message->what == SET_FONT_INDICES) + { + size_name = message->FindString ("emacs:size"); + + if (message->FindInt32 ("emacs:family", &family) != B_OK + || message->FindInt32 ("emacs:style", &style) != B_OK) + return; + + rc = get_font_family (family, &name, &flags); + + if (rc != B_OK) + return; + + rc = get_font_style (name, style, &sname, &flags); + + if (rc != B_OK) + return; + + if (current_font) + delete current_font; + + current_font = new BFont; + current_font->SetFamilyAndStyle (name, sname); + + if (size_name && strlen (size_name)) + { + size = atoi (size_name); + current_font->SetSize (size); + } + + text_view.SetFont (current_font); + DoLayout (); + return; + } + + BWindow::MessageReceived (message); + } + +public: + + EmacsFontPreviewDialog (BWindow *target) + : BWindow (BRect (45, 45, 500, 300), + "Preview font", + B_FLOATING_WINDOW_LOOK, + B_MODAL_APP_WINDOW_FEEL, + B_NOT_ZOOMABLE | B_NOT_RESIZABLE), + text_view (BRect (0, 0, 0, 0), + NULL, "The quick brown fox " + "jumped over the lazy dog"), + preview_source (target), + current_font (NULL) + { + AddChild (&text_view); + DoLayout (); + } + + ~EmacsFontPreviewDialog (void) + { + text_view.RemoveSelf (); + + if (current_font) + delete current_font; + } +}; + +class DualLayoutView : public BView +{ + BScrollView *view_1; + BView *view_2; + + void + FrameResized (float new_width, float new_height) + { + BRect frame; + float width, height; + + frame = Frame (); + + view_2->GetPreferredSize (&width, &height); + + view_1->MoveTo (0, 0); + view_1->ResizeTo (BE_RECT_WIDTH (frame), + BE_RECT_HEIGHT (frame) - height); + view_2->MoveTo (2, BE_RECT_HEIGHT (frame) - height); + view_2->ResizeTo (BE_RECT_WIDTH (frame) - 4, height); + + BView::FrameResized (new_width, new_height); + } + + /* This is called by the BSplitView. */ + BSize + MinSize (void) + { + float width, height; + BSize size_1; + + size_1 = view_1->MinSize (); + view_2->GetPreferredSize (&width, &height); + + return BSize (std::max (size_1.width, width), + std::max (size_1.height, height)); + } + +public: + DualLayoutView (BScrollView *first, BView *second) : BView (NULL, B_FRAME_EVENTS), + view_1 (first), + view_2 (second) + { + FrameResized (801, 801); + } +}; + +class EmacsFontSelectionDialog : public BWindow +{ + BView basic_view; + BCheckBox preview_checkbox; + BSplitView split_view; + BListView font_family_pane; + BListView font_style_pane; + BScrollView font_family_scroller; + BScrollView font_style_scroller; + DualLayoutView style_view; + BObjectList all_families; + BObjectList all_styles; + BButton cancel_button, ok_button; + BTextControl size_entry; + port_id comm_port; + bool allow_monospace_only; + int pending_selection_idx; + EmacsFontPreviewDialog *preview; + + void + ShowPreview (void) + { + if (!preview) + { + preview = new EmacsFontPreviewDialog (this); + preview->Show (); + + UpdatePreview (); + } + } + + void + UpdatePreview (void) + { + int family, style; + BMessage message; + BMessenger messenger (preview); + + family = font_family_pane.CurrentSelection (); + style = font_style_pane.CurrentSelection (); + + message.what = SET_FONT_INDICES; + message.AddInt32 ("emacs:family", family); + message.AddInt32 ("emacs:style", style); + + message.AddString ("emacs:size", + size_entry.Text ()); + + messenger.SendMessage (&message); + } + + void + HidePreview (void) + { + if (preview) + { + if (preview->LockLooper ()) + preview->Quit (); + /* I hope this works. */ + else + delete preview; + + preview = NULL; + } + } + + void + UpdateStylesForIndex (int idx) + { + int n, i; + uint32 flags; + font_family family; + font_style style; + BStringItem *item; + + n = all_styles.CountItems (); + + font_style_pane.MakeEmpty (); + all_styles.MakeEmpty (); + + if (get_font_family (idx, &family, &flags) == B_OK) + { + n = count_font_styles (family); + + for (i = 0; i < n; ++i) + { + if (get_font_style (family, i, &style, &flags) == B_OK) + item = new BStringItem (style); + else + item = new BStringItem (""); + + font_style_pane.AddItem (item); + all_styles.AddItem (item); + } + } + + if (pending_selection_idx >= 0) + { + font_style_pane.Select (pending_selection_idx); + font_style_pane.ScrollToSelection (); + } + + pending_selection_idx = -1; + UpdateForSelectedStyle (); + } + + bool + QuitRequested (void) + { + struct font_selection_dialog_message rq; + + rq.cancel = true; + write_port (comm_port, 0, &rq, sizeof rq); + + return false; + } + + void + UpdateForSelectedStyle (void) + { + int style = font_style_pane.CurrentSelection (); + + if (style < 0) + ok_button.SetEnabled (false); + else + ok_button.SetEnabled (true); + + if (style >= 0 && preview) + UpdatePreview (); + } + + void + MessageReceived (BMessage *msg) + { + const char *text; + int idx; + struct font_selection_dialog_message rq; + + if (msg->what == FONT_FAMILY_SELECTED) + { + idx = font_family_pane.CurrentSelection (); + UpdateStylesForIndex (idx); + } + else if (msg->what == FONT_STYLE_SELECTED) + UpdateForSelectedStyle (); + else if (msg->what == B_OK + && font_style_pane.CurrentSelection () >= 0) + { + text = size_entry.Text (); + + rq.cancel = false; + rq.family_idx = font_family_pane.CurrentSelection (); + rq.style_idx = font_style_pane.CurrentSelection (); + rq.size = atoi (text); + rq.size_specified = rq.size > 0 || strlen (text); + + write_port (comm_port, 0, &rq, sizeof rq); + } + else if (msg->what == B_CANCEL) + { + rq.cancel = true; + + write_port (comm_port, 0, &rq, sizeof rq); + } + else if (msg->what == SET_PREVIEW_DIALOG) + { + if (preview_checkbox.Value () == B_CONTROL_OFF) + HidePreview (); + else + ShowPreview (); + } + else if (msg->what == QUIT_PREVIEW_DIALOG) + { + preview_checkbox.SetValue (B_CONTROL_OFF); + HidePreview (); + } + else if (msg->what == UPDATE_PREVIEW_DIALOG) + { + if (preview) + UpdatePreview (); + } + + BWindow::MessageReceived (msg); + } + +public: + + ~EmacsFontSelectionDialog (void) + { + if (preview) + { + if (preview->LockLooper ()) + preview->Quit (); + /* I hope this works. */ + else + delete preview; + } + + font_family_pane.MakeEmpty (); + font_style_pane.MakeEmpty (); + + font_family_pane.RemoveSelf (); + font_style_pane.RemoveSelf (); + preview_checkbox.RemoveSelf (); + style_view.RemoveSelf (); + font_family_scroller.RemoveSelf (); + font_style_scroller.RemoveSelf (); + cancel_button.RemoveSelf (); + ok_button.RemoveSelf (); + size_entry.RemoveSelf (); + basic_view.RemoveSelf (); + + if (comm_port >= B_OK) + delete_port (comm_port); + } + + EmacsFontSelectionDialog (bool monospace_only, + int initial_family_idx, + int initial_style_idx, + int initial_size) + : BWindow (BRect (0, 0, 500, 500), + "Select font from list", + B_TITLED_WINDOW_LOOK, + B_MODAL_APP_WINDOW_FEEL, 0), + basic_view (NULL, 0), + preview_checkbox ("Show preview", "Show preview", + new BMessage (SET_PREVIEW_DIALOG)), + font_family_pane (BRect (0, 0, 0, 0), NULL, + B_SINGLE_SELECTION_LIST, + B_FOLLOW_ALL_SIDES), + font_style_pane (BRect (0, 0, 0, 0), NULL, + B_SINGLE_SELECTION_LIST, + B_FOLLOW_ALL_SIDES), + font_family_scroller (NULL, &font_family_pane, + B_FOLLOW_LEFT | B_FOLLOW_TOP, + 0, false, true), + font_style_scroller (NULL, &font_style_pane, + B_FOLLOW_ALL_SIDES, + B_SUPPORTS_LAYOUT, false, true), + style_view (&font_style_scroller, &preview_checkbox), + all_families (20, true), + all_styles (20, true), + cancel_button ("Cancel", "Cancel", + new BMessage (B_CANCEL)), + ok_button ("OK", "OK", new BMessage (B_OK)), + size_entry (NULL, "Size:", NULL, + new BMessage (UPDATE_PREVIEW_DIALOG)), + allow_monospace_only (monospace_only), + pending_selection_idx (initial_style_idx), + preview (NULL) + { + BStringItem *family_item; + int i, n_families; + font_family name; + uint32 flags, c; + BMessage *selection; + BTextView *size_text; + char format_buffer[4]; + + AddChild (&basic_view); + + basic_view.AddChild (&split_view); + basic_view.AddChild (&cancel_button); + basic_view.AddChild (&ok_button); + basic_view.AddChild (&size_entry); + split_view.AddChild (&font_family_scroller, 0.7); + split_view.AddChild (&style_view, 0.3); + style_view.AddChild (&font_style_scroller); + style_view.AddChild (&preview_checkbox); + + basic_view.SetViewUIColor (B_PANEL_BACKGROUND_COLOR); + style_view.SetViewUIColor (B_PANEL_BACKGROUND_COLOR); + + FrameResized (801, 801); + UpdateForSelectedStyle (); + + selection = new BMessage (FONT_FAMILY_SELECTED); + font_family_pane.SetSelectionMessage (selection); + selection = new BMessage (FONT_STYLE_SELECTED); + font_style_pane.SetSelectionMessage (selection); + selection = new BMessage (B_OK); + font_style_pane.SetInvocationMessage (selection); + selection = new BMessage (UPDATE_PREVIEW_DIALOG); + size_entry.SetModificationMessage (selection); + + comm_port = create_port (1, "font dialog port"); + + n_families = count_font_families (); + + for (i = 0; i < n_families; ++i) + { + if (get_font_family (i, &name, &flags) == B_OK) + { + family_item = new BStringItem (name); + + all_families.AddItem (family_item); + font_family_pane.AddItem (family_item); + + family_item->SetEnabled (!allow_monospace_only + || flags & B_IS_FIXED); + } + else + { + family_item = new BStringItem (""); + + all_families.AddItem (family_item); + font_family_pane.AddItem (family_item); + } + } + + if (initial_family_idx >= 0) + { + font_family_pane.Select (initial_family_idx); + font_family_pane.ScrollToSelection (); + } + + size_text = size_entry.TextView (); + + for (c = 0; c <= 47; ++c) + size_text->DisallowChar (c); + + for (c = 58; c <= 127; ++c) + size_text->DisallowChar (c); + + if (initial_size > 0 && initial_size < 1000) + { + sprintf (format_buffer, "%d", initial_size); + size_entry.SetText (format_buffer); + } + } + + void + FrameResized (float new_width, float new_height) + { + BRect frame; + float ok_height, ok_width; + float cancel_height, cancel_width; + float size_width, size_height; + float bone; + int max_height; + + ok_button.GetPreferredSize (&ok_width, &ok_height); + cancel_button.GetPreferredSize (&cancel_width, + &cancel_height); + size_entry.GetPreferredSize (&size_width, &size_height); + + max_height = std::max (std::max (ok_height, cancel_height), + size_height); + + SetSizeLimits (cancel_width + ok_width + size_width + 6, + 65535, max_height + 64, 65535); + frame = Frame (); + + basic_view.ResizeTo (BE_RECT_WIDTH (frame), BE_RECT_HEIGHT (frame)); + split_view.ResizeTo (BE_RECT_WIDTH (frame) - 1, + BE_RECT_HEIGHT (frame) - 4 - max_height); + + bone = BE_RECT_HEIGHT (frame) - 2 - max_height / 2; + + ok_button.MoveTo ((BE_RECT_WIDTH (frame) + - 4 - cancel_width - ok_width), + bone - ok_height / 2); + cancel_button.MoveTo (BE_RECT_WIDTH (frame) - 2 - cancel_width, + bone - cancel_height / 2); + size_entry.MoveTo (2, bone - size_height / 2); + + ok_button.ResizeTo (ok_width, ok_height); + cancel_button.ResizeTo (cancel_width, cancel_height); + size_entry.ResizeTo (std::max (size_width, + BE_RECT_WIDTH (frame) / 4), + size_height); + } + + void + WaitForChoice (struct font_selection_dialog_message *msg, + void (*process_pending_signals_function) (void), + bool (*should_quit_function) (void)) + { + int32 reply_type; + struct object_wait_info infos[2]; + ssize_t status; + + infos[0].object = port_application_to_emacs; + infos[0].type = B_OBJECT_TYPE_PORT; + infos[0].events = B_EVENT_READ; + + infos[1].object = comm_port; + infos[1].type = B_OBJECT_TYPE_PORT; + infos[1].events = B_EVENT_READ; + + while (true) + { + status = wait_for_objects (infos, 2); + + if (status < B_OK) + continue; + + if (infos[1].events & B_EVENT_READ) + { + if (read_port (comm_port, &reply_type, + msg, sizeof *msg) >= B_OK) + return; + + goto cancel; + } + + if (infos[0].events & B_EVENT_READ) + process_pending_signals_function (); + + if (should_quit_function ()) + goto cancel; + + infos[0].events = B_EVENT_READ; + infos[1].events = B_EVENT_READ; + } + + cancel: + msg->cancel = true; + return; + } + + status_t + InitCheck (void) + { + return comm_port >= B_OK ? B_OK : comm_port; + } +}; + +class EmacsFilePanelCallbackLooper : public BLooper +{ + port_id comm_port; + + void + MessageReceived (BMessage *msg) + { + const char *str_path, *name; + char *file_name, *str_buf; + BEntry entry; + BPath path; + entry_ref ref; + int32 old_what; + + if (msg->what == FILE_PANEL_SELECTION + || ((msg->FindInt32 ("old_what", &old_what) == B_OK + && old_what == FILE_PANEL_SELECTION))) + { + file_name = NULL; + + if (msg->FindRef ("refs", &ref) == B_OK + && entry.SetTo (&ref, 0) == B_OK + && entry.GetPath (&path) == B_OK) + { + str_path = path.Path (); + + if (str_path) + file_name = strdup (str_path); + } + else if (msg->FindRef ("directory", &ref) == B_OK + && entry.SetTo (&ref, 0) == B_OK + && entry.GetPath (&path) == B_OK) + { + name = msg->GetString ("name"); + str_path = path.Path (); + + if (name) + { + str_buf = (char *) alloca (std::strlen (str_path) + + std::strlen (name) + 2); + snprintf (str_buf, std::strlen (str_path) + + std::strlen (name) + 2, "%s/%s", + str_path, name); + file_name = strdup (str_buf); + } + } + + write_port (comm_port, 0, &file_name, sizeof file_name); + } + + BLooper::MessageReceived (msg); + } + +public: + EmacsFilePanelCallbackLooper (void) : BLooper () + { + comm_port = create_port (1, "file panel port"); + } + + ~EmacsFilePanelCallbackLooper (void) + { + delete_port (comm_port); + } + + char * + ReadFileName (void (*process_pending_signals_function) (void)) + { + object_wait_info infos[2]; + ssize_t status; + int32 reply_type; + char *file_name; + + file_name = NULL; + + infos[0].object = port_application_to_emacs; + infos[0].type = B_OBJECT_TYPE_PORT; + infos[0].events = B_EVENT_READ; + + infos[1].object = comm_port; + infos[1].type = B_OBJECT_TYPE_PORT; + infos[1].events = B_EVENT_READ; + + while (true) + { + status = wait_for_objects (infos, 2); + + if (status == B_INTERRUPTED || status == B_WOULD_BLOCK) + continue; + + if (infos[0].events & B_EVENT_READ) + process_pending_signals_function (); + + if (infos[1].events & B_EVENT_READ) + { + status = read_port (comm_port, + &reply_type, &file_name, + sizeof file_name); + + if (status < B_OK) + file_name = NULL; + + goto out; + } + + infos[0].events = B_EVENT_READ; + infos[1].events = B_EVENT_READ; + } + + out: + return file_name; + } + + status_t + InitCheck (void) + { + return comm_port >= B_OK ? B_OK : comm_port; + } +}; + static int32 start_running_application (void *data) { + Emacs *app = (Emacs *) data; + haiku_io_init_in_app_thread (); - if (!((Emacs *) data)->Lock ()) + if (!app->Lock ()) gui_abort ("Failed to lock application"); - ((Emacs *) data)->Run (); - ((Emacs *) data)->Unlock (); + app->Run (); + app->Unlock (); return 0; } @@ -2001,44 +3177,58 @@ BBitmap_dimensions (void *bitmap, int *left, int *top, *mono_p = (((BBitmap *) bitmap)->ColorSpace () == B_GRAY1); } +static void +wait_for_exit_of_app_thread (void) +{ + status_t ret; + + be_app->PostMessage (QUIT_APPLICATION); + wait_for_thread (app_thread, &ret); +} + /* Set up an application and return it. If starting the application thread fails, abort Emacs. */ void * BApplication_setup (void) { - if (be_app) - return be_app; thread_id id; Emacs *app; + if (be_app) + return be_app; + app = new Emacs; app->Unlock (); + if ((id = spawn_thread (start_running_application, "Emacs app thread", B_DEFAULT_MEDIA_PRIORITY, app)) < 0) gui_abort ("spawn_thread failed"); resume_thread (id); - app_thread = id; + + atexit (wait_for_exit_of_app_thread); return app; } /* Set up and return a window with its view put in VIEW. */ void * -BWindow_new (void *_view) +BWindow_new (void **view) { - BWindow *window = new (std::nothrow) EmacsWindow; - BView **v = (BView **) _view; + BWindow *window; + BView *vw; + + window = new (std::nothrow) EmacsWindow; if (!window) { - *v = NULL; + *view = NULL; return window; } - BView *vw = new (std::nothrow) EmacsView; + vw = new (std::nothrow) EmacsView; if (!vw) { - *v = NULL; + *view = NULL; window->LockLooper (); window->Quit (); return NULL; @@ -2052,15 +3242,17 @@ BWindow_new (void *_view) the first time. */ window->UnlockLooper (); window->AddChild (vw); - *v = vw; + *view = vw; return window; } void BWindow_quit (void *window) { - ((BWindow *) window)->LockLooper (); - ((BWindow *) window)->Quit (); + BWindow *w = (BWindow *) window; + + w->LockLooper (); + w->Quit (); } /* Set WINDOW's offset to X, Y. */ @@ -2143,15 +3335,18 @@ BWindow_activate (void *window) /* Return the pixel dimensions of the main screen in WIDTH and HEIGHT. */ void -BScreen_px_dim (int *width, int *height) +be_get_screen_dimensions (int *width, int *height) { BScreen screen; + BRect frame; + if (!screen.IsValid ()) gui_abort ("Invalid screen"); - BRect frame = screen.Frame (); - *width = frame.right - frame.left; - *height = frame.bottom - frame.top; + frame = screen.Frame (); + + *width = 1 + frame.right - frame.left; + *height = 1 + frame.bottom - frame.top; } /* Resize VIEW to WIDTH, HEIGHT. */ @@ -2268,14 +3463,22 @@ BView_move_frame (void *view, int x, int y, int x1, int y1) vw->UnlockLooper (); } +/* DRAGGING can either be 0 (which means to update everything), 1 + (which means to update nothing), or -1 (which means to update only + the thumb size and range). */ + void -BView_scroll_bar_update (void *sb, int portion, int whole, int position) +BView_scroll_bar_update (void *sb, int portion, int whole, int position, + int dragging, bool can_overscroll) { BScrollBar *bar = (BScrollBar *) sb; BMessage msg = BMessage (SCROLL_BAR_UPDATE); BMessenger mr = BMessenger (bar); msg.AddInt32 ("emacs:range", whole); msg.AddInt32 ("emacs:units", position); + msg.AddInt32 ("emacs:portion", portion); + msg.AddInt32 ("emacs:dragging", dragging); + msg.AddBool ("emacs:overscroll", can_overscroll); mr.SendMessage (&msg); } @@ -2373,42 +3576,6 @@ BWindow_center_on_screen (void *window) w->CenterOnScreen (); } -/* Tell VIEW it has been clicked at X by Y. */ -void -BView_mouse_down (void *view, int x, int y) -{ - BView *vw = (BView *) view; - if (vw->LockLooper ()) - { - vw->MouseDown (BPoint (x, y)); - vw->UnlockLooper (); - } -} - -/* Tell VIEW the mouse has been released at X by Y. */ -void -BView_mouse_up (void *view, int x, int y) -{ - BView *vw = (BView *) view; - if (vw->LockLooper ()) - { - vw->MouseUp (BPoint (x, y)); - vw->UnlockLooper (); - } -} - -/* Tell VIEW that the mouse has moved to Y by Y. */ -void -BView_mouse_moved (void *view, int x, int y, uint32_t transit) -{ - BView *vw = (BView *) view; - if (vw->LockLooper ()) - { - vw->MouseMoved (BPoint (x, y), transit, NULL); - vw->UnlockLooper (); - } -} - /* Import fringe bitmap (short array, low bit rightmost) BITS into BITMAP using the B_GRAY1 colorspace. */ void @@ -2558,11 +3725,12 @@ BWindow_change_decoration (void *window, int decorate_p) void BWindow_set_tooltip_decoration (void *window) { - BWindow *w = (BWindow *) window; + EmacsWindow *w = (EmacsWindow *) window; if (!w->LockLooper ()) gui_abort ("Failed to lock window while setting ttip decoration"); + w->tooltip_p = true; + w->RecomputeFeel (); w->SetLook (B_BORDERED_WINDOW_LOOK); - w->SetFeel (kMenuWindowFeel); w->SetFlags (B_NOT_ZOOMABLE | B_NOT_MINIMIZABLE | B_AVOID_FRONT @@ -2596,20 +3764,6 @@ BView_emacs_delete (void *view) delete vw; } -/* Return the current workspace. */ -uint32_t -haiku_current_workspace (void) -{ - return current_workspace (); -} - -/* Return a bitmask consisting of workspaces WINDOW is on. */ -uint32_t -BWindow_workspaces (void *window) -{ - return ((BWindow *) window)->Workspaces (); -} - /* Create a popup menu. */ void * BPopUpMenu_new (const char *name) @@ -2758,7 +3912,7 @@ BMenu_run (void *menu, int x, int y, next_time = process_pending_signals_function (); if (next_time.tv_nsec < 0) - timeout = 100000; + timeout = 10000000000; else timeout = (next_time.tv_sec * 1000000 + next_time.tv_nsec / 1000); @@ -2766,7 +3920,8 @@ BMenu_run (void *menu, int x, int y, if ((stat = wait_for_objects_etc ((object_wait_info *) &infos, 3, B_RELATIVE_TIMEOUT, timeout)) < B_OK) { - if (stat == B_INTERRUPTED || stat == B_TIMED_OUT) + if (stat == B_INTERRUPTED || stat == B_TIMED_OUT + || stat == B_WOULD_BLOCK) continue; else gui_abort ("Failed to wait for popup"); @@ -2774,7 +3929,7 @@ BMenu_run (void *menu, int x, int y, if (infos[0].events & B_EVENT_READ) { - if (!haiku_read_with_timeout (&type, buf, 200, 1000000, true)) + while (!haiku_read_with_timeout (&type, buf, 200, 0, true)) { switch (type) { @@ -3047,25 +4202,32 @@ BAlert_delete (void *alert) delete (BAlert *) alert; } -/* Place the resolution of the monitor in DPI in RSSX and RSSY. */ +/* Place the resolution of the monitor in DPI in X_OUT and Y_OUT. */ void -BScreen_res (double *rrsx, double *rrsy) +be_get_display_resolution (double *x_out, double *y_out) { BScreen s (B_MAIN_SCREEN_ID); + monitor_info i; + double x_inches, y_inches; + BRect frame; + if (!s.IsValid ()) gui_abort ("Invalid screen for resolution checks"); - monitor_info i; if (s.GetMonitorInfo (&i) == B_OK) { - *rrsx = (double) i.width / (double) 2.54; - *rrsy = (double) i.height / (double) 2.54; - } - else - { - *rrsx = 72.27; - *rrsy = 72.27; + frame = s.Frame (); + + x_inches = (double) i.width * 25.4; + y_inches = (double) i.height * 25.4; + + *x_out = (double) BE_RECT_WIDTH (frame) / x_inches; + *y_out = (double) BE_RECT_HEIGHT (frame) / y_inches; + return; } + + *x_out = 72.0; + *y_out = 72.0; } /* Add WINDOW to OTHER_WINDOW's subset and parent it to @@ -3096,6 +4258,8 @@ void be_get_version_string (char *version, int len) { std::strncpy (version, "Unknown Haiku release", len - 1); + version[len - 1] = '\0'; + BPath path; if (find_directory (B_BEOS_LIB_DIRECTORY, &path) == B_OK) { @@ -3109,7 +4273,10 @@ be_get_version_string (char *version, int len) && appFileInfo.GetVersionInfo (&versionInfo, B_APP_VERSION_KIND) == B_OK && versionInfo.short_info[0] != '\0') - std::strncpy (version, versionInfo.short_info, len - 1); + { + std::strncpy (version, versionInfo.short_info, len - 1); + version[len - 1] = '\0'; + } } } @@ -3118,24 +4285,35 @@ int be_get_display_planes (void) { color_space space = dpy_color_space; + BScreen screen; + if (space == B_NO_COLOR_SPACE) { - BScreen screen; /* This is actually a very slow operation. */ if (!screen.IsValid ()) gui_abort ("Invalid screen"); + space = dpy_color_space = screen.ColorSpace (); } - if (space == B_RGB32 || space == B_RGB24) - return 24; - if (space == B_RGB16) - return 16; - if (space == B_RGB15) - return 15; - if (space == B_CMAP8) - return 8; + switch (space) + { + case B_RGB32: + case B_RGB24: + return 24; + case B_RGB16: + return 16; + case B_RGB15: + return 15; + case B_CMAP8: + case B_GRAY8: + return 8; + case B_GRAY1: + return 1; + + default: + gui_abort ("Bad colorspace for screen"); + } - gui_abort ("Bad colorspace for screen"); /* https://www.haiku-os.org/docs/api/classBScreen.html says a valid screen can't be anything else. */ return -1; @@ -3145,28 +4323,58 @@ be_get_display_planes (void) int be_get_display_color_cells (void) { + BScreen screen; color_space space = dpy_color_space; + if (space == B_NO_COLOR_SPACE) { - BScreen screen; if (!screen.IsValid ()) gui_abort ("Invalid screen"); + space = dpy_color_space = screen.ColorSpace (); } - if (space == B_RGB32 || space == B_RGB24) - return 1677216; - if (space == B_RGB16) - return 65536; - if (space == B_RGB15) - return 32768; - if (space == B_CMAP8) - return 256; + switch (space) + { + case B_RGB32: + case B_RGB24: + return 16777216; + case B_RGB16: + return 65536; + case B_RGB15: + return 32768; + case B_CMAP8: + case B_GRAY8: + return 256; + case B_GRAY1: + return 2; + + default: + gui_abort ("Bad colorspace for screen"); + } - gui_abort ("Bad colorspace for screen"); return -1; } +/* Return whether or not the current display is only capable of + producing grayscale colors. */ +bool +be_is_display_grayscale (void) +{ + BScreen screen; + color_space space = dpy_color_space; + + if (space == B_NO_COLOR_SPACE) + { + if (!screen.IsValid ()) + gui_abort ("Invalid screen"); + + space = dpy_color_space = screen.ColorSpace (); + } + + return space == B_GRAY8 || space == B_GRAY1; +} + /* Warp the pointer to X by Y. */ void be_warp_pointer (int x, int y) @@ -3258,111 +4466,60 @@ EmacsView_double_buffered_p (void *vw) return db_p; } -struct popup_file_dialog_data -{ - BMessage *msg; - BFilePanel *panel; - BEntry *entry; -}; - -static void -unwind_popup_file_dialog (void *ptr) -{ - struct popup_file_dialog_data *data = - (struct popup_file_dialog_data *) ptr; - BFilePanel *panel = data->panel; - delete panel; - delete data->entry; - delete data->msg; -} - -static void -be_popup_file_dialog_safe_set_target (BFilePanel *dialog, BWindow *window) -{ - dialog->SetTarget (BMessenger (window)); -} - /* Popup a file dialog. */ char * -be_popup_file_dialog (int open_p, const char *default_dir, int must_match_p, int dir_only_p, - void *window, const char *save_text, const char *prompt, - void (*block_input_function) (void), - void (*unblock_input_function) (void), - void (*maybe_quit_function) (void)) +be_popup_file_dialog (int open_p, const char *default_dir, int must_match_p, + int dir_only_p, void *window, const char *save_text, + const char *prompt, + void (*process_pending_signals_function) (void)) { - specpdl_ref idx = c_specpdl_idx_from_cxx (); - /* setjmp/longjmp is UB with automatic objects. */ - block_input_function (); - BWindow *w = (BWindow *) window; - uint32_t mode = dir_only_p ? B_DIRECTORY_NODE : B_FILE_NODE | B_DIRECTORY_NODE; - BEntry *path = new BEntry; - BMessage *msg = new BMessage ('FPSE'); - BFilePanel *panel = new BFilePanel (open_p ? B_OPEN_PANEL : B_SAVE_PANEL, - NULL, NULL, mode); + BWindow *panel_window; + BEntry path; + BMessage msg (FILE_PANEL_SELECTION); + BFilePanel panel (open_p ? B_OPEN_PANEL : B_SAVE_PANEL, + NULL, NULL, (dir_only_p + ? B_DIRECTORY_NODE + : B_FILE_NODE | B_DIRECTORY_NODE)); + char *file_name; + EmacsFilePanelCallbackLooper *looper; - struct popup_file_dialog_data dat; - dat.entry = path; - dat.msg = msg; - dat.panel = panel; + looper = new EmacsFilePanelCallbackLooper; + + if (looper->InitCheck () < B_OK) + { + delete looper; + return NULL; + } - record_c_unwind_protect_from_cxx (unwind_popup_file_dialog, &dat); if (default_dir) { - if (path->SetTo (default_dir, 0) != B_OK) + if (path.SetTo (default_dir, 0) != B_OK) default_dir = NULL; } - panel->SetMessage (msg); + panel_window = panel.Window (); + if (default_dir) - panel->SetPanelDirectory (path); + panel.SetPanelDirectory (&path); + if (save_text) - panel->SetSaveText (save_text); - panel->SetHideWhenDone (0); - panel->Window ()->SetTitle (prompt); - be_popup_file_dialog_safe_set_target (panel, w); + panel.SetSaveText (save_text); - panel->Show (); - unblock_input_function (); + panel_window->SetTitle (prompt); + panel_window->SetFeel (B_MODAL_APP_WINDOW_FEEL); - void *buf = alloca (200); - while (1) - { - enum haiku_event_type type; - char *ptr = NULL; + panel.SetHideWhenDone (false); + panel.SetTarget (BMessenger (looper)); + panel.SetMessage (&msg); + panel.Show (); - if (!haiku_read_with_timeout (&type, buf, 200, 1000000, false)) - { - block_input_function (); - if (type != FILE_PANEL_EVENT) - haiku_write (type, buf); - else if (!ptr) - ptr = (char *) ((struct haiku_file_panel_event *) buf)->ptr; - unblock_input_function (); + looper->Run (); + file_name = looper->ReadFileName (process_pending_signals_function); - maybe_quit_function (); - } + if (looper->Lock ()) + looper->Quit (); - ssize_t b_s; - block_input_function (); - haiku_read_size (&b_s, false); - if (!b_s || ptr || panel->Window ()->IsHidden ()) - { - c_unbind_to_nil_from_cxx (idx); - unblock_input_function (); - return ptr; - } - unblock_input_function (); - } -} - -void -be_app_quit (void) -{ - if (be_app) - { - while (!be_app->Lock ()); - be_app->Quit (); - } + return file_name; } /* Zoom WINDOW. */ @@ -3389,20 +4546,18 @@ EmacsWindow_unzoom (void *window) w->UnZoom (); } -/* Move the pointer into MBAR and start tracking. */ -void +/* Move the pointer into MBAR and start tracking. Return whether the + menu bar was opened correctly. */ +bool BMenuBar_start_tracking (void *mbar) { EmacsMenuBar *mb = (EmacsMenuBar *) mbar; - if (!mb->LockLooper ()) - gui_abort ("Couldn't lock menubar"); - BRect frame = mb->Frame (); - BPoint pt = frame.LeftTop (); - BPoint l = pt; - mb->Parent ()->ConvertToScreen (&pt); - set_mouse_position (pt.x, pt.y); - mb->MouseDown (l); - mb->UnlockLooper (); + BMessenger messenger (mb); + BMessage reply; + + messenger.SendMessage (SHOW_MENU_BAR, &reply); + + return reply.what == BE_MENU_BAR_OPEN; } #ifdef HAVE_NATIVE_IMAGE_API @@ -3584,17 +4739,6 @@ be_get_display_screens (void) } /* Set the minimum width the user can resize WINDOW to. */ -void -BWindow_set_min_size (void *window, int width, int height) -{ - BWindow *w = (BWindow *) window; - - if (!w->LockLooper ()) - gui_abort ("Failed to lock window looper setting min size"); - w->SetSizeLimits (width, -1, height, -1); - w->UnlockLooper (); -} - /* Synchronize WINDOW's connection to the App Server. */ void BWindow_sync (void *window) @@ -3664,9 +4808,8 @@ BWindow_set_override_redirect (void *window, bool override_redirect_p) if (override_redirect_p && !w->override_redirect_p) { w->override_redirect_p = true; - w->pre_override_redirect_feel = w->Feel (); w->pre_override_redirect_look = w->Look (); - w->SetFeel (kMenuWindowFeel); + w->RecomputeFeel (); w->SetLook (B_NO_BORDER_WINDOW_LOOK); w->pre_override_redirect_workspaces = w->Workspaces (); w->SetWorkspaces (B_ALL_WORKSPACES); @@ -3674,8 +4817,8 @@ BWindow_set_override_redirect (void *window, bool override_redirect_p) else if (w->override_redirect_p) { w->override_redirect_p = false; - w->SetFeel (w->pre_override_redirect_feel); w->SetLook (w->pre_override_redirect_look); + w->RecomputeFeel (); w->SetWorkspaces (w->pre_override_redirect_workspaces); } @@ -3704,12 +4847,238 @@ be_find_setting (const char *name) } void -EmacsWindow_signal_menu_update_complete (void *window) +BMessage_delete (void *message) +{ + delete (BMessage *) message; +} + +static int32 +be_drag_message_thread_entry (void *thread_data) +{ + BMessenger *messenger; + BMessage reply; + + messenger = (BMessenger *) thread_data; + messenger->SendMessage (WAIT_FOR_RELEASE, &reply); + + return 0; +} + +bool +be_drag_message (void *view, void *message, bool allow_same_view, + void (*block_input_function) (void), + void (*unblock_input_function) (void), + void (*process_pending_signals_function) (void), + bool (*should_quit_function) (void)) +{ + EmacsView *vw = (EmacsView *) view; + EmacsWindow *window = (EmacsWindow *) vw->Window (); + BMessage *msg = (BMessage *) message; + BMessage wait_for_release; + BMessenger messenger (vw); + BMessage cancel_message (CANCEL_DROP); + struct object_wait_info infos[2]; + ssize_t stat; + + block_input_function (); + + if (!allow_same_view && + (msg->ReplaceInt32 ("emacs:window_id", window->window_id) + == B_NAME_NOT_FOUND)) + msg->AddInt32 ("emacs:window_id", window->window_id); + + if (!vw->LockLooper ()) + gui_abort ("Failed to lock view looper for drag"); + + vw->DragMessage (msg, BRect (0, 0, 0, 0)); + vw->UnlockLooper (); + + infos[0].object = port_application_to_emacs; + infos[0].type = B_OBJECT_TYPE_PORT; + infos[0].events = B_EVENT_READ; + + infos[1].object = spawn_thread (be_drag_message_thread_entry, + "Drag waiter thread", + B_DEFAULT_MEDIA_PRIORITY, + (void *) &messenger); + infos[1].type = B_OBJECT_TYPE_THREAD; + infos[1].events = B_EVENT_INVALID; + unblock_input_function (); + + if (infos[1].object < B_OK) + return false; + + block_input_function (); + resume_thread (infos[1].object); + unblock_input_function (); + + drag_and_drop_in_progress = true; + + while (true) + { + block_input_function (); + stat = wait_for_objects ((struct object_wait_info *) &infos, 2); + unblock_input_function (); + + if (stat == B_INTERRUPTED || stat == B_TIMED_OUT + || stat == B_WOULD_BLOCK) + continue; + + if (stat < B_OK) + gui_abort ("Failed to wait for drag"); + + if (infos[0].events & B_EVENT_READ) + process_pending_signals_function (); + + if (should_quit_function ()) + { + /* Do the best we can to prevent something from being + dropped, since Haiku doesn't provide a way to actually + cancel drag-and-drop. */ + if (vw->LockLooper ()) + { + vw->DragMessage (&cancel_message, BRect (0, 0, 0, 0)); + vw->UnlockLooper (); + } + + messenger.SendMessage (CANCEL_DROP); + drag_and_drop_in_progress = false; + return true; + } + + if (infos[1].events & B_EVENT_INVALID) + { + drag_and_drop_in_progress = false; + return false; + } + + infos[0].events = B_EVENT_READ; + infos[1].events = B_EVENT_INVALID; + } +} + +bool +be_drag_and_drop_in_progress (void) +{ + return drag_and_drop_in_progress; +} + +/* Replay the menu bar click event EVENT. Return whether or not the + menu bar actually opened. */ +bool +be_replay_menu_bar_event (void *menu_bar, + struct haiku_menu_bar_click_event *event) +{ + BMenuBar *m = (BMenuBar *) menu_bar; + BMessenger messenger (m); + BMessage reply, msg (REPLAY_MENU_BAR); + + msg.AddPoint ("emacs:point", BPoint (event->x, event->y)); + messenger.SendMessage (&msg, &reply); + return reply.what == BE_MENU_BAR_OPEN; +} + +void +BWindow_set_z_group (void *window, enum haiku_z_group z_group) { EmacsWindow *w = (EmacsWindow *) window; - pthread_mutex_lock (&w->menu_update_mutex); - w->menu_updated_p = true; - pthread_cond_signal (&w->menu_update_cv); - pthread_mutex_unlock (&w->menu_update_mutex); + if (w->LockLooper ()) + { + if (w->z_group != z_group) + { + w->z_group = z_group; + w->RecomputeFeel (); + + if (w->z_group == Z_GROUP_BELOW) + w->SetFlags (w->Flags () | B_AVOID_FRONT); + else + w->SetFlags (w->Flags () & ~B_AVOID_FRONT); + } + + w->UnlockLooper (); + } +} + +int +be_get_ui_color (const char *name, uint32_t *color) +{ + color_which which; + rgb_color rgb; + + which = which_ui_color (name); + + if (which == B_NO_COLOR) + return 1; + + rgb = ui_color (which); + *color = (rgb.blue | rgb.green << 8 + | rgb.red << 16 | 255 << 24); + + return 0; +} + +bool +be_select_font (void (*process_pending_signals_function) (void), + bool (*should_quit_function) (void), + haiku_font_family_or_style *family, + haiku_font_family_or_style *style, + int *size, bool allow_monospace_only, + int initial_family, int initial_style, + int initial_size) +{ + EmacsFontSelectionDialog *dialog; + struct font_selection_dialog_message msg; + uint32 flags; + font_family family_buffer; + font_style style_buffer; + + dialog = new EmacsFontSelectionDialog (allow_monospace_only, + initial_family, initial_style, + initial_size); + dialog->CenterOnScreen (); + + if (dialog->InitCheck () < B_OK) + { + dialog->Quit (); + return false; + } + + dialog->Show (); + dialog->WaitForChoice (&msg, process_pending_signals_function, + should_quit_function); + + if (!dialog->LockLooper ()) + gui_abort ("Failed to lock font selection dialog looper"); + dialog->Quit (); + + if (msg.cancel) + return false; + + if (get_font_family (msg.family_idx, + &family_buffer, &flags) != B_OK + || get_font_style (family_buffer, msg.style_idx, + &style_buffer, &flags) != B_OK) + return false; + + memcpy (family, family_buffer, sizeof *family); + memcpy (style, style_buffer, sizeof *style); + *size = msg.size_specified ? msg.size : -1; + + return true; +} + +void +BWindow_set_sticky (void *window, bool sticky) +{ + BWindow *w = (BWindow *) window; + + if (w->LockLooper ()) + { + w->SetFlags (sticky ? (w->Flags () + | B_SAME_POSITION_IN_ALL_WORKSPACES) + : w->Flags () & ~B_SAME_POSITION_IN_ALL_WORKSPACES); + + w->UnlockLooper (); + } } diff --git a/src/haiku_support.h b/src/haiku_support.h index fb86372c4ff..5ded9300d8a 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -38,21 +38,28 @@ along with GNU Emacs. If not, see . */ enum haiku_cursor { - CURSOR_ID_NO_CURSOR = 12, - CURSOR_ID_RESIZE_NORTH = 15, - CURSOR_ID_RESIZE_EAST = 16, - CURSOR_ID_RESIZE_SOUTH = 17, - CURSOR_ID_RESIZE_WEST = 18, - CURSOR_ID_RESIZE_NORTH_EAST = 19, - CURSOR_ID_RESIZE_NORTH_WEST = 20, - CURSOR_ID_RESIZE_SOUTH_EAST = 21, - CURSOR_ID_RESIZE_SOUTH_WEST = 22, - CURSOR_ID_RESIZE_NORTH_SOUTH = 23, - CURSOR_ID_RESIZE_EAST_WEST = 24, + CURSOR_ID_NO_CURSOR = 12, + CURSOR_ID_RESIZE_NORTH = 15, + CURSOR_ID_RESIZE_EAST = 16, + CURSOR_ID_RESIZE_SOUTH = 17, + CURSOR_ID_RESIZE_WEST = 18, + CURSOR_ID_RESIZE_NORTH_EAST = 19, + CURSOR_ID_RESIZE_NORTH_WEST = 20, + CURSOR_ID_RESIZE_SOUTH_EAST = 21, + CURSOR_ID_RESIZE_SOUTH_WEST = 22, + CURSOR_ID_RESIZE_NORTH_SOUTH = 23, + CURSOR_ID_RESIZE_EAST_WEST = 24, CURSOR_ID_RESIZE_NORTH_EAST_SOUTH_WEST = 25, CURSOR_ID_RESIZE_NORTH_WEST_SOUTH_EAST = 26 }; +enum haiku_z_group + { + Z_GROUP_ABOVE, + Z_GROUP_NONE, + Z_GROUP_BELOW, + }; + enum haiku_alert_type { HAIKU_EMPTY_ALERT = 0, @@ -80,13 +87,13 @@ enum haiku_event_type SCROLL_BAR_DRAG_EVENT, WHEEL_MOVE_EVENT, MENU_BAR_RESIZE, + MENU_BAR_CLICK, MENU_BAR_OPEN, MENU_BAR_SELECT_EVENT, MENU_BAR_CLOSE, - FILE_PANEL_EVENT, MENU_BAR_HELP_EVENT, ZOOM_EVENT, - REFS_EVENT, + DRAG_AND_DROP_EVENT, APP_QUIT_REQUESTED_EVENT, DUMMY_EVENT, MENU_BAR_LEFT @@ -113,12 +120,11 @@ struct haiku_expose_event int height; }; -struct haiku_refs_event +struct haiku_drag_and_drop_event { void *window; int x, y; - /* Free this with free! */ - char *ref; + void *message; }; struct haiku_app_quit_requested_event @@ -131,10 +137,13 @@ struct haiku_dummy_event char dummy; }; -#define HAIKU_MODIFIER_ALT (1) -#define HAIKU_MODIFIER_CTRL (1 << 1) -#define HAIKU_MODIFIER_SHIFT (1 << 2) -#define HAIKU_MODIFIER_SUPER (1 << 3) +enum haiku_modifier_specification + { + HAIKU_MODIFIER_ALT = 1, + HAIKU_MODIFIER_CTRL = (1 << 1), + HAIKU_MODIFIER_SHIFT = (1 << 2), + HAIKU_MODIFIER_SUPER = (1 << 3), + }; struct haiku_key_event { @@ -160,6 +169,7 @@ struct haiku_mouse_motion_event int x; int y; bigtime_t time; + bool dnd_message; }; struct haiku_menu_bar_left_event @@ -168,6 +178,12 @@ struct haiku_menu_bar_left_event int x, y; }; +struct haiku_menu_bar_click_event +{ + void *window; + int x, y; +}; + struct haiku_button_event { void *window; @@ -205,11 +221,6 @@ struct haiku_menu_bar_select_event void *ptr; }; -struct haiku_file_panel_event -{ - void *ptr; -}; - struct haiku_menu_bar_help_event { void *window; @@ -221,21 +232,22 @@ struct haiku_menu_bar_help_event struct haiku_zoom_event { void *window; - int x; - int y; - int width; - int height; + bool zoomed; }; -#define FSPEC_FAMILY 1 -#define FSPEC_STYLE (1 << 1) -#define FSPEC_SLANT (1 << 2) -#define FSPEC_WEIGHT (1 << 3) -#define FSPEC_SPACING (1 << 4) -#define FSPEC_WANTED (1 << 5) -#define FSPEC_NEED_ONE_OF (1 << 6) -#define FSPEC_WIDTH (1 << 7) -#define FSPEC_LANGUAGE (1 << 8) +enum haiku_font_specification + { + FSPEC_FAMILY = 1, + FSPEC_STYLE = 1 << 1, + FSPEC_SLANT = 1 << 2, + FSPEC_WEIGHT = 1 << 3, + FSPEC_SPACING = 1 << 4, + FSPEC_WANTED = 1 << 5, + FSPEC_NEED_ONE_OF = 1 << 6, + FSPEC_WIDTH = 1 << 7, + FSPEC_LANGUAGE = 1 << 8, + FSPEC_INDICES = 1 << 9, + }; typedef char haiku_font_family_or_style[64]; @@ -269,27 +281,81 @@ enum haiku_font_language MAX_LANGUAGE /* This isn't a language. */ }; +enum haiku_font_weight + { + NO_WEIGHT = -1, + HAIKU_THIN = 0, + HAIKU_EXTRALIGHT = 40, + HAIKU_LIGHT = 50, + HAIKU_SEMI_LIGHT = 75, + HAIKU_REGULAR = 100, + HAIKU_SEMI_BOLD = 180, + HAIKU_BOLD = 200, + HAIKU_EXTRA_BOLD = 205, + HAIKU_BOOK = 400, + HAIKU_HEAVY = 800, + HAIKU_ULTRA_HEAVY = 900, + HAIKU_BLACK = 1000, + HAIKU_MEDIUM = 2000, + }; + struct haiku_font_pattern { + /* Bitmask indicating which fields are set. */ int specified; - struct haiku_font_pattern *next; - /* The next two fields are only temporarily used during the font - discovery process! Do not rely on them being correct outside - BFont_find. */ - struct haiku_font_pattern *last; - struct haiku_font_pattern *next_family; - haiku_font_family_or_style family; - haiku_font_family_or_style style; - int weight; - int mono_spacing_p; - int want_chars_len; - int need_one_of_len; - enum haiku_font_slant slant; - enum haiku_font_width width; - enum haiku_font_language language; - uint32_t *wanted_chars; - uint32_t *need_one_of; + /* The next font in this list. */ + struct haiku_font_pattern *next; + + /* The last font in the list during font lookup. */ + struct haiku_font_pattern *last; + + /* The next font in the list whose family differs from this one. + Only valid during font lookup. */ + struct haiku_font_pattern *next_family; + + /* The family of the font. */ + haiku_font_family_or_style family; + + /* The style of the font. */ + haiku_font_family_or_style style; + + /* Whether or the font is monospace. */ + int mono_spacing_p; + + /* The slant of the font. */ + enum haiku_font_slant slant; + + /* The width of the font. */ + enum haiku_font_width width; + + /* The language of the font. Used during font lookup. */ + enum haiku_font_language language; + + /* The weight of the font. */ + enum haiku_font_weight weight; + + /* List of characters that must be present in the font for the match + to succeed. */ + int *wanted_chars; + + /* The number of characters in `wanted_chars'. */ + int want_chars_len; + + /* List of characters. The font must fullfill at least one of + them for the match to succeed. */ + int *need_one_of; + + /* The number of characters in `need_one_of'. */ + int need_one_of_len; + + /* The index of the family of the font this pattern represents. */ + int family_index; + + /* The index of the style of the font this pattern represents. */ + int style_index; + + /* Temporary field used during font enumeration. */ int oblique_seen_p; }; @@ -330,24 +396,12 @@ struct haiku_menu_bar_resize_event struct haiku_menu_bar_state_event { void *window; - bool no_lock; }; -#define HAIKU_THIN 0 -#define HAIKU_ULTRALIGHT 20 -#define HAIKU_EXTRALIGHT 40 -#define HAIKU_LIGHT 50 -#define HAIKU_SEMI_LIGHT 75 -#define HAIKU_REGULAR 100 -#define HAIKU_SEMI_BOLD 180 -#define HAIKU_BOLD 200 -#define HAIKU_EXTRA_BOLD 205 -#define HAIKU_ULTRA_BOLD 210 -#define HAIKU_BOOK 400 -#define HAIKU_HEAVY 800 -#define HAIKU_ULTRA_HEAVY 900 -#define HAIKU_BLACK 1000 -#define HAIKU_MEDIUM 2000 +struct haiku_session_manager_reply +{ + bool quit_reply; +}; #ifdef __cplusplus /* Haiku's built in Height and Width functions for calculating @@ -375,7 +429,6 @@ struct haiku_menu_bar_state_event to bind to the specpdl and handle quitting correctly. */ #ifdef __cplusplus - #if SIZE_MAX > 0xffffffff #define WRAP_SPECPDL_REF 1 #endif @@ -397,596 +450,255 @@ extern "C" #include #ifdef __cplusplus - typedef void *haiku; +typedef void *haiku; - extern void - haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel); - - extern unsigned long - haiku_get_pixel (haiku bitmap, int x, int y); +extern void haiku_put_pixel (haiku, int, int, unsigned long); +extern unsigned long haiku_get_pixel (haiku, int, int); #endif - extern port_id port_application_to_emacs; - extern port_id port_popup_menu_to_emacs; - - extern void haiku_io_init (void); - extern void haiku_io_init_in_app_thread (void); - - extern void - haiku_read_size (ssize_t *len, bool popup_menu_p); - - extern int - haiku_read (enum haiku_event_type *type, void *buf, ssize_t len); - - extern int - haiku_read_with_timeout (enum haiku_event_type *type, void *buf, ssize_t len, - time_t timeout, bool popup_menu_p); - - extern int - haiku_write (enum haiku_event_type type, void *buf); - - extern int - haiku_write_without_signal (enum haiku_event_type type, void *buf, - bool popup_menu_p); - - extern void - rgb_color_hsl (uint32_t rgb, double *h, double *s, double *l); - - extern void - hsl_color_rgb (double h, double s, double l, uint32_t *rgb); - - extern void * - BBitmap_new (int width, int height, int mono_p); - - extern void * - BBitmap_data (void *bitmap); - - extern int - BBitmap_convert (void *bitmap, void **new_bitmap); - - extern void - BBitmap_free (void *bitmap); - - extern void - BBitmap_dimensions (void *bitmap, int *left, int *top, - int *right, int *bottom, int32_t *bytes_per_row, - int *mono_p); - - extern void * - BApplication_setup (void); - - extern void * - BWindow_new (void *view); - - extern void - BWindow_quit (void *window); - - extern void - BWindow_set_offset (void *window, int x, int y); - - extern void - BWindow_iconify (void *window); - - extern void - BWindow_set_visible (void *window, int visible_p); - - extern void - BFont_close (void *font); - - extern void - BFont_dat (void *font, int *px_size, int *min_width, int *max_width, - int *avg_width, int *height, int *space_width, int *ascent, - int *descent, int *underline_position, int *underline_thickness); - - extern int - BFont_have_char_p (void *font, int32_t chr); - - extern int - BFont_have_char_block (void *font, int32_t beg, int32_t end); - - extern void - BFont_char_bounds (void *font, const char *mb_str, int *advance, - int *lb, int *rb); - - extern void - BFont_nchar_bounds (void *font, const char *mb_str, int *advance, - int *lb, int *rb, int32_t n); - - extern void - BWindow_retitle (void *window, const char *title); - - extern void - BWindow_resize (void *window, int width, int height); - - extern void - BWindow_activate (void *window); - - extern void - BView_StartClip (void *view); - - extern void - BView_EndClip (void *view); - - extern void - BView_SetHighColor (void *view, uint32_t color); - - extern void - BView_SetHighColorForVisibleBell (void *view, uint32_t color); - - extern void - BView_SetLowColor (void *view, uint32_t color); - - extern void - BView_SetPenSize (void *view, int u); - - extern void - BView_SetFont (void *view, void *font); - - extern void - BView_MovePenTo (void *view, int x, int y); - - extern void - BView_DrawString (void *view, const char *chr, ptrdiff_t len); - - extern void - BView_DrawChar (void *view, char chr); - - extern void - BView_FillRectangle (void *view, int x, int y, int width, int height); - - extern void - BView_FillRectangleAbs (void *view, int x, int y, int x1, int y1); - - extern void - BView_FillTriangle (void *view, int x1, int y1, - int x2, int y2, int x3, int y3); - - extern void - BView_StrokeRectangle (void *view, int x, int y, int width, int height); - - extern void - BView_SetViewColor (void *view, uint32_t color); - - extern void - BView_ClipToRect (void *view, int x, int y, int width, int height); - - extern void - BView_ClipToInverseRect (void *view, int x, int y, int width, int height); - - extern void - BView_StrokeLine (void *view, int sx, int sy, int tx, int ty); - - extern void - BView_CopyBits (void *view, int x, int y, int width, int height, - int tox, int toy, int towidth, int toheight); - - extern void - BView_DrawBitmap (void *view, void *bitmap, int x, int y, - int width, int height, int vx, int vy, int vwidth, - int vheight); - - extern void - BView_DrawBitmapWithEraseOp (void *view, void *bitmap, int x, - int y, int width, int height); - - extern void - BView_DrawMask (void *src, void *view, - int x, int y, int width, int height, - int vx, int vy, int vwidth, int vheight, - uint32_t color); - - extern void - BView_InvertRect (void *view, int x, int y, int width, int height); - - extern void * - BBitmap_transform_bitmap (void *bitmap, void *mask, uint32_t m_color, - double rot, int desw, int desh); - - extern void - BScreen_px_dim (int *width, int *height); - - extern void - BView_resize_to (void *view, int width, int height); - - /* Functions for creating and freeing cursors. */ - extern void * - BCursor_create_default (void); - - extern void * - BCursor_from_id (enum haiku_cursor cursor); - - extern void * - BCursor_create_modeline (void); - - extern void * - BCursor_create_i_beam (void); - - extern void * - BCursor_create_progress_cursor (void); - - extern void * - BCursor_create_grab (void); - - extern void - BCursor_delete (void *cursor); - - extern void - BView_set_view_cursor (void *view, void *cursor); - - extern void - BWindow_Flush (void *window); - - extern void * - BScrollBar_make_for_view (void *view, int horizontal_p, - int x, int y, int x1, int y1, - void *scroll_bar_ptr); - - extern void - BScrollBar_delete (void *sb); - - extern void - BView_move_frame (void *view, int x, int y, int x1, int y1); - - extern void - BView_scroll_bar_update (void *sb, int portion, int whole, int position); - - extern int - BScrollBar_default_size (int horizontal_p); - - extern void - BView_invalidate (void *view); - - extern void - BView_draw_lock (void *view, bool invalidate_region, - int x, int y, int width, int height); - - extern void - BView_invalidate_region (void *view, int x, int y, int width, int height); - - extern void - BView_draw_unlock (void *view); - - extern void - BWindow_center_on_screen (void *window); - - extern void - BView_mouse_moved (void *view, int x, int y, uint32_t transit); - - extern void - BView_mouse_down (void *view, int x, int y); - - extern void - BView_mouse_up (void *view, int x, int y); - - extern void - BBitmap_import_fringe_bitmap (void *bitmap, unsigned short *bits, - int wd, int h); - - extern void - BBitmap_import_mono_bits (void *bitmap, void *bits, int wd, int h); - - extern void - haiku_font_pattern_free (struct haiku_font_pattern *pt); - - extern struct haiku_font_pattern * - BFont_find (struct haiku_font_pattern *pt); - - extern int - BFont_open_pattern (struct haiku_font_pattern *pat, void **font, float size); - - extern void - BFont_populate_fixed_family (struct haiku_font_pattern *ptn); - - extern void - BFont_populate_plain_family (struct haiku_font_pattern *ptn); - - extern void - BView_publish_scroll_bar (void *view, int x, int y, int width, int height); - - extern void - BView_forget_scroll_bar (void *view, int x, int y, int width, int height); - - extern bool - BView_inside_scroll_bar (void *view, int x, int y); - - extern void - BView_get_mouse (void *view, int *x, int *y); - - extern void - BView_convert_to_screen (void *view, int *x, int *y); - - extern void - BView_convert_from_screen (void *view, int *x, int *y); - - extern void - BWindow_change_decoration (void *window, int decorate_p); - - extern void - BWindow_set_tooltip_decoration (void *window); - - extern void - BWindow_set_avoid_focus (void *window, int avoid_focus_p); - - extern void - BView_emacs_delete (void *view); - - extern uint32_t - haiku_current_workspace (void); - - extern uint32_t - BWindow_workspaces (void *window); - - extern void * - BPopUpMenu_new (const char *name); - - extern void - BMenu_add_item (void *menu, const char *label, void *ptr, bool enabled_p, - bool marked_p, bool mbar_p, void *mbw_ptr, const char *key, - const char *help); - - extern void - BMenu_add_separator (void *menu); - - extern void * - BMenu_new_submenu (void *menu, const char *label, bool enabled_p); - - extern void * - BMenu_new_menu_bar_submenu (void *menu, const char *label); - - extern int - BMenu_count_items (void *menu); - - extern void * - BMenu_item_at (void *menu, int idx); - - extern void * - BMenu_run (void *menu, int x, int y, - void (*run_help_callback) (void *, void *), - void (*block_input_function) (void), - void (*unblock_input_function) (void), - struct timespec (*process_pending_signals_function) (void), - void *run_help_callback_data); - - extern void - BPopUpMenu_delete (void *menu); - - extern void * - BMenuBar_new (void *view); - - extern void - BMenu_delete_all (void *menu); - - extern void - BMenuBar_delete (void *menubar); - - extern void - BMenu_item_set_label (void *item, const char *label); - - extern void * - BMenu_item_get_menu (void *item); - - extern void - BMenu_delete_from (void *menu, int start, int count); - - extern void - haiku_ring_bell (void); - - extern void * - BAlert_new (const char *text, enum haiku_alert_type type); - - extern void * - BAlert_add_button (void *alert, const char *text); - - extern void - BAlert_set_offset_spacing (void *alert); - - extern int32 - BAlert_go (void *alert, - void (*block_input_function) (void), - void (*unblock_input_function) (void), - void (*process_pending_signals_function) (void)); - - extern void - BButton_set_enabled (void *button, int enabled_p); - - extern void - BView_set_tooltip (void *view, const char *tooltip); - - extern void - BAlert_delete (void *alert); - - extern void - BScreen_res (double *rrsx, double *rrsy); - - extern void - EmacsWindow_parent_to (void *window, void *other_window); - - extern void - EmacsWindow_unparent (void *window); - - extern int - BFont_string_width (void *font, const char *utf8); - - extern void - be_get_version_string (char *version, int len); - - extern int - be_get_display_planes (void); - - extern int - be_get_display_color_cells (void); - - extern void - be_warp_pointer (int x, int y); - - extern void - EmacsWindow_move_weak_child (void *window, void *child, int xoff, int yoff); - - extern void - EmacsView_set_up_double_buffering (void *vw); - - extern void - EmacsView_disable_double_buffering (void *vw); - - extern void - EmacsView_flip_and_blit (void *vw); - - extern int - EmacsView_double_buffered_p (void *vw); - - extern char * - be_popup_file_dialog (int open_p, const char *default_dir, int must_match_p, - int dir_only_p, void *window, const char *save_text, - const char *prompt, - void (*block_input_function) (void), - void (*unblock_input_function) (void), - void (*maybe_quit_function) (void)); - - extern void - record_c_unwind_protect_from_cxx (void (*) (void *), void *); - - extern specpdl_ref c_specpdl_idx_from_cxx (void); - - extern void - c_unbind_to_nil_from_cxx (specpdl_ref idx); - - extern void - BWindow_zoom (void *window); - - extern void - EmacsWindow_make_fullscreen (void *window, int fullscreen_p); - - extern void - EmacsWindow_unzoom (void *window); +extern port_id port_application_to_emacs; +extern port_id port_popup_menu_to_emacs; +extern port_id port_emacs_to_session_manager; + +extern void haiku_io_init (void); +extern void haiku_io_init_in_app_thread (void); + +extern void haiku_read_size (ssize_t *, bool); + +extern int haiku_read (enum haiku_event_type *, void *, ssize_t); +extern int haiku_read_with_timeout (enum haiku_event_type *, void *, ssize_t, + bigtime_t, bool); +extern int haiku_write (enum haiku_event_type, void *); +extern int haiku_write_without_signal (enum haiku_event_type, void *, bool); + +extern void rgb_color_hsl (uint32_t, double *, double *, double *); +extern void hsl_color_rgb (double, double, double, uint32_t *); + +extern void *BBitmap_new (int, int, int); +extern void *BBitmap_data (void *); +extern int BBitmap_convert (void *, void **); + +extern void BBitmap_free (void *); + +extern void BBitmap_dimensions (void *, int *, int *, int *, int *, + int32_t *, int *); +extern void *BApplication_setup (void); +extern void *BWindow_new (void **); +extern void BWindow_quit (void *); + +extern void BWindow_set_offset (void *, int, int); +extern void BWindow_iconify (void *); +extern void BWindow_set_visible (void *, int); +extern void BWindow_retitle (void *, const char *); +extern void BWindow_resize (void *, int, int); +extern void BWindow_activate (void *); +extern void BWindow_center_on_screen (void *); +extern void BWindow_change_decoration (void *, int); +extern void BWindow_set_tooltip_decoration (void *); +extern void BWindow_set_avoid_focus (void *, int); +extern void BWindow_zoom (void *); +extern void BWindow_set_size_alignment (void *, int, int); +extern void BWindow_sync (void *); +extern void BWindow_send_behind (void *, void *); +extern bool BWindow_is_active (void *); +extern void BWindow_set_override_redirect (void *, bool); +extern void BWindow_dimensions (void *, int *, int *); +extern void BWindow_set_z_group (void *, enum haiku_z_group); +extern void BWindow_set_sticky (void *, bool); +extern void BWindow_Flush (void *); + +extern void BFont_close (void *); +extern void BFont_metrics (void *, int *, int *, int *, int *, + int *, int *, int *, int *, int *, int *); +extern int BFont_have_char_p (void *, int32_t); +extern int BFont_have_char_block (void *, int32_t, int32_t); +extern void BFont_char_bounds (void *, const char *, int *, int *, int *); +extern void BFont_nchar_bounds (void *, const char *, int *, int *, + int *, int32_t); +extern struct haiku_font_pattern *BFont_find (struct haiku_font_pattern *); + +extern void BView_StartClip (void *); +extern void BView_EndClip (void *); +extern void BView_SetHighColor (void *, uint32_t); +extern void BView_SetLowColor (void *, uint32_t); +extern void BView_SetPenSize (void *, int); +extern void BView_SetFont (void *, void *); +extern void BView_MovePenTo (void *, int, int); +extern void BView_DrawString (void *, const char *, ptrdiff_t); +extern void BView_DrawChar (void *, char); +extern void BView_FillRectangle (void *, int, int, int, int); +extern void BView_FillRectangleAbs (void *, int, int, int, int); +extern void BView_FillTriangle (void *, int, int, int, int, int, int); +extern void BView_StrokeRectangle (void *, int, int, int, int); +extern void BView_SetViewColor (void *, uint32_t); +extern void BView_ClipToRect (void *, int, int, int, int); +extern void BView_ClipToInverseRect (void *, int, int, int, int); +extern void BView_StrokeLine (void *, int, int, int, int); +extern void BView_CopyBits (void *, int, int, int, int, int, int, int, int); +extern void BView_InvertRect (void *, int, int, int, int); +extern void BView_DrawBitmap (void *, void *, int, int, int, int, int, int, + int, int); +extern void BView_DrawBitmapWithEraseOp (void *, void *, int, int, int, int); +extern void BView_DrawMask (void *, void *, int, int, int, int, int, int, + int, int, uint32_t); + +extern void BView_resize_to (void *, int, int); +extern void BView_set_view_cursor (void *, void *); +extern void BView_move_frame (void *, int, int, int, int); +extern void BView_scroll_bar_update (void *, int, int, int, int, bool); + +extern void *BBitmap_transform_bitmap (void *, void *, uint32_t, double, + int, int); + +extern void be_get_display_resolution (double *, double *); +extern void be_get_screen_dimensions (int *, int *); + +/* Functions for creating and freeing cursors. */ +extern void *BCursor_create_default (void); +extern void *BCursor_from_id (enum haiku_cursor); +extern void *BCursor_create_modeline (void); +extern void *BCursor_create_i_beam (void); +extern void *BCursor_create_progress_cursor (void); +extern void *BCursor_create_grab (void); +extern void BCursor_delete (void *); + +extern void *BScrollBar_make_for_view (void *, int, int, int, int, int, void *); +extern void BScrollBar_delete (void *); +extern int BScrollBar_default_size (int); + +extern void BView_invalidate (void *); +extern void BView_draw_lock (void *, bool, int, int, int, int); +extern void BView_invalidate_region (void *, int, int, int, int); +extern void BView_draw_unlock (void *); + +extern void BBitmap_import_fringe_bitmap (void *, unsigned short *, int, int); +extern void BBitmap_import_mono_bits (void *, void *, int, int); + +extern void haiku_font_pattern_free (struct haiku_font_pattern *); + +extern int BFont_open_pattern (struct haiku_font_pattern *, void **, float); +extern void BFont_populate_fixed_family (struct haiku_font_pattern *); +extern void BFont_populate_plain_family (struct haiku_font_pattern *); + +extern void BView_publish_scroll_bar (void *, int, int, int, int); +extern void BView_forget_scroll_bar (void *, int, int, int, int); +extern bool BView_inside_scroll_bar (void *, int, int); +extern void BView_get_mouse (void *, int *, int *); +extern void BView_convert_to_screen (void *, int *, int *); +extern void BView_convert_from_screen (void *, int *, int *); + +extern void BView_emacs_delete (void *); + +extern void *BPopUpMenu_new (const char *); + +extern void BMenu_add_item (void *, const char *, void *, bool, + bool, bool, void *, const char *, + const char *); +extern void BMenu_add_separator (void *); +extern void *BMenu_new_submenu (void *, const char *, bool); +extern void *BMenu_new_menu_bar_submenu (void *, const char *); +extern int BMenu_count_items (void *); +extern void *BMenu_item_at (void *, int); +extern void *BMenu_run (void *, int, int, void (*) (void *, void *), + void (*) (void), void (*) (void), + struct timespec (*) (void), void *); +extern void BPopUpMenu_delete (void *); +extern void *BMenuBar_new (void *); +extern void BMenu_delete_all (void *); +extern void BMenuBar_delete (void *); +extern void BMenu_item_set_label (void *, const char *); +extern void *BMenu_item_get_menu (void *); +extern void BMenu_delete_from (void *, int, int); + +extern void haiku_ring_bell (void); + +extern void *BAlert_new (const char *, enum haiku_alert_type); +extern void *BAlert_add_button (void *, const char *); +extern void BAlert_set_offset_spacing (void *); +extern int32 BAlert_go (void *, void (*) (void), void (*) (void), + void (*) (void)); +extern void BButton_set_enabled (void *, int); +extern void BView_set_tooltip (void *, const char *); +extern void BView_show_tooltip (void *); +extern void BView_set_and_show_sticky_tooltip (void *, const char *, + int, int); + +extern void BAlert_delete (void *); + +extern void EmacsWindow_parent_to (void *, void *); +extern void EmacsWindow_unparent (void *); +extern void EmacsWindow_move_weak_child (void *, void *, int, int); +extern void EmacsWindow_make_fullscreen (void *, int); +extern void EmacsWindow_unzoom (void *); + +extern void be_get_version_string (char *, int); +extern int be_get_display_planes (void); +extern int be_get_display_color_cells (void); +extern bool be_is_display_grayscale (void); +extern void be_warp_pointer (int, int); + +extern void EmacsView_set_up_double_buffering (void *); +extern void EmacsView_disable_double_buffering (void *); +extern void EmacsView_flip_and_blit (void *); +extern int EmacsView_double_buffered_p (void *); + +extern char *be_popup_file_dialog (int, const char *, int, + int, void *, const char *, + const char *, void (*) (void)); #ifdef HAVE_NATIVE_IMAGE_API - extern int - be_can_translate_type_to_bitmap_p (const char *mime); - - extern void * - be_translate_bitmap_from_file_name (const char *filename); - - extern void * - be_translate_bitmap_from_memory (const void *buf, size_t bytes); +extern int be_can_translate_type_to_bitmap_p (const char *); +extern void *be_translate_bitmap_from_file_name (const char *); +extern void *be_translate_bitmap_from_memory (const void *, size_t); #endif - extern void - BMenuBar_start_tracking (void *mbar); - - extern size_t - BBitmap_bytes_length (void *bitmap); - - extern void - BView_show_tooltip (void *view); +extern bool BMenuBar_start_tracking (void *); +extern size_t BBitmap_bytes_length (void *); #ifdef USE_BE_CAIRO - extern cairo_t * - EmacsView_cairo_context (void *view); - - extern void - BView_cr_dump_clipping (void *view, cairo_t *ctx); - - extern void - EmacsWindow_begin_cr_critical_section (void *window); - - extern void - EmacsWindow_end_cr_critical_section (void *window); +extern cairo_t *EmacsView_cairo_context (void *); +extern void BView_cr_dump_clipping (void *, cairo_t *); +extern void EmacsWindow_begin_cr_critical_section (void *); +extern void EmacsWindow_end_cr_critical_section (void *); #endif - extern void - BView_set_and_show_sticky_tooltip (void *view, const char *tooltip, - int x, int y); +extern void BMenu_add_title (void *, const char *); - extern void - BMenu_add_title (void *menu, const char *text); +extern int be_plain_font_height (void); +extern int be_string_width_with_plain_font (const char *); +extern void be_init_font_data (void); +extern void be_evict_font_cache (void); +extern int be_get_display_screens (void); +extern bool be_use_subpixel_antialiasing (void); +extern const char *be_find_setting (const char *); +extern haiku_font_family_or_style *be_list_font_families (size_t *); +extern void be_font_style_to_flags (char *, struct haiku_font_pattern *); +extern void *be_open_font_at_index (int, int, float); +extern int be_get_ui_color (const char *, uint32_t *); - extern int - be_plain_font_height (void); +extern void BMessage_delete (void *); - extern int - be_string_width_with_plain_font (const char *str); +extern bool be_drag_message (void *, void *, bool, void (*) (void), + void (*) (void), void (*) (void), + bool (*) (void)); +extern bool be_drag_and_drop_in_progress (void); - extern int - be_get_display_screens (void); - - extern void - BWindow_set_min_size (void *window, int width, int height); - - extern void - BWindow_set_size_alignment (void *window, int align_width, int align_height); - - extern void - BWindow_sync (void *window); - - extern void - BWindow_send_behind (void *window, void *other_window); - - extern bool - BWindow_is_active (void *window); - - extern bool - be_use_subpixel_antialiasing (void); - - extern void - BWindow_set_override_redirect (void *window, bool override_redirect_p); - - extern const char * - be_find_setting (const char *name); - - extern void - EmacsWindow_signal_menu_update_complete (void *window); - - extern haiku_font_family_or_style * - be_list_font_families (size_t *length); - - extern void - BWindow_dimensions (void *window, int *width, int *height); +extern bool be_replay_menu_bar_event (void *, struct haiku_menu_bar_click_event *); +extern bool be_select_font (void (*) (void), bool (*) (void), + haiku_font_family_or_style *, + haiku_font_family_or_style *, + int *, bool, int, int, int); +extern int be_find_font_indices (struct haiku_font_pattern *, int *, int *); #ifdef __cplusplus - extern void * - find_appropriate_view_for_draw (void *vw); } -extern _Noreturn void -gui_abort (const char *msg); +extern _Noreturn void gui_abort (const char *); +extern void *find_appropriate_view_for_draw (void *); #endif /* _cplusplus */ -/* Borrowed from X.Org keysymdef.h */ -#define XK_BackSpace 0xff08 /* Back space, back char */ -#define XK_Tab 0xff09 -#define XK_Linefeed 0xff0a /* Linefeed, LF */ -#define XK_Clear 0xff0b -#define XK_Return 0xff0d /* Return, enter */ -#define XK_Pause 0xff13 /* Pause, hold */ -#define XK_Scroll_Lock 0xff14 -#define XK_Sys_Req 0xff15 -#define XK_Escape 0xff1b -#define XK_Delete 0xffff /* Delete, rubout */ -#define XK_Home 0xff50 -#define XK_Left 0xff51 /* Move left, left arrow */ -#define XK_Up 0xff52 /* Move up, up arrow */ -#define XK_Right 0xff53 /* Move right, right arrow */ -#define XK_Down 0xff54 /* Move down, down arrow */ -#define XK_Prior 0xff55 /* Prior, previous */ -#define XK_Page_Up 0xff55 -#define XK_Next 0xff56 /* Next */ -#define XK_Page_Down 0xff56 -#define XK_End 0xff57 /* EOL */ -#define XK_Begin 0xff58 /* BOL */ -#define XK_Select 0xff60 /* Select, mark */ -#define XK_Print 0xff61 -#define XK_Execute 0xff62 /* Execute, run, do */ -#define XK_Insert 0xff63 /* Insert, insert here */ -#define XK_Undo 0xff65 -#define XK_Redo 0xff66 /* Redo, again */ -#define XK_Menu 0xff67 -#define XK_Find 0xff68 /* Find, search */ -#define XK_Cancel 0xff69 /* Cancel, stop, abort, exit */ -#define XK_Help 0xff6a /* Help */ -#define XK_Break 0xff6b -#define XK_Mode_switch 0xff7e /* Character set switch */ -#define XK_script_switch 0xff7e /* Alias for mode_switch */ -#define XK_Num_Lock 0xff7f -#define XK_F1 0xffbe - #endif /* _HAIKU_SUPPORT_H_ */ + +// Local Variables: +// eval: (setf (alist-get 'inextern-lang c-offsets-alist) 0) +// End: diff --git a/src/haikufns.c b/src/haikufns.c index 24e4613e3ee..8596317de25 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -64,11 +64,10 @@ static Lisp_Object tip_last_frame; /* PARMS argument of last `x-show-tip' call. */ static Lisp_Object tip_last_parms; -static void -haiku_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval); -static void -haiku_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name); +static void haiku_explicitly_set_name (struct frame *, Lisp_Object, Lisp_Object); +static void haiku_set_title (struct frame *, Lisp_Object, Lisp_Object); +/* The number of references to an image cache. */ static ptrdiff_t image_cache_refcount; static Lisp_Object @@ -255,7 +254,11 @@ int haiku_get_color (const char *name, Emacs_Color *color) { unsigned short r16, g16, b16; - Lisp_Object tem; + Lisp_Object tem, col; + int32 clr, rc; + uint32_t ui_color; + ptrdiff_t size, i; + Lisp_Object string; if (parse_color_spec (name, &r16, &g16, &b16)) { @@ -272,10 +275,11 @@ haiku_get_color (const char *name, Emacs_Color *color) tem = x_display_list->color_map; for (; CONSP (tem); tem = XCDR (tem)) { - Lisp_Object col = XCAR (tem); + col = XCAR (tem); + if (CONSP (col) && !xstrcasecmp (SSDATA (XCAR (col)), name)) { - int32_t clr = XFIXNUM (XCDR (col)); + clr = XFIXNUM (XCDR (col)); color->pixel = clr; color->red = RED_FROM_ULONG (clr) * 257; color->green = GREEN_FROM_ULONG (clr) * 257; @@ -284,11 +288,34 @@ haiku_get_color (const char *name, Emacs_Color *color) return 0; } } - unblock_input (); } - return 1; + rc = 1; + if (VECTORP (Vhaiku_allowed_ui_colors)) + { + size = ASIZE (Vhaiku_allowed_ui_colors); + + for (i = 0; i < size; ++i) + { + string = AREF (Vhaiku_allowed_ui_colors, i); + + block_input (); + if (STRINGP (string) && !strcmp (SSDATA (string), name)) + rc = be_get_ui_color (name, &ui_color); + unblock_input (); + } + } + + if (!rc) + { + color->pixel = ui_color; + color->red = RED_FROM_ULONG (ui_color) * 257; + color->green = GREEN_FROM_ULONG (ui_color) * 257; + color->blue = BLUE_FROM_ULONG (ui_color) * 257; + } + + return rc; } static struct haiku_display_info * @@ -301,10 +328,10 @@ haiku_display_info_for_name (Lisp_Object name) if (!x_display_list) return x_display_list; - error ("Be windowing not initialized"); + error ("Haiku windowing not initialized"); } - error ("Be displays can only be named \"be\""); + error ("Haiku displays can only be named \"be\""); } static struct haiku_display_info * @@ -321,14 +348,14 @@ check_haiku_display_info (Lisp_Object object) else if (x_display_list) dpyinfo = x_display_list; else - error ("Be windowing not present"); + error ("Haiku windowing not present"); } else if (TERMINALP (object)) { struct terminal *t = decode_live_terminal (object); if (t->type != output_haiku) - error ("Terminal %d is not a Be display", t->id); + error ("Terminal %d is not a Haiku display", t->id); dpyinfo = t->display_info.haiku; } @@ -396,8 +423,8 @@ haiku_set_child_frame_border_width (struct frame *f, } static void -haiku_set_parent_frame (struct frame *f, - Lisp_Object new_value, Lisp_Object old_value) +haiku_set_parent_frame (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) { struct frame *p = NULL; block_input (); @@ -422,6 +449,7 @@ haiku_set_parent_frame (struct frame *f, EmacsWindow_unparent (FRAME_HAIKU_WINDOW (f)); FRAME_OUTPUT_DATA (f)->parent_desc = NULL; } + if (!NILP (new_value)) { EmacsWindow_parent_to (FRAME_HAIKU_WINDOW (f), @@ -437,6 +465,43 @@ haiku_set_parent_frame (struct frame *f, unblock_input (); } +static void +haiku_set_z_group (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +{ + int rc; + + /* Tooltip frames can't have Z groups, since the window feel is + overridden during frame creation. */ + if (FRAME_TOOLTIP_P (f)) + return; + + rc = 1; + block_input (); + + if (NILP (new_value)) + { + BWindow_set_z_group (FRAME_HAIKU_WINDOW (f), Z_GROUP_NONE); + FRAME_Z_GROUP (f) = z_group_none; + } + else if (EQ (new_value, Qabove)) + { + BWindow_set_z_group (FRAME_HAIKU_WINDOW (f), Z_GROUP_ABOVE); + FRAME_Z_GROUP (f) = z_group_above; + } + else if (EQ (new_value, Qbelow)) + { + BWindow_set_z_group (FRAME_HAIKU_WINDOW (f), Z_GROUP_BELOW); + FRAME_Z_GROUP (f) = z_group_below; + } + else + rc = 0; + + unblock_input (); + if (!rc) + error ("Invalid z-group specification"); +} + static void haiku_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { @@ -446,15 +511,13 @@ haiku_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) static void haiku_set_no_accept_focus (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) { - block_input (); if (!EQ (new_value, old_value)) FRAME_NO_ACCEPT_FOCUS (f) = !NILP (new_value); + block_input (); if (FRAME_HAIKU_WINDOW (f)) - { - BWindow_set_avoid_focus (FRAME_HAIKU_WINDOW (f), - FRAME_NO_ACCEPT_FOCUS (f)); - } + BWindow_set_avoid_focus (FRAME_HAIKU_WINDOW (f), + FRAME_NO_ACCEPT_FOCUS (f)); unblock_input (); } @@ -554,14 +617,6 @@ haiku_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval } } -static void -unwind_popup (void) -{ - if (!popup_activated_p) - emacs_abort (); - --popup_activated_p; -} - static Lisp_Object haiku_create_frame (Lisp_Object parms) { @@ -582,6 +637,11 @@ haiku_create_frame (Lisp_Object parms) else cascade_target = NULL; + /* Always cascade from the most toplevel frame. */ + + while (cascade_target && FRAME_PARENT_FRAME (cascade_target)) + cascade_target = FRAME_PARENT_FRAME (cascade_target); + parms = Fcopy_alist (parms); Vx_resource_name = Vinvocation_name; @@ -624,17 +684,15 @@ haiku_create_frame (Lisp_Object parms) f = make_frame_without_minibuffer (tem, kb, display); else f = make_frame (1); + XSETFRAME (frame, f); f->terminal = dpyinfo->terminal; f->output_method = output_haiku; f->output_data.haiku = xzalloc (sizeof *f->output_data.haiku); - - f->output_data.haiku->pending_zoom_x = INT_MIN; - f->output_data.haiku->pending_zoom_y = INT_MIN; - f->output_data.haiku->pending_zoom_width = INT_MIN; - f->output_data.haiku->pending_zoom_height = INT_MIN; + f->output_data.haiku->wait_for_event_type = -1; + f->output_data.haiku->relief_background = -1; fset_icon_name (f, gui_display_get_arg (dpyinfo, parms, Qicon_name, "iconName", "Title", @@ -647,9 +705,6 @@ haiku_create_frame (Lisp_Object parms) /* With FRAME_DISPLAY_INFO set up, this unwind-protect is safe. */ record_unwind_protect (unwind_create_frame, frame); - FRAME_OUTPUT_DATA (f)->parent_desc = NULL; - FRAME_OUTPUT_DATA (f)->explicit_parent = 0; - /* Set the name; the functions to which we pass f expect the name to be set. */ if (EQ (name, Qunbound) || NILP (name) || ! STRINGP (name)) @@ -688,7 +743,7 @@ haiku_create_frame (Lisp_Object parms) gui_default_parameter (f, parms, Qborder_width, make_fixnum (0), "borderwidth", "BorderWidth", RES_TYPE_NUMBER); - gui_default_parameter (f, parms, Qinternal_border_width, make_fixnum (2), + gui_default_parameter (f, parms, Qinternal_border_width, make_fixnum (0), "internalBorderWidth", "InternalBorderWidth", RES_TYPE_NUMBER); gui_default_parameter (f, parms, Qchild_frame_border_width, Qnil, @@ -728,11 +783,11 @@ haiku_create_frame (Lisp_Object parms) RES_TYPE_NUMBER); if (FIXNUMP (tem)) store_frame_param (f, Qmin_height, tem); + adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1, Qx_create_frame_1); - gui_default_parameter (f, parms, Qz_group, Qnil, NULL, NULL, RES_TYPE_SYMBOL); gui_default_parameter (f, parms, Qno_focus_on_map, Qnil, NULL, NULL, RES_TYPE_BOOLEAN); gui_default_parameter (f, parms, Qno_accept_focus, Qnil, @@ -766,38 +821,27 @@ haiku_create_frame (Lisp_Object parms) f->no_split = minibuffer_only || (!EQ (tem, Qunbound) && !NILP (tem)); block_input (); -#define ASSIGN_CURSOR(cursor, be_cursor) \ - (FRAME_OUTPUT_DATA (f)->cursor = be_cursor) +#define ASSIGN_CURSOR(cursor) \ + (FRAME_OUTPUT_DATA (f)->cursor = dpyinfo->cursor) - ASSIGN_CURSOR (text_cursor, BCursor_create_i_beam ()); - ASSIGN_CURSOR (nontext_cursor, BCursor_create_default ()); - ASSIGN_CURSOR (modeline_cursor, BCursor_create_modeline ()); - ASSIGN_CURSOR (hand_cursor, BCursor_create_grab ()); - ASSIGN_CURSOR (hourglass_cursor, BCursor_create_progress_cursor ()); - ASSIGN_CURSOR (horizontal_drag_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_EAST_WEST)); - ASSIGN_CURSOR (vertical_drag_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_NORTH_SOUTH)); - ASSIGN_CURSOR (left_edge_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_WEST)); - ASSIGN_CURSOR (top_left_corner_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_NORTH_WEST)); - ASSIGN_CURSOR (top_edge_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_NORTH)); - ASSIGN_CURSOR (top_right_corner_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_NORTH_EAST)); - ASSIGN_CURSOR (right_edge_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_EAST)); - ASSIGN_CURSOR (bottom_right_corner_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_EAST)); - ASSIGN_CURSOR (bottom_edge_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_SOUTH)); - ASSIGN_CURSOR (bottom_left_corner_cursor, - BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_WEST)); - ASSIGN_CURSOR (no_cursor, - BCursor_from_id (CURSOR_ID_NO_CURSOR)); + ASSIGN_CURSOR (text_cursor); + ASSIGN_CURSOR (nontext_cursor); + ASSIGN_CURSOR (modeline_cursor); + ASSIGN_CURSOR (hand_cursor); + ASSIGN_CURSOR (hourglass_cursor); + ASSIGN_CURSOR (horizontal_drag_cursor); + ASSIGN_CURSOR (vertical_drag_cursor); + ASSIGN_CURSOR (left_edge_cursor); + ASSIGN_CURSOR (top_left_corner_cursor); + ASSIGN_CURSOR (top_edge_cursor); + ASSIGN_CURSOR (top_right_corner_cursor); + ASSIGN_CURSOR (right_edge_cursor); + ASSIGN_CURSOR (bottom_right_corner_cursor); + ASSIGN_CURSOR (bottom_edge_cursor); + ASSIGN_CURSOR (bottom_left_corner_cursor); + ASSIGN_CURSOR (no_cursor); - ASSIGN_CURSOR (current_cursor, FRAME_OUTPUT_DATA (f)->text_cursor); + FRAME_OUTPUT_DATA (f)->current_cursor = dpyinfo->text_cursor; #undef ASSIGN_CURSOR f->terminal->reference_count++; @@ -813,8 +857,6 @@ haiku_create_frame (Lisp_Object parms) initialize_frame_menubar (f); unblock_input (); - FRAME_OUTPUT_DATA (f)->window_desc = FRAME_OUTPUT_DATA (f)->window; - Vframe_list = Fcons (frame, Vframe_list); Lisp_Object parent_frame = gui_display_get_arg (dpyinfo, parms, Qparent_frame, NULL, NULL, @@ -826,6 +868,11 @@ haiku_create_frame (Lisp_Object parms) || !FRAME_LIVE_P (XFRAME (parent_frame))) parent_frame = Qnil; + /* It doesn't make sense to center child frames, the resulting + position makes no sense. */ + if (!NILP (parent_frame)) + window_prompting |= PPosition; + fset_parent_frame (f, parent_frame); store_frame_param (f, Qparent_frame, parent_frame); @@ -865,22 +912,19 @@ haiku_create_frame (Lisp_Object parms) adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, true, Qx_create_frame_2); - if (!FRAME_OUTPUT_DATA (f)->explicit_parent) - { - Lisp_Object visibility; + Lisp_Object visibility; - visibility = gui_display_get_arg (dpyinfo, parms, Qvisibility, 0, 0, - RES_TYPE_SYMBOL); - if (EQ (visibility, Qunbound)) - visibility = Qt; - if (EQ (visibility, Qicon)) - haiku_iconify_frame (f); - else if (!NILP (visibility)) - haiku_visualize_frame (f); - else /* Qnil */ - { - f->was_invisible = true; - } + visibility = gui_display_get_arg (dpyinfo, parms, Qvisibility, 0, 0, + RES_TYPE_SYMBOL); + if (EQ (visibility, Qunbound)) + visibility = Qt; + if (EQ (visibility, Qicon)) + haiku_iconify_frame (f); + else if (!NILP (visibility)) + haiku_visualize_frame (f); + else /* Qnil */ + { + f->was_invisible = true; } if (FRAME_HAS_MINIBUF_P (f) @@ -888,6 +932,9 @@ haiku_create_frame (Lisp_Object parms) || !FRAME_LIVE_P (XFRAME (KVAR (kb, Vdefault_minibuffer_frame))))) kset_default_minibuffer_frame (kb, frame); + gui_default_parameter (f, parms, Qz_group, Qnil, + NULL, NULL, RES_TYPE_SYMBOL); + for (tem = parms; CONSP (tem); tem = XCDR (tem)) if (CONSP (XCAR (tem)) && !NILP (XCAR (XCAR (tem)))) fset_param_alist (f, Fcons (XCAR (tem), f->param_alist)); @@ -902,6 +949,11 @@ haiku_create_frame (Lisp_Object parms) BWindow_center_on_screen (FRAME_HAIKU_WINDOW (f)); unblock_input (); + FRAME_OUTPUT_DATA (f)->configury_done = true; + + if (f->want_fullscreen != FULLSCREEN_NONE) + FRAME_TERMINAL (f)->fullscreen_hook (f); + /* Make sure windows on this frame appear in calls to next-window and similar functions. */ Vwindow_list = Qnil; @@ -955,18 +1007,14 @@ haiku_create_tip_frame (Lisp_Object parms) counts etc. */ f->output_method = output_haiku; f->output_data.haiku = xzalloc (sizeof *f->output_data.haiku); - - f->output_data.haiku->pending_zoom_x = INT_MIN; - f->output_data.haiku->pending_zoom_y = INT_MIN; - f->output_data.haiku->pending_zoom_width = INT_MIN; - f->output_data.haiku->pending_zoom_height = INT_MIN; + f->output_data.haiku->wait_for_event_type = -1; + f->output_data.haiku->relief_background = -1; f->tooltip = true; fset_icon_name (f, Qnil); FRAME_DISPLAY_INFO (f) = dpyinfo; FRAME_OUTPUT_DATA (f)->parent_desc = NULL; - FRAME_OUTPUT_DATA (f)->explicit_parent = 0; /* Set the name; the functions to which we pass f expect the name to be set. */ @@ -1058,7 +1106,6 @@ haiku_create_tip_frame (Lisp_Object parms) if (!window) emacs_abort (); - FRAME_OUTPUT_DATA (f)->window_desc = window; BWindow_set_tooltip_decoration (window); unblock_input (); } @@ -1156,7 +1203,11 @@ compute_tip_xy (struct frame *f, /* Default min and max values. */ min_x = 0; min_y = 0; - BScreen_px_dim (&max_x, &max_y); + + be_get_screen_dimensions (&max_x, &max_y); + + max_x = max_x - 1; + max_y = max_y - 1; block_input (); BView_get_mouse (FRAME_HAIKU_VIEW (f), &x, &y); @@ -1280,9 +1331,11 @@ haiku_set_override_redirect (struct frame *f, Lisp_Object new_value, static void haiku_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) { + int nlines; + if (FRAME_TOOLTIP_P (f)) return; - int nlines; + if (TYPE_RANGED_FIXNUMP (int, value)) nlines = XFIXNUM (value); else @@ -1290,9 +1343,6 @@ haiku_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval fset_redisplay (f); - FRAME_MENU_BAR_LINES (f) = 0; - FRAME_MENU_BAR_HEIGHT (f) = 0; - if (nlines) { FRAME_EXTERNAL_MENU_BAR (f) = 1; @@ -1301,11 +1351,14 @@ haiku_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval } else { + FRAME_MENU_BAR_LINES (f) = 0; + FRAME_MENU_BAR_HEIGHT (f) = 0; + if (FRAME_EXTERNAL_MENU_BAR (f)) free_frame_menubar (f); + FRAME_EXTERNAL_MENU_BAR (f) = 0; - if (FRAME_HAIKU_P (f)) - FRAME_HAIKU_MENU_BAR (f) = 0; + FRAME_HAIKU_MENU_BAR (f) = 0; } adjust_frame_glyphs (f); @@ -1365,11 +1418,12 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute) void haiku_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { + Emacs_Color color; + struct face *defface; + CHECK_STRING (arg); block_input (); - Emacs_Color color; - if (haiku_get_color (SSDATA (arg), &color)) { store_frame_param (f, Qbackground_color, oldval); @@ -1382,8 +1436,6 @@ haiku_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval if (FRAME_HAIKU_VIEW (f)) { - struct face *defface; - BView_draw_lock (FRAME_HAIKU_VIEW (f), false, 0, 0, 0, 0); BView_SetViewColor (FRAME_HAIKU_VIEW (f), color.pixel); BView_draw_unlock (FRAME_HAIKU_VIEW (f)); @@ -1405,11 +1457,11 @@ haiku_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval void haiku_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { - CHECK_STRING (arg); - - block_input (); Emacs_Color color, fore_pixel; + CHECK_STRING (arg); + block_input (); + if (haiku_get_color (SSDATA (arg), &color)) { store_frame_param (f, Qcursor_color, oldval); @@ -1449,11 +1501,7 @@ haiku_get_pixel (haiku bitmap, int x, int y) { unsigned char *data; int32_t bytes_per_row; - int mono_p; - int left; - int right; - int top; - int bottom; + int mono_p, left, right, top, bottom, byte; data = BBitmap_data (bitmap); BBitmap_dimensions (bitmap, &left, &top, &right, &bottom, @@ -1465,20 +1513,17 @@ haiku_get_pixel (haiku bitmap, int x, int y) if (!mono_p) return ((uint32_t *) (data + (bytes_per_row * y)))[x]; - int byte = y * bytes_per_row + x / 8; + byte = y * bytes_per_row + x / 8; return data[byte] & (1 << (x % 8)); } void haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel) { - unsigned char *data; + unsigned char *data, *byte; int32_t bytes_per_row; - int mono_p; - int left; - int right; - int top; - int bottom; + int mono_p, left, right, top, bottom; + ptrdiff_t off, bit, xoff; data = BBitmap_data (bitmap); BBitmap_dimensions (bitmap, &left, &top, &right, &bottom, @@ -1489,11 +1534,11 @@ haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel) if (mono_p) { - ptrdiff_t off = y * bytes_per_row; - ptrdiff_t bit = x % 8; - ptrdiff_t xoff = x / 8; + off = y * bytes_per_row; + bit = x % 8; + xoff = x / 8; - unsigned char *byte = data + off + xoff; + byte = data + off + xoff; if (!pixel) *byte &= ~(1 << bit); else @@ -1560,24 +1605,8 @@ haiku_free_frame_resources (struct frame *f) if (window) BWindow_quit (window); - /* Free cursors */ - - BCursor_delete (f->output_data.haiku->text_cursor); - BCursor_delete (f->output_data.haiku->nontext_cursor); - BCursor_delete (f->output_data.haiku->modeline_cursor); - BCursor_delete (f->output_data.haiku->hand_cursor); - BCursor_delete (f->output_data.haiku->hourglass_cursor); - BCursor_delete (f->output_data.haiku->horizontal_drag_cursor); - BCursor_delete (f->output_data.haiku->vertical_drag_cursor); - BCursor_delete (f->output_data.haiku->left_edge_cursor); - BCursor_delete (f->output_data.haiku->top_left_corner_cursor); - BCursor_delete (f->output_data.haiku->top_edge_cursor); - BCursor_delete (f->output_data.haiku->top_right_corner_cursor); - BCursor_delete (f->output_data.haiku->right_edge_cursor); - BCursor_delete (f->output_data.haiku->bottom_right_corner_cursor); - BCursor_delete (f->output_data.haiku->bottom_edge_cursor); - BCursor_delete (f->output_data.haiku->bottom_left_corner_cursor); - BCursor_delete (f->output_data.haiku->no_cursor); + if (FRAME_OUTPUT_DATA (f)->saved_menu_event) + xfree (FRAME_OUTPUT_DATA (f)->saved_menu_event); xfree (FRAME_OUTPUT_DATA (f)); FRAME_OUTPUT_DATA (f) = NULL; @@ -1591,13 +1620,11 @@ haiku_iconify_frame (struct frame *frame) if (FRAME_ICONIFIED_P (frame)) return; - block_input (); - SET_FRAME_VISIBLE (frame, false); SET_FRAME_ICONIFIED (frame, true); + block_input (); BWindow_iconify (FRAME_HAIKU_WINDOW (frame)); - unblock_input (); } @@ -1639,7 +1666,8 @@ haiku_unvisualize_frame (struct frame *f) } void -haiku_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +haiku_set_internal_border_width (struct frame *f, Lisp_Object arg, + Lisp_Object oldval) { int old_width = FRAME_INTERNAL_BORDER_WIDTH (f); int new_width = check_int_nonnegative (arg); @@ -1694,28 +1722,33 @@ check_x_display_info (Lisp_Object object) return check_haiku_display_info (object); } -/* Rename frame F to NAME. If NAME is nil, set F's name to "GNU - Emacs". If EXPLICIT_P is non-zero, that indicates Lisp code is - setting the name, not redisplay; in that case, set F's name to NAME - and set F->explicit_name; if NAME is nil, clear F->explicit_name. +/* Rename frame F to NAME. If NAME is nil, set F's name to the + default name. If EXPLICIT_P is non-zero, that indicates Lisp code + is setting the name, not redisplay; in that case, set F's name to + NAME and set F->explicit_name; if NAME is nil, clear + F->explicit_name. If EXPLICIT_P is zero, it means redisplay is setting the name; the name provided will be ignored if explicit_name is set. */ void haiku_set_name (struct frame *f, Lisp_Object name, bool explicit_p) { + struct haiku_display_info *dpyinfo; + if (explicit_p) { if (f->explicit_name && NILP (name)) - update_mode_lines = 24; + update_mode_lines = 37; f->explicit_name = !NILP (name); } else if (f->explicit_name) return; + dpyinfo = FRAME_DISPLAY_INFO (f); + if (NILP (name)) - name = build_unibyte_string ("GNU Emacs"); + name = dpyinfo->default_name; if (!NILP (Fstring_equal (name, f->name))) return; @@ -1738,23 +1771,27 @@ haiku_set_inhibit_double_buffering (struct frame *f, { #ifndef USE_BE_CAIRO if (NILP (new_value)) - { #endif - EmacsView_set_up_double_buffering (FRAME_HAIKU_VIEW (f)); - if (!NILP (old_value)) - { - SET_FRAME_GARBAGED (f); - expose_frame (f, 0, 0, 0, 0); - } + EmacsView_set_up_double_buffering (FRAME_HAIKU_VIEW (f)); #ifndef USE_BE_CAIRO - } else EmacsView_disable_double_buffering (FRAME_HAIKU_VIEW (f)); #endif + + SET_FRAME_GARBAGED (f); } unblock_input (); } +static void +haiku_set_sticky (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) +{ + block_input (); + BWindow_set_sticky (FRAME_HAIKU_WINDOW (f), !NILP (new_value)); + unblock_input (); +} + DEFUN ("haiku-set-mouse-absolute-pixel-position", @@ -1785,19 +1822,15 @@ the mouse cursor position in pixels relative to a position (0, 0) of the selected frame's display. */) (void) { - if (!x_display_list) - return Qnil; - struct frame *f = SELECTED_FRAME (); + void *view; + int x, y; - if (FRAME_INITIAL_P (f) || !FRAME_HAIKU_P (f) - || !FRAME_HAIKU_VIEW (f)) + if (FRAME_INITIAL_P (f) || !FRAME_HAIKU_P (f)) return Qnil; block_input (); - void *view = FRAME_HAIKU_VIEW (f); - - int x, y; + view = FRAME_HAIKU_VIEW (f); BView_get_mouse (view, &x, &y); BView_convert_to_screen (view, &x, &y); unblock_input (); @@ -1809,7 +1842,9 @@ DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { - return Qt; + check_haiku_display_info (terminal); + + return be_is_display_grayscale () ? Qnil : Qt; } DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, @@ -1817,6 +1852,7 @@ DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, (Lisp_Object color, Lisp_Object frame) { Emacs_Color col; + CHECK_STRING (color); decode_window_system_frame (frame); @@ -1828,17 +1864,19 @@ DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, (Lisp_Object color, Lisp_Object frame) { Emacs_Color col; + int rc; + CHECK_STRING (color); decode_window_system_frame (frame); block_input (); - if (haiku_get_color (SSDATA (color), &col)) - { - unblock_input (); - return Qnil; - } + rc = haiku_get_color (SSDATA (color), &col); unblock_input (); - return list3i (lrint (col.red), lrint (col.green), lrint (col.blue)); + + if (rc) + return Qnil; + + return list3i (col.red, col.green, col.blue); } DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p, @@ -1846,7 +1884,9 @@ DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { - return Qnil; + check_haiku_display_info (terminal); + + return be_is_display_grayscale () ? Qt : Qnil; } DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection, @@ -1887,10 +1927,10 @@ DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width, (Lisp_Object terminal) { + int width, height; check_haiku_display_info (terminal); - int width, height; - BScreen_px_dim (&width, &height); + be_get_screen_dimensions (&width, &height); return make_fixnum (width); } @@ -1900,10 +1940,10 @@ DEFUN ("x-display-pixel-height", Fx_display_pixel_height, Sx_display_pixel_heigh (Lisp_Object terminal) { + int width, height; check_haiku_display_info (terminal); - int width, height; - BScreen_px_dim (&width, &height); + be_get_screen_dimensions (&width, &height); return make_fixnum (width); } @@ -1912,10 +1952,9 @@ DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, (Lisp_Object terminal) { struct haiku_display_info *dpyinfo = check_haiku_display_info (terminal); - int width, height; - BScreen_px_dim (&width, &height); + be_get_screen_dimensions (&width, &height); return make_fixnum (height / (dpyinfo->resy / 25.4)); } @@ -1925,10 +1964,9 @@ DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0, (Lisp_Object terminal) { struct haiku_display_info *dpyinfo = check_haiku_display_info (terminal); - int width, height; - BScreen_px_dim (&width, &height); + be_get_screen_dimensions (&width, &height); return make_fixnum (width / (dpyinfo->resx / 25.4)); } @@ -1945,14 +1983,20 @@ DEFUN ("x-display-visual-class", Fx_display_visual_class, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { + int planes; + bool grayscale_p; + check_haiku_display_info (terminal); - int planes = be_get_display_planes (); + grayscale_p = be_is_display_grayscale (); + if (grayscale_p) + return Qstatic_gray; + planes = be_get_display_planes (); if (planes == 8) - return intern ("static-color"); + return Qstatic_color; - return intern ("true-color"); + return Qtrue_color; } DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, @@ -1982,9 +2026,8 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, f = decode_window_system_frame (frame); if (NILP (timeout)) - timeout = make_fixnum (5); - else - CHECK_FIXNAT (timeout); + timeout = Vx_show_tooltip_timeout; + CHECK_FIXNAT (timeout); if (NILP (dx)) dx = make_fixnum (5); @@ -2333,8 +2376,7 @@ DEFUN ("x-double-buffered-p", Fx_double_buffered_p, Sx_double_buffered_p, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object frame) { - struct frame *f = decode_live_frame (frame); - check_window_system (f); + struct frame *f = decode_window_system_frame (frame); return EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f)) ? Qt : Qnil; } @@ -2344,13 +2386,14 @@ DEFUN ("x-display-backing-store", Fx_display_backing_store, Sx_display_backing_s doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { + struct frame *f; + if (FRAMEP (terminal)) { - CHECK_LIVE_FRAME (terminal); - struct frame *f = decode_window_system_frame (terminal); + f = decode_window_system_frame (terminal); - if (FRAME_HAIKU_VIEW (f) && - EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f))) + if (FRAME_HAIKU_VIEW (f) + && EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f))) return FRAME_PARENT_FRAME (f) ? Qwhen_mapped : Qalways; else return Qnot_useful; @@ -2441,15 +2484,21 @@ Optional arg MUSTMATCH, if non-nil, means the returned file or directory must exist. Optional arg DIR_ONLY_P, if non-nil, means choose only directories. Optional arg SAVE_TEXT, if non-nil, specifies some text to show in the entry field. */) - (Lisp_Object prompt, Lisp_Object frame, - Lisp_Object dir, Lisp_Object mustmatch, - Lisp_Object dir_only_p, Lisp_Object save_text) + (Lisp_Object prompt, Lisp_Object frame, Lisp_Object dir, + Lisp_Object mustmatch, Lisp_Object dir_only_p, Lisp_Object save_text) { - if (!x_display_list) - error ("Be windowing not initialized"); + struct frame *f; + char *file_name; + Lisp_Object value; + + if (popup_activated_p) + error ("Trying to use a menu from within a menu-entry"); if (!NILP (dir)) - CHECK_STRING (dir); + { + CHECK_STRING (dir); + dir = ENCODE_FILE (dir); + } if (!NILP (save_text)) CHECK_STRING (save_text); @@ -2459,37 +2508,28 @@ Optional arg SAVE_TEXT, if non-nil, specifies some text to show in the entry fie CHECK_STRING (prompt); - CHECK_LIVE_FRAME (frame); - check_window_system (XFRAME (frame)); - - specpdl_ref idx = SPECPDL_INDEX (); - record_unwind_protect_void (unwind_popup); - - struct frame *f = XFRAME (frame); - - FRAME_DISPLAY_INFO (f)->focus_event_frame = f; + f = decode_window_system_frame (frame); ++popup_activated_p; - char *fn = be_popup_file_dialog (!NILP (mustmatch) || !NILP (dir_only_p), - !NILP (dir) ? SSDATA (ENCODE_UTF_8 (dir)) : NULL, - !NILP (mustmatch), !NILP (dir_only_p), - FRAME_HAIKU_WINDOW (f), - !NILP (save_text) ? SSDATA (ENCODE_UTF_8 (save_text)) : NULL, - SSDATA (ENCODE_UTF_8 (prompt)), - block_input, unblock_input, maybe_quit); + unrequest_sigio (); + file_name = be_popup_file_dialog (!NILP (mustmatch) || !NILP (dir_only_p), + !NILP (dir) ? SSDATA (dir) : NULL, + !NILP (mustmatch), !NILP (dir_only_p), + FRAME_HAIKU_WINDOW (f), + (!NILP (save_text) + ? SSDATA (ENCODE_UTF_8 (save_text)) : NULL), + SSDATA (ENCODE_UTF_8 (prompt)), + process_pending_signals); + request_sigio (); + --popup_activated_p; - unbind_to (idx, Qnil); + if (!file_name) + quit (); - block_input (); - BWindow_activate (FRAME_HAIKU_WINDOW (f)); - unblock_input (); + value = build_string (file_name); + free (file_name); - if (!fn) - return Qnil; - - Lisp_Object p = build_string_from_utf8 (fn); - free (fn); - return p; + return DECODE_FILE (value); } DEFUN ("haiku-put-resource", Fhaiku_put_resource, Shaiku_put_resource, @@ -2547,13 +2587,15 @@ DEFUN ("x-display-save-under", Fx_display_save_under, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { + struct frame *f; check_haiku_display_info (terminal); if (FRAMEP (terminal)) { - struct frame *f = decode_window_system_frame (terminal); - return FRAME_HAIKU_VIEW (f) && EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f)) ? - Qt : Qnil; + f = decode_window_system_frame (terminal); + return ((FRAME_HAIKU_VIEW (f) + && EmacsView_double_buffered_p (FRAME_HAIKU_VIEW (f))) + ? Qt : Qnil); } return Qnil; @@ -2568,13 +2610,10 @@ means that if both frames are visible and the display areas of these frames overlap, FRAME1 (partially) obscures FRAME2. Some window managers may refuse to restack windows. */) - (Lisp_Object frame1, Lisp_Object frame2, Lisp_Object above) + (Lisp_Object frame1, Lisp_Object frame2, Lisp_Object above) { - struct frame *f1 = decode_live_frame (frame1); - struct frame *f2 = decode_live_frame (frame2); - - check_window_system (f1); - check_window_system (f2); + struct frame *f1 = decode_window_system_frame (frame1); + struct frame *f2 = decode_window_system_frame (frame2); block_input (); @@ -2620,6 +2659,30 @@ Some window managers may refuse to restack windows. */) return Qnil; } +DEFUN ("haiku-save-session-reply", Fhaiku_save_session_reply, + Shaiku_save_session_reply, 1, 1, 0, + doc: /* Reply to a `save-session' event. +QUIT-REPLY means whether or not all files were saved and program +termination should proceed. + +Calls to this function must be balanced by the amount of +`save-session' events received. This is done automatically, so do not +call this function yourself. */) + (Lisp_Object quit_reply) +{ + struct haiku_session_manager_reply reply; + reply.quit_reply = !NILP (quit_reply); + + block_input (); + unrequest_sigio (); + write_port (port_emacs_to_session_manager, 0, &reply, + sizeof reply); + request_sigio (); + unblock_input (); + + return Qnil; +} + frame_parm_handler haiku_frame_parm_handlers[] = { gui_set_autoraise, @@ -2659,7 +2722,7 @@ frame_parm_handler haiku_frame_parm_handlers[] = gui_set_fullscreen, gui_set_font_backend, gui_set_alpha, - NULL, /* set sticky */ + haiku_set_sticky, NULL, /* set tool bar pos */ haiku_set_inhibit_double_buffering, haiku_set_undecorated, @@ -2667,7 +2730,7 @@ frame_parm_handler haiku_frame_parm_handlers[] = NULL, /* set skip taskbar */ haiku_set_no_focus_on_map, haiku_set_no_accept_focus, - NULL, /* set z group */ + haiku_set_z_group, haiku_set_override_redirect, gui_set_no_special_glyphs, gui_set_alpha_background, @@ -2685,6 +2748,10 @@ syms_of_haikufns (void) DEFSYM (Qwhen_mapped, "when-mapped"); DEFSYM (Qtooltip_reuse_hidden_frame, "tooltip-reuse-hidden-frame"); + DEFSYM (Qstatic_color, "static-color"); + DEFSYM (Qstatic_gray, "static-gray"); + DEFSYM (Qtrue_color, "true-color"); + defsubr (&Sx_hide_tip); defsubr (&Sxw_display_color_p); defsubr (&Sx_display_grayscale_p); @@ -2717,6 +2784,7 @@ syms_of_haikufns (void) defsubr (&Shaiku_frame_list_z_order); defsubr (&Sx_display_save_under); defsubr (&Shaiku_frame_restack); + defsubr (&Shaiku_save_session_reply); tip_timer = Qnil; staticpro (&tip_timer); @@ -2737,6 +2805,12 @@ syms_of_haikufns (void) doc: /* SKIP: real doc in xfns.c. */); Vx_cursor_fore_pixel = Qnil; + DEFVAR_LISP ("haiku-allowed-ui-colors", Vhaiku_allowed_ui_colors, + doc: /* Vector of UI colors that Emacs can look up from the system. +If this is set up incorrectly, Emacs can crash when encoutering an +invalid color. */); + Vhaiku_allowed_ui_colors = Qnil; + #ifdef USE_BE_CAIRO DEFVAR_LISP ("cairo-version-string", Vcairo_version_string, doc: /* Version info for cairo. */); diff --git a/src/haikufont.c b/src/haikufont.c index 5099285f100..e0db086aa00 100644 --- a/src/haikufont.c +++ b/src/haikufont.c @@ -137,7 +137,7 @@ haikufont_apply_registry (struct haiku_font_pattern *pattern, for (l = 0; uniquifier[l]; ++l); - uint32_t *a = xmalloc (l * sizeof *a); + int *a = xmalloc (l * sizeof *a); for (l = 0; uniquifier[l]; ++l) a[l] = uniquifier[l]; @@ -149,6 +149,7 @@ haikufont_apply_registry (struct haiku_font_pattern *pattern, memcpy (&a[old_l], pattern->wanted_chars, (l - old_l) * sizeof *a); xfree (pattern->wanted_chars); } + pattern->specified |= FSPEC_WANTED; pattern->want_chars_len = l; pattern->wanted_chars = a; @@ -183,7 +184,7 @@ haikufont_get_fallback_entity (void) ASET (ent, FONT_FOUNDRY_INDEX, Qhaiku); ASET (ent, FONT_FAMILY_INDEX, Qnil); ASET (ent, FONT_ADSTYLE_INDEX, Qnil); - ASET (ent, FONT_REGISTRY_INDEX, Qutf_8); + ASET (ent, FONT_REGISTRY_INDEX, Qiso10646_1); ASET (ent, FONT_SIZE_INDEX, make_fixnum (0)); ASET (ent, FONT_AVGWIDTH_INDEX, make_fixnum (0)); ASET (ent, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_MONO)); @@ -207,8 +208,6 @@ haikufont_weight_to_lisp (int weight) { case HAIKU_THIN: return Qthin; - case HAIKU_ULTRALIGHT: - return Qultra_light; case HAIKU_EXTRALIGHT: return Qextra_light; case HAIKU_LIGHT: @@ -223,8 +222,6 @@ haikufont_weight_to_lisp (int weight) return Qbold; case HAIKU_EXTRA_BOLD: return Qextra_bold; - case HAIKU_ULTRA_BOLD: - return Qultra_bold; case HAIKU_BOOK: return Qbook; case HAIKU_HEAVY: @@ -245,14 +242,14 @@ haikufont_lisp_to_weight (Lisp_Object weight) if (EQ (weight, Qthin)) return HAIKU_THIN; if (EQ (weight, Qultra_light)) - return HAIKU_ULTRALIGHT; + return HAIKU_EXTRALIGHT; if (EQ (weight, Qextra_light)) return HAIKU_EXTRALIGHT; if (EQ (weight, Qlight)) return HAIKU_LIGHT; if (EQ (weight, Qsemi_light)) return HAIKU_SEMI_LIGHT; - if (EQ (weight, Qnormal)) + if (EQ (weight, Qnormal) || EQ (weight, Qregular)) return HAIKU_REGULAR; if (EQ (weight, Qsemi_bold)) return HAIKU_SEMI_BOLD; @@ -261,7 +258,7 @@ haikufont_lisp_to_weight (Lisp_Object weight) if (EQ (weight, Qextra_bold)) return HAIKU_EXTRA_BOLD; if (EQ (weight, Qultra_bold)) - return HAIKU_ULTRA_BOLD; + return HAIKU_EXTRA_BOLD; if (EQ (weight, Qbook)) return HAIKU_BOOK; if (EQ (weight, Qheavy)) @@ -273,7 +270,7 @@ haikufont_lisp_to_weight (Lisp_Object weight) if (EQ (weight, Qmedium)) return HAIKU_MEDIUM; - emacs_abort (); + return HAIKU_REGULAR; } static Lisp_Object @@ -296,15 +293,16 @@ haikufont_slant_to_lisp (enum haiku_font_slant slant) static enum haiku_font_slant haikufont_lisp_to_slant (Lisp_Object slant) { - if (EQ (slant, Qitalic) || - EQ (slant, Qreverse_italic)) + if (EQ (slant, Qitalic) + || EQ (slant, Qreverse_italic)) return SLANT_ITALIC; - if (EQ (slant, Qoblique) || - EQ (slant, Qreverse_oblique)) + if (EQ (slant, Qoblique) + || EQ (slant, Qreverse_oblique)) return SLANT_OBLIQUE; - if (EQ (slant, Qnormal)) + if (EQ (slant, Qnormal) || EQ (slant, Qregular)) return SLANT_REGULAR; - emacs_abort (); + + return SLANT_REGULAR; } static Lisp_Object @@ -348,7 +346,7 @@ haikufont_lisp_to_width (Lisp_Object lisp) return CONDENSED; if (EQ (lisp, Qsemi_condensed)) return SEMI_CONDENSED; - if (EQ (lisp, Qnormal)) + if (EQ (lisp, Qnormal) || EQ (lisp, Qregular)) return NORMAL_WIDTH; if (EQ (lisp, Qexpanded)) return EXPANDED; @@ -356,7 +354,8 @@ haikufont_lisp_to_width (Lisp_Object lisp) return EXTRA_EXPANDED; if (EQ (lisp, Qultra_expanded)) return ULTRA_EXPANDED; - emacs_abort (); + + return NORMAL_WIDTH; } static int @@ -382,15 +381,25 @@ haikufont_maybe_handle_special_family (Lisp_Object family, static Lisp_Object haikufont_pattern_to_entity (struct haiku_font_pattern *ptn) { - Lisp_Object ent = font_make_entity (); + Lisp_Object ent; + + ent = font_make_entity (); ASET (ent, FONT_TYPE_INDEX, Qhaiku); ASET (ent, FONT_FOUNDRY_INDEX, Qhaiku); ASET (ent, FONT_FAMILY_INDEX, Qdefault); ASET (ent, FONT_ADSTYLE_INDEX, Qnil); - ASET (ent, FONT_REGISTRY_INDEX, Qutf_8); + ASET (ent, FONT_REGISTRY_INDEX, Qiso10646_1); ASET (ent, FONT_SIZE_INDEX, make_fixnum (0)); ASET (ent, FONT_AVGWIDTH_INDEX, make_fixnum (0)); ASET (ent, FONT_SPACING_INDEX, make_fixnum (FONT_SPACING_MONO)); + + /* FONT_EXTRA_INDEX in a font entity can be a cons of two numbers + (STYLE . IDX) that tell Emacs how to open a font. */ + if (ptn->specified & FSPEC_INDICES) + ASET (ent, FONT_EXTRA_INDEX, + Fcons (make_fixnum (ptn->family_index), + make_fixnum (ptn->style_index))); + FONT_SET_STYLE (ent, FONT_WIDTH_INDEX, Qnormal); FONT_SET_STYLE (ent, FONT_WEIGHT_INDEX, Qnormal); FONT_SET_STYLE (ent, FONT_SLANT_INDEX, Qnormal); @@ -423,8 +432,57 @@ haikufont_pattern_to_entity (struct haiku_font_pattern *ptn) } static void -haikufont_spec_or_entity_to_pattern (Lisp_Object ent, - int list_p, +haikufont_pattern_from_object (struct haiku_font_pattern *pattern, + Lisp_Object font_object) +{ + Lisp_Object val; + + pattern->specified = 0; + + val = AREF (font_object, FONT_FAMILY_INDEX); + if (!NILP (val)) + { + pattern->specified |= FSPEC_FAMILY; + strncpy ((char *) &pattern->family, + SSDATA (SYMBOL_NAME (val)), + sizeof pattern->family - 1); + pattern->family[sizeof pattern->family - 1] = '\0'; + } + + val = AREF (font_object, FONT_ADSTYLE_INDEX); + if (!NILP (val)) + { + pattern->specified |= FSPEC_STYLE; + strncpy ((char *) &pattern->style, + SSDATA (SYMBOL_NAME (val)), + sizeof pattern->style - 1); + pattern->style[sizeof pattern->style - 1] = '\0'; + } + + val = FONT_WEIGHT_FOR_FACE (font_object); + if (!NILP (val) && !EQ (val, Qunspecified)) + { + pattern->specified |= FSPEC_WEIGHT; + pattern->weight = haikufont_lisp_to_weight (val); + } + + val = FONT_SLANT_FOR_FACE (font_object); + if (!NILP (val) && !EQ (val, Qunspecified)) + { + pattern->specified |= FSPEC_SLANT; + pattern->slant = haikufont_lisp_to_slant (val); + } + + val = FONT_WIDTH_FOR_FACE (font_object); + if (!NILP (val) && !EQ (val, Qunspecified)) + { + pattern->specified |= FSPEC_WIDTH; + pattern->width = haikufont_lisp_to_width (val); + } +} + +static void +haikufont_spec_or_entity_to_pattern (Lisp_Object ent, int list_p, struct haiku_font_pattern *ptn) { Lisp_Object tem; @@ -437,6 +495,7 @@ haikufont_spec_or_entity_to_pattern (Lisp_Object ent, strncpy ((char *) &ptn->style, SSDATA (SYMBOL_NAME (tem)), sizeof ptn->style - 1); + ptn->style[sizeof ptn->style - 1] = '\0'; } tem = FONT_SLANT_SYMBOLIC (ent); @@ -468,13 +527,15 @@ haikufont_spec_or_entity_to_pattern (Lisp_Object ent, } tem = AREF (ent, FONT_FAMILY_INDEX); - if (!NILP (tem) && !EQ (tem, Qunspecified) && - (list_p && !haikufont_maybe_handle_special_family (tem, ptn))) + if (!NILP (tem) && !EQ (tem, Qunspecified) + && (list_p + && !haikufont_maybe_handle_special_family (tem, ptn))) { ptn->specified |= FSPEC_FAMILY; strncpy ((char *) &ptn->family, SSDATA (SYMBOL_NAME (tem)), sizeof ptn->family - 1); + ptn->family[sizeof ptn->family - 1] = '\0'; } tem = assq_no_quit (QCscript, AREF (ent, FONT_EXTRA_INDEX)); @@ -589,27 +650,29 @@ haikufont_match (struct frame *f, Lisp_Object font_spec) static Lisp_Object haikufont_list (struct frame *f, Lisp_Object font_spec) { - block_input (); - Lisp_Object lst = Qnil; + Lisp_Object lst, tem; + struct haiku_font_pattern ptn, *found, *pt; + lst = Qnil; + + block_input (); /* Returning irrelevant results on receiving an OTF form will cause fontset.c to loop over and over, making displaying some characters very slow. */ - Lisp_Object tem = assq_no_quit (QCotf, AREF (font_spec, FONT_EXTRA_INDEX)); + tem = assq_no_quit (QCotf, AREF (font_spec, FONT_EXTRA_INDEX)); + if (CONSP (tem) && !NILP (XCDR (tem))) { unblock_input (); return Qnil; } - struct haiku_font_pattern ptn; haikufont_spec_or_entity_to_pattern (font_spec, 1, &ptn); - struct haiku_font_pattern *found = BFont_find (&ptn); + found = BFont_find (&ptn); haikufont_done_with_query_pattern (&ptn); if (found) { - for (struct haiku_font_pattern *pt = found; - pt; pt = pt->next) + for (pt = found; pt; pt = pt->next) lst = Fcons (haikufont_pattern_to_entity (pt), lst); haiku_font_pattern_free (found); } @@ -669,10 +732,11 @@ haikufont_open (struct frame *f, Lisp_Object font_entity, int x) struct haiku_font_pattern ptn; struct font *font; void *be_font; - Lisp_Object font_object; - Lisp_Object tem; + Lisp_Object font_object, tem, extra; + int px_size, min_width, max_width, + avg_width, height, space_width, ascent, + descent, underline_pos, underline_thickness; - block_input (); if (x <= 0) { /* Get pixel size from frame instead. */ @@ -680,19 +744,47 @@ haikufont_open (struct frame *f, Lisp_Object font_entity, int x) x = NILP (tem) ? 0 : XFIXNAT (tem); } - haikufont_spec_or_entity_to_pattern (font_entity, 1, &ptn); + extra = AREF (font_entity, FONT_EXTRA_INDEX); - if (BFont_open_pattern (&ptn, &be_font, x)) + /* If the font's indices is already available, open the font using + those instead. */ + + if (CONSP (extra) && FIXNUMP (XCAR (extra)) + && FIXNUMP (XCDR (extra))) { + block_input (); + be_font = be_open_font_at_index (XFIXNUM (XCAR (extra)), + XFIXNUM (XCDR (extra)), x); + unblock_input (); + + if (!be_font) + return Qnil; + } + else + { + block_input (); + haikufont_spec_or_entity_to_pattern (font_entity, 1, &ptn); + + if (BFont_open_pattern (&ptn, &be_font, x)) + { + haikufont_done_with_query_pattern (&ptn); + unblock_input (); + return Qnil; + } + haikufont_done_with_query_pattern (&ptn); unblock_input (); - return Qnil; } - haikufont_done_with_query_pattern (&ptn); + block_input (); + /* `font_make_object' tries to treat the extra data as an alist. + There is never any real data here, so clear that field. */ + + ASET (font_entity, FONT_EXTRA_INDEX, Qnil); font_object = font_make_object (VECSIZE (struct haikufont_info), font_entity, x); + ASET (font_entity, FONT_EXTRA_INDEX, extra); ASET (font_object, FONT_TYPE_INDEX, Qhaiku); font_info = (struct haikufont_info *) XFONT_OBJECT (font_object); @@ -719,14 +811,10 @@ haikufont_open (struct frame *f, Lisp_Object font_entity, int x) font_info->metrics = NULL; font_info->metrics_nrows = 0; - int px_size, min_width, max_width, - avg_width, height, space_width, ascent, - descent, underline_pos, underline_thickness; - - BFont_dat (be_font, &px_size, &min_width, - &max_width, &avg_width, &height, - &space_width, &ascent, &descent, - &underline_pos, &underline_thickness); + BFont_metrics (be_font, &px_size, &min_width, + &max_width, &avg_width, &height, + &space_width, &ascent, &descent, + &underline_pos, &underline_thickness); font->pixel_size = px_size; font->min_width = min_width; @@ -753,22 +841,31 @@ haikufont_open (struct frame *f, Lisp_Object font_entity, int x) static void haikufont_close (struct font *font) { + struct haikufont_info *info = (struct haikufont_info *) font; + int i; + if (font_data_structures_may_be_ill_formed ()) return; - struct haikufont_info *info = (struct haikufont_info *) font; block_input (); if (info && info->be_font) BFont_close (info->be_font); - for (int i = 0; i < info->metrics_nrows; i++) - if (info->metrics[i]) - xfree (info->metrics[i]); + for (i = 0; i < info->metrics_nrows; i++) + { + if (info->metrics[i]) + xfree (info->metrics[i]); + } + if (info->metrics) xfree (info->metrics); - for (int i = 0; i < 0x100; ++i) - if (info->glyphs[i]) - xfree (info->glyphs[i]); + + for (i = 0; i < 0x100; ++i) + { + if (info->glyphs[i]) + xfree (info->glyphs[i]); + } + xfree (info->glyphs); unblock_input (); } @@ -1069,6 +1166,86 @@ struct font_driver const haikufont_driver = .list_family = haikufont_list_family }; +static bool +haikufont_should_quit_popup (void) +{ + return !NILP (Vquit_flag); +} + +DEFUN ("x-select-font", Fx_select_font, Sx_select_font, 0, 2, 0, + doc: /* Read a font using a native dialog. +Return a font spec describing the font chosen by the user. + +FRAME is the frame on which to pop up the font chooser. If omitted or +nil, it defaults to the selected frame. +If EXCLUDE-PROPORTIONAL is non-nil, exclude proportional fonts +in the font selection dialog. */) + (Lisp_Object frame, Lisp_Object exclude_proportional) +{ + struct frame *f; + struct font *font; + Lisp_Object font_object; + haiku_font_family_or_style family, style; + int rc, size, initial_family, initial_style, initial_size; + struct haiku_font_pattern pattern; + Lisp_Object lfamily, lweight, lslant, lwidth, ladstyle, lsize; + + f = decode_window_system_frame (frame); + + if (popup_activated_p) + error ("Trying to use a menu from within a menu-entry"); + + initial_style = -1; + initial_family = -1; + initial_size = -1; + + font = FRAME_FONT (f); + + if (font) + { + XSETFONT (font_object, font); + + haikufont_pattern_from_object (&pattern, font_object); + be_find_font_indices (&pattern, &initial_family, + &initial_style); + haikufont_done_with_query_pattern (&pattern); + + initial_size = font->pixel_size; + } + + popup_activated_p++; + unrequest_sigio (); + rc = be_select_font (process_pending_signals, + haikufont_should_quit_popup, + &family, &style, &size, + !NILP (exclude_proportional), + initial_family, initial_style, + initial_size); + request_sigio (); + popup_activated_p--; + + if (!rc) + quit (); + + be_font_style_to_flags (style, &pattern); + + lfamily = build_string_from_utf8 (family); + lweight = (pattern.specified & FSPEC_WEIGHT + ? haikufont_weight_to_lisp (pattern.weight) : Qnil); + lslant = (pattern.specified & FSPEC_SLANT + ? haikufont_slant_to_lisp (pattern.slant) : Qnil); + lwidth = (pattern.specified & FSPEC_WIDTH + ? haikufont_width_to_lisp (pattern.width) : Qnil); + ladstyle = (pattern.specified & FSPEC_STYLE + ? intern (pattern.style) : Qnil); + lsize = (size >= 0 ? make_fixnum (size) : Qnil); + + return CALLN (Ffont_spec, QCfamily, lfamily, + QCweight, lweight, QCslant, lslant, + QCwidth, lwidth, QCadstyle, ladstyle, + QCsize, lsize); +} + void syms_of_haikufont (void) { @@ -1088,10 +1265,19 @@ syms_of_haikufont (void) DEFSYM (Qexpanded, "expanded"); DEFSYM (Qextra_expanded, "extra-expanded"); DEFSYM (Qultra_expanded, "ultra-expanded"); + DEFSYM (Qregular, "regular"); DEFSYM (Qzh, "zh"); DEFSYM (Qko, "ko"); DEFSYM (Qjp, "jp"); +#ifdef USE_BE_CAIRO + Fput (Qhaiku, Qfont_driver_superseded_by, Qftcr); +#endif + font_cache = list (Qnil); staticpro (&font_cache); + + defsubr (&Sx_select_font); + + be_init_font_data (); } diff --git a/src/haikuimage.c b/src/haikuimage.c index fe960bbc291..af3021c5cd9 100644 --- a/src/haikuimage.c +++ b/src/haikuimage.c @@ -42,8 +42,10 @@ haiku_can_use_native_image_api (Lisp_Object type) mime_type = "image/jpeg"; else if (EQ (type, Qpng)) mime_type = "image/png"; +#ifndef HAVE_GIF else if (EQ (type, Qgif)) mime_type = "image/gif"; +#endif else if (EQ (type, Qtiff)) mime_type = "image/tiff"; else if (EQ (type, Qbmp)) @@ -52,8 +54,12 @@ haiku_can_use_native_image_api (Lisp_Object type) mime_type = "image/svg"; else if (EQ (type, Qpbm)) mime_type = "image/pbm"; + /* Don't use native image APIs for image types that have animations, + since those aren't supported by the Translation Kit. */ +#ifndef HAVE_WEBP else if (EQ (type, Qwebp)) mime_type = "image/webp"; +#endif if (!mime_type) return 0; @@ -107,5 +113,4 @@ haiku_load_image (struct frame *f, struct image *img, void syms_of_haikuimage (void) { - DEFSYM (Qbmp, "bmp"); } diff --git a/src/haikumenu.c b/src/haikumenu.c index 8da00ffcb05..9779c34a998 100644 --- a/src/haikumenu.c +++ b/src/haikumenu.c @@ -29,6 +29,7 @@ along with GNU Emacs. If not, see . */ #include "haiku_support.h" static Lisp_Object *volatile menu_item_selection; +static struct timespec menu_timer_timespec; int popup_activated_p = 0; @@ -340,12 +341,35 @@ haiku_menu_show_help (void *help, void *data) show_help_echo (Qnil, Qnil, Qnil, Qnil); } +static Lisp_Object +haiku_process_pending_signals_for_menu_1 (void *ptr) +{ + menu_timer_timespec = timer_check (); + + return Qnil; +} + +static Lisp_Object +haiku_process_pending_signals_for_menu_2 (enum nonlocal_exit exit, Lisp_Object error) +{ + menu_timer_timespec.tv_sec = 0; + menu_timer_timespec.tv_nsec = -1; + + return Qnil; +} + static struct timespec haiku_process_pending_signals_for_menu (void) { process_pending_signals (); - return timer_check (); + /* The original idea was to let timers throw so that timeouts can + work correctly, but there's no way to pop down a BPopupMenu + that's currently popped up. */ + internal_catch_all (haiku_process_pending_signals_for_menu_1, NULL, + haiku_process_pending_signals_for_menu_2); + + return menu_timer_timespec; } Lisp_Object @@ -462,14 +486,19 @@ haiku_menu_show (struct frame *f, int x, int y, int menuflags, void free_frame_menubar (struct frame *f) { + void *mbar; + FRAME_MENU_BAR_LINES (f) = 0; FRAME_MENU_BAR_HEIGHT (f) = 0; FRAME_EXTERNAL_MENU_BAR (f) = 0; block_input (); - void *mbar = FRAME_HAIKU_MENU_BAR (f); + mbar = FRAME_HAIKU_MENU_BAR (f); + FRAME_HAIKU_MENU_BAR (f) = NULL; + if (mbar) BMenuBar_delete (mbar); + if (FRAME_OUTPUT_DATA (f)->menu_bar_open_p) --popup_activated_p; FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 0; @@ -492,13 +521,20 @@ set_frame_menubar (struct frame *f, bool deep_p) { void *mbar = FRAME_HAIKU_MENU_BAR (f); void *view = FRAME_HAIKU_VIEW (f); - - int first_time_p = 0; + bool first_time_p = false; if (!mbar) { + block_input (); mbar = FRAME_HAIKU_MENU_BAR (f) = BMenuBar_new (view); first_time_p = 1; + + /* Now wait for the MENU_BAR_RESIZE event informing us of the + initial dimensions of that menu bar. */ + if (FRAME_VISIBLE_P (f)) + haiku_wait_for_event (f, MENU_BAR_RESIZE); + + unblock_input (); } Lisp_Object items; @@ -517,7 +553,6 @@ set_frame_menubar (struct frame *f, bool deep_p) if (!deep_p) { - FRAME_OUTPUT_DATA (f)->menu_up_to_date_p = 0; items = FRAME_MENU_BAR_ITEMS (f); Lisp_Object string; @@ -630,8 +665,6 @@ set_frame_menubar (struct frame *f, bool deep_p) set_buffer_internal_1 (prev); - FRAME_OUTPUT_DATA (f)->menu_up_to_date_p = 1; - /* If there has been no change in the Lisp-level contents of the menu bar, skip redisplaying it. Just exit. */ @@ -681,19 +714,11 @@ set_frame_menubar (struct frame *f, bool deep_p) void run_menu_bar_help_event (struct frame *f, int mb_idx) { - Lisp_Object frame; - Lisp_Object vec; - Lisp_Object help; - - block_input (); - if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) - { - unblock_input (); - return; - } + Lisp_Object frame, vec, help; XSETFRAME (frame, f); + block_input (); if (mb_idx < 0) { kbd_buffer_store_help_event (frame, Qnil); @@ -728,21 +753,65 @@ the position of the last non-menu event instead. */) (Lisp_Object frame) { struct frame *f = decode_window_system_frame (frame); + int rc; if (FRAME_EXTERNAL_MENU_BAR (f)) { block_input (); set_frame_menubar (f, 1); - BMenuBar_start_tracking (FRAME_HAIKU_MENU_BAR (f)); + rc = BMenuBar_start_tracking (FRAME_HAIKU_MENU_BAR (f)); unblock_input (); + + if (!rc) + return Qnil; + + FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 1; + popup_activated_p += 1; + } + else + return call2 (Qpopup_menu, call0 (Qmouse_menu_bar_map), + last_nonmenu_event); + + return Qnil; +} + +void +haiku_activate_menubar (struct frame *f) +{ + int rc; + + if (!FRAME_HAIKU_MENU_BAR (f)) + return; + + set_frame_menubar (f, true); + + if (FRAME_OUTPUT_DATA (f)->saved_menu_event) + { + block_input (); + rc = be_replay_menu_bar_event (FRAME_HAIKU_MENU_BAR (f), + FRAME_OUTPUT_DATA (f)->saved_menu_event); + xfree (FRAME_OUTPUT_DATA (f)->saved_menu_event); + FRAME_OUTPUT_DATA (f)->saved_menu_event = NULL; + unblock_input (); + + if (!rc) + return; + + FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 1; + popup_activated_p += 1; } else { - return call2 (Qpopup_menu, call0 (Qmouse_menu_bar_map), - last_nonmenu_event); - } + block_input (); + rc = BMenuBar_start_tracking (FRAME_HAIKU_MENU_BAR (f)); + unblock_input (); - return Qnil; + if (!rc) + return; + + FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 1; + popup_activated_p += 1; + } } void diff --git a/src/haikuselect.c b/src/haikuselect.c index 65dac0e02fa..a186acc66ff 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -23,113 +23,154 @@ along with GNU Emacs. If not, see . */ #include "coding.h" #include "haikuselect.h" #include "haikuterm.h" +#include "haiku_support.h" #include -static Lisp_Object -haiku_selection_data_1 (Lisp_Object clipboard) -{ - Lisp_Object result = Qnil; - char *targets[256]; +/* The frame that is currently the source of a drag-and-drop + operation, or NULL if none is in progress. The reason for this + variable is to prevent it from being deleted, which really breaks + the nested event loop inside be_drag_message. */ +struct frame *haiku_dnd_frame; - block_input (); - if (EQ (clipboard, QPRIMARY)) - BClipboard_primary_targets ((char **) &targets, 256); - else if (EQ (clipboard, QSECONDARY)) - BClipboard_secondary_targets ((char **) &targets, 256); - else if (EQ (clipboard, QCLIPBOARD)) - BClipboard_system_targets ((char **) &targets, 256); - else - { - unblock_input (); - signal_error ("Bad clipboard", clipboard); - } - - for (int i = 0; targets[i]; ++i) - { - result = Fcons (build_unibyte_string (targets[i]), - result); - free (targets[i]); - } - unblock_input (); - - return result; -} - -DEFUN ("haiku-selection-targets", Fhaiku_selection_targets, - Shaiku_selection_targets, 1, 1, 0, - doc: /* Find the types of data available from CLIPBOARD. -CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. -Return the available types as a list of strings. */) - (Lisp_Object clipboard) -{ - return haiku_selection_data_1 (clipboard); -} +static void haiku_lisp_to_message (Lisp_Object, void *); DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data, 2, 2, 0, doc: /* Retrieve content typed as NAME from the clipboard CLIPBOARD. CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or -`CLIPBOARD'. NAME is a MIME type denoting the type of the data to -fetch. */) +`CLIPBOARD'. NAME is a string describing the MIME type denoting the +type of the data to fetch. If NAME is nil, then the entire contents +of the clipboard will be returned instead, as a serialized system +message in the format accepted by `haiku-drag-message', which see. */) (Lisp_Object clipboard, Lisp_Object name) { - CHECK_SYMBOL (clipboard); - CHECK_STRING (name); char *dat; ssize_t len; + Lisp_Object str; + void *message; + enum haiku_clipboard clipboard_name; + int rc; - block_input (); - if (EQ (clipboard, QPRIMARY)) - dat = BClipboard_find_primary_selection_data (SSDATA (name), &len); - else if (EQ (clipboard, QSECONDARY)) - dat = BClipboard_find_secondary_selection_data (SSDATA (name), &len); - else if (EQ (clipboard, QCLIPBOARD)) - dat = BClipboard_find_system_data (SSDATA (name), &len); + CHECK_SYMBOL (clipboard); + + if (!EQ (clipboard, QPRIMARY) && !EQ (clipboard, QSECONDARY) + && !EQ (clipboard, QCLIPBOARD)) + signal_error ("Invalid clipboard", clipboard); + + if (!NILP (name)) + { + CHECK_STRING (name); + + block_input (); + if (EQ (clipboard, QPRIMARY)) + dat = BClipboard_find_primary_selection_data (SSDATA (name), &len); + else if (EQ (clipboard, QSECONDARY)) + dat = BClipboard_find_secondary_selection_data (SSDATA (name), &len); + else + dat = BClipboard_find_system_data (SSDATA (name), &len); + unblock_input (); + + if (!dat) + return Qnil; + + str = make_unibyte_string (dat, len); + + /* `foreign-selection' just means that the selection has to be + decoded by `gui-get-selection'. It has no other meaning, + AFAICT. */ + Fput_text_property (make_fixnum (0), make_fixnum (len), + Qforeign_selection, Qt, str); + + block_input (); + BClipboard_free_data (dat); + unblock_input (); + } else { + if (EQ (clipboard, QPRIMARY)) + clipboard_name = CLIPBOARD_PRIMARY; + else if (EQ (clipboard, QSECONDARY)) + clipboard_name = CLIPBOARD_SECONDARY; + else + clipboard_name = CLIPBOARD_CLIPBOARD; + + block_input (); + rc = be_lock_clipboard_message (clipboard_name, &message, false); + unblock_input (); + + if (rc) + signal_error ("Couldn't open clipboard", clipboard); + + block_input (); + str = haiku_message_to_lisp (message); + be_unlock_clipboard (clipboard_name, true); unblock_input (); - signal_error ("Bad clipboard", clipboard); } - unblock_input (); - - if (!dat) - return Qnil; - - Lisp_Object str = make_unibyte_string (dat, len); - - /* `foreign-selection' just means that the selection has to be - decoded by `gui-get-selection'. It has no other meaning, - AFAICT. */ - Fput_text_property (make_fixnum (0), make_fixnum (len), - Qforeign_selection, Qt, str); - - block_input (); - BClipboard_free_data (dat); - unblock_input (); return str; } +static void +haiku_unwind_clipboard_lock (int clipboard) +{ + be_unlock_clipboard (clipboard, false); +} + DEFUN ("haiku-selection-put", Fhaiku_selection_put, Shaiku_selection_put, - 3, 4, 0, + 2, 4, 0, doc: /* Add or remove content from the clipboard CLIPBOARD. CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'. NAME is a MIME type denoting the type of the data to add. DATA is the string that will be placed in the clipboard, or nil if the content is to be removed. CLEAR, if non-nil, means to erase all the previous -contents of the clipboard. */) +contents of the clipboard. + +Alternatively, NAME can be a system message in the format accepted by +`haiku-drag-message', which will replace the contents of CLIPBOARD. +In that case, the arguments after NAME are ignored. */) (Lisp_Object clipboard, Lisp_Object name, Lisp_Object data, Lisp_Object clear) { + enum haiku_clipboard clipboard_name; + specpdl_ref ref; + char *dat; + ptrdiff_t len; + int rc; + void *message; + + if (CONSP (name) || NILP (name)) + { + if (EQ (clipboard, QPRIMARY)) + clipboard_name = CLIPBOARD_PRIMARY; + else if (EQ (clipboard, QSECONDARY)) + clipboard_name = CLIPBOARD_SECONDARY; + else if (EQ (clipboard, QCLIPBOARD)) + clipboard_name = CLIPBOARD_CLIPBOARD; + else + signal_error ("Invalid clipboard", clipboard); + + rc = be_lock_clipboard_message (clipboard_name, + &message, true); + + if (rc) + signal_error ("Couldn't open clipboard", clipboard); + + ref = SPECPDL_INDEX (); + record_unwind_protect_int (haiku_unwind_clipboard_lock, + clipboard_name); + haiku_lisp_to_message (name, message); + + return unbind_to (ref, Qnil); + } + CHECK_SYMBOL (clipboard); CHECK_STRING (name); if (!NILP (data)) CHECK_STRING (data); - block_input (); - char *dat = !NILP (data) ? SSDATA (data) : NULL; - ptrdiff_t len = !NILP (data) ? SBYTES (data) : 0; + dat = !NILP (data) ? SSDATA (data) : NULL; + len = !NILP (data) ? SBYTES (data) : 0; if (EQ (clipboard, QPRIMARY)) BClipboard_set_primary_selection_data (SSDATA (name), dat, len, @@ -144,7 +185,6 @@ contents of the clipboard. */) unblock_input (); signal_error ("Bad clipboard", clipboard); } - unblock_input (); return Qnil; } @@ -179,18 +219,647 @@ same as `SECONDARY'. */) return value ? Qt : Qnil; } +/* Return the Lisp representation of MESSAGE. See Fhaiku_drag_message + for the format of the object returned. */ +Lisp_Object +haiku_message_to_lisp (void *message) +{ + Lisp_Object list = Qnil, tem, t1, t2; + const char *name; + char *pbuf; + const void *buf; + ssize_t buf_size; + int32 i, j, count, type_code; + int rc; + void *msg; + float point_x, point_y; + + for (i = 0; !be_enum_message (message, &type_code, i, + &count, &name); ++i) + { + tem = Qnil; + + for (j = 0; j < count; ++j) + { + rc = be_get_message_data (message, name, + type_code, j, + &buf, &buf_size); + if (rc) + emacs_abort (); + + switch (type_code) + { + case 'MSGG': + msg = be_get_message_message (message, name, j); + if (!msg) + memory_full (SIZE_MAX); + t1 = haiku_message_to_lisp (msg); + BMessage_delete (msg); + + break; + + case 'BOOL': + t1 = (*(bool *) buf) ? Qt : Qnil; + break; + + case 'RREF': + rc = be_get_refs_data (message, name, + j, &pbuf); + + if (rc) + { + t1 = Qnil; + break; + } + + if (!pbuf) + memory_full (SIZE_MAX); + + t1 = build_string (pbuf); + + free (pbuf); + break; + + case 'BPNT': + rc = be_get_point_data (message, name, + j, &point_x, + &point_y); + + if (rc) + { + t1 = Qnil; + break; + } + + t1 = Fcons (make_float (point_x), + make_float (point_y)); + break; + + case 'SHRT': + t1 = make_fixnum (*(int16 *) buf); + break; + + case 'LONG': + t1 = make_int (*(int32 *) buf); + break; + + case 'LLNG': + t1 = make_int ((intmax_t) *(int64 *) buf); + break; + + case 'BYTE': + case 'CHAR': + t1 = make_fixnum (*(int8 *) buf); + break; + + case 'SIZT': + t1 = make_uint ((uintmax_t) *(size_t *) buf); + break; + + case 'SSZT': + t1 = make_int ((intmax_t) *(ssize_t *) buf); + break; + + default: + t1 = make_uninit_string (buf_size); + memcpy (SDATA (t1), buf, buf_size); + } + + tem = Fcons (t1, tem); + } + + switch (type_code) + { + case 'CSTR': + t2 = Qstring; + break; + + case 'SHRT': + t2 = Qshort; + break; + + case 'LONG': + t2 = Qlong; + break; + + case 'LLNG': + t2 = Qllong; + break; + + case 'BYTE': + t2 = Qbyte; + break; + + case 'RREF': + t2 = Qref; + break; + + case 'CHAR': + t2 = Qchar; + break; + + case 'BOOL': + t2 = Qbool; + break; + + case 'MSGG': + t2 = Qmessage; + break; + + case 'SIZT': + t2 = Qsize_t; + break; + + case 'SSZT': + t2 = Qssize_t; + break; + + case 'BPNT': + t2 = Qpoint; + break; + + default: + t2 = make_int (type_code); + } + + tem = Fcons (t2, tem); + list = Fcons (Fcons (build_string_from_utf8 (name), tem), list); + } + + tem = Fcons (Qtype, make_uint (be_get_message_type (message))); + return Fcons (tem, list); +} + +static int32 +lisp_to_type_code (Lisp_Object obj) +{ + if (BIGNUMP (obj)) + return (int32) bignum_to_intmax (obj); + + if (FIXNUMP (obj)) + return XFIXNUM (obj); + + if (EQ (obj, Qstring)) + return 'CSTR'; + else if (EQ (obj, Qshort)) + return 'SHRT'; + else if (EQ (obj, Qlong)) + return 'LONG'; + else if (EQ (obj, Qllong)) + return 'LLNG'; + else if (EQ (obj, Qbyte)) + return 'BYTE'; + else if (EQ (obj, Qref)) + return 'RREF'; + else if (EQ (obj, Qchar)) + return 'CHAR'; + else if (EQ (obj, Qbool)) + return 'BOOL'; + else if (EQ (obj, Qmessage)) + return 'MSGG'; + else if (EQ (obj, Qsize_t)) + return 'SIZT'; + else if (EQ (obj, Qssize_t)) + return 'SSZT'; + else if (EQ (obj, Qpoint)) + return 'BPNT'; + else + return -1; +} + +static void +haiku_lisp_to_message (Lisp_Object obj, void *message) +{ + Lisp_Object tem, t1, name, type_sym, t2, data; + int32 type_code, long_data; + int16 short_data; + int64 llong_data; + int8 char_data; + bool bool_data; + void *msg_data; + size_t sizet_data; + ssize_t ssizet_data; + intmax_t t4; + uintmax_t t5; + float t6, t7; + int rc; + specpdl_ref ref; + + CHECK_LIST (obj); + for (tem = obj; CONSP (tem); tem = XCDR (tem)) + { + maybe_quit (); + t1 = XCAR (tem); + CHECK_CONS (t1); + + name = XCAR (t1); + + if (EQ (name, Qtype)) + { + t2 = XCDR (t1); + + if (BIGNUMP (t2)) + { + t5 = bignum_to_uintmax (t2); + + if (!t5 || t5 > TYPE_MAXIMUM (uint32)) + signal_error ("Value too large", t2); + + block_input (); + be_set_message_type (message, t5); + unblock_input (); + } + else + { + if (!TYPE_RANGED_FIXNUMP (uint32, t2)) + signal_error ("Invalid data type", t2); + + block_input (); + be_set_message_type (message, XFIXNAT (t2)); + unblock_input (); + } + + continue; + } + + CHECK_STRING (name); + + t1 = XCDR (t1); + CHECK_CONS (t1); + + type_sym = XCAR (t1); + type_code = lisp_to_type_code (type_sym); + + if (type_code == -1) + signal_error ("Unknown data type", type_sym); + + CHECK_LIST (t1); + for (t2 = XCDR (t1); CONSP (t2); t2 = XCDR (t2)) + { + maybe_quit (); + data = XCAR (t2); + + if (FIXNUMP (type_sym) || BIGNUMP (type_sym)) + goto decode_normally; + + switch (type_code) + { + case 'MSGG': + ref = SPECPDL_INDEX (); + + block_input (); + msg_data = be_create_simple_message (); + unblock_input (); + + record_unwind_protect_ptr (BMessage_delete, msg_data); + haiku_lisp_to_message (data, msg_data); + + block_input (); + rc = be_add_message_message (message, SSDATA (name), msg_data); + unblock_input (); + + if (rc) + signal_error ("Invalid message", msg_data); + unbind_to (ref, Qnil); + break; + + case 'RREF': + CHECK_STRING (data); + + if (be_add_refs_data (message, SSDATA (name), SSDATA (data)) + && haiku_signal_invalid_refs) + signal_error ("Invalid file name", data); + break; + + case 'BPNT': + CHECK_CONS (data); + CHECK_NUMBER (XCAR (data)); + CHECK_NUMBER (XCDR (data)); + + t6 = XFLOATINT (XCAR (data)); + t7 = XFLOATINT (XCDR (data)); + + if (be_add_point_data (message, SSDATA (name), + t6, t7)) + signal_error ("Invalid point", data); + break; + + case 'SHRT': + if (!TYPE_RANGED_FIXNUMP (int16, data)) + signal_error ("Invalid value", data); + short_data = XFIXNUM (data); + + block_input (); + rc = be_add_message_data (message, SSDATA (name), + type_code, &short_data, + sizeof short_data); + unblock_input (); + + if (rc) + signal_error ("Failed to add short", data); + break; + + case 'LONG': + if (BIGNUMP (data)) + { + t4 = bignum_to_intmax (data); + + /* We know that int32 is signed. */ + if (!t4 || t4 > TYPE_MINIMUM (int32) + || t4 < TYPE_MAXIMUM (int32)) + signal_error ("Value too large", data); + + long_data = (int32) t4; + } + else + { + if (!TYPE_RANGED_FIXNUMP (int32, data)) + signal_error ("Invalid value", data); + + long_data = (int32) XFIXNUM (data); + } + + block_input (); + rc = be_add_message_data (message, SSDATA (name), + type_code, &long_data, + sizeof long_data); + unblock_input (); + + if (rc) + signal_error ("Failed to add long", data); + break; + + case 'LLNG': + if (BIGNUMP (data)) + { + t4 = bignum_to_intmax (data); + + if (!t4 || t4 > TYPE_MINIMUM (int64) + || t4 < TYPE_MAXIMUM (int64)) + signal_error ("Value too large", data); + + llong_data = (int64) t4; + } + else + { + if (!TYPE_RANGED_FIXNUMP (int64, data)) + signal_error ("Invalid value", data); + + llong_data = (int64) XFIXNUM (data); + } + + block_input (); + rc = be_add_message_data (message, SSDATA (name), + type_code, &llong_data, + sizeof llong_data); + unblock_input (); + + if (rc) + signal_error ("Failed to add llong", data); + break; + + case 'SIZT': + if (BIGNUMP (data)) + { + t4 = bignum_to_intmax (data); + + if (!t4 || t4 > TYPE_MAXIMUM (size_t)) + signal_error ("Value too large", data); + + sizet_data = (size_t) t4; + } + else + { + if (!TYPE_RANGED_FIXNUMP (size_t, data)) + signal_error ("Invalid value", data); + + sizet_data = (int64) XFIXNUM (data); + } + + block_input (); + rc = be_add_message_data (message, SSDATA (name), + type_code, &sizet_data, + sizeof sizet_data); + unblock_input (); + + if (rc) + signal_error ("Failed to add sizet", data); + break; + + case 'SSZT': + if (BIGNUMP (data)) + { + t4 = bignum_to_intmax (data); + + if (!t4 || t4 > TYPE_MINIMUM (ssize_t) + || t4 < TYPE_MAXIMUM (ssize_t)) + signal_error ("Value too large", data); + + ssizet_data = (ssize_t) t4; + } + else + { + if (!TYPE_RANGED_FIXNUMP (ssize_t, data)) + signal_error ("Invalid value", data); + + ssizet_data = (int64) XFIXNUM (data); + } + + block_input (); + rc = be_add_message_data (message, SSDATA (name), + type_code, &ssizet_data, + sizeof ssizet_data); + unblock_input (); + + if (rc) + signal_error ("Failed to add ssizet", data); + break; + + case 'CHAR': + case 'BYTE': + if (!TYPE_RANGED_FIXNUMP (int8, data)) + signal_error ("Invalid value", data); + char_data = XFIXNUM (data); + + block_input (); + rc = be_add_message_data (message, SSDATA (name), + type_code, &char_data, + sizeof char_data); + unblock_input (); + + if (rc) + signal_error ("Failed to add char", data); + break; + + case 'BOOL': + bool_data = !NILP (data); + + block_input (); + rc = be_add_message_data (message, SSDATA (name), + type_code, &bool_data, + sizeof bool_data); + unblock_input (); + + if (rc) + signal_error ("Failed to add bool", data); + break; + + default: + decode_normally: + CHECK_STRING (data); + + block_input (); + rc = be_add_message_data (message, SSDATA (name), + type_code, SDATA (data), + SBYTES (data)); + unblock_input (); + + if (rc) + signal_error ("Failed to add", data); + } + } + CHECK_LIST_END (t2, t1); + } + CHECK_LIST_END (tem, obj); +} + +static bool +haiku_should_quit_drag (void) +{ + return !NILP (Vquit_flag); +} + +static void +haiku_unwind_drag_message (void *message) +{ + haiku_dnd_frame = NULL; + BMessage_delete (message); +} + +DEFUN ("haiku-drag-message", Fhaiku_drag_message, Shaiku_drag_message, + 2, 3, 0, + doc: /* Begin dragging MESSAGE from FRAME. + +MESSAGE an alist of strings, denoting message field names, to a list +the form (TYPE DATA ...), where TYPE is an integer denoting the system +data type of DATA, and DATA is in the general case a unibyte string. + +If TYPE is a symbol instead of an integer, then DATA was specially +decoded. If TYPE is `ref', then DATA is the absolute file name of a +file, or nil if decoding the file name failed. If TYPE is `string', +then DATA is a unibyte string. If TYPE is `short', then DATA is a +16-bit signed integer. If TYPE is `long', then DATA is a 32-bit +signed integer. If TYPE is `llong', then DATA is a 64-bit signed +integer. If TYPE is `byte' or `char', then DATA is an 8-bit signed +integer. If TYPE is `bool', then DATA is a boolean. If TYPE is +`size_t', then DATA is an integer that can hold between 0 and the +maximum value returned by the `sizeof' C operator on the current +system. If TYPE is `ssize_t', then DATA is an integer that can hold +values from -1 to the maximum value of the C data type `ssize_t' on +the current system. If TYPE is `point', then DATA is a cons of float +values describing the X and Y coordinates of an on-screen location. + +If the field name is not a string but the symbol `type', then it +associates to a 32-bit unsigned integer describing the type of the +system message. + +FRAME is a window system frame that must be visible, from which the +drag will originate. + +ALLOW-SAME-FRAME, if nil or not specified, means that MESSAGE will be +ignored if it is dropped on top of FRAME. */) + (Lisp_Object frame, Lisp_Object message, Lisp_Object allow_same_frame) +{ + specpdl_ref idx; + void *be_message; + struct frame *f; + bool rc; + + idx = SPECPDL_INDEX (); + f = decode_window_system_frame (frame); + + if (!FRAME_VISIBLE_P (f)) + error ("Frame is invisible"); + + haiku_dnd_frame = f; + be_message = be_create_simple_message (); + + record_unwind_protect_ptr (haiku_unwind_drag_message, be_message); + haiku_lisp_to_message (message, be_message); + rc = be_drag_message (FRAME_HAIKU_VIEW (f), be_message, + !NILP (allow_same_frame), + block_input, unblock_input, + process_pending_signals, + haiku_should_quit_drag); + FRAME_DISPLAY_INFO (f)->grabbed = 0; + + if (rc) + quit (); + + return unbind_to (idx, Qnil); +} + +static Lisp_Object +haiku_note_drag_motion_1 (void *data) +{ + if (!NILP (Vhaiku_drag_track_function)) + return call0 (Vhaiku_drag_track_function); + + return Qnil; +} + +static Lisp_Object +haiku_note_drag_motion_2 (enum nonlocal_exit exit, Lisp_Object error) +{ + return Qnil; +} + +void +haiku_note_drag_motion (void) +{ + internal_catch_all (haiku_note_drag_motion_1, NULL, + haiku_note_drag_motion_2); +} + void syms_of_haikuselect (void) { + DEFVAR_BOOL ("haiku-signal-invalid-refs", haiku_signal_invalid_refs, + doc: /* If nil, silently ignore invalid file names in system messages. +Otherwise, an error will be signalled if adding a file reference to a +system message failed. */); + haiku_signal_invalid_refs = true; + + DEFVAR_LISP ("haiku-drag-track-function", Vhaiku_drag_track_function, + doc: /* If non-nil, a function to call upon mouse movement while dragging a message. +The function is called without any arguments. `mouse-position' can be +used to retrieve the current position of the mouse. */); + Vhaiku_drag_track_function = Qnil; + DEFSYM (QSECONDARY, "SECONDARY"); DEFSYM (QCLIPBOARD, "CLIPBOARD"); DEFSYM (QSTRING, "STRING"); DEFSYM (QUTF8_STRING, "UTF8_STRING"); DEFSYM (Qforeign_selection, "foreign-selection"); DEFSYM (QTARGETS, "TARGETS"); + DEFSYM (Qmessage, "message"); + DEFSYM (Qstring, "string"); + DEFSYM (Qref, "ref"); + DEFSYM (Qshort, "short"); + DEFSYM (Qlong, "long"); + DEFSYM (Qllong, "llong"); + DEFSYM (Qbyte, "byte"); + DEFSYM (Qchar, "char"); + DEFSYM (Qbool, "bool"); + DEFSYM (Qtype, "type"); + DEFSYM (Qsize_t, "size_t"); + DEFSYM (Qssize_t, "ssize_t"); + DEFSYM (Qpoint, "point"); defsubr (&Shaiku_selection_data); defsubr (&Shaiku_selection_put); - defsubr (&Shaiku_selection_targets); defsubr (&Shaiku_selection_owner_p); + defsubr (&Shaiku_drag_message); + + haiku_dnd_frame = NULL; } diff --git a/src/haikuselect.h b/src/haikuselect.h index 566aae596f6..d4f331a9ccb 100644 --- a/src/haikuselect.h +++ b/src/haikuselect.h @@ -21,63 +21,68 @@ along with GNU Emacs. If not, see . */ #ifdef __cplusplus #include +#else +#include #endif +#include + +enum haiku_clipboard + { + CLIPBOARD_PRIMARY, + CLIPBOARD_SECONDARY, + CLIPBOARD_CLIPBOARD + }; + #ifdef __cplusplus -#include extern "C" { - extern void init_haiku_select (void); +extern void init_haiku_select (void); #endif +/* Whether or not the selection was recently changed. */ - /* Whether or not the selection was recently changed. */ - extern int selection_state_flag; +/* Find a string with the MIME type TYPE in the system clipboard. */ +extern char *BClipboard_find_system_data (const char *, ssize_t *); +extern char *BClipboard_find_primary_selection_data (const char *, ssize_t *); +extern char *BClipboard_find_secondary_selection_data (const char *, ssize_t *); - /* Find a string with the MIME type TYPE in the system clipboard. */ - extern char * - BClipboard_find_system_data (const char *type, ssize_t *len); +extern void BClipboard_set_system_data (const char *, const char *, ssize_t, bool); +extern void BClipboard_set_primary_selection_data (const char *, const char *, + ssize_t, bool); +extern void BClipboard_set_secondary_selection_data (const char *, const char *, + ssize_t, bool); - /* Ditto, but for the primary selection and not clipboard. */ - extern char * - BClipboard_find_primary_selection_data (const char *type, ssize_t *len); +extern void BClipboard_system_targets (char **, int); +extern void BClipboard_primary_targets (char **, int); +extern void BClipboard_secondary_targets (char **, int); - /* Ditto, this time for the secondary selection. */ - extern char * - BClipboard_find_secondary_selection_data (const char *type, ssize_t *len); +extern bool BClipboard_owns_clipboard (void); +extern bool BClipboard_owns_primary (void); +extern bool BClipboard_owns_secondary (void); - extern void - BClipboard_set_system_data (const char *type, const char *data, ssize_t len, - bool clear); +/* Free the returned data. */ +extern void BClipboard_free_data (void *); - extern void - BClipboard_set_primary_selection_data (const char *type, const char *data, - ssize_t len, bool clear); - - extern void - BClipboard_set_secondary_selection_data (const char *type, const char *data, - ssize_t len, bool clear); - - extern void - BClipboard_system_targets (char **buf, int len); - - extern void - BClipboard_primary_targets (char **buf, int len); - - extern void - BClipboard_secondary_targets (char **buf, int len); - - extern bool - BClipboard_owns_clipboard (void); - - extern bool - BClipboard_owns_primary (void); - - extern bool - BClipboard_owns_secondary (void); - - /* Free the returned data. */ - extern void BClipboard_free_data (void *ptr); +extern int be_enum_message (void *, int32 *, int32, int32 *, const char **); +extern int be_get_message_data (void *, const char *, int32, int32, + const void **, ssize_t *); +extern int be_get_refs_data (void *, const char *, int32, char **); +extern int be_get_point_data (void *, const char *, int32, float *, float *); +extern uint32 be_get_message_type (void *); +extern void be_set_message_type (void *, uint32); +extern void *be_get_message_message (void *, const char *, int32); +extern void *be_create_simple_message (void); +extern int be_add_message_data (void *, const char *, int32, const void *, ssize_t); +extern int be_add_refs_data (void *, const char *, const char *); +extern int be_add_point_data (void *, const char *, float, float); +extern int be_add_message_message (void *, const char *, void *); +extern int be_lock_clipboard_message (enum haiku_clipboard, void **, bool); +extern void be_unlock_clipboard (enum haiku_clipboard, bool); #ifdef __cplusplus }; #endif #endif /* _HAIKU_SELECT_H_ */ + +// Local Variables: +// eval: (setf (alist-get 'inextern-lang c-offsets-alist) 0) +// End: diff --git a/src/haikuterm.c b/src/haikuterm.c index d3168129ce4..ced16d9f09b 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -40,22 +40,21 @@ along with GNU Emacs. If not, see . */ #include #endif +/* Minimum and maximum values used for Haiku scroll bars. */ +#define BE_SB_MAX 12000000 + struct haiku_display_info *x_display_list = NULL; extern frame_parm_handler haiku_frame_parm_handlers[]; +/* This is used to determine when to evict the font lookup cache, + which we do every 50 updates. */ +static int up_to_date_count; + static void **fringe_bmps; static int max_fringe_bmp = 0; static Lisp_Object rdb; - -struct unhandled_event -{ - struct unhandled_event *next; - enum haiku_event_type type; - uint8_t buffer[200]; -}; - -static bool any_help_event_p = false; +static bool any_help_event_p; char * get_keysym_name (int keysym) @@ -112,7 +111,7 @@ haiku_toolkit_position (struct frame *f, int x, int y, static void haiku_delete_terminal (struct terminal *terminal) { - emacs_abort (); + error ("The Haiku terminal cannot be deleted"); } static const char * @@ -137,23 +136,15 @@ get_string_resource (void *ignored, const char *name, const char *class) static void haiku_update_size_hints (struct frame *f) { - int base_width, base_height; - eassert (FRAME_HAIKU_P (f) && FRAME_HAIKU_WINDOW (f)); - if (f->tooltip) return; - base_width = FRAME_TEXT_COLS_TO_PIXEL_WIDTH (f, 0); - base_height = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, 0); - block_input (); BWindow_set_size_alignment (FRAME_HAIKU_WINDOW (f), - frame_resize_pixelwise ? 1 : FRAME_COLUMN_WIDTH (f), - frame_resize_pixelwise ? 1 : FRAME_LINE_HEIGHT (f)); - BWindow_set_min_size (FRAME_HAIKU_WINDOW (f), base_width, - base_height - + FRAME_TOOL_BAR_HEIGHT (f) - + FRAME_MENU_BAR_HEIGHT (f)); + (frame_resize_pixelwise + ? 1 : FRAME_COLUMN_WIDTH (f)), + (frame_resize_pixelwise + ? 1 : FRAME_LINE_HEIGHT (f))); unblock_input (); } @@ -228,6 +219,13 @@ haiku_frame_up_to_date (struct frame *f) FRAME_MOUSE_UPDATE (f); if (FRAME_DIRTY_P (f) && !buffer_flipping_blocked_p ()) haiku_flip_buffers (f); + + up_to_date_count++; + if (up_to_date_count == 50) + { + be_evict_font_cache (); + up_to_date_count = 0; + } unblock_input (); } @@ -406,20 +404,21 @@ haiku_frame_raise_lower (struct frame *f, bool raise_p) } static struct frame * -haiku_mouse_or_wdesc_frame (void *window) +haiku_mouse_or_wdesc_frame (void *window, bool accept_tooltip) { struct frame *lm_f = (gui_mouse_grabbed (x_display_list) ? x_display_list->last_mouse_frame : NULL); - if (lm_f && !EQ (track_mouse, Qdropping)) + if (lm_f && !EQ (track_mouse, Qdropping) + && !EQ (track_mouse, Qdrag_source)) return lm_f; else { struct frame *w_f = haiku_window_to_frame (window); /* Do not return a tooltip frame. */ - if (!w_f || FRAME_TOOLTIP_P (w_f)) + if (!w_f || (FRAME_TOOLTIP_P (w_f) && !accept_tooltip)) return EQ (track_mouse, Qdropping) ? lm_f : NULL; else /* When dropping it would be probably nice to raise w_f @@ -428,6 +427,81 @@ haiku_mouse_or_wdesc_frame (void *window) } } +/* Set the thumb size and position of scroll bar BAR. We are + currently displaying PORTION out of a whole WHOLE, and our position + POSITION. */ + +static void +haiku_set_scroll_bar_thumb (struct scroll_bar *bar, int portion, + int position, int whole) +{ + void *scroll_bar = bar->scroll_bar; + double top, shown, size, value; + + if (scroll_bar_adjust_thumb_portion_p) + { + /* We use an estimate of 30 chars per line rather than the real + `portion' value. This has the disadvantage that the thumb + size is not very representative, but it makes our life a lot + easier. Otherwise, we have to constantly adjust the thumb + size, which we can't always do quickly enough: while + dragging, the size of the thumb might prevent the user from + dragging the thumb all the way to the end. */ + portion = WINDOW_TOTAL_LINES (XWINDOW (bar->window)) * 30; + /* When the thumb is at the bottom, position == whole. So we + need to increase `whole' to make space for the thumb. */ + whole += portion; + } + else + bar->page_size = 0; + + if (whole <= 0) + top = 0, shown = 1; + else + { + top = (double) position / whole; + shown = (double) portion / whole; + } + + /* Slider size. Must be in the range [1 .. MAX - MIN] where MAX + is the scroll bar's maximum and MIN is the scroll bar's minimum + value. */ + size = clip_to_bounds (1, shown * BE_SB_MAX, BE_SB_MAX); + + /* Position. Must be in the range [MIN .. MAX - SLIDER_SIZE]. */ + value = top * BE_SB_MAX; + value = min (value, BE_SB_MAX - size); + + if (!bar->dragging && scroll_bar_adjust_thumb_portion_p) + bar->page_size = size; + + BView_scroll_bar_update (scroll_bar, lrint (size), + BE_SB_MAX, ceil (value), + (scroll_bar_adjust_thumb_portion_p + ? bar->dragging : bar->dragging ? -1 : 0), + !scroll_bar_adjust_thumb_portion_p); +} + +static void +haiku_set_horizontal_scroll_bar_thumb (struct scroll_bar *bar, int portion, + int position, int whole) +{ + void *scroll_bar = bar->scroll_bar; + double size, value, shown, top; + + shown = (double) portion / whole; + top = (double) position / whole; + + size = shown * BE_SB_MAX; + value = top * BE_SB_MAX; + + if (!bar->dragging) + bar->page_size = size; + + BView_scroll_bar_update (scroll_bar, lrint (size), BE_SB_MAX, + ceil (value), bar->dragging ? -1 : 0, true); +} + static struct scroll_bar * haiku_scroll_bar_from_widget (void *scroll_bar, void *window) { @@ -531,35 +605,45 @@ haiku_calculate_relief_colors (struct glyph_string *s, uint32_t *rgbout_w, uint32_t *rgbout_b) { struct face *face = s->face; + double h, cs, l; + uint32_t rgbin; + struct haiku_output *di; - prepare_face_for_display (s->f, s->face); - - uint32_t rgbin = face->use_box_color_for_shadows_p - ? face->box_color : face->background; + rgbin = (face->use_box_color_for_shadows_p + ? face->box_color : face->background); + di = FRAME_OUTPUT_DATA (s->f); if (s->hl == DRAW_CURSOR) rgbin = FRAME_CURSOR_COLOR (s->f).pixel; - double h, cs, l; - rgb_color_hsl (rgbin, &h, &cs, &l); + if (di->relief_background != rgbin) + { + di->relief_background = rgbin & 0xffffffff; - hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 0.6), rgbout_b); - hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 1.2), rgbout_w); + rgb_color_hsl (rgbin, &h, &cs, &l); + hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 0.6), + &di->black_relief_pixel); + hsl_color_rgb (h, cs, fmin (1.0, fmax (0.2, l) * 1.2), + &di->white_relief_pixel); + } + + *rgbout_w = di->white_relief_pixel; + *rgbout_b = di->black_relief_pixel; } static void haiku_draw_relief_rect (struct glyph_string *s, int left_x, int top_y, int right_x, int bottom_y, - int hwidth, int vwidth, bool raised_p, bool top_p, bool bot_p, - bool left_p, bool right_p, + int hwidth, int vwidth, bool raised_p, bool top_p, + bool bot_p, bool left_p, bool right_p, struct haiku_rect *clip_rect, bool fancy_p) { - uint32_t color_white; - uint32_t color_black; + uint32_t color_white, color_black; + void *view; haiku_calculate_relief_colors (s, &color_white, &color_black); - void *view = FRAME_HAIKU_VIEW (s->f); + view = FRAME_HAIKU_VIEW (s->f); BView_SetHighColor (view, raised_p ? color_white : color_black); if (clip_rect) { @@ -636,15 +720,14 @@ haiku_draw_underwave (struct glyph_string *s, int width, int x) { int wave_height = 3, wave_length = 2; int y, dx, dy, odd, xmax; + float ax, ay, bx, by; + void *view = FRAME_HAIKU_VIEW (s->f); + dx = wave_length; dy = wave_height - 1; y = s->ybase - wave_height + 3; - - float ax, ay, bx, by; xmax = x + width; - void *view = FRAME_HAIKU_VIEW (s->f); - BView_StartClip (view); haiku_clip_to_string (s); BView_ClipToRect (view, x, y, width, wave_height); @@ -980,6 +1063,8 @@ haiku_draw_glyph_string_foreground (struct glyph_string *s) for (i = 0; i < s->nchars; ++i) { struct glyph *g = s->first_glyph + i; + + BView_SetPenSize (view, 1); BView_StrokeRectangle (view, x, s->y, g->pixel_width, s->height); x += g->pixel_width; @@ -1011,6 +1096,7 @@ haiku_draw_glyphless_glyph_string_foreground (struct glyph_string *s) unsigned char2b[8]; int x, i, j; struct face *face = s->face; + unsigned long color; /* If first glyph of S has a left box line, start drawing the text of S to the right of that box line. */ @@ -1074,11 +1160,21 @@ haiku_draw_glyphless_glyph_string_foreground (struct glyph_string *s) s->ybase + glyph->slice.glyphless.lower_yoff, false); } + if (glyph->u.glyphless.method != GLYPHLESS_DISPLAY_THIN_SPACE) - BView_FillRectangle (FRAME_HAIKU_VIEW (s->f), - x, s->ybase - glyph->ascent, - glyph->pixel_width - 1, - glyph->ascent + glyph->descent - 1); + { + if (s->hl == DRAW_CURSOR) + haiku_merge_cursor_foreground (s, NULL, &color); + else + color = s->face->foreground; + + BView_SetHighColor (FRAME_HAIKU_VIEW (s->f), color); + BView_SetPenSize (FRAME_HAIKU_VIEW (s->f), 1); + BView_StrokeRectangle (FRAME_HAIKU_VIEW (s->f), + x, s->ybase - glyph->ascent, + glyph->pixel_width, + glyph->ascent + glyph->descent); + } x += glyph->pixel_width; } } @@ -1247,14 +1343,16 @@ haiku_draw_composite_glyph_string_foreground (struct glyph_string *s) /* Draw a rectangle for the composition if the font for the very first character of the composition could not be loaded. */ - if (s->font_not_found_p && !s->cmp_from) { if (s->hl == DRAW_CURSOR) BView_SetHighColor (view, FRAME_OUTPUT_DATA (s->f)->cursor_fg); else BView_SetHighColor (view, s->face->foreground); - BView_StrokeRectangle (view, s->x, s->y, s->width - 1, s->height - 1); + + BView_SetPenSize (view, 1); + BView_StrokeRectangle (view, s->x, s->y, + s->width, s->height); } else if (!s->first_glyph->u.cmp.automatic) { @@ -1739,6 +1837,22 @@ static void haiku_set_window_size (struct frame *f, bool change_gravity, int width, int height) { + Lisp_Object frame; + + /* On X Windows, window managers typically disallow resizing a + window when it is fullscreen. Do the same here. */ + + XSETFRAME (frame, f); + if (!NILP (Fframe_parameter (frame, Qfullscreen)) + /* Only do this if the fullscreen status has actually been + applied. */ + && f->want_fullscreen == FULLSCREEN_NONE + /* And if the configury during frame completion has been + completed. Otherwise, there will be no valid "old size" to + go back to. */ + && FRAME_OUTPUT_DATA (f)->configury_done) + return; + haiku_update_size_hints (f); if (FRAME_HAIKU_WINDOW (f)) @@ -1877,7 +1991,8 @@ haiku_draw_window_cursor (struct window *w, static void haiku_show_hourglass (struct frame *f) { - if (FRAME_OUTPUT_DATA (f)->hourglass_p) + if (FRAME_TOOLTIP_P (f) + || FRAME_OUTPUT_DATA (f)->hourglass_p) return; block_input (); @@ -1892,7 +2007,8 @@ haiku_show_hourglass (struct frame *f) static void haiku_hide_hourglass (struct frame *f) { - if (!FRAME_OUTPUT_DATA (f)->hourglass_p) + if (FRAME_TOOLTIP_P (f) + || !FRAME_OUTPUT_DATA (f)->hourglass_p) return; block_input (); @@ -2211,7 +2327,6 @@ haiku_set_horizontal_scroll_bar (struct window *w, int portion, int whole, int p if (NILP (w->horizontal_scroll_bar)) { bar = haiku_scroll_bar_create (w, left, top, width, height, true); - BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); bar->update = position; bar->position = position; bar->total = whole; @@ -2234,13 +2349,9 @@ haiku_set_horizontal_scroll_bar (struct window *w, int portion, int whole, int p bar->width = width; bar->height = height; } - - if (!bar->dragging) - { - BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); - BView_invalidate (bar->scroll_bar); - } } + + haiku_set_horizontal_scroll_bar_thumb (bar, portion, position, whole); bar->position = position; bar->total = whole; XSETVECTOR (barobj, bar); @@ -2271,7 +2382,6 @@ haiku_set_vertical_scroll_bar (struct window *w, if (NILP (w->vertical_scroll_bar)) { bar = haiku_scroll_bar_create (w, left, top, width, height, false); - BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); bar->position = position; bar->total = whole; } @@ -2293,15 +2403,9 @@ haiku_set_vertical_scroll_bar (struct window *w, bar->width = width; bar->height = height; } - - if (!bar->dragging) - { - BView_scroll_bar_update (bar->scroll_bar, portion, whole, position); - bar->update = position; - BView_invalidate (bar->scroll_bar); - } } + haiku_set_scroll_bar_thumb (bar, portion, position, whole); bar->position = position; bar->total = whole; @@ -2447,17 +2551,26 @@ haiku_scroll_run (struct window *w, struct run *run) unblock_input (); } +/* Haiku doesn't provide any way to get the frame actually underneath + the pointer, so we typically return dpyinfo->last_mouse_frame if + the display is grabbed and `track-mouse' is not `dropping' or + `drag-source'; failing that, we return the selected frame, and + finally a random window system frame (as long as `track-mouse' is + not `drag-source') if that didn't work either. */ static void haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, enum scroll_bar_part *part, Lisp_Object *x, Lisp_Object *y, Time *timestamp) { Lisp_Object frame, tail; - struct frame *f1 = NULL; + struct frame *f1; + int screen_x, screen_y; + void *view; if (!fp) return; + f1 = NULL; block_input (); FOR_EACH_FRAME (tail, frame) @@ -2466,15 +2579,14 @@ haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, XFRAME (frame)->mouse_moved = false; } - if (gui_mouse_grabbed (x_display_list) && !EQ (track_mouse, Qdropping)) + if (gui_mouse_grabbed (x_display_list) + && !EQ (track_mouse, Qdropping) + && !EQ (track_mouse, Qdrag_source)) f1 = x_display_list->last_mouse_frame; + else + f1 = x_display_list->last_mouse_motion_frame; - if (!f1 || FRAME_TOOLTIP_P (f1)) - f1 = ((EQ (track_mouse, Qdropping) && gui_mouse_grabbed (x_display_list)) - ? x_display_list->last_mouse_frame - : NULL); - - if (!f1 && insist > 0) + if (!f1 && FRAME_HAIKU_P (SELECTED_FRAME ())) f1 = SELECTED_FRAME (); if (!f1 || (!FRAME_HAIKU_P (f1) && (insist > 0))) @@ -2483,26 +2595,37 @@ haiku_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, !FRAME_TOOLTIP_P (XFRAME (frame))) f1 = XFRAME (frame); - if (FRAME_TOOLTIP_P (f1)) + if (f1 && FRAME_TOOLTIP_P (f1)) f1 = NULL; if (f1 && FRAME_HAIKU_P (f1)) { - int sx, sy; - void *view = FRAME_HAIKU_VIEW (f1); + view = FRAME_HAIKU_VIEW (f1); + if (view) { - BView_get_mouse (view, &sx, &sy); - - remember_mouse_glyph (f1, sx, sy, &x_display_list->last_mouse_glyph); + BView_get_mouse (view, &screen_x, &screen_y); + remember_mouse_glyph (f1, screen_x, screen_y, + &x_display_list->last_mouse_glyph); x_display_list->last_mouse_glyph_frame = f1; *bar_window = Qnil; *part = scroll_bar_above_handle; - *fp = f1; + + /* If track-mouse is `drag-source' and the mouse pointer is + certain to not be actually under the chosen frame, return + NULL in FP to at least try being consistent with X. */ + if (EQ (track_mouse, Qdrag_source) + && (screen_x < 0 || screen_y < 0 + || screen_x >= FRAME_PIXEL_WIDTH (f1) + || screen_y >= FRAME_PIXEL_HEIGHT (f1))) + *fp = NULL; + else + *fp = f1; + *timestamp = x_display_list->last_mouse_movement_time; - XSETINT (*x, sx); - XSETINT (*y, sy); + XSETINT (*x, screen_x); + XSETINT (*y, screen_y); } } @@ -2524,8 +2647,9 @@ haiku_flush (struct frame *f) static void haiku_define_frame_cursor (struct frame *f, Emacs_Cursor cursor) { - if (f->tooltip) + if (FRAME_TOOLTIP_P (f)) return; + block_input (); if (!f->pointer_invisible && FRAME_HAIKU_VIEW (f) && !FRAME_OUTPUT_DATA (f)->hourglass_p) @@ -2646,44 +2770,69 @@ haiku_make_fullscreen_consistent (struct frame *f) } static void -flush_dirty_back_buffers (void) +haiku_flush_dirty_back_buffer_on (struct frame *f) { - block_input (); - Lisp_Object tail, frame; - FOR_EACH_FRAME (tail, frame) + if (!FRAME_GARBAGED_P (f) + && !buffer_flipping_blocked_p () + && FRAME_DIRTY_P (f)) + haiku_flip_buffers (f); +} + +/* N.B. that support for TYPE must be explictly added to + haiku_read_socket. */ +void +haiku_wait_for_event (struct frame *f, int type) +{ + int input_blocked_to; + object_wait_info info; + specpdl_ref depth; + + input_blocked_to = interrupt_input_blocked; + info.object = port_application_to_emacs; + info.type = B_OBJECT_TYPE_PORT; + info.events = B_EVENT_READ; + + depth = SPECPDL_INDEX (); + specbind (Qinhibit_quit, Qt); + + FRAME_OUTPUT_DATA (f)->wait_for_event_type = type; + + while (FRAME_OUTPUT_DATA (f)->wait_for_event_type == type) { - struct frame *f = XFRAME (frame); - if (FRAME_LIVE_P (f) && - FRAME_HAIKU_P (f) && - FRAME_HAIKU_WINDOW (f) && - !FRAME_GARBAGED_P (f) && - !buffer_flipping_blocked_p () && - FRAME_DIRTY_P (f)) - haiku_flip_buffers (f); + if (wait_for_objects (&info, 1) < B_OK) + continue; + + pending_signals = true; + /* This will call the read_socket_hook. */ + totally_unblock_input (); + interrupt_input_blocked = input_blocked_to; + info.events = B_EVENT_READ; } - unblock_input (); + + unbind_to (depth, Qnil); } static int haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) { - block_input (); - int message_count = 0; - static void *buf = NULL; + int message_count; + static void *buf; ssize_t b_size; - struct unhandled_event *unhandled_events = NULL; - int button_or_motion_p; - int need_flush = 0; - int do_help = 0; + int button_or_motion_p, do_help; + enum haiku_event_type type; + struct input_event inev, inev2; + message_count = 0; + button_or_motion_p = 0; + do_help = 0; + buf = NULL; + + block_input (); if (!buf) buf = xmalloc (200); haiku_read_size (&b_size, false); while (b_size >= 0) { - enum haiku_event_type type; - struct input_event inev, inev2; - if (b_size > 200) emacs_abort (); @@ -2695,7 +2844,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) inev2.arg = Qnil; button_or_motion_p = 0; - haiku_read (&type, buf, b_size); switch (type) @@ -2751,19 +2899,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) cancel_mouse_face (f); haiku_clear_under_internal_border (f); } - - if (FRAME_OUTPUT_DATA (f)->pending_zoom_width != width || - FRAME_OUTPUT_DATA (f)->pending_zoom_height != height) - { - FRAME_OUTPUT_DATA (f)->zoomed_p = 0; - haiku_make_fullscreen_consistent (f); - } - else - { - FRAME_OUTPUT_DATA (f)->zoomed_p = 1; - FRAME_OUTPUT_DATA (f)->pending_zoom_width = INT_MIN; - FRAME_OUTPUT_DATA (f)->pending_zoom_height = INT_MIN; - } break; } case FRAME_EXPOSED: @@ -2775,7 +2910,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) continue; expose_frame (f, b->x, b->y, b->width, b->height); - haiku_clear_under_internal_border (f); break; } @@ -2785,6 +2919,9 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) Mouse_HLInfo *hlinfo = &x_display_list->mouse_highlight; struct frame *f = haiku_window_to_frame (b->window); + if (!f) + continue; + /* If mouse-highlight is an integer, input clears out mouse highlighting. */ if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight) @@ -2794,12 +2931,9 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) { clear_mouse_face (hlinfo); hlinfo->mouse_face_hidden = true; - need_flush = 1; + haiku_flush_dirty_back_buffer_on (f); } - if (!f) - continue; - inev.code = b->keysym ? b->keysym : b->multibyte_char; if (b->keysym) @@ -2828,8 +2962,8 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (!f) continue; - if ((x_display_list->focus_event_frame != f && b->activated_p) || - (x_display_list->focus_event_frame == f && !b->activated_p)) + if ((x_display_list->focus_event_frame != f && b->activated_p) + || (x_display_list->focus_event_frame == f && !b->activated_p)) { haiku_new_focus_frame (b->activated_p ? f : NULL); if (b->activated_p) @@ -2862,8 +2996,9 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) case MOUSE_MOTION: { struct haiku_mouse_motion_event *b = buf; - struct frame *f = haiku_mouse_or_wdesc_frame (b->window); + struct frame *f = haiku_mouse_or_wdesc_frame (b->window, true); Mouse_HLInfo *hlinfo = &x_display_list->mouse_highlight; + Lisp_Object frame; if (!f) continue; @@ -2876,11 +3011,9 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (any_help_event_p) do_help = -1; - break; } - Lisp_Object frame; XSETFRAME (frame, f); x_display_list->last_mouse_movement_time = b->time / 1000; @@ -2890,7 +3023,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) { hlinfo->mouse_face_hidden = false; clear_mouse_face (hlinfo); - need_flush = 1; + haiku_flush_dirty_back_buffer_on (f); } if (b->just_exited_p) @@ -2903,7 +3036,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) clear_mouse_face (hlinfo); hlinfo->mouse_face_mouse_frame = 0; - need_flush = 1; + haiku_flush_dirty_back_buffer_on (f); } if (f->auto_lower && !popup_activated_p @@ -2974,7 +3107,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) || b->y < r.y || b->y >= r.y + r.height) { f->mouse_moved = true; - dpyinfo->last_mouse_scroll_bar = NULL; note_mouse_highlight (f, b->x, b->y); remember_mouse_glyph (f, b->x, b->y, &FRAME_DISPLAY_INFO (f)->last_mouse_glyph); @@ -2996,8 +3128,8 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) && (!NILP (focus_follows_mouse) || f == SELECTED_FRAME ())) { - inev.kind = SELECT_WINDOW_EVENT; - inev.frame_or_window = window; + inev2.kind = SELECT_WINDOW_EVENT; + inev2.frame_or_window = window; } last_mouse_window = window; @@ -3012,16 +3144,40 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (!NILP (help_echo_string) || !NILP (previous_help_echo_string)) do_help = 1; + + if (b->dnd_message) + { + /* It doesn't make sense to show tooltips when + another program is dragging stuff over us. */ + + if (any_help_event_p || do_help) + do_help = -1; + + if (!be_drag_and_drop_in_progress ()) + { + inev.kind = DRAG_N_DROP_EVENT; + inev.arg = Qlambda; + + XSETINT (inev.x, b->x); + XSETINT (inev.y, b->y); + XSETFRAME (inev.frame_or_window, f); + } + else + haiku_note_drag_motion (); + + break; + } } - need_flush = FRAME_DIRTY_P (f); + if (FRAME_DIRTY_P (f)) + haiku_flush_dirty_back_buffer_on (f); break; } case BUTTON_UP: case BUTTON_DOWN: { struct haiku_button_event *b = buf; - struct frame *f = haiku_mouse_or_wdesc_frame (b->window); + struct frame *f = haiku_mouse_or_wdesc_frame (b->window, false); Lisp_Object tab_bar_arg = Qnil; int tab_bar_p = 0, tool_bar_p = 0; bool up_okay_p = false; @@ -3052,7 +3208,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) { tab_bar_arg = handle_tab_bar_click (f, x, y, type == BUTTON_DOWN, inev.modifiers); - need_flush = 1; + haiku_flush_dirty_back_buffer_on (f); } } @@ -3064,13 +3220,15 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) int y = b->y; window = window_from_coordinates (f, x, y, 0, true, true); - tool_bar_p = EQ (window, f->tool_bar_window); + tool_bar_p = (EQ (window, f->tool_bar_window) + && (type != BUTTON_UP + || f->last_tool_bar_item != -1)); if (tool_bar_p) { handle_tool_bar_click (f, x, y, type == BUTTON_DOWN, inev.modifiers); - need_flush = 1; + haiku_flush_dirty_back_buffer_on (f); } } @@ -3149,16 +3307,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (!f) continue; - if (FRAME_OUTPUT_DATA (f)->pending_zoom_x != b->x || - FRAME_OUTPUT_DATA (f)->pending_zoom_y != b->y) - FRAME_OUTPUT_DATA (f)->zoomed_p = 0; - else - { - FRAME_OUTPUT_DATA (f)->zoomed_p = 1; - FRAME_OUTPUT_DATA (f)->pending_zoom_x = INT_MIN; - FRAME_OUTPUT_DATA (f)->pending_zoom_y = INT_MIN; - } - if (FRAME_PARENT_FRAME (f)) haiku_coords_from_parent (f, &b->x, &b->y); @@ -3191,6 +3339,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) struct haiku_scroll_bar_value_event *b = buf; struct scroll_bar *bar = haiku_scroll_bar_from_widget (b->scroll_bar, b->window); + int portion, whole; if (!bar) continue; @@ -3205,13 +3354,29 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (bar->position != b->position) { - inev.kind = bar->horizontal ? HORIZONTAL_SCROLL_BAR_CLICK_EVENT : - SCROLL_BAR_CLICK_EVENT; + inev.kind = (bar->horizontal + ? HORIZONTAL_SCROLL_BAR_CLICK_EVENT : + SCROLL_BAR_CLICK_EVENT); inev.part = bar->horizontal ? scroll_bar_horizontal_handle : scroll_bar_handle; - XSETINT (inev.x, b->position); - XSETINT (inev.y, bar->total); + if (bar->horizontal) + { + portion = bar->total * ((float) b->position + / BE_SB_MAX); + whole = (bar->total + * ((float) (BE_SB_MAX - bar->page_size) + / BE_SB_MAX)); + portion = min (portion, whole); + } + else + { + whole = BE_SB_MAX - bar->page_size; + portion = min (b->position, whole); + } + + XSETINT (inev.x, portion); + XSETINT (inev.y, whole); XSETWINDOW (inev.frame_or_window, w); } break; @@ -3332,7 +3497,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) break; } - case MENU_BAR_RESIZE: { struct haiku_menu_bar_resize_event *b = buf; @@ -3341,11 +3505,15 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (!f || !FRAME_EXTERNAL_MENU_BAR (f)) continue; + if (FRAME_OUTPUT_DATA (f)->wait_for_event_type + == MENU_BAR_RESIZE) + FRAME_OUTPUT_DATA (f)->wait_for_event_type = -1; + int old_height = FRAME_MENU_BAR_HEIGHT (f); - FRAME_MENU_BAR_HEIGHT (f) = b->height + 1; - FRAME_MENU_BAR_LINES (f) = - (b->height + FRAME_LINE_HEIGHT (f)) / FRAME_LINE_HEIGHT (f); + FRAME_MENU_BAR_HEIGHT (f) = b->height; + FRAME_MENU_BAR_LINES (f) + = (b->height + FRAME_LINE_HEIGHT (f)) / FRAME_LINE_HEIGHT (f); if (old_height != b->height) { @@ -3354,6 +3522,21 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) } break; } + case MENU_BAR_CLICK: + { + struct haiku_menu_bar_click_event *b = buf; + struct frame *f = haiku_window_to_frame (b->window); + + if (!f || !FRAME_EXTERNAL_MENU_BAR (f)) + continue; + + if (!FRAME_OUTPUT_DATA (f)->saved_menu_event) + FRAME_OUTPUT_DATA (f)->saved_menu_event = xmalloc (sizeof *b); + *FRAME_OUTPUT_DATA (f)->saved_menu_event = *b; + inev.kind = MENU_BAR_ACTIVATE_EVENT; + XSETFRAME (inev.frame_or_window, f); + break; + } case MENU_BAR_OPEN: case MENU_BAR_CLOSE: { @@ -3365,35 +3548,14 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (type == MENU_BAR_OPEN) { - /* b->no_lock means that MenusBeginning was called - from the main thread, which means tracking was - started manually, and we have already updated the - menu bar. */ - if (!b->no_lock) - { - BView_draw_lock (FRAME_HAIKU_VIEW (f), false, 0, 0, 0, 0); - /* This shouldn't be here, but nsmenu does it, so - it should probably be safe. */ - int was_waiting_for_input_p = waiting_for_input; - if (waiting_for_input) - waiting_for_input = 0; - set_frame_menubar (f, 1); - waiting_for_input = was_waiting_for_input_p; - BView_draw_unlock (FRAME_HAIKU_VIEW (f)); - } - - /* But set the flag anyway, because the menu will end - from the window thread. */ FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 1; popup_activated_p += 1; - - if (!b->no_lock) - EmacsWindow_signal_menu_update_complete (b->window); } else { if (!popup_activated_p) emacs_abort (); + if (FRAME_OUTPUT_DATA (f)->menu_bar_open_p) { FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 0; @@ -3410,22 +3572,8 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (!f || !FRAME_EXTERNAL_MENU_BAR (f)) continue; - if (FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) - find_and_call_menu_selection (f, f->menu_bar_items_used, - f->menu_bar_vector, b->ptr); - break; - } - case FILE_PANEL_EVENT: - { - if (!popup_activated_p) - continue; - - struct unhandled_event *ev = xmalloc (sizeof *ev); - ev->next = unhandled_events; - ev->type = type; - memcpy (&ev->buffer, buf, 200); - - unhandled_events = ev; + find_and_call_menu_selection (f, f->menu_bar_items_used, + f->menu_bar_vector, b->ptr); break; } case MENU_BAR_HELP_EVENT: @@ -3436,12 +3584,11 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) continue; struct frame *f = haiku_window_to_frame (b->window); - if (!f || !FRAME_EXTERNAL_MENU_BAR (f) || - !FRAME_OUTPUT_DATA (f)->menu_bar_open_p) + if (!f || !FRAME_EXTERNAL_MENU_BAR (f) + || !FRAME_OUTPUT_DATA (f)->menu_bar_open_p) continue; run_menu_bar_help_event (f, b->mb_idx); - break; } case ZOOM_EVENT: @@ -3453,39 +3600,35 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (!f) continue; - FRAME_OUTPUT_DATA (f)->pending_zoom_height = b->height; - FRAME_OUTPUT_DATA (f)->pending_zoom_width = b->width; - FRAME_OUTPUT_DATA (f)->pending_zoom_x = b->x; - FRAME_OUTPUT_DATA (f)->pending_zoom_y = b->y; - - FRAME_OUTPUT_DATA (f)->zoomed_p = 1; + FRAME_OUTPUT_DATA (f)->zoomed_p = b->zoomed; haiku_make_fullscreen_consistent (f); break; } - case REFS_EVENT: + case DRAG_AND_DROP_EVENT: { - struct haiku_refs_event *b = buf; + struct haiku_drag_and_drop_event *b = buf; struct frame *f = haiku_window_to_frame (b->window); if (!f) { - free (b->ref); + BMessage_delete (b->message); continue; } inev.kind = DRAG_N_DROP_EVENT; - inev.arg = build_string_from_utf8 (b->ref); + inev.arg = haiku_message_to_lisp (b->message); XSETINT (inev.x, b->x); XSETINT (inev.y, b->y); XSETFRAME (inev.frame_or_window, f); - /* There should be no problem with calling free here. - free on Haiku is thread-safe. */ - free (b->ref); + BMessage_delete (b->message); break; } case APP_QUIT_REQUESTED_EVENT: + inev.kind = SAVE_SESSION_EVENT; + inev.arg = Qt; + break; case KEY_UP: case DUMMY_EVENT: default: @@ -3515,14 +3658,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) } } - for (struct unhandled_event *ev = unhandled_events; ev;) - { - haiku_write_without_signal (ev->type, &ev->buffer, false); - struct unhandled_event *old = ev; - ev = old->next; - xfree (old); - } - if (do_help && !(hold_quit && hold_quit->kind != NO_EVENT)) { Lisp_Object help_frame = Qnil; @@ -3545,9 +3680,6 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) } } - if (need_flush) - flush_dirty_back_buffers (); - unblock_input (); return message_count; @@ -3584,10 +3716,13 @@ haiku_flash (struct frame *f) int flash_right = FRAME_PIXEL_WIDTH (f) - FRAME_INTERNAL_BORDER_WIDTH (f); int width = flash_right - flash_left; void *view = FRAME_HAIKU_VIEW (f); - struct timespec delay, wakeup, current, timeout; + object_wait_info info; + bigtime_t wakeup; - delay = make_timespec (0, 150 * 1000 * 1000); - wakeup = timespec_add (current_timespec (), delay); + info.object = port_application_to_emacs; + info.type = B_OBJECT_TYPE_PORT; + info.events = B_EVENT_READ; + wakeup = system_time () + 150000; BView_draw_lock (view, true, 0, 0, FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f)); @@ -3621,17 +3756,17 @@ haiku_flash (struct frame *f) available. */ while (!detect_input_pending ()) { - current = current_timespec (); - /* Break if result would not be positive. */ - if (timespec_cmp (wakeup, current) <= 0) + if (wakeup < system_time ()) break; - /* How long `select' should wait. */ - timeout = make_timespec (0, 10 * 1000 * 1000); - /* Try to wait that long--but we might wake up sooner. */ - pselect (0, NULL, NULL, NULL, &timeout, NULL); + wait_for_objects_etc (&info, 1, B_ABSOLUTE_TIMEOUT, wakeup); + + if (info.events & B_EVENT_READ) + break; + + info.events = B_EVENT_READ; } BView_draw_lock (view, true, 0, 0, FRAME_PIXEL_WIDTH (f), @@ -3684,12 +3819,12 @@ haiku_toggle_invisible_pointer (struct frame *f, bool invisible_p) { void *view = FRAME_HAIKU_VIEW (f); - if (view) + if (view && !FRAME_TOOLTIP_P (f)) { block_input (); - BView_set_view_cursor (view, invisible_p ? - FRAME_OUTPUT_DATA (f)->no_cursor : - FRAME_OUTPUT_DATA (f)->current_cursor); + BView_set_view_cursor (view, (invisible_p + ? FRAME_OUTPUT_DATA (f)->no_cursor + : FRAME_OUTPUT_DATA (f)->current_cursor)); f->pointer_invisible = invisible_p; unblock_input (); } @@ -3698,14 +3833,18 @@ haiku_toggle_invisible_pointer (struct frame *f, bool invisible_p) static void haiku_fullscreen (struct frame *f) { + /* When FRAME_OUTPUT_DATA (f)->configury_done is false, the frame is + being created, and its regular width and height have not yet been + set. This function will be called again by haiku_create_frame, + so do nothing. */ + if (!FRAME_OUTPUT_DATA (f)->configury_done) + return; + if (f->want_fullscreen == FULLSCREEN_MAXIMIZED) - { - EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0); - BWindow_zoom (FRAME_HAIKU_WINDOW (f)); - } + BWindow_zoom (FRAME_HAIKU_WINDOW (f)); else if (f->want_fullscreen == FULLSCREEN_BOTH) EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 1); - else if (f->want_fullscreen == FULLSCREEN_NONE) + else { EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0); EmacsWindow_unzoom (FRAME_HAIKU_WINDOW (f)); @@ -3764,6 +3903,7 @@ haiku_create_terminal (struct haiku_display_info *dpyinfo) terminal->toggle_invisible_pointer_hook = haiku_toggle_invisible_pointer; terminal->fullscreen_hook = haiku_fullscreen; terminal->toolkit_position_hook = haiku_toolkit_position; + terminal->activate_menubar_hook = haiku_activate_menubar; return terminal; } @@ -3773,36 +3913,34 @@ haiku_term_init (void) { struct haiku_display_info *dpyinfo; struct terminal *terminal; - - Lisp_Object color_file, color_map; + Lisp_Object color_file, color_map, system_name; + ptrdiff_t nbytes; + void *name_buffer; block_input (); + Fset_input_interrupt_mode (Qt); - baud_rate = 19200; - dpyinfo = xzalloc (sizeof *dpyinfo); - haiku_io_init (); - if (port_application_to_emacs < B_OK) + if (port_application_to_emacs < B_OK + || port_emacs_to_session_manager < B_OK) emacs_abort (); color_file = Fexpand_file_name (build_string ("rgb.txt"), Fsymbol_value (intern ("data-directory"))); - color_map = Fx_load_color_file (color_file); + if (NILP (color_map)) fatal ("Could not read %s.\n", SDATA (color_file)); dpyinfo->color_map = color_map; - dpyinfo->display = BApplication_setup (); - - BScreen_res (&dpyinfo->resx, &dpyinfo->resy); - dpyinfo->next = x_display_list; dpyinfo->n_planes = be_get_display_planes (); + be_get_display_resolution (&dpyinfo->resx, &dpyinfo->resy); + x_display_list = dpyinfo; terminal = haiku_create_terminal (dpyinfo); @@ -3820,6 +3958,54 @@ haiku_term_init (void) dpyinfo->smallest_char_width = 1; gui_init_fringe (terminal->rif); + +#define ASSIGN_CURSOR(cursor, be_cursor) (dpyinfo->cursor = be_cursor) + ASSIGN_CURSOR (text_cursor, BCursor_create_i_beam ()); + ASSIGN_CURSOR (nontext_cursor, BCursor_create_default ()); + ASSIGN_CURSOR (modeline_cursor, BCursor_create_modeline ()); + ASSIGN_CURSOR (hand_cursor, BCursor_create_grab ()); + ASSIGN_CURSOR (hourglass_cursor, BCursor_create_progress_cursor ()); + ASSIGN_CURSOR (horizontal_drag_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_EAST_WEST)); + ASSIGN_CURSOR (vertical_drag_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_SOUTH)); + ASSIGN_CURSOR (left_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_WEST)); + ASSIGN_CURSOR (top_left_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_WEST)); + ASSIGN_CURSOR (top_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH)); + ASSIGN_CURSOR (top_right_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_NORTH_EAST)); + ASSIGN_CURSOR (right_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_EAST)); + ASSIGN_CURSOR (bottom_right_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_EAST)); + ASSIGN_CURSOR (bottom_edge_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH)); + ASSIGN_CURSOR (bottom_left_corner_cursor, + BCursor_from_id (CURSOR_ID_RESIZE_SOUTH_WEST)); + ASSIGN_CURSOR (no_cursor, + BCursor_from_id (CURSOR_ID_NO_CURSOR)); +#undef ASSIGN_CURSOR + + system_name = Fsystem_name (); + + if (STRINGP (system_name)) + { + nbytes = sizeof "GNU Emacs" + sizeof " at "; + + if (INT_ADD_WRAPV (nbytes, SBYTES (system_name), &nbytes)) + memory_full (SIZE_MAX); + + name_buffer = alloca (nbytes); + sprintf (name_buffer, "%s%s%s", "GNU Emacs", + " at ", SDATA (system_name)); + dpyinfo->default_name = build_string (name_buffer); + } + else + dpyinfo->default_name = build_string ("GNU Emacs"); + unblock_input (); return dpyinfo; @@ -3887,7 +4073,10 @@ void mark_haiku_display (void) { if (x_display_list) - mark_object (x_display_list->color_map); + { + mark_object (x_display_list->color_map); + mark_object (x_display_list->default_name); + } } void @@ -4044,7 +4233,6 @@ This is either one of the symbols `shift', `control', `command', and Setting it to any other value is equivalent to `shift'. */); Vhaiku_shift_keysym = Qnil; - DEFSYM (Qx_use_underline_position_properties, "x-use-underline-position-properties"); diff --git a/src/haikuterm.h b/src/haikuterm.h index a2520858f54..30b474b1e1d 100644 --- a/src/haikuterm.h +++ b/src/haikuterm.h @@ -36,8 +36,6 @@ along with GNU Emacs. If not, see . */ extern int popup_activated_p; -extern void be_app_quit (void); - struct haikufont_info { struct font font; @@ -83,6 +81,7 @@ struct haiku_display_info int color_p; Lisp_Object rdb; + Lisp_Object default_name; Emacs_Cursor vertical_scroll_bar_cursor; Emacs_Cursor horizontal_scroll_bar_cursor; @@ -98,8 +97,6 @@ struct haiku_display_info struct haiku_rect last_mouse_glyph; - void *last_mouse_scroll_bar; - haiku display; double resx, resy; @@ -107,10 +104,7 @@ struct haiku_display_info Time last_mouse_movement_time; Window root_window; -}; -struct haiku_output -{ Emacs_Cursor text_cursor; Emacs_Cursor nontext_cursor; Emacs_Cursor modeline_cursor; @@ -127,44 +121,77 @@ struct haiku_output Emacs_Cursor bottom_edge_cursor; Emacs_Cursor bottom_left_corner_cursor; Emacs_Cursor no_cursor; +}; - Emacs_Cursor current_cursor; - +struct haiku_output +{ struct haiku_display_info *display_info; - int baseline_offset; - int fontset; + Emacs_Cursor text_cursor; + Emacs_Cursor nontext_cursor; + Emacs_Cursor modeline_cursor; + Emacs_Cursor hand_cursor; + Emacs_Cursor hourglass_cursor; + Emacs_Cursor horizontal_drag_cursor; + Emacs_Cursor vertical_drag_cursor; + Emacs_Cursor left_edge_cursor; + Emacs_Cursor top_left_corner_cursor; + Emacs_Cursor top_edge_cursor; + Emacs_Cursor top_right_corner_cursor; + Emacs_Cursor right_edge_cursor; + Emacs_Cursor bottom_right_corner_cursor; + Emacs_Cursor bottom_edge_cursor; + Emacs_Cursor bottom_left_corner_cursor; + Emacs_Cursor no_cursor; + Emacs_Cursor current_cursor; Emacs_Color cursor_color; - Window window_desc, parent_desc; - char explicit_parent; - - int titlebar_height; - int toolbar_height; + Window parent_desc; haiku window; haiku view; haiku menubar; - int menu_up_to_date_p; - int zoomed_p; + int fontset; + int baseline_offset; - int pending_zoom_x; - int pending_zoom_y; - int pending_zoom_width; - int pending_zoom_height; + bool_bf zoomed_p : 1; + bool_bf hourglass_p : 1; + bool_bf menu_bar_open_p : 1; - int menu_bar_open_p; + /* Whether or not there is data in a back buffer that hasn't been + displayed yet. */ + bool dirty_p; struct font *font; - int hourglass_p; - uint32_t cursor_fg; - bool dirty_p; - /* The pending position we're waiting for. */ int pending_top, pending_left; + + /* Whether or not adjust_frame_size and haiku_set_offset have yet + been called by haiku_create_frame. */ + bool configury_done; + + /* The default cursor foreground color. */ + uint32_t cursor_fg; + + /* If non-NULL, the last menu bar click event received. */ + struct haiku_menu_bar_click_event *saved_menu_event; + + /* The type of any event that's being waited for. */ + int wait_for_event_type; + + /* The "dark" color of the current relief. */ + uint32_t black_relief_pixel; + + /* The "light" color of the current relief. */ + uint32_t white_relief_pixel; + + /* The background for which the relief colors above were computed. + They are changed only when a different background is involved. + -1 means no color has been computed. */ + long relief_background; }; struct x_output @@ -176,6 +203,7 @@ extern struct haiku_display_info *x_display_list; extern struct font_driver const haikufont_driver; extern Lisp_Object tip_frame; +extern struct frame *haiku_dnd_frame; struct scroll_bar { @@ -213,22 +241,26 @@ struct scroll_bar /* True if the scroll bar is horizontal. */ bool horizontal; + + /* The amount of units taken up by the thumb, which represents the + portion of the buffer currently on screen. */ + int page_size; }; #define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec)) -#define FRAME_DIRTY_P(f) (FRAME_OUTPUT_DATA (f)->dirty_p) -#define MAKE_FRAME_DIRTY(f) (FRAME_DIRTY_P (f) = 1) -#define FRAME_OUTPUT_DATA(f) ((f)->output_data.haiku) -#define FRAME_HAIKU_WINDOW(f) (FRAME_OUTPUT_DATA (f)->window) -#define FRAME_HAIKU_VIEW(f) ((MAKE_FRAME_DIRTY (f)), FRAME_OUTPUT_DATA (f)->view) -#define FRAME_HAIKU_MENU_BAR(f) (FRAME_OUTPUT_DATA (f)->menubar) -#define FRAME_DISPLAY_INFO(f) (FRAME_OUTPUT_DATA (f)->display_info) -#define FRAME_FONT(f) (FRAME_OUTPUT_DATA (f)->font) -#define FRAME_FONTSET(f) (FRAME_OUTPUT_DATA (f)->fontset) -#define FRAME_NATIVE_WINDOW(f) (FRAME_OUTPUT_DATA (f)->window) -#define FRAME_BASELINE_OFFSET(f) (FRAME_OUTPUT_DATA (f)->baseline_offset) -#define FRAME_CURSOR_COLOR(f) (FRAME_OUTPUT_DATA (f)->cursor_color) +#define FRAME_DIRTY_P(f) (FRAME_OUTPUT_DATA (f)->dirty_p) +#define MAKE_FRAME_DIRTY(f) (FRAME_DIRTY_P (f) = 1) +#define FRAME_OUTPUT_DATA(f) ((f)->output_data.haiku) +#define FRAME_HAIKU_WINDOW(f) (FRAME_OUTPUT_DATA (f)->window) +#define FRAME_HAIKU_VIEW(f) ((MAKE_FRAME_DIRTY (f)), FRAME_OUTPUT_DATA (f)->view) +#define FRAME_HAIKU_MENU_BAR(f) (FRAME_OUTPUT_DATA (f)->menubar) +#define FRAME_DISPLAY_INFO(f) (FRAME_OUTPUT_DATA (f)->display_info) +#define FRAME_FONT(f) (FRAME_OUTPUT_DATA (f)->font) +#define FRAME_FONTSET(f) (FRAME_OUTPUT_DATA (f)->fontset) +#define FRAME_NATIVE_WINDOW(f) (FRAME_OUTPUT_DATA (f)->window) +#define FRAME_BASELINE_OFFSET(f) (FRAME_OUTPUT_DATA (f)->baseline_offset) +#define FRAME_CURSOR_COLOR(f) (FRAME_OUTPUT_DATA (f)->cursor_color) #ifdef USE_BE_CAIRO #define FRAME_CR_CONTEXT(f) \ @@ -249,50 +281,52 @@ extern void haiku_visualize_frame (struct frame *); extern void haiku_unvisualize_frame (struct frame *); extern void haiku_set_offset (struct frame *, int, int, int); extern void haiku_set_frame_visible_invisible (struct frame *, bool); -extern void haiku_free_frame_resources (struct frame *f); -extern void haiku_scroll_bar_remove (struct scroll_bar *bar); -extern void haiku_clear_under_internal_border (struct frame *f); -extern void haiku_set_name (struct frame *f, Lisp_Object name, bool explicit_p); +extern void haiku_free_frame_resources (struct frame *); +extern void haiku_scroll_bar_remove (struct scroll_bar *); +extern void haiku_clear_under_internal_border (struct frame *); +extern void haiku_set_name (struct frame *, Lisp_Object, bool); +extern Lisp_Object haiku_message_to_lisp (void *); extern struct haiku_display_info *haiku_term_init (void); extern void mark_haiku_display (void); -extern int haiku_get_color (const char *name, Emacs_Color *color); -extern void haiku_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval); -extern void haiku_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval); -extern void haiku_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval); -extern void haiku_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval); -extern void haiku_change_tab_bar_height (struct frame *f, int height); -extern void haiku_change_tool_bar_height (struct frame *f, int height); +extern int haiku_get_color (const char *, Emacs_Color *); +extern void haiku_set_background_color (struct frame *, Lisp_Object, Lisp_Object); +extern void haiku_set_cursor_color (struct frame *, Lisp_Object, Lisp_Object); +extern void haiku_set_cursor_type (struct frame *, Lisp_Object, Lisp_Object); +extern void haiku_set_internal_border_width (struct frame *, Lisp_Object, Lisp_Object); +extern void haiku_change_tab_bar_height (struct frame *, int); +extern void haiku_change_tool_bar_height (struct frame *, int); -extern void haiku_query_color (uint32_t col, Emacs_Color *color); +extern void haiku_query_color (uint32_t, Emacs_Color *); -extern unsigned long haiku_get_pixel (haiku bitmap, int x, int y); -extern void haiku_put_pixel (haiku bitmap, int x, int y, unsigned long pixel); +extern unsigned long haiku_get_pixel (haiku, int, int); +extern void haiku_put_pixel (haiku, int, int, unsigned long); -extern Lisp_Object haiku_menu_show (struct frame *f, int x, int y, int menu_flags, - Lisp_Object title, const char **error_name); -extern Lisp_Object haiku_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents); +extern Lisp_Object haiku_menu_show (struct frame *, int, int, int, + Lisp_Object, const char **); +extern Lisp_Object haiku_popup_dialog (struct frame *, Lisp_Object, Lisp_Object); +extern void haiku_activate_menubar (struct frame *); +extern void haiku_wait_for_event (struct frame *, int); +extern void haiku_note_drag_motion (void); -extern void initialize_frame_menubar (struct frame *f); +extern void initialize_frame_menubar (struct frame *); -extern void run_menu_bar_help_event (struct frame *f, int mb_idx); -extern void put_xrm_resource (Lisp_Object name, Lisp_Object val); +extern void run_menu_bar_help_event (struct frame *, int); +extern void put_xrm_resource (Lisp_Object, Lisp_Object); #ifdef HAVE_NATIVE_IMAGE_API -extern bool haiku_can_use_native_image_api (Lisp_Object type); -extern int haiku_load_image (struct frame *f, struct image *img, - Lisp_Object spec_file, Lisp_Object spec_data); +extern bool haiku_can_use_native_image_api (Lisp_Object); +extern int haiku_load_image (struct frame *, struct image *, + Lisp_Object, Lisp_Object); extern void syms_of_haikuimage (void); #endif #ifdef USE_BE_CAIRO -extern cairo_t * -haiku_begin_cr_clip (struct frame *f, struct glyph_string *s); +extern cairo_t *haiku_begin_cr_clip (struct frame *, struct glyph_string *); -extern void -haiku_end_cr_clip (cairo_t *cr); +extern void haiku_end_cr_clip (cairo_t *); #endif extern void haiku_merge_cursor_foreground (struct glyph_string *, unsigned long *, diff --git a/src/image.c b/src/image.c index c412dc90296..e4b56e29cff 100644 --- a/src/image.c +++ b/src/image.c @@ -1796,13 +1796,50 @@ search_image_cache (struct frame *f, Lisp_Object spec, EMACS_UINT hash, } +/* Filter out image elements that don't affect display, but will + disrupt finding the image in the cache. This should perhaps be + user-configurable, but for now it's hard-coded (but new elements + can be added at will). */ +static Lisp_Object +filter_image_spec (Lisp_Object spec) +{ + Lisp_Object out = Qnil; + + /* Skip past the `image' element. */ + if (CONSP (spec)) + spec = XCDR (spec); + + while (CONSP (spec)) + { + Lisp_Object key = XCAR (spec); + spec = XCDR (spec); + if (CONSP (spec)) + { + Lisp_Object value = XCAR (spec); + spec = XCDR (spec); + + /* Some animation-related data doesn't affect display, but + breaks the image cache. Filter those out. */ + if (!(EQ (key, QCanimate_buffer) + || EQ (key, QCanimate_tardiness) + || EQ (key, QCanimate_position) + || EQ (key, QCanimate_multi_frame_data))) + { + out = Fcons (value, out); + out = Fcons (key, out); + } + } + } + return out; +} + /* Search frame F for an image with spec SPEC, and free it. */ static void uncache_image (struct frame *f, Lisp_Object spec) { struct image *img; - EMACS_UINT hash = sxhash (spec); + EMACS_UINT hash = sxhash (filter_image_spec (spec)); /* Because the background colors are based on the current face, we can have multiple copies of an image with the same spec. We want @@ -2643,7 +2680,7 @@ lookup_image (struct frame *f, Lisp_Object spec, int face_id) eassert (valid_image_p (spec)); /* Look up SPEC in the hash table of the image cache. */ - hash = sxhash (spec); + hash = sxhash (filter_image_spec (spec)); img = search_image_cache (f, spec, hash, foreground, background, font_size, font_family, false); if (img && img->load_failed_p) @@ -2782,6 +2819,92 @@ cache_image (struct frame *f, struct image *img) } +#if defined (HAVE_WEBP) || defined (HAVE_GIF) + +/* To speed animations up, we keep a cache (based on EQ-ness of the + image spec/object) where we put the animator iterator. */ + +struct anim_cache +{ + Lisp_Object spec; + /* For webp, this will be an iterator, and for libgif, a gif handle. */ + void *handle; + /* If we need to maintain temporary data of some sort. */ + void *temp; + /* A function to call to free the handle. */ + void (*destructor) (void *); + int index, width, height, frames; + struct timespec update_time; + struct anim_cache *next; +}; + +static struct anim_cache *anim_cache = NULL; + +static struct anim_cache * +anim_create_cache (Lisp_Object spec) +{ + struct anim_cache *cache = xmalloc (sizeof (struct anim_cache)); + cache->handle = NULL; + cache->temp = NULL; + + cache->index = -1; + cache->next = NULL; + cache->spec = spec; + return cache; +} + +/* Discard cached images that haven't been used for a minute. */ +static void +anim_prune_animation_cache (void) +{ + struct anim_cache **pcache = &anim_cache; + struct timespec old = timespec_sub (current_timespec (), + make_timespec (60, 0)); + + while (*pcache) + { + struct anim_cache *cache = *pcache; + if (timespec_cmp (old, cache->update_time) <= 0) + pcache = &cache->next; + else + { + if (cache->handle) + cache->destructor (cache); + if (cache->temp) + xfree (cache->temp); + *pcache = cache->next; + xfree (cache); + } + } +} + +static struct anim_cache * +anim_get_animation_cache (Lisp_Object spec) +{ + struct anim_cache *cache; + struct anim_cache **pcache = &anim_cache; + + anim_prune_animation_cache (); + + while (1) + { + cache = *pcache; + if (! cache) + { + *pcache = cache = anim_create_cache (spec); + break; + } + if (EQ (spec, cache->spec)) + break; + pcache = &cache->next; + } + + cache->update_time = current_timespec (); + return cache; +} + +#endif /* HAVE_WEBP || HAVE_GIF */ + /* Call FN on every image in the image cache of frame F. Used to mark Lisp Objects in the image cache. */ @@ -2808,6 +2931,11 @@ mark_image_cache (struct image_cache *c) if (c->images[i]) mark_image (c->images[i]); } + +#if defined HAVE_WEBP || defined HAVE_GIF + for (struct anim_cache *cache = anim_cache; cache; cache = cache->next) + mark_object (cache->spec); +#endif } @@ -8665,117 +8793,192 @@ static const int interlace_increment[] = {8, 8, 4, 2}; #define GIF_LOCAL_DESCRIPTOR_EXTENSION 249 +static void +gif_destroy (struct anim_cache* cache) +{ + int gif_err; + gif_close (cache->handle, &gif_err); +} + static bool gif_load (struct frame *f, struct image *img) { int rc, width, height, x, y, i, j; ColorMapObject *gif_color_map; - GifFileType *gif; + GifFileType *gif = NULL; gif_memory_source memsrc; Lisp_Object specified_bg = image_spec_value (img->spec, QCbackground, NULL); Lisp_Object specified_file = image_spec_value (img->spec, QCfile, NULL); Lisp_Object specified_data = image_spec_value (img->spec, QCdata, NULL); - EMACS_INT idx; + unsigned long *pixmap = NULL; + EMACS_INT idx = -1; int gif_err; + struct anim_cache* cache = NULL; + /* Which sub-image are we to display? */ + Lisp_Object image_number = image_spec_value (img->spec, QCindex, NULL); - if (NILP (specified_data)) + idx = FIXNUMP (image_number) ? XFIXNAT (image_number) : 0; + + if (!NILP (image_number)) { - Lisp_Object file = image_find_image_file (specified_file); - if (!STRINGP (file)) + /* If this is an animated image, create a cache for it. */ + cache = anim_get_animation_cache (img->spec); + /* We have an old cache entry, so use it. */ + if (cache->handle) { - image_error ("Cannot find image file `%s'", specified_file); - return false; + gif = cache->handle; + pixmap = cache->temp; + /* We're out of sync, so start from the beginning. */ + if (cache->index != idx - 1) + cache->index = -1; + } + } + + /* If we don't have a cached entry, read the image. */ + if (! gif) + { + if (NILP (specified_data)) + { + Lisp_Object file = image_find_image_file (specified_file); + if (!STRINGP (file)) + { + image_error ("Cannot find image file `%s'", specified_file); + return false; + } + + Lisp_Object encoded_file = ENCODE_FILE (file); +#ifdef WINDOWSNT + encoded_file = ansi_encode_filename (encoded_file); +#endif + + /* Open the GIF file. */ +#if GIFLIB_MAJOR < 5 + gif = DGifOpenFileName (SSDATA (encoded_file)); +#else + gif = DGifOpenFileName (SSDATA (encoded_file), &gif_err); +#endif + if (gif == NULL) + { +#if HAVE_GIFERRORSTRING + const char *errstr = GifErrorString (gif_err); + if (errstr) + image_error ("Cannot open `%s': %s", file, + build_string (errstr)); + else +#endif + image_error ("Cannot open `%s'", file); + return false; + } + } + else + { + if (!STRINGP (specified_data)) + { + image_error ("Invalid image data `%s'", specified_data); + return false; + } + + /* Read from memory! */ + current_gif_memory_src = &memsrc; + memsrc.bytes = SDATA (specified_data); + memsrc.len = SBYTES (specified_data); + memsrc.index = 0; + +#if GIFLIB_MAJOR < 5 + gif = DGifOpen (&memsrc, gif_read_from_memory); +#else + gif = DGifOpen (&memsrc, gif_read_from_memory, &gif_err); +#endif + if (!gif) + { +#if HAVE_GIFERRORSTRING + const char *errstr = GifErrorString (gif_err); + if (errstr) + image_error ("Cannot open memory source `%s': %s", + img->spec, build_string (errstr)); + else +#endif + image_error ("Cannot open memory source `%s'", img->spec); + return false; + } } - Lisp_Object encoded_file = ENCODE_FILE (file); -#ifdef WINDOWSNT - encoded_file = ansi_encode_filename (encoded_file); -#endif + /* Before reading entire contents, check the declared image size. */ + if (!check_image_size (f, gif->SWidth, gif->SHeight)) + { + image_size_error (); + goto gif_error; + } - /* Open the GIF file. */ -#if GIFLIB_MAJOR < 5 - gif = DGifOpenFileName (SSDATA (encoded_file)); -#else - gif = DGifOpenFileName (SSDATA (encoded_file), &gif_err); -#endif - if (gif == NULL) + /* Read entire contents. */ + rc = DGifSlurp (gif); + if (rc == GIF_ERROR || gif->ImageCount <= 0) { #if HAVE_GIFERRORSTRING - const char *errstr = GifErrorString (gif_err); + const char *errstr = GifErrorString (gif->Error); if (errstr) - image_error ("Cannot open `%s': %s", file, build_string (errstr)); + if (NILP (specified_data)) + image_error ("Error reading `%s' (%s)", img->spec, + build_string (errstr)); + else + image_error ("Error reading GIF data: %s", + build_string (errstr)); else #endif - image_error ("Cannot open `%s'", file); - return false; + if (NILP (specified_data)) + image_error ("Error reading `%s'", img->spec); + else + image_error ("Error reading GIF data"); + goto gif_error; + } + + width = img->width = gif->SWidth; + height = img->height = gif->SHeight; + + /* Check that the selected subimages fit. It's not clear whether + the GIF spec requires this, but Emacs can crash if they don't fit. */ + for (j = 0; j < gif->ImageCount; ++j) + { + struct SavedImage *subimage = gif->SavedImages + j; + int subimg_width = subimage->ImageDesc.Width; + int subimg_height = subimage->ImageDesc.Height; + int subimg_top = subimage->ImageDesc.Top; + int subimg_left = subimage->ImageDesc.Left; + if (subimg_width < 0 + || subimg_height < 0 + || subimg_top < 0 + || subimg_left < 0 + || subimg_top + subimg_height > height + || subimg_left + subimg_width > width) + { + image_error ("Subimage does not fit in image"); + goto gif_error; + } } } else { - if (!STRINGP (specified_data)) - { - image_error ("Invalid image data `%s'", specified_data); - return false; - } - - /* Read from memory! */ - current_gif_memory_src = &memsrc; - memsrc.bytes = SDATA (specified_data); - memsrc.len = SBYTES (specified_data); - memsrc.index = 0; - -#if GIFLIB_MAJOR < 5 - gif = DGifOpen (&memsrc, gif_read_from_memory); -#else - gif = DGifOpen (&memsrc, gif_read_from_memory, &gif_err); -#endif - if (!gif) - { -#if HAVE_GIFERRORSTRING - const char *errstr = GifErrorString (gif_err); - if (errstr) - image_error ("Cannot open memory source `%s': %s", - img->spec, build_string (errstr)); - else -#endif - image_error ("Cannot open memory source `%s'", img->spec); - return false; - } + /* Cached image; set data. */ + width = img->width = gif->SWidth; + height = img->height = gif->SHeight; } - /* Before reading entire contents, check the declared image size. */ - if (!check_image_size (f, gif->SWidth, gif->SHeight)) + if (idx < 0 || idx >= gif->ImageCount) { - image_size_error (); + image_error ("Invalid image number `%s' in image `%s'", + make_fixnum (idx), img->spec); goto gif_error; } - /* Read entire contents. */ - rc = DGifSlurp (gif); - if (rc == GIF_ERROR || gif->ImageCount <= 0) + /* It's an animated image, so initalize the cache. */ + if (cache && !cache->handle) { - if (NILP (specified_data)) - image_error ("Error reading `%s'", img->spec); - else - image_error ("Error reading GIF data"); - goto gif_error; + cache->handle = gif; + cache->destructor = (void (*)(void *)) &gif_destroy; + cache->width = width; + cache->height = height; } - /* Which sub-image are we to display? */ - { - Lisp_Object image_number = image_spec_value (img->spec, QCindex, NULL); - idx = FIXNUMP (image_number) ? XFIXNAT (image_number) : 0; - if (idx < 0 || idx >= gif->ImageCount) - { - image_error ("Invalid image number `%s' in image `%s'", - image_number, img->spec); - goto gif_error; - } - } - - width = img->width = gif->SWidth; - height = img->height = gif->SHeight; - img->corners[TOP_CORNER] = gif->SavedImages[0].ImageDesc.Top; img->corners[LEFT_CORNER] = gif->SavedImages[0].ImageDesc.Left; img->corners[BOT_CORNER] @@ -8789,29 +8992,20 @@ gif_load (struct frame *f, struct image *img) goto gif_error; } - /* Check that the selected subimages fit. It's not clear whether - the GIF spec requires this, but Emacs can crash if they don't fit. */ - for (j = 0; j <= idx; ++j) - { - struct SavedImage *subimage = gif->SavedImages + j; - int subimg_width = subimage->ImageDesc.Width; - int subimg_height = subimage->ImageDesc.Height; - int subimg_top = subimage->ImageDesc.Top; - int subimg_left = subimage->ImageDesc.Left; - if (! (subimg_width >= 0 && subimg_height >= 0 - && 0 <= subimg_top && subimg_top <= height - subimg_height - && 0 <= subimg_left && subimg_left <= width - subimg_width)) - { - image_error ("Subimage does not fit in image"); - goto gif_error; - } - } - /* Create the X image and pixmap. */ Emacs_Pix_Container ximg; if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, 0)) goto gif_error; + /* We construct the (possibly composited animated) image in this + buffer. */ + if (!pixmap) + { + pixmap = xmalloc (width * height * sizeof (unsigned long)); + if (cache) + cache->temp = pixmap; + } + /* Clear the part of the screen image not covered by the image. Full animated GIF support requires more here (see the gif89 spec, disposal methods). Let's simply assume that the part not covered @@ -8826,29 +9020,25 @@ gif_load (struct frame *f, struct image *img) frame_bg = lookup_rgb_color (f, color.red, color.green, color.blue); } #endif /* USE_CAIRO */ + for (y = 0; y < img->corners[TOP_CORNER]; ++y) for (x = 0; x < width; ++x) - PUT_PIXEL (ximg, x, y, frame_bg); + *(pixmap + x + y * width) = frame_bg; for (y = img->corners[BOT_CORNER]; y < height; ++y) for (x = 0; x < width; ++x) - PUT_PIXEL (ximg, x, y, frame_bg); + *(pixmap + x + y * width) = frame_bg; for (y = img->corners[TOP_CORNER]; y < img->corners[BOT_CORNER]; ++y) { for (x = 0; x < img->corners[LEFT_CORNER]; ++x) - PUT_PIXEL (ximg, x, y, frame_bg); + *(pixmap + x + y * width) = frame_bg; for (x = img->corners[RIGHT_CORNER]; x < width; ++x) - PUT_PIXEL (ximg, x, y, frame_bg); + *(pixmap + x + y * width) = frame_bg; } /* Read the GIF image into the X image. */ - /* FIXME: With the current implementation, loading an animated gif - is quadratic in the number of animation frames, since each frame - is a separate struct image. We must provide a way for a single - gif_load call to construct and save all animation frames. */ - init_color_table (); unsigned long bgcolor UNINIT; @@ -8863,7 +9053,18 @@ gif_load (struct frame *f, struct image *img) #endif } - for (j = 0; j <= idx; ++j) + int start_frame = 0; + + /* We have animation data in the cache. */ + if (cache && cache->temp) + { + start_frame = cache->index + 1; + if (start_frame > idx) + start_frame = 0; + cache->index = idx; + } + + for (j = start_frame; j <= idx; ++j) { /* We use a local variable `raster' here because RasterBits is a char *, which invites problems with bytes >= 0x80. */ @@ -8914,6 +9115,14 @@ gif_load (struct frame *f, struct image *img) if (disposal == DISPOSAL_UNSPECIFIED) disposal = DISPOSE_DO_NOT; + /* This is not quite correct -- the specification is unclear, + but I think we're supposed to restore to the frame before the + previous frame? And we don't have that data at this point. + But DISPOSE_DO_NOT is less wrong than substituting the + background, so do that for now. */ + if (disposal == DISPOSE_PREVIOUS) + disposal = DISPOSE_DO_NOT; + gif_color_map = subimage->ImageDesc.ColorMap; if (!gif_color_map) gif_color_map = gif->SColorMap; @@ -8953,8 +9162,8 @@ gif_load (struct frame *f, struct image *img) int c = raster[y * subimg_width + x]; if (transparency_color_index != c || disposal != DISPOSE_DO_NOT) { - PUT_PIXEL (ximg, x + subimg_left, row + subimg_top, - pixel_colors[c]); + *(pixmap + x + subimg_left + (y + subimg_top) * width) = + pixel_colors[c]; } } } @@ -8967,13 +9176,19 @@ gif_load (struct frame *f, struct image *img) int c = raster[y * subimg_width + x]; if (transparency_color_index != c || disposal != DISPOSE_DO_NOT) { - PUT_PIXEL (ximg, x + subimg_left, y + subimg_top, - pixel_colors[c]); + *(pixmap + x + subimg_left + (y + subimg_top) * width) = + pixel_colors[c]; } } } } + /* We now have the complete image (possibly composed from a series + of animated frames) in pixmap. Put it into ximg. */ + for (y = 0; y < height; ++y) + for (x = 0; x < width; ++x) + PUT_PIXEL (ximg, x, y, *(pixmap + x + y * width)); + #ifdef COLOR_TABLE_SUPPORT img->colors = colors_in_color_table (&img->ncolors); free_color_table (); @@ -9002,11 +9217,11 @@ gif_load (struct frame *f, struct image *img) } } img->lisp_data = list2 (Qextension_data, img->lisp_data); - if (delay) - img->lisp_data - = Fcons (Qdelay, - Fcons (make_float (delay / 100.0), - img->lisp_data)); + img->lisp_data + = Fcons (Qdelay, + /* Default GIF delay is 1/15th of a second. */ + Fcons (make_float (delay? delay / 100.0: 1.0 / 15), + img->lisp_data)); } if (gif->ImageCount > 1) @@ -9014,17 +9229,22 @@ gif_load (struct frame *f, struct image *img) Fcons (make_fixnum (gif->ImageCount), img->lisp_data)); - if (gif_close (gif, &gif_err) == GIF_ERROR) + if (!cache) { + if (pixmap) + xfree (pixmap); + if (gif_close (gif, &gif_err) == GIF_ERROR) + { #if HAVE_GIFERRORSTRING - char const *error_text = GifErrorString (gif_err); + char const *error_text = GifErrorString (gif_err); - if (error_text) - image_error ("Error closing `%s': %s", - img->spec, build_string (error_text)); - else + if (error_text) + image_error ("Error closing `%s': %s", + img->spec, build_string (error_text)); + else #endif - image_error ("Error closing `%s'", img->spec); + image_error ("Error closing `%s'", img->spec); + } } /* Maybe fill in the background field while we have ximg handy. */ @@ -9038,7 +9258,14 @@ gif_load (struct frame *f, struct image *img) return true; gif_error: + if (pixmap) + xfree (pixmap); gif_close (gif, NULL); + if (cache) + { + cache->handle = NULL; + cache->temp = NULL; + } return false; } @@ -9053,6 +9280,7 @@ gif_load (struct frame *f, struct image *img) ***********************************************************************/ #include "webp/decode.h" +#include "webp/demux.h" /* Indices of image specification fields in webp_format, below. */ @@ -9067,6 +9295,7 @@ enum webp_keyword_index WEBP_ALGORITHM, WEBP_HEURISTIC_MASK, WEBP_MASK, + WEBP_INDEX, WEBP_BACKGROUND, WEBP_LAST }; @@ -9085,6 +9314,7 @@ static const struct image_keyword webp_format[WEBP_LAST] = {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":index", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0}, {":background", IMAGE_STRING_OR_NIL_VALUE, 0} }; @@ -9117,20 +9347,41 @@ DEF_DLL_FN (VP8StatusCode, WebPGetFeaturesInternal, DEF_DLL_FN (uint8_t *, WebPDecodeRGBA, (const uint8_t *, size_t, int *, int *)); DEF_DLL_FN (uint8_t *, WebPDecodeRGB, (const uint8_t *, size_t, int *, int *)); DEF_DLL_FN (void, WebPFree, (void *)); +DEF_DLL_FN (uint32_t, WebPDemuxGetI, (const WebPDemuxer *, WebPFormatFeature)); +DEF_DLL_FN (WebPDemuxer *, WebPDemuxInternal, + (const WebPData *, int, WebPDemuxState *, int)); +DEF_DLL_FN (void, WebPDemuxDelete, (WebPDemuxer *)); +DEF_DLL_FN (int, WebPAnimDecoderGetNext, + (WebPAnimDecoder *, uint8_t **, int *)); +DEF_DLL_FN (WebPAnimDecoder *, WebPAnimDecoderNewInternal, + (const WebPData *, const WebPAnimDecoderOptions *, int)); +DEF_DLL_FN (int, WebPAnimDecoderOptionsInitInternal, + (WebPAnimDecoderOptions *, int)); +DEF_DLL_FN (int, WebPAnimDecoderHasMoreFrames, (const WebPAnimDecoder *)); +DEF_DLL_FN (void, WebPAnimDecoderDelete, (WebPAnimDecoder *)); static bool init_webp_functions (void) { - HMODULE library; + HMODULE library1, library2; - if (!(library = w32_delayed_load (Qwebp))) + if (!((library1 = w32_delayed_load (Qwebp)) + && (library2 = w32_delayed_load (Qwebpdemux)))) return false; - LOAD_DLL_FN (library, WebPGetInfo); - LOAD_DLL_FN (library, WebPGetFeaturesInternal); - LOAD_DLL_FN (library, WebPDecodeRGBA); - LOAD_DLL_FN (library, WebPDecodeRGB); - LOAD_DLL_FN (library, WebPFree); + LOAD_DLL_FN (library1, WebPGetInfo); + LOAD_DLL_FN (library1, WebPGetFeaturesInternal); + LOAD_DLL_FN (library1, WebPDecodeRGBA); + LOAD_DLL_FN (library1, WebPDecodeRGB); + LOAD_DLL_FN (library1, WebPFree); + LOAD_DLL_FN (library2, WebPDemuxGetI); + LOAD_DLL_FN (library2, WebPDemuxInternal); + LOAD_DLL_FN (library2, WebPDemuxDelete); + LOAD_DLL_FN (library2, WebPAnimDecoderGetNext); + LOAD_DLL_FN (library2, WebPAnimDecoderNewInternal); + LOAD_DLL_FN (library2, WebPAnimDecoderOptionsInitInternal); + LOAD_DLL_FN (library2, WebPAnimDecoderHasMoreFrames); + LOAD_DLL_FN (library2, WebPAnimDecoderDelete); return true; } @@ -9139,6 +9390,14 @@ init_webp_functions (void) #undef WebPDecodeRGBA #undef WebPDecodeRGB #undef WebPFree +#undef WebPDemuxGetI +#undef WebPDemux +#undef WebPDemuxDelete +#undef WebPAnimDecoderGetNext +#undef WebPAnimDecoderNew +#undef WebPAnimDecoderOptionsInit +#undef WebPAnimDecoderHasMoreFrames +#undef WebPAnimDecoderDelete #define WebPGetInfo fn_WebPGetInfo #define WebPGetFeatures(d,s,f) \ @@ -9146,9 +9405,26 @@ init_webp_functions (void) #define WebPDecodeRGBA fn_WebPDecodeRGBA #define WebPDecodeRGB fn_WebPDecodeRGB #define WebPFree fn_WebPFree +#define WebPDemuxGetI fn_WebPDemuxGetI +#define WebPDemux(d) \ + fn_WebPDemuxInternal(d,0,NULL,WEBP_DEMUX_ABI_VERSION) +#define WebPDemuxDelete fn_WebPDemuxDelete +#define WebPAnimDecoderGetNext fn_WebPAnimDecoderGetNext +#define WebPAnimDecoderNew(d,o) \ + fn_WebPAnimDecoderNewInternal(d,o,WEBP_DEMUX_ABI_VERSION) +#define WebPAnimDecoderOptionsInit(o) \ + fn_WebPAnimDecoderOptionsInitInternal(o,WEBP_DEMUX_ABI_VERSION) +#define WebPAnimDecoderHasMoreFrames fn_WebPAnimDecoderHasMoreFrames +#define WebPAnimDecoderDelete fn_WebPAnimDecoderDelete #endif /* WINDOWSNT */ +static void +webp_destroy (struct anim_cache* cache) +{ + WebPAnimDecoderDelete (cache->handle); +} + /* Load WebP image IMG for use on frame F. Value is true if successful. */ @@ -9158,6 +9434,9 @@ webp_load (struct frame *f, struct image *img) ptrdiff_t size = 0; uint8_t *contents; Lisp_Object file = Qnil; + int frames = 0; + double delay = 0; + WebPAnimDecoder* anim = NULL; /* Open the WebP file. */ Lisp_Object specified_file = image_spec_value (img->spec, QCfile, NULL); @@ -9201,6 +9480,9 @@ webp_load (struct frame *f, struct image *img) goto webp_error1; } + Lisp_Object image_number = image_spec_value (img->spec, QCindex, NULL); + ptrdiff_t idx = FIXNUMP (image_number) ? XFIXNAT (image_number) : 0; + /* Get WebP features. */ WebPBitstreamFeatures features; VP8StatusCode result = WebPGetFeatures (contents, size, &features); @@ -9224,19 +9506,90 @@ webp_load (struct frame *f, struct image *img) goto webp_error1; } - /* Decode WebP data. */ - uint8_t *decoded; + uint8_t *decoded = NULL; int width, height; - if (features.has_alpha) - /* Linear [r0, g0, b0, a0, r1, g1, b1, a1, ...] order. */ - decoded = WebPDecodeRGBA (contents, size, &width, &height); + + if (features.has_animation) + { + /* Animated image. */ + int timestamp; + + struct anim_cache* cache = anim_get_animation_cache (img->spec); + /* Get the next frame from the animation cache. */ + if (cache->handle && cache->index == idx - 1) + { + WebPAnimDecoderGetNext (cache->handle, &decoded, ×tamp); + delay = timestamp; + cache->index++; + anim = cache->handle; + width = cache->width; + height = cache->height; + frames = cache->frames; + } + else + { + /* Start a new cache entry. */ + if (cache->handle) + WebPAnimDecoderDelete (cache->handle); + + WebPData webp_data; + if (NILP (specified_data)) + /* If we got the data from a file, then we don't need to + copy the data. */ + webp_data.bytes = cache->temp = contents; + else + /* We got the data from a string, so copy it over so that + it doesn't get garbage-collected. */ + { + webp_data.bytes = xmalloc (size); + memcpy ((void*) webp_data.bytes, contents, size); + } + /* In any case, we release the allocated memory when we + purge the anim cache. */ + webp_data.size = size; + + /* Get the width/height of the total image. */ + WebPDemuxer* demux = WebPDemux (&webp_data); + cache->width = width = WebPDemuxGetI (demux, WEBP_FF_CANVAS_WIDTH); + cache->height = height = WebPDemuxGetI (demux, + WEBP_FF_CANVAS_HEIGHT); + cache->frames = frames = WebPDemuxGetI (demux, WEBP_FF_FRAME_COUNT); + cache->destructor = (void (*)(void *)) webp_destroy; + WebPDemuxDelete (demux); + + WebPAnimDecoderOptions dec_options; + WebPAnimDecoderOptionsInit (&dec_options); + anim = WebPAnimDecoderNew (&webp_data, &dec_options); + + cache->handle = anim; + cache->index = idx; + + while (WebPAnimDecoderHasMoreFrames (anim)) { + WebPAnimDecoderGetNext (anim, &decoded, ×tamp); + /* Each frame has its own delay, but we don't really support + that. So just use the delay from the first frame. */ + if (delay == 0) + delay = timestamp; + /* Stop when we get to the desired index. */ + if (idx-- == 0) + break; + } + } + } else - /* Linear [r0, g0, b0, r1, g1, b1, ...] order. */ - decoded = WebPDecodeRGB (contents, size, &width, &height); + { + /* Non-animated image. */ + if (features.has_alpha) + /* Linear [r0, g0, b0, a0, r1, g1, b1, a1, ...] order. */ + decoded = WebPDecodeRGBA (contents, size, &width, &height); + else + /* Linear [r0, g0, b0, r1, g1, b1, ...] order. */ + decoded = WebPDecodeRGB (contents, size, &width, &height); + } if (!decoded) { - image_error ("Error when interpreting WebP image data"); + image_error ("Error when decoding WebP image data"); goto webp_error1; } @@ -9255,7 +9608,8 @@ webp_load (struct frame *f, struct image *img) /* Create an image and pixmap serving as mask if the WebP image contains an alpha channel. */ if (features.has_alpha - && !image_create_x_image_and_pixmap (f, img, width, height, 1, &mask_img, true)) + && !image_create_x_image_and_pixmap (f, img, width, height, 1, + &mask_img, true)) { image_destroy_x_image (ximg); image_clear_image_1 (f, img, CLEAR_IMAGE_PIXMAP); @@ -9265,6 +9619,13 @@ webp_load (struct frame *f, struct image *img) /* Fill the X image and mask from WebP data. */ init_color_table (); + img->corners[TOP_CORNER] = 0; + img->corners[LEFT_CORNER] = 0; + img->corners[BOT_CORNER] + = img->corners[TOP_CORNER] + height; + img->corners[RIGHT_CORNER] + = img->corners[LEFT_CORNER] + width; + uint8_t *p = decoded; for (int y = 0; y < height; ++y) { @@ -9279,7 +9640,7 @@ webp_load (struct frame *f, struct image *img) image. WebP allows up to 256 levels of partial transparency. We handle this like with PNG (which see), using the frame's background color to combine the image with. */ - if (features.has_alpha) + if (features.has_alpha || anim) { if (mask_img) PUT_PIXEL (mask_img, x, y, *p > 0 ? PIX_MASK_DRAW : PIX_MASK_RETAIN); @@ -9310,14 +9671,24 @@ webp_load (struct frame *f, struct image *img) img->width = width; img->height = height; + /* Return animation data. */ + img->lisp_data = Fcons (Qcount, + Fcons (make_fixnum (frames), + img->lisp_data)); + img->lisp_data = Fcons (Qdelay, + Fcons (make_float (delay / 1000), + img->lisp_data)); + /* Clean up. */ - WebPFree (decoded); - if (NILP (specified_data)) + if (!anim) + WebPFree (decoded); + if (NILP (specified_data) && !anim) xfree (contents); return true; webp_error2: - WebPFree (decoded); + if (!anim) + WebPFree (decoded); webp_error1: if (NILP (specified_data)) @@ -9484,7 +9855,7 @@ imagemagick_filename_hint (Lisp_Object spec, char hint_buffer[MaxTextExtent]) (which is the first one, and then there's a number of images that follow. If following images have non-transparent colors, these are composed "on top" of the master image. So, in general, one has to - compute ann the preceding images to be able to display a particular + compute all the preceding images to be able to display a particular sub-image. Computing all the preceding images is too slow, so we maintain a @@ -10945,7 +11316,7 @@ svg_load_image (struct frame *f, struct image *img, char *contents, #endif /* FIXME: Use error->message so the user knows what is the actual problem with the image. */ - image_error ("Error parsing SVG image `%s'", img->spec); + image_error ("Error parsing SVG image"); g_clear_error (&err); return 0; } @@ -11524,6 +11895,7 @@ non-numeric, there is no explicit limit on the size of images. */); #if defined (HAVE_WEBP) || (defined (HAVE_NATIVE_IMAGE_API) \ && defined (HAVE_HAIKU)) DEFSYM (Qwebp, "webp"); + DEFSYM (Qwebpdemux, "webpdemux"); add_image_type (Qwebp); #endif @@ -11555,6 +11927,12 @@ non-numeric, there is no explicit limit on the size of images. */); #if HAVE_NATIVE_IMAGE_API DEFSYM (Qnative_image, "native-image"); + +# if defined HAVE_NTGUI || defined HAVE_HAIKU + DEFSYM (Qbmp, "bmp"); + add_image_type (Qbmp); +# endif + # ifdef HAVE_NTGUI DEFSYM (Qgdiplus, "gdiplus"); DEFSYM (Qshlwapi, "shlwapi"); @@ -11577,6 +11955,11 @@ non-numeric, there is no explicit limit on the size of images. */); defsubr (&Slookup_image); #endif + DEFSYM (QCanimate_buffer, ":animate-buffer"); + DEFSYM (QCanimate_tardiness, ":animate-tardiness"); + DEFSYM (QCanimate_position, ":animate-position"); + DEFSYM (QCanimate_multi_frame_data, ":animate-multi-frame-data"); + defsubr (&Simage_transforms_p); DEFVAR_BOOL ("cross-disabled-images", cross_disabled_images, diff --git a/src/indent.c b/src/indent.c index d5ad02ae3af..acbb9dc9723 100644 --- a/src/indent.c +++ b/src/indent.c @@ -2209,7 +2209,10 @@ whether or not it is currently displayed in some window. */) } else it_overshoot_count = - !(it.method == GET_FROM_IMAGE || it.method == GET_FROM_STRETCH); + /* If image_id is negative, it's a fringe bitmap, which by + definition doesn't affect display in the text area. */ + !((it.method == GET_FROM_IMAGE && it.image_id >= 0) + || it.method == GET_FROM_STRETCH); if (start_x_given) { diff --git a/src/keyboard.c b/src/keyboard.c index 218f9a86c86..70908120cb0 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -336,6 +336,11 @@ static struct timespec timer_idleness_start_time; static struct timespec timer_last_idleness_start_time; +/* Predefined strings for core device names. */ + +static Lisp_Object virtual_core_pointer_name; +static Lisp_Object virtual_core_keyboard_name; + /* Global variable declarations. */ @@ -1054,7 +1059,7 @@ Default value of `command-error-function'. */) print_error_message (data, Qexternal_debugging_output, SSDATA (context), signal); Fterpri (Qexternal_debugging_output, Qnil); - Fkill_emacs (make_fixnum (-1)); + Fkill_emacs (make_fixnum (-1), Qnil); } else { @@ -1117,7 +1122,7 @@ command_loop (void) /* End of file in -batch run causes exit here. */ if (noninteractive) - Fkill_emacs (Qt); + Fkill_emacs (Qt, Qnil); } } @@ -1326,7 +1331,7 @@ command_loop_1 (void) Lisp_Object cmd; if (! FRAME_LIVE_P (XFRAME (selected_frame))) - Fkill_emacs (Qnil); + Fkill_emacs (Qnil, Qnil); /* Make sure the current window's buffer is selected. */ set_buffer_internal (XBUFFER (XWINDOW (selected_window)->contents)); @@ -1397,7 +1402,7 @@ command_loop_1 (void) /* A filter may have run while we were reading the input. */ if (! FRAME_LIVE_P (XFRAME (selected_frame))) - Fkill_emacs (Qnil); + Fkill_emacs (Qnil, Qnil); set_buffer_internal (XBUFFER (XWINDOW (selected_window)->contents)); ++num_input_keys; @@ -1655,7 +1660,7 @@ read_menu_command (void) unbind_to (count, Qnil); if (! FRAME_LIVE_P (XFRAME (selected_frame))) - Fkill_emacs (Qnil); + Fkill_emacs (Qnil, Qnil); if (i == 0 || i == -1) return Qt; @@ -2254,7 +2259,7 @@ read_event_from_main_queue (struct timespec *end_time, /* Terminate Emacs in batch mode if at eof. */ if (noninteractive && FIXNUMP (c) && XFIXNUM (c) < 0) - Fkill_emacs (make_fixnum (1)); + Fkill_emacs (make_fixnum (1), Qnil); if (FIXNUMP (c)) { @@ -2460,6 +2465,7 @@ read_char (int commandflag, Lisp_Object map, else reread = false; + Vlast_event_device = Qnil; if (CONSP (Vunread_command_events)) { @@ -3760,6 +3766,7 @@ gen_help_event (Lisp_Object help, Lisp_Object frame, Lisp_Object window, Lisp_Object object, ptrdiff_t pos) { struct input_event event; + EVENT_INIT (event); event.kind = HELP_EVENT; event.frame_or_window = frame; @@ -3777,6 +3784,7 @@ void kbd_buffer_store_help_event (Lisp_Object frame, Lisp_Object help) { struct input_event event; + EVENT_INIT (event); event.kind = HELP_EVENT; event.frame_or_window = frame; @@ -4006,6 +4014,41 @@ kbd_buffer_get_event (KBOARD **kbp, } break; +#ifdef HAVE_X_WINDOWS + case UNSUPPORTED_DROP_EVENT: + { + struct frame *f; + + kbd_fetch_ptr = next_kbd_event (event); + input_pending = readable_events (0); + + f = XFRAME (event->ie.frame_or_window); + + if (!FRAME_LIVE_P (f)) + break; + + if (!NILP (Vx_dnd_unsupported_drop_function)) + { + if (!NILP (call6 (Vx_dnd_unsupported_drop_function, + XCAR (XCDR (event->ie.arg)), event->ie.x, + event->ie.y, XCAR (XCDR (XCDR (event->ie.arg))), + make_uint (event->ie.code), + event->ie.frame_or_window))) + break; + } + + x_dnd_do_unsupported_drop (FRAME_DISPLAY_INFO (f), + event->ie.frame_or_window, + XCAR (event->ie.arg), + XCAR (XCDR (event->ie.arg)), + (Window) event->ie.code, + XFIXNUM (event->ie.x), + XFIXNUM (event->ie.y), + event->ie.timestamp); + break; + } +#endif + #ifdef HAVE_EXT_MENU_BAR case MENU_BAR_ACTIVATE_EVENT: { @@ -4083,6 +4126,15 @@ kbd_buffer_get_event (KBOARD **kbp, obj = make_lispy_switch_frame (frame); internal_last_event_frame = frame; + if (EQ (event->ie.device, Qt)) + Vlast_event_device = ((event->ie.kind == ASCII_KEYSTROKE_EVENT + || event->ie.kind == MULTIBYTE_CHAR_KEYSTROKE_EVENT + || event->ie.kind == NON_ASCII_KEYSTROKE_EVENT) + ? virtual_core_keyboard_name + : virtual_core_pointer_name); + else + Vlast_event_device = event->ie.device; + /* If we didn't decide to make a switch-frame event, go ahead and build a real event from the queue entry. */ if (NILP (obj)) @@ -4138,6 +4190,10 @@ kbd_buffer_get_event (KBOARD **kbp, XSETCAR (Fnthcdr (make_fixnum (3), maybe_event->ie.arg), make_float (fmod (pinch_angle, 360.0))); + + if (!EQ (maybe_event->ie.device, Qt)) + Vlast_event_device = maybe_event->ie.device; + maybe_event = next_kbd_event (event); } } @@ -4221,12 +4277,13 @@ kbd_buffer_get_event (KBOARD **kbp, /* Try generating a mouse motion event. */ else if (some_mouse_moved ()) { - struct frame *f = some_mouse_moved (); + struct frame *f, *movement_frame = some_mouse_moved (); Lisp_Object bar_window; enum scroll_bar_part part; Lisp_Object x, y; Time t; + f = movement_frame; *kbp = current_kboard; /* Note that this uses F to determine which terminal to look at. If there is no valid info, it does not store anything @@ -4261,6 +4318,11 @@ kbd_buffer_get_event (KBOARD **kbp, return a mouse-motion event. */ if (!NILP (x) && NILP (obj)) obj = make_lispy_movement (f, bar_window, part, x, y, t); + + if (!NILP (obj)) + Vlast_event_device = (STRINGP (movement_frame->last_mouse_device) + ? movement_frame->last_mouse_device + : virtual_core_pointer_name); } else /* We were promised by the above while loop that there was @@ -4571,6 +4633,8 @@ timer_check (void) Lisp_Object tem = Vinhibit_quit; Vinhibit_quit = Qt; + block_input (); + turn_on_atimers (false); /* We use copies of the timers' lists to allow a timer to add itself again, without locking up Emacs if the newly added timer is @@ -4584,6 +4648,8 @@ timer_check (void) else idle_timers = Qnil; + turn_on_atimers (true); + unblock_input (); Vinhibit_quit = tem; do @@ -5247,19 +5313,19 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, Lisp_Object window_or_frame = f ? window_from_coordinates (f, mx, my, &part, true, true) : Qnil; +#ifdef HAVE_WINDOW_SYSTEM bool tool_bar_p = false; bool menu_bar_p = false; /* Report mouse events on the tab bar and (on GUI frames) on the tool bar. */ -#ifdef HAVE_WINDOW_SYSTEM - if ((WINDOWP (f->tab_bar_window) - && EQ (window_or_frame, f->tab_bar_window)) + if (f && ((WINDOWP (f->tab_bar_window) + && EQ (window_or_frame, f->tab_bar_window)) #ifndef HAVE_EXT_TOOL_BAR - || (WINDOWP (f->tool_bar_window) - && EQ (window_or_frame, f->tool_bar_window)) + || (WINDOWP (f->tool_bar_window) + && EQ (window_or_frame, f->tool_bar_window)) #endif - ) + )) { /* While 'track-mouse' is neither nil nor t, do not report this event as something that happened on the tool or tab bar since @@ -5283,7 +5349,7 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, window_or_frame = Qnil; } - if (FRAME_TERMINAL (f)->toolkit_position_hook) + if (f && FRAME_TERMINAL (f)->toolkit_position_hook) { FRAME_TERMINAL (f)->toolkit_position_hook (f, mx, my, &menu_bar_p, &tool_bar_p); @@ -5524,9 +5590,16 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y, } #endif } - else - window_or_frame = Qnil; + { + if (EQ (track_mouse, Qdrag_source)) + { + xret = mx; + yret = my; + } + + window_or_frame = Qnil; + } return Fcons (window_or_frame, Fcons (posn, @@ -9970,7 +10043,7 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt, if (fix_current_buffer) { if (! FRAME_LIVE_P (XFRAME (selected_frame))) - Fkill_emacs (Qnil); + Fkill_emacs (Qnil, Qnil); if (XBUFFER (XWINDOW (selected_window)->contents) != current_buffer) Fset_buffer (XWINDOW (selected_window)->contents); @@ -10094,7 +10167,7 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt, record_unwind_current_buffer (); if (! FRAME_LIVE_P (XFRAME (selected_frame))) - Fkill_emacs (Qnil); + Fkill_emacs (Qnil, Qnil); set_buffer_internal (XBUFFER (XWINDOW (window)->contents)); goto replay_sequence; } @@ -11324,7 +11397,7 @@ quit_throw_to_read_char (bool from_signal) /* When not called from a signal handler it is safe to call Lisp. */ if (!from_signal && EQ (Vquit_flag, Qkill_emacs)) - Fkill_emacs (Qnil); + Fkill_emacs (Qnil, Qnil); /* Prevent another signal from doing this before we finish. */ clear_waiting_for_input (); @@ -11763,6 +11836,10 @@ init_keyboard (void) interrupt_input_blocked = 0; pending_signals = false; + virtual_core_pointer_name = build_string ("Virtual core pointer"); + virtual_core_keyboard_name = build_string ("Virtual core keyboard"); + Vlast_event_device = Qnil; + /* This means that command_loop_1 won't try to select anything the first time through. */ internal_last_event_frame = Qnil; @@ -12183,6 +12260,12 @@ syms_of_keyboard (void) staticpro (&poll_timer_time); #endif + virtual_core_pointer_name = Qnil; + staticpro (&virtual_core_pointer_name); + + virtual_core_keyboard_name = Qnil; + staticpro (&virtual_core_keyboard_name); + defsubr (&Scurrent_idle_time); defsubr (&Sevent_symbol_parse_modifiers); defsubr (&Sevent_convert_list); @@ -12351,7 +12434,10 @@ Polling is automatically disabled in all other cases. */); doc: /* Maximum time between mouse clicks to make a double-click. Measured in milliseconds. The value nil means disable double-click recognition; t means double-clicks have no time limit and are detected -by position only. */); +by position only. + +In Lisp, you might want to use `mouse-double-click-time' instead of +reading the value of this variable directly. */); Vdouble_click_time = make_fixnum (500); DEFVAR_INT ("double-click-fuzz", double_click_fuzz, @@ -12381,6 +12467,17 @@ This does not include events generated by keyboard macros. */); If the last event came from a keyboard macro, this is set to `macro'. */); Vlast_event_frame = Qnil; + DEFVAR_LISP ("last-event-device", Vlast_event_device, + doc: /* The name of the input device of the most recently read event. +When the input extension is being used on X, this is the name of the X +Input Extension device from which the last event was generated as a +string. Otherwise, this is "Virtual core keyboard" for keyboard input +events, and "Virtual core pointer" for other events. + +It is nil if the last event did not come from an input device (i.e. it +came from `unread-command-events' instead). */); + Vlast_event_device = Qnil; + /* This variable is set up in sysdep.c. */ DEFVAR_LISP ("tty-erase-char", Vtty_erase_char, doc: /* The ERASE character as set by the user with stty. */); @@ -12563,12 +12660,15 @@ and the minor mode maps regardless of `overriding-local-map'. */); doc: /* Non-nil means generate motion events for mouse motion. The special values `dragging' and `dropping' assert that the mouse cursor retains its appearance during mouse motion. Any non-nil value -but `dropping' asserts that motion events always relate to the frame -where the mouse movement started. The value `dropping' asserts -that motion events relate to the frame where the mouse cursor is seen -when generating the event. If there's no such frame, such motion -events relate to the frame where the mouse movement started. */); - +but `dropping' or `drag-source' asserts that motion events always +relate to the frame where the mouse movement started. The value +`dropping' asserts that motion events relate to the frame where the +mouse cursor is seen when generating the event. If there's no such +frame, such motion events relate to the frame where the mouse movement +started. The value `drag-source' is like `dropping', but the +`posn-window' will be nil in mouse position lists inside mouse +movement events if there is no frame directly visible underneath the +mouse pointer. */); DEFVAR_KBOARD ("system-key-alist", Vsystem_key_alist, doc: /* Alist of system-specific X windows key symbols. Each element should have the form (N . SYMBOL) where N is the @@ -12998,6 +13098,12 @@ mark_kboards (void) mark_object (event->ie.y); mark_object (event->ie.frame_or_window); mark_object (event->ie.arg); + + /* This should never be allocated for a single event, but + mark it anyway in the situation where the list of devices + changed but an event with an old device is still present + in the queue. */ + mark_object (event->ie.device); } } } diff --git a/src/keymap.c b/src/keymap.c index 83c54e26300..da0a52bd2c1 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -2867,7 +2867,7 @@ You type Translation\n\ CALLN (Ffuncall, Qdescribe_map_tree, Vkey_translation_map, Qnil, Qnil, prefix, - msg, nomenu, Qt, Qnil, Qnil); + msg, nomenu, Qt, Qnil, Qnil, buffer); } /* Print the (major mode) local map. */ @@ -2881,7 +2881,7 @@ You type Translation\n\ CALLN (Ffuncall, Qdescribe_map_tree, start1, Qt, shadow, prefix, - msg, nomenu, Qnil, Qnil, Qnil); + msg, nomenu, Qnil, Qnil, Qnil, buffer); shadow = Fcons (start1, shadow); start1 = Qnil; } @@ -2894,7 +2894,7 @@ You type Translation\n\ CALLN (Ffuncall, Qdescribe_map_tree, start1, Qt, shadow, prefix, - msg, nomenu, Qnil, Qnil, Qnil); + msg, nomenu, Qnil, Qnil, Qnil, buffer); shadow = Fcons (start1, shadow); } else @@ -2917,7 +2917,7 @@ You type Translation\n\ CALLN (Ffuncall, Qdescribe_map_tree, start1, Qt, shadow, prefix, - msg, nomenu, Qnil, Qnil, Qnil); + msg, nomenu, Qnil, Qnil, Qnil, buffer); shadow = Fcons (start1, shadow); } @@ -2950,7 +2950,7 @@ You type Translation\n\ CALLN (Ffuncall, Qdescribe_map_tree, maps[i], Qt, shadow, prefix, - msg, nomenu, Qnil, Qnil, Qnil); + msg, nomenu, Qnil, Qnil, Qnil, buffer); shadow = Fcons (maps[i], shadow); SAFE_FREE (); } @@ -2968,7 +2968,7 @@ You type Translation\n\ CALLN (Ffuncall, Qdescribe_map_tree, start1, Qt, shadow, prefix, - msg, nomenu, Qnil, Qnil, Qnil); + msg, nomenu, Qnil, Qnil, Qnil, buffer); } else { @@ -2976,7 +2976,7 @@ You type Translation\n\ CALLN (Ffuncall, Qdescribe_map_tree, start1, Qt, shadow, prefix, - msg, nomenu, Qnil, Qnil, Qnil); + msg, nomenu, Qnil, Qnil, Qnil, buffer); } shadow = Fcons (start1, shadow); @@ -2987,7 +2987,7 @@ You type Translation\n\ CALLN (Ffuncall, Qdescribe_map_tree, current_global_map, Qt, shadow, prefix, - msg, nomenu, Qnil, Qt, Qnil); + msg, nomenu, Qnil, Qt, Qnil, buffer); /* Print the function-key-map translations under this prefix. */ if (!NILP (KVAR (current_kboard, Vlocal_function_key_map))) @@ -2996,7 +2996,7 @@ You type Translation\n\ CALLN (Ffuncall, Qdescribe_map_tree, KVAR (current_kboard, Vlocal_function_key_map), Qnil, Qnil, prefix, - msg, nomenu, Qt, Qnil, Qnil); + msg, nomenu, Qt, Qnil, Qnil, buffer); } /* Print the input-decode-map translations under this prefix. */ @@ -3006,7 +3006,7 @@ You type Translation\n\ CALLN (Ffuncall, Qdescribe_map_tree, KVAR (current_kboard, Vinput_decode_map), Qnil, Qnil, prefix, - msg, nomenu, Qt, Qnil, Qnil); + msg, nomenu, Qt, Qnil, Qnil, buffer); } return Qnil; } diff --git a/src/lisp.h b/src/lisp.h index aecbfed7fae..eb1f1ec2c21 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -342,6 +342,7 @@ typedef EMACS_INT Lisp_Word; # define lisp_h_XIL(i) (i) # define lisp_h_XLP(o) ((void *) (uintptr_t) (o)) # endif +# define lisp_h_Qnil 0 #else # if LISP_WORDS_ARE_POINTERS # define lisp_h_XLI(o) ((EMACS_INT) (o).i) @@ -352,6 +353,7 @@ typedef EMACS_INT Lisp_Word; # define lisp_h_XIL(i) ((Lisp_Object) {i}) # define lisp_h_XLP(o) ((void *) (uintptr_t) (o).i) # endif +# define lisp_h_Qnil {0} #endif #define lisp_h_PSEUDOVECTORP(a,code) \ @@ -624,6 +626,7 @@ extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); extern AVOID wrong_type_argument (Lisp_Object, Lisp_Object); extern Lisp_Object default_value (Lisp_Object symbol); extern void defalias (Lisp_Object symbol, Lisp_Object definition); +extern char *fixnum_to_string (EMACS_INT number, char *buffer, char *end); /* Defined in emacs.c. */ @@ -2154,9 +2157,10 @@ struct Lisp_Subr short min_args, max_args; const char *symbol_name; union { - const char *intspec; - Lisp_Object native_intspec; - }; + const char *string; + Lisp_Object native; + } intspec; + Lisp_Object command_modes; EMACS_INT doc; #ifdef HAVE_NATIVE_COMP Lisp_Object native_comp_u; @@ -2185,6 +2189,16 @@ XSUBR (Lisp_Object a) return &XUNTAG (a, Lisp_Vectorlike, union Aligned_Lisp_Subr)->s; } +/* Return whether a value might be a valid docstring. + Used to distinguish the presence of non-docstring in the docstring slot, + as in the case of OClosures. */ +INLINE bool +VALID_DOCSTRING_P (Lisp_Object doc) +{ + return FIXNUMP (doc) || STRINGP (doc) + || (CONSP (doc) && STRINGP (XCAR (doc)) && FIXNUMP (XCDR (doc))); +} + enum char_table_specials { /* This is the number of slots that every char table must have. This @@ -3175,12 +3189,12 @@ CHECK_SUBR (Lisp_Object x) /* This version of DEFUN declares a function prototype with the right arguments, so we can catch errors with maxargs at compile-time. */ -#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ - SUBR_SECTION_ATTRIBUTE \ - static union Aligned_Lisp_Subr sname = \ - {{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ - { .a ## maxargs = fnname }, \ - minargs, maxargs, lname, {intspec}, 0}}; \ +#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ + SUBR_SECTION_ATTRIBUTE \ + static union Aligned_Lisp_Subr sname = \ + {{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ + { .a ## maxargs = fnname }, \ + minargs, maxargs, lname, {intspec}, lisp_h_Qnil}}; \ Lisp_Object fnname /* defsubr (Sname); @@ -3204,6 +3218,76 @@ enum maxargs 'Finsert (1, &text);'. */ #define CALLN(f, ...) CALLMANY (f, ((Lisp_Object []) {__VA_ARGS__})) +/* Call function fn on no arguments. */ +INLINE Lisp_Object +call0 (Lisp_Object fn) +{ + return Ffuncall (1, &fn); +} + +/* Call function fn with 1 argument arg1. */ +INLINE Lisp_Object +call1 (Lisp_Object fn, Lisp_Object arg1) +{ + return CALLN (Ffuncall, fn, arg1); +} + +/* Call function fn with 2 arguments arg1, arg2. */ +INLINE Lisp_Object +call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) +{ + return CALLN (Ffuncall, fn, arg1, arg2); +} + +/* Call function fn with 3 arguments arg1, arg2, arg3. */ +INLINE Lisp_Object +call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3); +} + +/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */ +INLINE Lisp_Object +call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object arg4) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4); +} + +/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */ +INLINE Lisp_Object +call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object arg4, Lisp_Object arg5) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5); +} + +/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */ +INLINE Lisp_Object +call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6); +} + +/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */ +INLINE Lisp_Object +call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7); +} + +/* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5, + arg6, arg7, arg8. */ +INLINE Lisp_Object +call8 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7, + Lisp_Object arg8) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +} + extern void defvar_lisp (struct Lisp_Objfwd const *, char const *); extern void defvar_lisp_nopro (struct Lisp_Objfwd const *, char const *); extern void defvar_bool (struct Lisp_Boolfwd const *, char const *); @@ -3318,8 +3402,9 @@ union specbinding } unwind_array; struct { ENUM_BF (specbind_tag) kind : CHAR_BIT; - void (*func) (void *); + void (*func) (void *); /* Unwind function. */ void *arg; + void (*mark) (void *); /* GC mark function (if non-null). */ } unwind_ptr; struct { ENUM_BF (specbind_tag) kind : CHAR_BIT; @@ -3458,6 +3543,41 @@ backtrace_debug_on_exit (union specbinding *pdl) return pdl->bt.debug_on_exit; } +void grow_specpdl_allocation (void); + +/* Grow the specpdl stack by one entry. + The caller should have already initialized the entry. + Signal an error on stack overflow. + + Make sure that there is always one unused entry past the top of the + stack, so that the just-initialized entry is safely unwound if + memory exhausted and an error is signaled here. Also, allocate a + never-used entry just before the bottom of the stack; sometimes its + address is taken. */ +INLINE void +grow_specpdl (void) +{ + specpdl_ptr++; + if (specpdl_ptr == specpdl_end) + grow_specpdl_allocation (); +} + +INLINE specpdl_ref +record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) +{ + specpdl_ref count = SPECPDL_INDEX (); + + eassert (nargs >= UNEVALLED); + specpdl_ptr->bt.kind = SPECPDL_BACKTRACE; + specpdl_ptr->bt.debug_on_exit = false; + specpdl_ptr->bt.function = function; + current_thread->stack_top = specpdl_ptr->bt.args = args; + specpdl_ptr->bt.nargs = nargs; + grow_specpdl (); + + return count; +} + /* This structure helps implement the `catch/throw' and `condition-case/signal' control structures. A struct handler contains all the information needed to restore the state of the interpreter after a non-local jump. @@ -3515,6 +3635,7 @@ struct handler sys_jmp_buf jmp; EMACS_INT f_lisp_eval_depth; specpdl_ref pdlcount; + struct bc_frame *act_rec; int poll_suppress_count; int interrupt_input_blocked; }; @@ -3876,8 +3997,6 @@ extern void hexbuf_digest (char *, void const *, int); extern char *extract_data_from_object (Lisp_Object, ptrdiff_t *, ptrdiff_t *); EMACS_UINT hash_string (char const *, ptrdiff_t); EMACS_UINT sxhash (Lisp_Object); -Lisp_Object hashfn_eql (Lisp_Object, struct Lisp_Hash_Table *); -Lisp_Object hashfn_equal (Lisp_Object, struct Lisp_Hash_Table *); Lisp_Object hashfn_user_defined (Lisp_Object, struct Lisp_Hash_Table *); Lisp_Object make_hash_table (struct hash_table_test, EMACS_INT, float, float, Lisp_Object, bool); @@ -3893,7 +4012,6 @@ extern Lisp_Object substring_both (Lisp_Object, ptrdiff_t, ptrdiff_t, extern Lisp_Object merge (Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object merge_c (Lisp_Object, Lisp_Object, bool (*) (Lisp_Object, Lisp_Object)); extern Lisp_Object do_yes_or_no_p (Lisp_Object); -extern int string_version_cmp (Lisp_Object, Lisp_Object); extern Lisp_Object concat2 (Lisp_Object, Lisp_Object); extern Lisp_Object concat3 (Lisp_Object, Lisp_Object, Lisp_Object); extern bool equal_no_quit (Lisp_Object, Lisp_Object); @@ -3907,6 +4025,9 @@ extern Lisp_Object string_to_multibyte (Lisp_Object); extern Lisp_Object string_make_unibyte (Lisp_Object); extern void syms_of_fns (void); +/* Defined in sort.c */ +extern void tim_sort (Lisp_Object, Lisp_Object *, const ptrdiff_t); + /* Defined in floatfns.c. */ verify (FLT_RADIX == 2 || FLT_RADIX == 16); enum { LOG2_FLT_RADIX = FLT_RADIX == 2 ? 1 : 4 }; @@ -4054,8 +4175,9 @@ extern void refill_memory_reserve (void); #endif extern void alloc_unexec_pre (void); extern void alloc_unexec_post (void); -extern void mark_stack (char const *, char const *); +extern void mark_c_stack (char const *, char const *); extern void flush_stack_call_func1 (void (*func) (void *arg), void *arg); +extern void mark_memory (void const *start, void const *end); /* Force callee-saved registers and register windows onto the stack, so that conservative garbage collection can see their values. */ @@ -4417,23 +4539,11 @@ extern bool FUNCTIONP (Lisp_Object); extern Lisp_Object funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *arg_vector); extern Lisp_Object eval_sub (Lisp_Object form); extern Lisp_Object apply1 (Lisp_Object, Lisp_Object); -extern Lisp_Object call0 (Lisp_Object); -extern Lisp_Object call1 (Lisp_Object, Lisp_Object); -extern Lisp_Object call2 (Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call6 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call7 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object call8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object internal_catch (Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object); extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); -extern Lisp_Object internal_condition_case_3 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); -extern Lisp_Object internal_condition_case_4 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); -extern Lisp_Object internal_condition_case_5 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); @@ -4445,6 +4555,8 @@ extern void specbind (Lisp_Object, Lisp_Object); extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object); extern void record_unwind_protect_array (Lisp_Object *, ptrdiff_t); extern void record_unwind_protect_ptr (void (*) (void *), void *); +extern void record_unwind_protect_ptr_mark (void (*function) (void *), + void *arg, void (*mark) (void *)); extern void record_unwind_protect_int (void (*) (int), int); extern void record_unwind_protect_intmax (void (*) (intmax_t), intmax_t); extern void record_unwind_protect_void (void (*) (void)); @@ -4473,7 +4585,6 @@ extern Lisp_Object safe_call2 (Lisp_Object, Lisp_Object, Lisp_Object); extern void init_eval (void); extern void syms_of_eval (void); extern void prog_ignore (Lisp_Object); -extern specpdl_ref record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t); extern void mark_specpdl (union specbinding *first, union specbinding *ptr); extern void get_backtrace (Lisp_Object array); Lisp_Object backtrace_top_function (void); @@ -4822,9 +4933,24 @@ extern int read_bytecode_char (bool); /* Defined in bytecode.c. */ extern void syms_of_bytecode (void); -extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, - ptrdiff_t, ptrdiff_t, Lisp_Object *); +extern Lisp_Object exec_byte_code (Lisp_Object, ptrdiff_t, + ptrdiff_t, Lisp_Object *); extern Lisp_Object get_byte_code_arity (Lisp_Object); +extern void init_bc_thread (struct bc_thread_state *bc); +extern void free_bc_thread (struct bc_thread_state *bc); +extern void mark_bytecode (struct bc_thread_state *bc); + +INLINE struct bc_frame * +get_act_rec (struct thread_state *th) +{ + return th->bc.fp; +} + +INLINE void +set_act_rec (struct thread_state *th, struct bc_frame *act_rec) +{ + th->bc.fp = act_rec; +} /* Defined in macros.c. */ extern void init_macros (void); @@ -4879,6 +5005,7 @@ extern void child_setup_tty (int); extern void setup_pty (int); extern int set_window_size (int, int, int); extern EMACS_INT get_random (void); +extern unsigned long int get_random_ulong (void); extern void seed_random (void *, ptrdiff_t); extern void init_random (void); extern void emacs_backtrace (int); diff --git a/src/lread.c b/src/lread.c index 8989e2d12dd..f1ffdef04e4 100644 --- a/src/lread.c +++ b/src/lread.c @@ -550,13 +550,21 @@ invalid_syntax_lisp (Lisp_Object s, Lisp_Object readcharfun) { if (BUFFERP (readcharfun)) { + ptrdiff_t line, column; + + /* Get the line/column in the readcharfun buffer. */ + { + specpdl_ref count = SPECPDL_INDEX (); + + record_unwind_protect_excursion (); + set_buffer_internal (XBUFFER (readcharfun)); + line = count_lines (BEGV_BYTE, PT_BYTE) + 1; + column = current_column (); + unbind_to (count, Qnil); + } + xsignal (Qinvalid_read_syntax, - list3 (s, - /* We should already be in the readcharfun - buffer when this error is called, so no need - to switch to it first. */ - make_fixnum (count_lines (BEGV_BYTE, PT_BYTE) + 1), - make_fixnum (current_column ()))); + list3 (s, make_fixnum (line), make_fixnum (column))); } else xsignal1 (Qinvalid_read_syntax, s); @@ -1661,7 +1669,7 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) (Lisp_Object filename, Lisp_Object path, Lisp_Object suffixes, Lisp_Object predicate) { Lisp_Object file; - int fd = openp (path, filename, suffixes, &file, predicate, false, false); + int fd = openp (path, filename, suffixes, &file, predicate, false, true); if (NILP (predicate) && fd >= 0) emacs_close (fd); return file; @@ -3480,6 +3488,29 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) /* Read the object itself. */ Lisp_Object tem = read0 (readcharfun, locate_syms); + if (CONSP (tem)) + { + if (BASE_EQ (tem, placeholder)) + /* Catch silly games like #1=#1# */ + invalid_syntax ("nonsensical self-reference", + readcharfun); + + /* Optimisation: since the placeholder is already + a cons, repurpose it as the actual value. + This allows us to skip the substition below, + since the placeholder is already referenced + inside TEM at the appropriate places. */ + Fsetcar (placeholder, XCAR (tem)); + Fsetcdr (placeholder, XCDR (tem)); + + struct Lisp_Hash_Table *h2 + = XHASH_TABLE (read_objects_completed); + ptrdiff_t i = hash_lookup (h2, placeholder, &hash); + eassert (i < 0); + hash_put (h2, placeholder, Qnil, hash); + return placeholder; + } + /* If it can be recursive, remember it for future substitutions. */ if (! SYMBOLP (tem) @@ -3494,24 +3525,15 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) } /* Now put it everywhere the placeholder was... */ - if (CONSP (tem)) - { - Fsetcar (placeholder, XCAR (tem)); - Fsetcdr (placeholder, XCDR (tem)); - return placeholder; - } - else - { - Flread__substitute_object_in_subtree - (tem, placeholder, read_objects_completed); + Flread__substitute_object_in_subtree + (tem, placeholder, read_objects_completed); - /* ...and #n# will use the real value from now on. */ - i = hash_lookup (h, number, &hash); - eassert (i >= 0); - set_hash_value_slot (h, i, tem); + /* ...and #n# will use the real value from now on. */ + i = hash_lookup (h, number, &hash); + eassert (i >= 0); + set_hash_value_slot (h, i, tem); - return tem; - } + return tem; } /* #n# returns a previously read object. */ diff --git a/src/macfont.m b/src/macfont.m index 34e48afb98f..4dd55e77469 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -57,8 +57,10 @@ static Boolean mac_font_descriptor_supports_languages (CTFontDescriptorRef, static CFIndex mac_font_shape (CTFontRef, CFStringRef, struct mac_glyph_layout *, CFIndex, enum lgstring_direction); +#if MAC_OS_X_VERSION_MIN_REQUIRED < 1090 static CFArrayRef mac_font_copy_default_descriptors_for_language (CFStringRef); static CFStringRef mac_font_copy_default_name_for_charset_and_languages (CFCharacterSetRef, CFArrayRef); +#endif #if USE_CT_GLYPH_INFO static CGGlyph mac_ctfont_get_glyph_for_cid (CTFontRef, CTCharacterCollection, CGFontIndex); @@ -845,7 +847,7 @@ static void mac_font_get_glyphs_for_variants (CFDataRef, UTF32Char, {{FONT_WEIGHT_INDEX, kCTFontWeightTrait, {{-0.4, 50}, /* light */ {-0.24, 87.5}, /* (semi-light + normal) / 2 */ - {0, 100}, /* normal */ + {0, 80}, /* normal */ {0.24, 140}, /* (semi-bold + normal) / 2 */ {0.4, 200}, /* bold */ {CGFLOAT_MAX, CGFLOAT_MAX}}, @@ -3570,18 +3572,17 @@ So we use CTFontDescriptorCreateMatchingFontDescriptor (no if (languages && CFArrayGetCount (languages) > 0) { - if ([[NSProcessInfo processInfo] - isOperatingSystemAtLeastVersion: - ((NSOperatingSystemVersion){ - .majorVersion = 10, .minorVersion = 9})]) - values[num_values++] = CFArrayGetValueAtIndex (languages, 0); - else +#if MAC_OS_X_VERSION_MIN_REQUIRED < 1090 + if (CTGetCoreTextVersion () < kCTVersionNumber10_9) { CFCharacterSetRef charset = CFDictionaryGetValue (attributes, kCTFontCharacterSetAttribute); result = mac_font_copy_default_name_for_charset_and_languages (charset, languages); } + else +#endif + values[num_values++] = CFArrayGetValueAtIndex (languages, 0); } if (result == NULL) { @@ -4000,6 +4001,7 @@ So we use CTFontDescriptorCreateMatchingFontDescriptor (no } #endif +#if MAC_OS_X_VERSION_MIN_REQUIRED < 1090 static CFArrayRef mac_font_copy_default_descriptors_for_language (CFStringRef language) { @@ -4134,6 +4136,7 @@ So we use CTFontDescriptorCreateMatchingFontDescriptor (no return result; } +#endif void * macfont_get_nsctfont (struct font *font) diff --git a/src/macros.c b/src/macros.c index 0447a367fd6..6b6865d9298 100644 --- a/src/macros.c +++ b/src/macros.c @@ -273,9 +273,15 @@ pop_kbd_macro (Lisp_Object info) } DEFUN ("execute-kbd-macro", Fexecute_kbd_macro, Sexecute_kbd_macro, 1, 3, 0, - doc: /* Execute MACRO as string of editor command characters. -MACRO can also be a vector of keyboard events. If MACRO is a symbol, -its function definition is used. + doc: /* Execute MACRO as a sequence of events. +If MACRO is a string or vector, then the events in it are executed +exactly as if they had been input by the user. + +If MACRO is a symbol, its function definition is used. If that is +another symbol, this process repeats. Eventually the result should be +a string or vector. If the result is not a symbol, string, or vector, +an error is signaled. + COUNT is a repeat count, or nil for once, or 0 for infinite loop. Optional third arg LOOPFUNC may be a function that is called prior to diff --git a/src/minibuf.c b/src/minibuf.c index 49a474dd492..df82bcb121a 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -34,6 +34,10 @@ along with GNU Emacs. If not, see . */ #include "systty.h" #include "pdumper.h" +#ifdef HAVE_NTGUI +#include "w32term.h" +#endif + /* List of buffers for use as minibuffers. The first element of the list is used for the outermost minibuffer invocation, the next element is used for a recursive minibuffer @@ -41,7 +45,7 @@ along with GNU Emacs. If not, see . */ minibuffer recursions are encountered. */ Lisp_Object Vminibuffer_list; -Lisp_Object Vcommand_loop_level_list; +static Lisp_Object Vcommand_loop_level_list; /* Data to remember during recursive minibuffer invocations. */ @@ -916,7 +920,17 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, XWINDOW (minibuf_window)->cursor.x = 0; XWINDOW (minibuf_window)->must_be_updated_p = true; update_frame (XFRAME (selected_frame), true, true); +#ifndef HAVE_NTGUI flush_frame (XFRAME (XWINDOW (minibuf_window)->frame)); +#else + /* The reason this function isn't `flush_display' in the RIF is + that `flush_frame' is also called in many other circumstances + when some code wants X requests to be sent to the X server, + but there is no corresponding "flush" concept on MS Windows, + and flipping buffers every time `flush_frame' is called + causes flicker. */ + w32_flip_buffers_if_dirty (XFRAME (XWINDOW (minibuf_window)->frame)); +#endif } /* Make minibuffer contents into a string. */ @@ -1568,36 +1582,47 @@ match_regexps (Lisp_Object string, Lisp_Object regexps, } DEFUN ("try-completion", Ftry_completion, Stry_completion, 2, 3, 0, - doc: /* Return common substring of all completions of STRING in COLLECTION. + doc: /* Return longest common substring of all completions of STRING in COLLECTION. + Test each possible completion specified by COLLECTION to see if it begins with STRING. The possible completions may be strings or symbols. Symbols are converted to strings before testing, -see `symbol-name'. -All that match STRING are compared together; the longest initial sequence -common to all these matches is the return value. -If there is no match at all, the return value is nil. -For a unique match which is exact, the return value is t. +by using `symbol-name'. + +If no possible completions match, the function returns nil; if +there's just one exact match, it returns t; otherwise it returns +the longest initial substring common to all possible completions +that begin with STRING. If COLLECTION is an alist, the keys (cars of elements) are the possible completions. If an element is not a cons cell, then the -element itself is the possible completion. -If COLLECTION is a hash-table, all the keys that are strings or symbols -are the possible completions. +element itself is a possible completion. +If COLLECTION is a hash-table, all the keys that are either strings +or symbols are the possible completions. If COLLECTION is an obarray, the names of all symbols in the obarray are the possible completions. COLLECTION can also be a function to do the completion itself. -It receives three arguments: the values STRING, PREDICATE and nil. +It receives three arguments: STRING, PREDICATE and nil. Whatever it returns becomes the value of `try-completion'. -If optional third argument PREDICATE is non-nil, -it is used to test each possible match. -The match is a candidate only if PREDICATE returns non-nil. -The argument given to PREDICATE is the alist element -or the symbol from the obarray. If COLLECTION is a hash-table, -predicate is called with two arguments: the key and the value. -Additionally to this predicate, `completion-regexp-list' -is used to further constrain the set of candidates. */) +If optional third argument PREDICATE is non-nil, it must be a function +of one or two arguments, and is used to test each possible completion. +A possible completion is accepted only if PREDICATE returns non-nil. + +The argument given to PREDICATE is either a string or a cons cell (whose +car is a string) from the alist, or a symbol from the obarray. +If COLLECTION is a hash-table, PREDICATE is called with two arguments: +the string key and the associated value. + +To be acceptable, a possible completion must also match all the regexps +in `completion-regexp-list' (unless COLLECTION is a function, in +which case that function should itself handle `completion-regexp-list'). + +If `completion-ignore-case' is non-nil, possible completions are matched +while ignoring letter-case, but no guarantee is made about the letter-case +of the return value, except that it comes either from the user's input +or from one of the possible completions. */) (Lisp_Object string, Lisp_Object collection, Lisp_Object predicate) { @@ -1807,11 +1832,13 @@ is used to further constrain the set of candidates. */) } DEFUN ("all-completions", Fall_completions, Sall_completions, 2, 4, 0, - doc: /* Search for partial matches to STRING in COLLECTION. -Test each of the possible completions specified by COLLECTION + doc: /* Search for partial matches of STRING in COLLECTION. + +Test each possible completion specified by COLLECTION to see if it begins with STRING. The possible completions may be strings or symbols. Symbols are converted to strings before testing, -see `symbol-name'. +by using `symbol-name'. + The value is a list of all the possible completions that match STRING. If COLLECTION is an alist, the keys (cars of elements) are the @@ -1823,17 +1850,21 @@ If COLLECTION is an obarray, the names of all symbols in the obarray are the possible completions. COLLECTION can also be a function to do the completion itself. -It receives three arguments: the values STRING, PREDICATE and t. +It receives three arguments: STRING, PREDICATE and t. Whatever it returns becomes the value of `all-completions'. -If optional third argument PREDICATE is non-nil, -it is used to test each possible match. -The match is a candidate only if PREDICATE returns non-nil. -The argument given to PREDICATE is the alist element -or the symbol from the obarray. If COLLECTION is a hash-table, -predicate is called with two arguments: the key and the value. -Additionally to this predicate, `completion-regexp-list' -is used to further constrain the set of candidates. +If optional third argument PREDICATE is non-nil, it must be a function +of one or two arguments, and is used to test each possible completion. +A possible completion is accepted only if PREDICATE returns non-nil. + +The argument given to PREDICATE is either a string or a cons cell (whose +car is a string) from the alist, or a symbol from the obarray. +If COLLECTION is a hash-table, PREDICATE is called with two arguments: +the string key and the associated value. + +To be acceptable, a possible completion must also match all the regexps +in `completion-regexp-list' (unless COLLECTION is a function, in +which case that function should itself handle `completion-regexp-list'). An obsolete optional fourth argument HIDE-SPACES is still accepted for backward compatibility. If non-nil, strings in COLLECTION that start diff --git a/src/msdos.h b/src/msdos.h index 7e57c7c1102..24697bcf24b 100644 --- a/src/msdos.h +++ b/src/msdos.h @@ -22,6 +22,10 @@ along with GNU Emacs. If not, see . */ #include #include "termhooks.h" /* struct terminal */ +struct terminal; + +extern unsigned int _dos_commit(int); +#define tcdrain(f) _dos_commit(f) int dos_ttraw (struct tty_display_info *); int dos_ttcooked (void); @@ -57,6 +61,11 @@ ssize_t readlinkat (int, const char *, char *, size_t); int fstatat (int, char const *, struct stat *, int); int unsetenv (const char *); int faccessat (int, const char *, int, int); +int openat (int, const char *, int, int); +int fchmodat (int, const char *, mode_t, int); +int futimens (int, const struct timespec[2]); +int utimensat (int, const char *, const struct timespec[2], int); + void msdos_fatal_signal (int); void syms_of_msdos (void); int pthread_sigmask (int, const sigset_t *, sigset_t *); diff --git a/src/nsfns.m b/src/nsfns.m index 720ed3f88e5..a67dafe0950 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -891,7 +891,10 @@ Turn the input menu (an NSMenu) into a lisp list for tracking on lisp side. ns_appkit_version_str (void) { NSString *tmp; + Lisp_Object string; + NSAutoreleasePool *autorelease; + autorelease = [[NSAutoreleasePool alloc] init]; #ifdef NS_IMPL_GNUSTEP tmp = [NSString stringWithFormat:@"gnustep-gui-%s", Xstr(GNUSTEP_GUI_VERSION)]; #elif defined (NS_IMPL_COCOA) @@ -901,7 +904,10 @@ Turn the input menu (an NSMenu) into a lisp list for tracking on lisp side. #else tmp = [NSString initWithUTF8String:@"ns-unknown"]; #endif - return [tmp lispString]; + string = [tmp lispString]; + [autorelease release]; + + return string; } @@ -1587,26 +1593,22 @@ Frames are listed from topmost (first) to bottommost (last). */) } } -DEFUN ("ns-popup-font-panel", Fns_popup_font_panel, Sns_popup_font_panel, - 0, 1, "", - doc: /* Pop up the font panel. */) - (Lisp_Object frame) +DEFUN ("x-select-font", Fx_select_font, Sx_select_font, 0, 2, 0, + doc: /* Read a font using a Nextstep dialog. +Return a font specification describing the selected font. + +FRAME is the frame on which to pop up the font chooser. If omitted or +nil, it defaults to the selected frame. */) + (Lisp_Object frame, Lisp_Object ignored) { struct frame *f = decode_window_system_frame (frame); - id fm = [NSFontManager sharedFontManager]; - struct font *font = f->output_data.ns->font; - NSFont *nsfont; -#ifdef NS_IMPL_GNUSTEP - nsfont = ((struct nsfont_info *)font)->nsfont; -#endif -#ifdef NS_IMPL_COCOA - nsfont = (NSFont *) macfont_get_nsctfont (font); -#endif - [fm setSelectedFont: nsfont isMultiple: NO]; - [fm orderFrontFontPanel: NSApp]; - return Qnil; -} + Lisp_Object font = [FRAME_NS_VIEW (f) showFontPanel]; + if (NILP (font)) + quit (); + + return font; +} DEFUN ("ns-popup-color-panel", Fns_popup_color_panel, Sns_popup_color_panel, 0, 1, "", @@ -1675,16 +1677,18 @@ Frames are listed from topmost (first) to bottommost (last). */) BOOL isSave = NILP (mustmatch) && NILP (dir_only_p); id panel; Lisp_Object fname = Qnil; - - NSString *promptS = NILP (prompt) || !STRINGP (prompt) ? nil : - [NSString stringWithLispString:prompt]; - NSString *dirS = NILP (dir) || !STRINGP (dir) ? - [NSString stringWithLispString:BVAR (current_buffer, directory)] : - [NSString stringWithLispString:dir]; - NSString *initS = NILP (init) || !STRINGP (init) ? nil : - [NSString stringWithLispString:init]; + NSString *promptS, *dirS, *initS, *str; NSEvent *nxev; + promptS = (NILP (prompt) || !STRINGP (prompt) + ? nil : [NSString stringWithLispString: prompt]); + dirS = (NILP (dir) || !STRINGP (dir) + ? [NSString stringWithLispString: + ENCODE_FILE (BVAR (current_buffer, directory))] : + [NSString stringWithLispString: ENCODE_FILE (dir)]); + initS = (NILP (init) || !STRINGP (init) + ? nil : [NSString stringWithLispString: init]); + check_window_system (NULL); if (fileDelegate == nil) @@ -1756,9 +1760,15 @@ Frames are listed from topmost (first) to bottommost (last). */) if (ns_fd_data.ret == MODAL_OK_RESPONSE) { - NSString *str = ns_filename_from_panel (panel); - if (! str) str = ns_directory_from_panel (panel); - if (str) fname = [str lispString]; + str = ns_filename_from_panel (panel); + + if (!str) + str = ns_directory_from_panel (panel); + if (str) + fname = [str lispString]; + + if (!NILP (fname)) + fname = DECODE_FILE (fname); } [[FRAME_NS_VIEW (SELECTED_FRAME ()) window] makeKeyWindow]; @@ -2103,6 +2113,7 @@ Frames are listed from topmost (first) to bottommost (last). */) Lisp_Object list = Qnil; NSEnumerator *colorlists; NSColorList *clist; + NSAutoreleasePool *pool; if (!NILP (frame)) { @@ -2112,7 +2123,9 @@ Frames are listed from topmost (first) to bottommost (last). */) } block_input (); - + /* This can be called during dumping, so we need to set up a + temporary autorelease pool. */ + pool = [[NSAutoreleasePool alloc] init]; colorlists = [[NSColorList availableColorLists] objectEnumerator]; while ((clist = [colorlists nextObject])) { @@ -2123,12 +2136,9 @@ Frames are listed from topmost (first) to bottommost (last). */) NSString *cname; while ((cname = [cnames nextObject])) list = Fcons ([cname lispString], list); -/* for (i = [[clist allKeys] count] - 1; i >= 0; i--) - list = Fcons (build_string ([[[clist allKeys] objectAtIndex: i] - UTF8String]), list); */ } } - + [pool release]; unblock_input (); return list; @@ -2856,9 +2866,8 @@ Frames are listed from topmost (first) to bottommost (last). */) str = SSDATA (string); f = decode_window_system_frame (frame); if (NILP (timeout)) - timeout = make_fixnum (5); - else - CHECK_FIXNAT (timeout); + timeout = Vx_show_tooltip_timeout; + CHECK_FIXNAT (timeout); if (NILP (dx)) dx = make_fixnum (5); @@ -3294,7 +3303,7 @@ - (Lisp_Object)lispString defsubr (&Sns_emacs_info_panel); defsubr (&Sns_list_services); defsubr (&Sns_perform_service); - defsubr (&Sns_popup_font_panel); + defsubr (&Sx_select_font); defsubr (&Sns_popup_color_panel); defsubr (&Sx_show_tip); diff --git a/src/nsfont.m b/src/nsfont.m index f3c8a82930b..e913a50cb69 100644 --- a/src/nsfont.m +++ b/src/nsfont.m @@ -1176,15 +1176,15 @@ is false when (FROM > 0 || TO < S->nchars). */ face = s->face; - r.origin.x = s->x; + r.origin.x = x; if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) r.origin.x += max (s->face->box_vertical_line_width, 0); - r.origin.y = s->y; + r.origin.y = y; r.size.height = FONT_HEIGHT (font); - for (int i = from; i < to; ++i) - c[i] = s->char2b[i]; + for (int i = 0; i < len; ++i) + c[i] = s->char2b[i + from]; /* Fill background if requested. */ if (with_background && !isComposite) @@ -1210,8 +1210,6 @@ is false when (FROM > 0 || TO < S->nchars). */ } /* set up for character rendering */ - r.origin.y = y; - if (s->hl == DRAW_CURSOR) col = FRAME_BACKGROUND_COLOR (s->f); else @@ -1721,8 +1719,8 @@ is false when (FROM > 0 || TO < S->nchars). */ metrics->rbearing = lrint (rb); metrics->lbearing = lrint (lb); - metrics->descent = NSMinY (r); - metrics->ascent = NSMaxY (r); + metrics->descent = - NSMaxY (r); + metrics->ascent = - NSMinY (r); } unblock_input (); } diff --git a/src/nsmenu.m b/src/nsmenu.m index 81d7cd2da13..b0ab12bb87d 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -649,7 +649,8 @@ - (void)fillWithWidgetValue: (void *)wvptr work around it by using tabs to split the title into two columns. */ NSFont *menuFont = [NSFont menuFontOfSize:0]; - NSDictionary *font_attribs = @{NSFontAttributeName: menuFont}; + NSDictionary *font_attribs = [NSDictionary dictionaryWithObjectsAndKeys: + menuFont, NSFontAttributeName, nil]; CGFloat maxNameWidth = 0; CGFloat maxKeyWidth = 0; @@ -677,11 +678,12 @@ - (void)fillWithWidgetValue: (void *)wvptr NSTextTab *tab = [[[NSTextTab alloc] initWithTextAlignment: NSTextAlignmentRight location: maxWidth - options: @{}] autorelease]; + options: [NSDictionary dictionary]] autorelease]; NSMutableParagraphStyle *pstyle = [[[NSMutableParagraphStyle alloc] init] autorelease]; - [pstyle setTabStops: @[tab]]; - attributes = @{NSParagraphStyleAttributeName: pstyle}; + [pstyle setTabStops: [NSArray arrayWithObject:tab]]; + attributes = [NSDictionary dictionaryWithObjectsAndKeys: + pstyle, NSParagraphStyleAttributeName, nil]; #endif /* clear existing contents */ @@ -758,12 +760,6 @@ - (Lisp_Object)runMenuAt: (NSPoint)p forFrame: (struct frame *)f : Qnil; } -#ifdef NS_IMPL_GNUSTEP -/* The code below doesn't work on Mac OS X, because it runs a nested - Carbon-related event loop to track menu bar movement. - - But it works fine aside from that, so it will work on GNUstep if - they start to call `willHighlightItem'. */ - (void) menu: (NSMenu *) menu willHighlightItem: (NSMenuItem *) item { NSInteger idx = [item tag]; @@ -777,12 +773,11 @@ - (void) menu: (NSMenu *) menu willHighlightItem: (NSMenuItem *) item XSETFRAME (frame, f); help = AREF (vec, idx + MENU_ITEMS_ITEM_HELP); + popup_activated_flag++; if (STRINGP (help) || NILP (help)) - kbd_buffer_store_help_event (frame, help); - - raise (SIGIO); + show_help_echo (help, Qnil, Qnil, Qnil); + popup_activated_flag--; } -#endif #ifdef NS_IMPL_GNUSTEP - (void) close diff --git a/src/nsterm.h b/src/nsterm.h index f0276461231..9d8a6f486fc 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -442,23 +442,25 @@ typedef id instancetype; #else @interface EmacsView : NSView #endif - { +{ #ifdef NS_IMPL_COCOA - char *old_title; - BOOL maximizing_resize; + char *old_title; + BOOL maximizing_resize; #endif - BOOL windowClosing; - NSString *workingText; - BOOL processingCompose; - int fs_state, fs_before_fs, next_maximized; - int maximized_width, maximized_height; - EmacsWindow *nonfs_window; - BOOL fs_is_native; + BOOL font_panel_active; + NSFont *font_panel_result; + BOOL windowClosing; + NSString *workingText; + BOOL processingCompose; + int fs_state, fs_before_fs, next_maximized; + int maximized_width, maximized_height; + EmacsWindow *nonfs_window; + BOOL fs_is_native; @public - struct frame *emacsframe; - int scrollbarsNeedingUpdate; - NSRect ns_userRect; - } + struct frame *emacsframe; + int scrollbarsNeedingUpdate; + NSRect ns_userRect; +} /* AppKit-side interface */ - (instancetype)menuDown: (id)sender; @@ -485,9 +487,10 @@ typedef id instancetype; #ifdef NS_IMPL_GNUSTEP - (void)windowDidMove: (id)sender; #endif +- (Lisp_Object) showFontPanel; - (int)fullscreenState; -#ifdef NS_IMPL_COCOA +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400 - (void)lockFocus; - (void)unlockFocus; #endif @@ -698,7 +701,7 @@ typedef id instancetype; + (CGFloat)scrollerWidth; @end -#ifdef NS_IMPL_COCOA +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400 @interface EmacsLayer : CALayer { NSMutableArray *cache; @@ -1290,6 +1293,7 @@ extern char gnustep_base_version[]; /* version tracking */ #define NSAlertStyleCritical NSCriticalAlertStyle #define NSControlSizeRegular NSRegularControlSize #define NSCompositingOperationCopy NSCompositeCopy +#define NSTextAlignmentRight NSRightTextAlignment /* And adds NSWindowStyleMask. */ #ifdef __OBJC__ diff --git a/src/nsterm.m b/src/nsterm.m index fd56094c28b..fef7f0dc6c8 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -163,7 +163,7 @@ - (NSColor *)colorUsingDefaultColorSpace && NSAppKitVersionNumber >= NSAppKitVersionNumber10_7) return [self colorUsingColorSpace: [NSColorSpace sRGBColorSpace]]; #endif - return [self colorUsingColorSpace: [NSColorSpace deviceRGBColorSpace]]; + return [self colorUsingColorSpace: [NSColorSpace genericRGBColorSpace]]; } + (NSColor *)colorWithUnsignedLong:(unsigned long)c @@ -751,7 +751,18 @@ Free a pool and temporary objects it refers to (callable from C) EmacsView *parentView = FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)); parentRect = [parentView convertRect:[parentView frame] toView:nil]; + +#if defined (NS_IMPL_COCOA) && !defined (MAC_OS_X_VERSION_10_7) + parentRect.origin = [[parentView window] convertBaseToScreen:parentRect.origin]; +#elif defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED < 1070 + if ([[parentView window] + respondsToSelector:@selector(convertRectToScreen:)]) + parentRect = [[parentView window] convertRectToScreen:parentRect]; + else + parentRect.origin = [[parentView window] convertBaseToScreen:parentRect.origin]; +#else parentRect = [[parentView window] convertRectToScreen:parentRect]; +#endif } else parentRect = [[[NSScreen screens] objectAtIndex:0] frame]; @@ -788,10 +799,16 @@ Free a pool and temporary objects it refers to (callable from C) double ns_frame_scale_factor (struct frame *f) { -#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED > 1060 - return [[FRAME_NS_VIEW (f) window] backingScaleFactor]; -#else +#if defined (NS_IMPL_GNUSTEP) || !defined (MAC_OS_X_VERSION_10_7) return [[FRAME_NS_VIEW (f) window] userSpaceScaleFactor]; +#elif MAC_OS_X_VERSION_MIN_REQUIRED < 1070 + if ([[FRAME_NS_VIEW (f) window] + respondsToSelector:@selector(backingScaleFactor:)]) + return [[FRAME_NS_VIEW (f) window] backingScaleFactor]; + else + return [[FRAME_NS_VIEW (f) window] userSpaceScaleFactor]; +#else + return [[FRAME_NS_VIEW (f) window] backingScaleFactor]; #endif } @@ -1060,7 +1077,7 @@ static NSRect constrain_frame_rect(NSRect frameRect, bool isFullscreen) block_input (); [view unlockFocus]; -#if defined (NS_IMPL_GNUSTEP) +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 [[view window] flushWindow]; #endif @@ -1127,7 +1144,7 @@ static NSRect constrain_frame_rect(NSRect frameRect, bool isFullscreen) { EmacsView *view = FRAME_NS_VIEW (f); [view unlockFocus]; -#if defined (NS_IMPL_GNUSTEP) +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 [[view window] flushWindow]; #endif } @@ -2270,6 +2287,7 @@ Hide the window (X11 semantics) Lisp_Object frame, tail; struct frame *f = NULL; struct ns_display_info *dpyinfo; + bool return_no_frame_flag = false; NSTRACE ("ns_mouse_position"); @@ -2313,15 +2331,25 @@ Hide the window (X11 semantics) #endif if (!f) - f = dpyinfo->ns_focus_frame ? dpyinfo->ns_focus_frame : SELECTED_FRAME (); + { + f = (dpyinfo->ns_focus_frame + ? dpyinfo->ns_focus_frame : SELECTED_FRAME ()); + return_no_frame_flag = EQ (track_mouse, Qdrag_source); + } + + if (!FRAME_NS_P (f)) + f = NULL; /* While dropping, use the last mouse frame only if there is no currently focused frame. */ - if (!f - && EQ (track_mouse, Qdropping) + if (!f && (EQ (track_mouse, Qdropping) + || EQ (track_mouse, Qdrag_source)) && dpyinfo->last_mouse_frame && FRAME_LIVE_P (dpyinfo->last_mouse_frame)) - f = dpyinfo->last_mouse_frame; + { + f = dpyinfo->last_mouse_frame; + return_no_frame_flag = EQ (track_mouse, Qdrag_source); + } if (f && FRAME_NS_P (f)) { @@ -2340,7 +2368,7 @@ Hide the window (X11 semantics) if (y) XSETINT (*y, lrint (view_position.y)); if (time) *time = dpyinfo->last_mouse_movement_time; - *fp = f; + *fp = return_no_frame_flag ? NULL : f; } unblock_input (); @@ -3934,6 +3962,81 @@ Function modeled after x_draw_glyph_string_box (). } } +/* Draw the foreground of glyph string S for glyphless characters. */ +static void +ns_draw_glyphless_glyph_string_foreground (struct glyph_string *s) +{ + struct glyph *glyph = s->first_glyph; + NSGlyph char2b[8]; + int x, i, j; + + /* If first glyph of S has a left box line, start drawing the text + of S to the right of that box line. */ + if (s->face && s->face->box != FACE_NO_BOX + && s->first_glyph->left_box_line_p) + x = s->x + max (s->face->box_vertical_line_width, 0); + else + x = s->x; + + s->char2b = char2b; + + for (i = 0; i < s->nchars; i++, glyph++) + { + char buf[7]; + char *str = NULL; + int len = glyph->u.glyphless.len; + + if (glyph->u.glyphless.method == GLYPHLESS_DISPLAY_ACRONYM) + { + if (len > 0 + && CHAR_TABLE_P (Vglyphless_char_display) + && (CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (Vglyphless_char_display)) + >= 1)) + { + Lisp_Object acronym + = (! glyph->u.glyphless.for_no_font + ? CHAR_TABLE_REF (Vglyphless_char_display, + glyph->u.glyphless.ch) + : XCHAR_TABLE (Vglyphless_char_display)->extras[0]); + if (STRINGP (acronym)) + str = SSDATA (acronym); + } + } + else if (glyph->u.glyphless.method == GLYPHLESS_DISPLAY_HEX_CODE) + { + unsigned int ch = glyph->u.glyphless.ch; + eassume (ch <= MAX_CHAR); + sprintf (buf, "%0*X", ch < 0x10000 ? 4 : 6, ch); + str = buf; + } + + if (str) + { + int upper_len = (len + 1) / 2; + + /* It is assured that all LEN characters in STR is ASCII. */ + for (j = 0; j < len; j++) + char2b[j] = s->font->driver->encode_char (s->font, str[j]) & 0xFFFF; + s->font->driver->draw (s, 0, upper_len, + x + glyph->slice.glyphless.upper_xoff, + s->ybase + glyph->slice.glyphless.upper_yoff, + false); + s->font->driver->draw (s, upper_len, len, + x + glyph->slice.glyphless.lower_xoff, + s->ybase + glyph->slice.glyphless.lower_yoff, + false); + } + if (glyph->u.glyphless.method != GLYPHLESS_DISPLAY_THIN_SPACE) + ns_draw_box (NSMakeRect (x, s->ybase - glyph->ascent, + glyph->pixel_width - 1, + glyph->ascent + glyph->descent - 1), + 1, 1, + [NSColor colorWithUnsignedLong:NS_FACE_FOREGROUND (s->face)], + YES, YES); + x += glyph->pixel_width; + } +} + static void ns_draw_glyph_string (struct glyph_string *s) /* -------------------------------------------------------------------------- @@ -4047,9 +4150,7 @@ Function modeled after x_draw_glyph_string_box (). else ns_maybe_dumpglyphs_background (s, s->first_glyph->type == COMPOSITE_GLYPH); - /* ... */ - /* Not yet implemented. */ - /* ... */ + ns_draw_glyphless_glyph_string_foreground (s); break; default: @@ -4341,10 +4442,10 @@ in certain situations (rapid incoming events). } -int -ns_select (int nfds, fd_set *readfds, fd_set *writefds, - fd_set *exceptfds, struct timespec *timeout, - sigset_t *sigmask) +static int +ns_select_1 (int nfds, fd_set *readfds, fd_set *writefds, + fd_set *exceptfds, struct timespec *timeout, + sigset_t *sigmask, BOOL run_loop_only) /* -------------------------------------------------------------------------- Replacement for select, checking for events -------------------------------------------------------------------------- */ @@ -4360,7 +4461,7 @@ in certain situations (rapid incoming events). check_native_fs (); #endif - if (hold_event_q.nr > 0) + if (hold_event_q.nr > 0 && !run_loop_only) { /* We already have events pending. */ raise (SIGIO); @@ -4378,12 +4479,12 @@ in certain situations (rapid incoming events). if (NSApp == nil || ![NSThread isMainThread] || (timeout && timeout->tv_sec == 0 && timeout->tv_nsec == 0)) - return thread_select(pselect, nfds, readfds, writefds, - exceptfds, timeout, sigmask); + return thread_select (pselect, nfds, readfds, writefds, + exceptfds, timeout, sigmask); else { struct timespec t = {0, 0}; - thread_select(pselect, 0, NULL, NULL, NULL, &t, sigmask); + thread_select (pselect, 0, NULL, NULL, NULL, &t, sigmask); } /* FIXME: This draining of outerpool causes a crash when a buffer @@ -4501,6 +4602,15 @@ in certain situations (rapid incoming events). return result; } +int +ns_select (int nfds, fd_set *readfds, fd_set *writefds, + fd_set *exceptfds, struct timespec *timeout, + sigset_t *sigmask) +{ + return ns_select_1 (nfds, readfds, writefds, exceptfds, + timeout, sigmask, NO); +} + #ifdef HAVE_PTHREAD void ns_run_loop_break (void) @@ -5320,20 +5430,21 @@ Needs to be here because ns_initialize_display_info () uses AppKit classes. void ns_term_shutdown (int sig) { + NSAutoreleasePool *pool; + /* We also need an autorelease pool here, since this can be called + during dumping. */ + pool = [[NSAutoreleasePool alloc] init]; [[NSUserDefaults standardUserDefaults] synchronize]; + [pool release]; /* code not reached in emacs.c after this is called by shut_down_emacs: */ if (STRINGP (Vauto_save_list_file_name)) unlink (SSDATA (Vauto_save_list_file_name)); if (sig == 0 || sig == SIGTERM) - { - [NSApp terminate: NSApp]; - } - else // force a stack trace to happen - { - emacs_abort (); - } + [NSApp terminate: NSApp]; + else /* Force a stack trace to happen. */ + emacs_abort (); } @@ -5944,6 +6055,123 @@ - (BOOL)fulfillService: (NSString *)name withArg: (NSString *)arg @end /* EmacsApp */ +static Lisp_Object +ns_font_desc_to_font_spec (NSFontDescriptor *desc, NSFont *font) +{ + NSFontSymbolicTraits traits = [desc symbolicTraits]; + NSDictionary *dict = [desc objectForKey: NSFontTraitsAttribute]; + NSString *family = [font familyName]; + Lisp_Object lwidth, lslant, lweight, lheight; + NSNumber *tem; + + lwidth = Qnil; + lslant = Qnil; + lweight = Qnil; + lheight = Qnil; + + if (traits & NSFontBoldTrait) + lweight = Qbold; + + if (traits & NSFontItalicTrait) + lslant = Qitalic; + + if (traits & NSFontCondensedTrait) + lwidth = Qcondensed; + else if (traits & NSFontExpandedTrait) + lwidth = Qexpanded; + + if (dict != nil) + { + tem = [dict objectForKey: NSFontSlantTrait]; + + if (tem != nil) + lslant = ([tem floatValue] > 0 + ? Qitalic : ([tem floatValue] < 0 + ? Qreverse_italic + : Qnormal)); + + tem = [dict objectForKey: NSFontWeightTrait]; + +#ifdef NS_IMPL_GNUSTEP + if (tem != nil) + lweight = ([tem floatValue] > 0 + ? Qbold : ([tem floatValue] < -0.4f + ? Qlight : Qnormal)); +#else + if (tem != nil) + { + if ([tem floatValue] >= 0.4) + lweight = Qbold; + else if ([tem floatValue] >= 0.24) + lweight = Qmedium; + else if ([tem floatValue] >= 0) + lweight = Qnormal; + else if ([tem floatValue] >= -0.24) + lweight = Qsemi_light; + else + lweight = Qlight; + } +#endif + + tem = [dict objectForKey: NSFontWidthTrait]; + + if (tem != nil) + lwidth = ([tem floatValue] > 0 + ? Qexpanded : ([tem floatValue] < 0 + ? Qcondensed : Qnormal)); + } + + lheight = make_float ([font pointSize]); + + return CALLN (Ffont_spec, + QCwidth, lwidth, QCslant, lslant, + QCweight, lweight, QCsize, lheight, + QCfamily, (family + ? [family lispString] + : Qnil)); +} + +#ifdef NS_IMPL_COCOA +static NSView * +ns_create_font_panel_buttons (id target, SEL select, SEL cancel_action) +{ + NSMatrix *matrix; + NSButtonCell *prototype; + NSSize cell_size; + NSRect frame; + NSButtonCell *cancel, *ok; + + prototype = [[NSButtonCell alloc] init]; + [prototype setBezelStyle: NSBezelStyleRounded]; + [prototype setTitle: @"Cancel"]; + cell_size = [prototype cellSize]; + frame = NSMakeRect (0, 0, cell_size.width * 2, + cell_size.height); + matrix = [[NSMatrix alloc] initWithFrame: frame + mode: NSTrackModeMatrix + prototype: prototype + numberOfRows: 1 + numberOfColumns: 2]; + [prototype release]; + + ok = (NSButtonCell *) [matrix cellAtRow: 0 column: 0]; + cancel = (NSButtonCell *) [matrix cellAtRow: 0 column: 1]; + + [ok setTitle: @"OK"]; + [ok setTarget: target]; + [ok setAction: select]; + [ok setButtonType: NSButtonTypeMomentaryPushIn]; + + [cancel setTitle: @"Cancel"]; + [cancel setTarget: target]; + [cancel setAction: cancel_action]; + [cancel setButtonType: NSButtonTypeMomentaryPushIn]; + + [matrix selectCell: ok]; + + return matrix; +} +#endif /* ========================================================================== @@ -5980,40 +6208,129 @@ - (void)dealloc /* Called on font panel selection. */ -- (void)changeFont: (id)sender +- (void) changeFont: (id) sender { - struct face *face = FACE_FROM_ID (emacsframe, DEFAULT_FACE_ID); - struct font *font = face->font; - id newFont; - CGFloat size; + struct font *font = FRAME_OUTPUT_DATA (emacsframe)->font; NSFont *nsfont; - struct input_event ie; - - NSTRACE ("[EmacsView changeFont:]"); - EVENT_INIT (ie); #ifdef NS_IMPL_GNUSTEP - nsfont = ((struct nsfont_info *)font)->nsfont; -#endif -#ifdef NS_IMPL_COCOA + nsfont = ((struct nsfont_info *) font)->nsfont; +#else nsfont = (NSFont *) macfont_get_nsctfont (font); #endif - if ((newFont = [sender convertFont: nsfont])) - { - ie.kind = NS_NONKEY_EVENT; - ie.modifiers = 0; - ie.code = KEY_NS_CHANGE_FONT; - XSETFRAME (ie.frame_or_window, emacsframe); + if (!font_panel_active) + return; - size = [newFont pointSize]; - ns_input_fontsize = make_fixnum (lrint (size)); - ns_input_font = [[newFont familyName] lispString]; + if (font_panel_result) + [font_panel_result release]; - kbd_buffer_store_event (&ie); - } + font_panel_result = (NSFont *) [sender convertFont: nsfont]; + + if (font_panel_result) + [font_panel_result retain]; + +#ifndef NS_IMPL_COCOA + font_panel_active = NO; + [NSApp stop: self]; +#endif } +#ifdef NS_IMPL_COCOA +- (void) noteUserSelectedFont +{ + font_panel_active = NO; + + /* If no font was previously selected, use the currently selected + font. */ + + if (!font_panel_result && FRAME_FONT (emacsframe)) + { + font_panel_result + = macfont_get_nsctfont (FRAME_FONT (emacsframe)); + + if (font_panel_result) + [font_panel_result retain]; + } + + [NSApp stop: self]; +} + +- (void) noteUserCancelledSelection +{ + font_panel_active = NO; + + if (font_panel_result) + [font_panel_result release]; + font_panel_result = nil; + + [NSApp stop: self]; +} +#endif + +- (Lisp_Object) showFontPanel +{ + id fm = [NSFontManager sharedFontManager]; + struct font *font = FRAME_OUTPUT_DATA (emacsframe)->font; + NSFont *nsfont, *result; + struct timespec timeout; +#ifdef NS_IMPL_COCOA + NSView *buttons; + BOOL canceled; +#endif + +#ifdef NS_IMPL_GNUSTEP + nsfont = ((struct nsfont_info *) font)->nsfont; +#else + nsfont = (NSFont *) macfont_get_nsctfont (font); +#endif + +#ifdef NS_IMPL_COCOA + buttons + = ns_create_font_panel_buttons (self, + @selector (noteUserSelectedFont), + @selector (noteUserCancelledSelection)); + [[fm fontPanel: YES] setAccessoryView: buttons]; + [buttons release]; +#endif + + [fm setSelectedFont: nsfont isMultiple: NO]; + [fm orderFrontFontPanel: NSApp]; + + font_panel_active = YES; + timeout = make_timespec (0, 100000000); + + block_input (); + while (font_panel_active +#ifdef NS_IMPL_COCOA + && (canceled = [[fm fontPanel: YES] isVisible]) +#else + && [[fm fontPanel: YES] isVisible] +#endif + ) + ns_select_1 (0, NULL, NULL, NULL, &timeout, NULL, YES); + unblock_input (); + + if (font_panel_result) + [font_panel_result autorelease]; + +#ifdef NS_IMPL_COCOA + if (!canceled) + font_panel_result = nil; +#endif + + result = font_panel_result; + font_panel_result = nil; + + [[fm fontPanel: YES] setIsVisible: NO]; + font_panel_active = NO; + + if (result) + return ns_font_desc_to_font_spec ([result fontDescriptor], + result); + + return Qnil; +} - (BOOL)acceptsFirstResponder { @@ -6021,7 +6338,6 @@ - (BOOL)acceptsFirstResponder return YES; } - - (void)resetCursorRects { NSRect visible = [self visibleRect]; @@ -6858,7 +7174,7 @@ - (void)otherMouseDragged: (NSEvent *)e [self mouseMoved: e]; } -#ifdef NS_IMPL_COCOA +#if defined NS_IMPL_COCOA && defined MAC_OS_X_VERSION_10_7 - (void) magnifyWithEvent: (NSEvent *) event { NSPoint pt = [self convertPoint: [event locationInWindow] fromView: nil]; @@ -7197,7 +7513,7 @@ - (instancetype) initFrameFromEmacs: (struct frame *)f [[EmacsWindow alloc] initWithEmacsFrame:f]; -#ifdef NS_IMPL_COCOA +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400 /* These settings mean AppKit will retain the contents of the frame on resize. Unfortunately it also means the frame will not be automatically marked for display, but we can do that ourselves in @@ -7861,8 +8177,8 @@ - (instancetype)toggleToolbar: (id)sender } -#ifdef NS_IMPL_COCOA -- (CALayer *)makeBackingLayer; +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400 +- (CALayer *)makeBackingLayer { EmacsLayer *l = [[EmacsLayer alloc] initWithColorSpace:[[[self window] colorSpace] CGColorSpace]]; @@ -7877,19 +8193,12 @@ - (void)lockFocus { NSTRACE ("[EmacsView lockFocus]"); - if ([self wantsLayer]) - { - CGContextRef context = [(EmacsLayer*)[self layer] getContext]; + CGContextRef context = [(EmacsLayer*)[self layer] getContext]; - [NSGraphicsContext + [NSGraphicsContext setCurrentContext:[NSGraphicsContext graphicsContextWithCGContext:context flipped:YES]]; - } -#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 - else - [super lockFocus]; -#endif } @@ -7897,18 +8206,8 @@ - (void)unlockFocus { NSTRACE ("[EmacsView unlockFocus]"); - if ([self wantsLayer]) - { - [NSGraphicsContext setCurrentContext:nil]; - [self setNeedsDisplay:YES]; - } -#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 - else - { - [super unlockFocus]; - [super flushWindow]; - } -#endif + [NSGraphicsContext setCurrentContext:nil]; + [self setNeedsDisplay:YES]; } @@ -7917,19 +8216,16 @@ - (void)windowDidChangeBackingProperties:(NSNotification *)notification { NSTRACE ("EmacsView windowDidChangeBackingProperties:]"); - if ([self wantsLayer]) - { - NSRect frame = [self frame]; - EmacsLayer *layer = (EmacsLayer *)[self layer]; + NSRect frame = [self frame]; + EmacsLayer *layer = (EmacsLayer *)[self layer]; - [layer setContentsScale:[[notification object] backingScaleFactor]]; - [layer setColorSpace:[[[notification object] colorSpace] CGColorSpace]]; + [layer setContentsScale:[[notification object] backingScaleFactor]]; + [layer setColorSpace:[[[notification object] colorSpace] CGColorSpace]]; - ns_clear_frame (emacsframe); - expose_frame (emacsframe, 0, 0, NSWidth (frame), NSHeight (frame)); - } + ns_clear_frame (emacsframe); + expose_frame (emacsframe, 0, 0, NSWidth (frame), NSHeight (frame)); } -#endif /* NS_IMPL_COCOA */ +#endif - (void)copyRect:(NSRect)srcRect to:(NSPoint)dest @@ -7941,57 +8237,45 @@ - (void)copyRect:(NSRect)srcRect to:(NSPoint)dest NSRect dstRect = NSMakeRect (dest.x, dest.y, NSWidth (srcRect), NSHeight (srcRect)); -#ifdef NS_IMPL_COCOA - if ([self wantsLayer]) - { - double scale = [[self window] backingScaleFactor]; - CGContextRef context = [(EmacsLayer *)[self layer] getContext]; - int bpp = CGBitmapContextGetBitsPerPixel (context) / 8; - void *pixels = CGBitmapContextGetData (context); - int rowSize = CGBitmapContextGetBytesPerRow (context); - int srcRowSize = NSWidth (srcRect) * scale * bpp; - void *srcPixels = (char *) pixels - + (int) (NSMinY (srcRect) * scale * rowSize - + NSMinX (srcRect) * scale * bpp); - void *dstPixels = (char *) pixels - + (int) (dest.y * scale * rowSize - + dest.x * scale * bpp); +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400 + double scale = [[self window] backingScaleFactor]; + CGContextRef context = [(EmacsLayer *)[self layer] getContext]; + int bpp = CGBitmapContextGetBitsPerPixel (context) / 8; + void *pixels = CGBitmapContextGetData (context); + int rowSize = CGBitmapContextGetBytesPerRow (context); + int srcRowSize = NSWidth (srcRect) * scale * bpp; + void *srcPixels = (char *) pixels + + (int) (NSMinY (srcRect) * scale * rowSize + + NSMinX (srcRect) * scale * bpp); + void *dstPixels = (char *) pixels + + (int) (dest.y * scale * rowSize + + dest.x * scale * bpp); - if (NSIntersectsRect (srcRect, dstRect) - && NSMinY (srcRect) < NSMinY (dstRect)) - for (int y = NSHeight (srcRect) * scale - 1 ; y >= 0 ; y--) - memmove ((char *) dstPixels + y * rowSize, - (char *) srcPixels + y * rowSize, - srcRowSize); - else - for (int y = 0 ; y < NSHeight (srcRect) * scale ; y++) - memmove ((char *) dstPixels + y * rowSize, - (char *) srcPixels + y * rowSize, - srcRowSize); - - } -#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if (NSIntersectsRect (srcRect, dstRect) + && NSMinY (srcRect) < NSMinY (dstRect)) + for (int y = NSHeight (srcRect) * scale - 1 ; y >= 0 ; y--) + memmove ((char *) dstPixels + y * rowSize, + (char *) srcPixels + y * rowSize, + srcRowSize); else - { -#endif -#endif /* NS_IMPL_COCOA */ + for (int y = 0 ; y < NSHeight (srcRect) * scale ; y++) + memmove ((char *) dstPixels + y * rowSize, + (char *) srcPixels + y * rowSize, + srcRowSize); -#if !defined (NS_IMPL_COCOA) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 - hide_bell(); // Ensure the bell image isn't scrolled. +#else + hide_bell(); // Ensure the bell image isn't scrolled. - ns_focus (emacsframe, &dstRect, 1); - [self scrollRect: srcRect - by: NSMakeSize (dstRect.origin.x - srcRect.origin.x, - dstRect.origin.y - srcRect.origin.y)]; - ns_unfocus (emacsframe); -#endif -#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400 - } + ns_focus (emacsframe, &dstRect, 1); + [self scrollRect: srcRect + by: NSMakeSize (dstRect.origin.x - srcRect.origin.x, + dstRect.origin.y - srcRect.origin.y)]; + ns_unfocus (emacsframe); #endif } -#ifdef NS_IMPL_COCOA +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400 /* If the frame has been garbaged but the toolkit wants to draw, for example when resizing the frame, we end up with a blank screen. Sometimes this results in an unpleasant flicker, so try to @@ -8056,6 +8340,37 @@ -(BOOL)prepareForDragOperation: (id ) sender return YES; } +- (BOOL) wantsPeriodicDraggingUpdates +{ + return YES; +} + +- (NSDragOperation) draggingUpdated: (id ) sender +{ + struct input_event ie; + NSPoint position; + int x, y; + + EVENT_INIT (ie); + ie.kind = DRAG_N_DROP_EVENT; + + /* Get rid of mouse face. */ + [self mouseExited: [[self window] currentEvent]]; + + position = [self convertPoint: [sender draggingLocation] + fromView: nil]; + x = lrint (position.x); + y = lrint (position.y); + + XSETINT (ie.x, x); + XSETINT (ie.y, y); + XSETFRAME (ie.frame_or_window, emacsframe); + ie.arg = Qlambda; + ie.modifiers = 0; + + kbd_buffer_store_event (&ie); + return NSDragOperationGeneric; +} -(BOOL)performDragOperation: (id ) sender { @@ -8442,7 +8757,7 @@ - (void)setParentChildRelationships expected later. */ #if MAC_OS_X_VERSION_MIN_REQUIRED < 101000 - if ([child respondsToSelector:@selector(setAccessibilitySubrole:)]) + if ([self respondsToSelector:@selector(setAccessibilitySubrole:)]) #endif /* Set the accessibility subroles. */ if (parentFrame) @@ -8474,7 +8789,7 @@ - (void)setParentChildRelationships #ifdef NS_IMPL_COCOA #if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 - if ([ourView respondsToSelector:@selector (toggleFullScreen)] + if ([ourView respondsToSelector:@selector (toggleFullScreen)]) #endif /* If we are the descendent of a fullscreen window and we have no new parent, go fullscreen. */ @@ -8499,11 +8814,11 @@ - (void)setParentChildRelationships #ifdef NS_IMPL_COCOA #if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 - if ([ourView respondsToSelector:@selector (toggleFullScreen)] + if ([ourView respondsToSelector:@selector (toggleFullScreen)]) #endif - /* Child frames must not be fullscreen. */ - if ([ourView fsIsNative] && [ourView isFullscreen]) - [ourView toggleFullScreen:self]; + /* Child frames must not be fullscreen. */ + if ([ourView fsIsNative] && [ourView isFullscreen]) + [ourView toggleFullScreen:self]; #endif [parentWindow addChildWindow:self @@ -9435,7 +9750,7 @@ - (void) scrollWheel: (NSEvent *)theEvent @end /* EmacsScroller */ -#ifdef NS_IMPL_COCOA +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400 /* ========================================================================== @@ -10062,6 +10377,9 @@ Nil means use fullscreen the old (< 10.7) way. The old way works better with DEFSYM (QCordinary, ":ordinary"); DEFSYM (QCfunction, ":function"); DEFSYM (QCmouse, ":mouse"); + DEFSYM (Qcondensed, "condensed"); + DEFSYM (Qreverse_italic, "reverse-italic"); + DEFSYM (Qexpanded, "expanded"); #ifdef NS_IMPL_COCOA Fprovide (Qcocoa, Qnil); diff --git a/src/pdumper.c b/src/pdumper.c index f14239f863a..5923d9b1d82 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -36,7 +36,6 @@ along with GNU Emacs. If not, see . */ #include "coding.h" #include "fingerprint.h" #include "frame.h" -#include "getpagesize.h" #include "intervals.h" #include "lisp.h" #include "pdumper.h" @@ -163,7 +162,7 @@ ptrdiff_t_to_dump_off (ptrdiff_t value) /* Worst-case allocation granularity on any system that might load this dump. */ static int -dump_get_page_size (void) +dump_get_max_page_size (void) { return 64 * 1024; } @@ -2854,7 +2853,7 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_F09D8E8E19) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_20B7443AD7) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2877,12 +2876,14 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_remember_cold_op (ctx, COLD_OP_NATIVE_SUBR, make_lisp_ptr ((void *) subr, Lisp_Vectorlike)); - dump_field_lv (ctx, &out, subr, &subr->native_intspec, WEIGHT_NORMAL); + dump_field_lv (ctx, &out, subr, &subr->intspec.native, WEIGHT_NORMAL); + dump_field_lv (ctx, &out, subr, &subr->command_modes, WEIGHT_NORMAL); } else { dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); - dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); + dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec.string); + dump_field_emacs_ptr (ctx, &out, subr, &subr->command_modes); } DUMP_FIELD_COPY (&out, subr, doc); #ifdef HAVE_NATIVE_COMP @@ -4209,7 +4210,7 @@ types. */) eassert (dump_queue_empty_p (&ctx->dump_queue)); dump_off discardable_end = ctx->offset; - dump_align_output (ctx, dump_get_page_size ()); + dump_align_output (ctx, dump_get_max_page_size ()); ctx->header.cold_start = ctx->offset; /* Start the cold section. This section contains bytes that should @@ -4927,7 +4928,7 @@ dump_mmap_contiguous (struct dump_memory_map *maps, int nr_maps) return true; size_t total_size = 0; - int worst_case_page_size = dump_get_page_size (); + int worst_case_page_size = dump_get_max_page_size (); for (int i = 0; i < nr_maps; ++i) { @@ -5615,7 +5616,7 @@ pdumper_load (const char *dump_filename, char *argv0) err = PDUMPER_LOAD_OOM; adj_discardable_start = header->discardable_start; - dump_page_size = dump_get_page_size (); + dump_page_size = dump_get_max_page_size (); /* Snap to next page boundary. */ adj_discardable_start = ROUNDUP (adj_discardable_start, dump_page_size); eassert (adj_discardable_start % dump_page_size == 0); diff --git a/src/pgtkfns.c b/src/pgtkfns.c index dd2e305965a..a0fcf70f31b 100644 --- a/src/pgtkfns.c +++ b/src/pgtkfns.c @@ -38,13 +38,6 @@ along with GNU Emacs. If not, see . */ #include "xsettings.h" #include "atimer.h" - -#ifdef HAVE_PGTK - -/* Static variables to handle applescript execution. */ -static Lisp_Object as_script, *as_result; -static int as_status; - static ptrdiff_t image_cache_refcount; static int x_decode_color (struct frame *f, Lisp_Object color_name, @@ -184,7 +177,7 @@ pgtk_display_info_for_name (Lisp_Object name) static void -x_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +pgtk_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { unsigned long fg, old_fg; @@ -211,7 +204,7 @@ x_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) static void -x_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +pgtk_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { unsigned long bg; @@ -253,7 +246,7 @@ pgtk_set_alpha_background (struct frame *f, Lisp_Object arg, Lisp_Object oldval) } static void -x_set_border_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +pgtk_set_border_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { int pix; @@ -264,7 +257,7 @@ x_set_border_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) } static void -x_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +pgtk_set_cursor_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { unsigned long fore_pixel, pixel; struct pgtk_output *x = f->output_data.pgtk; @@ -367,7 +360,8 @@ pgtk_set_name (struct frame *f, Lisp_Object name, int explicit) specified a name for the frame; the name will override any set by the redisplay code. */ static void -x_explicitly_set_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +pgtk_explicitly_set_name (struct frame *f, Lisp_Object arg, + Lisp_Object oldval) { pgtk_set_name (f, arg, true); } @@ -388,7 +382,7 @@ pgtk_implicitly_set_name (struct frame *f, Lisp_Object arg, If NAME is nil, use the frame name as the title. */ static void -x_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name) +pgtk_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name) { /* Don't change the title if it's already NAME. */ if (EQ (name, f->title)) @@ -414,7 +408,7 @@ pgtk_set_doc_edited (void) static void -x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +pgtk_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) { int nlines; /* Right now, menu bars don't work properly in minibuf-only frames; @@ -460,7 +454,7 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) The frame's height doesn't change. */ static void -x_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +pgtk_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) { int nlines; @@ -474,13 +468,12 @@ x_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) else nlines = 0; - x_change_tab_bar_height (f, nlines * FRAME_LINE_HEIGHT (f)); + pgtk_change_tab_bar_height (f, nlines * FRAME_LINE_HEIGHT (f)); } - /* Set the pixel height of the tab bar of frame F to HEIGHT. */ void -x_change_tab_bar_height (struct frame *f, int height) +pgtk_change_tab_bar_height (struct frame *f, int height) { int unit = FRAME_LINE_HEIGHT (f); int old_height = FRAME_TAB_BAR_HEIGHT (f); @@ -552,7 +545,7 @@ x_change_tool_bar_height (struct frame *f, int height) /* Toolbar support. */ static void -x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) +pgtk_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) { int nlines; @@ -571,7 +564,7 @@ x_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) } static void -x_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +pgtk_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { int border = check_int_nonnegative (arg); @@ -585,12 +578,11 @@ x_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object ol pgtk_clear_under_internal_border (f); } } - } static void -x_set_internal_border_width (struct frame *f, Lisp_Object arg, - Lisp_Object oldval) +pgtk_set_internal_border_width (struct frame *f, Lisp_Object arg, + Lisp_Object oldval) { int border = check_int_nonnegative (arg); @@ -607,7 +599,7 @@ x_set_internal_border_width (struct frame *f, Lisp_Object arg, } static void -x_set_icon_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +pgtk_set_icon_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { bool result; @@ -637,7 +629,7 @@ x_set_icon_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) } static void -x_set_icon_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +pgtk_set_icon_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { bool result; @@ -668,34 +660,19 @@ x_set_icon_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) unblock_input (); } -/* This is the same as the xfns.c definition. */ static void -x_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +pgtk_set_cursor_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { set_frame_cursor_types (f, arg); } -/* called to set mouse pointer color, but all other terms use it to - initialize pointer types (and don't set the color ;) */ static void -x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +pgtk_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { } -/** - * x_set_undecorated: - * - * Set frame F's `undecorated' parameter. If non-nil, F's window-system - * window is drawn without decorations, title, minimize/maximize boxes - * and external borders. This usually means that the window cannot be - * dragged, resized, iconified, maximized or deleted with the mouse. If - * nil, draw the frame with all the elements listed above unless these - * have been suspended via window manager settings. - * - * Some window managers may not honor this parameter. - */ static void -x_set_undecorated (struct frame *f, Lisp_Object new_value, +pgtk_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) { if (!EQ (new_value, old_value)) @@ -705,18 +682,8 @@ x_set_undecorated (struct frame *f, Lisp_Object new_value, } } -/** - * x_set_skip_taskbar: - * - * Set frame F's `skip-taskbar' parameter. If non-nil, this should - * remove F's icon from the taskbar associated with the display of F's - * window-system window and inhibit switching to F's window via - * -. If nil, lift these restrictions. - * - * Some window managers may not honor this parameter. - */ static void -x_set_skip_taskbar (struct frame *f, Lisp_Object new_value, +pgtk_set_skip_taskbar (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) { if (!EQ (new_value, old_value)) @@ -726,18 +693,9 @@ x_set_skip_taskbar (struct frame *f, Lisp_Object new_value, } } -/** - * x_set_override_redirect: - * - * Set frame F's `override_redirect' parameter which, if non-nil, hints - * that the window manager doesn't want to deal with F. Usually, such - * frames have no decorations and always appear on top of all frames. - * - * Some window managers may not honor this parameter. - */ static void -x_set_override_redirect (struct frame *f, Lisp_Object new_value, - Lisp_Object old_value) +pgtk_set_override_redirect (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) { if (!EQ (new_value, old_value)) { @@ -752,9 +710,7 @@ x_set_override_redirect (struct frame *f, Lisp_Object new_value, } } -/* Set icon from FILE for frame F. By using GTK functions the icon - may be any format that GdkPixbuf knows about, i.e. not just bitmaps. */ - +/* Set icon from FILE for frame F. */ bool xg_set_icon (struct frame *f, Lisp_Object file) { @@ -976,59 +932,58 @@ unless TYPE is `png'. */) return pgtk_cr_export_frames (frames, surface_type); } - -/* Note: see frame.c for template, also where generic functions are impl */ -frame_parm_handler pgtk_frame_parm_handlers[] = { - gui_set_autoraise, /* generic OK */ - gui_set_autolower, /* generic OK */ - x_set_background_color, - x_set_border_color, - gui_set_border_width, - x_set_cursor_color, - x_set_cursor_type, - gui_set_font, /* generic OK */ - x_set_foreground_color, - x_set_icon_name, - x_set_icon_type, - x_set_child_frame_border_width, - x_set_internal_border_width, /* generic OK */ - gui_set_right_divider_width, - gui_set_bottom_divider_width, - x_set_menu_bar_lines, - x_set_mouse_color, - x_explicitly_set_name, - gui_set_scroll_bar_width, /* generic OK */ - gui_set_scroll_bar_height, /* generic OK */ - x_set_title, - gui_set_unsplittable, /* generic OK */ - gui_set_vertical_scroll_bars, /* generic OK */ - gui_set_horizontal_scroll_bars, /* generic OK */ - gui_set_visibility, /* generic OK */ - x_set_tab_bar_lines, - x_set_tool_bar_lines, - pgtk_set_scroll_bar_foreground, - pgtk_set_scroll_bar_background, - gui_set_screen_gamma, /* generic OK */ - gui_set_line_spacing, /* generic OK, sets f->extra_line_spacing to int */ - gui_set_left_fringe, /* generic OK */ - gui_set_right_fringe, /* generic OK */ - 0, /* x_set_wait_for_wm */ - gui_set_fullscreen, /* generic OK */ - gui_set_font_backend, /* generic OK */ - gui_set_alpha, - pgtk_set_sticky, - pgtk_set_tool_bar_position, - 0, /* x_set_inhibit_double_buffering */ - x_set_undecorated, - x_set_parent_frame, - x_set_skip_taskbar, - x_set_no_focus_on_map, - x_set_no_accept_focus, - x_set_z_group, - x_set_override_redirect, - gui_set_no_special_glyphs, - pgtk_set_alpha_background, -}; +frame_parm_handler pgtk_frame_parm_handlers[] = + { + gui_set_autoraise, /* generic OK */ + gui_set_autolower, /* generic OK */ + pgtk_set_background_color, + pgtk_set_border_color, + gui_set_border_width, + pgtk_set_cursor_color, + pgtk_set_cursor_type, + gui_set_font, /* generic OK */ + pgtk_set_foreground_color, + pgtk_set_icon_name, + pgtk_set_icon_type, + pgtk_set_child_frame_border_width, + pgtk_set_internal_border_width, /* generic OK */ + gui_set_right_divider_width, + gui_set_bottom_divider_width, + pgtk_set_menu_bar_lines, + pgtk_set_mouse_color, + pgtk_explicitly_set_name, + gui_set_scroll_bar_width, /* generic OK */ + gui_set_scroll_bar_height, /* generic OK */ + pgtk_set_title, + gui_set_unsplittable, /* generic OK */ + gui_set_vertical_scroll_bars, /* generic OK */ + gui_set_horizontal_scroll_bars, /* generic OK */ + gui_set_visibility, /* generic OK */ + pgtk_set_tab_bar_lines, + pgtk_set_tool_bar_lines, + pgtk_set_scroll_bar_foreground, + pgtk_set_scroll_bar_background, + gui_set_screen_gamma, /* generic OK */ + gui_set_line_spacing, /* generic OK, sets f->extra_line_spacing to int */ + gui_set_left_fringe, /* generic OK */ + gui_set_right_fringe, /* generic OK */ + 0, + gui_set_fullscreen, /* generic OK */ + gui_set_font_backend, /* generic OK */ + gui_set_alpha, + pgtk_set_sticky, + pgtk_set_tool_bar_position, + 0, + pgtk_set_undecorated, + pgtk_set_parent_frame, + pgtk_set_skip_taskbar, + pgtk_set_no_focus_on_map, + pgtk_set_no_accept_focus, + pgtk_set_z_group, + pgtk_set_override_redirect, + gui_set_no_special_glyphs, + pgtk_set_alpha_background, + }; /* Handler for signals raised during x_create_frame and @@ -1060,7 +1015,7 @@ unwind_create_frame (Lisp_Object frame) && FRAME_IMAGE_CACHE (f)->refcount == image_cache_refcount) FRAME_IMAGE_CACHE (f)->refcount++; - x_free_frame_resources (f); + pgtk_free_frame_resources (f); free_glyphs (f); return Qt; } @@ -1193,7 +1148,7 @@ incorrect when you specify fractional scale factor in compositor. If you set scale factor by this function, it is used instead of Gdk's one. Pass nil as SCALE-FACTOR if you want to reset the specified monitor's -scale factor. */ ) +scale factor. */) (Lisp_Object monitor_model, Lisp_Object scale_factor) { CHECK_STRING (monitor_model); @@ -1521,10 +1476,11 @@ This function is an internal primitive--use `make-frame' instead. */ ) init_frame_faces (f); /* We have to call adjust_frame_size here since otherwise - x_set_tool_bar_lines will already work with the character sizes - installed by init_frame_faces while the frame's pixel size is still - calculated from a character size of 1 and we subsequently hit the - (height >= 0) assertion in window_box_height. + pgtk_set_tool_bar_lines will already work with the character + sizes installed by init_frame_faces while the frame's pixel size + is still calculated from a character size of 1 and we + subsequently hit the (height >= 0) assertion in + window_box_height. The non-pixelwise code apparently worked around this because it had one frame line vs one toolbar line which left us with a zero @@ -1532,14 +1488,12 @@ This function is an internal primitive--use `make-frame' instead. */ ) Also process `min-width' and `min-height' parameters right here because `frame-windows-min-size' needs them. */ - tem = - gui_display_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL, - RES_TYPE_NUMBER); + tem = gui_display_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL, + RES_TYPE_NUMBER); if (NUMBERP (tem)) store_frame_param (f, Qmin_width, tem); - tem = - gui_display_get_arg (dpyinfo, parms, Qmin_height, NULL, NULL, - RES_TYPE_NUMBER); + tem = gui_display_get_arg (dpyinfo, parms, Qmin_height, NULL, NULL, + RES_TYPE_NUMBER); if (NUMBERP (tem)) store_frame_param (f, Qmin_height, tem); adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), @@ -1700,7 +1654,7 @@ This function is an internal primitive--use `make-frame' instead. */ ) badly we want them. This should be done after we have the menu bar so that its size can be taken into account. */ block_input (); - x_wm_set_size_hint (f, window_prompting, false); + xg_wm_set_size_hint (f, window_prompting, false); unblock_input (); adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), @@ -2219,7 +2173,6 @@ terminate Emacs if we can't open the connection. */) CHECK_STRING (display); - nxatoms_of_pgtkselect (); dpyinfo = pgtk_term_init (display, SSDATA (Vx_resource_name)); if (dpyinfo == 0) { @@ -2264,27 +2217,6 @@ DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0, return result; } - -DEFUN ("pgtk-hide-others", Fpgtk_hide_others, Spgtk_hide_others, 0, 0, 0, - doc: /* Hides all applications other than Emacs. */) - (void) -{ - check_window_system (NULL); - return Qnil; -} - -DEFUN ("pgtk-hide-emacs", Fpgtk_hide_emacs, Spgtk_hide_emacs, 1, 1, 0, - doc: /* If ON is non-nil, the entire Emacs application is hidden. -Otherwise if Emacs is hidden, it is unhidden. -If ON is equal to `activate', Emacs is unhidden and becomes -the active application. */) - (Lisp_Object on) -{ - check_window_system (NULL); - return Qnil; -} - - DEFUN ("pgtk-font-name", Fpgtk_font_name, Spgtk_font_name, 1, 1, 0, doc: /* Determine font PostScript or family name for font NAME. NAME should be a string containing either the font name or an XLFD @@ -2320,7 +2252,6 @@ check_x_display_info (Lisp_Object frame) return check_pgtk_display_info (frame); } - void pgtk_set_scroll_bar_default_width (struct frame *f) { @@ -2368,9 +2299,8 @@ pgtk_get_string_resource (XrmDatabase rdb, const char *name, return res; } - Lisp_Object -x_get_focus_frame (struct frame *frame) +pgtk_get_focus_frame (struct frame *frame) { struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame); Lisp_Object focus; @@ -2382,13 +2312,6 @@ x_get_focus_frame (struct frame *frame) return focus; } -/* ========================================================================== - - Lisp definitions that, for whatever reason, we can't alias as 'ns-XXX'. - - ========================================================================== */ - - DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0, doc: /* Internal function called by `color-defined-p', which see. */) (Lisp_Object color, Lisp_Object frame) @@ -2420,7 +2343,6 @@ DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, return Qnil; } - DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, doc: /* Internal function called by `display-color-p', which see. */) (Lisp_Object terminal) @@ -2429,7 +2351,6 @@ DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0, return Qt; } - DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p, 0, 1, 0, doc: /* Return t if the display supports shades of gray. Note that color displays do support shades of gray. @@ -2441,7 +2362,6 @@ If omitted or nil, that stands for the selected frame's display. */) return Qnil; } - DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width, 0, 1, 0, doc: /* Return the width in pixels of the display TERMINAL. The optional argument TERMINAL specifies which display to ask about. @@ -2487,7 +2407,6 @@ each physical monitor, use `display-monitor-attributes-list'. */) return make_fixnum (width); } - DEFUN ("x-display-pixel-height", Fx_display_pixel_height, Sx_display_pixel_height, 0, 1, 0, doc: /* Return the height in pixels of the display TERMINAL. The optional argument TERMINAL specifies which display to ask about. @@ -3042,8 +2961,8 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, { min_x = 0; min_y = 0; - max_x = x_display_pixel_width (FRAME_DISPLAY_INFO (f)); - max_y = x_display_pixel_height (FRAME_DISPLAY_INFO (f)); + max_x = pgtk_display_pixel_width (FRAME_DISPLAY_INFO (f)); + max_y = pgtk_display_pixel_height (FRAME_DISPLAY_INFO (f)); } if (INTEGERP (top)) @@ -3082,7 +3001,7 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, /* Hide tooltip. Delete its frame if DELETE is true. */ static Lisp_Object -x_hide_tip (bool delete) +pgtk_hide_tip (bool delete) { if (!NILP (tip_timer)) { @@ -3173,7 +3092,8 @@ PARMS is an optional list of frame parameters which can be used to change the tooltip's appearance. Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil -means use the default timeout of 5 seconds. +means use the default timeout from the `x-show-tooltip-timeout' +variable. If the list of frame parameters PARMS contains a `left' parameter, display the tooltip at that x-position. If the list of frame parameters @@ -3219,9 +3139,8 @@ Text larger than the specified size is clipped. */) return unbind_to (count, Qnil); if (NILP (timeout)) - timeout = make_fixnum (5); - else - CHECK_FIXNAT (timeout); + timeout = Vx_show_tooltip_timeout; + CHECK_FIXNAT (timeout); if (NILP (dx)) dx = make_fixnum (5); @@ -3322,13 +3241,13 @@ Text larger than the specified size is clipped. */) } } - x_hide_tip (delete); + pgtk_hide_tip (delete); } else - x_hide_tip (true); + pgtk_hide_tip (true); } else - x_hide_tip (true); + pgtk_hide_tip (true); tip_last_frame = frame; tip_last_string = string; @@ -3455,7 +3374,7 @@ DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0, Value is t if tooltip was open, nil otherwise. */) (void) { - return x_hide_tip (!tooltip_reuse_hidden_frame); + return pgtk_hide_tip (!tooltip_reuse_hidden_frame); } /* Return geometric attributes of FRAME. According to the value of @@ -3481,10 +3400,8 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute) int left_pos, top_pos; if (FRAME_GTK_OUTER_WIDGET (f)) - { - gtk_window_get_position (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), - &left_pos, &top_pos); - } + gtk_window_get_position (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + &left_pos, &top_pos); else { GtkAllocation alloc; @@ -3872,11 +3789,18 @@ nil, it defaults to the selected frame. */) return unbind_to (count, font); } -/* ========================================================================== +DEFUN ("x-gtk-debug", Fx_gtk_debug, Sx_gtk_debug, 1, 1, 0, + doc: /* SKIP: real doc in xfns.c. */) + (Lisp_Object enable) +{ + gboolean enable_debug = !NILP (enable); - Lisp interface declaration + block_input (); + gtk_window_set_interactive_debugging (enable_debug); + unblock_input (); - ========================================================================== */ + return NILP (enable) ? Qnil : Qt; +} void syms_of_pgtkfns (void) @@ -3894,27 +3818,6 @@ syms_of_pgtkfns (void) doc: /* SKIP: real doc in xfns.c. */); Vx_cursor_fore_pixel = Qnil; - DEFVAR_LISP ("pgtk-icon-type-alist", Vpgtk_icon_type_alist, - doc: /* Alist of elements (REGEXP . IMAGE) for images of icons associated to frames. -If the title of a frame matches REGEXP, then IMAGE.tiff is -selected as the image of the icon representing the frame when it's -miniaturized. If an element is t, then Emacs tries to select an icon -based on the filetype of the visited file. - -The images have to be installed in a folder called English.lproj in the -Emacs folder. You have to restart Emacs after installing new icons. - -Example: Install an icon Gnus.tiff and execute the following code - -(setq pgtk-icon-type-alist -(append pgtk-icon-type-alist -\\='((\"^\\\\*\\\\(Group\\\\*$\\\\|Summary \\\\|Article\\\\*$\\\\)\" -. \"Gnus\")))) - -When you miniaturize a Group, Summary or Article frame, Gnus.tiff will -be used as the image of the icon representing the frame. */); - Vpgtk_icon_type_alist = list1 (Qt); - Fprovide (intern_c_string ("gtk"), Qnil); DEFVAR_LISP ("gtk-version-string", Vgtk_version_string, @@ -3942,7 +3845,6 @@ be used as the image of the icon representing the frame. */); g_free (ver); } - defsubr (&Spgtk_set_resource); defsubr (&Sxw_display_color_p); /* this and next called directly by C code */ defsubr (&Sx_display_grayscale_p); @@ -3970,9 +3872,7 @@ be used as the image of the icon representing the frame. */); defsubr (&Sx_open_connection); defsubr (&Sx_close_connection); defsubr (&Sx_display_list); - - defsubr (&Spgtk_hide_others); - defsubr (&Spgtk_hide_emacs); + defsubr (&Sx_gtk_debug); defsubr (&Sx_show_tip); defsubr (&Sx_hide_tip); @@ -3988,10 +3888,6 @@ be used as the image of the icon representing the frame. */); defsubr (&Sx_file_dialog); defsubr (&Sx_select_font); - as_status = 0; - as_script = Qnil; - as_result = 0; - monitor_scale_factor_alist = Qnil; staticpro (&monitor_scale_factor_alist); @@ -4036,5 +3932,3 @@ be used as the image of the icon representing the frame. */); DEFSYM (Qreverse_portrait, "reverse-portrait"); DEFSYM (Qreverse_landscape, "reverse-landscape"); } - -#endif diff --git a/src/pgtkmenu.c b/src/pgtkmenu.c index bd63af3b223..eec9f419d07 100644 --- a/src/pgtkmenu.c +++ b/src/pgtkmenu.c @@ -62,19 +62,14 @@ pgtk_menu_set_in_use (bool in_use) struct frame *f = XFRAME (frame); if (in_use && FRAME_Z_GROUP_ABOVE (f)) - x_set_z_group (f, Qabove_suspended, Qabove); + pgtk_set_z_group (f, Qabove_suspended, Qabove); else if (!in_use && FRAME_Z_GROUP_ABOVE_SUSPENDED (f)) - x_set_z_group (f, Qabove, Qabove_suspended); + pgtk_set_z_group (f, Qabove, Qabove_suspended); } } DEFUN ("x-menu-bar-open-internal", Fx_menu_bar_open_internal, Sx_menu_bar_open_internal, 0, 1, "i", - doc: /* Start key navigation of the menu bar in FRAME. - This initially opens the first menu bar item and you can then navigate with the - arrow keys, select a menu entry with the return key or cancel with the - escape key. If FRAME has no menu bar this function does nothing. - - If FRAME is nil or not given, use the selected frame. */) + doc: /* SKIP: real doc in USE_GTK definition in xmenu.c. */) (Lisp_Object frame) { GtkWidget *menubar; diff --git a/src/pgtkselect.c b/src/pgtkselect.c index 2660ea3ed38..4c87aaa7ea6 100644 --- a/src/pgtkselect.c +++ b/src/pgtkselect.c @@ -17,13 +17,15 @@ 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 . */ -/* -Originally by Carl Edman -Updated by Christian Limpach (chris@nice.ch) -OpenStep/Rhapsody port by Scott Bender (sbender@harmony-ds.com) -macOS/Aqua port by Christophe de Dinechin (descubes@earthlink.net) -GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) -*/ +/* FIXME: this file needs a major rewrite to replace the use of GTK's + own high-level GtkClipboard API with the GDK selection API: + + https://developer-old.gnome.org/gdk3/stable/gdk3-Selections.html + + That way, most of the code can be shared with X, and non-text + targets along with drag-and-drop can be supported. GDK implements + selections according to the ICCCM, as on X, but its selection API + will work on any supported window system. */ /* This should be the first include, as it may set up #defines affecting interpretation of even the system includes. */ @@ -151,10 +153,8 @@ selection_type_to_quarks (GdkAtom type, GQuark * quark_data, *quark_size = quark_clipboard_size; } else - { - /* fixme: Is it safe to use 'error' here? */ - error ("Unknown selection type."); - } + /* FIXME: Is it safe to use 'error' here? */ + error ("Unknown selection type."); } static void @@ -492,12 +492,6 @@ frame's display, or the first available display. */) return Qnil; } - -void -nxatoms_of_pgtkselect (void) -{ -} - void syms_of_pgtkselect (void) { diff --git a/src/pgtkselect.h b/src/pgtkselect.h index 0509c83bdec..fd9910b2d18 100644 --- a/src/pgtkselect.h +++ b/src/pgtkselect.h @@ -26,8 +26,6 @@ along with GNU Emacs. If not, see . */ #include extern void pgtk_selection_init (void); -extern void pgtk_selection_lost (GtkWidget * widget, - GdkEventSelection * event, - gpointer user_data); +extern void pgtk_selection_lost (GtkWidget *, GdkEventSelection *, gpointer); #endif /* HAVE_PGTK */ diff --git a/src/pgtkterm.c b/src/pgtkterm.c index abcf18e11df..c8c8bd0d85e 100644 --- a/src/pgtkterm.c +++ b/src/pgtkterm.c @@ -1,4 +1,4 @@ -/* Pure Gtk+-3 communication module. -*- coding: utf-8 -*- +/* Communication module for window systems using GTK. Copyright (C) 1989, 1993-1994, 2005-2006, 2008-2022 Free Software Foundation, Inc. @@ -36,6 +36,8 @@ along with GNU Emacs. If not, see . */ #include #include +#include + #include "lisp.h" #include "blockinput.h" #include "frame.h" @@ -47,7 +49,6 @@ along with GNU Emacs. If not, see . */ #include "fontset.h" #include "composite.h" #include "ccl.h" -#include "dynlib.h" #include "termhooks.h" #include "termopts.h" @@ -67,11 +68,9 @@ along with GNU Emacs. If not, see . */ #include #endif -#define STORE_KEYSYM_FOR_DEBUG(keysym) ((void)0) - -#define FRAME_CR_CONTEXT(f) ((f)->output_data.pgtk->cr_context) +#define FRAME_CR_CONTEXT(f) ((f)->output_data.pgtk->cr_context) #define FRAME_CR_ACTIVE_CONTEXT(f) ((f)->output_data.pgtk->cr_active) -#define FRAME_CR_SURFACE(f) (cairo_get_target (FRAME_CR_CONTEXT (f))) +#define FRAME_CR_SURFACE(f) (cairo_get_target (FRAME_CR_CONTEXT (f))) /* Non-zero means that a HELP_EVENT has been generated since Emacs start. */ @@ -97,15 +96,124 @@ static Time ignore_next_mouse_click_timeout; static Lisp_Object xg_default_icon_file; -static void pgtk_delete_display (struct pgtk_display_info *dpyinfo); -static void pgtk_clear_frame_area (struct frame *f, int x, int y, int width, - int height); -static void pgtk_fill_rectangle (struct frame *f, unsigned long color, int x, - int y, int width, int height, - bool respect_alpha_background); -static void pgtk_clip_to_row (struct window *w, struct glyph_row *row, - enum glyph_row_area area, cairo_t * cr); -static struct frame *pgtk_any_window_to_frame (GdkWindow *window); +static void pgtk_delete_display (struct pgtk_display_info *); +static void pgtk_clear_frame_area (struct frame *, int, int, int, int); +static void pgtk_fill_rectangle (struct frame *, unsigned long, int, int, + int, int, bool); +static void pgtk_clip_to_row (struct window *, struct glyph_row *, + enum glyph_row_area, cairo_t *); +static struct frame *pgtk_any_window_to_frame (GdkWindow *); +static void pgtk_regenerate_devices (struct pgtk_display_info *); + +static void +pgtk_device_added_or_removal_cb (GdkSeat *seat, GdkDevice *device, + gpointer user_data) +{ + pgtk_regenerate_devices (user_data); +} + +static void +pgtk_seat_added_cb (GdkDisplay *dpy, GdkSeat *seat, + gpointer user_data) +{ + pgtk_regenerate_devices (user_data); + + g_signal_connect (G_OBJECT (seat), "device-added", + G_CALLBACK (pgtk_device_added_or_removal_cb), + user_data); + g_signal_connect (G_OBJECT (seat), "device-removed", + G_CALLBACK (pgtk_device_added_or_removal_cb), + user_data); +} + +static void +pgtk_seat_removed_cb (GdkDisplay *dpy, GdkSeat *seat, + gpointer user_data) +{ + pgtk_regenerate_devices (user_data); + + g_signal_handlers_disconnect_by_func (G_OBJECT (seat), + G_CALLBACK (pgtk_device_added_or_removal_cb), + user_data); +} + +static void +pgtk_enumerate_devices (struct pgtk_display_info *dpyinfo, + bool initial_p) +{ + struct pgtk_device_t *rec; + GList *all_seats, *devices_on_seat, *tem, *t1; + GdkSeat *seat; + char printbuf[1026]; /* Believe it or not, some device names are + actually almost this long. */ + + block_input (); + all_seats = gdk_display_list_seats (dpyinfo->gdpy); + + for (tem = all_seats; tem; tem = tem->next) + { + seat = GDK_SEAT (tem->data); + + if (initial_p) + { + g_signal_connect (G_OBJECT (seat), "device-added", + G_CALLBACK (pgtk_device_added_or_removal_cb), + dpyinfo); + g_signal_connect (G_OBJECT (seat), "device-removed", + G_CALLBACK (pgtk_device_added_or_removal_cb), + dpyinfo); + } + + /* We only want slaves, not master devices. */ + devices_on_seat = gdk_seat_get_slaves (seat, + GDK_SEAT_CAPABILITY_ALL); + + for (t1 = devices_on_seat; t1; t1 = t1->next) + { + rec = xmalloc (sizeof *rec); + rec->seat = g_object_ref (seat); + rec->device = GDK_DEVICE (t1->data); + + snprintf (printbuf, 1026, "%u:%s", + gdk_device_get_source (rec->device), + gdk_device_get_name (rec->device)); + + rec->name = build_string (printbuf); + rec->next = dpyinfo->devices; + dpyinfo->devices = rec; + } + + g_list_free (devices_on_seat); + } + + g_list_free (all_seats); + unblock_input (); +} + +static void +pgtk_free_devices (struct pgtk_display_info *dpyinfo) +{ + struct pgtk_device_t *last, *tem; + + tem = dpyinfo->devices; + while (tem) + { + last = tem; + tem = tem->next; + + g_object_unref (last->seat); + xfree (last); + } + + dpyinfo->devices = NULL; +} + +static void +pgtk_regenerate_devices (struct pgtk_display_info *dpyinfo) +{ + pgtk_free_devices (dpyinfo); + pgtk_enumerate_devices (dpyinfo, false); +} static void pgtk_toolkit_position (struct frame *f, int x, int y, @@ -135,12 +243,31 @@ pgtk_toolkit_position (struct frame *f, int x, int y, } } -/* - * This is not a flip context in the same sense as gpu rendering - * scences, it only occurs when a new context was required due to a - * resize or other fundamental change. This is called when that - * context's surface has completed drawing - */ +static Lisp_Object +pgtk_get_device_for_event (struct pgtk_display_info *dpyinfo, + GdkEvent *event) +{ + struct pgtk_device_t *tem; + GdkDevice *device; + + device = gdk_event_get_source_device (event); + + if (!device) + return Qt; + + for (tem = dpyinfo->devices; tem; tem = tem->next) + { + if (tem->device == device) + return tem->name; + } + + return Qt; +} + +/* This is not a flip context in the same sense as gpu rendering + scenes, it only occurs when a new context was required due to a + resize or other fundamental change. This is called when that + context's surface has completed drawing. */ static void flip_cr_context (struct frame *f) @@ -151,8 +278,9 @@ flip_cr_context (struct frame *f) if (cr != FRAME_CR_CONTEXT (f)) { cairo_destroy (cr); - FRAME_CR_ACTIVE_CONTEXT (f) = cairo_reference (FRAME_CR_CONTEXT (f)); + FRAME_CR_ACTIVE_CONTEXT (f) + = cairo_reference (FRAME_CR_CONTEXT (f)); } unblock_input (); } @@ -206,8 +334,11 @@ evq_flush (struct input_event *hold_quit) void mark_pgtkterm (void) { + struct pgtk_display_info *dpyinfo; + struct pgtk_device_t *device; struct event_queue_t *evq = &event_q; int i, n = evq->nr; + for (i = 0; i < n; i++) { union buffered_input_event *ev = &evq->q[i]; @@ -215,19 +346,22 @@ mark_pgtkterm (void) mark_object (ev->ie.y); mark_object (ev->ie.frame_or_window); mark_object (ev->ie.arg); + mark_object (ev->ie.device); + } + + for (dpyinfo = x_display_list; dpyinfo; + dpyinfo = dpyinfo->next) + { + for (device = dpyinfo->devices; device; + device = device->next) + mark_object (device->name); } } char * get_keysym_name (int keysym) -/* -------------------------------------------------------------------------- - Called by keyboard.c. Not sure if the return val is important, except - that it be unique. - -------------------------------------------------------------------------- */ { - static char value[16]; - sprintf (value, "%d", keysym); - return value; + return gdk_keyval_name (keysym); } void @@ -277,7 +411,7 @@ pgtk_frame_raise_lower (struct frame *f, bool raise_flag) /* Free X resources of frame F. */ void -x_free_frame_resources (struct frame *f) +pgtk_free_frame_resources (struct frame *f) { struct pgtk_display_info *dpyinfo; Mouse_HLInfo *hlinfo; @@ -378,7 +512,7 @@ x_free_frame_resources (struct frame *f) } void -x_destroy_window (struct frame *f) +pgtk_destroy_window (struct frame *f) /* -------------------------------------------------------------------------- External: Delete the window -------------------------------------------------------------------------- */ @@ -387,7 +521,7 @@ x_destroy_window (struct frame *f) check_window_system (f); if (dpyinfo->gdpy != NULL) - x_free_frame_resources (f); + pgtk_free_frame_resources (f); dpyinfo->reference_count--; } @@ -396,7 +530,7 @@ x_destroy_window (struct frame *f) from its current recorded position values and gravity. */ static void -x_calc_absolute_position (struct frame *f) +pgtk_calc_absolute_position (struct frame *f) { int flags = f->size_hint_flags; struct frame *p = FRAME_PARENT_FRAME (f); @@ -430,7 +564,7 @@ x_calc_absolute_position (struct frame *f) f->left_pos = (FRAME_PIXEL_WIDTH (p) - width - 2 * f->border_width + f->left_pos); else - f->left_pos = (x_display_pixel_width (FRAME_DISPLAY_INFO (f)) + f->left_pos = (pgtk_display_pixel_width (FRAME_DISPLAY_INFO (f)) - width + f->left_pos); } @@ -456,7 +590,7 @@ x_calc_absolute_position (struct frame *f) f->top_pos = (FRAME_PIXEL_HEIGHT (p) - height - 2 * f->border_width + f->top_pos); else - f->top_pos = (x_display_pixel_height (FRAME_DISPLAY_INFO (f)) + f->top_pos = (pgtk_display_pixel_height (FRAME_DISPLAY_INFO (f)) - height + f->top_pos); } @@ -473,10 +607,7 @@ x_calc_absolute_position (struct frame *f) which means, do adjust for borders but don't change the gravity. */ static void -x_set_offset (struct frame *f, int xoff, int yoff, int change_gravity) -/* -------------------------------------------------------------------------- - External: Position the window - -------------------------------------------------------------------------- */ +pgtk_set_offset (struct frame *f, int xoff, int yoff, int change_gravity) { if (change_gravity > 0) { @@ -490,18 +621,16 @@ x_set_offset (struct frame *f, int xoff, int yoff, int change_gravity) f->win_gravity = NorthWestGravity; } - x_calc_absolute_position (f); + pgtk_calc_absolute_position (f); block_input (); - x_wm_set_size_hint (f, 0, false); + xg_wm_set_size_hint (f, 0, false); if (change_gravity != 0) { if (FRAME_GTK_OUTER_WIDGET (f)) - { - gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), - f->left_pos, f->top_pos); - } + gtk_window_move (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + f->left_pos, f->top_pos); else { GtkWidget *fixed = FRAME_GTK_WIDGET (f); @@ -530,31 +659,8 @@ pgtk_set_window_size (struct frame *f, bool change_gravity, gtk_widget_get_size_request (FRAME_GTK_WIDGET (f), &pixelwidth, &pixelheight); -#if 0 - if (pixelwise) - { - pixelwidth = FRAME_TEXT_TO_PIXEL_WIDTH (f, width); - pixelheight = FRAME_TEXT_TO_PIXEL_HEIGHT (f, height); - } - else - { - pixelwidth = FRAME_TEXT_COLS_TO_PIXEL_WIDTH (f, width); - pixelheight = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, height); - } -#else pixelwidth = width; pixelheight = height; -#endif - -#if 0 - frame_size_history_add - (f, Qx_set_window_size_1, width, height, - list5 (Fcons (make_fixnum (pixelwidth), make_fixnum (pixelheight)), - Fcons (make_fixnum (pixelwidth), make_fixnum (pixelheight)), - make_fixnum (f->border_width), - make_fixnum (FRAME_PGTK_TITLEBAR_HEIGHT (f)), - make_fixnum (FRAME_TOOLBAR_HEIGHT (f)))); -#endif for (GtkWidget * w = FRAME_GTK_WIDGET (f); w != NULL; w = gtk_widget_get_parent (w)) @@ -565,7 +671,7 @@ pgtk_set_window_size (struct frame *f, bool change_gravity, f->output_data.pgtk->preferred_width = pixelwidth; f->output_data.pgtk->preferred_height = pixelheight; - x_wm_set_size_hint (f, 0, 0); + xg_wm_set_size_hint (f, 0, 0); xg_frame_set_char_size (f, pixelwidth, pixelheight); gtk_widget_queue_resize (FRAME_WIDGET (f)); @@ -602,7 +708,7 @@ pgtk_iconify_frame (struct frame *f) /* Make sure the X server knows where the window should be positioned, in case the user deiconifies with the window manager. */ if (!FRAME_VISIBLE_P (f) && !FRAME_ICONIFIED_P (f)) - x_set_offset (f, f->left_pos, f->top_pos, 0); + pgtk_set_offset (f, f->left_pos, f->top_pos, 0); SET_FRAME_ICONIFIED (f, true); SET_FRAME_VISIBLE (f, 0); @@ -611,8 +717,8 @@ pgtk_iconify_frame (struct frame *f) } static gboolean -pgtk_make_frame_visible_wait_for_map_event_cb (GtkWidget * widget, - GdkEventAny * event, +pgtk_make_frame_visible_wait_for_map_event_cb (GtkWidget *widget, + GdkEventAny *event, gpointer user_data) { int *foundptr = user_data; @@ -633,19 +739,19 @@ pgtk_wait_for_map_event (struct frame *f, bool multiple_times) { if (FLOATP (Vpgtk_wait_for_event_timeout)) { - guint msec = - (guint) (XFLOAT_DATA (Vpgtk_wait_for_event_timeout) * 1000); + guint msec + = (guint) (XFLOAT_DATA (Vpgtk_wait_for_event_timeout) * 1000); int found = 0; int timed_out = 0; - gulong id = - g_signal_connect (FRAME_WIDGET (f), "map-event", - G_CALLBACK - (pgtk_make_frame_visible_wait_for_map_event_cb), - &found); - guint src = - g_timeout_add (msec, - pgtk_make_frame_visible_wait_for_map_event_timeout, - &timed_out); + gulong id + = g_signal_connect (FRAME_WIDGET (f), "map-event", + G_CALLBACK + (pgtk_make_frame_visible_wait_for_map_event_cb), + &found); + guint src + = g_timeout_add (msec, + pgtk_make_frame_visible_wait_for_map_event_timeout, + &timed_out); if (!multiple_times) { @@ -659,6 +765,7 @@ pgtk_wait_for_map_event (struct frame *f, bool multiple_times) } g_signal_handler_disconnect (FRAME_WIDGET (f), id); + if (!timed_out) g_source_remove (src); } @@ -666,9 +773,6 @@ pgtk_wait_for_map_event (struct frame *f, bool multiple_times) void pgtk_make_frame_visible (struct frame *f) -/* -------------------------------------------------------------------------- - External: Show the window (X11 semantics) - -------------------------------------------------------------------------- */ { GtkWidget *win = FRAME_GTK_OUTER_WIDGET (f); @@ -685,17 +789,11 @@ pgtk_make_frame_visible (struct frame *f) void pgtk_make_frame_invisible (struct frame *f) -/* -------------------------------------------------------------------------- - External: Hide the window (X11 semantics) - -------------------------------------------------------------------------- */ { gtk_widget_hide (FRAME_WIDGET (f)); - /* Map events are emitted many times, and - * map_event() do SET_FRAME_VISIBLE(f, 1). - * I expect visible = 0, so process those map events here and - * SET_FRAME_VISIBLE(f, 0) after that. - */ + /* Handle any pending map event(s), then make the frame visible + manually, to avoid race conditions. */ pgtk_wait_for_map_event (f, true); SET_FRAME_VISIBLE (f, 0); @@ -774,45 +872,26 @@ pgtk_new_font (struct frame *f, Lisp_Object font_object, int fontset) } int -x_display_pixel_height (struct pgtk_display_info *dpyinfo) +pgtk_display_pixel_height (struct pgtk_display_info *dpyinfo) { GdkDisplay *gdpy = dpyinfo->gdpy; GdkScreen *gscr = gdk_display_get_default_screen (gdpy); + return gdk_screen_get_height (gscr); } int -x_display_pixel_width (struct pgtk_display_info *dpyinfo) +pgtk_display_pixel_width (struct pgtk_display_info *dpyinfo) { GdkDisplay *gdpy = dpyinfo->gdpy; GdkScreen *gscr = gdk_display_get_default_screen (gdpy); + return gdk_screen_get_width (gscr); } void -x_set_parent_frame (struct frame *f, Lisp_Object new_value, - Lisp_Object old_value) -/* -------------------------------------------------------------------------- - Set frame F's `parent-frame' parameter. If non-nil, make F a child - frame of the frame specified by that parameter. Technically, this - makes F's window-system window a child window of the parent frame's - window-system window. If nil, make F's window-system window a - top-level window--a child of its display's root window. - - A child frame's `left' and `top' parameters specify positions - relative to the top-left corner of its parent frame's native - rectangle. On macOS moving a parent frame moves all its child - frames too, keeping their position relative to the parent - unaltered. When a parent frame is iconified or made invisible, its - child frames are made invisible. When a parent frame is deleted, - its child frames are deleted too. - - Whether a child frame has a tool bar may be window-system or window - manager dependent. It's advisable to disable it via the frame - parameter settings. - - Some window managers may not honor this parameter. - -------------------------------------------------------------------------- */ +pgtk_set_parent_frame (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) { struct frame *p = NULL; @@ -852,7 +931,8 @@ x_set_parent_frame (struct frame *f, Lisp_Object new_value, { GtkWidget *whbox_of_f = gtk_widget_get_parent (fixed); - /* Here, unhighlight can be called and may change border_color_css_provider. */ + /* Here, unhighlight can be called and may change + border_color_css_provider. */ gtk_container_remove (GTK_CONTAINER (whbox_of_f), fixed); if (FRAME_GTK_OUTER_WIDGET (f)) @@ -873,10 +953,11 @@ x_set_parent_frame (struct frame *f, Lisp_Object new_value, { xg_create_frame_outer_widgets (f); pgtk_set_event_handler (f); - gtk_box_pack_start (GTK_BOX (f->output_data.pgtk->hbox_widget), fixed, TRUE, TRUE, 0); + gtk_box_pack_start (GTK_BOX (f->output_data.pgtk->hbox_widget), + fixed, TRUE, TRUE, 0); f->output_data.pgtk->preferred_width = alloc.width; f->output_data.pgtk->preferred_height = alloc.height; - x_wm_set_size_hint (f, 0, 0); + xg_wm_set_size_hint (f, 0, 0); xg_frame_set_char_size (f, FRAME_PIXEL_TO_TEXT_WIDTH (f, alloc.width), FRAME_PIXEL_TO_TEXT_HEIGHT (f, alloc.height)); gtk_widget_queue_resize (FRAME_WIDGET (f)); @@ -913,20 +994,11 @@ x_set_parent_frame (struct frame *f, Lisp_Object new_value, } } - +/* Doesn't work on wayland. */ void -x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value, - Lisp_Object old_value) -/* Set frame F's `no-focus-on-map' parameter which, if non-nil, means - * that F's window-system window does not want to receive input focus - * when it is mapped. (A frame's window is mapped when the frame is - * displayed for the first time and when the frame changes its state - * from `iconified' or `invisible' to `visible'.) - * - * Some window managers may not honor this parameter. */ +pgtk_set_no_focus_on_map (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) { - /* doesn't work on wayland. */ - if (!EQ (new_value, old_value)) { xg_set_no_focus_on_map (f, new_value); @@ -935,36 +1007,16 @@ x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value, } void -x_set_no_accept_focus (struct frame *f, Lisp_Object new_value, - Lisp_Object old_value) -/* Set frame F's `no-accept-focus' parameter which, if non-nil, hints - * that F's window-system window does not want to receive input focus - * via mouse clicks or by moving the mouse into it. - * - * If non-nil, this may have the unwanted side-effect that a user cannot - * scroll a non-selected frame with the mouse. - * - * Some window managers may not honor this parameter. */ +pgtk_set_no_accept_focus (struct frame *f, Lisp_Object new_value, + Lisp_Object old_value) { - /* doesn't work on wayland. */ - xg_set_no_accept_focus (f, new_value); FRAME_NO_ACCEPT_FOCUS (f) = !NILP (new_value); } void -x_set_z_group (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) -/* Set frame F's `z-group' parameter. If `above', F's window-system - window is displayed above all windows that do not have the `above' - property set. If nil, F's window is shown below all windows that - have the `above' property set and above all windows that have the - `below' property set. If `below', F's window is displayed below - all windows that do. - - Some window managers may not honor this parameter. */ +pgtk_set_z_group (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) { - /* doesn't work on wayland. */ - if (!FRAME_GTK_OUTER_WIDGET (f)) return; @@ -1025,7 +1077,7 @@ pgtk_initialize_display_info (struct pgtk_display_info *dpyinfo) face. */ static void -x_set_cursor_gc (struct glyph_string *s) +pgtk_set_cursor_gc (struct glyph_string *s) { if (s->font == FRAME_FONT (s->f) && s->face->background == FRAME_BACKGROUND_PIXEL (s->f) @@ -1063,7 +1115,7 @@ x_set_cursor_gc (struct glyph_string *s) /* Set up S->gc of glyph string S for drawing text in mouse face. */ static void -x_set_mouse_face_gc (struct glyph_string *s) +pgtk_set_mouse_face_gc (struct glyph_string *s) { prepare_face_for_display (s->f, s->face); @@ -1092,7 +1144,7 @@ x_set_mouse_face_gc (struct glyph_string *s) matrix was built, so there isn't much to do, here. */ static void -x_set_mode_line_face_gc (struct glyph_string *s) +pgtk_set_mode_line_face_gc (struct glyph_string *s) { s->xgcv.foreground = s->face->foreground; s->xgcv.background = s->face->background; @@ -1104,7 +1156,7 @@ x_set_mode_line_face_gc (struct glyph_string *s) pattern. */ static void -x_set_glyph_string_gc (struct glyph_string *s) +pgtk_set_glyph_string_gc (struct glyph_string *s) { prepare_face_for_display (s->f, s->face); @@ -1116,17 +1168,17 @@ x_set_glyph_string_gc (struct glyph_string *s) } else if (s->hl == DRAW_INVERSE_VIDEO) { - x_set_mode_line_face_gc (s); + pgtk_set_mode_line_face_gc (s); s->stippled_p = s->face->stipple != 0; } else if (s->hl == DRAW_CURSOR) { - x_set_cursor_gc (s); + pgtk_set_cursor_gc (s); s->stippled_p = false; } else if (s->hl == DRAW_MOUSE_FACE) { - x_set_mouse_face_gc (s); + pgtk_set_mouse_face_gc (s); s->stippled_p = s->face->stipple != 0; } else if (s->hl == DRAW_IMAGE_RAISED || s->hl == DRAW_IMAGE_SUNKEN) @@ -1144,7 +1196,7 @@ x_set_glyph_string_gc (struct glyph_string *s) line or menu if we don't have X toolkit support. */ static void -x_set_glyph_string_clipping (struct glyph_string *s, cairo_t * cr) +pgtk_set_glyph_string_clipping (struct glyph_string *s, cairo_t * cr) { XRectangle r[2]; int n = get_glyph_string_clip_rects (s, r, 2); @@ -1159,14 +1211,13 @@ x_set_glyph_string_clipping (struct glyph_string *s, cairo_t * cr) } } - /* Set SRC's clipping for output of glyph string DST. This is called when we are drawing DST's left_overhang or right_overhang only in the area of SRC. */ static void -x_set_glyph_string_clipping_exactly (struct glyph_string *src, - struct glyph_string *dst, cairo_t * cr) +pgtk_set_glyph_string_clipping_exactly (struct glyph_string *src, + struct glyph_string *dst, cairo_t * cr) { dst->clip[0].x = src->x; dst->clip[0].y = src->y; @@ -1178,7 +1229,6 @@ x_set_glyph_string_clipping_exactly (struct glyph_string *src, cairo_clip (cr); } - /* RIF: Compute left and right overhang of glyph string S. */ @@ -1219,18 +1269,17 @@ pgtk_compute_glyph_string_overhangs (struct glyph_string *s) } } - -/* Fill rectangle X, Y, W, H with background color of glyph string S. */ - +/* Fill rectangle X, Y, W, H with background color of glyph string + S. */ static void -x_clear_glyph_string_rect (struct glyph_string *s, int x, int y, int w, int h) +pgtk_clear_glyph_string_rect (struct glyph_string *s, int x, int y, + int w, int h) { pgtk_fill_rectangle (s->f, s->xgcv.background, x, y, w, h, (s->first_glyph->type != STRETCH_GLYPH || s->hl != DRAW_CURSOR)); } - static void fill_background_by_face (struct frame *f, struct face *face, int x, int y, int width, int height) @@ -1272,9 +1321,8 @@ fill_background (struct glyph_string *s, int x, int y, int width, int height) background even if it wouldn't be drawn normally. This is used when a string preceding S draws into the background of S, or S contains the first component of a composition. */ - static void -x_draw_glyph_string_background (struct glyph_string *s, bool force_p) +pgtk_draw_glyph_string_background (struct glyph_string *s, bool force_p) { /* Nothing to do if background has already been drawn or if it shouldn't be drawn in the first place. */ @@ -1301,9 +1349,9 @@ x_draw_glyph_string_background (struct glyph_string *s, bool force_p) || s->font_not_found_p || s->extends_to_end_of_line_p || force_p) { - x_clear_glyph_string_rect (s, s->x, s->y + box_line_width, - s->background_width, - s->height - 2 * box_line_width); + pgtk_clear_glyph_string_rect (s, s->x, s->y + box_line_width, + s->background_width, + s->height - 2 * box_line_width); s->background_filled_p = true; } } @@ -1325,9 +1373,8 @@ pgtk_draw_rectangle (struct frame *f, unsigned long color, int x, int y, } /* Draw the foreground of glyph string S. */ - static void -x_draw_glyph_string_foreground (struct glyph_string *s) +pgtk_draw_glyph_string_foreground (struct glyph_string *s) { int i, x; @@ -1372,9 +1419,8 @@ x_draw_glyph_string_foreground (struct glyph_string *s) } /* Draw the foreground of composite glyph string S. */ - static void -x_draw_composite_glyph_string_foreground (struct glyph_string *s) +pgtk_draw_composite_glyph_string_foreground (struct glyph_string *s) { int i, j, x; struct font *font = s->font; @@ -1463,9 +1509,8 @@ x_draw_composite_glyph_string_foreground (struct glyph_string *s) /* Draw the foreground of glyph string S for glyphless characters. */ - static void -x_draw_glyphless_glyph_string_foreground (struct glyph_string *s) +pgtk_draw_glyphless_glyph_string_foreground (struct glyph_string *s) { struct glyph *glyph = s->first_glyph; unsigned char2b[8]; @@ -1560,20 +1605,18 @@ x_draw_glyphless_glyph_string_foreground (struct glyph_string *s) #define HIGHLIGHT_COLOR_DARK_BOOST_LIMIT 48000 -/* Allocate a color which is lighter or darker than *PIXEL by FACTOR - or DELTA. Try a color with RGB values multiplied by FACTOR first. - If this produces the same color as PIXEL, try a color where all RGB - values have DELTA added. Return the allocated color in *PIXEL. - DISPLAY is the X display, CMAP is the colormap to operate on. - Value is non-zero if successful. */ +/* Compute a color which is lighter or darker than *PIXEL by FACTOR or + DELTA. Try a color with RGB values multiplied by FACTOR first. If + this produces the same color as PIXEL, try a color where all RGB + values have DELTA added. Return the computed color in *PIXEL. F + is the frame to act on. */ -static bool -x_alloc_lighter_color (struct frame *f, unsigned long *pixel, double factor, - int delta) +static void +pgtk_compute_lighter_color (struct frame *f, unsigned long *pixel, + double factor, int delta) { Emacs_Color color, new; long bright; - bool success_p; /* Get RGB color values. */ color.pixel = *pixel; @@ -1613,33 +1656,28 @@ x_alloc_lighter_color (struct frame *f, unsigned long *pixel, double factor, } } - /* Try to allocate the color. */ - new.pixel = new.red >> 8 << 16 | new.green >> 8 << 8 | new.blue >> 8; - success_p = true; - if (success_p) + new.pixel = (new.red >> 8 << 16 + | new.green >> 8 << 8 + | new.blue >> 8); + + if (new.pixel == *pixel) { - if (new.pixel == *pixel) - { - /* If we end up with the same color as before, try adding - delta to the RGB values. */ - new.red = min (0xffff, delta + color.red); - new.green = min (0xffff, delta + color.green); - new.blue = min (0xffff, delta + color.blue); - new.pixel = - new.red >> 8 << 16 | new.green >> 8 << 8 | new.blue >> 8; - success_p = true; - } - else - success_p = true; - *pixel = new.pixel; + /* If we end up with the same color as before, try adding + delta to the RGB values. */ + new.red = min (0xffff, delta + color.red); + new.green = min (0xffff, delta + color.green); + new.blue = min (0xffff, delta + color.blue); + new.pixel = (new.red >> 8 << 16 + | new.green >> 8 << 8 + | new.blue >> 8); } - return success_p; + *pixel = new.pixel; } static void -x_fill_trapezoid_for_relief (struct frame *f, unsigned long color, int x, - int y, int width, int height, int top_p) +pgtk_fill_trapezoid_for_relief (struct frame *f, unsigned long color, int x, + int y, int width, int height, int top_p) { cairo_t *cr; @@ -1663,9 +1701,9 @@ enum corners }; static void -x_erase_corners_for_relief (struct frame *f, unsigned long color, int x, - int y, int width, int height, double radius, - double margin, int corners) +pgtk_erase_corners_for_relief (struct frame *f, unsigned long color, int x, + int y, int width, int height, double radius, + double margin, int corners) { cairo_t *cr; int i; @@ -1695,16 +1733,9 @@ x_erase_corners_for_relief (struct frame *f, unsigned long color, int x, pgtk_end_cr_clip (f); } -/* Set up the foreground color for drawing relief lines of glyph - string S. RELIEF is a pointer to a struct relief containing the GC - with which lines will be drawn. Use a color that is FACTOR or - DELTA lighter or darker than the relief's background which is found - in S->f->output_data.pgtk->relief_background. If such a color cannot - be allocated, use DEFAULT_PIXEL, instead. */ - static void -x_setup_relief_color (struct frame *f, struct relief *relief, double factor, - int delta, unsigned long default_pixel) +pgtk_setup_relief_color (struct frame *f, struct relief *relief, double factor, + int delta, unsigned long default_pixel) { Emacs_GC xgcv; struct pgtk_output *di = FRAME_X_OUTPUT (f); @@ -1714,16 +1745,15 @@ x_setup_relief_color (struct frame *f, struct relief *relief, double factor, /* Allocate new color. */ xgcv.foreground = default_pixel; pixel = background; - if (x_alloc_lighter_color (f, &pixel, factor, delta)) - xgcv.foreground = relief->pixel = pixel; + pgtk_compute_lighter_color (f, &pixel, factor, delta); + xgcv.foreground = relief->pixel = pixel; relief->xgcv = xgcv; } /* Set up colors for the relief lines around glyph string S. */ - static void -x_setup_relief_colors (struct glyph_string *s) +pgtk_setup_relief_colors (struct glyph_string *s) { struct pgtk_output *di = FRAME_X_OUTPUT (s->f); unsigned long color; @@ -1740,30 +1770,27 @@ x_setup_relief_colors (struct glyph_string *s) color = s->xgcv.background; } - if (TRUE) + if (!di->relief_background_valid_p + || di->relief_background != color) { + di->relief_background_valid_p = true; di->relief_background = color; - x_setup_relief_color (s->f, &di->white_relief, 1.2, 0x8000, - WHITE_PIX_DEFAULT (s->f)); - x_setup_relief_color (s->f, &di->black_relief, 0.6, 0x4000, - BLACK_PIX_DEFAULT (s->f)); + pgtk_setup_relief_color (s->f, &di->white_relief, 1.2, 0x8000, + WHITE_PIX_DEFAULT (s->f)); + pgtk_setup_relief_color (s->f, &di->black_relief, 0.6, 0x4000, + BLACK_PIX_DEFAULT (s->f)); } } - static void -x_set_clip_rectangles (struct frame *f, cairo_t * cr, XRectangle * rectangles, - int n) +pgtk_set_clip_rectangles (struct frame *f, cairo_t *cr, + XRectangle *rectangles, int n) { if (n > 0) { for (int i = 0; i < n; i++) - { - cairo_rectangle (cr, - rectangles[i].x, - rectangles[i].y, - rectangles[i].width, rectangles[i].height); - } + cairo_rectangle (cr, rectangles[i].x, rectangles[i].y, + rectangles[i].width, rectangles[i].height); cairo_clip (cr); } } @@ -1777,11 +1804,11 @@ x_set_clip_rectangles (struct frame *f, cairo_t * cr, XRectangle * rectangles, when drawing. */ static void -x_draw_relief_rect (struct frame *f, - int left_x, int top_y, int right_x, int bottom_y, - int hwidth, int vwidth, bool raised_p, bool top_p, - bool bot_p, bool left_p, bool right_p, - XRectangle * clip_rect) +pgtk_draw_relief_rect (struct frame *f, + int left_x, int top_y, int right_x, int bottom_y, + int hwidth, int vwidth, bool raised_p, bool top_p, + bool bot_p, bool left_p, bool right_p, + XRectangle *clip_rect) { unsigned long top_left_color, bottom_right_color; int corners = 0; @@ -1799,7 +1826,7 @@ x_draw_relief_rect (struct frame *f, bottom_right_color = FRAME_X_OUTPUT (f)->white_relief.xgcv.foreground; } - x_set_clip_rectangles (f, cr, clip_rect, 1); + pgtk_set_clip_rectangles (f, cr, clip_rect, 1); if (left_p) { @@ -1825,8 +1852,8 @@ x_draw_relief_rect (struct frame *f, pgtk_fill_rectangle (f, top_left_color, left_x, top_y, right_x + 1 - left_x, hwidth, false); else - x_fill_trapezoid_for_relief (f, top_left_color, left_x, top_y, - right_x + 1 - left_x, hwidth, 1); + pgtk_fill_trapezoid_for_relief (f, top_left_color, left_x, top_y, + right_x + 1 - left_x, hwidth, 1); } if (bot_p) { @@ -1835,9 +1862,9 @@ x_draw_relief_rect (struct frame *f, bottom_y + 1 - hwidth, right_x + 1 - left_x, hwidth, false); else - x_fill_trapezoid_for_relief (f, bottom_right_color, - left_x, bottom_y + 1 - hwidth, - right_x + 1 - left_x, hwidth, 0); + pgtk_fill_trapezoid_for_relief (f, bottom_right_color, + left_x, bottom_y + 1 - hwidth, + right_x + 1 - left_x, hwidth, 0); } if (left_p && vwidth > 1) pgtk_fill_rectangle (f, bottom_right_color, left_x, top_y, @@ -1846,11 +1873,9 @@ x_draw_relief_rect (struct frame *f, pgtk_fill_rectangle (f, bottom_right_color, left_x, top_y, right_x + 1 - left_x, 1, false); if (corners) - { - x_erase_corners_for_relief (f, FRAME_BACKGROUND_PIXEL (f), left_x, - top_y, right_x - left_x + 1, - bottom_y - top_y + 1, 6, 1, corners); - } + pgtk_erase_corners_for_relief (f, FRAME_BACKGROUND_PIXEL (f), left_x, + top_y, right_x - left_x + 1, + bottom_y - top_y + 1, 6, 1, corners); pgtk_end_cr_clip (f); } @@ -1863,10 +1888,10 @@ x_draw_relief_rect (struct frame *f, rectangle to use when drawing. */ static void -x_draw_box_rect (struct glyph_string *s, - int left_x, int top_y, int right_x, int bottom_y, int hwidth, - int vwidth, bool left_p, bool right_p, - XRectangle * clip_rect) +pgtk_draw_box_rect (struct glyph_string *s, int left_x, + int top_y, int right_x, int bottom_y, int hwidth, + int vwidth, bool left_p, bool right_p, + XRectangle * clip_rect) { unsigned long foreground_backup; @@ -1875,7 +1900,7 @@ x_draw_box_rect (struct glyph_string *s, foreground_backup = s->xgcv.foreground; s->xgcv.foreground = s->face->box_color; - x_set_clip_rectangles (s->f, cr, clip_rect, 1); + pgtk_set_clip_rectangles (s->f, cr, clip_rect, 1); /* Top. */ pgtk_fill_rectangle (s->f, s->xgcv.foreground, @@ -1908,7 +1933,7 @@ x_draw_box_rect (struct glyph_string *s, /* Draw a box around glyph string S. */ static void -x_draw_glyph_string_box (struct glyph_string *s) +pgtk_draw_glyph_string_box (struct glyph_string *s) { int hwidth, vwidth, left_x, right_x, top_y, bottom_y, last_x; bool raised_p, left_p, right_p; @@ -1941,26 +1966,20 @@ x_draw_glyph_string_box (struct glyph_string *s) get_glyph_string_clip_rect (s, &clip_rect); if (s->face->box == FACE_SIMPLE_BOX) - x_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth, - vwidth, left_p, right_p, &clip_rect); + pgtk_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, left_p, right_p, &clip_rect); else { - x_setup_relief_colors (s); - x_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, hwidth, - vwidth, raised_p, true, true, left_p, right_p, - &clip_rect); + pgtk_setup_relief_colors (s); + pgtk_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, raised_p, true, true, left_p, right_p, + &clip_rect); } } static void -x_get_scale_factor (int *scale_x, int *scale_y) -{ - *scale_x = *scale_y = 1; -} - -static void -x_draw_horizontal_wave (struct frame *f, unsigned long color, int x, int y, - int width, int height, int wave_length) +pgtk_draw_horizontal_wave (struct frame *f, unsigned long color, int x, int y, + int width, int height, int wave_length) { cairo_t *cr; double dx = wave_length, dy = height - 1; @@ -1999,34 +2018,19 @@ x_draw_horizontal_wave (struct frame *f, unsigned long color, int x, int y, pgtk_end_cr_clip (f); } -/* - Draw a wavy line under S. The wave fills wave_height pixels from y0. - - x0 wave_length = 2 - -- - y0 * * * * * - |* * * * * * * * * - wave_height = 3 | * * * * - -*/ static void -x_draw_underwave (struct glyph_string *s, unsigned long color) +pgtk_draw_underwave (struct glyph_string *s, unsigned long color) { - /* Adjust for scale/HiDPI. */ - int scale_x, scale_y; + int wave_height = 3, wave_length = 2; - x_get_scale_factor (&scale_x, &scale_y); - - int wave_height = 3 * scale_y, wave_length = 2 * scale_x; - - x_draw_horizontal_wave (s->f, color, s->x, s->ybase - wave_height + 3, - s->width, wave_height, wave_length); + pgtk_draw_horizontal_wave (s->f, color, s->x, s->ybase - wave_height + 3, + s->width, wave_height, wave_length); } /* Draw a relief around the image glyph string S. */ static void -x_draw_image_relief (struct glyph_string *s) +pgtk_draw_image_relief (struct glyph_string *s) { int x1, y1, thick; bool raised_p, top_p, bot_p, left_p, right_p; @@ -2109,33 +2113,29 @@ x_draw_image_relief (struct glyph_string *s) if (s->slice.y + s->slice.height == s->img->height) y1 += thick + extra_y, bot_p = true; - x_setup_relief_colors (s); + pgtk_setup_relief_colors (s); get_glyph_string_clip_rect (s, &r); - x_draw_relief_rect (s->f, x, y, x1, y1, thick, thick, raised_p, - top_p, bot_p, left_p, right_p, &r); + pgtk_draw_relief_rect (s->f, x, y, x1, y1, thick, thick, raised_p, + top_p, bot_p, left_p, right_p, &r); } /* Draw part of the background of glyph string S. X, Y, W, and H give the rectangle to draw. */ static void -x_draw_glyph_string_bg_rect (struct glyph_string *s, int x, int y, int w, - int h) +pgtk_draw_glyph_string_bg_rect (struct glyph_string *s, int x, int y, int w, + int h) { if (s->stippled_p) - { - /* Fill background with a stipple pattern. */ - - fill_background (s, x, y, w, h); - } + fill_background (s, x, y, w, h); else - x_clear_glyph_string_rect (s, x, y, w, h); + pgtk_clear_glyph_string_rect (s, x, y, w, h); } static void -x_cr_draw_image (struct frame *f, Emacs_GC *gc, cairo_pattern_t *image, - int src_x, int src_y, int width, int height, - int dest_x, int dest_y, bool overlay_p) +pgtk_cr_draw_image (struct frame *f, Emacs_GC *gc, cairo_pattern_t *image, + int src_x, int src_y, int width, int height, + int dest_x, int dest_y, bool overlay_p) { cairo_t *cr = pgtk_begin_cr_clip (f); @@ -2171,7 +2171,7 @@ x_cr_draw_image (struct frame *f, Emacs_GC *gc, cairo_pattern_t *image, /* Draw foreground of image glyph string S. */ static void -x_draw_image_foreground (struct glyph_string *s) +pgtk_draw_image_foreground (struct glyph_string *s) { int x = s->x; int y = s->ybase - image_ascent (s->img, s->face, &s->slice); @@ -2193,10 +2193,10 @@ x_draw_image_foreground (struct glyph_string *s) if (s->img->cr_data) { cairo_t *cr = pgtk_begin_cr_clip (s->f); - x_set_glyph_string_clipping (s, cr); - x_cr_draw_image (s->f, &s->xgcv, s->img->cr_data, - s->slice.x, s->slice.y, s->slice.width, s->slice.height, - x, y, true); + pgtk_set_glyph_string_clipping (s, cr); + pgtk_cr_draw_image (s->f, &s->xgcv, s->img->cr_data, + s->slice.x, s->slice.y, s->slice.width, s->slice.height, + x, y, true); if (!s->img->mask) { /* When the image has a mask, we can expect that at @@ -2208,9 +2208,9 @@ x_draw_image_foreground (struct glyph_string *s) if (s->hl == DRAW_CURSOR) { int relief = eabs (s->img->relief); - pgtk_draw_rectangle (s->f, s->xgcv.foreground, x - relief, y - relief, - s->slice.width + relief*2 - 1, - s->slice.height + relief*2 - 1, false); + pgtk_draw_rectangle (s->f, s->xgcv.foreground, x - relief, + y - relief, s->slice.width + relief * 2 - 1, + s->slice.height + relief * 2 - 1, false); } } pgtk_end_cr_clip (s->f); @@ -2236,7 +2236,7 @@ x_draw_image_foreground (struct glyph_string *s) */ static void -x_draw_image_glyph_string (struct glyph_string *s) +pgtk_draw_image_glyph_string (struct glyph_string *s) { int box_line_hwidth = max (s->face->box_vertical_line_width, 0); int box_line_vwidth = max (s->face->box_horizontal_line_width, 0); @@ -2259,41 +2259,39 @@ x_draw_image_glyph_string (struct glyph_string *s) || s->img->pixmap == 0 || s->width != s->background_width) { + int x = s->x; + int y = s->y; + int width = s->background_width; + + if (s->first_glyph->left_box_line_p + && s->slice.x == 0) { - int x = s->x; - int y = s->y; - int width = s->background_width; - - if (s->first_glyph->left_box_line_p - && s->slice.x == 0) - { - x += box_line_hwidth; - width -= box_line_hwidth; - } - - if (s->slice.y == 0) - y += box_line_vwidth; - - x_draw_glyph_string_bg_rect (s, x, y, width, height); + x += box_line_hwidth; + width -= box_line_hwidth; } + if (s->slice.y == 0) + y += box_line_vwidth; + + pgtk_draw_glyph_string_bg_rect (s, x, y, width, height); + s->background_filled_p = true; } /* Draw the foreground. */ - x_draw_image_foreground (s); + pgtk_draw_image_foreground (s); /* If we must draw a relief around the image, do it. */ if (s->img->relief || s->hl == DRAW_IMAGE_RAISED || s->hl == DRAW_IMAGE_SUNKEN) - x_draw_image_relief (s); + pgtk_draw_image_relief (s); } /* Draw stretch glyph string S. */ static void -x_draw_stretch_glyph_string (struct glyph_string *s) +pgtk_draw_stretch_glyph_string (struct glyph_string *s) { eassert (s->first_glyph->type == STRETCH_GLYPH); @@ -2329,7 +2327,7 @@ x_draw_stretch_glyph_string (struct glyph_string *s) x -= width; /* Draw cursor. */ - x_draw_glyph_string_bg_rect (s, x, s->y, width, s->height); + pgtk_draw_glyph_string_bg_rect (s, x, s->y, width, s->height); /* Clear rest using the GC of the original non-cursor face. */ if (width < background_width) @@ -2345,7 +2343,7 @@ x_draw_stretch_glyph_string (struct glyph_string *s) x = s->x; if (s->row->mouse_face_p && cursor_in_mouse_face_p (s->w)) { - x_set_mouse_face_gc (s); + pgtk_set_mouse_face_gc (s); color = s->xgcv.foreground; } else @@ -2354,18 +2352,13 @@ x_draw_stretch_glyph_string (struct glyph_string *s) cairo_t *cr = pgtk_begin_cr_clip (s->f); get_glyph_string_clip_rect (s, &r); - x_set_clip_rectangles (s->f, cr, &r, 1); + pgtk_set_clip_rectangles (s->f, cr, &r, 1); if (s->face->stipple) - { - /* Fill background with a stipple pattern. */ - fill_background (s, x, y, w, h); - } + fill_background (s, x, y, w, h); else - { - pgtk_fill_rectangle (s->f, color, x, y, w, h, - true); - } + pgtk_fill_rectangle (s->f, color, x, y, w, h, + true); pgtk_end_cr_clip (s->f); } @@ -2383,8 +2376,9 @@ x_draw_stretch_glyph_string (struct glyph_string *s) background_width -= text_left_x - x; x = text_left_x; } + if (background_width > 0) - x_draw_glyph_string_bg_rect (s, x, s->y, background_width, s->height); + pgtk_draw_glyph_string_bg_rect (s, x, s->y, background_width, s->height); } s->background_filled_p = true; @@ -2409,19 +2403,19 @@ pgtk_draw_glyph_string (struct glyph_string *s) if (next->first_glyph->type != IMAGE_GLYPH) { cairo_t *cr = pgtk_begin_cr_clip (next->f); - x_set_glyph_string_gc (next); - x_set_glyph_string_clipping (next, cr); + pgtk_set_glyph_string_gc (next); + pgtk_set_glyph_string_clipping (next, cr); if (next->first_glyph->type == STRETCH_GLYPH) - x_draw_stretch_glyph_string (next); + pgtk_draw_stretch_glyph_string (next); else - x_draw_glyph_string_background (next, true); + pgtk_draw_glyph_string_background (next, true); next->num_clips = 0; pgtk_end_cr_clip (next->f); } } /* Set up S->gc, set clipping and draw S. */ - x_set_glyph_string_gc (s); + pgtk_set_glyph_string_gc (s); cairo_t *cr = pgtk_begin_cr_clip (s->f); @@ -2433,10 +2427,10 @@ pgtk_draw_glyph_string (struct glyph_string *s) || s->first_glyph->type == COMPOSITE_GLYPH)) { - x_set_glyph_string_clipping (s, cr); - x_draw_glyph_string_background (s, true); - x_draw_glyph_string_box (s); - x_set_glyph_string_clipping (s, cr); + pgtk_set_glyph_string_clipping (s, cr); + pgtk_draw_glyph_string_background (s, true); + pgtk_draw_glyph_string_box (s); + pgtk_set_glyph_string_clipping (s, cr); relief_drawn_p = true; } else if (!s->clip_head /* draw_glyphs didn't specify a clip mask. */ @@ -2446,14 +2440,14 @@ pgtk_draw_glyph_string (struct glyph_string *s) /* We must clip just this glyph. left_overhang part has already drawn when s->prev was drawn, and right_overhang part will be drawn later when s->next is drawn. */ - x_set_glyph_string_clipping_exactly (s, s, cr); + pgtk_set_glyph_string_clipping_exactly (s, s, cr); else - x_set_glyph_string_clipping (s, cr); + pgtk_set_glyph_string_clipping (s, cr); switch (s->first_glyph->type) { case IMAGE_GLYPH: - x_draw_image_glyph_string (s); + pgtk_draw_image_glyph_string (s); break; case XWIDGET_GLYPH: @@ -2461,15 +2455,15 @@ pgtk_draw_glyph_string (struct glyph_string *s) break; case STRETCH_GLYPH: - x_draw_stretch_glyph_string (s); + pgtk_draw_stretch_glyph_string (s); break; case CHAR_GLYPH: if (s->for_overlaps) s->background_filled_p = true; else - x_draw_glyph_string_background (s, false); - x_draw_glyph_string_foreground (s); + pgtk_draw_glyph_string_background (s, false); + pgtk_draw_glyph_string_foreground (s); break; case COMPOSITE_GLYPH: @@ -2477,16 +2471,16 @@ pgtk_draw_glyph_string (struct glyph_string *s) && !s->first_glyph->u.cmp.automatic)) s->background_filled_p = true; else - x_draw_glyph_string_background (s, true); - x_draw_composite_glyph_string_foreground (s); + pgtk_draw_glyph_string_background (s, true); + pgtk_draw_composite_glyph_string_foreground (s); break; case GLYPHLESS_GLYPH: if (s->for_overlaps) s->background_filled_p = true; else - x_draw_glyph_string_background (s, true); - x_draw_glyphless_glyph_string_foreground (s); + pgtk_draw_glyph_string_background (s, true); + pgtk_draw_glyphless_glyph_string_foreground (s); break; default: @@ -2497,7 +2491,7 @@ pgtk_draw_glyph_string (struct glyph_string *s) { /* Draw relief if not yet drawn. */ if (!relief_drawn_p && s->face->box != FACE_NO_BOX) - x_draw_glyph_string_box (s); + pgtk_draw_glyph_string_box (s); /* Draw underline. */ if (s->face->underline) @@ -2505,10 +2499,10 @@ pgtk_draw_glyph_string (struct glyph_string *s) if (s->face->underline == FACE_UNDER_WAVE) { if (s->face->underline_defaulted_p) - x_draw_underwave (s, s->xgcv.foreground); + pgtk_draw_underwave (s, s->xgcv.foreground); else { - x_draw_underwave (s, s->face->underline_color); + pgtk_draw_underwave (s, s->face->underline_color); } } else if (s->face->underline == FACE_UNDER_LINE) @@ -2595,10 +2589,8 @@ pgtk_draw_glyph_string (struct glyph_string *s) pgtk_fill_rectangle (s->f, s->xgcv.foreground, s->x, s->y + dy, s->width, h, false); else - { - pgtk_fill_rectangle (s->f, s->face->overline_color, s->x, - s->y + dy, s->width, h, false); - } + pgtk_fill_rectangle (s->f, s->face->overline_color, s->x, + s->y + dy, s->width, h, false); } /* Draw strike-through. */ @@ -2620,10 +2612,8 @@ pgtk_draw_glyph_string (struct glyph_string *s) pgtk_fill_rectangle (s->f, s->xgcv.foreground, s->x, glyph_y + dy, s->width, h, false); else - { - pgtk_fill_rectangle (s->f, s->face->strike_through_color, s->x, - glyph_y + dy, s->width, h, false); - } + pgtk_fill_rectangle (s->f, s->face->strike_through_color, s->x, + glyph_y + dy, s->width, h, false); } if (s->prev) @@ -2639,13 +2629,13 @@ pgtk_draw_glyph_string (struct glyph_string *s) enum draw_glyphs_face save = prev->hl; prev->hl = s->hl; - x_set_glyph_string_gc (prev); + pgtk_set_glyph_string_gc (prev); cairo_save (cr); - x_set_glyph_string_clipping_exactly (s, prev, cr); + pgtk_set_glyph_string_clipping_exactly (s, prev, cr); if (prev->first_glyph->type == CHAR_GLYPH) - x_draw_glyph_string_foreground (prev); + pgtk_draw_glyph_string_foreground (prev); else - x_draw_composite_glyph_string_foreground (prev); + pgtk_draw_composite_glyph_string_foreground (prev); prev->hl = save; prev->num_clips = 0; cairo_restore (cr); @@ -2665,13 +2655,13 @@ pgtk_draw_glyph_string (struct glyph_string *s) enum draw_glyphs_face save = next->hl; next->hl = s->hl; - x_set_glyph_string_gc (next); + pgtk_set_glyph_string_gc (next); cairo_save (cr); - x_set_glyph_string_clipping_exactly (s, next, cr); + pgtk_set_glyph_string_clipping_exactly (s, next, cr); if (next->first_glyph->type == CHAR_GLYPH) - x_draw_glyph_string_foreground (next); + pgtk_draw_glyph_string_foreground (next); else - x_draw_composite_glyph_string_foreground (next); + pgtk_draw_composite_glyph_string_foreground (next); cairo_restore (cr); next->hl = save; next->num_clips = 0; @@ -2736,7 +2726,7 @@ pgtk_clear_frame_area (struct frame *f, int x, int y, int width, int height) /* Draw a hollow box cursor on window W in glyph row ROW. */ static void -x_draw_hollow_cursor (struct window *w, struct glyph_row *row) +pgtk_draw_hollow_cursor (struct window *w, struct glyph_row *row) { struct frame *f = XFRAME (WINDOW_FRAME (w)); int x, y, wd, h; @@ -2769,7 +2759,8 @@ x_draw_hollow_cursor (struct window *w, struct glyph_row *row) } /* Set clipping, draw the rectangle, and reset clipping again. */ pgtk_clip_to_row (w, row, TEXT_AREA, cr); - pgtk_draw_rectangle (f, FRAME_X_OUTPUT (f)->cursor_color, x, y, wd, h - 1, false); + pgtk_draw_rectangle (f, FRAME_X_OUTPUT (f)->cursor_color, + x, y, wd, h - 1, false); pgtk_end_cr_clip (f); } @@ -2781,7 +2772,7 @@ x_draw_hollow_cursor (struct window *w, struct glyph_row *row) --gerd. */ static void -x_draw_bar_cursor (struct window *w, struct glyph_row *row, int width, +pgtk_draw_bar_cursor (struct window *w, struct glyph_row *row, int width, enum text_cursor_kinds kind) { struct frame *f = XFRAME (w->frame); @@ -2879,6 +2870,7 @@ pgtk_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, int x, int cursor_width, bool on_p, bool active_p) { struct frame *f = XFRAME (w->frame); + if (on_p) { w->phys_cursor_type = cursor_type; @@ -2897,7 +2889,7 @@ pgtk_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, int x, switch (cursor_type) { case HOLLOW_BOX_CURSOR: - x_draw_hollow_cursor (w, glyph_row); + pgtk_draw_hollow_cursor (w, glyph_row); break; case FILLED_BOX_CURSOR: @@ -2905,11 +2897,11 @@ pgtk_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, int x, break; case BAR_CURSOR: - x_draw_bar_cursor (w, glyph_row, cursor_width, BAR_CURSOR); + pgtk_draw_bar_cursor (w, glyph_row, cursor_width, BAR_CURSOR); break; case HBAR_CURSOR: - x_draw_bar_cursor (w, glyph_row, cursor_width, HBAR_CURSOR); + pgtk_draw_bar_cursor (w, glyph_row, cursor_width, HBAR_CURSOR); break; case NO_CURSOR: @@ -2939,20 +2931,13 @@ pgtk_copy_bits (struct frame *f, cairo_rectangle_t *src_rect, cairo_rectangle_t *dst_rect) { cairo_t *cr; - GdkWindow *window; cairo_surface_t *surface; /* temporary surface */ - int scale; - window = gtk_widget_get_window (FRAME_GTK_WIDGET (f)); - - surface = - gdk_window_create_similar_surface (window, CAIRO_CONTENT_COLOR_ALPHA, - FRAME_CR_SURFACE_DESIRED_WIDTH (f), - FRAME_CR_SURFACE_DESIRED_HEIGHT - (f)); - - scale = gtk_widget_get_scale_factor (FRAME_GTK_WIDGET (f)); - cairo_surface_set_device_scale (surface, scale, scale); + surface + = cairo_surface_create_similar (FRAME_CR_SURFACE (f), + CAIRO_CONTENT_COLOR_ALPHA, + (int) src_rect->width, + (int) src_rect->height); cr = cairo_create (surface); cairo_set_source_surface (cr, FRAME_CR_SURFACE (f), -src_rect->x, @@ -3172,10 +3157,9 @@ pgtk_bitmap_icon (struct frame *f, Lisp_Object file) } if (FRAME_DISPLAY_INFO (f)->bitmaps[bitmap_id - 1].img != NULL) - { - gtk_window_set_icon (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), - FRAME_DISPLAY_INFO (f)->bitmaps[bitmap_id - 1].img); - } + gtk_window_set_icon (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)), + FRAME_DISPLAY_INFO (f)->bitmaps[bitmap_id - 1].img); + f->output_data.pgtk->icon_bitmap = bitmap_id; return false; @@ -3335,8 +3319,8 @@ pgtk_frame_up_to_date (struct frame *f) static void pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window, - enum scroll_bar_part *part, Lisp_Object * x, - Lisp_Object * y, Time * timestamp) + enum scroll_bar_part *part, Lisp_Object *x, + Lisp_Object *y, Time *timestamp) { struct frame *f1; struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (*fp); @@ -3345,6 +3329,7 @@ pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window, GdkDevice *device; GdkModifierType mask; GdkWindow *win; + bool return_frame_flag = false; block_input (); @@ -3358,30 +3343,37 @@ pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window, dpyinfo->last_mouse_scroll_bar = NULL; - if (gui_mouse_grabbed (dpyinfo)) + if (gui_mouse_grabbed (dpyinfo) + && (!EQ (track_mouse, Qdropping) + && !EQ (track_mouse, Qdrag_source))) { - /* 1.1. use last_mouse_frame as frame where the pointer is on. */ + /* 1.1. use last_mouse_frame as frame where the pointer is + on. */ f1 = dpyinfo->last_mouse_frame; } else { f1 = *fp; - /* 1.2. get frame where the pointer is on. */ + /* 1.2. get frame where the pointer is on. */ win = gtk_widget_get_window (FRAME_GTK_WIDGET (*fp)); seat = gdk_display_get_default_seat (dpyinfo->gdpy); device = gdk_seat_get_pointer (seat); - win = - gdk_window_get_device_position (win, device, &win_x, &win_y, &mask); + win = gdk_window_get_device_position (win, device, &win_x, + &win_y, &mask); if (win != NULL) f1 = pgtk_any_window_to_frame (win); else { - /* crossing display server? */ f1 = SELECTED_FRAME (); + + if (!FRAME_PGTK_P (f1)) + f1 = dpyinfo->last_mouse_frame; + + return_frame_flag = EQ (track_mouse, Qdrag_source); } } - /* f1 can be a terminal frame. Bug#50322 */ + /* F1 can be a terminal frame. (Bug#50322) */ if (f1 == NULL || !FRAME_PGTK_P (f1)) { unblock_input (); @@ -3405,7 +3397,7 @@ pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window, *bar_window = Qnil; *part = 0; - *fp = f1; + *fp = !return_frame_flag ? f1 : NULL; XSETINT (*x, win_x); XSETINT (*y, win_y); *timestamp = dpyinfo->last_mouse_movement_time; @@ -3431,10 +3423,10 @@ pgtk_define_fringe_bitmap (int which, unsigned short *bits, int h, int wd) { i = max_fringe_bmp; max_fringe_bmp = which + 20; - fringe_bmp = - (cairo_pattern_t **) xrealloc (fringe_bmp, - max_fringe_bmp * - sizeof (cairo_pattern_t *)); + fringe_bmp + = (cairo_pattern_t **) xrealloc (fringe_bmp, + max_fringe_bmp * + sizeof (cairo_pattern_t *)); while (i < max_fringe_bmp) fringe_bmp[i++] = 0; } @@ -3494,41 +3486,6 @@ pgtk_clip_to_row (struct window *w, struct glyph_row *row, cairo_clip (cr); } -static void -pgtk_cr_draw_image (struct frame *f, Emacs_GC * gc, cairo_pattern_t * image, - int src_x, int src_y, int width, int height, - int dest_x, int dest_y, bool overlay_p) -{ - cairo_t *cr = pgtk_begin_cr_clip (f); - - if (overlay_p) - cairo_rectangle (cr, dest_x, dest_y, width, height); - else - { - pgtk_set_cr_source_with_gc_background (f, gc, false); - cairo_rectangle (cr, dest_x, dest_y, width, height); - cairo_fill_preserve (cr); - } - cairo_translate (cr, dest_x - src_x, dest_y - src_y); - - cairo_surface_t *surface; - cairo_pattern_get_surface (image, &surface); - cairo_format_t format = cairo_image_surface_get_format (surface); - if (format != CAIRO_FORMAT_A8 && format != CAIRO_FORMAT_A1) - { - cairo_set_source (cr, image); - cairo_fill (cr); - } - else - { - pgtk_set_cr_source_with_gc_foreground (f, gc, false); - cairo_clip (cr); - cairo_mask (cr, image); - } - - pgtk_end_cr_clip (f); -} - static void pgtk_draw_fringe_bitmap (struct window *w, struct glyph_row *row, struct draw_fringe_bitmap_params *p) @@ -3543,10 +3500,10 @@ pgtk_draw_fringe_bitmap (struct window *w, struct glyph_row *row, if (p->bx >= 0 && !p->overlay_p) { - /* In case the same realized face is used for fringes and - for something displayed in the text (e.g. face `region' on + /* In case the same realized face is used for fringes and for + something displayed in the text (e.g. face `region' on mono-displays, the fill style may have been changed to - FillSolid in x_draw_glyph_string_background. */ + FillSolid in pgtk_draw_glyph_string_background. */ if (face->stipple) { fill_background_by_face (f, face, p->bx, p->by, p->nx, p->ny); @@ -3594,7 +3551,8 @@ static int hourglass_enter_count = 0; static void hourglass_cb (struct atimer *timer) { - /*NOP*/} + +} static void pgtk_show_hourglass (struct frame *f) @@ -3602,7 +3560,9 @@ pgtk_show_hourglass (struct frame *f) struct pgtk_output *x = FRAME_X_OUTPUT (f); if (x->hourglass_widget != NULL) gtk_widget_destroy (x->hourglass_widget); - x->hourglass_widget = gtk_event_box_new (); /* gtk_event_box is GDK_INPUT_ONLY. */ + + /* This creates a GDK_INPUT_ONLY window. */ + x->hourglass_widget = gtk_event_box_new (); gtk_widget_set_has_window (x->hourglass_widget, true); gtk_fixed_put (GTK_FIXED (FRAME_GTK_WIDGET (f)), x->hourglass_widget, 0, 0); gtk_widget_show (x->hourglass_widget); @@ -3611,17 +3571,16 @@ pgtk_show_hourglass (struct frame *f) gdk_window_set_cursor (gtk_widget_get_window (x->hourglass_widget), x->hourglass_cursor); - /* For cursor animation, we receive signals, set pending_signals, and dispatch. */ + /* For cursor animation, we receive signals, set pending_signals, + and wait for the signal handler to run. */ if (hourglass_enter_count++ == 0) { struct timespec ts = make_timespec (0, 50 * 1000 * 1000); if (hourglass_atimer != NULL) cancel_atimer (hourglass_atimer); - hourglass_atimer = - start_atimer (ATIMER_CONTINUOUS, ts, hourglass_cb, NULL); + hourglass_atimer + = start_atimer (ATIMER_CONTINUOUS, ts, hourglass_cb, NULL); } - - /* Cursor frequently stops animation. gtk's bug? */ } static void @@ -3682,35 +3641,19 @@ static struct redisplay_interface pgtk_redisplay_interface = { pgtk_default_font_parameter, }; -static void -pgtk_redraw_scroll_bars (struct frame *f) -{ -} - void pgtk_clear_frame (struct frame *f) -/* -------------------------------------------------------------------------- - External (hook): Erase the entire frame - -------------------------------------------------------------------------- */ { - /* comes on initial frame because we have - after-make-frame-functions = select-frame */ if (!FRAME_DEFAULT_FACE (f)) return; - /* mark_window_cursors_off (XWINDOW (FRAME_ROOT_WINDOW (f))); */ + mark_window_cursors_off (XWINDOW (FRAME_ROOT_WINDOW (f))); block_input (); - pgtk_clear_area (f, 0, 0, FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f)); - - /* as of 2006/11 or so this is now needed */ - pgtk_redraw_scroll_bars (f); unblock_input (); } -/* Invert the middle quarter of the frame for .15 sec. */ - static void recover_from_visible_bell (struct atimer *timer) { @@ -3726,86 +3669,90 @@ recover_from_visible_bell (struct atimer *timer) FRAME_X_OUTPUT (f)->atimer_visible_bell = NULL; } +/* Invert the middle quarter of the frame for .15 sec. */ + static void pgtk_flash (struct frame *f) { - { - if (!FRAME_CR_CONTEXT (f)) - return; + cairo_surface_t *surface_orig, *surface; + cairo_t *cr; + int width, height, flash_height, flash_left, flash_right; + struct timespec delay; - block_input (); + if (!FRAME_CR_CONTEXT (f)) + return; - cairo_surface_t *surface_orig = FRAME_CR_SURFACE (f); + block_input (); - int width = FRAME_CR_SURFACE_DESIRED_WIDTH (f); - int height = FRAME_CR_SURFACE_DESIRED_HEIGHT (f); - cairo_surface_t *surface = - cairo_surface_create_similar (surface_orig, CAIRO_CONTENT_COLOR_ALPHA, - width, height); + surface_orig = FRAME_CR_SURFACE (f); - cairo_t *cr = cairo_create (surface); - cairo_set_source_surface (cr, surface_orig, 0, 0); - cairo_rectangle (cr, 0, 0, width, height); - cairo_clip (cr); - cairo_paint (cr); + width = FRAME_CR_SURFACE_DESIRED_WIDTH (f); + height = FRAME_CR_SURFACE_DESIRED_HEIGHT (f); + surface = cairo_surface_create_similar (surface_orig, + CAIRO_CONTENT_COLOR_ALPHA, + width, height); - cairo_set_source_rgb (cr, 1, 1, 1); - cairo_set_operator (cr, CAIRO_OPERATOR_DIFFERENCE); + cr = cairo_create (surface); + cairo_set_source_surface (cr, surface_orig, 0, 0); + cairo_rectangle (cr, 0, 0, width, height); + cairo_clip (cr); + cairo_paint (cr); + cairo_set_source_rgb (cr, 1, 1, 1); + cairo_set_operator (cr, CAIRO_OPERATOR_DIFFERENCE); + + /* Get the height not including a menu bar widget. */ + height = FRAME_PIXEL_HEIGHT (f); + /* Height of each line to flash. */ + flash_height = FRAME_LINE_HEIGHT (f); + /* These will be the left and right margins of the rectangles. */ + flash_left = FRAME_INTERNAL_BORDER_WIDTH (f); + flash_right = (FRAME_PIXEL_WIDTH (f) + - FRAME_INTERNAL_BORDER_WIDTH (f)); + width = flash_right - flash_left; + + /* If window is tall, flash top and bottom line. */ + if (height > 3 * FRAME_LINE_HEIGHT (f)) { - /* Get the height not including a menu bar widget. */ - int height = FRAME_PIXEL_HEIGHT (f); - /* Height of each line to flash. */ - int flash_height = FRAME_LINE_HEIGHT (f); - /* These will be the left and right margins of the rectangles. */ - int flash_left = FRAME_INTERNAL_BORDER_WIDTH (f); - int flash_right = - FRAME_PIXEL_WIDTH (f) - FRAME_INTERNAL_BORDER_WIDTH (f); - int width = flash_right - flash_left; - - /* If window is tall, flash top and bottom line. */ - if (height > 3 * FRAME_LINE_HEIGHT (f)) - { - cairo_rectangle (cr, - flash_left, - (FRAME_INTERNAL_BORDER_WIDTH (f) - + FRAME_TOP_MARGIN_HEIGHT (f)), - width, flash_height); - cairo_fill (cr); - - cairo_rectangle (cr, - flash_left, - (height - flash_height - - FRAME_INTERNAL_BORDER_WIDTH (f)), - width, flash_height); - cairo_fill (cr); - } - else - { - /* If it is short, flash it all. */ - cairo_rectangle (cr, - flash_left, FRAME_INTERNAL_BORDER_WIDTH (f), - width, height - 2 * FRAME_INTERNAL_BORDER_WIDTH (f)); - cairo_fill (cr); - } - - FRAME_X_OUTPUT (f)->cr_surface_visible_bell = surface; - { - struct timespec delay = make_timespec (0, 50 * 1000 * 1000); - if (FRAME_X_OUTPUT (f)->atimer_visible_bell != NULL) - { - cancel_atimer (FRAME_X_OUTPUT (f)->atimer_visible_bell); - FRAME_X_OUTPUT (f)->atimer_visible_bell = NULL; - } - FRAME_X_OUTPUT (f)->atimer_visible_bell = - start_atimer (ATIMER_RELATIVE, delay, recover_from_visible_bell, f); - } + cairo_rectangle (cr, + flash_left, + (FRAME_INTERNAL_BORDER_WIDTH (f) + + FRAME_TOP_MARGIN_HEIGHT (f)), + width, flash_height); + cairo_fill (cr); + cairo_rectangle (cr, + flash_left, + (height - flash_height + - FRAME_INTERNAL_BORDER_WIDTH (f)), + width, flash_height); + cairo_fill (cr); + } + else + { + /* If it is short, flash it all. */ + cairo_rectangle (cr, + flash_left, FRAME_INTERNAL_BORDER_WIDTH (f), + width, height - 2 * FRAME_INTERNAL_BORDER_WIDTH (f)); + cairo_fill (cr); } - cairo_destroy (cr); - unblock_input (); - } + FRAME_X_OUTPUT (f)->cr_surface_visible_bell = surface; + + delay = make_timespec (0, 50 * 1000 * 1000); + + if (FRAME_X_OUTPUT (f)->atimer_visible_bell != NULL) + { + cancel_atimer (FRAME_X_OUTPUT (f)->atimer_visible_bell); + FRAME_X_OUTPUT (f)->atimer_visible_bell = NULL; + } + + FRAME_X_OUTPUT (f)->atimer_visible_bell + = start_atimer (ATIMER_RELATIVE, delay, recover_from_visible_bell, f); + + + cairo_destroy (cr); + unblock_input (); } /* Make audible bell. */ @@ -3886,8 +3833,9 @@ pgtk_send_scroll_bar_event (Lisp_Object window, enum scroll_bar_part part, EVENT_INIT (inev.ie); - inev.ie.kind = - horizontal ? HORIZONTAL_SCROLL_BAR_CLICK_EVENT : SCROLL_BAR_CLICK_EVENT; + inev.ie.kind = (horizontal + ? HORIZONTAL_SCROLL_BAR_CLICK_EVENT + : SCROLL_BAR_CLICK_EVENT); inev.ie.frame_or_window = window; inev.ie.arg = Qnil; inev.ie.timestamp = 0; @@ -3919,28 +3867,21 @@ xg_scroll_callback (GtkRange * range, switch (scroll) { case GTK_SCROLL_JUMP: -#if 0 - /* Buttons 1 2 or 3 must be grabbed. */ - if (FRAME_DISPLAY_INFO (f)->grabbed != 0 - && FRAME_DISPLAY_INFO (f)->grabbed < (1 << 4)) -#endif - { - if (bar->horizontal) - { - part = scroll_bar_horizontal_handle; - whole = (int) (gtk_adjustment_get_upper (adj) - - gtk_adjustment_get_page_size (adj)); - portion = min ((int) value, whole); - bar->dragging = portion; - } - else - { - part = scroll_bar_handle; - whole = gtk_adjustment_get_upper (adj) - - gtk_adjustment_get_page_size (adj); - portion = min ((int) value, whole); - bar->dragging = portion; - } + if (bar->horizontal) + { + part = scroll_bar_horizontal_handle; + whole = (int) (gtk_adjustment_get_upper (adj) - + gtk_adjustment_get_page_size (adj)); + portion = min ((int) value, whole); + bar->dragging = portion; + } + else + { + part = scroll_bar_handle; + whole = gtk_adjustment_get_upper (adj) - + gtk_adjustment_get_page_size (adj); + portion = min ((int) value, whole); + bar->dragging = portion; } break; case GTK_SCROLL_STEP_BACKWARD: @@ -4002,7 +3943,7 @@ xg_end_scroll_callback (GtkWidget * widget, and X window of the scroll bar in BAR. */ static void -x_create_toolkit_scroll_bar (struct frame *f, struct scroll_bar *bar) +pgtk_create_toolkit_scroll_bar (struct frame *f, struct scroll_bar *bar) { const char *scroll_bar_name = SCROLL_BAR_NAME; @@ -4013,8 +3954,8 @@ x_create_toolkit_scroll_bar (struct frame *f, struct scroll_bar *bar) } static void -x_create_horizontal_toolkit_scroll_bar (struct frame *f, - struct scroll_bar *bar) +pgtk_create_horizontal_toolkit_scroll_bar (struct frame *f, + struct scroll_bar *bar) { const char *scroll_bar_name = SCROLL_BAR_HORIZONTAL_NAME; @@ -4029,30 +3970,28 @@ x_create_horizontal_toolkit_scroll_bar (struct frame *f, displaying PORTION out of a whole WHOLE, and our position POSITION. */ static void -x_set_toolkit_scroll_bar_thumb (struct scroll_bar *bar, int portion, - int position, int whole) +pgtk_set_toolkit_scroll_bar_thumb (struct scroll_bar *bar, int portion, + int position, int whole) { xg_set_toolkit_scroll_bar_thumb (bar, portion, position, whole); } static void -x_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar, - int portion, int position, - int whole) +pgtk_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar, + int portion, int position, + int whole) { xg_set_toolkit_horizontal_scroll_bar_thumb (bar, portion, position, whole); } - - /* Create a scroll bar and return the scroll bar vector for it. W is the Emacs window on which to create the scroll bar. TOP, LEFT, WIDTH and HEIGHT are the pixel coordinates and dimensions of the scroll bar. */ static struct scroll_bar * -x_scroll_bar_create (struct window *w, int top, int left, - int width, int height, bool horizontal) +pgtk_scroll_bar_create (struct window *w, int top, int left, + int width, int height, bool horizontal) { struct frame *f = XFRAME (w->frame); struct scroll_bar *bar @@ -4062,9 +4001,9 @@ x_scroll_bar_create (struct window *w, int top, int left, block_input (); if (horizontal) - x_create_horizontal_toolkit_scroll_bar (f, bar); + pgtk_create_horizontal_toolkit_scroll_bar (f, bar); else - x_create_toolkit_scroll_bar (f, bar); + pgtk_create_toolkit_scroll_bar (f, bar); XSETWINDOW (bar->window, w); bar->top = top; @@ -4102,7 +4041,7 @@ x_scroll_bar_create (struct window *w, int top, int left, nil. */ static void -x_scroll_bar_remove (struct scroll_bar *bar) +pgtk_scroll_bar_remove (struct scroll_bar *bar) { struct frame *f = XFRAME (WINDOW_FRAME (XWINDOW (bar->window))); block_input (); @@ -4150,7 +4089,7 @@ pgtk_set_vertical_scroll_bar (struct window *w, int portion, int whole, unblock_input (); } - bar = x_scroll_bar_create (w, top, left, width, max (height, 1), false); + bar = pgtk_scroll_bar_create (w, top, left, width, max (height, 1), false); } else { @@ -4190,13 +4129,12 @@ pgtk_set_vertical_scroll_bar (struct window *w, int portion, int whole, unblock_input (); } - x_set_toolkit_scroll_bar_thumb (bar, portion, position, whole); + pgtk_set_toolkit_scroll_bar_thumb (bar, portion, position, whole); XSETVECTOR (barobj, bar); wset_vertical_scroll_bar (w, barobj); } - static void pgtk_set_horizontal_scroll_bar (struct window *w, int portion, int whole, int position) @@ -4228,7 +4166,7 @@ pgtk_set_horizontal_scroll_bar (struct window *w, int portion, int whole, unblock_input (); } - bar = x_scroll_bar_create (w, top, left, width, height, true); + bar = pgtk_scroll_bar_create (w, top, left, width, height, true); } else { @@ -4271,7 +4209,7 @@ pgtk_set_horizontal_scroll_bar (struct window *w, int portion, int whole, unblock_input (); } - x_set_toolkit_horizontal_scroll_bar_thumb (bar, portion, position, whole); + pgtk_set_toolkit_horizontal_scroll_bar_thumb (bar, portion, position, whole); XSETVECTOR (barobj, bar); wset_horizontal_scroll_bar (w, barobj); @@ -4311,7 +4249,6 @@ pgtk_condemn_scroll_bars (struct frame *frame) } } - /* Un-mark WINDOW's scroll bar for deletion in this judgment cycle. Note that WINDOW isn't necessarily condemned at all. */ @@ -4415,7 +4352,7 @@ pgtk_judge_scroll_bars (struct frame *f) { struct scroll_bar *b = XSCROLL_BAR (bar); - x_scroll_bar_remove (b); + pgtk_scroll_bar_remove (b); next = b->next; b->next = b->prev = Qnil; @@ -4496,15 +4433,22 @@ pgtk_delete_terminal (struct terminal *terminal) g_clear_object (&dpyinfo->vertical_scroll_bar_cursor); g_clear_object (&dpyinfo->horizontal_scroll_bar_cursor); g_clear_object (&dpyinfo->invisible_cursor); - if (dpyinfo->last_click_event != NULL) { - gdk_event_free (dpyinfo->last_click_event); - dpyinfo->last_click_event = NULL; - } + if (dpyinfo->last_click_event != NULL) + { + gdk_event_free (dpyinfo->last_click_event); + dpyinfo->last_click_event = NULL; + } + /* Disconnect these handlers before the display closes so + useless removal signals don't fire. */ + g_signal_handlers_disconnect_by_func (G_OBJECT (dpyinfo->gdpy), + G_CALLBACK (pgtk_seat_added_cb), + dpyinfo); + g_signal_handlers_disconnect_by_func (G_OBJECT (dpyinfo->gdpy), + G_CALLBACK (pgtk_seat_removed_cb), + dpyinfo); xg_display_close (dpyinfo->gdpy); - /* Do not close the connection here because it's already closed - by X(t)CloseDisplay (Bug#18403). */ dpyinfo->gdpy = NULL; } @@ -4528,7 +4472,7 @@ pgtk_query_frame_background_color (struct frame *f, Emacs_Color * bgcolor) } static void -pgtk_free_pixmap (struct frame *_f, Emacs_Pixmap pixmap) +pgtk_free_pixmap (struct frame *f, Emacs_Pixmap pixmap) { if (pixmap) { @@ -4552,17 +4496,18 @@ pgtk_focus_frame (struct frame *f, bool noactivate) } } - static void -set_opacity_recursively (GtkWidget * w, gpointer data) +set_opacity_recursively (GtkWidget *w, gpointer data) { gtk_widget_set_opacity (w, *(double *) data); + if (GTK_IS_CONTAINER (w)) - gtk_container_foreach (GTK_CONTAINER (w), set_opacity_recursively, data); + gtk_container_foreach (GTK_CONTAINER (w), + set_opacity_recursively, data); } static void -x_set_frame_alpha (struct frame *f) +pgtk_set_frame_alpha (struct frame *f) { struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); double alpha = 1.0; @@ -4594,22 +4539,13 @@ x_set_frame_alpha (struct frame *f) static void frame_highlight (struct frame *f) { - /* We used to only do this if Vx_no_window_manager was non-nil, but - the ICCCM (section 4.1.6) says that the window's border pixmap - and border pixel are window attributes which are "private to the - client", so we can always change it to whatever we want. */ block_input (); - /* I recently started to get errors in this XSetWindowBorder, depending on - the window-manager in use, tho something more is at play since I've been - using that same window-manager binary for ever. Let's not crash just - because of this (bug#9310). */ - GtkWidget *w = FRAME_WIDGET (f); - char *css = - g_strdup_printf ("decoration { border: solid %dpx #%06x; }", - f->border_width, - (unsigned int) FRAME_X_OUTPUT (f)->border_pixel & 0x00ffffff); + char *css = g_strdup_printf ("decoration { border: solid %dpx #%06x; }", + f->border_width, + ((unsigned int) FRAME_X_OUTPUT (f)->border_pixel + & 0x00ffffff)); GtkStyleContext *ctxt = gtk_widget_get_style_context (w); GtkCssProvider *css_provider = gtk_css_provider_new (); @@ -4628,33 +4564,32 @@ frame_highlight (struct frame *f) unblock_input (); gui_update_cursor (f, true); - x_set_frame_alpha (f); + pgtk_set_frame_alpha (f); } static void frame_unhighlight (struct frame *f) { - /* We used to only do this if Vx_no_window_manager was non-nil, but - the ICCCM (section 4.1.6) says that the window's border pixmap - and border pixel are window attributes which are "private to the - client", so we can always change it to whatever we want. */ + GtkWidget *w; + char *css; + GtkStyleContext *ctxt; + GtkCssProvider *css_provider, *old; + block_input (); - /* Same as above for XSetWindowBorder (bug#9310). */ - GtkWidget *w = FRAME_WIDGET (f); + w = FRAME_WIDGET (f); - char *css = - g_strdup_printf ("decoration { border: dotted %dpx #ffffff; }", - f->border_width); + css = g_strdup_printf ("decoration { border: dotted %dpx #ffffff; }", + f->border_width); - GtkStyleContext *ctxt = gtk_widget_get_style_context (w); - GtkCssProvider *css_provider = gtk_css_provider_new (); + ctxt = gtk_widget_get_style_context (w); + css_provider = gtk_css_provider_new (); gtk_css_provider_load_from_data (css_provider, css, -1, NULL); gtk_style_context_add_provider (ctxt, GTK_STYLE_PROVIDER (css_provider), GTK_STYLE_PROVIDER_PRIORITY_USER); g_free (css); - GtkCssProvider *old = FRAME_X_OUTPUT (f)->border_color_css_provider; + old = FRAME_X_OUTPUT (f)->border_color_css_provider; FRAME_X_OUTPUT (f)->border_color_css_provider = css_provider; if (old != NULL) { @@ -4664,7 +4599,7 @@ frame_unhighlight (struct frame *f) unblock_input (); gui_update_cursor (f, true); - x_set_frame_alpha (f); + pgtk_set_frame_alpha (f); } @@ -4703,16 +4638,15 @@ pgtk_frame_rehighlight (struct pgtk_display_info *dpyinfo) the appropriate X display info. */ static void -XTframe_rehighlight (struct frame *frame) +pgtk_frame_rehighlight_hook (struct frame *frame) { pgtk_frame_rehighlight (FRAME_DISPLAY_INFO (frame)); } - -/* Toggle mouse pointer visibility on frame F by using invisible cursor. */ - +/* Set whether or not the mouse pointer should be visible on frame + F. */ static void -x_toggle_visible_pointer (struct frame *f, bool invisible) +pgtk_toggle_invisible_pointer (struct frame *f, bool invisible) { Emacs_Cursor cursor; if (invisible) @@ -4722,22 +4656,10 @@ x_toggle_visible_pointer (struct frame *f, bool invisible) gdk_window_set_cursor (gtk_widget_get_window (FRAME_GTK_WIDGET (f)), cursor); f->pointer_invisible = invisible; -} -static void -x_setup_pointer_blanking (struct pgtk_display_info *dpyinfo) -{ - dpyinfo->toggle_visible_pointer = x_toggle_visible_pointer; - dpyinfo->invisible_cursor = - gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_BLANK_CURSOR); -} - -static void -XTtoggle_invisible_pointer (struct frame *f, bool invisible) -{ - block_input (); - FRAME_DISPLAY_INFO (f)->toggle_visible_pointer (f, invisible); - unblock_input (); + /* This is needed to make the pointer visible upon receiving a + motion notify event. */ + gdk_display_flush (FRAME_X_DISPLAY (f)); } /* The focus has changed. Update the frames as necessary to reflect @@ -4747,7 +4669,7 @@ XTtoggle_invisible_pointer (struct frame *f, bool invisible) Lisp code can tell when the switch took place by examining the events. */ static void -x_new_focus_frame (struct pgtk_display_info *dpyinfo, struct frame *frame) +pgtk_new_focus_frame (struct pgtk_display_info *dpyinfo, struct frame *frame) { struct frame *old_focus = dpyinfo->x_focus_frame; /* doesn't work on wayland */ @@ -4783,9 +4705,6 @@ pgtk_buffer_flipping_unblocked_hook (struct frame *f) static struct terminal * pgtk_create_terminal (struct pgtk_display_info *dpyinfo) -/* -------------------------------------------------------------------------- - Set up use of Gtk before we make the first connection. - -------------------------------------------------------------------------- */ { struct terminal *terminal; @@ -4796,13 +4715,13 @@ pgtk_create_terminal (struct pgtk_display_info *dpyinfo) terminal->clear_frame_hook = pgtk_clear_frame; terminal->ring_bell_hook = pgtk_ring_bell; - terminal->toggle_invisible_pointer_hook = XTtoggle_invisible_pointer; + terminal->toggle_invisible_pointer_hook = pgtk_toggle_invisible_pointer; terminal->update_begin_hook = pgtk_update_begin; terminal->update_end_hook = pgtk_update_end; terminal->read_socket_hook = pgtk_read_socket; terminal->frame_up_to_date_hook = pgtk_frame_up_to_date; terminal->mouse_position_hook = pgtk_mouse_position; - terminal->frame_rehighlight_hook = XTframe_rehighlight; + terminal->frame_rehighlight_hook = pgtk_frame_rehighlight_hook; terminal->buffer_flipping_unblocked_hook = pgtk_buffer_flipping_unblocked_hook; terminal->frame_raise_lower_hook = pgtk_frame_raise_lower; terminal->frame_visible_invisible_hook = pgtk_make_frame_visible_invisible; @@ -4810,14 +4729,14 @@ pgtk_create_terminal (struct pgtk_display_info *dpyinfo) terminal->menu_show_hook = pgtk_menu_show; terminal->activate_menubar_hook = pgtk_activate_menubar; terminal->popup_dialog_hook = pgtk_popup_dialog; - terminal->change_tab_bar_height_hook = x_change_tab_bar_height; + terminal->change_tab_bar_height_hook = pgtk_change_tab_bar_height; terminal->set_vertical_scroll_bar_hook = pgtk_set_vertical_scroll_bar; terminal->set_horizontal_scroll_bar_hook = pgtk_set_horizontal_scroll_bar; terminal->condemn_scroll_bars_hook = pgtk_condemn_scroll_bars; terminal->redeem_scroll_bar_hook = pgtk_redeem_scroll_bar; terminal->judge_scroll_bars_hook = pgtk_judge_scroll_bars; terminal->get_string_resource_hook = pgtk_get_string_resource; - terminal->delete_frame_hook = x_destroy_window; + terminal->delete_frame_hook = pgtk_destroy_window; terminal->delete_terminal_hook = pgtk_delete_terminal; terminal->query_frame_background_color = pgtk_query_frame_background_color; terminal->defined_color_hook = pgtk_defined_color; @@ -4825,15 +4744,15 @@ pgtk_create_terminal (struct pgtk_display_info *dpyinfo) terminal->set_bitmap_icon_hook = pgtk_bitmap_icon; terminal->implicit_set_name_hook = pgtk_implicitly_set_name; terminal->iconify_frame_hook = pgtk_iconify_frame; - terminal->set_scroll_bar_default_width_hook = - pgtk_set_scroll_bar_default_width; - terminal->set_scroll_bar_default_height_hook = - pgtk_set_scroll_bar_default_height; + terminal->set_scroll_bar_default_width_hook + = pgtk_set_scroll_bar_default_width; + terminal->set_scroll_bar_default_height_hook + = pgtk_set_scroll_bar_default_height; terminal->set_window_size_hook = pgtk_set_window_size; terminal->query_colors = pgtk_query_colors; - terminal->get_focus_frame = x_get_focus_frame; + terminal->get_focus_frame = pgtk_get_focus_frame; terminal->focus_frame_hook = pgtk_focus_frame; - terminal->set_frame_offset_hook = x_set_offset; + terminal->set_frame_offset_hook = pgtk_set_offset; terminal->free_pixmap = pgtk_free_pixmap; terminal->toolkit_position_hook = pgtk_toolkit_position; @@ -4850,7 +4769,7 @@ struct pgtk_window_is_of_frame_recursive_t }; static void -pgtk_window_is_of_frame_recursive (GtkWidget * widget, gpointer data) +pgtk_window_is_of_frame_recursive (GtkWidget *widget, gpointer data) { struct pgtk_window_is_of_frame_recursive_t *datap = data; @@ -4866,14 +4785,13 @@ pgtk_window_is_of_frame_recursive (GtkWidget * widget, gpointer data) return; } - if (GTK_IS_CONTAINER (widget)) { + if (GTK_IS_CONTAINER (widget)) gtk_container_foreach (GTK_CONTAINER (widget), pgtk_window_is_of_frame_recursive, datap); - } } static bool -pgtk_window_is_of_frame (struct frame *f, GdkWindow * window) +pgtk_window_is_of_frame (struct frame *f, GdkWindow *window) { struct pgtk_window_is_of_frame_recursive_t data; data.window = window; @@ -4886,7 +4804,7 @@ pgtk_window_is_of_frame (struct frame *f, GdkWindow * window) /* Like x_window_to_frame but also compares the window with the widget's windows. */ static struct frame * -pgtk_any_window_to_frame (GdkWindow * window) +pgtk_any_window_to_frame (GdkWindow *window) { Lisp_Object tail, frame; struct frame *f, *found = NULL; @@ -4912,7 +4830,6 @@ pgtk_any_window_to_frame (GdkWindow * window) static gboolean pgtk_handle_event (GtkWidget *widget, GdkEvent *event, gpointer *data) { -#if GTK_CHECK_VERSION (3, 18, 0) struct frame *f; union buffered_input_event inev; GtkWidget *frame_widget; @@ -4942,12 +4859,13 @@ pgtk_handle_event (GtkWidget *widget, GdkEvent *event, gpointer *data) make_float (event->touchpad_pinch.angle_delta)); inev.ie.modifiers = pgtk_gtk_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), event->touchpad_pinch.state); + inev.ie.device + = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event); evq_enqueue (&inev); } return TRUE; } -#endif return FALSE; } @@ -5011,7 +4929,7 @@ pgtk_clear_under_internal_border (struct frame *f) } static gboolean -pgtk_handle_draw (GtkWidget * widget, cairo_t * cr, gpointer * data) +pgtk_handle_draw (GtkWidget *widget, cairo_t *cr, gpointer *data) { struct frame *f; @@ -5037,19 +4955,11 @@ pgtk_handle_draw (GtkWidget * widget, cairo_t * cr, gpointer * data) } static void -size_allocate (GtkWidget * widget, GtkAllocation * alloc, +size_allocate (GtkWidget *widget, GtkAllocation *alloc, gpointer user_data) { struct frame *f = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); - /* Between a frame is created and not shown, size is allocated and - * this handler is called. When that, since the widget's window is - * NULL, we can't get f, pgtk_cr_update_surface_desired_size is not - * called, and its size is 0x0. That causes empty frame. - * - * Fortunately since we know f in pgtk_set_event_handler, we can get - * it through user_data; - */ if (!f) f = user_data; @@ -5061,88 +4971,8 @@ size_allocate (GtkWidget * widget, GtkAllocation * alloc, } static void -x_find_modifier_meanings (struct pgtk_display_info *dpyinfo) -{ - GdkDisplay *gdpy = dpyinfo->gdpy; - GdkKeymap *keymap = gdk_keymap_get_for_display (gdpy); - GdkModifierType state = GDK_META_MASK; - gboolean r = gdk_keymap_map_virtual_modifiers (keymap, &state); - if (r) - { - /* Meta key exists. */ - if (state == GDK_META_MASK) - { - dpyinfo->meta_mod_mask = GDK_MOD1_MASK; /* maybe this is meta. */ - dpyinfo->alt_mod_mask = 0; - } - else - { - dpyinfo->meta_mod_mask = state & ~GDK_META_MASK; - if (dpyinfo->meta_mod_mask == GDK_MOD1_MASK) - dpyinfo->alt_mod_mask = 0; - else - dpyinfo->alt_mod_mask = GDK_MOD1_MASK; - } - } - else - { - dpyinfo->meta_mod_mask = GDK_MOD1_MASK; - dpyinfo->alt_mod_mask = 0; - } - - state = GDK_SUPER_MASK; - r = gdk_keymap_map_virtual_modifiers (keymap, &state); - if (r) - { - /* Super key exists. */ - if (state == GDK_SUPER_MASK) - { - dpyinfo->super_mod_mask = GDK_MOD4_MASK; /* maybe this is super. */ - } - else - { - dpyinfo->super_mod_mask = state & ~GDK_SUPER_MASK; - } - } - else - { - dpyinfo->super_mod_mask = GDK_MOD4_MASK; - } - - state = GDK_HYPER_MASK; - r = gdk_keymap_map_virtual_modifiers (keymap, &state); - if (r) - { - /* Hyper key exists. */ - if (state == GDK_HYPER_MASK) - { - dpyinfo->hyper_mod_mask = GDK_MOD3_MASK; /* maybe this is hyper. */ - } - else - { - dpyinfo->hyper_mod_mask = state & ~GDK_HYPER_MASK; - } - } - else - { - dpyinfo->hyper_mod_mask = GDK_MOD3_MASK; - } - - /* If xmodmap says: - * $ xmodmap | grep mod4 - * mod4 Super_L (0x85), Super_R (0x86), Super_L (0xce), Hyper_L (0xcf) - * then, when mod4 is pressed, both of super and hyper are recognized ON. - * Maybe many people have such configuration, and they don't like such behavior, - * so I disable hyper if such configuration is detected. - */ - if (dpyinfo->hyper_mod_mask == dpyinfo->super_mod_mask) - dpyinfo->hyper_mod_mask = 0; -} - -static void -get_modifier_values (int *mod_ctrl, - int *mod_meta, - int *mod_alt, int *mod_hyper, int *mod_super) +get_modifier_values (int *mod_ctrl, int *mod_meta, int *mod_alt, + int *mod_hyper, int *mod_super) { Lisp_Object tem; @@ -5187,14 +5017,13 @@ pgtk_gtk_to_emacs_modifiers (struct pgtk_display_info *dpyinfo, int state) mod |= shift_modifier; if (state & GDK_CONTROL_MASK) mod |= mod_ctrl; - if (state & dpyinfo->meta_mod_mask) + if (state & GDK_META_MASK || state & GDK_MOD1_MASK) mod |= mod_meta; - if (state & dpyinfo->alt_mod_mask) - mod |= mod_alt; - if (state & dpyinfo->super_mod_mask) + if (state & GDK_SUPER_MASK) mod |= mod_super; - if (state & dpyinfo->hyper_mod_mask) + if (state & GDK_HYPER_MASK) mod |= mod_hyper; + return mod; } @@ -5212,18 +5041,16 @@ pgtk_emacs_to_gtk_modifiers (struct pgtk_display_info *dpyinfo, int state) &mod_super); mask = 0; - if (state & mod_alt) - mask |= dpyinfo->alt_mod_mask; if (state & mod_super) - mask |= dpyinfo->super_mod_mask; + mask |= GDK_SUPER_MASK; if (state & mod_hyper) - mask |= dpyinfo->hyper_mod_mask; + mask |= GDK_HYPER_MASK; if (state & shift_modifier) mask |= GDK_SHIFT_MASK; if (state & mod_ctrl) mask |= GDK_CONTROL_MASK; if (state & mod_meta) - mask |= dpyinfo->meta_mod_mask; + mask |= GDK_MOD1_MASK; return mask; } @@ -5239,7 +5066,7 @@ pgtk_emacs_to_gtk_modifiers (struct pgtk_display_info *dpyinfo, int state) void -pgtk_enqueue_string (struct frame *f, gchar * str) +pgtk_enqueue_string (struct frame *f, gchar *str) { gunichar *ustr, *uptr; @@ -5280,20 +5107,15 @@ pgtk_enqueue_preedit (struct frame *f, Lisp_Object preedit) } static gboolean -key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) +key_press_event (GtkWidget *widget, GdkEvent *event, gpointer *user_data) { - struct coding_system coding; union buffered_input_event inev; ptrdiff_t nbytes = 0; Mouse_HLInfo *hlinfo; + struct frame *f; - USE_SAFE_ALLOCA; - + f = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); EVENT_INIT (inev.ie); - inev.ie.kind = NO_EVENT; - inev.ie.arg = Qnil; - - struct frame *f = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); hlinfo = MOUSE_HL_INFO (f); /* If mouse-highlight is an integer, input clears out @@ -5304,20 +5126,6 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) hlinfo->mouse_face_hidden = true; } - if (f != 0) - { - /* While super is pressed, gtk_im_context_filter_keypress() always process the - * key events ignoring super. - * As a work around, don't call it while super or hyper are pressed... - */ - struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); - if (!(event->key.state & (dpyinfo->super_mod_mask | dpyinfo->hyper_mod_mask))) - { - if (pgtk_im_filter_keypress (f, &event->key)) - return TRUE; - } - } - if (f != 0) { guint keysym, orig_keysym; @@ -5336,13 +5144,22 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) unsigned char *copy_bufptr = copy_buffer; int copy_bufsiz = sizeof (copy_buffer); int modifiers; - Lisp_Object coding_system = Qlatin_1; Lisp_Object c; - guint state = event->key.state; + guint state; - state |= - pgtk_emacs_to_gtk_modifiers (FRAME_DISPLAY_INFO (f), - extra_keyboard_modifiers); + state = event->key.state; + + /* While super is pressed, the input method will always always + resend the key events ignoring super. As a workaround, don't + filter key events with super or hyper pressed. */ + if (!(event->key.state & (GDK_SUPER_MASK | GDK_HYPER_MASK))) + { + if (pgtk_im_filter_keypress (f, &event->key)) + return TRUE; + } + + state |= pgtk_emacs_to_gtk_modifiers (FRAME_DISPLAY_INFO (f), + extra_keyboard_modifiers); modifiers = state; /* This will have to go some day... */ @@ -5374,6 +5191,9 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) { inev.ie.kind = ASCII_KEYSTROKE_EVENT; inev.ie.code = keysym; + + inev.ie.device + = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event); goto done; } @@ -5385,6 +5205,9 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) else inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT; inev.ie.code = keysym & 0xFFFFFF; + + inev.ie.device + = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event); goto done; } @@ -5397,6 +5220,9 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) ? ASCII_KEYSTROKE_EVENT : MULTIBYTE_CHAR_KEYSTROKE_EVENT); inev.ie.code = XFIXNAT (c); + + inev.ie.device + = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event); goto done; } @@ -5460,9 +5286,6 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) || (orig_keysym & (1 << 28)) || (keysym != GDK_KEY_VoidSymbol && nbytes == 0)) && !(event->key.is_modifier - /* Gtk's modifier keys are different from Xlib's ones. - * I need to exclude them. - */ || IsModifierKey (orig_keysym) /* The symbols from GDK_KEY_ISO_Lock to GDK_KEY_ISO_Last_Group_Lock @@ -5475,68 +5298,21 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) #endif )) { - STORE_KEYSYM_FOR_DEBUG (keysym); /* make_lispy_event will convert this to a symbolic key. */ inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT; inev.ie.code = keysym; + + inev.ie.device + = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event); goto done; } - { /* Raw bytes, not keysym. */ - ptrdiff_t i; - int nchars, len; - - for (i = 0, nchars = 0; i < nbytes; i++) - { - if (ASCII_CHAR_P (copy_bufptr[i])) - nchars++; - STORE_KEYSYM_FOR_DEBUG (copy_bufptr[i]); - } - - if (nchars < nbytes) - { - /* Decode the input data. */ - - /* The input should be decoded with locale `coding_system'. */ - if (!NILP (Vlocale_coding_system)) - coding_system = Vlocale_coding_system; - setup_coding_system (coding_system, &coding); - coding.src_multibyte = false; - coding.dst_multibyte = true; - /* The input is converted to events, thus we can't - handle composition. Anyway, there's no XIM that - gives us composition information. */ - coding.common_flags &= ~CODING_ANNOTATION_MASK; - - SAFE_NALLOCA (coding.destination, MAX_MULTIBYTE_LENGTH, nbytes); - coding.dst_bytes = MAX_MULTIBYTE_LENGTH * nbytes; - coding.mode |= CODING_MODE_LAST_BLOCK; - decode_coding_c_string (&coding, copy_bufptr, nbytes, Qnil); - nbytes = coding.produced; - nchars = coding.produced_char; - copy_bufptr = coding.destination; - } - - /* Convert the input data to a sequence of - character events. */ - for (i = 0; i < nbytes; i += len) - { - int ch; - if (nchars == nbytes) - ch = copy_bufptr[i], len = 1; - else - ch = string_char_and_length (copy_bufptr + i, &len); - inev.ie.kind = (SINGLE_BYTE_CHAR_P (ch) - ? ASCII_KEYSTROKE_EVENT - : MULTIBYTE_CHAR_KEYSTROKE_EVENT); - inev.ie.code = ch; - evq_enqueue (&inev); - } - - /* count += nchars; */ - - inev.ie.kind = NO_EVENT; /* Already stored above. */ + { + inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT; + inev.ie.arg = make_unibyte_string ((char *) copy_bufptr, nbytes); + inev.ie.device + = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event); if (keysym == GDK_KEY_VoidSymbol) goto done; @@ -5548,11 +5324,8 @@ key_press_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) { XSETFRAME (inev.ie.frame_or_window, f); evq_enqueue (&inev); - /* count++; */ } - SAFE_FREE (); - return TRUE; } @@ -5624,9 +5397,9 @@ map_event (GtkWidget *widget, /* The `z-group' is reset every time a frame becomes invisible. Handle this here. */ if (FRAME_Z_GROUP (f) == z_group_above) - x_set_z_group (f, Qabove, Qnil); + pgtk_set_z_group (f, Qabove, Qnil); else if (FRAME_Z_GROUP (f) == z_group_below) - x_set_z_group (f, Qbelow, Qnil); + pgtk_set_z_group (f, Qbelow, Qnil); } SET_FRAME_VISIBLE (f, 1); @@ -5738,15 +5511,15 @@ delete_event (GtkWidget *widget, a FOCUS_IN_EVENT into *BUFP. */ static void -x_focus_changed (gboolean is_enter, int state, - struct pgtk_display_info *dpyinfo, struct frame *frame, - union buffered_input_event *bufp) +pgtk_focus_changed (gboolean is_enter, int state, + struct pgtk_display_info *dpyinfo, struct frame *frame, + union buffered_input_event *bufp) { if (is_enter) { if (dpyinfo->x_focus_event_frame != frame) { - x_new_focus_frame (dpyinfo, frame); + pgtk_new_focus_frame (dpyinfo, frame); dpyinfo->x_focus_event_frame = frame; /* Don't stop displaying the initial startup message @@ -5771,14 +5544,14 @@ x_focus_changed (gboolean is_enter, int state, if (dpyinfo->x_focus_event_frame == frame) { dpyinfo->x_focus_event_frame = 0; - x_new_focus_frame (dpyinfo, 0); + pgtk_new_focus_frame (dpyinfo, NULL); bufp->ie.kind = FOCUS_OUT_EVENT; XSETFRAME (bufp->ie.frame_or_window, frame); } if (frame->pointer_invisible) - XTtoggle_invisible_pointer (frame, false); + pgtk_toggle_invisible_pointer (frame, false); } } @@ -5787,10 +5560,12 @@ enter_notify_event (GtkWidget *widget, GdkEvent *event, gpointer *user_data) { union buffered_input_event inev; - struct frame *frame = - pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + struct frame *frame + = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + if (frame == NULL) return FALSE; + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame); struct frame *focus_frame = dpyinfo->x_focus_frame; int focus_state @@ -5802,7 +5577,7 @@ enter_notify_event (GtkWidget *widget, GdkEvent *event, if (event->crossing.detail != GDK_NOTIFY_INFERIOR && event->crossing.focus && !(focus_state & FOCUS_EXPLICIT)) - x_focus_changed (TRUE, FOCUS_IMPLICIT, dpyinfo, frame, &inev); + pgtk_focus_changed (TRUE, FOCUS_IMPLICIT, dpyinfo, frame, &inev); if (inev.ie.kind != NO_EVENT) evq_enqueue (&inev); return TRUE; @@ -5813,10 +5588,12 @@ leave_notify_event (GtkWidget *widget, GdkEvent *event, gpointer *user_data) { union buffered_input_event inev; - struct frame *frame = - pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + struct frame *frame + = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + if (frame == NULL) return FALSE; + struct pgtk_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame); struct frame *focus_frame = dpyinfo->x_focus_frame; int focus_state @@ -5837,7 +5614,7 @@ leave_notify_event (GtkWidget *widget, GdkEvent *event, if (event->crossing.detail != GDK_NOTIFY_INFERIOR && event->crossing.focus && !(focus_state & FOCUS_EXPLICIT)) - x_focus_changed (FALSE, FOCUS_IMPLICIT, dpyinfo, frame, &inev); + pgtk_focus_changed (FALSE, FOCUS_IMPLICIT, dpyinfo, frame, &inev); if (frame) { @@ -5856,11 +5633,11 @@ leave_notify_event (GtkWidget *widget, GdkEvent *event, } static gboolean -focus_in_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) +focus_in_event (GtkWidget *widget, GdkEvent *event, gpointer *user_data) { union buffered_input_event inev; - struct frame *frame = - pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + struct frame *frame + = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); if (frame == NULL) return TRUE; @@ -5869,8 +5646,8 @@ focus_in_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) inev.ie.kind = NO_EVENT; inev.ie.arg = Qnil; - x_focus_changed (TRUE, FOCUS_EXPLICIT, - FRAME_DISPLAY_INFO (frame), frame, &inev); + pgtk_focus_changed (TRUE, FOCUS_EXPLICIT, + FRAME_DISPLAY_INFO (frame), frame, &inev); if (inev.ie.kind != NO_EVENT) evq_enqueue (&inev); @@ -5880,11 +5657,11 @@ focus_in_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) } static gboolean -focus_out_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) +focus_out_event (GtkWidget *widget, GdkEvent *event, gpointer *user_data) { union buffered_input_event inev; - struct frame *frame = - pgtk_any_window_to_frame (gtk_widget_get_window (widget)); + struct frame *frame + = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); if (frame == NULL) return TRUE; @@ -5893,8 +5670,8 @@ focus_out_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) inev.ie.kind = NO_EVENT; inev.ie.arg = Qnil; - x_focus_changed (FALSE, FOCUS_EXPLICIT, - FRAME_DISPLAY_INFO (frame), frame, &inev); + pgtk_focus_changed (FALSE, FOCUS_EXPLICIT, + FRAME_DISPLAY_INFO (frame), frame, &inev); if (inev.ie.kind != NO_EVENT) evq_enqueue (&inev); @@ -5912,7 +5689,8 @@ focus_out_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) another motion event, so we can check again the next time it moves. */ static bool -note_mouse_movement (struct frame *frame, const GdkEventMotion * event) +note_mouse_movement (struct frame *frame, + const GdkEventMotion *event) { XRectangle *r; struct pgtk_display_info *dpyinfo; @@ -5932,6 +5710,9 @@ note_mouse_movement (struct frame *frame, const GdkEventMotion * event) dpyinfo->last_mouse_scroll_bar = NULL; note_mouse_highlight (frame, -1, -1); dpyinfo->last_mouse_glyph_frame = NULL; + frame->last_mouse_device + = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (frame), + (GdkEvent *) event); return true; } @@ -5948,6 +5729,9 @@ note_mouse_movement (struct frame *frame, const GdkEventMotion * event) /* Remember which glyph we're now on. */ remember_mouse_glyph (frame, event->x, event->y, r); dpyinfo->last_mouse_glyph_frame = frame; + frame->last_mouse_device + = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (frame), + (GdkEvent *) event); return true; } @@ -5955,17 +5739,14 @@ note_mouse_movement (struct frame *frame, const GdkEventMotion * event) } static gboolean -motion_notify_event (GtkWidget * widget, GdkEvent * event, - gpointer * user_data) +motion_notify_event (GtkWidget *widget, GdkEvent *event, + gpointer *user_data) { union buffered_input_event inev; struct frame *f, *frame; struct pgtk_display_info *dpyinfo; Mouse_HLInfo *hlinfo; - /* This is needed to make pointer visible when motion_notify event */ - pending_signals = true; - EVENT_INIT (inev.ie); inev.ie.kind = NO_EVENT; inev.ie.arg = Qnil; @@ -5987,6 +5768,7 @@ motion_notify_event (GtkWidget * widget, GdkEvent * event, if (f && xg_event_is_for_scrollbar (f, event, false)) f = 0; + if (f) { /* Maybe generate a SELECT_WINDOW_EVENT for @@ -6031,11 +5813,9 @@ motion_notify_event (GtkWidget * widget, GdkEvent * event, help_echo_string = previous_help_echo_string; } else - { - /* If we move outside the frame, then we're - certainly no longer on any text in the frame. */ - clear_mouse_face (hlinfo); - } + /* If we move outside the frame, then we're + certainly no longer on any text in the frame. */ + clear_mouse_face (hlinfo); /* If the contents of the global variable help_echo_string has changed, generate a HELP_EVENT. */ @@ -6063,26 +5843,6 @@ motion_notify_event (GtkWidget * widget, GdkEvent * event, return TRUE; } -/* Mouse clicks and mouse movement. Rah. - - Formerly, we used PointerMotionHintMask (in standard_event_mask) - so that we would have to call XQueryPointer after each MotionNotify - event to ask for another such event. However, this made mouse tracking - slow, and there was a bug that made it eventually stop. - - Simply asking for MotionNotify all the time seems to work better. - - In order to avoid asking for motion events and then throwing most - of them away or busy-polling the server for mouse positions, we ask - the server for pointer motion hints. This means that we get only - one event per group of mouse movements. "Groups" are delimited by - other kinds of events (focus changes and button clicks, for - example), or by XQueryPointer calls; when one of these happens, we - get another MotionNotify event the next time the mouse moves. This - is at least as efficient as getting motion events when mouse - tracking is on, and I suspect only negligibly worse when tracking - is off. */ - /* Prepare a mouse-event in *RESULT for placement in the input queue. If the event is a button press, then note that we have grabbed @@ -6090,7 +5850,8 @@ motion_notify_event (GtkWidget * widget, GdkEvent * event, static Lisp_Object construct_mouse_click (struct input_event *result, - const GdkEventButton * event, struct frame *f) + const GdkEventButton *event, + struct frame *f) { /* Make the event type NO_EVENT; we'll change that when we decide otherwise. */ @@ -6105,11 +5866,15 @@ construct_mouse_click (struct input_event *result, XSETINT (result->y, event->y); XSETFRAME (result->frame_or_window, f); result->arg = Qnil; + result->device = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), + (GdkEvent *) event); return Qnil; } static gboolean -button_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) +button_event (GtkWidget *widget, + GdkEvent *event, + gpointer *user_data) { union buffered_input_event inev; struct frame *f, *frame; @@ -6228,7 +5993,7 @@ button_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) } static gboolean -scroll_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) +scroll_event (GtkWidget *widget, GdkEvent *event, gpointer *user_data) { union buffered_input_event inev; struct frame *f, *frame; @@ -6260,6 +6025,8 @@ scroll_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) if (gdk_event_is_scroll_stop_event (event)) { inev.ie.kind = TOUCH_END_EVENT; + inev.ie.device + = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event); evq_enqueue (&inev); return TRUE; } @@ -6353,14 +6120,17 @@ scroll_event (GtkWidget * widget, GdkEvent * event, gpointer * user_data) } if (inev.ie.kind != NO_EVENT) - evq_enqueue (&inev); + { + inev.ie.device + = pgtk_get_device_for_event (FRAME_DISPLAY_INFO (f), event); + evq_enqueue (&inev); + } return TRUE; } static void -drag_data_received (GtkWidget * widget, GdkDragContext * context, - gint x, gint y, - GtkSelectionData * data, +drag_data_received (GtkWidget *widget, GdkDragContext *context, + gint x, gint y, GtkSelectionData *data, guint info, guint time, gpointer user_data) { struct frame *f = pgtk_any_window_to_frame (gtk_widget_get_window (widget)); @@ -6545,8 +6315,8 @@ pgtk_term_init (Lisp_Object display_name, char *resource_name) static int x_initialized = 0; static unsigned x_display_id = 0; static char *initial_display = NULL; - static dynlib_handle_ptr *handle = NULL; char *dpy_name; + static void *handle = NULL; Lisp_Object lisp_dpy_name = Qnil; block_input (); @@ -6684,9 +6454,6 @@ pgtk_term_init (Lisp_Object display_name, char *resource_name) *nametail++ = '@'; lispstpcpy (nametail, system_name); - /* Figure out which modifier bits mean what. */ - x_find_modifier_meanings (dpyinfo); - /* Get the scroll bar cursor. */ /* We must create a GTK cursor, it is required for GTK widgets. */ dpyinfo->xg_cursor = xg_create_default_cursor (dpyinfo->gdpy); @@ -6720,15 +6487,15 @@ pgtk_term_init (Lisp_Object display_name, char *resource_name) dpyinfo->connection = -1; if (!handle) - handle = dynlib_open (NULL); + handle = dlopen (NULL, RTLD_LAZY); #ifdef GDK_WINDOWING_X11 if (!strcmp (G_OBJECT_TYPE_NAME (dpy), "GdkX11Display") && handle) { void *(*gdk_x11_display_get_xdisplay) (GdkDisplay *) - = dynlib_sym (handle, "gdk_x11_display_get_xdisplay"); + = dlsym (handle, "gdk_x11_display_get_xdisplay"); int (*x_connection_number) (void *) - = dynlib_sym (handle, "XConnectionNumber"); + = dlsym (handle, "XConnectionNumber"); if (x_connection_number && gdk_x11_display_get_xdisplay) @@ -6742,7 +6509,7 @@ pgtk_term_init (Lisp_Object display_name, char *resource_name) { struct wl_display *wl_dpy = gdk_wayland_display_get_wl_display (dpy); int (*display_get_fd) (struct wl_display *) - = dynlib_sym (handle, "wl_display_get_fd"); + = dlsym (handle, "wl_display_get_fd"); if (display_get_fd) dpyinfo->connection = display_get_fd (wl_dpy); @@ -6760,7 +6527,8 @@ pgtk_term_init (Lisp_Object display_name, char *resource_name) init_sigio (dpyinfo->connection); } - x_setup_pointer_blanking (dpyinfo); + dpyinfo->invisible_cursor + = gdk_cursor_new_for_display (dpyinfo->gdpy, GDK_BLANK_CURSOR); xsettings_initialize (dpyinfo); @@ -6768,6 +6536,12 @@ pgtk_term_init (Lisp_Object display_name, char *resource_name) pgtk_im_init (dpyinfo); + g_signal_connect (G_OBJECT (dpyinfo->gdpy), "seat-added", + G_CALLBACK (pgtk_seat_added_cb), dpyinfo); + g_signal_connect (G_OBJECT (dpyinfo->gdpy), "seat-removed", + G_CALLBACK (pgtk_seat_removed_cb), dpyinfo); + pgtk_enumerate_devices (dpyinfo, true); + unblock_input (); return dpyinfo; @@ -6801,6 +6575,7 @@ pgtk_delete_display (struct pgtk_display_info *dpyinfo) tail->next = tail->next->next; } + pgtk_free_devices (dpyinfo); xfree (dpyinfo); } @@ -6927,7 +6702,6 @@ pgtk_clear_area (struct frame *f, int x, int y, int width, int height) void syms_of_pgtkterm (void) { - /* from 23+ we need to tell emacs what modifiers there are.. */ DEFSYM (Qmodifier_value, "modifier-value"); DEFSYM (Qalt, "alt"); DEFSYM (Qhyper, "hyper"); @@ -7089,8 +6863,11 @@ pgtk_set_cr_source_with_color (struct frame *f, unsigned long color, pgtk_query_color (f, &col); if (!respects_alpha_background) - cairo_set_source_rgb (FRAME_CR_CONTEXT (f), col.red / 65535.0, - col.green / 65535.0, col.blue / 65535.0); + { + cairo_set_source_rgb (FRAME_CR_CONTEXT (f), col.red / 65535.0, + col.green / 65535.0, col.blue / 65535.0); + cairo_set_operator (FRAME_CR_CONTEXT (f), CAIRO_OPERATOR_OVER); + } else { cairo_set_source_rgba (FRAME_CR_CONTEXT (f), col.red / 65535.0, @@ -7109,7 +6886,7 @@ pgtk_cr_draw_frame (cairo_t * cr, struct frame *f) static cairo_status_t pgtk_cr_accumulate_data (void *closure, const unsigned char *data, - unsigned int length) + unsigned int length) { Lisp_Object *acc = (Lisp_Object *) closure; @@ -7136,8 +6913,6 @@ pgtk_cr_destroy (void *cr) unblock_input (); } - - Lisp_Object pgtk_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type) { @@ -7231,7 +7006,6 @@ pgtk_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type) return CALLN (Fapply, intern ("concat"), Fnreverse (acc)); } - void init_pgtkterm (void) { diff --git a/src/pgtkterm.h b/src/pgtkterm.h index 4d2285cdb0a..20c161e63b9 100644 --- a/src/pgtkterm.h +++ b/src/pgtkterm.h @@ -40,8 +40,6 @@ along with GNU Emacs. If not, see . */ #include #endif -/* could use list to store these, but rest of emacs has a big infrastructure - for managing a table of bitmap "records" */ struct pgtk_bitmap_record { void *img; @@ -51,13 +49,22 @@ struct pgtk_bitmap_record cairo_pattern_t *pattern; }; +struct pgtk_device_t +{ + GdkSeat *seat; + GdkDevice *device; + + Lisp_Object name; + struct pgtk_device_t *next; +}; + #define RGB_TO_ULONG(r, g, b) (((r) << 16) | ((g) << 8) | (b)) #define ARGB_TO_ULONG(a, r, g, b) (((a) << 24) | ((r) << 16) | ((g) << 8) | (b)) #define ALPHA_FROM_ULONG(color) ((color) >> 24) -#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) +#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff) #define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff) -#define BLUE_FROM_ULONG(color) ((color) & 0xff) +#define BLUE_FROM_ULONG(color) ((color) & 0xff) struct scroll_bar { @@ -112,8 +119,6 @@ struct scroll_bar bool horizontal; }; - -/* init'd in pgtk_initialize_display_info () */ struct pgtk_display_info { /* Chain of all pgtk_display_info structures. */ @@ -208,27 +213,22 @@ struct pgtk_display_info /* The scroll bar in which the last motion event occurred. */ void *last_mouse_scroll_bar; - /* The invisible cursor used for pointer blanking. - Unused if this display supports Xfixes extension. */ + /* The invisible cursor used for pointer blanking. */ Emacs_Cursor invisible_cursor; - /* Function used to toggle pointer visibility on this display. */ - void (*toggle_visible_pointer) (struct frame *, bool); - /* The GDK cursor for scroll bars and popup menus. */ GdkCursor *xg_cursor; + /* List of all devices for all seats on this display. */ + struct pgtk_device_t *devices; /* The frame where the mouse was last time we reported a mouse position. */ struct frame *last_mouse_glyph_frame; - /* Modifier masks in gdk */ - int meta_mod_mask, alt_mod_mask, super_mod_mask, hyper_mod_mask; - /* The last click event. */ GdkEvent *last_click_event; - /* input method */ + /* IM context data. */ struct { GtkIMContext *context; @@ -249,10 +249,6 @@ extern struct pgtk_display_info *x_display_list; struct pgtk_output { -#if 0 - void *view; - void *miniimage; -#endif unsigned long foreground_color; unsigned long background_color; void *toolbar; @@ -396,6 +392,10 @@ struct pgtk_output They are changed only when a different background is involved. */ unsigned long relief_background; + /* Whether or not a relief background has been computed for this + frame. */ + bool_bf relief_background_valid_p : 1; + /* Keep track of focus. May be EXPLICIT if we received a FocusIn for this frame, or IMPLICIT if we received an EnterNotify. FocusOut and LeaveNotify clears EXPLICIT/IMPLICIT. */ @@ -409,7 +409,7 @@ struct pgtk_output struct atimer *scale_factor_atimer; }; -/* this dummy decl needed to support TTYs */ +/* Satisfy term.c. */ struct x_output { int unused; @@ -455,59 +455,8 @@ enum /* Turning a lisp vector value into a pointer to a struct scroll_bar. */ #define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec)) -#define PGTK_FACE_FOREGROUND(f) ((f)->foreground) -#define PGTK_FACE_BACKGROUND(f) ((f)->background) #define FRAME_DEFAULT_FACE(f) FACE_FROM_ID_OR_NULL (f, DEFAULT_FACE_ID) - -/* Compute pixel height of the frame's titlebar. */ -#define FRAME_PGTK_TITLEBAR_HEIGHT(f) 0 - -/* Compute pixel size for vertical scroll bars */ -#define PGTK_SCROLL_BAR_WIDTH(f) \ - (FRAME_HAS_VERTICAL_SCROLL_BARS (f) \ - ? rint (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0 \ - ? FRAME_CONFIG_SCROLL_BAR_WIDTH (f) \ - : (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f))) \ - : 0) - -/* Compute pixel size for horizontal scroll bars */ -#define PGTK_SCROLL_BAR_HEIGHT(f) \ - (FRAME_HAS_HORIZONTAL_SCROLL_BARS (f) \ - ? rint (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0 \ - ? FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) \ - : (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f))) \ - : 0) - -/* Difference btwn char-column-calculated and actual SB widths. - This is only a concern for rendering when SB on left. */ -#define PGTK_SCROLL_BAR_ADJUST(w, f) \ - (WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_LEFT (w) ? \ - (FRAME_SCROLL_BAR_COLS (f) * FRAME_COLUMN_WIDTH (f) \ - - PGTK_SCROLL_BAR_WIDTH (f)) : 0) - -/* Difference btwn char-line-calculated and actual SB heights. - This is only a concern for rendering when SB on top. */ -#define PGTK_SCROLL_BAR_ADJUST_HORIZONTALLY(w, f) \ - (WINDOW_HAS_HORIZONTAL_SCROLL_BARS (w) ? \ - (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f) \ - - PGTK_SCROLL_BAR_HEIGHT (f)) : 0) - #define FRAME_MENUBAR_HEIGHT(f) (FRAME_X_OUTPUT (f)->menubar_height) - -/* Calculate system coordinates of the left and top of the parent - window or, if there is no parent window, the screen. */ -#define PGTK_PARENT_WINDOW_LEFT_POS(f) \ - (FRAME_PARENT_FRAME (f) != NULL \ - ? [[FRAME_PGTK_VIEW (f) window] parentWindow].frame.origin.x : 0) -#define PGTK_PARENT_WINDOW_TOP_POS(f) \ - (FRAME_PARENT_FRAME (f) != NULL \ - ? ([[FRAME_PGTK_VIEW (f) window] parentWindow].frame.origin.y \ - + [[FRAME_PGTK_VIEW (f) window] parentWindow].frame.size.height \ - - FRAME_PGTK_TITLEBAR_HEIGHT (FRAME_PARENT_FRAME (f))) \ - : [[[PGTKScreen screepgtk] objectAtIndex: 0] frame].size.height) - -#define FRAME_PGTK_FONT_TABLE(f) (FRAME_DISPLAY_INFO (f)->font_table) - #define FRAME_TOOLBAR_TOP_HEIGHT(f) ((f)->output_data.pgtk->toolbar_top_height) #define FRAME_TOOLBAR_BOTTOM_HEIGHT(f) \ ((f)->output_data.pgtk->toolbar_bottom_height) @@ -573,19 +522,14 @@ extern void pgtk_clear_under_internal_border (struct frame *f); extern void pgtk_set_event_handler (struct frame *f); /* Implemented in pgtkterm.c */ -extern int x_display_pixel_height (struct pgtk_display_info *); -extern int x_display_pixel_width (struct pgtk_display_info *); +extern int pgtk_display_pixel_height (struct pgtk_display_info *); +extern int pgtk_display_pixel_width (struct pgtk_display_info *); -/* Implemented in pgtkterm.c */ -extern void x_destroy_window (struct frame *f); -extern void x_set_parent_frame (struct frame *f, Lisp_Object new_value, - Lisp_Object old_value); -extern void x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value, - Lisp_Object old_value); -extern void x_set_no_accept_focus (struct frame *f, Lisp_Object new_value, - Lisp_Object old_value); -extern void x_set_z_group (struct frame *f, Lisp_Object new_value, - Lisp_Object old_value); +extern void pgtk_destroy_window (struct frame *f); +extern void pgtk_set_parent_frame (struct frame *f, Lisp_Object, Lisp_Object); +extern void pgtk_set_no_focus_on_map (struct frame *, Lisp_Object, Lisp_Object); +extern void pgtk_set_no_accept_focus (struct frame *, Lisp_Object, Lisp_Object); +extern void pgtk_set_z_group (struct frame *, Lisp_Object, Lisp_Object); /* Cairo related functions implemented in pgtkterm.c */ extern void pgtk_cr_update_surface_desired_size (struct frame *, int, int, bool); @@ -614,9 +558,6 @@ extern void syms_of_pgtkmenu (void); extern void syms_of_pgtkselect (void); extern void syms_of_pgtkim (void); -/* Implemented in pgtkselect. */ -extern void nxatoms_of_pgtkselect (void); - /* Initialization and marking implemented in pgtkterm.c */ extern void init_pgtkterm (void); extern void mark_pgtkterm (void); @@ -624,17 +565,16 @@ extern void pgtk_delete_terminal (struct terminal *terminal); extern void pgtk_make_frame_visible (struct frame *f); extern void pgtk_make_frame_invisible (struct frame *f); -extern void x_wm_set_size_hint (struct frame *, long, bool); -extern void x_free_frame_resources (struct frame *); +extern void pgtk_free_frame_resources (struct frame *); extern void pgtk_iconify_frame (struct frame *f); extern void pgtk_focus_frame (struct frame *f, bool noactivate); extern void pgtk_set_scroll_bar_default_width (struct frame *f); extern void pgtk_set_scroll_bar_default_height (struct frame *f); -extern Lisp_Object x_get_focus_frame (struct frame *frame); +extern Lisp_Object pgtk_get_focus_frame (struct frame *frame); extern void pgtk_frame_rehighlight (struct pgtk_display_info *dpyinfo); -extern void x_change_tab_bar_height (struct frame *, int); +extern void pgtk_change_tab_bar_height (struct frame *, int); extern struct pgtk_display_info *check_pgtk_display_info (Lisp_Object object); diff --git a/src/print.c b/src/print.c index ab3047dee52..d8b8513f311 100644 --- a/src/print.c +++ b/src/print.c @@ -772,6 +772,16 @@ is used instead. */) return object; } +DEFUN ("flush-standard-output", Fflush_standard_output, Sflush_standard_output, + 0, 0, 0, + doc: /* Flush standard-output. +This can be useful after using `princ' and the like in scripts. */) + (void) +{ + fflush (stdout); + return Qnil; +} + DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0, doc: /* Write CHARACTER to stderr. You can call `print' while debugging emacs, and pass it this function @@ -948,7 +958,14 @@ print_error_message (Lisp_Object data, Lisp_Object stream, const char *context, errmsg = Fget (errname, Qerror_message); /* During loadup 'substitute-command-keys' might not be available. */ if (!NILP (Ffboundp (Qsubstitute_command_keys))) - errmsg = call1 (Qsubstitute_command_keys, errmsg); + { + /* `substitute-command-keys' may bug out, which would lead + to infinite recursion when we're called from + skip_debugger, so ignore errors. */ + Lisp_Object subs = safe_call1 (Qsubstitute_command_keys, errmsg); + if (!NILP (subs)) + errmsg = subs; + } file_error = Fmemq (Qfile_error, error_conditions); } @@ -1695,10 +1712,10 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, case PVEC_USER_PTR: { + void *finalizer = XUSER_PTR (obj)->finalizer; print_c_string ("#p, - XUSER_PTR (obj)->finalizer); + XUSER_PTR (obj)->p, finalizer); strout (buf, i, i, printcharfun); printchar ('>', printcharfun); } @@ -1869,7 +1886,8 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, print_string (XTHREAD (obj)->name, printcharfun); else { - int len = sprintf (buf, "%p", XTHREAD (obj)); + void *p = XTHREAD (obj); + int len = sprintf (buf, "%p", p); strout (buf, len, len, printcharfun); } printchar ('>', printcharfun); @@ -1881,7 +1899,8 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, print_string (XMUTEX (obj)->name, printcharfun); else { - int len = sprintf (buf, "%p", XMUTEX (obj)); + void *p = XMUTEX (obj); + int len = sprintf (buf, "%p", p); strout (buf, len, len, printcharfun); } printchar ('>', printcharfun); @@ -1893,7 +1912,8 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, print_string (XCONDVAR (obj)->name, printcharfun); else { - int len = sprintf (buf, "%p", XCONDVAR (obj)); + void *p = XCONDVAR (obj); + int len = sprintf (buf, "%p", p); strout (buf, len, len, printcharfun); } printchar ('>', printcharfun); @@ -2088,8 +2108,10 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) } else { - int len = sprintf (buf, "%"pI"d", i); - strout (buf, len, len, printcharfun); + char *end = buf + sizeof buf; + char *start = fixnum_to_string (i, buf, end); + ptrdiff_t len = end - start; + strout (start, len, len, printcharfun); } } break; @@ -2199,14 +2221,19 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) Lisp_Object name = SYMBOL_NAME (obj); ptrdiff_t size_byte = SBYTES (name); - /* Set CONFUSING if NAME looks like a number, calling - string_to_number for non-obvious cases. */ char *p = SSDATA (name); bool signedp = *p == '-' || *p == '+'; ptrdiff_t len; - bool confusing = ((c_isdigit (p[signedp]) || p[signedp] == '.') - && !NILP (string_to_number (p, 10, &len)) - && len == size_byte); + bool confusing = + /* Set CONFUSING if NAME looks like a number, calling + string_to_number for non-obvious cases. */ + ((c_isdigit (p[signedp]) || p[signedp] == '.') + && !NILP (string_to_number (p, 10, &len)) + && len == size_byte) + /* We don't escape "." or "?" (unless they're the first + character in the symbol name). */ + || *p == '?' + || *p == '.'; if (! NILP (Vprint_gensym) && !SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (obj)) @@ -2229,8 +2256,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' || c == '(' || c == ')' - || c == ',' || c == '.' || c == '`' - || c == '[' || c == ']' || c == '?' || c <= 040 + || c == ',' || c == '`' + || c == '[' || c == ']' || c <= 040 || c == NO_BREAK_SPACE || confusing) { @@ -2570,4 +2597,6 @@ printed. If the function returns anything else, the object will not be printed. */); Vprint_unreadable_function = Qnil; DEFSYM (Qprint_unreadable_function, "print-unreadable-function"); + + defsubr (&Sflush_standard_output); } diff --git a/src/process.c b/src/process.c index 94cc8800970..08a02ad9423 100644 --- a/src/process.c +++ b/src/process.c @@ -6239,7 +6239,6 @@ Otherwise it discards the output. */) { Lisp_Object old_read_only; ptrdiff_t old_begv, old_zv; - ptrdiff_t old_begv_byte, old_zv_byte; ptrdiff_t before, before_byte; ptrdiff_t opoint_byte; struct buffer *b; @@ -6250,8 +6249,6 @@ Otherwise it discards the output. */) old_read_only = BVAR (current_buffer, read_only); old_begv = BEGV; old_zv = ZV; - old_begv_byte = BEGV_BYTE; - old_zv_byte = ZV_BYTE; bset_read_only (current_buffer, Qnil); @@ -6299,15 +6296,9 @@ Otherwise it discards the output. */) opoint_byte += PT_BYTE - before_byte; } if (old_begv > before) - { - old_begv += PT - before; - old_begv_byte += PT_BYTE - before_byte; - } + old_begv += PT - before; if (old_zv >= before) - { - old_zv += PT - before; - old_zv_byte += PT_BYTE - before_byte; - } + old_zv += PT - before; /* If the restriction isn't what it should be, set it. */ if (old_begv != BEGV || old_zv != ZV) @@ -6420,7 +6411,7 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, if (p->raw_status_new) update_status (p); if (! EQ (p->status, Qrun)) - error ("Process %s not running", SDATA (p->name)); + error ("Process %s not running: %s", SDATA (p->name), SDATA (status_message (p))); if (p->outfd < 0) error ("Output file descriptor of %s is closed", SDATA (p->name)); @@ -7034,14 +7025,13 @@ abbr_to_signal (char const *name) return -1; } -DEFUN ("signal-process", Fsignal_process, Ssignal_process, - 2, 2, "sProcess (name or number): \nnSignal code: ", - doc: /* Send PROCESS the signal with code SIGCODE. -PROCESS may also be a number specifying the process id of the -process to signal; in this case, the process need not be a child of -this Emacs. -SIGCODE may be an integer, or a symbol whose name is a signal name. */) - (Lisp_Object process, Lisp_Object sigcode) +DEFUN ("internal-default-signal-process", + Finternal_default_signal_process, + Sinternal_default_signal_process, 2, 3, 0, + doc: /* Default function to send PROCESS the signal with code SIGCODE. +It shall be the last element in list `signal-process-functions'. +See function `signal-process' for more details on usage. */) + (Lisp_Object process, Lisp_Object sigcode, Lisp_Object remote) { pid_t pid; int signo; @@ -7091,6 +7081,23 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */) return make_fixnum (kill (pid, signo)); } +DEFUN ("signal-process", Fsignal_process, Ssignal_process, + 2, 3, "sProcess (name or number): \nnSignal code: ", + doc: /* Send PROCESS the signal with code SIGCODE. +PROCESS may also be a number specifying the process id of the +process to signal; in this case, the process need not be a child of +this Emacs. +If PROCESS is a process object which contains the property +`remote-pid', or PROCESS is a number and REMOTE is a remote file name, +PROCESS is interpreted as process on the respective remote host, which +will be the process to signal. +SIGCODE may be an integer, or a symbol whose name is a signal name. */) + (Lisp_Object process, Lisp_Object sigcode, Lisp_Object remote) +{ + return CALLN (Frun_hook_with_args_until_success, Qsignal_process_functions, + process, sigcode, remote); +} + DEFUN ("process-send-eof", Fprocess_send_eof, Sprocess_send_eof, 0, 1, 0, doc: /* Make PROCESS see end-of-file in its input. EOF comes after any text already sent to it. @@ -7125,7 +7132,7 @@ process has been transmitted to the serial port. */) if (XPROCESS (proc)->raw_status_new) update_status (XPROCESS (proc)); if (! EQ (XPROCESS (proc)->status, Qrun)) - error ("Process %s not running", SDATA (XPROCESS (proc)->name)); + error ("Process %s not running: %s", SDATA (XPROCESS (proc)->name), SDATA (status_message (XPROCESS (proc)))); if (coding && CODING_REQUIRE_FLUSHING (coding)) { @@ -8187,16 +8194,25 @@ DEFUN ("list-system-processes", Flist_system_processes, Slist_system_processes, 0, 0, 0, doc: /* Return a list of numerical process IDs of all running processes. If this functionality is unsupported, return nil. +If `default-directory' is remote, return process IDs of the respective remote host. See `process-attributes' for getting attributes of a process given its ID. */) (void) { + Lisp_Object handler + = Ffind_file_name_handler (BVAR (current_buffer, directory), + Qlist_system_processes); + if (!NILP (handler)) + return call1 (handler, Qlist_system_processes); + return list_system_processes (); } DEFUN ("process-attributes", Fprocess_attributes, Sprocess_attributes, 1, 1, 0, doc: /* Return attributes of the process given by its PID, a number. +If `default-directory' is remote, PID is regarded as process +identifier on the respective remote host. Value is an alist where each element is a cons cell of the form @@ -8247,6 +8263,12 @@ integer or floating point values. args -- command line which invoked the process (string). */) ( Lisp_Object pid) { + Lisp_Object handler + = Ffind_file_name_handler (BVAR (current_buffer, directory), + Qprocess_attributes); + if (!NILP (handler)) + return call2 (handler, Qprocess_attributes, pid); + return system_process_attributes (pid); } @@ -8422,6 +8444,8 @@ void syms_of_process (void) { DEFSYM (Qmake_process, "make-process"); + DEFSYM (Qlist_system_processes, "list-system-processes"); + DEFSYM (Qprocess_attributes, "process-attributes"); #ifdef subprocesses @@ -8580,6 +8604,13 @@ These functions are called in the order of the list, until one of them returns non-nil. */); Vinterrupt_process_functions = list1 (Qinternal_default_interrupt_process); + DEFVAR_LISP ("signal-process-functions", Vsignal_process_functions, + doc: /* List of functions to be called for `signal-process'. +The arguments of the functions are the same as for `signal-process'. +These functions are called in the order of the list, until one of them +returns non-nil. */); + Vsignal_process_functions = list1 (Qinternal_default_signal_process); + DEFVAR_LISP ("internal--daemon-sockname", Vinternal__daemon_sockname, doc: /* Name of external socket passed to Emacs, or nil if none. */); Vinternal__daemon_sockname = Qnil; @@ -8600,6 +8631,10 @@ sentinel or a process filter function has an error. */); "internal-default-interrupt-process"); DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions"); + DEFSYM (Qinternal_default_signal_process, + "internal-default-signal-process"); + DEFSYM (Qsignal_process_functions, "signal-process-functions"); + DEFSYM (Qnull, "null"); DEFSYM (Qpipe_process_p, "pipe-process-p"); @@ -8654,6 +8689,7 @@ sentinel or a process filter function has an error. */); defsubr (&Scontinue_process); defsubr (&Sprocess_running_child_p); defsubr (&Sprocess_send_eof); + defsubr (&Sinternal_default_signal_process); defsubr (&Ssignal_process); defsubr (&Swaiting_for_user_input_p); defsubr (&Sprocess_type); diff --git a/src/sort.c b/src/sort.c new file mode 100644 index 00000000000..c7ccfc23055 --- /dev/null +++ b/src/sort.c @@ -0,0 +1,974 @@ +/* Timsort for sequences. + +Copyright (C) 2022 Free Software Foundation, Inc. + +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 . */ + +/* This is a version of the cpython code implementing the TIMSORT + sorting algorithm described in + https://github.com/python/cpython/blob/main/Objects/listsort.txt. + This algorithm identifies and pushes naturally ordered sublists of + the original list, or "runs", onto a stack, and merges them + periodically according to a merge strategy called "powersort". + State is maintained during the sort in a merge_state structure, + which is passed around as an argument to all the subroutines. A + "stretch" structure includes a pointer to the run BASE of length + LEN along with its POWER (a computed integer used by the powersort + merge strategy that depends on this run and the succeeding run.) */ + + +#include +#include "lisp.h" + + +/* MAX_MERGE_PENDING is the maximum number of entries in merge_state's + pending-stretch stack. For a list with n elements, this needs at most + floor(log2(n)) + 1 entries even if we didn't force runs to a + minimal length. So the number of bits in a ptrdiff_t is plenty large + enough for all cases. */ + +#define MAX_MERGE_PENDING (sizeof (ptrdiff_t) * 8) + +/* Once we get into galloping mode, we stay there as long as both runs + win at least GALLOP_WIN_MIN consecutive times. */ + +#define GALLOP_WIN_MIN 7 + +/* A small temp array of size MERGESTATE_TEMP_SIZE is used to avoid + malloc when merging small lists. */ + +#define MERGESTATE_TEMP_SIZE 256 + +struct stretch +{ + Lisp_Object *base; + ptrdiff_t len; + int power; +}; + +struct reloc +{ + Lisp_Object **src; + Lisp_Object **dst; + ptrdiff_t *size; + int order; /* -1 while in merge_lo; +1 while in merg_hi; 0 otherwise. */ +}; + + +typedef struct +{ + Lisp_Object *listbase; + ptrdiff_t listlen; + + /* PENDING is a stack of N pending stretches yet to be merged. + Stretch #i starts at address base[i] and extends for len[i] + elements. */ + + int n; + struct stretch pending[MAX_MERGE_PENDING]; + + /* The variable MIN_GALLOP, initialized to GALLOP_WIN_MIN, controls + when we get *into* galloping mode. merge_lo and merge_hi tend to + nudge it higher for random data, and lower for highly structured + data. */ + + ptrdiff_t min_gallop; + + /* 'A' is temporary storage, able to hold ALLOCED elements, to help + with merges. 'A' initially points to TEMPARRAY, and subsequently + to newly allocated memory if needed. */ + + Lisp_Object *a; + ptrdiff_t alloced; + specpdl_ref count; + Lisp_Object temparray[MERGESTATE_TEMP_SIZE]; + + /* If an exception is thrown while merging we might have to relocate + some list elements from temporary storage back into the list. + RELOC keeps track of the information needed to do this. */ + + struct reloc reloc; + + /* PREDICATE is the lisp comparison predicate for the sort. */ + + Lisp_Object predicate; +} merge_state; + + +/* Return true iff (PREDICATE A B) is non-nil. */ + +static inline bool +inorder (const Lisp_Object predicate, const Lisp_Object a, const Lisp_Object b) +{ + return !NILP (call2 (predicate, a, b)); +} + + +/* Sort the list starting at LO and ending at HI using a stable binary + insertion sort algorithm. On entry the sublist [LO, START) (with + START between LO and HIGH) is known to be sorted (pass START == LO + if you are unsure). Even in case of error, the output will be some + permutation of the input (nothing is lost or duplicated). */ + +static void +binarysort (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi, + Lisp_Object *start) +{ + Lisp_Object pred = ms->predicate; + + eassume (lo <= start && start <= hi); + if (lo == start) + ++start; + for (; start < hi; ++start) + { + Lisp_Object *l = lo; + Lisp_Object *r = start; + Lisp_Object pivot = *r; + + eassume (l < r); + do { + Lisp_Object *p = l + ((r - l) >> 1); + if (inorder (pred, pivot, *p)) + r = p; + else + l = p + 1; + } while (l < r); + eassume (l == r); + for (Lisp_Object *p = start; p > l; --p) + p[0] = p[-1]; + *l = pivot; + } +} + + +/* Find and return the length of the "run" (the longest + non-decreasing sequence or the longest strictly decreasing + sequence, with the Boolean *DESCENDING set to 0 in the former + case, or to 1 in the latter) beginning at LO, in the slice [LO, + HI) with LO < HI. The strictness of the definition of + "descending" ensures there are no equal elements to get out of + order so the caller can safely reverse a descending sequence + without violating stability. */ + +static ptrdiff_t +count_run (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi, + bool *descending) +{ + Lisp_Object pred = ms->predicate; + + eassume (lo < hi); + *descending = 0; + ++lo; + ptrdiff_t n = 1; + if (lo == hi) + return n; + + n = 2; + if (inorder (pred, lo[0], lo[-1])) + { + *descending = 1; + for (lo = lo + 1; lo < hi; ++lo, ++n) + { + if (!inorder (pred, lo[0], lo[-1])) + break; + } + } + else + { + for (lo = lo + 1; lo < hi; ++lo, ++n) + { + if (inorder (pred, lo[0], lo[-1])) + break; + } + } + + return n; +} + + +/* Locate and return the proper insertion position of KEY in a sorted + vector: if the vector contains an element equal to KEY, return the + position immediately to the left of the leftmost equal element. + [GALLOP_RIGHT does the same except it returns the position to the + right of the rightmost equal element (if any).] + + 'A' is a sorted vector of N elements. N must be > 0. + + Elements preceding HINT, a non-negative index less than N, are + skipped. The closer HINT is to the final result, the faster this + runs. + + The return value is the int k in [0, N] such that + + A[k-1] < KEY <= a[k] + + pretending that *(A-1) precedes all values and *(A+N) succeeds all + values. In other words, the first k elements of A should precede + KEY, and the last N-k should follow KEY. */ + +static ptrdiff_t +gallop_left (merge_state *ms, const Lisp_Object key, Lisp_Object *a, + const ptrdiff_t n, const ptrdiff_t hint) +{ + Lisp_Object pred = ms->predicate; + + eassume (a && n > 0 && hint >= 0 && hint < n); + + a += hint; + ptrdiff_t lastofs = 0; + ptrdiff_t ofs = 1; + if (inorder (pred, *a, key)) + { + /* When a[hint] < key, gallop right until + a[hint + lastofs] < key <= a[hint + ofs]. */ + const ptrdiff_t maxofs = n - hint; /* This is one after the end of a. */ + while (ofs < maxofs) + { + if (inorder (pred, a[ofs], key)) + { + lastofs = ofs; + eassume (ofs <= (PTRDIFF_MAX - 1) / 2); + ofs = (ofs << 1) + 1; + } + else + break; /* Here key <= a[hint+ofs]. */ + } + if (ofs > maxofs) + ofs = maxofs; + /* Translate back to offsets relative to &a[0]. */ + lastofs += hint; + ofs += hint; + } + else + { + /* When key <= a[hint], gallop left, until + a[hint - ofs] < key <= a[hint - lastofs]. */ + const ptrdiff_t maxofs = hint + 1; /* Here &a[0] is lowest. */ + while (ofs < maxofs) + { + if (inorder (pred, a[-ofs], key)) + break; + /* Here key <= a[hint - ofs]. */ + lastofs = ofs; + eassume (ofs <= (PTRDIFF_MAX - 1) / 2); + ofs = (ofs << 1) + 1; + } + if (ofs > maxofs) + ofs = maxofs; + /* Translate back to use positive offsets relative to &a[0]. */ + ptrdiff_t k = lastofs; + lastofs = hint - ofs; + ofs = hint - k; + } + a -= hint; + + eassume (-1 <= lastofs && lastofs < ofs && ofs <= n); + /* Now a[lastofs] < key <= a[ofs], so key belongs somewhere to the + right of lastofs but no farther right than ofs. Do a binary + search, with invariant a[lastofs-1] < key <= a[ofs]. */ + ++lastofs; + while (lastofs < ofs) + { + ptrdiff_t m = lastofs + ((ofs - lastofs) >> 1); + + if (inorder (pred, a[m], key)) + lastofs = m + 1; /* Here a[m] < key. */ + else + ofs = m; /* Here key <= a[m]. */ + } + eassume (lastofs == ofs); /* Then a[ofs-1] < key <= a[ofs]. */ + return ofs; +} + + +/* Locate and return the proper position of KEY in a sorted vector + exactly like GALLOP_LEFT, except that if KEY already exists in + A[0:N] find the position immediately to the right of the rightmost + equal value. + + The return value is the int k in [0, N] such that + + A[k-1] <= KEY < A[k]. */ + +static ptrdiff_t +gallop_right (merge_state *ms, const Lisp_Object key, Lisp_Object *a, + const ptrdiff_t n, const ptrdiff_t hint) +{ + Lisp_Object pred = ms->predicate; + + eassume (a && n > 0 && hint >= 0 && hint < n); + + a += hint; + ptrdiff_t lastofs = 0; + ptrdiff_t ofs = 1; + if (inorder (pred, key, *a)) + { + /* When key < a[hint], gallop left until + a[hint - ofs] <= key < a[hint - lastofs]. */ + const ptrdiff_t maxofs = hint + 1; /* Here &a[0] is lowest. */ + while (ofs < maxofs) + { + if (inorder (pred, key, a[-ofs])) + { + lastofs = ofs; + eassume (ofs <= (PTRDIFF_MAX - 1) / 2); + ofs = (ofs << 1) + 1; + } + else /* Here a[hint - ofs] <= key. */ + break; + } + if (ofs > maxofs) + ofs = maxofs; + /* Translate back to use positive offsets relative to &a[0]. */ + ptrdiff_t k = lastofs; + lastofs = hint - ofs; + ofs = hint - k; + } + else + { + /* When a[hint] <= key, gallop right, until + a[hint + lastofs] <= key < a[hint + ofs]. */ + const ptrdiff_t maxofs = n - hint; /* Here &a[n-1] is highest. */ + while (ofs < maxofs) + { + if (inorder (pred, key, a[ofs])) + break; + /* Here a[hint + ofs] <= key. */ + lastofs = ofs; + eassume (ofs <= (PTRDIFF_MAX - 1) / 2); + ofs = (ofs << 1) + 1; + } + if (ofs > maxofs) + ofs = maxofs; + /* Translate back to use offsets relative to &a[0]. */ + lastofs += hint; + ofs += hint; + } + a -= hint; + + eassume (-1 <= lastofs && lastofs < ofs && ofs <= n); + /* Now a[lastofs] <= key < a[ofs], so key belongs somewhere to the + right of lastofs but no farther right than ofs. Do a binary + search, with invariant a[lastofs-1] <= key < a[ofs]. */ + ++lastofs; + while (lastofs < ofs) + { + ptrdiff_t m = lastofs + ((ofs - lastofs) >> 1); + + if (inorder (pred, key, a[m])) + ofs = m; /* Here key < a[m]. */ + else + lastofs = m + 1; /* Here a[m] <= key. */ + } + eassume (lastofs == ofs); /* Now a[ofs-1] <= key < a[ofs]. */ + return ofs; +} + + +static void +merge_init (merge_state *ms, const ptrdiff_t list_size, Lisp_Object *lo, + const Lisp_Object predicate) +{ + eassume (ms != NULL); + + ms->a = ms->temparray; + ms->alloced = MERGESTATE_TEMP_SIZE; + + ms->n = 0; + ms->min_gallop = GALLOP_WIN_MIN; + ms->listlen = list_size; + ms->listbase = lo; + ms->predicate = predicate; + ms->reloc = (struct reloc){NULL, NULL, NULL, 0}; +} + + +/* The dynamically allocated memory may hold lisp objects during + merging. MERGE_MARKMEM marks them so they aren't reaped during + GC. */ + +static void +merge_markmem (void *arg) +{ + merge_state *ms = arg; + eassume (ms != NULL); + + if (ms->reloc.size != NULL && *ms->reloc.size > 0) + { + eassume (ms->reloc.src != NULL); + mark_objects (*ms->reloc.src, *ms->reloc.size); + } +} + + +/* Free all temp storage. If an exception occurs while merging, + relocate any lisp elements in temp storage back to the original + array. */ + +static void +cleanup_mem (void *arg) +{ + merge_state *ms = arg; + eassume (ms != NULL); + + /* If we have an exception while merging, some of the list elements + might only live in temp storage; we copy everything remaining in + the temp storage back into the original list. This ensures that + the original list has all of the original elements, although + their order is unpredictable. */ + + if (ms->reloc.order != 0 && *ms->reloc.size > 0) + { + eassume (*ms->reloc.src != NULL && *ms->reloc.dst != NULL); + ptrdiff_t n = *ms->reloc.size; + ptrdiff_t shift = ms->reloc.order == -1 ? 0 : n - 1; + memcpy (*ms->reloc.dst - shift, *ms->reloc.src, n * word_size); + } + + /* Free any remaining temp storage. */ + xfree (ms->a); +} + + +/* Allocate enough temp memory for NEED array slots. Any previously + allocated memory is first freed, and a cleanup routine is + registered to free memory at the very end of the sort, or on + exception. */ + +static void +merge_getmem (merge_state *ms, const ptrdiff_t need) +{ + eassume (ms != NULL); + + if (ms->a == ms->temparray) + { + /* We only get here if alloc is needed and this is the first + time, so we set up the unwind protection. */ + specpdl_ref count = SPECPDL_INDEX (); + record_unwind_protect_ptr_mark (cleanup_mem, ms, merge_markmem); + ms->count = count; + } + else + { + /* We have previously alloced storage. Since we don't care + what's in the block we don't use realloc which would waste + cycles copying the old data. We just free and alloc + again. */ + xfree (ms->a); + } + ms->a = xmalloc (need * word_size); + ms->alloced = need; +} + + +static inline void +needmem (merge_state *ms, ptrdiff_t na) +{ + if (na > ms->alloced) + merge_getmem (ms, na); +} + + +/* Stably merge (in-place) the NA elements starting at SSA with the NB + elements starting at SSB = SSA + NA. NA and NB must be positive. + Require that SSA[NA-1] belongs at the end of the merge, and NA <= + NB. */ + +static void +merge_lo (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, Lisp_Object *ssb, + ptrdiff_t nb) +{ + Lisp_Object pred = ms->predicate; + + eassume (ms && ssa && ssb && na > 0 && nb > 0); + eassume (ssa + na == ssb); + needmem (ms, na); + memcpy (ms->a, ssa, na * word_size); + Lisp_Object *dest = ssa; + ssa = ms->a; + + ms->reloc = (struct reloc){&ssa, &dest, &na, -1}; + + *dest++ = *ssb++; + --nb; + if (nb == 0) + goto Succeed; + if (na == 1) + goto CopyB; + + ptrdiff_t min_gallop = ms->min_gallop; + for (;;) + { + ptrdiff_t acount = 0; /* The # of consecutive times A won. */ + + ptrdiff_t bcount = 0; /* The # of consecutive times B won. */ + + for (;;) + { + eassume (na > 1 && nb > 0); + if (inorder (pred, *ssb, *ssa)) + { + *dest++ = *ssb++ ; + ++bcount; + acount = 0; + --nb; + if (nb == 0) + goto Succeed; + if (bcount >= min_gallop) + break; + } + else + { + *dest++ = *ssa++; + ++acount; + bcount = 0; + --na; + if (na == 1) + goto CopyB; + if (acount >= min_gallop) + break; + } + } + + /* One run is winning so consistently that galloping may be a + huge speedup. We try that, and continue galloping until (if + ever) neither run appears to be winning consistently + anymore. */ + ++min_gallop; + do { + eassume (na > 1 && nb > 0); + min_gallop -= min_gallop > 1; + ms->min_gallop = min_gallop; + ptrdiff_t k = gallop_right (ms, ssb[0], ssa, na, 0); + acount = k; + if (k) + { + memcpy (dest, ssa, k * word_size); + dest += k; + ssa += k; + na -= k; + if (na == 1) + goto CopyB; + /* While na==0 is impossible for a consistent comparison + function, we shouldn't assume that it is. */ + if (na == 0) + goto Succeed; + } + *dest++ = *ssb++ ; + --nb; + if (nb == 0) + goto Succeed; + + k = gallop_left (ms, ssa[0], ssb, nb, 0); + bcount = k; + if (k) + { + memmove (dest, ssb, k * word_size); + dest += k; + ssb += k; + nb -= k; + if (nb == 0) + goto Succeed; + } + *dest++ = *ssa++; + --na; + if (na == 1) + goto CopyB; + } while (acount >= GALLOP_WIN_MIN || bcount >= GALLOP_WIN_MIN); + ++min_gallop; /* Apply a penalty for leaving galloping mode. */ + ms->min_gallop = min_gallop; + } + Succeed: + ms->reloc = (struct reloc){NULL, NULL, NULL, 0}; + + if (na) + memcpy (dest, ssa, na * word_size); + return; + CopyB: + eassume (na == 1 && nb > 0); + ms->reloc = (struct reloc){NULL, NULL, NULL, 0}; + + /* The last element of ssa belongs at the end of the merge. */ + memmove (dest, ssb, nb * word_size); + dest[nb] = ssa[0]; +} + + +/* Stably merge (in-place) the NA elements starting at SSA with the NB + elements starting at SSB = SSA + NA. NA and NB must be positive. + Require that SSA[NA-1] belongs at the end of the merge, and NA >= + NB. */ + +static void +merge_hi (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, + Lisp_Object *ssb, ptrdiff_t nb) +{ + Lisp_Object pred = ms->predicate; + + eassume (ms && ssa && ssb && na > 0 && nb > 0); + eassume (ssa + na == ssb); + needmem (ms, nb); + Lisp_Object *dest = ssb; + dest += nb - 1; + memcpy(ms->a, ssb, nb * word_size); + Lisp_Object *basea = ssa; + Lisp_Object *baseb = ms->a; + ssb = ms->a + nb - 1; + ssa += na - 1; + + ms->reloc = (struct reloc){&baseb, &dest, &nb, 1}; + + *dest-- = *ssa--; + --na; + if (na == 0) + goto Succeed; + if (nb == 1) + goto CopyA; + + ptrdiff_t min_gallop = ms->min_gallop; + for (;;) { + ptrdiff_t acount = 0; /* The # of consecutive times A won. */ + ptrdiff_t bcount = 0; /* The # of consecutive times B won. */ + + for (;;) { + eassume (na > 0 && nb > 1); + if (inorder (pred, *ssb, *ssa)) + { + *dest-- = *ssa--; + ++acount; + bcount = 0; + --na; + if (na == 0) + goto Succeed; + if (acount >= min_gallop) + break; + } + else + { + *dest-- = *ssb--; + ++bcount; + acount = 0; + --nb; + if (nb == 1) + goto CopyA; + if (bcount >= min_gallop) + break; + } + } + + /* One run is winning so consistently that galloping may be a huge + speedup. Try that, and continue galloping until (if ever) + neither run appears to be winning consistently anymore. */ + ++min_gallop; + do { + eassume (na > 0 && nb > 1); + min_gallop -= min_gallop > 1; + ms->min_gallop = min_gallop; + ptrdiff_t k = gallop_right (ms, ssb[0], basea, na, na - 1); + k = na - k; + acount = k; + if (k) + { + dest += -k; + ssa += -k; + memmove(dest + 1, ssa + 1, k * word_size); + na -= k; + if (na == 0) + goto Succeed; + } + *dest-- = *ssb--; + --nb; + if (nb == 1) + goto CopyA; + + k = gallop_left (ms, ssa[0], baseb, nb, nb - 1); + k = nb - k; + bcount = k; + if (k) + { + dest += -k; + ssb += -k; + memcpy(dest + 1, ssb + 1, k * word_size); + nb -= k; + if (nb == 1) + goto CopyA; + /* While nb==0 is impossible for a consistent comparison + function we shouldn't assume that it is. */ + if (nb == 0) + goto Succeed; + } + *dest-- = *ssa--; + --na; + if (na == 0) + goto Succeed; + } while (acount >= GALLOP_WIN_MIN || bcount >= GALLOP_WIN_MIN); + ++min_gallop; /* Apply a penalty for leaving galloping mode. */ + ms->min_gallop = min_gallop; + } + Succeed: + ms->reloc = (struct reloc){NULL, NULL, NULL, 0}; + if (nb) + memcpy (dest - nb + 1, baseb, nb * word_size); + return; + CopyA: + eassume (nb == 1 && na > 0); + ms->reloc = (struct reloc){NULL, NULL, NULL, 0}; + /* The first element of ssb belongs at the front of the merge. */ + memmove (dest + 1 - na, ssa + 1 - na, na * word_size); + dest += -na; + ssa += -na; + dest[0] = ssb[0]; +} + + +/* Merge the two runs at stack indices I and I+1. */ + +static void +merge_at (merge_state *ms, const ptrdiff_t i) +{ + eassume (ms != NULL); + eassume (ms->n >= 2); + eassume (i >= 0); + eassume (i == ms->n - 2 || i == ms->n - 3); + + Lisp_Object *ssa = ms->pending[i].base; + ptrdiff_t na = ms->pending[i].len; + Lisp_Object *ssb = ms->pending[i + 1].base; + ptrdiff_t nb = ms->pending[i + 1].len; + eassume (na > 0 && nb > 0); + eassume (ssa + na == ssb); + + /* Record the length of the combined runs. The current run i+1 goes + away after the merge. If i is the 3rd-last run now, slide the + last run (which isn't involved in this merge) over to i+1. */ + ms->pending[i].len = na + nb; + if (i == ms->n - 3) + ms->pending[i + 1] = ms->pending[i + 2]; + --ms->n; + + /* Where does b start in a? Elements in a before that can be + ignored (they are already in place). */ + ptrdiff_t k = gallop_right (ms, *ssb, ssa, na, 0); + eassume (k >= 0); + ssa += k; + na -= k; + if (na == 0) + return; + + /* Where does a end in b? Elements in b after that can be ignored + (they are already in place). */ + nb = gallop_left (ms, ssa[na - 1], ssb, nb, nb - 1); + if (nb == 0) + return; + eassume (nb > 0); + /* Merge what remains of the runs using a temp array with size + min(na, nb) elements. */ + if (na <= nb) + merge_lo (ms, ssa, na, ssb, nb); + else + merge_hi (ms, ssa, na, ssb, nb); +} + + +/* Compute the "power" of the first of two adjacent runs begining at + index S1, with the first having length N1 and the second (starting + at index S1+N1) having length N2. The run has total length N. */ + +static int +powerloop (const ptrdiff_t s1, const ptrdiff_t n1, const ptrdiff_t n2, + const ptrdiff_t n) +{ + eassume (s1 >= 0); + eassume (n1 > 0 && n2 > 0); + eassume (s1 + n1 + n2 <= n); + /* The midpoints a and b are + a = s1 + n1/2 + b = s1 + n1 + n2/2 = a + (n1 + n2)/2 + + These may not be integers because of the "/2", so we work with + 2*a and 2*b instead. It makes no difference to the outcome, + since the bits in the expansion of (2*i)/n are merely shifted one + position from those of i/n. */ + ptrdiff_t a = 2 * s1 + n1; + ptrdiff_t b = a + n1 + n2; + int result = 0; + /* Emulate a/n and b/n one bit a time, until their bits differ. */ + for (;;) + { + ++result; + if (a >= n) + { /* Both quotient bits are now 1. */ + eassume (b >= a); + a -= n; + b -= n; + } + else if (b >= n) + { /* a/n bit is 0 and b/n bit is 1. */ + break; + } /* Otherwise both quotient bits are 0. */ + eassume (a < b && b < n); + a <<= 1; + b <<= 1; + } + return result; +} + + +/* Update the state upon identifying a run of length N2. If there's + already a stretch on the stack, apply the "powersort" merge + strategy: compute the topmost stretch's "power" (depth in a + conceptual binary merge tree) and merge adjacent runs on the stack + with greater power. */ + +static void +found_new_run (merge_state *ms, const ptrdiff_t n2) +{ + eassume (ms != NULL); + if (ms->n) + { + eassume (ms->n > 0); + struct stretch *p = ms->pending; + ptrdiff_t s1 = p[ms->n - 1].base - ms->listbase; + ptrdiff_t n1 = p[ms->n - 1].len; + int power = powerloop (s1, n1, n2, ms->listlen); + while (ms->n > 1 && p[ms->n - 2].power > power) + { + merge_at (ms, ms->n - 2); + } + eassume (ms->n < 2 || p[ms->n - 2].power < power); + p[ms->n - 1].power = power; + } +} + + +/* Unconditionally merge all stretches on the stack until only one + remains. */ + +static void +merge_force_collapse (merge_state *ms) +{ + struct stretch *p = ms->pending; + + eassume (ms != NULL); + while (ms->n > 1) + { + ptrdiff_t n = ms->n - 2; + if (n > 0 && p[n - 1].len < p[n + 1].len) + --n; + merge_at (ms, n); + } +} + + +/* Compute a good value for the minimum run length; natural runs + shorter than this are boosted artificially via binary insertion. + + If N < 64, return N (it's too small to bother with fancy stuff). + Otherwise if N is an exact power of 2, return 32. Finally, return + an int k, 32 <= k <= 64, such that N/k is close to, but strictly + less than, an exact power of 2. */ + +static ptrdiff_t +merge_compute_minrun (ptrdiff_t n) +{ + ptrdiff_t r = 0; /* r will become 1 if any non-zero bits are + shifted off. */ + + eassume (n >= 0); + while (n >= 64) + { + r |= n & 1; + n >>= 1; + } + return n + r; +} + + +static void +reverse_vector (Lisp_Object *s, const ptrdiff_t n) +{ + for (ptrdiff_t i = 0; i < n >> 1; i++) + { + Lisp_Object tem = s[i]; + s[i] = s[n - i - 1]; + s[n - i - 1] = tem; + } +} + +/* Sort the array SEQ with LENGTH elements in the order determined by + PREDICATE. */ + +void +tim_sort (Lisp_Object predicate, Lisp_Object *seq, const ptrdiff_t length) +{ + if (SYMBOLP (predicate)) + { + /* Attempt to resolve the function as far as possible ahead of time, + to avoid having to do it for each call. */ + Lisp_Object fun = XSYMBOL (predicate)->u.s.function; + if (SYMBOLP (fun)) + /* Function was an alias; use slow-path resolution. */ + fun = indirect_function (fun); + /* Don't resolve to an autoload spec; that would be very slow. */ + if (!NILP (fun) && !(CONSP (fun) && EQ (XCAR (fun), Qautoload))) + predicate = fun; + } + + merge_state ms; + Lisp_Object *lo = seq; + + merge_init (&ms, length, lo, predicate); + + /* March over the array once, left to right, finding natural runs, + and extending short natural runs to minrun elements. */ + const ptrdiff_t minrun = merge_compute_minrun (length); + ptrdiff_t nremaining = length; + do { + bool descending; + + /* Identify the next run. */ + ptrdiff_t n = count_run (&ms, lo, lo + nremaining, &descending); + if (descending) + reverse_vector (lo, n); + /* If the run is short, extend it to min(minrun, nremaining). */ + if (n < minrun) + { + const ptrdiff_t force = nremaining <= minrun ? + nremaining : minrun; + binarysort (&ms, lo, lo + force, lo + n); + n = force; + } + eassume (ms.n == 0 || ms.pending[ms.n - 1].base + + ms.pending[ms.n - 1].len == lo); + found_new_run (&ms, n); + /* Push the new run on to the stack. */ + eassume (ms.n < MAX_MERGE_PENDING); + ms.pending[ms.n].base = lo; + ms.pending[ms.n].len = n; + ++ms.n; + /* Advance to find the next run. */ + lo += n; + nremaining -= n; + } while (nremaining); + + merge_force_collapse (&ms); + eassume (ms.n == 1); + eassume (ms.pending[0].len == length); + lo = ms.pending[0].base; + + if (ms.a != ms.temparray) + unbind_to (ms.count, Qnil); +} diff --git a/src/sqlite.c b/src/sqlite.c index 649cb382948..75a3b2ea32c 100644 --- a/src/sqlite.c +++ b/src/sqlite.c @@ -1,4 +1,5 @@ -/* +/* Support for accessing SQLite databases. + Copyright (C) 2021-2022 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -19,8 +20,7 @@ along with GNU Emacs. If not, see . This file is based on the emacs-sqlite3 package written by Syohei YOSHIDA , which can be found at: - https://github.com/syohex/emacs-sqlite3 -*/ + https://github.com/syohex/emacs-sqlite3 */ #include #include "lisp.h" @@ -43,6 +43,8 @@ DEF_DLL_FN (SQLITE_API int, sqlite3_open_v2, DEF_DLL_FN (SQLITE_API int, sqlite3_reset, (sqlite3_stmt*)); DEF_DLL_FN (SQLITE_API int, sqlite3_bind_text, (sqlite3_stmt*, int, const char*, int, void(*)(void*))); +DEF_DLL_FN (SQLITE_API int, sqlite3_bind_blob, + (sqlite3_stmt*, int, const char*, int, void(*)(void*))); DEF_DLL_FN (SQLITE_API int, sqlite3_bind_int64, (sqlite3_stmt*, int, sqlite3_int64)); DEF_DLL_FN (SQLITE_API int, sqlite3_bind_double, (sqlite3_stmt*, int, double)); @@ -80,6 +82,7 @@ DEF_DLL_FN (SQLITE_API int, sqlite3_load_extension, # undef sqlite3_open_v2 # undef sqlite3_reset # undef sqlite3_bind_text +# undef sqlite3_bind_blob # undef sqlite3_bind_int64 # undef sqlite3_bind_double # undef sqlite3_bind_null @@ -103,6 +106,7 @@ DEF_DLL_FN (SQLITE_API int, sqlite3_load_extension, # define sqlite3_open_v2 fn_sqlite3_open_v2 # define sqlite3_reset fn_sqlite3_reset # define sqlite3_bind_text fn_sqlite3_bind_text +# define sqlite3_bind_blob fn_sqlite3_bind_blob # define sqlite3_bind_int64 fn_sqlite3_bind_int64 # define sqlite3_bind_double fn_sqlite3_bind_double # define sqlite3_bind_null fn_sqlite3_bind_null @@ -129,6 +133,7 @@ load_dll_functions (HMODULE library) LOAD_DLL_FN (library, sqlite3_open_v2); LOAD_DLL_FN (library, sqlite3_reset); LOAD_DLL_FN (library, sqlite3_bind_text); + LOAD_DLL_FN (library, sqlite3_bind_blob); LOAD_DLL_FN (library, sqlite3_bind_int64); LOAD_DLL_FN (library, sqlite3_bind_double); LOAD_DLL_FN (library, sqlite3_bind_null); @@ -240,38 +245,36 @@ DEFUN ("sqlite-open", Fsqlite_open, Ssqlite_open, 0, 1, 0, If FILE is nil, an in-memory database will be opened instead. */) (Lisp_Object file) { - char *name; + Lisp_Object name; + int flags = (SQLITE_OPEN_CREATE | SQLITE_OPEN_FULLMUTEX + | SQLITE_OPEN_READWRITE); +#ifdef SQLITE_OPEN_URI + flags |= SQLITE_OPEN_URI; +#endif + if (!init_sqlite_functions ()) xsignal1 (Qerror, build_string ("sqlite support is not available")); if (!NILP (file)) - { - CHECK_STRING (file); - file = ENCODE_FILE (Fexpand_file_name (file, Qnil)); - name = xstrdup (SSDATA (file)); - } + name = ENCODE_FILE (Fexpand_file_name (file, Qnil)); else - /* In-memory database. These have to have different names to - refer to different databases. */ - name = xstrdup (SSDATA (CALLN (Fformat, build_string (":memory:%d"), - make_int (++db_count)))); + { +#ifdef SQLITE_OPEN_MEMORY + /* In-memory database. These have to have different names to + refer to different databases. */ + AUTO_STRING (memory_fmt, ":memory:%d"); + name = CALLN (Fformat, memory_fmt, make_int (++db_count)); + flags |= SQLITE_OPEN_MEMORY; +#else + xsignal1 (Qerror, build_string ("sqlite in-memory is not available")); +#endif + } sqlite3 *sdb; - int ret = sqlite3_open_v2 (name, - &sdb, - SQLITE_OPEN_FULLMUTEX - | SQLITE_OPEN_READWRITE - | SQLITE_OPEN_CREATE - | (NILP (file) ? SQLITE_OPEN_MEMORY : 0) -#ifdef SQLITE_OPEN_URI - | SQLITE_OPEN_URI -#endif - | 0, NULL); - - if (ret != SQLITE_OK) + if (sqlite3_open_v2 (SSDATA (name), &sdb, flags, NULL) != SQLITE_OK) return Qnil; - return make_sqlite (false, sdb, NULL, name); + return make_sqlite (false, sdb, NULL, xstrdup (SSDATA (name))); } DEFUN ("sqlite-close", Fsqlite_close, Ssqlite_close, 1, 1, 0, @@ -311,10 +314,37 @@ bind_values (sqlite3 *db, sqlite3_stmt *stmt, Lisp_Object values) if (EQ (type, Qstring)) { - Lisp_Object encoded = encode_string (value); - ret = sqlite3_bind_text (stmt, i + 1, - SSDATA (encoded), SBYTES (encoded), - NULL); + Lisp_Object encoded; + bool blob = false; + + if (SBYTES (value) == 0) + encoded = value; + else + { + Lisp_Object coding_system = + Fget_text_property (make_fixnum (0), Qcoding_system, value); + if (NILP (coding_system)) + /* Default to utf-8. */ + encoded = encode_string (value); + else if (EQ (coding_system, Qbinary)) + blob = true; + else + encoded = Fencode_coding_string (value, coding_system, + Qnil, Qnil); + } + + if (blob) + { + if (SBYTES (value) != SCHARS (value)) + xsignal1 (Qerror, build_string ("BLOB values must be unibyte")); + ret = sqlite3_bind_blob (stmt, i + 1, + SSDATA (value), SBYTES (value), + NULL); + } + else + ret = sqlite3_bind_text (stmt, i + 1, + SSDATA (encoded), SBYTES (encoded), + NULL); } else if (EQ (type, Qinteger)) { @@ -428,11 +458,8 @@ row_to_value (sqlite3_stmt *stmt) break; case SQLITE_BLOB: - v = - code_convert_string_norecord - (make_unibyte_string (sqlite3_column_blob (stmt, i), - sqlite3_column_bytes (stmt, i)), - Qutf_8, false); + v = make_unibyte_string (sqlite3_column_blob (stmt, i), + sqlite3_column_bytes (stmt, i)); break; case SQLITE_NULL: @@ -750,4 +777,6 @@ syms_of_sqlite (void) DEFSYM (Qfalse, "false"); DEFSYM (Qsqlite, "sqlite"); DEFSYM (Qsqlite3, "sqlite3"); + DEFSYM (Qbinary, "binary"); + DEFSYM (Qcoding_system, "coding-system"); } diff --git a/src/syntax.c b/src/syntax.c index 13c36fdf3cd..f9022d18d26 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -1074,7 +1074,7 @@ unsigned char const syntax_spec_code[0400] = /* Indexed by syntax code, give the letter that describes it. */ -char const syntax_code_spec[16] = +static char const syntax_code_spec[16] = { ' ', '.', 'w', '_', '(', ')', '\'', '\"', '$', '\\', '/', '<', '>', '@', '!', '|' diff --git a/src/syntax.h b/src/syntax.h index c1bb9274d00..5949a95a73b 100644 --- a/src/syntax.h +++ b/src/syntax.h @@ -147,10 +147,6 @@ extern bool syntax_prefix_flag_p (int c); extern unsigned char const syntax_spec_code[0400]; -/* Indexed by syntax code, give the letter that describes it. */ - -extern char const syntax_code_spec[16]; - /* Convert the byte offset BYTEPOS into a character position, for the object recorded in gl_state with SETUP_SYNTAX_TABLE_FOR_OBJECT. diff --git a/src/sysdep.c b/src/sysdep.c index b5b18ee6c0f..95295e7e676 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -2200,6 +2200,16 @@ get_random (void) return val & INTMASK; } +/* Return a random unsigned long. */ +unsigned long int +get_random_ulong (void) +{ + unsigned long int r = 0; + for (int i = 0; i < (ULONG_WIDTH + RAND_BITS - 1) / RAND_BITS; i++) + r = random () ^ (r << RAND_BITS) ^ (r >> (ULONG_WIDTH - RAND_BITS)); + return r; +} + #ifndef HAVE_SNPRINTF /* Approximate snprintf as best we can on ancient hosts that lack it. */ int @@ -2320,6 +2330,20 @@ emacs_fstatat (int dirfd, char const *filename, void *st, int flags) return r; } +static int +sys_openat (int dirfd, char const *file, int oflags, int mode) +{ +#ifdef O_PATH + return openat (dirfd, file, oflags, mode); +#else + /* On platforms without O_PATH, emacs_openat's callers arrange for + DIRFD to be AT_FDCWD, so it should be safe to just call 'open'. + This ports to old platforms like OS X 10.9 that lack openat. */ + eassert (dirfd == AT_FDCWD); + return open (file, oflags, mode); +#endif +} + /* Assuming the directory DIRFD, open FILE for Emacs use, using open flags OFLAGS and mode MODE. Use binary I/O on systems that care about text vs binary I/O. @@ -2335,7 +2359,7 @@ emacs_openat (int dirfd, char const *file, int oflags, int mode) if (! (oflags & O_TEXT)) oflags |= O_BINARY; oflags |= O_CLOEXEC; - while ((fd = openat (dirfd, file, oflags, mode)) < 0 && errno == EINTR) + while ((fd = sys_openat (dirfd, file, oflags, mode)) < 0 && errno == EINTR) maybe_quit (); return fd; } @@ -2348,26 +2372,19 @@ emacs_open (char const *file, int oflags, int mode) /* Same as above, but doesn't allow the user to quit. */ -static int -emacs_openat_noquit (int dirfd, const char *file, int oflags, - int mode) +int +emacs_open_noquit (char const *file, int oflags, int mode) { int fd; if (! (oflags & O_TEXT)) oflags |= O_BINARY; oflags |= O_CLOEXEC; do - fd = openat (dirfd, file, oflags, mode); + fd = open (file, oflags, mode); while (fd < 0 && errno == EINTR); return fd; } -int -emacs_open_noquit (char const *file, int oflags, int mode) -{ - return emacs_openat_noquit (AT_FDCWD, file, oflags, mode); -} - /* Open FILE as a stream for Emacs use, with mode MODE. Act like emacs_open with respect to threads, signals, and quits. */ @@ -3176,7 +3193,7 @@ make_lisp_timeval (struct timeval t) #endif -#ifdef GNU_LINUX +#if defined (GNU_LINUX) || defined (CYGWIN) static Lisp_Object time_from_jiffies (unsigned long long ticks, Lisp_Object hz, Lisp_Object form) @@ -3224,6 +3241,7 @@ get_up_time (void) return up; } +# ifdef GNU_LINUX #define MAJOR(d) (((unsigned)(d) >> 8) & 0xfff) #define MINOR(d) (((unsigned)(d) & 0xff) | (((unsigned)(d) & 0xfff00000) >> 12)) @@ -3269,6 +3287,7 @@ procfs_ttyname (int rdev) unblock_input (); return build_string (name); } +# endif /* GNU_LINUX */ static uintmax_t procfs_get_total_memory (void) @@ -3403,7 +3422,7 @@ system_process_attributes (Lisp_Object pid) utime stime cutime cstime priority nice thcount . start vsize rss */ if (q && (sscanf (q + 2, ("%c %d %d %d %d %d %*u %lu %lu %lu %lu " - "%Lu %Lu %Lu %Lu %ld %ld %d %*d %Lu %lu %ld"), + "%llu %llu %llu %llu %ld %ld %d %*d %llu %lu %ld"), &c, &ppid, &pgrp, &sess, &tty, &tpgid, &minflt, &cminflt, &majflt, &cmajflt, &u_time, &s_time, &cutime, &cstime, @@ -3417,7 +3436,9 @@ system_process_attributes (Lisp_Object pid) attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (ppid)), attrs); attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (pgrp)), attrs); attrs = Fcons (Fcons (Qsess, INT_TO_INTEGER (sess)), attrs); +# ifdef GNU_LINUX attrs = Fcons (Fcons (Qttname, procfs_ttyname (tty)), attrs); +# endif attrs = Fcons (Fcons (Qtpgid, INT_TO_INTEGER (tpgid)), attrs); attrs = Fcons (Fcons (Qminflt, INT_TO_INTEGER (minflt)), attrs); attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (majflt)), attrs); @@ -3466,6 +3487,26 @@ system_process_attributes (Lisp_Object pid) } unbind_to (count, Qnil); +# ifdef CYGWIN + /* ttname */ + strcpy (procfn_end, "/ctty"); + fd = emacs_open (fn, O_RDONLY, 0); + if (fd < 0) + nread = 0; + else + { + record_unwind_protect_int (close_file_unwind, fd); + nread = emacs_read_quit (fd, procbuf, sizeof procbuf); + } + /* /proc//ctty should always end in newline. */ + if (0 < nread && procbuf[nread - 1] == '\n') + procbuf[nread - 1] = '\0'; + else + procbuf[0] = '\0'; + attrs = Fcons (Fcons (Qttname, build_string (procbuf)), attrs); + unbind_to (count, Qnil); +# endif /* CYGWIN */ + /* args */ strcpy (procfn_end, "/cmdline"); fd = emacs_open (fn, O_RDONLY, 0); @@ -4002,6 +4043,9 @@ system_process_attributes (Lisp_Object pid) #elif defined DARWIN_OS +#define HAVE_RUSAGE_INFO_CURRENT (__MAC_OS_X_VERSION_MIN_REQUIRED >= 101000) +#define HAVE_PROC_PIDINFO (__MAC_OS_X_VERSION_MIN_REQUIRED >= 1050) + Lisp_Object system_process_attributes (Lisp_Object pid) { @@ -4104,6 +4148,7 @@ system_process_attributes (Lisp_Object pid) attrs = Fcons (Fcons (Qtpgid, INT_TO_INTEGER (proc.kp_eproc.e_tpgid)), attrs); +#if HAVE_RUSAGE_INFO_CURRENT rusage_info_current ri; if (proc_pid_rusage(proc_id, RUSAGE_INFO_CURRENT, (rusage_info_t *) &ri) == 0) { @@ -4117,6 +4162,22 @@ system_process_attributes (Lisp_Object pid) attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (ri.ri_pageins)), attrs); } +#else /* !HAVE_RUSAGE_INFO_CURRENT */ + struct rusage *rusage = proc.kp_proc.p_ru; + if (rusage) + { + attrs = Fcons (Fcons (Qminflt, INT_TO_INTEGER (rusage->ru_minflt)), + attrs); + attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (rusage->ru_majflt)), + attrs); + + Lisp_Object utime = make_lisp_timeval (rusage->ru_utime); + Lisp_Object stime = make_lisp_timeval (rusage->ru_stime); + attrs = Fcons (Fcons (Qutime, utime), attrs); + attrs = Fcons (Fcons (Qstime, stime), attrs); + attrs = Fcons (Fcons (Qtime, Ftime_add (utime, stime)), attrs); + } +#endif /* !HAVE_RUSAGE_INFO_CURRENT */ starttime = proc.kp_proc.p_starttime; attrs = Fcons (Fcons (Qnice, make_fixnum (proc.kp_proc.p_nice)), attrs); @@ -4127,6 +4188,7 @@ system_process_attributes (Lisp_Object pid) Lisp_Object etime = Ftime_convert (Ftime_subtract (now, start), Qnil); attrs = Fcons (Fcons (Qetime, etime), attrs); +#if HAVE_PROC_PIDINFO struct proc_taskinfo taskinfo; if (proc_pidinfo (proc_id, PROC_PIDTASKINFO, 0, &taskinfo, sizeof (taskinfo)) > 0) { @@ -4134,6 +4196,7 @@ system_process_attributes (Lisp_Object pid) attrs = Fcons (Fcons (Qrss, make_fixnum (taskinfo.pti_resident_size / 1024)), attrs); attrs = Fcons (Fcons (Qthcount, make_fixnum (taskinfo.pti_threadnum)), attrs); } +#endif /* HAVE_PROC_PIDINFO */ #ifdef KERN_PROCARGS2 char args[ARG_MAX]; diff --git a/src/systime.h b/src/systime.h index 41d728f1c29..75088bd4a62 100644 --- a/src/systime.h +++ b/src/systime.h @@ -91,7 +91,6 @@ extern Lisp_Object timespec_to_lisp (struct timespec); extern bool list4_to_timespec (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, struct timespec *); extern struct timespec lisp_time_argument (Lisp_Object); -extern AVOID time_overflow (void); extern double float_time (Lisp_Object); extern void init_timefns (void); extern void syms_of_timefns (void); diff --git a/src/termhooks.h b/src/termhooks.h index 93ac9ba0d2e..8c193914ba8 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -208,6 +208,25 @@ enum event_kind representation of the dropped items. .timestamp gives a timestamp (in milliseconds) for the click. */ +#ifdef HAVE_X_WINDOWS + UNSUPPORTED_DROP_EVENT, /* Event sent when the regular C + drag-and-drop machinery could not + handle a drop to a window. + + .code is the XID of the window that + could not be dropped to. + + .arg is a list of the local value of + XdndSelection, a list of selection + targets, and the intended action to + be taken upon drop, and .timestamp + gives the timestamp where the drop + happened. + + .x and .y give the coordinates of + the drop originating from the root + window. */ +#endif USER_SIGNAL_EVENT, /* A user signal. code is a number identifying it, index into lispy_user_signals. */ @@ -373,9 +392,17 @@ struct input_event when building events. Unfortunately some events have to pass much more data than it's reasonable to pack directly into this structure. */ Lisp_Object arg; + + /* The name of the device from which this event originated. + + It can either be a string, or Qt, which means to use the name + "Virtual core pointer" for all events other than keystroke + events, and "Virtual core keyboard" for those. */ + Lisp_Object device; }; -#define EVENT_INIT(event) memset (&(event), 0, sizeof (struct input_event)) +#define EVENT_INIT(event) (memset (&(event), 0, sizeof (struct input_event)), \ + (event).device = Qt) /* Bits in the modifiers member of the input_event structure. Note that reorder_modifiers assumes that the bits are in canonical diff --git a/src/textprop.c b/src/textprop.c index c6c9e102e34..072aac28667 100644 --- a/src/textprop.c +++ b/src/textprop.c @@ -561,8 +561,13 @@ DEFUN ("text-properties-at", Ftext_properties_at, doc: /* Return the list of properties of the character at POSITION in OBJECT. If the optional second argument OBJECT is a buffer (or nil, which means the current buffer), POSITION is a buffer position (integer or marker). + If OBJECT is a string, POSITION is a 0-based index into it. -If POSITION is at the end of OBJECT, the value is nil. + +If POSITION is at the end of OBJECT, the value is nil, but note that +buffer narrowing does not affect the value. That is, if OBJECT is a +buffer or nil, and the buffer is narrowed and POSITION is at the end +of the narrowed buffer, the result may be non-nil. If you want to display the text properties at point in a human-readable form, use the `describe-text-properties' command. */) @@ -590,7 +595,11 @@ DEFUN ("get-text-property", Fget_text_property, Sget_text_property, 2, 3, 0, doc: /* Return the value of POSITION's property PROP, in OBJECT. OBJECT should be a buffer or a string; if omitted or nil, it defaults to the current buffer. -If POSITION is at the end of OBJECT, the value is nil. */) + +If POSITION is at the end of OBJECT, the value is nil, but note that +buffer narrowing does not affect the value. That is, if the buffer is +narrowed and POSITION is at the end of the narrowed buffer, the result +may be non-nil. */) (Lisp_Object position, Lisp_Object prop, Lisp_Object object) { return textget (Ftext_properties_at (position, object), prop); diff --git a/src/thread.c b/src/thread.c index 4c98d590b7a..626d14aad0a 100644 --- a/src/thread.c +++ b/src/thread.c @@ -655,7 +655,7 @@ mark_one_thread (struct thread_state *thread) mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr); - mark_stack (thread->m_stack_bottom, stack_top); + mark_c_stack (thread->m_stack_bottom, stack_top); for (struct handler *handler = thread->m_handlerlist; handler; handler = handler->next) @@ -671,6 +671,8 @@ mark_one_thread (struct thread_state *thread) mark_object (tem); } + mark_bytecode (&thread->bc); + /* No need to mark Lisp_Object members like m_last_thing_searched, as mark_threads_callback does that by calling mark_object. */ } @@ -790,7 +792,7 @@ run_thread (void *state) xfree (self->m_specpdl - 1); self->m_specpdl = NULL; self->m_specpdl_ptr = NULL; - self->m_specpdl_size = 0; + self->m_specpdl_end = NULL; { struct handler *c, *c_next; @@ -839,6 +841,7 @@ finalize_one_thread (struct thread_state *state) free_search_regs (&state->m_search_regs); free_search_regs (&state->m_saved_search_regs); sys_cond_destroy (&state->thread_condvar); + free_bc_thread (&state->bc); } DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0, @@ -862,13 +865,14 @@ If NAME is given, it must be a string; it names the new thread. */) /* Perhaps copy m_last_thing_searched from parent? */ new_thread->m_current_buffer = current_thread->m_current_buffer; - new_thread->m_specpdl_size = 50; - new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size) - * sizeof (union specbinding)); - /* Skip the dummy entry. */ - ++new_thread->m_specpdl; + ptrdiff_t size = 50; + union specbinding *pdlvec = xmalloc ((1 + size) * sizeof (union specbinding)); + new_thread->m_specpdl = pdlvec + 1; /* Skip the dummy entry. */ + new_thread->m_specpdl_end = new_thread->m_specpdl + size; new_thread->m_specpdl_ptr = new_thread->m_specpdl; + init_bc_thread (&new_thread->bc); + sys_cond_init (&new_thread->thread_condvar); /* We'll need locking here eventually. */ @@ -1128,6 +1132,7 @@ init_threads (void) sys_mutex_lock (&global_lock); current_thread = &main_thread.s; main_thread.s.thread_id = sys_thread_self (); + init_bc_thread (&main_thread.s.bc); } void diff --git a/src/thread.h b/src/thread.h index 1e7eb86f6ee..82c445ba7e7 100644 --- a/src/thread.h +++ b/src/thread.h @@ -33,6 +33,17 @@ along with GNU Emacs. If not, see . */ #include "sysselect.h" /* FIXME */ #include "systhread.h" +INLINE_HEADER_BEGIN + +/* Byte-code interpreter thread state. */ +struct bc_thread_state { + struct bc_frame *fp; /* current frame pointer */ + + /* start and end of allocated bytecode stack */ + char *stack; + char *stack_end; +}; + struct thread_state { union vectorlike_header header; @@ -92,14 +103,14 @@ struct thread_state struct handler *m_handlerlist_sentinel; #define handlerlist_sentinel (current_thread->m_handlerlist_sentinel) - /* Current number of specbindings allocated in specpdl. */ - ptrdiff_t m_specpdl_size; -#define specpdl_size (current_thread->m_specpdl_size) - /* Pointer to beginning of specpdl. */ union specbinding *m_specpdl; #define specpdl (current_thread->m_specpdl) + /* End of specpld (just beyond the last element). */ + union specbinding *m_specpdl_end; +#define specpdl_end (current_thread->m_specpdl_end) + /* Pointer to first unused element in specpdl. */ union specbinding *m_specpdl_ptr; #define specpdl_ptr (current_thread->m_specpdl_ptr) @@ -181,6 +192,8 @@ struct thread_state /* Threads are kept on a linked list. */ struct thread_state *next_thread; + + struct bc_thread_state bc; } GCALIGNED_STRUCT; INLINE bool @@ -304,4 +317,6 @@ int thread_select (select_func *func, int max_fds, fd_set *rfds, bool thread_check_current_buffer (struct buffer *); +INLINE_HEADER_END + #endif /* THREAD_H */ diff --git a/src/timefns.c b/src/timefns.c index 9b5b090ba71..7d2e3f64143 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -69,10 +69,9 @@ enum { TM_YEAR_BASE = 1900 }; # define FASTER_TIMEFNS 1 #endif -/* Although current-time etc. generate list-format timestamps - (HI LO US PS), the plan is to change these functions to generate - frequency-based timestamps (TICKS . HZ) in a future release. - To try this now, compile with -DCURRENT_TIME_LIST=0. */ +/* current-time-list defaults to t, typically generating (HI LO US PS) + timestamps. To change the default to nil, generating (TICKS . HZ) + timestamps, compile with -DCURRENT_TIME_LIST=0. */ #ifndef CURRENT_TIME_LIST enum { CURRENT_TIME_LIST = true }; #endif @@ -342,7 +341,7 @@ init_timefns (void) } /* Report that a time value is out of range for Emacs. */ -void +static AVOID time_overflow (void) { error ("Specified time is not representable"); @@ -569,7 +568,7 @@ lisp_time_seconds (struct lisp_time t) Lisp_Object make_lisp_time (struct timespec t) { - if (CURRENT_TIME_LIST) + if (current_time_list) { time_t s = t.tv_sec; int ns = t.tv_nsec; @@ -1172,13 +1171,13 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) } /* Return an integer if the timestamp resolution is 1, - otherwise the (TICKS . HZ) form if !CURRENT_TIME_LIST or if + otherwise the (TICKS . HZ) form if !current_time_list or if either input used (TICKS . HZ) form or the result can't be expressed exactly in (HI LO US PS) form, otherwise the (HI LO US PS) form for backward compatibility. */ return (EQ (hz, make_fixnum (1)) ? ticks - : (!CURRENT_TIME_LIST + : (!current_time_list || aform == TIMEFORM_TICKS_HZ || bform == TIMEFORM_TICKS_HZ || !trillion_factor (hz)) @@ -1219,16 +1218,16 @@ time_cmp (Lisp_Object a, Lisp_Object b) return da < db ? -1 : da != db; } - struct lisp_time ta = lisp_time_struct (a, 0); - /* Compare nil to nil correctly, and handle other eq values quicker while we're at it. Compare here rather than earlier, to handle - NaNs and check formats. */ + NaNs. This means (time-equal-p X X) does not signal an error if + X is not a valid time value, but that's OK. */ if (EQ (a, b)) return 0; /* Compare (ATICKS . AZ) to (BTICKS . BHZ) by comparing ATICKS * BHZ to BTICKS * AHZ. */ + struct lisp_time ta = lisp_time_struct (a, 0); struct lisp_time tb = lisp_time_struct (b, 0); mpz_t const *za = bignum_integer (&mpz[0], ta.ticks); mpz_t const *zb = bignum_integer (&mpz[1], tb.ticks); @@ -1609,27 +1608,32 @@ check_tm_member (Lisp_Object obj, int offset) DEFUN ("encode-time", Fencode_time, Sencode_time, 1, MANY, 0, doc: /* Convert TIME to a timestamp. -TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE). +TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE) in the style of `decode-time', so that (encode-time (decode-time ...)) works. In this list, ZONE can be nil for Emacs local time, t for Universal Time, `wall' for system wall clock time, or a string as in the TZ -environment variable. It can also be a list (as from +environment variable. ZONE can also be a list (as from `current-time-zone') or an integer (as from `decode-time') applied without consideration for daylight saving time. If ZONE specifies a time zone with daylight-saving transitions, DST is t for daylight saving time, nil for standard time, and -1 to cause the daylight saving flag to be guessed. +TIME can also be a list (SECOND MINUTE HOUR DAY MONTH YEAR), which is +equivalent to (SECOND MINUTE HOUR DAY MONTH YEAR nil -1 nil). + As an obsolescent calling convention, if this function is called with 6 or more arguments, the first 6 arguments are SECOND, MINUTE, HOUR, DAY, MONTH, and YEAR, and specify the components of a decoded time. If there are more than 6 arguments the *last* argument is used as ZONE and any other extra arguments are ignored, so that (apply #\\='encode-time (decode-time ...)) works. In this obsolescent -convention, DST and ZONE default to -1 and nil respectively. +convention, DST is -1 and ZONE defaults to nil. -Years before 1970 are not guaranteed to work. On some systems, -year values as low as 1901 do work. +The range of supported years is at least 1970 to the near future. +Out-of-range values for SECOND through MONTH are brought into range +via date arithmetic. This can be tricky especially when combined with +DST; see Info node `(elisp)Time Conversion' for details and caveats. usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) @@ -1643,7 +1647,7 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) if (nargs == 1) { Lisp_Object tail = a; - for (int i = 0; i < 9; i++, tail = XCDR (tail)) + for (int i = 0; i < 6; i++, tail = XCDR (tail)) CHECK_CONS (tail); secarg = XCAR (a); a = XCDR (a); minarg = XCAR (a); a = XCDR (a); @@ -1651,11 +1655,17 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) mdayarg = XCAR (a); a = XCDR (a); monarg = XCAR (a); a = XCDR (a); yeararg = XCAR (a); a = XCDR (a); - a = XCDR (a); - Lisp_Object dstflag = XCAR (a); a = XCDR (a); - zone = XCAR (a); - if (SYMBOLP (dstflag) && !FIXNUMP (zone) && !CONSP (zone)) - tm.tm_isdst = !NILP (dstflag); + if (! NILP (a)) + { + CHECK_CONS (a); + a = XCDR (a); + CHECK_CONS (a); + Lisp_Object dstflag = XCAR (a); a = XCDR (a); + CHECK_CONS (a); + zone = XCAR (a); + if (SYMBOLP (dstflag) && !FIXNUMP (zone) && !CONSP (zone)) + tm.tm_isdst = !NILP (dstflag); + } } else if (nargs < 6) xsignal2 (Qwrong_number_of_arguments, Qencode_time, make_fixnum (nargs)); @@ -1706,7 +1716,7 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) time_error (mktime_errno); if (EQ (hz, make_fixnum (1))) - return (CURRENT_TIME_LIST + return (current_time_list ? list2 (hi_time (value), lo_time (value)) : INT_TO_INTEGER (value)); else @@ -1737,7 +1747,7 @@ bits, and USEC and PSEC are the microsecond and picosecond counts. */) struct lisp_time t; enum timeform input_form = decode_lisp_time (time, false, &t, 0); if (NILP (form)) - form = CURRENT_TIME_LIST ? Qlist : Qt; + form = current_time_list ? Qlist : Qt; if (EQ (form, Qlist)) return ticks_hz_list4 (t.ticks, t.hz); if (EQ (form, Qinteger)) @@ -1752,20 +1762,32 @@ bits, and USEC and PSEC are the microsecond and picosecond counts. */) DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0, doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00. -The time is returned as a list of integers (HIGH LOW USEC PSEC). -HIGH has the most significant bits of the seconds, while LOW has the -least significant 16 bits. USEC and PSEC are the microsecond and -picosecond counts. +If the variable `current-time-list' is nil, the time is returned as a +pair of integers (TICKS . HZ), where TICKS counts clock ticks and HZ +is the clock ticks per second. Otherwise, the time is returned as a +list of integers (HIGH LOW USEC PSEC) where HIGH has the most +significant bits of the seconds, LOW has the least significant 16 +bits, and USEC and PSEC are the microsecond and picosecond counts. -In a future Emacs version, the format of the returned timestamp is -planned to change. Use `time-convert' if you need a particular -timestamp form; for example, (time-convert nil \\='integer) returns -the current time in seconds. */) +You can use `time-convert' to get a particular timestamp form +regardless of the value of `current-time-list'. */) (void) { return make_lisp_time (current_timespec ()); } +#ifdef CLOCKS_PER_SEC +DEFUN ("current-cpu-time", Fcurrent_cpu_time, Scurrent_cpu_time, 0, 0, 0, + doc: /* Return the current CPU time along with its resolution. +The return value is a pair (CPU-TICKS . TICKS-PER-SEC). +The CPU-TICKS counter can wrap around, so values cannot be meaningfully +compared if too much time has passed between them. */) + (void) +{ + return Fcons (make_int (clock ()), make_int (CLOCKS_PER_SEC)); +} +#endif + DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, 0, 2, 0, doc: /* Return the current local time, as a human-readable string. @@ -2004,7 +2026,23 @@ syms_of_timefns (void) DEFSYM (Qencode_time, "encode-time"); + DEFVAR_BOOL ("current-time-list", current_time_list, + doc: /* Whether `current-time' should return list or (TICKS . HZ) form. + +This boolean variable is a transition aid. If t, `current-time' and +related functions return timestamps in list form, typically +\(HIGH LOW USEC PSEC); otherwise, they use (TICKS . HZ) form. +Currently this variable defaults to t, for behavior compatible with +previous Emacs versions. Developers are encouraged to test +timestamp-related code with this variable set to nil, as it will +default to nil in a future Emacs version, and will be removed in some +version after that. */); + current_time_list = CURRENT_TIME_LIST; + defsubr (&Scurrent_time); +#ifdef CLOCKS_PER_SEC + defsubr (&Scurrent_cpu_time); +#endif defsubr (&Stime_convert); defsubr (&Stime_add); defsubr (&Stime_subtract); diff --git a/src/w32.c b/src/w32.c index 0dc874eac40..1b10b9965fb 100644 --- a/src/w32.c +++ b/src/w32.c @@ -71,6 +71,8 @@ along with GNU Emacs. If not, see . */ #undef localtime +#undef clock + char *sys_ctime (const time_t *); int sys_chdir (const char *); int sys_creat (const char *, int); @@ -87,6 +89,7 @@ struct tm *sys_localtime (const time_t *); compiler to emit a warning about sys_strerror having no prototype. */ char *sys_strerror (int); +clock_t sys_clock (void); #ifdef HAVE_MODULES extern void dynlib_reset_last_error (void); @@ -348,6 +351,7 @@ static BOOL g_b_init_reg_open_key_ex_w; static BOOL g_b_init_reg_query_value_ex_w; static BOOL g_b_init_expand_environment_strings_w; static BOOL g_b_init_get_user_default_ui_language; +static BOOL g_b_init_get_console_font_size; BOOL g_b_init_compare_string_w; BOOL g_b_init_debug_break_process; @@ -537,6 +541,22 @@ typedef LONG (WINAPI *RegQueryValueExW_Proc) (HKEY,LPCWSTR,LPDWORD,LPDWORD,LPBYT typedef DWORD (WINAPI *ExpandEnvironmentStringsW_Proc) (LPCWSTR,LPWSTR,DWORD); typedef LANGID (WINAPI *GetUserDefaultUILanguage_Proc) (void); +typedef COORD (WINAPI *GetConsoleFontSize_Proc) (HANDLE, DWORD); + +#if _WIN32_WINNT < 0x0501 +typedef struct +{ + DWORD nFont; + COORD dwFontSize; +} CONSOLE_FONT_INFO; +#endif + +typedef BOOL (WINAPI *GetCurrentConsoleFont_Proc) ( + HANDLE, + BOOL, + CONSOLE_FONT_INFO *); + + /* ** A utility function ** */ static BOOL is_windows_9x (void) @@ -4640,6 +4660,9 @@ sys_open (const char * path, int oflag, int mode) return res; } +/* This is not currently used, but might be needed again at some + point; DO NOT DELETE! */ +#if 0 int openat (int fd, const char * path, int oflag, int mode) { @@ -4660,6 +4683,7 @@ openat (int fd, const char * path, int oflag, int mode) return sys_open (path, oflag, mode); } +#endif int fchmod (int fd, mode_t mode) @@ -10134,6 +10158,32 @@ sys_localtime (const time_t *t) return localtime (t); } +/* The Windows CRT implementation of 'clock' doesn't really return CPU + time of the process (it returns the elapsed time since the process + started), so we provide a better emulation here, if possible. */ +clock_t +sys_clock (void) +{ + if (get_process_times_fn) + { + FILETIME create, exit, kernel, user; + HANDLE proc = GetCurrentProcess (); + if ((*get_process_times_fn) (proc, &create, &exit, &kernel, &user)) + { + LARGE_INTEGER user_int, kernel_int, total; + user_int.LowPart = user.dwLowDateTime; + user_int.HighPart = user.dwHighDateTime; + kernel_int.LowPart = kernel.dwLowDateTime; + kernel_int.HighPart = kernel.dwHighDateTime; + total.QuadPart = user_int.QuadPart + kernel_int.QuadPart; + /* We could redefine CLOCKS_PER_SEC to provide a finer + resolution, but with the basic 15.625 msec resolution of + the Windows clock, it doesn't really sound worth the hassle. */ + return total.QuadPart / (10000000 / CLOCKS_PER_SEC); + } + } + return clock (); +} /* Try loading LIBRARY_ID from the file(s) specified in @@ -10614,6 +10664,120 @@ realpath (const char *file_name, char *resolved_name) return xstrdup (tgt); } +static void +get_console_font_size (HANDLE hscreen, int *font_width, int *font_height) +{ + static GetCurrentConsoleFont_Proc s_pfn_Get_Current_Console_Font = NULL; + static GetConsoleFontSize_Proc s_pfn_Get_Console_Font_Size = NULL; + + /* Default guessed values, for when we cannot obtain the actual ones. */ + *font_width = 8; + *font_height = 12; + + if (!is_windows_9x ()) + { + if (g_b_init_get_console_font_size == 0) + { + HMODULE hm_kernel32 = LoadLibrary ("Kernel32.dll"); + if (hm_kernel32) + { + s_pfn_Get_Current_Console_Font = (GetCurrentConsoleFont_Proc) + get_proc_addr (hm_kernel32, "GetCurrentConsoleFont"); + s_pfn_Get_Console_Font_Size = (GetConsoleFontSize_Proc) + get_proc_addr (hm_kernel32, "GetConsoleFontSize"); + } + g_b_init_get_console_font_size = 1; + } + } + if (s_pfn_Get_Current_Console_Font && s_pfn_Get_Console_Font_Size) + { + CONSOLE_FONT_INFO font_info; + + if (s_pfn_Get_Current_Console_Font (hscreen, FALSE, &font_info)) + { + COORD font_size = s_pfn_Get_Console_Font_Size (hscreen, + font_info.nFont); + if (font_size.X > 0) + *font_width = font_size.X; + if (font_size.Y > 0) + *font_height = font_size.Y; + } + } +} + +/* A replacement for Posix execvp, used to restart Emacs. This is + needed because the low-level Windows API to start processes accepts + the command-line arguments as a single string, so we cannot safely + use the MSVCRT execvp emulation, because elements of argv[] that + have embedded blanks and tabs will not be passed correctly to the + restarted Emacs. */ +int +w32_reexec_emacs (char *cmd_line, const char *wdir) +{ + STARTUPINFO si; + BOOL status; + PROCESS_INFORMATION proc_info; + DWORD dwCreationFlags = NORMAL_PRIORITY_CLASS; + + GetStartupInfo (&si); /* Use the same startup info as the caller. */ + if (inhibit_window_system) + { + HANDLE screen_handle; + CONSOLE_SCREEN_BUFFER_INFO screen_info; + + screen_handle = GetStdHandle (STD_OUTPUT_HANDLE); + if (screen_handle != INVALID_HANDLE_VALUE + && GetConsoleScreenBufferInfo (screen_handle, &screen_info)) + { + int font_width, font_height; + + /* Make the restarted Emacs's console window the same + dimensions as ours. */ + si.dwXCountChars = screen_info.dwSize.X; + si.dwYCountChars = screen_info.dwSize.Y; + get_console_font_size (screen_handle, &font_width, &font_height); + si.dwXSize = + (screen_info.srWindow.Right - screen_info.srWindow.Left + 1) + * font_width; + si.dwYSize = + (screen_info.srWindow.Bottom - screen_info.srWindow.Top + 1) + * font_height; + si.dwFlags |= STARTF_USESIZE | STARTF_USECOUNTCHARS; + } + /* This is a kludge: it causes the restarted "emacs -nw" to have + a new console window created for it, and that new window + might have different (default) properties, not the ones of + the parent process's console window. But without this, + restarting Emacs in the -nw mode simply doesn't work, + probably because the parent's console is still in use. + FIXME! */ + dwCreationFlags = CREATE_NEW_CONSOLE; + } + + /* Make sure we are in the original directory, in case the command + line specifies the program as a relative file name. */ + chdir (wdir); + + status = CreateProcess (NULL, /* no program, take from command line */ + cmd_line, /* command line */ + NULL, + NULL, /* thread attributes */ + FALSE, /* unherit handles? */ + dwCreationFlags, + NULL, /* environment */ + wdir, /* initial directory */ + &si, /* startup info */ + &proc_info); + if (status) + { + CloseHandle (proc_info.hThread); + CloseHandle (proc_info.hProcess); + exit (0); + } + errno = ENOEXEC; + return -1; +} + /* globals_of_w32 is used to initialize those global variables that must always be initialized on startup even when the global variable @@ -10674,6 +10838,7 @@ globals_of_w32 (void) g_b_init_compare_string_w = 0; g_b_init_debug_break_process = 0; g_b_init_get_user_default_ui_language = 0; + g_b_init_get_console_font_size = 0; num_of_processors = 0; /* The following sets a handler for shutdown notifications for console apps. This actually applies to Emacs in both console and diff --git a/src/w32.h b/src/w32.h index 4941170bdcf..dc91c595c43 100644 --- a/src/w32.h +++ b/src/w32.h @@ -244,6 +244,9 @@ extern int w32_init_random (void *, ptrdiff_t); extern Lisp_Object w32_read_registry (HKEY, Lisp_Object, Lisp_Object); +/* Used instead of execvp to restart Emacs. */ +extern int w32_reexec_emacs (char *, const char *); + #ifdef HAVE_GNUTLS #include diff --git a/src/w32console.c b/src/w32console.c index 12e1f397894..09749126e03 100644 --- a/src/w32console.c +++ b/src/w32console.c @@ -716,10 +716,10 @@ initialize_w32_display (struct terminal *term, int *width, int *height) if (cur_screen == INVALID_HANDLE_VALUE) { - printf ("CreateConsoleScreenBuffer failed in ResetTerm\n"); + printf ("CreateConsoleScreenBuffer failed in initialize_w32_display\n"); printf ("LastError = 0x%lx\n", GetLastError ()); fflush (stdout); - exit (0); + exit (1); } #else cur_screen = prev_screen; @@ -760,7 +760,13 @@ initialize_w32_display (struct terminal *term, int *width, int *height) } } - GetConsoleScreenBufferInfo (cur_screen, &info); + if (!GetConsoleScreenBufferInfo (cur_screen, &info)) + { + printf ("GetConsoleScreenBufferInfo failed in initialize_w32_display\n"); + printf ("LastError = 0x%lx\n", GetLastError ()); + fflush (stdout); + exit (1); + } char_attr_normal = info.wAttributes; diff --git a/src/w32fns.c b/src/w32fns.c index a880136d0ac..0f25c1a594a 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -1802,6 +1802,32 @@ w32_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) w32_change_tool_bar_height (f, nlines * FRAME_LINE_HEIGHT (f)); } +/* Enable or disable double buffering on frame F. + + When double buffering is enabled, all drawing happens on a back + buffer (a bitmap), which is then displayed as a single operation + after redisplay is complete. This avoids flicker caused by the + results of an incomplete redisplay becoming visible. */ +static void +w32_set_inhibit_double_buffering (struct frame *f, + Lisp_Object new_value, + /* This parameter is unused. */ + Lisp_Object old_value) +{ + block_input (); + + if (NILP (new_value)) + FRAME_OUTPUT_DATA (f)->want_paint_buffer = 1; + else + { + FRAME_OUTPUT_DATA (f)->want_paint_buffer = 0; + w32_release_paint_buffer (f); + + SET_FRAME_GARBAGED (f); + } + + unblock_input (); +} /* Set the pixel height of the tool bar of frame F to HEIGHT. */ void @@ -4093,7 +4119,10 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) { case WM_ERASEBKGND: f = w32_window_to_frame (dpyinfo, hwnd); - if (f) + + enter_crit (); + if (f && (w32_disable_double_buffering + || !FRAME_OUTPUT_DATA (f)->paint_buffer)) { HDC hdc = get_frame_dc (f); GetUpdateRect (hwnd, &wmsg.rect, FALSE); @@ -4107,6 +4136,7 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) wmsg.rect.right, wmsg.rect.bottom)); #endif /* W32_DEBUG_DISPLAY */ } + leave_crit (); return 1; case WM_PALETTECHANGED: /* ignore our own changes */ @@ -6080,6 +6110,10 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, ? make_fixnum (0) : make_fixnum (1), NULL, NULL, RES_TYPE_NUMBER); + gui_default_parameter (f, parameters, Qinhibit_double_buffering, Qnil, + "inhibitDoubleBuffering", "InhibitDoubleBuffering", + RES_TYPE_BOOLEAN); + gui_default_parameter (f, parameters, Qbuffer_predicate, Qnil, "bufferPredicate", "BufferPredicate", RES_TYPE_SYMBOL); gui_default_parameter (f, parameters, Qtitle, Qnil, @@ -7096,6 +7130,9 @@ w32_create_tip_frame (struct w32_display_info *dpyinfo, Lisp_Object parms) "alpha", "Alpha", RES_TYPE_NUMBER); gui_default_parameter (f, parms, Qalpha_background, Qnil, "alphaBackground", "AlphaBackground", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qinhibit_double_buffering, Qnil, + "inhibitDoubleBuffering", "InhibitDoubleBuffering", + RES_TYPE_BOOLEAN); /* Add `tooltip' frame parameter's default value. */ if (NILP (Fframe_parameter (frame, Qtooltip))) @@ -7329,9 +7366,8 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, decode_window_system_frame (frame); if (NILP (timeout)) - timeout = make_fixnum (5); - else - CHECK_FIXNAT (timeout); + timeout = Vx_show_tooltip_timeout; + CHECK_FIXNAT (timeout); if (NILP (dx)) dx = make_fixnum (5); @@ -10432,7 +10468,7 @@ frame_parm_handler w32_frame_parm_handlers[] = gui_set_alpha, 0, /* x_set_sticky */ 0, /* x_set_tool_bar_position */ - 0, /* x_set_inhibit_double_buffering */ + w32_set_inhibit_double_buffering, w32_set_undecorated, w32_set_parent_frame, w32_set_skip_taskbar, @@ -11207,6 +11243,12 @@ see `w32-ansi-code-page'. */); w32_multibyte_code_page = _getmbcp (); #endif + DEFVAR_BOOL ("w32-disable-double-buffering", w32_disable_double_buffering, + doc: /* Completely disable double buffering. +This variable is used for debugging, and takes precedence over any +value of the `inhibit-double-buffering' frame parameter. */); + w32_disable_double_buffering = false; + if (os_subtype == OS_SUBTYPE_NT) w32_unicode_gui = 1; else diff --git a/src/w32image.c b/src/w32image.c index f3374dcfd30..1f7c4921b31 100644 --- a/src/w32image.c +++ b/src/w32image.c @@ -253,6 +253,7 @@ w32_can_use_native_image_api (Lisp_Object type) || EQ (type, Qpng) || EQ (type, Qgif) || EQ (type, Qtiff) + || EQ (type, Qbmp) || EQ (type, Qnative_image))) { /* GDI+ can also display BMP, Exif, ICON, WMF, and EMF images. diff --git a/src/w32notify.c b/src/w32notify.c index e7d2f0f076b..ccefecb6596 100644 --- a/src/w32notify.c +++ b/src/w32notify.c @@ -40,8 +40,8 @@ along with GNU Emacs. If not, see . */ and returns. That causes the WaitForSingleObjectEx function call inside watch_worker to return, but the thread won't terminate until the event telling to do so will be signaled. The completion - routine issued another call to ReadDirectoryChangesW as quickly as - possible. (Except when it does not, see below.) + routine then issues another call to ReadDirectoryChangesW as quickly + as possible. (Except when it does not, see below.) In a GUI session, the WM_EMACS_FILENOTIFY message posted to the message queue gets dispatched to the main Emacs window procedure, diff --git a/src/w32term.c b/src/w32term.c index 9094843f60f..19786da3a6d 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -275,6 +275,62 @@ XGetGCValues (void *ignore, XGCValues *gc, } #endif +static void +w32_show_back_buffer (struct frame *f) +{ + struct w32_output *output; + HDC raw_dc; + + output = FRAME_OUTPUT_DATA (f); + + if (!output->want_paint_buffer || w32_disable_double_buffering) + return; + + enter_crit (); + + if (output->paint_buffer) + { + raw_dc = GetDC (output->window_desc); + + if (!raw_dc) + emacs_abort (); + + BitBlt (raw_dc, 0, 0, FRAME_PIXEL_WIDTH (f), + FRAME_PIXEL_HEIGHT (f), + output->paint_dc, 0, 0, SRCCOPY); + ReleaseDC (output->window_desc, raw_dc); + + output->paint_buffer_dirty = 0; + } + + leave_crit (); +} + +void +w32_release_paint_buffer (struct frame *f) +{ + /* Delete the back buffer so it gets created + again the next time we ask for the DC. */ + + enter_crit (); + if (FRAME_OUTPUT_DATA (f)->paint_buffer) + { + deselect_palette (f, FRAME_OUTPUT_DATA (f)->paint_buffer_handle); + + SelectObject (FRAME_OUTPUT_DATA (f)->paint_dc, + FRAME_OUTPUT_DATA (f)->paint_dc_object); + ReleaseDC (FRAME_OUTPUT_DATA (f)->window_desc, + FRAME_OUTPUT_DATA (f)->paint_buffer_handle); + DeleteDC (FRAME_OUTPUT_DATA (f)->paint_dc); + DeleteObject (FRAME_OUTPUT_DATA (f)->paint_buffer); + + FRAME_OUTPUT_DATA (f)->paint_buffer = NULL; + FRAME_OUTPUT_DATA (f)->paint_dc = NULL; + FRAME_OUTPUT_DATA (f)->paint_buffer_handle = NULL; + } + leave_crit (); +} + static void w32_get_mouse_wheel_vertical_delta (void) { @@ -704,10 +760,32 @@ w32_update_end (struct frame *f) static void w32_frame_up_to_date (struct frame *f) { - if (FRAME_W32_P (f)) - FRAME_MOUSE_UPDATE (f); + FRAME_MOUSE_UPDATE (f); + + if (!buffer_flipping_blocked_p () + && FRAME_OUTPUT_DATA (f)->paint_buffer_dirty) + w32_show_back_buffer (f); } +static void +w32_buffer_flipping_unblocked_hook (struct frame *f) +{ + if (FRAME_OUTPUT_DATA (f)->paint_buffer_dirty) + w32_show_back_buffer (f); +} + +/* Flip buffers on F if drawing has happened. This function is not + called to flush the display connection of a frame (which doesn't + exist on MS Windows), but also called in some situations in + minibuf.c to make the contents of the back buffer visible. */ +void +w32_flip_buffers_if_dirty (struct frame *f) +{ + if (FRAME_OUTPUT_DATA (f)->paint_buffer + && FRAME_OUTPUT_DATA (f)->paint_buffer_dirty + && !f->garbaged && !buffer_flipping_blocked_p ()) + w32_show_back_buffer (f); +} /* Draw truncation mark bitmaps, continuation mark bitmaps, overlay arrow bitmaps, or clear the fringes if no bitmaps are required @@ -2872,8 +2950,9 @@ w32_scroll_run (struct window *w, struct run *run) { struct frame *f = XFRAME (w->frame); int x, y, width, height, from_y, to_y, bottom_y; + HDC hdc; HWND hwnd = FRAME_W32_WINDOW (f); - HRGN expect_dirty; + HRGN expect_dirty = NULL; /* Get frame-relative bounding box of the text display area of W, without mode lines. Include in this box the left and right @@ -2892,7 +2971,9 @@ w32_scroll_run (struct window *w, struct run *run) height = bottom_y - from_y; else height = run->height; - expect_dirty = CreateRectRgn (x, y + height, x + width, bottom_y); + + if (w32_disable_double_buffering) + expect_dirty = CreateRectRgn (x, y + height, x + width, bottom_y); } else { @@ -2902,44 +2983,55 @@ w32_scroll_run (struct window *w, struct run *run) height = bottom_y - to_y; else height = run->height; - expect_dirty = CreateRectRgn (x, y, x + width, to_y); + + if (w32_disable_double_buffering) + expect_dirty = CreateRectRgn (x, y, x + width, to_y); } block_input (); /* Cursor off. Will be switched on again in gui_update_window_end. */ gui_clear_cursor (w); + if (!w32_disable_double_buffering) + { + hdc = get_frame_dc (f); + BitBlt (hdc, x, to_y, width, height, hdc, x, from_y, SRCCOPY); + release_frame_dc (f, hdc); + } + else + { + RECT from; + RECT to; + HRGN dirty = CreateRectRgn (0, 0, 0, 0); + HRGN combined = CreateRectRgn (0, 0, 0, 0); - { - RECT from; - RECT to; - HRGN dirty = CreateRectRgn (0, 0, 0, 0); - HRGN combined = CreateRectRgn (0, 0, 0, 0); + from.left = to.left = x; + from.right = to.right = x + width; + from.top = from_y; + from.bottom = from_y + height; + to.top = y; + to.bottom = bottom_y; - from.left = to.left = x; - from.right = to.right = x + width; - from.top = from_y; - from.bottom = from_y + height; - to.top = y; - to.bottom = bottom_y; + ScrollWindowEx (hwnd, 0, to_y - from_y, &from, &to, dirty, + NULL, SW_INVALIDATE); - ScrollWindowEx (hwnd, 0, to_y - from_y, &from, &to, dirty, - NULL, SW_INVALIDATE); + /* Combine this with what we expect to be dirty. This covers the + case where not all of the region we expect is actually dirty. */ + CombineRgn (combined, dirty, expect_dirty, RGN_OR); - /* Combine this with what we expect to be dirty. This covers the - case where not all of the region we expect is actually dirty. */ - CombineRgn (combined, dirty, expect_dirty, RGN_OR); + /* If the dirty region is not what we expected, redraw the entire frame. */ + if (!EqualRgn (combined, expect_dirty)) + SET_FRAME_GARBAGED (f); - /* If the dirty region is not what we expected, redraw the entire frame. */ - if (!EqualRgn (combined, expect_dirty)) - SET_FRAME_GARBAGED (f); - - DeleteObject (dirty); - DeleteObject (combined); - } + DeleteObject (dirty); + DeleteObject (combined); + } unblock_input (); - DeleteObject (expect_dirty); + + if (w32_disable_double_buffering + && expect_dirty) + DeleteObject (expect_dirty); } @@ -4809,6 +4901,14 @@ w32_scroll_bar_clear (struct frame *f) { Lisp_Object bar; + /* Return if double buffering is enabled, since clearing a frame + actually clears just the back buffer, so avoid clearing all of + the scroll bars, since that causes the scroll bars to + flicker. */ + if (!w32_disable_double_buffering + && FRAME_OUTPUT_DATA (f)->want_paint_buffer) + return; + /* We can have scroll bars even if this is 0, if we just turned off scroll bar mode. But in that case we should not clear them. */ @@ -4924,10 +5024,17 @@ w32_read_socket (struct terminal *terminal, struct input_event inev; int do_help = 0; + /* WM_WINDOWPOSCHANGED makes the buffer dirty, but there's no + reason to flush the back buffer after receiving such an + event, and that also causes flicker. */ + bool ignore_dirty_back_buffer = false; + /* DebPrint (("w32_read_socket: %s time:%u\n", */ /* w32_name_of_message (msg.msg.message), */ /* msg.msg.time)); */ + f = NULL; + EVENT_INIT (inev); inev.kind = NO_EVENT; inev.arg = Qnil; @@ -4969,24 +5076,32 @@ w32_read_socket (struct terminal *terminal, } else { - /* Erase background again for safety. But don't do - that if the frame's 'garbaged' flag is set, since - in that case expose_frame will do nothing, and if - the various redisplay flags happen to be unset, - we are left with a blank frame. */ - if (!FRAME_GARBAGED_P (f) || FRAME_PARENT_FRAME (f)) + if (w32_disable_double_buffering + || !FRAME_OUTPUT_DATA (f)->paint_buffer) { - HDC hdc = get_frame_dc (f); + /* Erase background again for safety. But don't do + that if the frame's 'garbaged' flag is set, since + in that case expose_frame will do nothing, and if + the various redisplay flags happen to be unset, + we are left with a blank frame. */ - w32_clear_rect (f, hdc, &msg.rect); - release_frame_dc (f, hdc); + if (!FRAME_GARBAGED_P (f) || FRAME_PARENT_FRAME (f)) + { + HDC hdc = get_frame_dc (f); + + w32_clear_rect (f, hdc, &msg.rect); + release_frame_dc (f, hdc); + } + + expose_frame (f, + msg.rect.left, + msg.rect.top, + msg.rect.right - msg.rect.left, + msg.rect.bottom - msg.rect.top); + w32_clear_under_internal_border (f); } - expose_frame (f, - msg.rect.left, - msg.rect.top, - msg.rect.right - msg.rect.left, - msg.rect.bottom - msg.rect.top); - w32_clear_under_internal_border (f); + else + w32_show_back_buffer (f); } } break; @@ -5320,7 +5435,18 @@ w32_read_socket (struct terminal *terminal, window = window_from_coordinates (f, x, y, 0, 1, 1); - if (EQ (window, f->tool_bar_window)) + if (EQ (window, f->tool_bar_window) + /* Make sure the tool bar was previously + pressed, otherwise an event that started + outside of the tool bar will not be handled + correctly when the mouse button is + released. For example, start dragging to + select some buffer text, drag the mouse to + the tool bar, and release the mouse button + -- this should not consider the release + event as a tool-bar click. */ + && (inev.modifiers & down_modifier + || f->last_tool_bar_item != -1)) { w32_handle_tool_bar_click (f, &inev); tool_bar_p = 1; @@ -5437,6 +5563,7 @@ w32_read_socket (struct terminal *terminal, case WM_WINDOWPOSCHANGED: f = w32_window_to_frame (dpyinfo, msg.msg.hwnd); + ignore_dirty_back_buffer = true; if (f) { @@ -5659,6 +5786,8 @@ w32_read_socket (struct terminal *terminal, if (width != FRAME_PIXEL_WIDTH (f) || height != FRAME_PIXEL_HEIGHT (f)) { + w32_release_paint_buffer (f); + change_frame_size (f, width, height, false, true, false); SET_FRAME_GARBAGED (f); @@ -5840,6 +5969,15 @@ w32_read_socket (struct terminal *terminal, } count++; } + + /* Event processing might have drawn to F outside redisplay. If + that is the case, flush any changes that have been made to + the front buffer. */ + + if (f && !w32_disable_double_buffering + && FRAME_OUTPUT_DATA (f)->paint_buffer_dirty + && !f->garbaged && !ignore_dirty_back_buffer) + w32_show_back_buffer (f); } /* If the focus was just given to an autoraising frame, @@ -7054,6 +7192,9 @@ w32_free_frame_resources (struct frame *f) face. */ free_frame_faces (f); + /* Now release the back buffer if any exists. */ + w32_release_paint_buffer (f); + if (FRAME_W32_WINDOW (f)) my_destroy_window (f, FRAME_W32_WINDOW (f)); @@ -7350,6 +7491,7 @@ w32_create_terminal (struct w32_display_info *dpyinfo) terminal->update_end_hook = w32_update_end; terminal->read_socket_hook = w32_read_socket; terminal->frame_up_to_date_hook = w32_frame_up_to_date; + terminal->buffer_flipping_unblocked_hook = w32_buffer_flipping_unblocked_hook; terminal->defined_color_hook = w32_defined_color; terminal->query_frame_background_color = w32_query_frame_background_color; terminal->query_colors = w32_query_colors; @@ -7505,6 +7647,7 @@ w32_delete_display (struct w32_display_info *dpyinfo) if (dpyinfo->palette) DeleteObject (dpyinfo->palette); } + w32_reset_fringes (); } @@ -7744,9 +7887,10 @@ The native image API library used is GDI+ via GDIPLUS.DLL. This library is available only since W2K, therefore this variable is unconditionally set to nil on older systems. */); - /* For now, disabled by default, since this is an experimental feature. */ -#if 0 && HAVE_NATIVE_IMAGE_API - if (os_subtype == OS_9X) + /* Disabled for Cygwin/w32 builds, since they don't link against + -lgdiplus, see configure.ac. */ +#if defined WINDOWSNT && HAVE_NATIVE_IMAGE_API + if (os_subtype == OS_SUBTYPE_9X) w32_use_native_image_api = 0; else w32_use_native_image_api = 1; diff --git a/src/w32term.h b/src/w32term.h index 6c48323651f..88b7ec22bd1 100644 --- a/src/w32term.h +++ b/src/w32term.h @@ -412,6 +412,27 @@ struct w32_output geometry when 'fullscreen' is reset to nil. */ WINDOWPLACEMENT normal_placement; int prev_fsmode; + + /* The back buffer if there is an ongoing double-buffered drawing + operation. */ + HBITMAP paint_buffer; + + /* The handle of the back buffer and a DC that ought to be released + alongside the back buffer. */ + HDC paint_dc, paint_buffer_handle; + + /* The object previously selected into `paint_dc'. */ + HGDIOBJ paint_dc_object; + + /* The width and height of `paint_buffer'. */ + int paint_buffer_width, paint_buffer_height; + + /* Whether or not some painting was done to this window that has not + yet been drawn. */ + unsigned paint_buffer_dirty : 1; + + /* Whether or not this frame should be double buffered. */ + unsigned want_paint_buffer : 1; }; extern struct w32_output w32term_display; @@ -876,6 +897,8 @@ typedef char guichar_t; extern Lisp_Object w32_popup_dialog (struct frame *, Lisp_Object, Lisp_Object); extern void w32_arrow_cursor (void); +extern void w32_release_paint_buffer (struct frame *); +extern void w32_flip_buffers_if_dirty (struct frame *); extern void syms_of_w32term (void); extern void syms_of_w32menu (void); diff --git a/src/w32xfns.c b/src/w32xfns.c index d5974b906e8..22d39ae0037 100644 --- a/src/w32xfns.c +++ b/src/w32xfns.c @@ -136,13 +136,13 @@ select_palette (struct frame *f, HDC hdc) f->output_data.w32->old_palette = NULL; if (RealizePalette (hdc) != GDI_ERROR) - { - Lisp_Object frame, framelist; - FOR_EACH_FRAME (framelist, frame) { - SET_FRAME_GARBAGED (XFRAME (frame)); + Lisp_Object frame, framelist; + FOR_EACH_FRAME (framelist, frame) + { + SET_FRAME_GARBAGED (XFRAME (frame)); + } } - } } void @@ -157,19 +157,70 @@ deselect_palette (struct frame *f, HDC hdc) HDC get_frame_dc (struct frame *f) { - HDC hdc; + HDC hdc, paint_dc; + HBITMAP back_buffer; + HGDIOBJ obj; + struct w32_output *output; if (f->output_method != output_w32) emacs_abort (); enter_crit (); + output = FRAME_OUTPUT_DATA (f); - hdc = GetDC (f->output_data.w32->window_desc); + if (output->paint_dc) + { + if (output->paint_buffer_width != FRAME_PIXEL_WIDTH (f) + || output->paint_buffer_height != FRAME_PIXEL_HEIGHT (f) + || w32_disable_double_buffering) + w32_release_paint_buffer (f); + else + { + output->paint_buffer_dirty = 1; + return output->paint_dc; + } + } + + hdc = GetDC (output->window_desc); /* If this gets called during startup before the frame is valid, there is a chance of corrupting random data or crashing. */ if (hdc) - select_palette (f, hdc); + { + select_palette (f, hdc); + + if (!w32_disable_double_buffering + && FRAME_OUTPUT_DATA (f)->want_paint_buffer) + { + back_buffer + = CreateCompatibleBitmap (hdc, FRAME_PIXEL_WIDTH (f), + FRAME_PIXEL_HEIGHT (f)); + + if (back_buffer) + { + paint_dc = CreateCompatibleDC (hdc); + + if (!paint_dc) + DeleteObject (back_buffer); + else + { + obj = SelectObject (paint_dc, back_buffer); + + output->paint_dc_object = obj; + output->paint_dc = paint_dc; + output->paint_buffer_handle = hdc; + output->paint_buffer = back_buffer; + output->paint_buffer_width = FRAME_PIXEL_WIDTH (f); + output->paint_buffer_height = FRAME_PIXEL_HEIGHT (f); + output->paint_buffer_dirty = 1; + + SET_FRAME_GARBAGED (f); + + return paint_dc; + } + } + } + } return hdc; } @@ -179,8 +230,15 @@ release_frame_dc (struct frame *f, HDC hdc) { int ret; - deselect_palette (f, hdc); - ret = ReleaseDC (f->output_data.w32->window_desc, hdc); + /* Avoid releasing the double-buffered DC here, since it'll be + released upon the next buffer flip instead. */ + if (hdc != FRAME_OUTPUT_DATA (f)->paint_dc) + { + deselect_palette (f, hdc); + ret = ReleaseDC (f->output_data.w32->window_desc, hdc); + } + else + ret = 0; leave_crit (); diff --git a/src/widget.c b/src/widget.c index 4231aa71b53..b125b4caeed 100644 --- a/src/widget.c +++ b/src/widget.c @@ -42,11 +42,13 @@ along with GNU Emacs. If not, see . */ #include #include "../lwlib/lwlib.h" -static void EmacsFrameInitialize (Widget request, Widget new, ArgList dum1, Cardinal *dum2); -static void EmacsFrameDestroy (Widget widget); -static void EmacsFrameRealize (Widget widget, XtValueMask *mask, XSetWindowAttributes *attrs); -static void EmacsFrameResize (Widget widget); -static XtGeometryResult EmacsFrameQueryGeometry (Widget widget, XtWidgetGeometry *request, XtWidgetGeometry *result); +static void EmacsFrameInitialize (Widget, Widget, ArgList, Cardinal *); +static void EmacsFrameDestroy (Widget); +static void EmacsFrameRealize (Widget, XtValueMask *, XSetWindowAttributes *); +static void EmacsFrameResize (Widget); +static void EmacsFrameExpose (Widget, XEvent *, Region); +static XtGeometryResult EmacsFrameQueryGeometry (Widget, XtWidgetGeometry *, + XtWidgetGeometry *); #define offset(field) offsetof (EmacsFrameRec, emacs_frame.field) @@ -118,12 +120,12 @@ static EmacsFrameClassRec emacsFrameClassRec = { /* resource_count */ XtNumber (resources), /* xrm_class */ NULLQUARK, /* compress_motion */ TRUE, - /* compress_exposure */ TRUE, + /* compress_exposure */ XtExposeNoCompress, /* compress_enterleave */ TRUE, /* visible_interest */ FALSE, /* destroy */ EmacsFrameDestroy, /* resize */ EmacsFrameResize, - /* expose */ XtInheritExpose, + /* expose */ EmacsFrameExpose, /* Emacs never does XtSetvalues on this widget, so we have no code for it. */ @@ -156,33 +158,41 @@ static void get_default_char_pixel_size (EmacsFrame ew, int *pixel_width, int *pixel_height) { struct frame *f = ew->emacs_frame.frame; + *pixel_width = FRAME_COLUMN_WIDTH (f); *pixel_height = FRAME_LINE_HEIGHT (f); } static void -pixel_to_char_size (EmacsFrame ew, Dimension pixel_width, Dimension pixel_height, int *char_width, int *char_height) +pixel_to_char_size (EmacsFrame ew, Dimension pixel_width, + Dimension pixel_height, int *char_width, int *char_height) { struct frame *f = ew->emacs_frame.frame; + *char_width = FRAME_PIXEL_WIDTH_TO_TEXT_COLS (f, (int) pixel_width); *char_height = FRAME_PIXEL_HEIGHT_TO_TEXT_LINES (f, (int) pixel_height); } static void -char_to_pixel_size (EmacsFrame ew, int char_width, int char_height, Dimension *pixel_width, Dimension *pixel_height) +char_to_pixel_size (EmacsFrame ew, int char_width, int char_height, + Dimension *pixel_width, Dimension *pixel_height) { struct frame *f = ew->emacs_frame.frame; + *pixel_width = FRAME_TEXT_COLS_TO_PIXEL_WIDTH (f, char_width); *pixel_height = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, char_height); } static void -round_size_to_char (EmacsFrame ew, Dimension in_width, Dimension in_height, Dimension *out_width, Dimension *out_height) +round_size_to_char (EmacsFrame ew, Dimension in_width, Dimension in_height, + Dimension *out_width, Dimension *out_height) { int char_width; int char_height; - pixel_to_char_size (ew, in_width, in_height, &char_width, &char_height); - char_to_pixel_size (ew, char_width, char_height, out_width, out_height); + pixel_to_char_size (ew, in_width, in_height, + &char_width, &char_height); + char_to_pixel_size (ew, char_width, char_height, + out_width, out_height); } static Widget @@ -334,7 +344,8 @@ update_from_various_frame_slots (EmacsFrame ew) } static void -EmacsFrameInitialize (Widget request, Widget new, ArgList dum1, Cardinal *dum2) +EmacsFrameInitialize (Widget request, Widget new, + ArgList dum1, Cardinal *dum2) { EmacsFrame ew = (EmacsFrame) new; @@ -359,7 +370,8 @@ resize_cb (Widget widget, static void -EmacsFrameRealize (Widget widget, XtValueMask *mask, XSetWindowAttributes *attrs) +EmacsFrameRealize (Widget widget, XtValueMask *mask, + XSetWindowAttributes *attrs) { EmacsFrame ew = (EmacsFrame) widget; struct frame *f = ew->emacs_frame.frame; @@ -404,7 +416,8 @@ EmacsFrameResize (Widget widget) ew->core.width, ew->core.height, f->new_width, f->new_height); - change_frame_size (f, ew->core.width, ew->core.height, false, true, false); + change_frame_size (f, ew->core.width, ew->core.height, + false, true, false); if (get_wm_shell (widget)) update_wm_hints (get_wm_shell (widget), ew); @@ -462,6 +475,17 @@ EmacsFrameSetCharSize (Widget widget, int columns, int rows) rows * FRAME_LINE_HEIGHT (f)); } +static void +EmacsFrameExpose (Widget widget, XEvent *event, Region region) +{ + EmacsFrame ew = (EmacsFrame) widget; + struct frame *f = ew->emacs_frame.frame; + + expose_frame (f, event->xexpose.x, event->xexpose.y, + event->xexpose.width, event->xexpose.height); + flush_frame (f); +} + void widget_store_internal_border (Widget widget) diff --git a/src/window.c b/src/window.c index 59e21f11cb1..15d6cf94b0e 100644 --- a/src/window.c +++ b/src/window.c @@ -1079,7 +1079,9 @@ means that if a column at the right of the text area is only partially visible, that column is not counted. Note that the returned value includes the column reserved for the -continuation glyph. */) +continuation glyph. + +Also see `window-max-characters-per-line'. */) (Lisp_Object window, Lisp_Object pixelwise) { return make_fixnum (window_body_width (decode_live_window (window), @@ -1692,6 +1694,14 @@ column 0. */) 0, false, false); } +ptrdiff_t +window_point (struct window *w) +{ + return (w == XWINDOW (selected_window) + ? BUF_PT (XBUFFER (w->contents)) + : XMARKER (w->pointm)->charpos); +} + DEFUN ("window-point", Fwindow_point, Swindow_point, 0, 1, 0, doc: /* Return current value of point in WINDOW. WINDOW must be a live window and defaults to the selected one. @@ -1705,12 +1715,7 @@ correct to return the top-level value of `point', outside of any `save-excursion' forms. But that is hard to define. */) (Lisp_Object window) { - register struct window *w = decode_live_window (window); - - if (w == XWINDOW (selected_window)) - return make_fixnum (BUF_PT (XBUFFER (w->contents))); - else - return Fmarker_position (w->pointm); + return make_fixnum (window_point (decode_live_window (window))); } DEFUN ("window-old-point", Fwindow_old_point, Swindow_old_point, 0, 1, 0, @@ -1852,13 +1857,24 @@ Return POS. */) DEFUN ("set-window-start", Fset_window_start, Sset_window_start, 2, 3, 0, doc: /* Make display in WINDOW start at position POS in WINDOW's buffer. WINDOW must be a live window and defaults to the selected one. Return -POS. Optional third arg NOFORCE non-nil inhibits next redisplay from -overriding motion of point in order to display at this exact start. +POS. + +Optional third arg NOFORCE non-nil prevents next redisplay from +moving point if displaying the window at POS makes point invisible; +redisplay will then choose the WINDOW's start position by itself in +that case, i.e. it will disregard POS if adhering to it will make +point not visible in the window. For reliable setting of WINDOW start position, make sure point is at a position that will be visible when that start is in effect, otherwise there's a chance POS will be disregarded, e.g., if point -winds up in a partially-visible line. */) +winds up in a partially-visible line. + +The setting of the WINDOW's start position takes effect during the +next redisplay cycle, not immediately. If NOFORCE is nil or +omitted, forcing the display of WINDOW to start at POS cancels +any setting of WINDOW's vertical scroll (\"vscroll\") amount +set by `set-window-vscroll' and by scrolling functions. */) (Lisp_Object window, Lisp_Object pos, Lisp_Object noforce) { register struct window *w = decode_live_window (window); @@ -3181,14 +3197,6 @@ resize_root_window (Lisp_Object window, Lisp_Object delta, horizontal, ignore, pixelwise); } -void -sanitize_window_sizes (Lisp_Object horizontal) -{ - /* Don't burp in temacs -nw before window.el is loaded. */ - if (!NILP (Fsymbol_function (Qwindow__sanitize_window_sizes))) - call1 (Qwindow__sanitize_window_sizes, horizontal); -} - static Lisp_Object window_pixel_to_total (Lisp_Object frame, Lisp_Object horizontal) @@ -6332,34 +6340,6 @@ followed by all visible frames on the current terminal. */) return window; } -DEFUN ("scroll-other-window", Fscroll_other_window, Sscroll_other_window, 0, 1, "P", - doc: /* Scroll next window upward ARG lines; or near full screen if no ARG. -A near full screen is `next-screen-context-lines' less than a full screen. -Negative ARG means scroll downward. If ARG is the atom `-', scroll -downward by nearly full screen. When calling from a program, supply -as argument a number, nil, or `-'. - -The next window is usually the one below the current one; -or the one at the top if the current one is at the bottom. -It is determined by the function `other-window-for-scrolling', -which see. */) - (Lisp_Object arg) -{ - specpdl_ref count = SPECPDL_INDEX (); - scroll_command (Fother_window_for_scrolling (), arg, 1); - return unbind_to (count, Qnil); -} - -DEFUN ("scroll-other-window-down", Fscroll_other_window_down, - Sscroll_other_window_down, 0, 1, "P", - doc: /* Scroll next window downward ARG lines; or near full screen if no ARG. -For more details, see the documentation for `scroll-other-window'. */) - (Lisp_Object arg) -{ - specpdl_ref count = SPECPDL_INDEX (); - scroll_command (Fother_window_for_scrolling (), arg, -1); - return unbind_to (count, Qnil); -} DEFUN ("scroll-left", Fscroll_left, Sscroll_left, 0, 2, "^P\np", doc: /* Scroll selected window display ARG columns left. @@ -8232,7 +8212,6 @@ syms_of_window (void) DEFSYM (Qwindow__resize_root_window_vertically, "window--resize-root-window-vertically"); DEFSYM (Qwindow__resize_mini_frame, "window--resize-mini-frame"); - DEFSYM (Qwindow__sanitize_window_sizes, "window--sanitize-window-sizes"); DEFSYM (Qwindow__pixel_to_total, "window--pixel-to-total"); DEFSYM (Qsafe, "safe"); DEFSYM (Qdisplay_buffer, "display-buffer"); @@ -8340,7 +8319,10 @@ In this case the window is passed as argument. Functions specified by the default value are called for each frame if at least one window on that frame has been added or changed its buffer or its total or body size since the last redisplay. In this case the -frame is passed as argument. */); +frame is passed as argument. + +For instance, to hide the title bar when the frame is maximized, you +can add `frame-hide-title-bar-when-maximized' to this variable. */); Vwindow_size_change_functions = Qnil; DEFVAR_LISP ("window-selection-change-functions", Vwindow_selection_change_functions, @@ -8602,8 +8584,6 @@ displayed after a scrolling operation to be somewhat inaccurate. */); defsubr (&Sscroll_left); defsubr (&Sscroll_right); defsubr (&Sother_window_for_scrolling); - defsubr (&Sscroll_other_window); - defsubr (&Sscroll_other_window_down); defsubr (&Sminibuffer_selected_window); defsubr (&Srecenter); defsubr (&Swindow_text_width); diff --git a/src/window.h b/src/window.h index 141c29e8100..387a3be36a9 100644 --- a/src/window.h +++ b/src/window.h @@ -1188,10 +1188,10 @@ extern int window_scroll_margin (struct window *, enum margin_unit); extern void temp_output_buffer_show (Lisp_Object); extern void replace_buffer_in_windows (Lisp_Object); extern void replace_buffer_in_windows_safely (Lisp_Object); -extern void sanitize_window_sizes (Lisp_Object horizontal); /* This looks like a setter, but it is a bit special. */ extern void wset_buffer (struct window *, Lisp_Object); extern bool window_outdated (struct window *); +extern ptrdiff_t window_point (struct window *w); extern void init_window_once (void); extern void init_window (void); extern void syms_of_window (void); diff --git a/src/xdisp.c b/src/xdisp.c index 5cb58391dde..50efa50c55b 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -770,7 +770,7 @@ static bool message_buf_print; static bool message_cleared_p; /* A scratch glyph row with contents used for generating truncation - glyphs. Also used in direct_output_for_insert. */ + glyphs and overlay-arrow glyphs. */ #define MAX_SCRATCH_GLYPHS 100 static struct glyph_row scratch_glyph_row; @@ -9910,6 +9910,18 @@ move_it_in_display_line_to (struct it *it, } else result = MOVE_NEWLINE_OR_CR; + /* If lines are truncated, and the line we moved across is + completely hscrolled out of view, reset the line metrics + to those of the newline we've just processed, so that + glyphs not on display don't affect the line's height. */ + if (it->line_wrap == TRUNCATE + && it->current_x <= it->first_visible_x + && result == MOVE_NEWLINE_OR_CR + && it->char_to_display == '\n') + { + it->max_ascent = it->ascent; + it->max_descent = it->descent; + } /* If we've processed the newline, make sure this flag is reset, as it must only be set when the newline itself is processed. */ @@ -10957,6 +10969,7 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to, same directionality. */ it.bidi_p = false; + int start_x; if (vertical_offset != 0) { int last_y; @@ -10990,6 +11003,7 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to, + WINDOW_HEADER_LINE_HEIGHT (w)); start = clip_to_bounds (BEGV, IT_CHARPOS (it), ZV); start_y = it.current_y; + start_x = it.current_x; } else { @@ -10999,11 +11013,52 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to, reseat_at_previous_visible_line_start (&it); it.current_x = it.hpos = 0; if (IT_CHARPOS (it) != start) - move_it_to (&it, start, -1, -1, -1, MOVE_TO_POS); + { + void *it1data = NULL; + struct it it1; + + SAVE_IT (it1, it, it1data); + move_it_to (&it, start, -1, -1, -1, MOVE_TO_POS); + /* We could have a display property at START, in which case + asking move_it_to to stop at START will overshoot and + stop at position after START. So we try again, stopping + before START, and account for the width of the last + buffer position manually. */ + if (IT_CHARPOS (it) > start && start > BEGV) + { + ptrdiff_t it1pos = IT_CHARPOS (it1); + int it1_x = it1.current_x; + + RESTORE_IT (&it, &it1, it1data); + /* If START - 1 is the beginning of screen line, + move_it_to will not move, so we need to use a + lower-level move_it_in_display_line subroutine, and + tell it to move just 1 pixel, so it stops at the next + display element. */ + if (start - 1 > it1pos) + move_it_to (&it, start - 1, -1, -1, -1, MOVE_TO_POS); + else + move_it_in_display_line (&it, start, it1_x + 1, + MOVE_TO_POS | MOVE_TO_X); + move_it_to (&it, start - 1, -1, -1, -1, MOVE_TO_POS); + start_x = it.current_x; + /* If we didn't change our buffer position, the pixel + width of what's here was not yet accounted for; do it + manually. */ + if (IT_CHARPOS (it) == start - 1) + start_x += it.pixel_width; + } + else + { + start_x = it.current_x; + bidi_unshelve_cache (it1data, true); + } + } + else + start_x = it.current_x; } /* Now move to TO. */ - int start_x = it.current_x; int move_op = MOVE_TO_POS | MOVE_TO_Y; int to_x = -1; it.current_y = start_y; @@ -12088,7 +12143,7 @@ setup_echo_area_for_printing (bool multibyte_p) { /* If we can't find an echo area any more, exit. */ if (! FRAME_LIVE_P (XFRAME (selected_frame))) - Fkill_emacs (Qnil); + Fkill_emacs (Qnil, Qnil); ensure_echo_area_buffers (); @@ -12626,18 +12681,23 @@ set_message_1 (void *a1, Lisp_Object string) void clear_message (bool current_p, bool last_displayed_p) { + Lisp_Object preserve = Qnil; + if (current_p) { - echo_area_buffer[0] = Qnil; - message_cleared_p = true; - if (FUNCTIONP (Vclear_message_function)) { specpdl_ref count = SPECPDL_INDEX (); specbind (Qinhibit_quit, Qt); - safe_call (1, Vclear_message_function); + preserve = safe_call (1, Vclear_message_function); unbind_to (count, Qnil); } + + if (!EQ (preserve, Qdont_clear_message)) + { + echo_area_buffer[0] = Qnil; + message_cleared_p = true; + } } if (last_displayed_p) @@ -13190,6 +13250,20 @@ gui_consider_frame_title (Lisp_Object frame) && (update_mode_lines == 0 \ || update_mode_lines == REDISPLAY_SOME)) +static bool +needs_no_redisplay (struct window *w) +{ + struct buffer *buffer = XBUFFER (w->contents); + struct frame *f = XFRAME (w->frame); + return (REDISPLAY_SOME_P () + && !w->redisplay + && !w->update_mode_line + && !f->face_change + && !f->redisplay + && !buffer->text->redisplay + && window_point (w) == w->last_point); +} + /* Prepare for redisplay by updating menu-bar item lists when appropriate. This can call eval. */ @@ -13209,12 +13283,10 @@ prepare_menu_bars (void) { Lisp_Object this = XCAR (ws); struct window *w = XWINDOW (this); - if (w->redisplay - || XFRAME (w->frame)->redisplay - || XBUFFER (w->contents)->text->redisplay) - { - windows = Fcons (this, windows); - } + /* Cf. conditions for redisplaying a window at the + beginning of redisplay_window. */ + if (!needs_no_redisplay (w)) + windows = Fcons (this, windows); } } safe__call1 (true, Vpre_redisplay_function, windows); @@ -15111,11 +15183,11 @@ get_tool_bar_item (struct frame *f, int x, int y, struct glyph **glyph, Handle mouse button event on the tool-bar of frame F, at frame-relative coordinates X/Y. DOWN_P is true for a button press, false for button release. MODIFIERS is event modifiers for button - release. */ + release. DEVICE is the device the click came from, or Qt. */ void -handle_tool_bar_click (struct frame *f, int x, int y, bool down_p, - int modifiers) +handle_tool_bar_click_with_device (struct frame *f, int x, int y, bool down_p, + int modifiers, Lisp_Object device) { Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); struct window *w = XWINDOW (f->tool_bar_window); @@ -15172,11 +15244,18 @@ handle_tool_bar_click (struct frame *f, int x, int y, bool down_p, event.frame_or_window = frame; event.arg = key; event.modifiers = modifiers; + event.device = device; kbd_buffer_store_event (&event); f->last_tool_bar_item = -1; } } +void +handle_tool_bar_click (struct frame *f, int x, int y, bool down_p, + int modifiers) +{ + handle_tool_bar_click_with_device (f, x, y, down_p, modifiers, Qt); +} /* Possibly highlight a tool-bar item on frame F when mouse moves to tool-bar window-relative coordinates X/Y. Called from @@ -18876,14 +18955,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) *w->desired_matrix->method = 0; #endif - if (!just_this_one_p - && REDISPLAY_SOME_P () - && !w->redisplay - && !w->update_mode_line - && !f->face_change - && !f->redisplay - && !buffer->text->redisplay - && BUF_PT (buffer) == w->last_point) + if (!just_this_one_p && needs_no_redisplay (w)) return; /* Make sure that both W's markers are valid. */ @@ -22072,7 +22144,7 @@ get_overlay_arrow_glyph_row (struct window *w, Lisp_Object overlay_arrow_string) struct buffer *buffer = XBUFFER (w->contents); struct buffer *old = current_buffer; const unsigned char *arrow_string = SDATA (overlay_arrow_string); - ptrdiff_t arrow_len = SCHARS (overlay_arrow_string); + ptrdiff_t arrow_len = SBYTES (overlay_arrow_string), char_num = 0; const unsigned char *arrow_end = arrow_string + arrow_len; const unsigned char *p; struct it it; @@ -22103,7 +22175,7 @@ get_overlay_arrow_glyph_row (struct window *w, Lisp_Object overlay_arrow_string) p += it.len; /* Get its face. */ - ilisp = make_fixnum (p - arrow_string); + ilisp = make_fixnum (char_num++); face = Fget_text_property (ilisp, Qface, overlay_arrow_string); it.face_id = compute_char_face (f, it.char_to_display, face); @@ -25009,7 +25081,10 @@ function `get-char-code-property' for a way to inquire about the directionality is weak or neutral, such as numbers or punctuation characters, can be forced to display in a very different place with respect of its surrounding characters, so as to make the surrounding -text confuse the user regarding what the text says. */) +text confuse the user regarding what the text says. + +Also see the `highlight-confusing-reorderings' function, which can be +useful in similar circumstances as this function. */) (Lisp_Object from, Lisp_Object to, Lisp_Object object, Lisp_Object base_dir) { struct buffer *buf = current_buffer; @@ -33850,7 +33925,8 @@ define_frame_cursor1 (struct frame *f, Emacs_Cursor cursor, Lisp_Object pointer) return; /* Do not change cursor shape while dragging mouse. */ - if (EQ (track_mouse, Qdragging) || EQ (track_mouse, Qdropping)) + if (EQ (track_mouse, Qdragging) || EQ (track_mouse, Qdropping) + || EQ (track_mouse, Qdrag_source)) return; if (!NILP (pointer)) @@ -35672,6 +35748,7 @@ be let-bound around code that needs to disable messages temporarily. */); DEFSYM (Qdragging, "dragging"); DEFSYM (Qdropping, "dropping"); + DEFSYM (Qdrag_source, "drag-source"); DEFSYM (Qdrag_with_mode_line, "drag-with-mode-line"); DEFSYM (Qdrag_with_header_line, "drag-with-header-line"); @@ -36487,12 +36564,20 @@ message displayed by this function), and `command-error-function' (which controls how error messages are displayed). */); Vset_message_function = Qnil; + DEFSYM (Qdont_clear_message, "dont-clear-message"); DEFVAR_LISP ("clear-message-function", Vclear_message_function, doc: /* If non-nil, function to clear echo-area messages. Usually this function is called when the next input event arrives. -The function is called without arguments. It is expected to clear the -message displayed by its counterpart function specified by -`set-message-function'. */); +It is expected to clear the message displayed by its counterpart +function specified by `set-message-function'. + +The function is called without arguments. + +If this function returns a value that isn't `dont-clear-message', the +message is cleared from the echo area as usual. If this function +returns `dont-clear-message', this means that the message was already +handled, and the original message text will not be cleared from the +echo area. */); Vclear_message_function = Qnil; DEFVAR_LISP ("redisplay--all-windows-cause", Vredisplay__all_windows_cause, diff --git a/src/xfaces.c b/src/xfaces.c index d7f1f4d96e5..05e0df4b7dc 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -1450,9 +1450,9 @@ enum xlfd_field }; /* Order by which font selection chooses fonts. The default values - mean `first, find a best match for the font width, then for the - font height, then for weight, then for slant.' This variable can be - set via set-face-font-sort-order. */ + mean "first, find a best match for the font width, then for the + font height, then for weight, then for slant." This variable can be + set via 'internal-set-font-selection-order'. */ static int font_sort_order[4]; @@ -1503,16 +1503,22 @@ If FAMILY is omitted or nil, list all families. Otherwise, FAMILY must be a string, possibly containing wildcards `?' and `*'. If FRAME is omitted or nil, use the selected frame. + Each element of the result is a vector [FAMILY WIDTH POINT-SIZE WEIGHT SLANT FIXED-P FULL REGISTRY-AND-ENCODING]. -FAMILY is the font family name. POINT-SIZE is the size of the -font in 1/10 pt. WIDTH, WEIGHT, and SLANT are symbols describing the -width, weight and slant of the font. These symbols are the same as for -face attributes. FIXED-P is non-nil if the font is fixed-pitch. -FULL is the full name of the font, and REGISTRY-AND-ENCODING is a string -giving the registry and encoding of the font. -The result list is sorted according to the current setting of -the face font sort order. */) + +FAMILY is the font family name. +POINT-SIZE is the size of the font in 1/10 pt. +WIDTH, WEIGHT, and SLANT are symbols describing the width, weight + and slant of the font. These symbols are the same as for face + attributes, see `set-face-attribute'. +FIXED-P is non-nil if the font is fixed-pitch. +FULL is the full name of the font. +REGISTRY-AND-ENCODING is a string giving the registry and encoding of + the font. + +The resulting list is sorted according to the current setting of +the face font sort order, see `face-font-selection-order'. */) (Lisp_Object family, Lisp_Object frame) { Lisp_Object font_spec, list, *drivers, vec; @@ -1573,7 +1579,14 @@ the face font sort order. */) make_fixnum (point), FONT_WEIGHT_SYMBOLIC (font), FONT_SLANT_SYMBOLIC (font), - NILP (spacing) || EQ (spacing, Qp) ? Qnil : Qt, + (NILP (spacing) + || EQ (spacing, Qp) + /* If the font was specified in a way + different from XLFD (e.g., on MS-Windows), + we will have a number there, not 'p'. */ + || EQ (spacing, + make_fixnum (FONT_SPACING_PROPORTIONAL))) + ? Qnil : Qt, Ffont_xlfd_name (font, Qnil), AREF (font, FONT_REGISTRY_INDEX)); result = Fcons (v, result); @@ -4434,17 +4447,26 @@ free_realized_face (struct frame *f, struct face *face) void prepare_face_for_display (struct frame *f, struct face *face) { + Emacs_GC egc; + unsigned long mask; + eassert (FRAME_WINDOW_P (f)); if (face->gc == 0) { - Emacs_GC egc; - unsigned long mask = GCForeground | GCBackground | GCGraphicsExposures; + mask = GCForeground | GCBackground | GCGraphicsExposures; egc.foreground = face->foreground; egc.background = face->background; #ifdef HAVE_X_WINDOWS egc.graphics_exposures = False; + + /* While this was historically slower than a line_width of 0, + the difference no longer matters on modern X servers, so set + it to 1 in order for PolyLine requests to behave consistently + everywhere. */ + mask |= GCLineWidth; + egc.line_width = 1; #endif block_input (); diff --git a/src/xfns.c b/src/xfns.c index a3236efbcc6..dc8f02780ce 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -730,9 +730,11 @@ x_set_wait_for_wm (struct frame *f, Lisp_Object new_value, Lisp_Object old_value static void x_set_alpha_background (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { -#ifndef HAVE_GTK3 unsigned long opaque_region[] = {0, 0, FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f)}; +#ifdef HAVE_GTK3 + GObjectClass *object_class; + GtkWidgetClass *class; #endif gui_set_alpha_background (f, arg, oldval); @@ -776,6 +778,24 @@ x_set_alpha_background (struct frame *f, Lisp_Object arg, Lisp_Object oldval) FRAME_DISPLAY_INFO (f)->Xatom_net_wm_opaque_region, XA_CARDINAL, 32, PropModeReplace, (unsigned char *) &opaque_region, 4); +#else + else + { + if (FRAME_TOOLTIP_P (f)) + XChangeProperty (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + FRAME_DISPLAY_INFO (f)->Xatom_net_wm_opaque_region, + XA_CARDINAL, 32, PropModeReplace, + (unsigned char *) &opaque_region, 4); + else + { + object_class = G_OBJECT_GET_CLASS (FRAME_GTK_OUTER_WIDGET (f)); + class = GTK_WIDGET_CLASS (object_class); + + if (class->style_updated) + class->style_updated (FRAME_GTK_OUTER_WIDGET (f)); + } + } #endif } @@ -803,22 +823,24 @@ x_set_tool_bar_position (struct frame *f, wrong_choice (choice, new_value); } +#ifdef HAVE_XDBE static void x_set_inhibit_double_buffering (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) { - block_input (); + bool want_double_buffering, was_double_buffered; + if (FRAME_X_WINDOW (f) && !EQ (new_value, old_value)) { - bool want_double_buffering = NILP (new_value); - bool was_double_buffered = FRAME_X_DOUBLE_BUFFERED_P (f); - /* font_drop_xrender_surfaces in xftfont does something only if - we're double-buffered, so call font_drop_xrender_surfaces before - and after any potential change. One of the calls will end up - being a no-op. */ + want_double_buffering = NILP (new_value); + was_double_buffered = FRAME_X_DOUBLE_BUFFERED_P (f); + + block_input (); if (want_double_buffering != was_double_buffered) { + /* Force XftDraw etc to be recreated with the new double + buffered drawable. */ font_drop_xrender_surfaces (f); /* Scroll bars decide whether or not to use a back buffer @@ -840,9 +862,10 @@ x_set_inhibit_double_buffering (struct frame *f, SET_FRAME_GARBAGED (f); font_drop_xrender_surfaces (f); } + unblock_input (); } - unblock_input (); } +#endif /** * x_set_undecorated: @@ -867,7 +890,7 @@ x_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_value #else Display *dpy = FRAME_X_DISPLAY (f); PropMotifWmHints hints; - Atom prop = XInternAtom (dpy, "_MOTIF_WM_HINTS", False); + Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_MOTIF_WM_HINTS; memset (&hints, 0, sizeof(hints)); hints.flags = MWM_HINTS_DECORATIONS; @@ -979,7 +1002,7 @@ x_set_no_focus_on_map (struct frame *f, Lisp_Object new_value, Lisp_Object old_v xg_set_no_focus_on_map (f, new_value); #else /* not USE_GTK */ Display *dpy = FRAME_X_DISPLAY (f); - Atom prop = XInternAtom (dpy, "_NET_WM_USER_TIME", False); + Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_net_wm_user_time; Time timestamp = NILP (new_value) ? CurrentTime : 0; XChangeProperty (dpy, FRAME_OUTER_WINDOW (f), prop, @@ -1943,6 +1966,10 @@ static void x_set_scroll_bar_foreground (struct frame *f, Lisp_Object value, Lisp_Object oldval) { unsigned long pixel; +#ifdef HAVE_GTK3 + XColor color; + char css[64]; +#endif if (STRINGP (value)) pixel = x_decode_color (f, value, BLACK_PIX_DEFAULT (f)); @@ -1964,6 +1991,28 @@ x_set_scroll_bar_foreground (struct frame *f, Lisp_Object value, Lisp_Object old update_face_from_frame_parameter (f, Qscroll_bar_foreground, value); redraw_frame (f); } + +#ifdef HAVE_GTK3 + if (!FRAME_TOOLTIP_P (f)) + { + if (pixel != -1) + { + color.pixel = pixel; + + XQueryColor (FRAME_X_DISPLAY (f), + FRAME_X_COLORMAP (f), + &color); + + sprintf (css, "scrollbar slider { background-color: #%02x%02x%02x; }", + color.red >> 8, color.green >> 8, color.blue >> 8); + gtk_css_provider_load_from_data (FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider, + css, -1, NULL); + } + else + gtk_css_provider_load_from_data (FRAME_X_OUTPUT (f)->scrollbar_foreground_css_provider, + "", -1, NULL); + } +#endif } @@ -1976,6 +2025,10 @@ static void x_set_scroll_bar_background (struct frame *f, Lisp_Object value, Lisp_Object oldval) { unsigned long pixel; +#ifdef HAVE_GTK3 + XColor color; + char css[64]; +#endif if (STRINGP (value)) pixel = x_decode_color (f, value, WHITE_PIX_DEFAULT (f)); @@ -2011,6 +2064,28 @@ x_set_scroll_bar_background (struct frame *f, Lisp_Object value, Lisp_Object old update_face_from_frame_parameter (f, Qscroll_bar_background, value); redraw_frame (f); } + +#ifdef HAVE_GTK3 + if (!FRAME_TOOLTIP_P (f)) + { + if (pixel != -1) + { + color.pixel = pixel; + + XQueryColor (FRAME_X_DISPLAY (f), + FRAME_X_COLORMAP (f), + &color); + + sprintf (css, "scrollbar trough { background-color: #%02x%02x%02x; }", + color.red >> 8, color.green >> 8, color.blue >> 8); + gtk_css_provider_load_from_data (FRAME_X_OUTPUT (f)->scrollbar_background_css_provider, + css, -1, NULL); + } + else + gtk_css_provider_load_from_data (FRAME_X_OUTPUT (f)->scrollbar_background_css_provider, + "", -1, NULL); + } +#endif } @@ -3476,8 +3551,11 @@ xic_set_xfontset (struct frame *f, const char *base_fontname) void x_mark_frame_dirty (struct frame *f) { - if (FRAME_X_DOUBLE_BUFFERED_P (f) && !FRAME_X_NEED_BUFFER_FLIP (f)) +#ifdef HAVE_XDBE + if (FRAME_X_DOUBLE_BUFFERED_P (f) + && !FRAME_X_NEED_BUFFER_FLIP (f)) FRAME_X_NEED_BUFFER_FLIP (f) = true; +#endif } static void @@ -3558,12 +3636,12 @@ tear_down_x_back_buffer (struct frame *f) void initial_set_up_x_back_buffer (struct frame *f) { - block_input (); eassert (FRAME_X_WINDOW (f)); FRAME_X_RAW_DRAWABLE (f) = FRAME_X_WINDOW (f); - if (NILP (CDR (Fassq (Qinhibit_double_buffering, f->param_alist)))) + + if (NILP (CDR (Fassq (Qinhibit_double_buffering, + f->param_alist)))) set_up_x_back_buffer (f); - unblock_input (); } #if defined HAVE_XINPUT2 @@ -3590,9 +3668,9 @@ setup_xi_event_mask (struct frame *f) #ifndef USE_GTK XISetMask (m, XI_FocusIn); XISetMask (m, XI_FocusOut); -#endif XISetMask (m, XI_KeyPress); XISetMask (m, XI_KeyRelease); +#endif XISelectEvents (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), &mask, 1); @@ -3866,7 +3944,7 @@ x_window (struct frame *f, long window_prompting) { Display *dpy = FRAME_X_DISPLAY (f); PropMotifWmHints hints; - Atom prop = XInternAtom (dpy, "_MOTIF_WM_HINTS", False); + Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_MOTIF_WM_HINTS; memset (&hints, 0, sizeof(hints)); hints.flags = MWM_HINTS_DECORATIONS; @@ -4045,7 +4123,7 @@ x_window (struct frame *f) { Display *dpy = FRAME_X_DISPLAY (f); PropMotifWmHints hints; - Atom prop = XInternAtom (dpy, "_MOTIF_WM_HINTS", False); + Atom prop = FRAME_DISPLAY_INFO (f)->Xatom_MOTIF_WM_HINTS; memset (&hints, 0, sizeof(hints)); hints.flags = MWM_HINTS_DECORATIONS; @@ -4159,7 +4237,7 @@ x_make_gc (struct frame *f) gc_values.foreground = FRAME_FOREGROUND_PIXEL (f); gc_values.background = FRAME_BACKGROUND_PIXEL (f); - gc_values.line_width = 0; /* Means 1 using fast algorithm. */ + gc_values.line_width = 1; f->output_data.x->normal_gc = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), @@ -4383,9 +4461,7 @@ set_machine_and_pid_properties (struct frame *f) unsigned long xpid = pid; XChangeProperty (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), - XInternAtom (FRAME_X_DISPLAY (f), - "_NET_WM_PID", - False), + FRAME_DISPLAY_INFO (f)->Xatom_net_wm_pid, XA_CARDINAL, 32, PropModeReplace, (unsigned char *) &xpid, 1); } @@ -4713,6 +4789,13 @@ This function is an internal primitive--use `make-frame' instead. */) gui_default_parameter (f, parms, Qno_special_glyphs, Qnil, NULL, NULL, RES_TYPE_BOOLEAN); +#ifdef HAVE_GTK3 + FRAME_OUTPUT_DATA (f)->scrollbar_background_css_provider + = gtk_css_provider_new (); + FRAME_OUTPUT_DATA (f)->scrollbar_foreground_css_provider + = gtk_css_provider_new (); +#endif + x_default_scroll_bar_color_parameter (f, parms, Qscroll_bar_foreground, "scrollBarForeground", "ScrollBarForeground", true); @@ -4788,6 +4871,13 @@ This function is an internal primitive--use `make-frame' instead. */) x_icon (f, parms); x_make_gc (f); +#ifdef HAVE_XINPUT2 + if (dpyinfo->supports_xi2) + FRAME_X_OUTPUT (f)->xi_masks + = XIGetSelectedEvents (dpyinfo->display, FRAME_X_WINDOW (f), + &FRAME_X_OUTPUT (f)->num_xi_masks); +#endif + /* Now consider the frame official. */ f->terminal->reference_count++; FRAME_DISPLAY_INFO (f)->reference_count++; @@ -5402,6 +5492,7 @@ On MS Windows, this just returns nil. */) static bool x_get_net_workarea (struct x_display_info *dpyinfo, XRectangle *rect) { +#ifndef USE_XCB Display *dpy = dpyinfo->display; long offset, max_len; Atom target_type, actual_type; @@ -5455,6 +5546,69 @@ x_get_net_workarea (struct x_display_info *dpyinfo, XRectangle *rect) x_uncatch_errors (); return result; +#else + xcb_get_property_cookie_t current_desktop_cookie; + xcb_get_property_cookie_t workarea_cookie; + xcb_get_property_reply_t *reply; + xcb_generic_error_t *error; + bool rc; + uint32_t current_workspace, *values; + + current_desktop_cookie + = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) dpyinfo->root_window, + (xcb_atom_t) dpyinfo->Xatom_net_current_desktop, + XCB_ATOM_CARDINAL, 0, 1); + + workarea_cookie + = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) dpyinfo->root_window, + (xcb_atom_t) dpyinfo->Xatom_net_workarea, + XCB_ATOM_CARDINAL, 0, UINT32_MAX); + + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + current_desktop_cookie, &error); + rc = true; + + if (!reply) + free (error), rc = false; + else + { + if (xcb_get_property_value_length (reply) != 4 + || reply->type != XCB_ATOM_CARDINAL || reply->format != 32) + rc = false; + else + current_workspace = *(uint32_t *) xcb_get_property_value (reply); + + free (reply); + } + + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + workarea_cookie, &error); + + if (!reply) + free (error), rc = false; + else + { + if (rc && reply->type == XCB_ATOM_CARDINAL && reply->format == 32 + && (xcb_get_property_value_length (reply) / sizeof (uint32_t) + >= current_workspace + 4)) + { + values = xcb_get_property_value (reply); + + rect->x = values[current_workspace]; + rect->y = values[current_workspace + 1]; + rect->width = values[current_workspace + 2]; + rect->height = values[current_workspace + 3]; + } + else + rc = false; + + free (reply); + } + + return rc; +#endif } #endif /* !(USE_GTK && HAVE_GTK3) */ @@ -5647,6 +5801,12 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) #if RANDR_MAJOR > 1 || (RANDR_MAJOR == 1 && RANDR_MINOR >= 5) XRRMonitorInfo *rr_monitors; +#ifdef USE_XCB + xcb_get_atom_name_cookie_t *atom_name_cookies; + xcb_get_atom_name_reply_t *reply; + xcb_generic_error_t *error; + int length; +#endif /* If RandR 1.5 or later is available, use that instead, as some video drivers don't report correct dimensions via other versions @@ -5665,6 +5825,9 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) goto fallback; monitors = xzalloc (n_monitors * sizeof *monitors); +#ifdef USE_XCB + atom_name_cookies = alloca (n_monitors * sizeof *atom_name_cookies); +#endif for (int i = 0; i < n_monitors; ++i) { @@ -5675,6 +5838,7 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) monitors[i].mm_width = rr_monitors[i].mwidth; monitors[i].mm_height = rr_monitors[i].mheight; +#ifndef USE_XCB name = XGetAtomName (dpyinfo->display, rr_monitors[i].name); if (name) { @@ -5683,6 +5847,11 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) } else monitors[i].name = xstrdup ("Unknown Monitor"); +#else + atom_name_cookies[i] + = xcb_get_atom_name (dpyinfo->xcb_connection, + (xcb_atom_t) rr_monitors[i].name); +#endif if (rr_monitors[i].primary) primary = i; @@ -5700,6 +5869,29 @@ x_get_monitor_attributes_xrandr (struct x_display_info *dpyinfo) monitors[i].work = monitors[i].geom; } +#ifdef USE_XCB + for (int i = 0; i < n_monitors; ++i) + { + reply = xcb_get_atom_name_reply (dpyinfo->xcb_connection, + atom_name_cookies[i], &error); + + if (!reply) + { + monitors[i].name = xstrdup ("Unknown monitor"); + free (error); + } + else + { + length = xcb_get_atom_name_name_length (reply); + name = xmalloc (length + 1); + memcpy (name, xcb_get_atom_name_name (reply), length); + name[length] = '\0'; + monitors[i].name = name; + free (reply); + } + } +#endif + XRRFreeMonitors (rr_monitors); randr15_p = true; goto out; @@ -6488,7 +6680,7 @@ DEFUN ("x-set-mouse-absolute-pixel-position", Fx_set_mouse_absolute_pixel_positi The coordinates X and Y are interpreted in pixels relative to a position \(0, 0) of the selected frame's display. */) (Lisp_Object x, Lisp_Object y) - { +{ struct frame *f = SELECTED_FRAME (); if (FRAME_INITIAL_P (f) || !FRAME_X_P (f)) @@ -6523,6 +6715,162 @@ The coordinates X and Y are interpreted in pixels relative to a position return Qnil; } +DEFUN ("x-begin-drag", Fx_begin_drag, Sx_begin_drag, 1, 5, 0, + doc: /* Begin dragging contents on FRAME, with targets TARGETS. +TARGETS is a list of strings, which defines the X selection targets +that will be available to the drop target. Block until the mouse +buttons are released, then return the action chosen by the target, or +`nil' if the drop was not accepted by the drop target. Dragging +starts when the mouse is pressed on FRAME, and the contents of the +selection `XdndSelection' will be sent to the X window underneath the +mouse pointer (the drop target) when the mouse button is released. +ACTION is a symbol which tells the target what the source will do, and +can be one of the following: + + - `XdndActionCopy', which means to copy the contents from the drag + source (FRAME) to the drop target. + + - `XdndActionMove', which means to first take the contents of + `XdndSelection', and to delete whatever was saved into that + selection afterwards. + +`XdndActionPrivate' is also a valid return value, and means that the +drop target chose to perform an unspecified or unknown action. + +There are also some other valid values of ACTION that depend on +details of both the drop target's implementation details and that of +Emacs. For that reason, they are not mentioned here. Consult +"Drag-and-Drop Protocol for the X Window System" for more details: +https://freedesktop.org/wiki/Specifications/XDND/. + +If RETURN-FRAME is non-nil, this function will return the frame if the +mouse pointer moves onto an Emacs frame, after first moving out of +FRAME. (This is not guaranteed to work on some systems.) If +RETURN-FRAME is the symbol `now', any frame underneath the mouse +pointer will be returned immediately. + +If ACTION is a list and not nil, its elements are assumed to be a cons +of (ITEM . STRING), where ITEM is the name of an action, and STRING is +a string describing ITEM to the user. The drop target is expected to +prompt the user to choose between any of the actions in the list. + +If ACTION is not specified or nil, `XdndActionCopy' is used +instead. + +If ALLOW-CURRENT-FRAME is not specified or nil, then the drop target +is allowed to be FRAME. Otherwise, no action will be taken if the +mouse buttons are released on top of FRAME. */) + (Lisp_Object targets, Lisp_Object action, Lisp_Object frame, + Lisp_Object return_frame, Lisp_Object allow_current_frame) +{ + struct frame *f = decode_window_system_frame (frame); + int ntargets = 0, nnames = 0; + ptrdiff_t len; + char *target_names[2048]; + Atom *target_atoms; + Lisp_Object lval, original, tem, t1, t2; + Atom xaction; + Atom action_list[2048]; + char *name_list[2048]; + char *scratch; + + USE_SAFE_ALLOCA; + + CHECK_LIST (targets); + original = targets; + + for (; CONSP (targets); targets = XCDR (targets)) + { + CHECK_STRING (XCAR (targets)); + maybe_quit (); + + if (ntargets < 2048) + { + scratch = SSDATA (XCAR (targets)); + len = strlen (scratch); + target_names[ntargets] = SAFE_ALLOCA (len + 1); + strncpy (target_names[ntargets], scratch, len + 1); + ntargets++; + } + else + error ("Too many targets"); + } + + CHECK_LIST_END (targets, original); + + if (NILP (action) || EQ (action, QXdndActionCopy)) + xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionCopy; + else if (EQ (action, QXdndActionMove)) + xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionMove; + else if (EQ (action, QXdndActionLink)) + xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionLink; + else if (EQ (action, QXdndActionPrivate)) + xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionPrivate; + else if (EQ (action, QXdndActionAsk)) + xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk; + else if (CONSP (action)) + { + xaction = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk; + original = action; + + CHECK_LIST (action); + for (; CONSP (action); action = XCDR (action)) + { + maybe_quit (); + tem = XCAR (action); + CHECK_CONS (tem); + t1 = XCAR (tem); + t2 = XCDR (tem); + CHECK_SYMBOL (t1); + CHECK_STRING (t2); + + if (nnames < 2048) + { + if (EQ (t1, QXdndActionCopy)) + action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionCopy; + else if (EQ (t1, QXdndActionMove)) + action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionMove; + else if (EQ (t1, QXdndActionLink)) + action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionLink; + else if (EQ (t1, QXdndActionAsk)) + action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionAsk; + else if (EQ (t1, QXdndActionPrivate)) + action_list[nnames] = FRAME_DISPLAY_INFO (f)->Xatom_XdndActionPrivate; + else + signal_error ("Invalid drag-and-drop action", tem); + + scratch = SSDATA (ENCODE_UTF_8 (t2)); + len = strlen (scratch); + name_list[nnames] = SAFE_ALLOCA (len + 1); + strncpy (name_list[nnames], scratch, len + 1); + + nnames++; + } + else + error ("Too many actions"); + } + CHECK_LIST_END (action, original); + } + else + signal_error ("Invalid drag-and-drop action", action); + + target_atoms = xmalloc (ntargets * sizeof *target_atoms); + + block_input (); + XInternAtoms (FRAME_X_DISPLAY (f), target_names, + ntargets, False, target_atoms); + unblock_input (); + + x_set_dnd_targets (target_atoms, ntargets); + lval = x_dnd_begin_drag_and_drop (f, FRAME_DISPLAY_INFO (f)->last_user_time, + xaction, return_frame, action_list, + (const char **) &name_list, nnames, + !NILP (allow_current_frame)); + + SAFE_FREE (); + return lval; +} + /************************************************************************ X Displays ************************************************************************/ @@ -6860,6 +7208,13 @@ If WINDOW-ID is non-nil, change the property of that window instead unsigned char *data; int nelements; Window target_window; +#ifdef USE_XCB + xcb_intern_atom_cookie_t prop_atom_cookie; + xcb_intern_atom_cookie_t target_type_cookie; + xcb_intern_atom_reply_t *reply; + xcb_generic_error_t *generic_error; + bool rc; +#endif CHECK_STRING (prop); @@ -6923,12 +7278,61 @@ If WINDOW-ID is non-nil, change the property of that window instead } block_input (); +#ifndef USE_XCB prop_atom = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (prop), False); if (! NILP (type)) { CHECK_STRING (type); target_type = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (type), False); } +#else + rc = true; + prop_atom_cookie + = xcb_intern_atom (FRAME_DISPLAY_INFO (f)->xcb_connection, + 0, SBYTES (prop), SSDATA (prop)); + + if (!NILP (type)) + { + CHECK_STRING (type); + target_type_cookie + = xcb_intern_atom (FRAME_DISPLAY_INFO (f)->xcb_connection, + 0, SBYTES (type), SSDATA (type)); + } + + reply = xcb_intern_atom_reply (FRAME_DISPLAY_INFO (f)->xcb_connection, + prop_atom_cookie, &generic_error); + + if (reply) + { + prop_atom = (Atom) reply->atom; + free (reply); + } + else + { + free (generic_error); + rc = false; + } + + if (!NILP (type)) + { + reply = xcb_intern_atom_reply (FRAME_DISPLAY_INFO (f)->xcb_connection, + target_type_cookie, &generic_error); + + if (reply) + { + target_type = (Atom) reply->atom; + free (reply); + } + else + { + free (generic_error); + rc = false; + } + } + + if (!rc) + error ("Failed to intern type or property atom"); +#endif XChangeProperty (FRAME_X_DISPLAY (f), target_window, prop_atom, target_type, element_format, PropModeReplace, @@ -7845,29 +8249,6 @@ x_hide_tip (bool delete) else x_make_frame_invisible (XFRAME (tip_frame)); -#ifdef USE_LUCID - /* Bloodcurdling hack alert: The Lucid menu bar widget's - redisplay procedure is not called when a tip frame over - menu items is unmapped. Redisplay the menu manually... */ - { - Widget w; - struct frame *f = SELECTED_FRAME (); - - if (FRAME_X_P (f) && FRAME_LIVE_P (f)) - { - w = f->output_data.x->menubar_widget; - - if (!DoesSaveUnders (FRAME_DISPLAY_INFO (f)->screen) - && w != NULL) - { - block_input (); - xlwmenu_redisplay (w); - unblock_input (); - } - } - } -#endif /* USE_LUCID */ - was_open = Qt; } else @@ -7894,7 +8275,8 @@ PARMS is an optional list of frame parameters which can be used to change the tooltip's appearance. Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil -means use the default timeout of 5 seconds. +means use the default timeout from the `x-show-tooltip-timeout' +variable. If the list of frame parameters PARMS contains a `left' parameter, display the tooltip at that x-position. If the list of frame parameters @@ -7940,9 +8322,8 @@ Text larger than the specified size is clipped. */) f = decode_window_system_frame (frame); if (NILP (timeout)) - timeout = make_fixnum (5); - else - CHECK_FIXNAT (timeout); + timeout = Vx_show_tooltip_timeout; + CHECK_FIXNAT (timeout); if (NILP (dx)) dx = make_fixnum (5); @@ -8239,7 +8620,12 @@ DEFUN ("x-double-buffered-p", Fx_double_buffered_p, Sx_double_buffered_p, (Lisp_Object frame) { struct frame *f = decode_live_frame (frame); + +#ifdef HAVE_XDBE return FRAME_X_DOUBLE_BUFFERED_P (f) ? Qt : Qnil; +#else + return Qnil; +#endif } @@ -8412,25 +8798,11 @@ DEFUN ("x-file-dialog", Fx_file_dialog, Sx_file_dialog, 2, 5, 0, while (result == 0) { XEvent event, copy; -#ifdef HAVE_XINPUT2 - x_menu_wait_for_event (FRAME_X_DISPLAY (f)); -#else x_menu_wait_for_event (0); -#endif - if ( -#ifndef HAVE_XINPUT2 - XtAppPending (Xt_app_con) -#else - XPending (FRAME_X_DISPLAY (f)) -#endif - ) + if (XtAppPending (Xt_app_con)) { -#ifndef HAVE_XINPUT2 XtAppNextEvent (Xt_app_con, &event); -#else - XNextEvent (FRAME_X_DISPLAY (f), &event); -#endif copy = event; if (event.type == KeyPress @@ -8999,7 +9371,11 @@ frame_parm_handler x_frame_parm_handlers[] = gui_set_alpha, x_set_sticky, x_set_tool_bar_position, +#ifdef HAVE_XDBE x_set_inhibit_double_buffering, +#else + NULL, +#endif x_set_undecorated, x_set_parent_frame, x_set_skip_taskbar, @@ -9091,6 +9467,12 @@ syms_of_xfns (void) DEFSYM (Qreverse_landscape, "reverse-landscape"); #endif + DEFSYM (QXdndActionCopy, "XdndActionCopy"); + DEFSYM (QXdndActionMove, "XdndActionMove"); + DEFSYM (QXdndActionLink, "XdndActionLink"); + DEFSYM (QXdndActionAsk, "XdndActionAsk"); + DEFSYM (QXdndActionPrivate, "XdndActionPrivate"); + Fput (Qundefined_color, Qerror_conditions, pure_list (Qundefined_color, Qerror)); Fput (Qundefined_color, Qerror_message, @@ -9364,6 +9746,7 @@ eliminated in future versions of Emacs. */); defsubr (&Sx_show_tip); defsubr (&Sx_hide_tip); defsubr (&Sx_double_buffered_p); + defsubr (&Sx_begin_drag); tip_timer = Qnil; staticpro (&tip_timer); tip_frame = Qnil; diff --git a/src/xftfont.c b/src/xftfont.c index e27c6cf3146..31fb877c35b 100644 --- a/src/xftfont.c +++ b/src/xftfont.c @@ -643,18 +643,23 @@ xftfont_end_for_frame (struct frame *f) return 0; } -/* When using X double buffering, the XftDraw structure we build - seems to be useless once a frame is resized, so recreate it on +/* When using X double buffering, the XRender surfaces we create seem + to become useless once the window acting as the front buffer is + resized for an unknown reason (X server bug?), so recreate it on ConfigureNotify and in some other cases. */ +#ifdef HAVE_XDBE static void xftfont_drop_xrender_surfaces (struct frame *f) { - block_input (); if (FRAME_X_DOUBLE_BUFFERED_P (f)) - xftfont_end_for_frame (f); - unblock_input (); + { + block_input (); + xftfont_end_for_frame (f); + unblock_input (); + } } +#endif static bool xftfont_cached_font_ok (struct frame *f, Lisp_Object font_object, @@ -741,35 +746,37 @@ static void syms_of_xftfont_for_pdumper (void); struct font_driver const xftfont_driver = { /* We can't draw a text without device dependent functions. */ - .type = LISPSYM_INITIALLY (Qxft), - .get_cache = xfont_get_cache, - .list = xftfont_list, - .match = xftfont_match, - .list_family = ftfont_list_family, - .open_font = xftfont_open, - .close_font = xftfont_close, - .prepare_face = xftfont_prepare_face, - .done_face = xftfont_done_face, - .has_char = xftfont_has_char, - .encode_char = xftfont_encode_char, - .text_extents = xftfont_text_extents, - .draw = xftfont_draw, - .get_bitmap = ftfont_get_bitmap, - .anchor_point = ftfont_anchor_point, + .type = LISPSYM_INITIALLY (Qxft), + .get_cache = xfont_get_cache, + .list = xftfont_list, + .match = xftfont_match, + .list_family = ftfont_list_family, + .open_font = xftfont_open, + .close_font = xftfont_close, + .prepare_face = xftfont_prepare_face, + .done_face = xftfont_done_face, + .has_char = xftfont_has_char, + .encode_char = xftfont_encode_char, + .text_extents = xftfont_text_extents, + .draw = xftfont_draw, + .get_bitmap = ftfont_get_bitmap, + .anchor_point = ftfont_anchor_point, #ifdef HAVE_LIBOTF - .otf_capability = ftfont_otf_capability, + .otf_capability = ftfont_otf_capability, #endif - .end_for_frame = xftfont_end_for_frame, + .end_for_frame = xftfont_end_for_frame, #if defined HAVE_M17N_FLT && defined HAVE_LIBOTF - .shape = xftfont_shape, + .shape = xftfont_shape, #endif #if defined HAVE_OTF_GET_VARIATION_GLYPHS || defined HAVE_FT_FACE_GETCHARVARIANTINDEX - .get_variation_glyphs = ftfont_variation_glyphs, + .get_variation_glyphs = ftfont_variation_glyphs, +#endif + .filter_properties = ftfont_filter_properties, + .cached_font_ok = xftfont_cached_font_ok, + .combining_capability = ftfont_combining_capability, +#ifdef HAVE_XDBE + .drop_xrender_surfaces = xftfont_drop_xrender_surfaces, #endif - .filter_properties = ftfont_filter_properties, - .cached_font_ok = xftfont_cached_font_ok, - .combining_capability = ftfont_combining_capability, - .drop_xrender_surfaces = xftfont_drop_xrender_surfaces, }; #ifdef HAVE_HARFBUZZ struct font_driver xfthbfont_driver; diff --git a/src/xmenu.c b/src/xmenu.c index d19fe13c295..aaf53569a72 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -365,16 +365,16 @@ popup_get_selection (XEvent *initial_event, struct x_display_info *dpyinfo, && event.xgeneric.display == dpyinfo->display && event.xgeneric.extension == dpyinfo->xi2_opcode) { + if (!event.xcookie.data + && XGetEventData (dpyinfo->display, &event.xcookie)) + cookie_claimed_p = true; + if (event.xcookie.data) { switch (event.xgeneric.evtype) { case XI_ButtonRelease: { - if (!event.xcookie.data - && XGetEventData (dpyinfo->display, &event.xcookie)) - cookie_claimed_p = true; - xev = (XIDeviceEvent *) event.xcookie.data; device = xi_device_from_id (dpyinfo, xev->deviceid); @@ -424,10 +424,6 @@ popup_get_selection (XEvent *initial_event, struct x_display_info *dpyinfo, { KeySym keysym; - if (!event.xcookie.data - && XGetEventData (dpyinfo->display, &event.xcookie)) - cookie_claimed_p = true; - xev = (XIDeviceEvent *) event.xcookie.data; copy.xkey.type = KeyPress; @@ -473,6 +469,9 @@ DEFUN ("x-menu-bar-open-internal", Fx_menu_bar_open_internal, Sx_menu_bar_open_i { XEvent ev; struct frame *f = decode_window_system_frame (frame); +#if defined USE_X_TOOLKIT && defined HAVE_XINPUT2 + struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); +#endif Widget menubar; block_input (); @@ -485,12 +484,44 @@ DEFUN ("x-menu-bar-open-internal", Fx_menu_bar_open_internal, Sx_menu_bar_open_i Window child; bool error_p = false; +#if defined USE_X_TOOLKIT && defined HAVE_XINPUT2 + /* Clear the XI2 grab so Motif or lwlib can set a core grab. + Otherwise some versions of Motif will emit a warning and hang, + and lwlib will fail to destroy the menu window. */ + + if (dpyinfo->supports_xi2 + && xi_frame_selected_for (f, XI_ButtonPress)) + { + for (int i = 0; i < dpyinfo->num_devices; ++i) + { + /* The keyboard grab matters too, in this specific + case. */ +#ifndef USE_LUCID + if (dpyinfo->devices[i].grab) +#endif + { + XIUngrabDevice (dpyinfo->display, + dpyinfo->devices[i].device_id, + CurrentTime); + dpyinfo->devices[i].grab = 0; + } + } + } +#endif + x_catch_errors (FRAME_X_DISPLAY (f)); memset (&ev, 0, sizeof ev); ev.xbutton.display = FRAME_X_DISPLAY (f); ev.xbutton.window = XtWindow (menubar); ev.xbutton.root = FRAME_DISPLAY_INFO (f)->root_window; +#ifndef HAVE_XINPUT2 ev.xbutton.time = XtLastTimestampProcessed (FRAME_X_DISPLAY (f)); +#else + ev.xbutton.time = ((dpyinfo->supports_xi2 + && xi_frame_selected_for (f, XI_KeyPress)) + ? dpyinfo->last_user_time + : XtLastTimestampProcessed (dpyinfo->display)); +#endif ev.xbutton.button = Button1; ev.xbutton.x = ev.xbutton.y = FRAME_MENUBAR_HEIGHT (f) / 2; ev.xbutton.same_screen = True; @@ -634,19 +665,22 @@ x_activate_menubar (struct frame *f) Otherwise some versions of Motif will emit a warning and hang, and lwlib will fail to destroy the menu window. */ - if (dpyinfo->num_devices) + if (dpyinfo->supports_xi2 + && xi_frame_selected_for (f, XI_ButtonPress)) { for (int i = 0; i < dpyinfo->num_devices; ++i) { if (dpyinfo->devices[i].grab) - { - XIUngrabDevice (dpyinfo->display, dpyinfo->devices[i].device_id, - CurrentTime); - } + XIUngrabDevice (dpyinfo->display, + dpyinfo->devices[i].device_id, + CurrentTime); } } #endif - XtDispatchEvent (f->output_data.x->saved_menu_event); + /* The cascade button might have been deleted, so don't activate the + popup if it no widget was found to dispatch to. */ + popup_activated_flag + = XtDispatchEvent (f->output_data.x->saved_menu_event); #endif unblock_input (); @@ -1528,7 +1562,8 @@ create_and_show_popup_menu (struct frame *f, widget_value *first_wv, } #if !defined HAVE_GTK3 && defined HAVE_XINPUT2 - if (FRAME_DISPLAY_INFO (f)->num_devices) + if (FRAME_DISPLAY_INFO (f)->supports_xi2 + && xi_frame_selected_for (f, XI_ButtonPress)) { for (int i = 0; i < FRAME_DISPLAY_INFO (f)->num_devices; ++i) { @@ -1586,6 +1621,84 @@ popup_selection_callback (Widget widget, LWLIB_ID id, XtPointer client_data) menu_item_selection = client_data; } + +#ifdef HAVE_XINPUT2 +static void +prepare_for_entry_into_toolkit_menu (struct frame *f) +{ + XIEventMask mask; + ptrdiff_t l = XIMaskLen (XI_LASTEVENT); + unsigned char *m; + Lisp_Object tail, frame; + struct x_display_info *dpyinfo; + + dpyinfo = FRAME_DISPLAY_INFO (f); + + if (!dpyinfo->supports_xi2) + return; + + mask.mask = m = alloca (l); + memset (m, 0, l); + mask.mask_len = l; + + mask.deviceid = XIAllMasterDevices; + + XISetMask (m, XI_Motion); + XISetMask (m, XI_Enter); + XISetMask (m, XI_Leave); + + FOR_EACH_FRAME (tail, frame) + { + f = XFRAME (frame); + + if (FRAME_X_P (f) + && FRAME_DISPLAY_INFO (f) == dpyinfo + && !FRAME_TOOLTIP_P (f)) + XISelectEvents (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + &mask, 1); + } +} + +static void +leave_toolkit_menu (void *data) +{ + XIEventMask mask; + ptrdiff_t l = XIMaskLen (XI_LASTEVENT); + unsigned char *m; + Lisp_Object tail, frame; + struct x_display_info *dpyinfo; + struct frame *f; + + dpyinfo = FRAME_DISPLAY_INFO ((struct frame *) data); + + if (!dpyinfo->supports_xi2) + return; + + mask.mask = m = alloca (l); + memset (m, 0, l); + mask.mask_len = l; + + mask.deviceid = XIAllMasterDevices; + + XISetMask (m, XI_ButtonPress); + XISetMask (m, XI_ButtonRelease); + XISetMask (m, XI_Motion); + XISetMask (m, XI_Enter); + XISetMask (m, XI_Leave); + + FOR_EACH_FRAME (tail, frame) + { + f = XFRAME (frame); + + if (FRAME_X_P (f) + && FRAME_DISPLAY_INFO (f) == dpyinfo + && !FRAME_TOOLTIP_P (f)) + XISelectEvents (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + &mask, 1); + } +} +#endif + /* ID is the LWLIB ID of the dialog box. */ static void @@ -1686,23 +1799,21 @@ create_and_show_popup_menu (struct frame *f, widget_value *first_wv, XtSetArg (av[ac], (char *) XtNgeometry, 0); ac++; XtSetValues (menu, av, ac); -#if defined HAVE_XINPUT2 +#ifdef HAVE_XINPUT2 struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); - bool any_xi_grab_p = false; /* Clear the XI2 grab, and if any XI2 grab was set, place a core grab on the frame's edit widget. */ - if (dpyinfo->supports_xi2) XGrabServer (dpyinfo->display); - if (dpyinfo->num_devices) + if (dpyinfo->supports_xi2 + && xi_frame_selected_for (f, XI_ButtonPress)) { for (int i = 0; i < dpyinfo->num_devices; ++i) { if (dpyinfo->devices[i].grab) { - any_xi_grab_p = true; dpyinfo->devices[i].grab = 0; XIUngrabDevice (dpyinfo->display, @@ -1712,20 +1823,6 @@ create_and_show_popup_menu (struct frame *f, widget_value *first_wv, } } - if (any_xi_grab_p) - { -#ifndef USE_MOTIF - XGrabPointer (dpyinfo->display, - FRAME_X_WINDOW (f), - False, (PointerMotionMask - | PointerMotionHintMask - | ButtonReleaseMask - | ButtonPressMask), - GrabModeSync, GrabModeAsync, - None, None, CurrentTime); -#endif - } - #ifdef USE_MOTIF if (dpyinfo->supports_xi2) { @@ -1746,49 +1843,41 @@ create_and_show_popup_menu (struct frame *f, widget_value *first_wv, XtDispatchEvent (&property_dummy); } #endif +#endif +#ifdef HAVE_XINPUT2 + prepare_for_entry_into_toolkit_menu (f); + +#ifdef USE_LUCID + if (dpyinfo->supports_xi2) + x_mouse_leave (dpyinfo); +#endif +#endif + /* Display the menu. */ + lw_popup_menu (menu, &dummy); + +#ifdef HAVE_XINPUT2 if (dpyinfo->supports_xi2) XUngrabServer (dpyinfo->display); #endif - /* Display the menu. */ - lw_popup_menu (menu, &dummy); - -#if defined HAVE_XINPUT2 && defined USE_MOTIF - /* This is needed to prevent XI_Enter events that set an implicit - focus from being sent. */ - if (dpyinfo->supports_xi2) - XSetInputFocus (XtDisplay (menu), XtWindow (menu), - RevertToParent, CurrentTime); -#endif - popup_activated_flag = 1; -#if defined HAVE_XINPUT2 && !defined USE_MOTIF - if (any_xi_grab_p) - XAllowEvents (dpyinfo->display, AsyncPointer, CurrentTime); -#endif - x_activate_timeout_atimer (); { specpdl_ref specpdl_count = SPECPDL_INDEX (); record_unwind_protect_int (pop_down_menu, (int) menu_id); +#ifdef HAVE_XINPUT2 + record_unwind_protect_ptr (leave_toolkit_menu, f); +#endif /* Process events that apply to the menu. */ popup_get_selection (0, FRAME_DISPLAY_INFO (f), menu_id, true); unbind_to (specpdl_count, Qnil); } - -#if defined HAVE_XINPUT2 && defined USE_MOTIF - /* For some reason input focus isn't always restored to the outer - window after the menu pops down. */ - if (any_xi_grab_p) - XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), - RevertToParent, CurrentTime); -#endif } #endif /* not USE_GTK */ @@ -2677,7 +2766,8 @@ x_menu_show (struct frame *f, int x, int y, int menuflags, struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); /* Clear the XI2 grab so a core grab can be set. */ - if (dpyinfo->num_devices) + if (dpyinfo->supports_xi2 + && xi_frame_selected_for (f, XI_ButtonPress)) { for (int i = 0; i < dpyinfo->num_devices; ++i) { diff --git a/src/xrdb.c b/src/xrdb.c index 56e07f74a26..aa79d719c8c 100644 --- a/src/xrdb.c +++ b/src/xrdb.c @@ -383,14 +383,6 @@ x_load_resources (Display *display, const char *xrm_string, XrmDatabase db; char line[256]; -#if defined USE_MOTIF || !(defined USE_CAIRO || defined HAVE_XFT) || !defined USE_LUCID - const char *helv = "-*-helvetica-medium-r-*--*-120-*-*-*-*-iso8859-1"; -#endif - -#ifdef USE_MOTIF - const char *courier = "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-1"; -#endif - x_rm_string = XrmStringToQuark (XrmStringType); #ifndef USE_X_TOOLKIT /* pmr@osf.org says this shouldn't be done if USE_X_TOOLKIT. @@ -399,47 +391,7 @@ x_load_resources (Display *display, const char *xrm_string, #endif rdb = XrmGetStringDatabase (""); - /* Add some font defaults. If the font `helv' doesn't exist, widgets - will use some other default font. */ #ifdef USE_MOTIF - - sprintf (line, "%s.pane.background: grey75", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*fontList: %s", myclass, helv); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*menu*background: grey75", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*menubar*background: grey75", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*verticalScrollBar.background: grey75", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*verticalScrollBar.troughColor: grey75", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*horizontalScrollBar.background: grey75", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*horizontalScrollBar.troughColor: grey75", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s.dialog*.background: grey75", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*fsb.Text.background: white", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*fsb.FilterText.background: white", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*fsb*DirList.background: white", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*fsb*ItemsList.background: white", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*fsb*background: grey75", myclass); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*fsb.Text.fontList: %s", myclass, courier); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*fsb.FilterText.fontList: %s", myclass, courier); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*fsb*ItemsList.fontList: %s", myclass, courier); - XrmPutLineResource (&rdb, line); - sprintf (line, "%s*fsb*DirList.fontList: %s", myclass, courier); - XrmPutLineResource (&rdb, line); - /* Set double click time of list boxes in the file selection dialog from `double-click-time'. */ if (FIXNUMP (Vdouble_click_time) && XFIXNUM (Vdouble_click_time) > 0) @@ -451,15 +403,17 @@ x_load_resources (Display *display, const char *xrm_string, myclass, XFIXNAT (Vdouble_click_time)); XrmPutLineResource (&rdb, line); } - #else /* not USE_MOTIF */ - + /* Add some font defaults. If the font `helv' doesn't exist, + widgets will use some other default font. */ sprintf (line, "Emacs.dialog*.background: grey75"); XrmPutLineResource (&rdb, line); #if !(defined USE_CAIRO || defined HAVE_XFT) || !defined (USE_LUCID) - sprintf (line, "Emacs.dialog*.font: %s", helv); + sprintf (line, "Emacs.dialog*.font: %s", + "-*-helvetica-medium-r-*--*-120-*-*-*-*-iso8859-1"); XrmPutLineResource (&rdb, line); - sprintf (line, "*XlwMenu*font: %s", helv); + sprintf (line, "*XlwMenu*font: %s", + "-*-helvetica-medium-r-*--*-120-*-*-*-*-iso8859-1"); XrmPutLineResource (&rdb, line); #endif sprintf (line, "*XlwMenu*background: grey75"); @@ -468,7 +422,6 @@ x_load_resources (Display *display, const char *xrm_string, XrmPutLineResource (&rdb, line); sprintf (line, "Emacs*horizontalScrollBar.background: grey75"); XrmPutLineResource (&rdb, line); - #endif /* not USE_MOTIF */ user_database = get_user_db (display); diff --git a/src/xselect.c b/src/xselect.c index a88c15aa95b..3acfcbe94b0 100644 --- a/src/xselect.c +++ b/src/xselect.c @@ -39,6 +39,8 @@ along with GNU Emacs. If not, see . */ #include +static Time pending_dnd_time; + struct prop_location; struct selection_data; @@ -58,6 +60,8 @@ static Lisp_Object selection_data_to_lisp_data (struct x_display_info *, ptrdiff_t, Atom, int); static void lisp_data_to_selection_data (struct x_display_info *, Lisp_Object, struct selection_data *); +static void x_send_client_event (Lisp_Object, Lisp_Object, Lisp_Object, + Atom, Lisp_Object, Lisp_Object); /* Printing traces to stderr. */ @@ -206,24 +210,49 @@ static Atom symbol_to_x_atom (struct x_display_info *dpyinfo, Lisp_Object sym) { Atom val; - if (NILP (sym)) return 0; - if (EQ (sym, QPRIMARY)) return XA_PRIMARY; - if (EQ (sym, QSECONDARY)) return XA_SECONDARY; - if (EQ (sym, QSTRING)) return XA_STRING; - if (EQ (sym, QINTEGER)) return XA_INTEGER; - if (EQ (sym, QATOM)) return XA_ATOM; - if (EQ (sym, QCLIPBOARD)) return dpyinfo->Xatom_CLIPBOARD; - if (EQ (sym, QTIMESTAMP)) return dpyinfo->Xatom_TIMESTAMP; - if (EQ (sym, QTEXT)) return dpyinfo->Xatom_TEXT; - if (EQ (sym, QCOMPOUND_TEXT)) return dpyinfo->Xatom_COMPOUND_TEXT; - if (EQ (sym, QUTF8_STRING)) return dpyinfo->Xatom_UTF8_STRING; - if (EQ (sym, QDELETE)) return dpyinfo->Xatom_DELETE; - if (EQ (sym, QMULTIPLE)) return dpyinfo->Xatom_MULTIPLE; - if (EQ (sym, QINCR)) return dpyinfo->Xatom_INCR; - if (EQ (sym, Q_EMACS_TMP_)) return dpyinfo->Xatom_EMACS_TMP; - if (EQ (sym, QTARGETS)) return dpyinfo->Xatom_TARGETS; - if (EQ (sym, QNULL)) return dpyinfo->Xatom_NULL; - if (!SYMBOLP (sym)) emacs_abort (); + if (NILP (sym)) + return 0; + if (EQ (sym, QPRIMARY)) + return XA_PRIMARY; + if (EQ (sym, QSECONDARY)) + return XA_SECONDARY; + if (EQ (sym, QSTRING)) + return XA_STRING; + if (EQ (sym, QINTEGER)) + return XA_INTEGER; + if (EQ (sym, QATOM)) + return XA_ATOM; + if (EQ (sym, QCLIPBOARD)) + return dpyinfo->Xatom_CLIPBOARD; + if (EQ (sym, QTIMESTAMP)) + return dpyinfo->Xatom_TIMESTAMP; + if (EQ (sym, QTEXT)) + return dpyinfo->Xatom_TEXT; + if (EQ (sym, QCOMPOUND_TEXT)) + return dpyinfo->Xatom_COMPOUND_TEXT; + if (EQ (sym, QUTF8_STRING)) + return dpyinfo->Xatom_UTF8_STRING; + if (EQ (sym, QDELETE)) + return dpyinfo->Xatom_DELETE; + if (EQ (sym, QMULTIPLE)) + return dpyinfo->Xatom_MULTIPLE; + if (EQ (sym, QINCR)) + return dpyinfo->Xatom_INCR; + if (EQ (sym, Q_EMACS_TMP_)) + return dpyinfo->Xatom_EMACS_TMP; + if (EQ (sym, QTARGETS)) + return dpyinfo->Xatom_TARGETS; + if (EQ (sym, QNULL)) + return dpyinfo->Xatom_NULL; + if (EQ (sym, QXdndSelection)) + return dpyinfo->Xatom_XdndSelection; + if (EQ (sym, QXmTRANSFER_SUCCESS)) + return dpyinfo->Xatom_XmTRANSFER_SUCCESS; + if (EQ (sym, QXmTRANSFER_FAILURE)) + return dpyinfo->Xatom_XmTRANSFER_FAILURE; + + if (!SYMBOLP (sym)) + emacs_abort (); TRACE1 (" XInternAtom %s", SSDATA (SYMBOL_NAME (sym))); block_input (); @@ -283,9 +312,17 @@ x_atom_to_symbol (struct x_display_info *dpyinfo, Atom atom) return QTARGETS; if (atom == dpyinfo->Xatom_NULL) return QNULL; + if (atom == dpyinfo->Xatom_XdndSelection) + return QXdndSelection; + if (atom == dpyinfo->Xatom_XmTRANSFER_SUCCESS) + return QXmTRANSFER_SUCCESS; + if (atom == dpyinfo->Xatom_XmTRANSFER_FAILURE) + return QXmTRANSFER_FAILURE; block_input (); + x_catch_errors (dpyinfo->display); str = XGetAtomName (dpyinfo->display, atom); + x_uncatch_errors (); unblock_input (); TRACE1 ("XGetAtomName --> %s", str); if (! str) return Qnil; @@ -302,7 +339,7 @@ x_atom_to_symbol (struct x_display_info *dpyinfo, Atom atom) Update the Vselection_alist so that we can reply to later requests for our selection. */ -static void +void x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value, Lisp_Object frame) { @@ -386,6 +423,9 @@ x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type, CHECK_SYMBOL (target_type); handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist)); + if (CONSP (handler_fn)) + handler_fn = XCDR (handler_fn); + if (!NILP (handler_fn)) value = call3 (handler_fn, selection_symbol, (local_request ? Qnil : target_type), @@ -766,6 +806,12 @@ x_handle_selection_request (struct selection_input_event *event) if (!dpyinfo) goto DONE; + /* This is how the XDND protocol recommends dropping text onto a + target that doesn't support XDND. */ + if (SELECTION_EVENT_TIME (event) == pending_dnd_time + 1 + || SELECTION_EVENT_TIME (event) == pending_dnd_time + 2) + selection_symbol = QXdndSelection; + local_selection_data = LOCAL_SELECTION (selection_symbol, dpyinfo); /* Decline if we don't own any selections. */ @@ -2568,7 +2614,7 @@ are ignored. */) return Qnil; } -void +static void x_send_client_event (Lisp_Object display, Lisp_Object dest, Lisp_Object from, Atom message_type, Lisp_Object format, Lisp_Object values) { @@ -2647,6 +2693,31 @@ x_send_client_event (Lisp_Object display, Lisp_Object dest, Lisp_Object from, +/* Return the timestamp where ownership of SELECTION was asserted, or + nil if no local selection is present. */ + +Lisp_Object +x_timestamp_for_selection (struct x_display_info *dpyinfo, + Lisp_Object selection) +{ + Lisp_Object value, local_value; + + local_value = LOCAL_SELECTION (selection, dpyinfo); + + if (NILP (local_value)) + return Qnil; + + value = XCAR (XCDR (XCDR (local_value))); + + return value; +} + +void +x_set_pending_dnd_time (Time time) +{ + pending_dnd_time = time; +} + static void syms_of_xselect_for_pdumper (void); void @@ -2671,11 +2742,18 @@ syms_of_xselect (void) DEFVAR_LISP ("selection-converter-alist", Vselection_converter_alist, doc: /* An alist associating X Windows selection-types with functions. These functions are called to convert the selection, with three args: -the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD'); -a desired type to which the selection should be converted; -and the local selection value (whatever was given to +the name of the selection (typically `PRIMARY', `SECONDARY', or +`CLIPBOARD'); a desired type to which the selection should be +converted; and the local selection value (whatever was given to `x-own-selection-internal'). +On X Windows, the function can also be a cons of (PREDICATE +. FUNCTION), where PREDICATE determines whether or not the selection +type will appear in the list of selection types available to other +programs, and FUNCTION is the function which is actually called. +PREDICATE is called with the same arguments as FUNCTION, and should +return a non-nil value if the data type is to appear in that list. + The function should return the value to send to the X server \(typically a string). A return value of nil means that the conversion could not be done. @@ -2746,6 +2824,9 @@ A value of 0 means wait as long as necessary. This is initialized from the DEFSYM (Qx_lost_selection_functions, "x-lost-selection-functions"); DEFSYM (Qx_sent_selection_functions, "x-sent-selection-functions"); + DEFSYM (QXmTRANSFER_SUCCESS, "XmTRANSFER_SUCCESS"); + DEFSYM (QXmTRANSFER_FAILURE, "XmTRANSFER_FAILURE"); + pdumper_do_now_and_after_load (syms_of_xselect_for_pdumper); } diff --git a/src/xsmfns.c b/src/xsmfns.c index 199e3ded3dd..7015a8eb633 100644 --- a/src/xsmfns.c +++ b/src/xsmfns.c @@ -522,7 +522,7 @@ Do not call this function yourself. */) { /* We should not do user interaction here, but it is not easy to prevent. Fix this in next version. */ - Fkill_emacs (Qnil); + Fkill_emacs (Qnil, Qnil); #if false /* This will not be reached, but we want kill-emacs-hook to be run. */ diff --git a/src/xterm.c b/src/xterm.c index 5b1e1023799..2141964c747 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -142,14 +142,22 @@ along with GNU Emacs. If not, see . */ draw text in inverse video, and the cursor graphics context is used to display the cursor in the most common case. + N.B. that some of the other window systems supported by use an + emulation of graphics contexts to hold the foreground and + background colors used in a glyph string, while the some others + ports compute those colors directly based on the colors of the + string's face and its highlight, but only on X are graphics + contexts a data structure inherent to the window system. + COLOR ALLOCATION - In X, pixel values for colors are not guaranteed to correspond to - their individual components. The rules for converting colors into - pixel values are defined by the visual class of each display opened - by Emacs. When a display is opened, a suitable visual is obtained - from the X server, and a colormap is created based on that visual, - which is then used for each frame created. + In (and only in) X, pixel values for colors are not guaranteed to + correspond to their individual components. The rules for + converting colors into pixel values are defined by the visual class + of each display opened by Emacs. When a display is opened, a + suitable visual is obtained from the X server, and a colormap is + created based on that visual, which is then used for each frame + created. The colormap is then used by the X server to convert pixel values from a frame created by Emacs into actual colors which are output @@ -202,6 +210,10 @@ along with GNU Emacs. If not, see . */ which is used to determine the color values for given pixel values. + In other window systems supported by Emacs, color allocation is + handled by the window system itself, to whom Emacs simply passes 24 + (or 32-bit) RGB values. + OPTIONAL FEATURES While X servers and client libraries tend to come with many @@ -496,7 +508,44 @@ along with GNU Emacs. If not, see . */ compositing manager that the contents of the window now accurately reflect the new size. The compositing manager will then display the contents of the window, and the window manager might also postpone - updating the window decorations until this moment. */ + updating the window decorations until this moment. + + DRAG AND DROP + + Drag and drop in Emacs is implemented in two ways, depending on + which side initiated the drag-and-drop operation. When another X + client initiates a drag, and the user drops something on Emacs, a + `drag-n-drop-event' is sent with the contents of the ClientMessage, + and further processing (i.e. retrieving selection contents and + replying to the initiating client) is performed from Lisp inside + `x-dnd.el'. + + However, dragging contents from Emacs is implemented entirely in C. + X Windows has several competing drag-and-drop protocols, of which + Emacs supports two: the XDND protocol (see + https://freedesktop.org/wiki/Specifications/XDND) and the Motif drag + and drop protocols. These protocols are based on the initiator + owning a special selection, specifying an action the recipient + should perform, grabbing the mouse, and sending various different + client messages to the toplevel window underneath the mouse as it + moves, or when buttons are released. + + The Lisp interface to drag-and-drop is synchronous, and involves + running a nested event loop with some global state until the drag + finishes. When the mouse moves, Emacs looks up the toplevel window + underneath the pointer (the target window) either using a cache + provided by window managers that support the + _NET_WM_CLIENT_LIST_STACKING root window property, or by calling + XTranslateCoordinates in a loop until a toplevel window is found, + and sends various entry, exit, or motion events to the window + containing a list of targets the special selection can be converted + to, and the chosen action that the recipient should perform. The + recipient can then send messages in reply detailing the action it + has actually chosen to perform. Finally, when the mouse buttons are + released over the recipient window, Emacs sends a "drop" message to + the target window, waits for a reply, and returns the action + selected by the recipient to the Lisp code that initiated the + drag-and-drop operation. */ #include #include @@ -542,6 +591,18 @@ along with GNU Emacs. If not, see . */ #include #endif +#ifdef HAVE_XCOMPOSITE +#include +#endif + +#ifdef HAVE_XSHAPE +#include +#endif + +#ifdef HAVE_XCB_SHAPE +#include +#endif + /* Load sys/types.h if not already loaded. In some systems loading it twice is suicidal. */ #ifndef makedev @@ -555,6 +616,10 @@ along with GNU Emacs. If not, see . */ #include #include #include +#include +#include +#include + #include "character.h" #include "coding.h" #include "composite.h" @@ -578,6 +643,7 @@ along with GNU Emacs. If not, see . */ #ifdef USE_X_TOOLKIT #include +#include #endif #include @@ -599,6 +665,7 @@ along with GNU Emacs. If not, see . */ #ifdef USE_MOTIF #include +#include #endif #ifdef USE_X_TOOLKIT @@ -649,6 +716,12 @@ bool use_xim = true; bool use_xim = false; /* configure --without-xim */ #endif +#if XCB_SHAPE_MAJOR_VERSION > 1 \ + || (XCB_SHAPE_MAJOR_VERSION == 1 && \ + XCB_SHAPE_MINOR_VERSION >= 1) +#define HAVE_XCB_SHAPE_INPUT_RECTS +#endif + #ifdef USE_GTK /* GTK can't tolerate a call to `handle_interrupt' inside an event signal handler, but we have to store input events inside the @@ -687,6 +760,10 @@ static bool toolkit_scroll_bar_interaction; static Time ignore_next_mouse_click_timeout; +/* The display that ignore_next_mouse_click_timeout applies to. */ + +static struct x_display_info *mouse_click_timeout_display; + /* Used locally within XTread_socket. */ static int x_noop_count; @@ -701,6 +778,19 @@ static Lisp_Object xg_default_icon_file; static char emacs_class[] = EMACS_CLASS; #endif +#ifdef USE_GTK +static int current_count; +static int current_finish; +static struct input_event *current_hold_quit; +#endif + +enum +{ + X_EVENT_NORMAL, + X_EVENT_GOTO_OUT, + X_EVENT_DROP +}; + enum xembed_info { XEMBED_MAPPED = 1 << 0 @@ -769,6 +859,2920 @@ static void x_update_opaque_region (struct frame *, XEvent *); static void x_scroll_bar_end_update (struct x_display_info *, struct scroll_bar *); #endif +#ifdef HAVE_X_I18N +static int x_filter_event (struct x_display_info *, XEvent *); +#endif + +/* Global state maintained during a drag-and-drop operation. */ + +/* Flag that indicates if a drag-and-drop operation is in progress. */ +bool x_dnd_in_progress; + +/* The frame where the drag-and-drop operation originated. */ +struct frame *x_dnd_frame; + +/* Flag that indicates if a drag-and-drop operation is no longer in + progress, but the nested event loop should continue to run, because + handle_one_xevent is waiting for the drop target to return some + important information. */ +static bool x_dnd_waiting_for_finish; + +/* The display the drop target that is supposed to send information is + on. */ +static Display *x_dnd_finish_display; + +/* State of the Motif drop operation. + + 0 means nothing has happened, i.e. the event loop should not wait + for the receiver to send any data. 1 means an XmDROP_START message + was sent to the target, but no response has yet been received. 2 + means a response to our XmDROP_START message was received and the + target accepted the drop, so Emacs should start waiting for the + drop target to convert one of the special selections + XmTRANSFER_SUCCESS or XmTRANSFER_FAILURE. */ +static int x_dnd_waiting_for_motif_finish; + +/* The display the Motif drag receiver will send response data + from. */ +struct x_display_info *x_dnd_waiting_for_motif_finish_display; + +/* Whether or not F1 was pressed during the drag-and-drop operation. + + Motif programs rely on this to decide whether or not help + information about the drop site should be displayed. */ +static bool x_dnd_xm_use_help; + +/* Whether or not Motif drag initiator info was set up. */ +static bool x_dnd_motif_setup_p; + +/* The target window we are waiting for an XdndFinished message + from. */ +static Window x_dnd_pending_finish_target; + +/* The protocol version of that target window. */ +static int x_dnd_waiting_for_finish_proto; + +/* Whether or not it is OK for something to be dropped on the frame + where the drag-and-drop operation originated. */ +static bool x_dnd_allow_current_frame; + +/* Whether or not to return a frame from `x_dnd_begin_drag_and_drop'. + + 0 means to do nothing. 1 means to wait for the mouse to first exit + `x_dnd_frame'. 2 means to wait for the mouse to move onto a frame, + and 3 means to return `x_dnd_return_frame_object'. */ +static int x_dnd_return_frame; + +/* The frame that should be returned by + `x_dnd_begin_drag_and_drop'. */ +static struct frame *x_dnd_return_frame_object; + +/* The last drop target window the mouse pointer moved over. This can + be different from `x_dnd_last_seen_toplevel' if that window had an + XdndProxy. */ +static Window x_dnd_last_seen_window; + +/* The last toplevel the mouse pointer moved over. */ +static Window x_dnd_last_seen_toplevel; + +/* The window where the drop happened. Normally None, but it is set + when something is actually dropped. */ +static Window x_dnd_end_window; + +/* The XDND protocol version of `x_dnd_last_seen_window'. -1 means it + did not support XDND. */ +static int x_dnd_last_protocol_version; + +/* The Motif drag and drop protocol style of `x_dnd_last_seen_window'. + XM_DRAG_STYLE_NONE means the window does not support the Motif drag + or drop protocol. XM_DRAG_STYLE_DROP_ONLY means the window does + not respond to any drag protocol messages, so only drops should be + sent. Any other value means that the window supports both the drag + and drop protocols. */ +static int x_dnd_last_motif_style; + +/* The timestamp where Emacs last acquired ownership of the + `XdndSelection' selection. */ +static Time x_dnd_selection_timestamp; + +/* The drop target window to which the rectangle below applies. */ +static Window x_dnd_mouse_rect_target; + +/* A rectangle where XDND position messages should not be sent to the + drop target if the mouse pointer lies within. */ +static XRectangle x_dnd_mouse_rect; + +/* The action the drop target actually chose to perform. + + Under XDND, this is set upon receiving the XdndFinished or + XdndStatus messages from the drop target. + + Under Motif, this is changed upon receiving a XmDROP_START message + in reply to our own. + + When dropping on a target that doesn't support any drag-and-drop + protocol, this is set to the atom XdndActionPrivate. */ +static Atom x_dnd_action; + +/* The action we want the drop target to perform. The drop target may + elect to perform some different action, which is guaranteed to be + in `x_dnd_action' upon completion of a drop. */ +static Atom x_dnd_wanted_action; + +/* Array of selection targets available to the drop target. */ +static Atom *x_dnd_targets = NULL; + +/* The number of elements in that array. */ +static int x_dnd_n_targets; + +/* The old window attributes of the root window before the + drag-and-drop operation started. It is used to keep the old event + mask around, since that should be restored after the operation + finishes. */ +static XWindowAttributes x_dnd_old_window_attrs; + +/* Whether or not `x_dnd_cleaup_drag_and_drop' should actually clean + up the drag and drop operation. */ +static bool x_dnd_unwind_flag; + +/* The frame for which `x-dnd-movement-function' should be called. */ +static struct frame *x_dnd_movement_frame; + +/* The coordinates which the movement function should be called + with. */ +static int x_dnd_movement_x, x_dnd_movement_y; + +#ifdef HAVE_XKB +/* The keyboard state during the drag-and-drop operation. */ +static unsigned int x_dnd_keyboard_state; +#endif + +/* jmp_buf that gets us out of the IO error handler if an error occurs + terminating DND as part of the display disconnect handler. */ +static jmp_buf x_dnd_disconnect_handler; + +struct x_client_list_window +{ + Window window; + Display *dpy; + int x, y; + int width, height; + bool mapped_p; + long previous_event_mask; + unsigned long wm_state; + + struct x_client_list_window *next; + uint8_t xm_protocol_style; + + int frame_extents_left; + int frame_extents_right; + int frame_extents_top; + int frame_extents_bottom; + +#ifdef HAVE_XSHAPE + int border_width; + + XRectangle *input_rects; + int n_input_rects; + + XRectangle *bounding_rects; + int n_bounding_rects; +#endif +}; + +static struct x_client_list_window *x_dnd_toplevels = NULL; +static bool x_dnd_use_toplevels; + +/* Motif drag-and-drop protocol support. */ + +typedef enum xm_byte_order + { + XM_BYTE_ORDER_LSB_FIRST = 'l', + XM_BYTE_ORDER_MSB_FIRST = 'B', +#ifndef WORDS_BIGENDIAN + XM_BYTE_ORDER_CUR_FIRST = 'l', +#else + XM_BYTE_ORDER_CUR_FIRST = 'B', +#endif + } xm_byte_order; + +#ifdef ENABLE_CHECKING + +#define SWAPCARD32(l) \ + { \ + struct { unsigned t : 32; } bit32; \ + char n, *tp = (char *) &bit32; \ + bit32.t = l; \ + n = tp[0]; tp[0] = tp[3]; tp[3] = n; \ + n = tp[1]; tp[1] = tp[2]; tp[2] = n; \ + l = bit32.t; \ + } + +#define SWAPCARD16(s) \ + { \ + struct { unsigned t : 16; } bit16; \ + char n, *tp = (char *) &bit16; \ + bit16.t = s; \ + n = tp[0]; tp[0] = tp[1]; tp[1] = n; \ + s = bit16.t; \ + } + +#else +#define SWAPCARD32(l) bswap_32 (l) +#define SWAPCARD16(l) bswap_16 (l) +#endif + +typedef struct xm_targets_table_header +{ + /* BYTE */ uint8_t byte_order; + /* BYTE */ uint8_t protocol; + + /* CARD16 */ uint16_t target_list_count; + /* CARD32 */ uint32_t total_data_size; +} xm_targets_table_header; + +typedef struct xm_targets_table_rec +{ + /* CARD16 */ uint16_t n_targets; + /* CARD32 */ uint32_t targets[FLEXIBLE_ARRAY_MEMBER]; +} xm_targets_table_rec; + +typedef struct xm_drop_start_message +{ + /* BYTE */ uint8_t reason; + /* BYTE */ uint8_t byte_order; + + /* CARD16 */ uint16_t side_effects; + /* CARD32 */ uint32_t timestamp; + /* CARD16 */ uint16_t x, y; + /* CARD32 */ uint32_t index_atom; + /* CARD32 */ uint32_t source_window; +} xm_drop_start_message; + +typedef struct xm_drop_start_reply +{ + /* BYTE */ uint8_t reason; + /* BYTE */ uint8_t byte_order; + + /* CARD16 */ uint16_t side_effects; + /* CARD16 */ uint16_t better_x; + /* CARD16 */ uint16_t better_y; +} xm_drop_start_reply; + +typedef struct xm_drag_initiator_info +{ + /* BYTE */ uint8_t byteorder; + /* BYTE */ uint8_t protocol; + + /* CARD16 */ uint16_t table_index; + /* CARD32 */ uint32_t selection; +} xm_drag_initiator_info; + +typedef struct xm_drag_receiver_info +{ + /* BYTE */ uint8_t byteorder; + /* BYTE */ uint8_t protocol; + + /* BYTE */ uint8_t protocol_style; + /* BYTE */ uint8_t unspecified0; + /* CARD32 */ uint32_t unspecified1; + /* CARD32 */ uint32_t unspecified2; + /* CARD32 */ uint32_t unspecified3; +} xm_drag_receiver_info; + +typedef struct xm_top_level_enter_message +{ + /* BYTE */ uint8_t reason; + /* BYTE */ uint8_t byteorder; + + /* CARD16 */ uint16_t zero; + /* CARD32 */ uint32_t timestamp; + /* CARD32 */ uint32_t source_window; + /* CARD32 */ uint32_t index_atom; +} xm_top_level_enter_message; + +typedef struct xm_drag_motion_message +{ + /* BYTE */ uint8_t reason; + /* BYTE */ uint8_t byteorder; + + /* CARD16 */ uint16_t side_effects; + /* CARD32 */ uint32_t timestamp; + /* CARD16 */ uint16_t x, y; +} xm_drag_motion_message; + +typedef struct xm_top_level_leave_message +{ + /* BYTE */ uint8_t reason; + /* BYTE */ uint8_t byteorder; + + /* CARD16 */ uint16_t zero; + /* CARD32 */ uint32_t timestamp; + /* CARD32 */ uint32_t source_window; +} xm_top_level_leave_message; + +#define XM_DRAG_SIDE_EFFECT(op, site, ops, act) \ + ((op) | ((site) << 4) | ((ops) << 8) | ((act) << 12)) + +/* Some of the macros below are temporarily unused. */ + +#define XM_DRAG_SIDE_EFFECT_OPERATION(effect) ((effect) & 0xf) +#define XM_DRAG_SIDE_EFFECT_SITE_STATUS(effect) (((effect) & 0xf0) >> 4) +/* #define XM_DRAG_SIDE_EFFECT_OPERATIONS(effect) (((effect) & 0xf00) >> 8) */ +#define XM_DRAG_SIDE_EFFECT_DROP_ACTION(effect) (((effect) & 0xf000) >> 12) + +#define XM_DRAG_NOOP 0 +#define XM_DRAG_MOVE (1L << 0) +#define XM_DRAG_COPY (1L << 1) +#define XM_DRAG_LINK (1L << 2) + +#define XM_DROP_ACTION_DROP 0 +#define XM_DROP_ACTION_DROP_HELP 1 +#define XM_DROP_ACTION_DROP_CANCEL 2 + +#define XM_DRAG_REASON(originator, code) ((code) | ((originator) << 7)) +#define XM_DRAG_REASON_ORIGINATOR(reason) (((reason) & 0x80) ? 1 : 0) +#define XM_DRAG_REASON_CODE(reason) ((reason) & 0x7f) + +#define XM_DRAG_REASON_DROP_START 5 +#define XM_DRAG_REASON_TOP_LEVEL_ENTER 0 +#define XM_DRAG_REASON_TOP_LEVEL_LEAVE 1 +#define XM_DRAG_REASON_DRAG_MOTION 2 +#define XM_DRAG_ORIGINATOR_INITIATOR 0 +#define XM_DRAG_ORIGINATOR_RECEIVER 1 + +#define XM_DRAG_STYLE_NONE 0 + +#define XM_DRAG_STYLE_DROP_ONLY 1 +#define XM_DRAG_STYLE_DROP_ONLY_REC 3 + +#define XM_DRAG_STYLE_DYNAMIC 5 +#define XM_DRAG_STYLE_DYNAMIC_REC 2 +#define XM_DRAG_STYLE_DYNAMIC_REC1 4 + +#define XM_DRAG_STYLE_IS_DROP_ONLY(n) ((n) == XM_DRAG_STYLE_DROP_ONLY \ + || (n) == XM_DRAG_STYLE_DROP_ONLY_REC) +#define XM_DRAG_STYLE_IS_DYNAMIC(n) ((n) == XM_DRAG_STYLE_DYNAMIC \ + || (n) == XM_DRAG_STYLE_DYNAMIC_REC \ + || (n) == XM_DRAG_STYLE_DYNAMIC_REC1) + +#define XM_DROP_SITE_VALID 3 +/* #define XM_DROP_SITE_INVALID 2 */ +#define XM_DROP_SITE_NONE 1 + +static uint8_t +xm_side_effect_from_action (struct x_display_info *dpyinfo, Atom action) +{ + if (action == dpyinfo->Xatom_XdndActionCopy) + return XM_DRAG_COPY; + else if (action == dpyinfo->Xatom_XdndActionMove) + return XM_DRAG_MOVE; + else if (action == dpyinfo->Xatom_XdndActionLink) + return XM_DRAG_LINK; + + return XM_DRAG_NOOP; +} + +static int +xm_read_targets_table_header (uint8_t *bytes, ptrdiff_t length, + xm_targets_table_header *header_return, + xm_byte_order *byteorder_return) +{ + if (length < 8) + return -1; + + header_return->byte_order = *byteorder_return = *(bytes++); + header_return->protocol = *(bytes++); + + header_return->target_list_count = *(uint16_t *) bytes; + header_return->total_data_size = *(uint32_t *) (bytes + 2); + + if (header_return->byte_order != XM_BYTE_ORDER_CUR_FIRST) + { + SWAPCARD16 (header_return->target_list_count); + SWAPCARD32 (header_return->total_data_size); + } + + header_return->byte_order = XM_BYTE_ORDER_CUR_FIRST; + + return 8; +} + +static xm_targets_table_rec * +xm_read_targets_table_rec (uint8_t *bytes, ptrdiff_t length, + xm_byte_order byteorder) +{ + uint16_t nitems, i; + xm_targets_table_rec *rec; + + if (length < 2) + return NULL; + + nitems = *(uint16_t *) bytes; + + if (length < 2 + nitems * 4) + return NULL; + + if (byteorder != XM_BYTE_ORDER_CUR_FIRST) + SWAPCARD16 (nitems); + + rec = xmalloc (FLEXSIZEOF (struct xm_targets_table_rec, + targets, nitems * 4)); + rec->n_targets = nitems; + + for (i = 0; i < nitems; ++i) + { + rec->targets[i] = ((uint32_t *) (bytes + 2))[i]; + + if (byteorder != XM_BYTE_ORDER_CUR_FIRST) + SWAPCARD32 (rec->targets[i]); + } + + return rec; +} + +static int +xm_find_targets_table_idx (xm_targets_table_header *header, + xm_targets_table_rec **recs, + Atom *sorted_targets, int ntargets) +{ + int j; + uint16_t i; + uint32_t *targets; + + targets = alloca (sizeof *targets * ntargets); + + for (j = 0; j < ntargets; ++j) + targets[j] = sorted_targets[j]; + + for (i = 0; i < header->target_list_count; ++i) + { + if (recs[i]->n_targets == ntargets + && !memcmp (&recs[i]->targets, targets, + sizeof *targets * ntargets)) + return i; + } + + return -1; +} + +static int +x_atoms_compare (const void *a, const void *b) +{ + return *(Atom *) a - *(Atom *) b; +} + +static void +xm_write_targets_table (Display *dpy, Window wdesc, + Atom targets_table_atom, + xm_targets_table_header *header, + xm_targets_table_rec **recs) +{ + uint8_t *header_buffer, *ptr, *rec_buffer; + ptrdiff_t rec_buffer_size; + uint16_t i, j; + + header_buffer = alloca (8); + ptr = header_buffer; + + *(header_buffer++) = header->byte_order; + *(header_buffer++) = header->protocol; + *((uint16_t *) header_buffer) = header->target_list_count; + *((uint32_t *) (header_buffer + 2)) = header->total_data_size; + + rec_buffer = xmalloc (600); + rec_buffer_size = 600; + + XChangeProperty (dpy, wdesc, targets_table_atom, + targets_table_atom, 8, PropModeReplace, + (unsigned char *) ptr, 8); + + for (i = 0; i < header->target_list_count; ++i) + { + if (rec_buffer_size < 2 + recs[i]->n_targets * 4) + { + rec_buffer_size = 2 + recs[i]->n_targets * 4; + rec_buffer = xrealloc (rec_buffer, rec_buffer_size); + } + + *((uint16_t *) rec_buffer) = recs[i]->n_targets; + + for (j = 0; j < recs[i]->n_targets; ++j) + ((uint32_t *) (rec_buffer + 2))[j] = recs[i]->targets[j]; + + XChangeProperty (dpy, wdesc, targets_table_atom, + targets_table_atom, 8, PropModeAppend, + (unsigned char *) rec_buffer, + 2 + recs[i]->n_targets * 4); + } + + xfree (rec_buffer); +} + +static void +xm_write_drag_initiator_info (Display *dpy, Window wdesc, + Atom prop_name, Atom type_name, + xm_drag_initiator_info *info) +{ + uint8_t *buf; + + buf = alloca (8); + buf[0] = info->byteorder; + buf[1] = info->protocol; + + if (info->byteorder != XM_BYTE_ORDER_CUR_FIRST) + { + SWAPCARD16 (info->table_index); + SWAPCARD16 (info->selection); + } + + *((uint16_t *) (buf + 2)) = info->table_index; + *((uint32_t *) (buf + 4)) = info->selection; + + XChangeProperty (dpy, wdesc, prop_name, type_name, 8, + PropModeReplace, (unsigned char *) buf, 8); +} + +static int +xm_drag_window_error_handler (Display *display, XErrorEvent *event) +{ + return 0; +} + +static _Noreturn int +xm_drag_window_io_error_handler (Display *dpy) +{ + /* DPY isn't created through GDK, so it doesn't matter if we don't + crash here. */ + longjmp (x_dnd_disconnect_handler, 1); +} + +static Window +xm_get_drag_window (struct x_display_info *dpyinfo) +{ + Atom actual_type, _MOTIF_DRAG_WINDOW; + int rc, actual_format; + unsigned long nitems, bytes_remaining; + unsigned char *tmp_data = NULL; + Window drag_window; + XSetWindowAttributes attrs; + Display *temp_display; + void *old_handler, *old_io_handler; + + drag_window = None; + rc = XGetWindowProperty (dpyinfo->display, dpyinfo->root_window, + dpyinfo->Xatom_MOTIF_DRAG_WINDOW, + 0, 1, False, XA_WINDOW, &actual_type, + &actual_format, &nitems, &bytes_remaining, + &tmp_data) == Success; + + if (rc) + { + if (actual_type == XA_WINDOW + && actual_format == 32 && nitems == 1) + { + drag_window = *(Window *) tmp_data; + x_catch_errors (dpyinfo->display); + /* We use ButtonPressMask since it's one of the events an + input-only window can never get. */ + XSelectInput (dpyinfo->display, drag_window, + ButtonPressMask); + rc = !x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + if (!rc) + drag_window = None; + } + + if (tmp_data) + XFree (tmp_data); + } + + if (drag_window == None) + { + block_input (); + old_io_handler = XSetIOErrorHandler (xm_drag_window_io_error_handler); + + if (sigsetjmp (x_dnd_disconnect_handler, 1)) + { + XSetIOErrorHandler (old_io_handler); + unblock_input (); + + return None; + } + + unrequest_sigio (); + temp_display = XOpenDisplay (XDisplayString (dpyinfo->display)); + request_sigio (); + + if (!temp_display) + { + XSetIOErrorHandler (old_io_handler); + unblock_input (); + + return None; + } + + XGrabServer (temp_display); + XSetCloseDownMode (temp_display, RetainPermanent); + + /* We can't use XErrorHandler since it's not in the Xlib + specification, and Emacs tries to be portable. */ + old_handler = (void *) XSetErrorHandler (xm_drag_window_error_handler); + + _MOTIF_DRAG_WINDOW = XInternAtom (temp_display, + "_MOTIF_DRAG_WINDOW", False); + + /* Some other program might've created a drag window between now + and when we first looked. Use that if it exists. */ + + tmp_data = NULL; + rc = XGetWindowProperty (temp_display, DefaultRootWindow (temp_display), + _MOTIF_DRAG_WINDOW, 0, 1, False, XA_WINDOW, + &actual_type, &actual_format, &nitems, + &bytes_remaining, &tmp_data) == Success; + + if (rc && actual_type == XA_WINDOW + && actual_format == 32 && nitems == 1 + && tmp_data) + drag_window = *(Window *) tmp_data; + + if (tmp_data) + XFree (tmp_data); + + if (drag_window == None) + { + attrs.override_redirect = True; + drag_window = XCreateWindow (temp_display, DefaultRootWindow (temp_display), + -1, -1, 1, 1, 0, CopyFromParent, InputOnly, + CopyFromParent, CWOverrideRedirect, &attrs); + XChangeProperty (temp_display, DefaultRootWindow (temp_display), + _MOTIF_DRAG_WINDOW, XA_WINDOW, 32, PropModeReplace, + (unsigned char *) &drag_window, 1); + } + + XCloseDisplay (temp_display); + XSetErrorHandler (old_handler); + XSetIOErrorHandler (old_io_handler); + + /* Make sure the drag window created is actually valid for the + current display, and the XOpenDisplay above didn't + accidentally connect to some other display. */ + x_catch_errors (dpyinfo->display); + /* We use ButtonPressMask since it's one of the events an + input-only window can never get. */ + XSelectInput (dpyinfo->display, drag_window, + ButtonPressMask); + rc = !x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + unblock_input (); + + /* We connected to the wrong display, so just give up. */ + if (!rc) + drag_window = None; + } + + return drag_window; +} + +static int +xm_setup_dnd_targets (struct x_display_info *dpyinfo, + Atom *targets, int ntargets) +{ + Window drag_window; + Atom *targets_sorted, actual_type; + unsigned char *tmp_data = NULL; + unsigned long nitems, bytes_remaining; + int rc, actual_format, idx; + xm_targets_table_header header; + xm_targets_table_rec **recs; + xm_byte_order byteorder; + uint8_t *data; + ptrdiff_t total_bytes, total_items, i; + uint32_t size, target_count; + + drag_window = xm_get_drag_window (dpyinfo); + + if (drag_window == None || ntargets > 64) + return -1; + + targets_sorted = xmalloc (sizeof *targets * ntargets); + memcpy (targets_sorted, targets, + sizeof *targets * ntargets); + qsort (targets_sorted, ntargets, + sizeof (Atom), x_atoms_compare); + + XGrabServer (dpyinfo->display); + rc = XGetWindowProperty (dpyinfo->display, drag_window, + dpyinfo->Xatom_MOTIF_DRAG_TARGETS, + 0L, LONG_MAX, False, + dpyinfo->Xatom_MOTIF_DRAG_TARGETS, + &actual_type, &actual_format, &nitems, + &bytes_remaining, &tmp_data) == Success; + + if (rc && tmp_data && !bytes_remaining + && actual_type == dpyinfo->Xatom_MOTIF_DRAG_TARGETS + && actual_format == 8) + { + data = (uint8_t *) tmp_data; + if (xm_read_targets_table_header ((uint8_t *) tmp_data, + nitems, &header, + &byteorder) == 8) + { + data += 8; + nitems -= 8; + total_bytes = 0; + total_items = 0; + + /* The extra rec is used to store a new target list if a + preexisting one doesn't already exist. */ + recs = xmalloc ((header.target_list_count + 1) + * sizeof *recs); + + while (total_items < header.target_list_count) + { + recs[total_items] = xm_read_targets_table_rec (data + total_bytes, + nitems, byteorder); + + if (!recs[total_items]) + break; + + total_bytes += 2 + recs[total_items]->n_targets * 4; + nitems -= 2 + recs[total_items]->n_targets * 4; + total_items++; + } + + if (header.target_list_count != total_items + || header.total_data_size != 8 + total_bytes) + { + for (i = 0; i < total_items; ++i) + { + if (recs[i]) + xfree (recs[i]); + else + break; + } + + xfree (recs); + + rc = false; + } + } + else + rc = false; + } + else + rc = false; + + if (tmp_data) + XFree (tmp_data); + + /* Now rc means whether or not the target lists weren't updated and + shouldn't be written to the drag window. */ + + if (!rc) + { + header.byte_order = XM_BYTE_ORDER_CUR_FIRST; + header.protocol = 0; + header.target_list_count = 1; + header.total_data_size = 8 + 2 + ntargets * 4; + + recs = xmalloc (sizeof *recs); + recs[0] = xmalloc (FLEXSIZEOF (struct xm_targets_table_rec, + targets, ntargets * 4)); + + recs[0]->n_targets = ntargets; + + for (i = 0; i < ntargets; ++i) + recs[0]->targets[i] = targets_sorted[i]; + + idx = 0; + } + else + { + idx = xm_find_targets_table_idx (&header, recs, + targets_sorted, + ntargets); + + if (idx == -1) + { + target_count = header.target_list_count; + rc = false; + + if (INT_ADD_WRAPV (header.target_list_count, 1, + &header.target_list_count) + || INT_MULTIPLY_WRAPV (ntargets, 4, &size) + || INT_ADD_WRAPV (header.total_data_size, size, + &header.total_data_size) + || INT_ADD_WRAPV (header.total_data_size, 2, + &header.total_data_size)) + { + /* Overflow, remove every entry from the targets table + and add one for our current targets list. This + confuses real Motif but not GTK 2.x, and there is no + other choice. */ + + for (i = 0; i < target_count; ++i) + xfree (recs[i]); + + xfree (recs); + + header.byte_order = XM_BYTE_ORDER_CUR_FIRST; + header.protocol = 0; + header.target_list_count = 1; + header.total_data_size = 8 + 2 + ntargets * 4; + + recs = xmalloc (sizeof *recs); + recs[0] = xmalloc (FLEXSIZEOF (struct xm_targets_table_rec, + targets, ntargets * 4)); + + recs[0]->n_targets = ntargets; + + for (i = 0; i < ntargets; ++i) + recs[0]->targets[i] = targets_sorted[i]; + + idx = 0; + } + else + { + recs[header.target_list_count - 1] + = xmalloc (FLEXSIZEOF (struct xm_targets_table_rec, + targets, ntargets * 4)); + recs[header.target_list_count - 1]->n_targets = ntargets; + + for (i = 0; i < ntargets; ++i) + recs[header.target_list_count - 1]->targets[i] = targets_sorted[i]; + + idx = header.target_list_count - 1; + } + } + } + + if (!rc) + { + /* Some implementations of Motif DND set the protocol version of + just the targets table to 1 without actually changing the + data format. To avoid confusing Motif when that happens, set + it back to 0. There will probably be no more updates to the + protocol either. */ + header.protocol = 0; + xm_write_targets_table (dpyinfo->display, drag_window, + dpyinfo->Xatom_MOTIF_DRAG_TARGETS, + &header, recs); + } + + XUngrabServer (dpyinfo->display); + + for (i = 0; i < header.target_list_count; ++i) + xfree (recs[i]); + + xfree (recs); + xfree (targets_sorted); + + return idx; +} + +static void +xm_setup_drag_info (struct x_display_info *dpyinfo, + struct frame *source_frame) +{ + xm_drag_initiator_info drag_initiator_info; + int idx; + + idx = xm_setup_dnd_targets (dpyinfo, x_dnd_targets, + x_dnd_n_targets); + + if (idx != -1) + { + drag_initiator_info.byteorder = XM_BYTE_ORDER_CUR_FIRST; + drag_initiator_info.protocol = 0; + drag_initiator_info.table_index = idx; + drag_initiator_info.selection = dpyinfo->Xatom_XdndSelection; + + xm_write_drag_initiator_info (dpyinfo->display, FRAME_X_WINDOW (source_frame), + dpyinfo->Xatom_XdndSelection, + dpyinfo->Xatom_MOTIF_DRAG_INITIATOR_INFO, + &drag_initiator_info); + + x_dnd_motif_setup_p = true; + } +} + +static void +xm_send_drop_message (struct x_display_info *dpyinfo, Window source, + Window target, xm_drop_start_message *dmsg) +{ + XEvent msg; + + msg.xclient.type = ClientMessage; + msg.xclient.message_type + = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE; + msg.xclient.format = 8; + msg.xclient.window = target; + msg.xclient.data.b[0] = dmsg->reason; + msg.xclient.data.b[1] = dmsg->byte_order; + *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->side_effects; + *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp; + *((uint16_t *) &msg.xclient.data.b[8]) = dmsg->x; + *((uint16_t *) &msg.xclient.data.b[10]) = dmsg->y; + *((uint32_t *) &msg.xclient.data.b[12]) = dmsg->index_atom; + *((uint32_t *) &msg.xclient.data.b[16]) = dmsg->source_window; + + x_catch_errors (dpyinfo->display); + XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg); + x_uncatch_errors (); +} + +static void +xm_send_top_level_enter_message (struct x_display_info *dpyinfo, Window source, + Window target, xm_top_level_enter_message *dmsg) +{ + XEvent msg; + + msg.xclient.type = ClientMessage; + msg.xclient.message_type + = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE; + msg.xclient.format = 8; + msg.xclient.window = target; + msg.xclient.data.b[0] = dmsg->reason; + msg.xclient.data.b[1] = dmsg->byteorder; + *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->zero; + *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp; + *((uint32_t *) &msg.xclient.data.b[8]) = dmsg->source_window; + *((uint32_t *) &msg.xclient.data.b[12]) = dmsg->index_atom; + msg.xclient.data.b[16] = 0; + msg.xclient.data.b[17] = 0; + msg.xclient.data.b[18] = 0; + msg.xclient.data.b[19] = 0; + + x_catch_errors (dpyinfo->display); + XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg); + x_uncatch_errors (); +} + +static void +xm_send_drag_motion_message (struct x_display_info *dpyinfo, Window source, + Window target, xm_drag_motion_message *dmsg) +{ + XEvent msg; + + msg.xclient.type = ClientMessage; + msg.xclient.message_type + = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE; + msg.xclient.format = 8; + msg.xclient.window = target; + msg.xclient.data.b[0] = dmsg->reason; + msg.xclient.data.b[1] = dmsg->byteorder; + *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->side_effects; + *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp; + *((uint16_t *) &msg.xclient.data.b[8]) = dmsg->x; + *((uint16_t *) &msg.xclient.data.b[10]) = dmsg->y; + msg.xclient.data.b[12] = 0; + msg.xclient.data.b[13] = 0; + msg.xclient.data.b[14] = 0; + msg.xclient.data.b[15] = 0; + msg.xclient.data.b[16] = 0; + msg.xclient.data.b[17] = 0; + msg.xclient.data.b[18] = 0; + msg.xclient.data.b[19] = 0; + + x_catch_errors (dpyinfo->display); + XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg); + x_uncatch_errors (); +} + +static void +xm_send_top_level_leave_message (struct x_display_info *dpyinfo, Window source, + Window target, xm_top_level_leave_message *dmsg) +{ + XEvent msg; + xm_drag_motion_message mmsg; + + /* Motif support for TOP_LEVEL_LEAVE has bitrotted, since these days + it assumes every client supports the preregister protocol style, + but we only support drop-only and dynamic. (Interestingly enough + LessTif works fine.) Sending an event with impossible + coordinates serves to get rid of any active drop site that might + still be around in the target drag context. */ + + if (x_dnd_fix_motif_leave) + { + mmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + mmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + mmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_NONE, XM_DRAG_NOOP, + XM_DROP_ACTION_DROP_CANCEL); + mmsg.timestamp = dmsg->timestamp; + mmsg.x = 65535; + mmsg.y = 65535; + + xm_send_drag_motion_message (dpyinfo, source, target, &mmsg); + } + + msg.xclient.type = ClientMessage; + msg.xclient.message_type + = dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE; + msg.xclient.format = 8; + msg.xclient.window = target; + msg.xclient.data.b[0] = dmsg->reason; + msg.xclient.data.b[1] = dmsg->byteorder; + *((uint16_t *) &msg.xclient.data.b[2]) = dmsg->zero; + *((uint32_t *) &msg.xclient.data.b[4]) = dmsg->timestamp; + *((uint32_t *) &msg.xclient.data.b[8]) = dmsg->source_window; + msg.xclient.data.b[12] = 0; + msg.xclient.data.b[13] = 0; + msg.xclient.data.b[14] = 0; + msg.xclient.data.b[15] = 0; + msg.xclient.data.b[16] = 0; + msg.xclient.data.b[17] = 0; + msg.xclient.data.b[18] = 0; + msg.xclient.data.b[19] = 0; + + x_catch_errors (dpyinfo->display); + XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg); + x_uncatch_errors (); +} + +static int +xm_read_drop_start_reply (const XEvent *msg, xm_drop_start_reply *reply) +{ + const uint8_t *data; + + data = (const uint8_t *) &msg->xclient.data.b[0]; + + if ((XM_DRAG_REASON_ORIGINATOR (data[0]) + != XM_DRAG_ORIGINATOR_RECEIVER) + || (XM_DRAG_REASON_CODE (data[0]) + != XM_DRAG_REASON_DROP_START)) + return 1; + + reply->reason = *(data++); + reply->byte_order = *(data++); + reply->side_effects = *(uint16_t *) data; + reply->better_x = *(uint16_t *) (data + 2); + reply->better_y = *(uint16_t *) (data + 4); + + if (reply->byte_order != XM_BYTE_ORDER_CUR_FIRST) + { + SWAPCARD16 (reply->side_effects); + SWAPCARD16 (reply->better_x); + SWAPCARD16 (reply->better_y); + } + + reply->byte_order = XM_BYTE_ORDER_CUR_FIRST; + + return 0; +} + +static int +xm_read_drag_receiver_info (struct x_display_info *dpyinfo, + Window wdesc, xm_drag_receiver_info *rec) +{ + Atom actual_type; + int rc, actual_format; + unsigned long nitems, bytes_remaining; + unsigned char *tmp_data = NULL; + uint8_t *data; + + x_catch_errors (dpyinfo->display); + rc = XGetWindowProperty (dpyinfo->display, wdesc, + dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + 0, 4, False, + dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + &actual_type, &actual_format, &nitems, + &bytes_remaining, + &tmp_data) == Success; + + if (x_had_errors_p (dpyinfo->display) + || actual_format != 8 || nitems < 16 || !tmp_data + || actual_type != dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO) + rc = 0; + x_uncatch_errors_after_check (); + + if (rc) + { + data = (uint8_t *) tmp_data; + + rec->byteorder = data[0]; + rec->protocol = data[1]; + rec->protocol_style = data[2]; + rec->unspecified0 = data[3]; + rec->unspecified1 = *(uint32_t *) &data[4]; + rec->unspecified2 = *(uint32_t *) &data[8]; + rec->unspecified3 = *(uint32_t *) &data[12]; + + if (rec->byteorder != XM_BYTE_ORDER_CUR_FIRST) + { + SWAPCARD32 (rec->unspecified1); + SWAPCARD32 (rec->unspecified2); + SWAPCARD32 (rec->unspecified3); + } + + rec->byteorder = XM_BYTE_ORDER_CUR_FIRST; + } + + if (tmp_data) + XFree (tmp_data); + + return !rc; +} + +static void +x_dnd_send_xm_leave_for_drop (struct x_display_info *dpyinfo, + struct frame *f, Window wdesc, + Time timestamp) +{ + xm_top_level_leave_message lmsg; + + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_LEAVE); + lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + lmsg.zero = 0; + lmsg.timestamp = timestamp; + lmsg.source_window = FRAME_X_WINDOW (f); + + if (x_dnd_motif_setup_p) + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (f), + wdesc, &lmsg); +} + +static void +x_dnd_free_toplevels (void) +{ + struct x_client_list_window *last; + struct x_client_list_window *tem = x_dnd_toplevels; + + while (tem) + { + last = tem; + tem = tem->next; + + x_catch_errors (last->dpy); + XSelectInput (last->dpy, last->window, + last->previous_event_mask); +#ifdef HAVE_XSHAPE + XShapeSelectInput (last->dpy, last->window, None); +#endif + x_uncatch_errors (); + +#ifdef HAVE_XSHAPE + if (last->n_input_rects != -1) + xfree (last->input_rects); + if (last->n_bounding_rects != -1) + xfree (last->bounding_rects); +#endif + + xfree (last); + } + + x_dnd_toplevels = NULL; +} + +static int +x_dnd_compute_toplevels (struct x_display_info *dpyinfo) +{ + Atom type; + Window *toplevels; + int format, rc; + unsigned long nitems, bytes_after; + unsigned long i; + unsigned char *data = NULL; + int frame_extents[4]; + +#ifndef USE_XCB + int dest_x, dest_y; + unsigned long *wmstate; + unsigned long wmstate_items, extent_items; + unsigned char *wmstate_data = NULL, *extent_data = NULL; + XWindowAttributes attrs; + Window child; + xm_drag_receiver_info xm_info; +#else + uint32_t *wmstate, *fextents; + uint8_t *xmdata; + xcb_get_window_attributes_cookie_t *window_attribute_cookies; + xcb_translate_coordinates_cookie_t *translate_coordinate_cookies; + xcb_get_property_cookie_t *get_property_cookies; + xcb_get_property_cookie_t *xm_property_cookies; + xcb_get_property_cookie_t *extent_property_cookies; + xcb_get_geometry_cookie_t *get_geometry_cookies; + xcb_get_window_attributes_reply_t attrs, *attrs_reply; + xcb_translate_coordinates_reply_t *coordinates_reply; + xcb_get_property_reply_t *property_reply; + xcb_get_property_reply_t *xm_property_reply; + xcb_get_property_reply_t *extent_property_reply; + xcb_get_geometry_reply_t *geometry_reply; + xcb_generic_error_t *error; +#endif + +#ifdef HAVE_XCB_SHAPE + xcb_shape_get_rectangles_cookie_t *bounding_rect_cookies; + xcb_shape_get_rectangles_reply_t *bounding_rect_reply; + xcb_rectangle_iterator_t bounding_rect_iterator; +#endif + +#ifdef HAVE_XCB_SHAPE_INPUT_RECTS + xcb_shape_get_rectangles_cookie_t *input_rect_cookies; + xcb_shape_get_rectangles_reply_t *input_rect_reply; + xcb_rectangle_iterator_t input_rect_iterator; +#endif + + struct x_client_list_window *tem; +#if defined HAVE_XSHAPE && !defined HAVE_XCB_SHAPE_INPUT_RECTS + int count, ordering; + XRectangle *rects; +#endif + + rc = XGetWindowProperty (dpyinfo->display, dpyinfo->root_window, + dpyinfo->Xatom_net_client_list_stacking, + 0, LONG_MAX, False, XA_WINDOW, &type, + &format, &nitems, &bytes_after, &data); + + if (rc != Success) + return 1; + + if (format != 32 || type != XA_WINDOW) + { + XFree (data); + return 1; + } + + toplevels = (Window *) data; + +#ifdef USE_XCB + window_attribute_cookies + = alloca (sizeof *window_attribute_cookies * nitems); + translate_coordinate_cookies + = alloca (sizeof *translate_coordinate_cookies * nitems); + get_property_cookies + = alloca (sizeof *get_property_cookies * nitems); + xm_property_cookies + = alloca (sizeof *xm_property_cookies * nitems); + extent_property_cookies + = alloca (sizeof *extent_property_cookies * nitems); + get_geometry_cookies + = alloca (sizeof *get_geometry_cookies * nitems); + +#ifdef HAVE_XCB_SHAPE + bounding_rect_cookies + = alloca (sizeof *bounding_rect_cookies * nitems); +#endif + +#ifdef HAVE_XCB_SHAPE_INPUT_RECTS + input_rect_cookies + = alloca (sizeof *input_rect_cookies * nitems); +#endif + + for (i = 0; i < nitems; ++i) + { + window_attribute_cookies[i] + = xcb_get_window_attributes (dpyinfo->xcb_connection, + (xcb_window_t) toplevels[i]); + translate_coordinate_cookies[i] + = xcb_translate_coordinates (dpyinfo->xcb_connection, + (xcb_window_t) toplevels[i], + (xcb_window_t) dpyinfo->root_window, + 0, 0); + get_property_cookies[i] + = xcb_get_property (dpyinfo->xcb_connection, 0, (xcb_window_t) toplevels[i], + (xcb_atom_t) dpyinfo->Xatom_wm_state, XCB_ATOM_ANY, + 0, 2); + xm_property_cookies[i] + = xcb_get_property (dpyinfo->xcb_connection, 0, (xcb_window_t) toplevels[i], + (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + 0, 4); + extent_property_cookies[i] + = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) toplevels[i], + (xcb_atom_t) dpyinfo->Xatom_net_frame_extents, + XCB_ATOM_CARDINAL, 0, 4); + get_geometry_cookies[i] + = xcb_get_geometry (dpyinfo->xcb_connection, (xcb_window_t) toplevels[i]); + +#ifdef HAVE_XCB_SHAPE + bounding_rect_cookies[i] + = xcb_shape_get_rectangles (dpyinfo->xcb_connection, + (xcb_window_t) toplevels[i], + XCB_SHAPE_SK_BOUNDING); +#endif + +#ifdef HAVE_XCB_SHAPE_INPUT_RECTS + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + input_rect_cookies[i] + = xcb_shape_get_rectangles (dpyinfo->xcb_connection, + (xcb_window_t) toplevels[i], + XCB_SHAPE_SK_INPUT); +#endif + } +#endif + + /* Actually right because _NET_CLIENT_LIST_STACKING has bottom-up + order. */ + for (i = 0; i < nitems; ++i) + { + frame_extents[0] = 0; + frame_extents[1] = 0; + frame_extents[2] = 0; + frame_extents[3] = 0; + +#ifndef USE_XCB + x_catch_errors (dpyinfo->display); + rc = (XGetWindowAttributes (dpyinfo->display, + toplevels[i], &attrs) + && !x_had_errors_p (dpyinfo->display)); + + if (rc) + rc = (XTranslateCoordinates (dpyinfo->display, toplevels[i], + attrs.root, -attrs.border_width, + -attrs.border_width, &dest_x, + &dest_y, &child) + && !x_had_errors_p (dpyinfo->display)); + if (rc) + rc = ((XGetWindowProperty (dpyinfo->display, + toplevels[i], + dpyinfo->Xatom_wm_state, + 0, 2, False, AnyPropertyType, + &type, &format, &wmstate_items, + &bytes_after, &wmstate_data) + == Success) + && !x_had_errors_p (dpyinfo->display) + && wmstate_data && wmstate_items == 2 && format == 32); + + if (XGetWindowProperty (dpyinfo->display, toplevels[i], + dpyinfo->Xatom_net_frame_extents, + 0, 4, False, XA_CARDINAL, &type, + &format, &extent_items, &bytes_after, + &extent_data) == Success + && !x_had_errors_p (dpyinfo->display) + && extent_data && extent_items >= 4 && format == 32) + { + frame_extents[0] = ((unsigned long *) extent_data)[0]; + frame_extents[1] = ((unsigned long *) extent_data)[1]; + frame_extents[2] = ((unsigned long *) extent_data)[2]; + frame_extents[3] = ((unsigned long *) extent_data)[3]; + } + + if (extent_data) + XFree (extent_data); + + x_uncatch_errors (); +#else + rc = true; + + attrs_reply + = xcb_get_window_attributes_reply (dpyinfo->xcb_connection, + window_attribute_cookies[i], + &error); + + if (!attrs_reply) + { + rc = false; + free (error); + } + + coordinates_reply + = xcb_translate_coordinates_reply (dpyinfo->xcb_connection, + translate_coordinate_cookies[i], + &error); + + if (!coordinates_reply) + { + rc = false; + free (error); + } + + property_reply = xcb_get_property_reply (dpyinfo->xcb_connection, + get_property_cookies[i], + &error); + + if (!property_reply) + { + rc = false; + free (error); + } + + /* These requests don't set rc on failure because they aren't + required. */ + + xm_property_reply = xcb_get_property_reply (dpyinfo->xcb_connection, + xm_property_cookies[i], + &error); + + if (!xm_property_reply) + free (error); + + extent_property_reply = xcb_get_property_reply (dpyinfo->xcb_connection, + extent_property_cookies[i], + &error); + + if (!extent_property_reply) + free (error); + else + { + if (xcb_get_property_value_length (extent_property_reply) == 16 + && extent_property_reply->format == 32 + && extent_property_reply->type == XCB_ATOM_CARDINAL) + { + fextents = xcb_get_property_value (extent_property_reply); + frame_extents[0] = fextents[0]; + frame_extents[1] = fextents[1]; + frame_extents[2] = fextents[2]; + frame_extents[3] = fextents[3]; + } + + free (extent_property_reply); + } + + if (property_reply + && (xcb_get_property_value_length (property_reply) != 8 + || property_reply->format != 32)) + rc = false; + + geometry_reply = xcb_get_geometry_reply (dpyinfo->xcb_connection, + get_geometry_cookies[i], + &error); + + if (!geometry_reply) + { + rc = false; + free (error); + } +#endif + + if (rc) + { +#ifdef USE_XCB + wmstate = (uint32_t *) xcb_get_property_value (property_reply); + attrs = *attrs_reply; +#else + wmstate = (unsigned long *) wmstate_data; +#endif + + tem = xmalloc (sizeof *tem); + tem->window = toplevels[i]; + tem->dpy = dpyinfo->display; + tem->frame_extents_left = frame_extents[0]; + tem->frame_extents_right = frame_extents[1]; + tem->frame_extents_top = frame_extents[2]; + tem->frame_extents_bottom = frame_extents[3]; + +#ifndef USE_XCB + tem->x = dest_x; + tem->y = dest_y; + tem->width = attrs.width + attrs.border_width; + tem->height = attrs.height + attrs.border_width; + tem->mapped_p = (attrs.map_state != IsUnmapped); +#else + tem->x = (coordinates_reply->dst_x + - geometry_reply->border_width); + tem->y = (coordinates_reply->dst_y + - geometry_reply->border_width); + tem->width = (geometry_reply->width + + geometry_reply->border_width); + tem->height = (geometry_reply->height + + geometry_reply->border_width); + tem->mapped_p = (attrs.map_state != XCB_MAP_STATE_UNMAPPED); +#endif + tem->next = x_dnd_toplevels; + tem->previous_event_mask = attrs.your_event_mask; + tem->wm_state = wmstate[0]; + tem->xm_protocol_style = XM_DRAG_STYLE_NONE; + +#ifndef USE_XCB + if (!xm_read_drag_receiver_info (dpyinfo, toplevels[i], &xm_info)) + tem->xm_protocol_style = xm_info.protocol_style; +#else + if (xm_property_reply + && xm_property_reply->format == 8 + && xm_property_reply->type == dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO + && xcb_get_property_value_length (xm_property_reply) >= 4) + { + xmdata = xcb_get_property_value (xm_property_reply); + tem->xm_protocol_style = xmdata[2]; + } +#endif + +#ifdef HAVE_XSHAPE +#ifndef USE_XCB + tem->border_width = attrs.border_width; +#else + tem->border_width = geometry_reply->border_width; +#endif + tem->n_bounding_rects = -1; + tem->n_input_rects = -1; + + if (dpyinfo->xshape_supported_p) + { + x_catch_errors (dpyinfo->display); + XShapeSelectInput (dpyinfo->display, + toplevels[i], + ShapeNotifyMask); + x_uncatch_errors (); + +#ifndef HAVE_XCB_SHAPE + x_catch_errors (dpyinfo->display); + rects = XShapeGetRectangles (dpyinfo->display, + toplevels[i], + ShapeBounding, + &count, &ordering); + rc = x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + /* Does XShapeGetRectangles allocate anything upon an + error? */ + if (!rc) + { + tem->n_bounding_rects = count; + tem->bounding_rects + = xmalloc (sizeof *tem->bounding_rects * count); + memcpy (tem->bounding_rects, rects, + sizeof *tem->bounding_rects * count); + + XFree (rects); + } +#else + bounding_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + bounding_rect_cookies[i], + &error); + + if (bounding_rect_reply) + { + bounding_rect_iterator + = xcb_shape_get_rectangles_rectangles_iterator (bounding_rect_reply); + tem->n_bounding_rects = bounding_rect_iterator.rem + 1; + tem->bounding_rects = xmalloc (tem->n_bounding_rects + * sizeof *tem->bounding_rects); + tem->n_bounding_rects = 0; + + for (; bounding_rect_iterator.rem; xcb_rectangle_next (&bounding_rect_iterator)) + { + tem->bounding_rects[tem->n_bounding_rects].x + = bounding_rect_iterator.data->x; + tem->bounding_rects[tem->n_bounding_rects].y + = bounding_rect_iterator.data->y; + tem->bounding_rects[tem->n_bounding_rects].width + = bounding_rect_iterator.data->width; + tem->bounding_rects[tem->n_bounding_rects].height + = bounding_rect_iterator.data->height; + + tem->n_bounding_rects++; + } + + free (bounding_rect_reply); + } + else + free (error); +#endif + +#ifdef HAVE_XCB_SHAPE_INPUT_RECTS + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + { + input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + input_rect_cookies[i], + &error); + + if (input_rect_reply) + { + input_rect_iterator + = xcb_shape_get_rectangles_rectangles_iterator (input_rect_reply); + tem->n_input_rects = input_rect_iterator.rem + 1; + tem->input_rects = xmalloc (tem->n_input_rects + * sizeof *tem->input_rects); + tem->n_input_rects = 0; + + for (; input_rect_iterator.rem; xcb_rectangle_next (&input_rect_iterator)) + { + tem->input_rects[tem->n_input_rects].x + = input_rect_iterator.data->x; + tem->input_rects[tem->n_input_rects].y + = input_rect_iterator.data->y; + tem->input_rects[tem->n_input_rects].width + = input_rect_iterator.data->width; + tem->input_rects[tem->n_input_rects].height + = input_rect_iterator.data->height; + + tem->n_input_rects++; + } + + free (input_rect_reply); + } + else + free (error); + } +#else +#ifdef ShapeInput + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + { + x_catch_errors (dpyinfo->display); + rects = XShapeGetRectangles (dpyinfo->display, + toplevels[i], ShapeInput, + &count, &ordering); + rc = x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + /* Does XShapeGetRectangles allocate anything upon + an error? */ + if (!rc) + { + tem->n_input_rects = count; + tem->input_rects + = xmalloc (sizeof *tem->input_rects * count); + memcpy (tem->input_rects, rects, + sizeof *tem->input_rects * count); + + XFree (rects); + } + } +#endif +#endif + } + + /* Handle the common case where the input shape equals the + bounding shape. */ + + if (tem->n_input_rects != -1 + && tem->n_bounding_rects == tem->n_input_rects + && !memcmp (tem->bounding_rects, tem->input_rects, + tem->n_input_rects * sizeof *tem->input_rects)) + { + xfree (tem->input_rects); + tem->n_input_rects = -1; + } + + /* And the common case where there is no input rect and the + bouding rect equals the window dimensions. */ + + if (tem->n_input_rects == -1 + && tem->n_bounding_rects == 1 +#ifdef USE_XCB + && tem->bounding_rects[0].width == (geometry_reply->width + + geometry_reply->border_width) + && tem->bounding_rects[0].height == (geometry_reply->height + + geometry_reply->border_width) + && tem->bounding_rects[0].x == -geometry_reply->border_width + && tem->bounding_rects[0].y == -geometry_reply->border_width +#else + && tem->bounding_rects[0].width == attrs.width + attrs.border_width + && tem->bounding_rects[0].height == attrs.height + attrs.border_width + && tem->bounding_rects[0].x == -attrs.border_width + && tem->bounding_rects[0].y == -attrs.border_width +#endif + ) + { + xfree (tem->bounding_rects); + tem->n_bounding_rects = -1; + } +#endif + + x_catch_errors (dpyinfo->display); + XSelectInput (dpyinfo->display, toplevels[i], + (attrs.your_event_mask + | StructureNotifyMask + | PropertyChangeMask)); + x_uncatch_errors (); + + x_dnd_toplevels = tem; + } + else + { +#ifdef HAVE_XCB_SHAPE + if (dpyinfo->xshape_supported_p) + { + bounding_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + bounding_rect_cookies[i], + &error); + + if (bounding_rect_reply) + free (bounding_rect_reply); + else + free (error); + } +#endif + +#ifdef HAVE_XCB_SHAPE_INPUT_RECTS + if (dpyinfo->xshape_supported_p + && (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1))) + { + input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + input_rect_cookies[i], + &error); + + if (input_rect_reply) + free (input_rect_reply); + else + free (error); + } +#endif + } + +#ifdef USE_XCB + if (attrs_reply) + free (attrs_reply); + + if (coordinates_reply) + free (coordinates_reply); + + if (property_reply) + free (property_reply); + + if (xm_property_reply) + free (xm_property_reply); + + if (geometry_reply) + free (geometry_reply); +#endif + +#ifndef USE_XCB + if (wmstate_data) + { + XFree (wmstate_data); + wmstate_data = NULL; + } +#endif + } + + return 0; +} + +static _Noreturn int +x_dnd_io_error_handler (Display *display) +{ +#ifdef USE_GTK + emacs_abort (); +#else + longjmp (x_dnd_disconnect_handler, 1); +#endif +} + +#define X_DND_SUPPORTED_VERSION 5 + +static int x_dnd_get_window_proto (struct x_display_info *, Window); +static Window x_dnd_get_window_proxy (struct x_display_info *, Window); +static void x_dnd_update_state (struct x_display_info *, Time); + +#ifdef USE_XCB +static void +x_dnd_get_proxy_proto (struct x_display_info *dpyinfo, Window wdesc, + Window *proxy_out, int *proto_out) +{ + xcb_get_property_cookie_t xdnd_proto_cookie; + xcb_get_property_cookie_t xdnd_proxy_cookie; + xcb_get_property_reply_t *reply; + xcb_generic_error_t *error; + + if (proxy_out) + *proxy_out = None; + + if (proto_out) + *proto_out = -1; + + if (proxy_out) + xdnd_proxy_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) wdesc, + (xcb_atom_t) dpyinfo->Xatom_XdndProxy, + XCB_ATOM_WINDOW, 0, 1); + + if (proto_out) + xdnd_proto_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) wdesc, + (xcb_atom_t) dpyinfo->Xatom_XdndAware, + XCB_ATOM_ATOM, 0, 1); + + if (proxy_out) + { + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + xdnd_proxy_cookie, &error); + + if (!reply) + free (error); + else + { + if (reply->format == 32 + && reply->type == XCB_ATOM_WINDOW + && (xcb_get_property_value_length (reply) >= 4)) + *proxy_out = *(xcb_window_t *) xcb_get_property_value (reply); + + free (reply); + } + } + + if (proto_out) + { + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + xdnd_proto_cookie, &error); + + if (!reply) + free (error); + else + { + if (reply->format == 32 + && reply->type == XCB_ATOM_ATOM + && (xcb_get_property_value_length (reply) >= 4)) + *proto_out = (int) *(xcb_atom_t *) xcb_get_property_value (reply); + + free (reply); + } + } +} +#endif + +#ifdef HAVE_XSHAPE +static bool +x_dnd_get_target_window_2 (XRectangle *rects, int nrects, + int x, int y) +{ + int i; + XRectangle *tem; + + for (i = 0; i < nrects; ++i) + { + tem = &rects[i]; + + if (x >= tem->x && y >= tem->y + && x < tem->x + tem->width + && y < tem->y + tem->height) + return true; + } + + return false; +} +#endif + +static Window +x_dnd_get_target_window_1 (struct x_display_info *dpyinfo, + int root_x, int root_y, int *motif_out, + bool *extents_p) +{ + struct x_client_list_window *tem, *chosen = NULL; + + /* Loop through x_dnd_toplevels until we find the toplevel where + root_x and root_y are. */ + + *motif_out = XM_DRAG_STYLE_NONE; + for (tem = x_dnd_toplevels; tem; tem = tem->next) + { + if (!tem->mapped_p || tem->wm_state != NormalState) + continue; + + /* Test if the coordinates are inside the window's frame + extents, and return None in that case. */ + + *extents_p = true; + if (root_x > tem->x - tem->frame_extents_left + && root_x < tem->x + && root_y > tem->y - tem->frame_extents_top + && root_y < (tem->y + tem->height - 1 + + tem->frame_extents_bottom)) + return None; + + if (root_x > tem->x + tem->width + && root_x < (tem->x + tem->width - 1 + + tem->frame_extents_right) + && root_y > tem->y - tem->frame_extents_top + && root_y < (tem->y + tem->height - 1 + + tem->frame_extents_bottom)) + return None; + + if (root_y > tem->y - tem->frame_extents_top + && root_y < tem->y + && root_x > tem->x - tem->frame_extents_left + && root_x < (tem->x + tem->width - 1 + + tem->frame_extents_right)) + return None; + + if (root_y > tem->y + tem->height + && root_y < (tem->y + tem->height - 1 + + tem->frame_extents_bottom) + && root_x >= tem->x - tem->frame_extents_left + && root_x < (tem->x + tem->width - 1 + + tem->frame_extents_right)) + return None; + *extents_p = false; + + if (root_x >= tem->x && root_y >= tem->y + && root_x < tem->x + tem->width + && root_y < tem->y + tem->height) + { +#ifdef HAVE_XSHAPE + if (tem->n_bounding_rects == -1) +#endif + { + chosen = tem; + break; + } + +#ifdef HAVE_XSHAPE + if (x_dnd_get_target_window_2 (tem->bounding_rects, + tem->n_bounding_rects, + tem->border_width + root_x - tem->x, + tem->border_width + root_y - tem->y)) + { + if (tem->n_input_rects == -1 + || x_dnd_get_target_window_2 (tem->input_rects, + tem->n_input_rects, + tem->border_width + root_x - tem->x, + tem->border_width + root_y - tem->y)) + { + chosen = tem; + break; + } + } +#endif + } + } + + if (chosen) + { + *motif_out = chosen->xm_protocol_style; + return chosen->window; + } + else + *motif_out = XM_DRAG_STYLE_NONE; + + return None; +} + +static int +x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo, + Window window, int *wmstate_out, + int *proto_out, int *motif_out, + Window *proxy_out) +{ +#ifndef USE_XCB + Atom type; + int format; + unsigned long nitems, bytes_after; + unsigned char *data = NULL; + xm_drag_receiver_info xm_info; +#else + xcb_get_property_cookie_t wmstate_cookie; + xcb_get_property_cookie_t xdnd_proto_cookie; + xcb_get_property_cookie_t xdnd_proxy_cookie; + xcb_get_property_cookie_t xm_style_cookie; + xcb_get_property_reply_t *reply; + xcb_generic_error_t *error; + uint8_t *xmdata; +#endif + int rc; + +#ifndef USE_XCB + x_catch_errors (dpyinfo->display); + rc = ((XGetWindowProperty (dpyinfo->display, window, + dpyinfo->Xatom_wm_state, + 0, 2, False, AnyPropertyType, + &type, &format, &nitems, + &bytes_after, &data) + == Success) + && !x_had_errors_p (dpyinfo->display) + && data && nitems == 2 && format == 32); + x_uncatch_errors (); + + if (rc) + *wmstate_out = *(unsigned long *) data; + + *proto_out = x_dnd_get_window_proto (dpyinfo, window); + + if (!xm_read_drag_receiver_info (dpyinfo, window, &xm_info)) + *motif_out = xm_info.protocol_style; + else + *motif_out = XM_DRAG_STYLE_NONE; + + *proxy_out = x_dnd_get_window_proxy (dpyinfo, window); + + if (data) + XFree (data); +#else + rc = true; + + wmstate_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) window, + (xcb_atom_t) dpyinfo->Xatom_wm_state, + XCB_ATOM_ANY, 0, 2); + xdnd_proto_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) window, + (xcb_atom_t) dpyinfo->Xatom_XdndAware, + XCB_ATOM_ATOM, 0, 1); + xdnd_proxy_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) window, + (xcb_atom_t) dpyinfo->Xatom_XdndProxy, + XCB_ATOM_WINDOW, 0, 1); + xm_style_cookie = xcb_get_property (dpyinfo->xcb_connection, 0, + (xcb_window_t) window, + (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + (xcb_atom_t) dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO, + 0, 4); + + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + wmstate_cookie, &error); + + if (!reply) + free (error), rc = false; + else + { + if (reply->format != 32 + || xcb_get_property_value_length (reply) != 8) + rc = false; + else + *wmstate_out = *(uint32_t *) xcb_get_property_value (reply); + + free (reply); + } + + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + xdnd_proto_cookie, &error); + + *proto_out = -1; + if (!reply) + free (error); + else + { + if (reply->format == 32 + && xcb_get_property_value_length (reply) >= 4) + *proto_out = *(uint32_t *) xcb_get_property_value (reply); + + free (reply); + } + + *proxy_out = None; + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + xdnd_proxy_cookie, &error); + + if (!reply) + free (error); + else + { + if (reply->format == 32 + && reply->type == XCB_ATOM_WINDOW + && (xcb_get_property_value_length (reply) >= 4)) + *proxy_out = *(xcb_window_t *) xcb_get_property_value (reply); + + free (reply); + } + + *motif_out = XM_DRAG_STYLE_NONE; + + reply = xcb_get_property_reply (dpyinfo->xcb_connection, + xm_style_cookie, &error); + + if (!reply) + free (error); + else + { + if (reply->format == 8 + && reply->type == dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO + && xcb_get_property_value_length (reply) >= 4) + { + xmdata = xcb_get_property_value (reply); + *motif_out = xmdata[2]; + } + + free (reply); + } +#endif + + return rc; +} + +/* From the XDND protocol specification: + + Dropping on windows that do not support XDND + + Since middle clicking is the universal shortcut for pasting + in X, one can drop data into a window that does not support + XDND by: + + 1. After the mouse has been released to trigger the drop, + obtain ownership of XA_PRIMARY. + + 2. Send a ButtonPress event and then a ButtonRelease event to + the deepest subwindow containing the mouse to simulate a + middle click. The times for these events should be the time + of the actual button release +1 and +2, respectively. These + values will not be used by anybody else, so one can + unambiguously recognize the resulting `XConvertSelection' + request. + + 3. If a request for XA_PRIMARY arrives bearing the timestamp + of either the ButtonPress or the ButtonRelease event, treat + it as a request for XdndSelection. Note that you must use + the X data types instead of the MIME types in this case. + (e.g. XA_STRING instead of text/plain). */ +void +x_dnd_do_unsupported_drop (struct x_display_info *dpyinfo, + Lisp_Object frame, Lisp_Object value, + Lisp_Object targets, Window target_window, + int root_x, int root_y, Time before) +{ + XEvent event; + int dest_x, dest_y; + Window child_return, child; + + event.xbutton.type = ButtonPress; + event.xbutton.serial = 0; + event.xbutton.send_event = True; + event.xbutton.display = dpyinfo->display; + event.xbutton.root = dpyinfo->root_window; + event.xbutton.x_root = root_x; + event.xbutton.y_root = root_y; + + x_catch_errors (dpyinfo->display); + + child = dpyinfo->root_window; + dest_x = root_x; + dest_y = root_y; + + while (XTranslateCoordinates (dpyinfo->display, child, + child, root_x, root_y, &dest_x, + &dest_y, &child_return) + && child_return != None + && XTranslateCoordinates (dpyinfo->display, child, + child_return, root_x, root_y, + &dest_x, &dest_y, &child)) + { + child = child_return; + root_x = dest_x; + root_y = dest_y; + } + + if (CONSP (value)) + x_own_selection (QPRIMARY, Fnth (make_fixnum (1), value), + frame); + else + x_own_selection (QPRIMARY, Qnil, frame); + + event.xbutton.window = child; + event.xbutton.x = dest_x; + event.xbutton.y = dest_y; + event.xbutton.state = 0; + event.xbutton.button = 2; + event.xbutton.same_screen = True; + event.xbutton.time = before + 1; + event.xbutton.time = before + 2; + + x_set_pending_dnd_time (before); + + XSendEvent (dpyinfo->display, child, + True, ButtonPressMask, &event); + event.xbutton.type = ButtonRelease; + XSendEvent (dpyinfo->display, child, + True, ButtonReleaseMask, &event); + + x_uncatch_errors (); +} + +static void +x_dnd_send_unsupported_drop (struct x_display_info *dpyinfo, Window target_window, + int root_x, int root_y, Time before) +{ + struct input_event ie; + Lisp_Object targets, arg; + int i; + char **atom_names, *name; + + EVENT_INIT (ie); + targets = Qnil; + atom_names = alloca (sizeof *atom_names * x_dnd_n_targets); + + if (!XGetAtomNames (dpyinfo->display, x_dnd_targets, + x_dnd_n_targets, atom_names)) + return; + + x_dnd_action = dpyinfo->Xatom_XdndActionPrivate; + + for (i = x_dnd_n_targets; i > 0; --i) + { + targets = Fcons (build_string (atom_names[i - 1]), + targets); + XFree (atom_names[i - 1]); + } + + name = XGetAtomName (dpyinfo->display, + x_dnd_wanted_action); + + if (name) + { + arg = intern (name); + XFree (name); + } + else + arg = Qnil; + + ie.kind = UNSUPPORTED_DROP_EVENT; + ie.code = (unsigned) target_window; + ie.arg = list3 (assq_no_quit (QXdndSelection, + dpyinfo->terminal->Vselection_alist), + targets, arg); + ie.timestamp = before; + + XSETINT (ie.x, root_x); + XSETINT (ie.y, root_y); + XSETFRAME (ie.frame_or_window, x_dnd_frame); + + kbd_buffer_store_event (&ie); +} + +static Window +x_dnd_get_target_window (struct x_display_info *dpyinfo, + int root_x, int root_y, int *proto_out, + int *motif_out, Window *toplevel_out) +{ + Window child_return, child, dummy, proxy; + int dest_x_return, dest_y_return, rc, proto, motif; + bool extents_p; +#if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2) + Window overlay_window; + XWindowAttributes attrs; +#endif + int wmstate; + + child_return = dpyinfo->root_window; + dest_x_return = root_x; + dest_y_return = root_y; + + proto = -1; + *motif_out = XM_DRAG_STYLE_NONE; + *toplevel_out = None; + + if (x_dnd_use_toplevels) + { + extents_p = false; + child = x_dnd_get_target_window_1 (dpyinfo, root_x, + root_y, motif_out, + &extents_p); + + if (!x_dnd_allow_current_frame + && FRAME_X_WINDOW (x_dnd_frame) == child) + *motif_out = XM_DRAG_STYLE_NONE; + + *toplevel_out = child; + + if (child != None) + { +#ifndef USE_XCB + proxy = x_dnd_get_window_proxy (dpyinfo, child); +#else + x_dnd_get_proxy_proto (dpyinfo, child, &proxy, proto_out); +#endif + + if (proxy != None) + { + proto = x_dnd_get_window_proto (dpyinfo, proxy); + + if (proto != -1) + { + *proto_out = proto; + return proxy; + } + } + +#ifndef USE_XCB + *proto_out = x_dnd_get_window_proto (dpyinfo, child); +#endif + return child; + } + + if (extents_p) + { + *proto_out = -1; + *motif_out = XM_DRAG_STYLE_NONE; + *toplevel_out = None; + + return None; + } + + /* Then look at the composite overlay window. */ +#if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2) + if (dpyinfo->composite_supported_p + && (dpyinfo->composite_major > 0 + || dpyinfo->composite_minor > 2)) + { + if (XGetSelectionOwner (dpyinfo->display, + dpyinfo->Xatom_NET_WM_CM_Sn) != None) + { + x_catch_errors (dpyinfo->display); + overlay_window = XCompositeGetOverlayWindow (dpyinfo->display, + dpyinfo->root_window); + XCompositeReleaseOverlayWindow (dpyinfo->display, + dpyinfo->root_window); + if (!x_had_errors_p (dpyinfo->display)) + { + XGetWindowAttributes (dpyinfo->display, overlay_window, &attrs); + + if (attrs.map_state == IsViewable) + { + proxy = x_dnd_get_window_proxy (dpyinfo, overlay_window); + + if (proxy != None) + { + proto = x_dnd_get_window_proto (dpyinfo, proxy); + + if (proto != -1) + { + *proto_out = proto; + *toplevel_out = overlay_window; + x_uncatch_errors_after_check (); + + return proxy; + } + } + } + } + x_uncatch_errors_after_check (); + } + } +#endif + + /* Now look for an XdndProxy on the root window. */ + + proxy = x_dnd_get_window_proxy (dpyinfo, dpyinfo->root_window); + + if (proxy != None) + { + proto = x_dnd_get_window_proto (dpyinfo, dpyinfo->root_window); + + if (proto != -1) + { + *toplevel_out = dpyinfo->root_window; + *proto_out = proto; + return proxy; + } + } + + /* No toplevel was found and the overlay and root windows were + not proxies, so return None. */ + *proto_out = -1; + *toplevel_out = dpyinfo->root_window; + return None; + } + + /* Not strictly necessary, but satisfies GCC. */ + child = dpyinfo->root_window; + + while (child_return != None) + { + child = child_return; + + x_catch_errors (dpyinfo->display); + rc = XTranslateCoordinates (dpyinfo->display, + child_return, child_return, + dest_x_return, dest_y_return, + &dest_x_return, &dest_y_return, + &child_return); + + if (x_had_errors_p (dpyinfo->display) || !rc) + { + x_uncatch_errors_after_check (); + break; + } + + if (child_return) + { + if (x_dnd_get_wm_state_and_proto (dpyinfo, child_return, + &wmstate, &proto, &motif, + &proxy) + /* `proto' and `motif' are set by x_dnd_get_wm_state + even if getting the wm state failed. */ + || proto != -1 || motif != XM_DRAG_STYLE_NONE) + { + *proto_out = proto; + *motif_out = motif; + *toplevel_out = child_return; + x_uncatch_errors (); + + return child_return; + } + + if (proxy != None) + { + proto = x_dnd_get_window_proto (dpyinfo, proxy); + + if (proto != -1) + { + *proto_out = proto; + *toplevel_out = child_return; + + x_uncatch_errors (); + return proxy; + } + } + + rc = XTranslateCoordinates (dpyinfo->display, + child, child_return, + dest_x_return, dest_y_return, + &dest_x_return, &dest_y_return, + &dummy); + + if (x_had_errors_p (dpyinfo->display) || !rc) + { + x_uncatch_errors_after_check (); + *proto_out = -1; + *toplevel_out = dpyinfo->root_window; + return None; + } + } + + x_uncatch_errors_after_check (); + } + +#if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2) + if (child != dpyinfo->root_window) + { +#endif + if (child != None) + { + proxy = x_dnd_get_window_proxy (dpyinfo, child); + + if (proxy) + { + proto = x_dnd_get_window_proto (dpyinfo, proxy); + + if (proto != -1) + { + *proto_out = proto; + *toplevel_out = child; + return proxy; + } + } + } + + *proto_out = x_dnd_get_window_proto (dpyinfo, child); + return child; +#if defined HAVE_XCOMPOSITE && (XCOMPOSITE_MAJOR > 0 || XCOMPOSITE_MINOR > 2) + } + else if (dpyinfo->composite_supported_p + && (dpyinfo->composite_major > 0 + || dpyinfo->composite_minor > 2)) + { + /* Only do this if a compositing manager is present. */ + if (XGetSelectionOwner (dpyinfo->display, + dpyinfo->Xatom_NET_WM_CM_Sn) != None) + { + x_catch_errors (dpyinfo->display); + overlay_window = XCompositeGetOverlayWindow (dpyinfo->display, + dpyinfo->root_window); + XCompositeReleaseOverlayWindow (dpyinfo->display, + dpyinfo->root_window); + if (!x_had_errors_p (dpyinfo->display)) + { + XGetWindowAttributes (dpyinfo->display, overlay_window, &attrs); + + if (attrs.map_state == IsViewable) + { + proxy = x_dnd_get_window_proxy (dpyinfo, overlay_window); + + if (proxy != None) + { + proto = x_dnd_get_window_proto (dpyinfo, proxy); + + if (proto != -1) + { + *proto_out = proto; + *toplevel_out = overlay_window; + x_uncatch_errors_after_check (); + + return proxy; + } + } + } + } + x_uncatch_errors_after_check (); + } + } + + if (child != None) + { + proxy = x_dnd_get_window_proxy (dpyinfo, child); + + if (proxy) + { + proto = x_dnd_get_window_proto (dpyinfo, proxy); + + if (proto != -1) + { + *toplevel_out = child; + *proto_out = proto; + return proxy; + } + } + } + + *proto_out = x_dnd_get_window_proto (dpyinfo, child); + *toplevel_out = child; + return child; +#endif +} + +static Window +x_dnd_get_window_proxy (struct x_display_info *dpyinfo, Window wdesc) +{ + int rc, actual_format; + unsigned long actual_size, bytes_remaining; + unsigned char *tmp_data = NULL; + XWindowAttributes attrs; + Atom actual_type; + Window proxy; + + proxy = None; + x_catch_errors (dpyinfo->display); + rc = XGetWindowProperty (dpyinfo->display, wdesc, + dpyinfo->Xatom_XdndProxy, + 0, 1, False, XA_WINDOW, + &actual_type, &actual_format, + &actual_size, &bytes_remaining, + &tmp_data); + + if (!x_had_errors_p (dpyinfo->display) + && rc == Success + && tmp_data + && actual_type == XA_WINDOW + && actual_format == 32 + && actual_size == 1) + { + proxy = *(Window *) tmp_data; + + /* Verify the proxy window exists. */ + XGetWindowAttributes (dpyinfo->display, proxy, &attrs); + + if (x_had_errors_p (dpyinfo->display)) + proxy = None; + } + + if (tmp_data) + XFree (tmp_data); + x_uncatch_errors_after_check (); + + return proxy; +} + +static int +x_dnd_get_window_proto (struct x_display_info *dpyinfo, Window wdesc) +{ + Atom actual, value; + unsigned char *tmp_data = NULL; + int rc, format; + unsigned long n, left; + bool had_errors; + + if (wdesc == None || (!x_dnd_allow_current_frame + && wdesc == FRAME_OUTER_WINDOW (x_dnd_frame))) + return -1; + + x_catch_errors (dpyinfo->display); + rc = XGetWindowProperty (dpyinfo->display, wdesc, dpyinfo->Xatom_XdndAware, + 0, 1, False, XA_ATOM, &actual, &format, &n, &left, + &tmp_data); + had_errors = x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + if (had_errors || rc != Success || actual != XA_ATOM || format != 32 || n < 1 + || !tmp_data) + { + if (tmp_data) + XFree (tmp_data); + return -1; + } + + value = (int) *(Atom *) tmp_data; + XFree (tmp_data); + + return min (X_DND_SUPPORTED_VERSION, (int) value); +} + +static void +x_dnd_send_enter (struct frame *f, Window target, int supported) +{ + struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + int i; + XEvent msg; + + if (x_top_window_to_frame (dpyinfo, target)) + return; + + msg.xclient.type = ClientMessage; + msg.xclient.message_type = dpyinfo->Xatom_XdndEnter; + msg.xclient.format = 32; + msg.xclient.window = target; + msg.xclient.data.l[0] = FRAME_X_WINDOW (f); + msg.xclient.data.l[1] = (((unsigned int) min (X_DND_SUPPORTED_VERSION, + supported) << 24) + | (x_dnd_n_targets > 3 ? 1 : 0)); + msg.xclient.data.l[2] = 0; + msg.xclient.data.l[3] = 0; + msg.xclient.data.l[4] = 0; + + for (i = 0; i < min (3, x_dnd_n_targets); ++i) + msg.xclient.data.l[i + 2] = x_dnd_targets[i]; + + if (x_dnd_n_targets > 3) + XChangeProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + dpyinfo->Xatom_XdndTypeList, XA_ATOM, 32, + PropModeReplace, (unsigned char *) x_dnd_targets, + x_dnd_n_targets); + + x_catch_errors (dpyinfo->display); + XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg); + x_uncatch_errors (); +} + +static void +x_dnd_send_position (struct frame *f, Window target, int supported, + unsigned short root_x, unsigned short root_y, + Time timestamp, Atom action, int button, + unsigned state) +{ + struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + XEvent msg; + struct frame *target_frame; + int dest_x, dest_y; + Window child_return; + + target_frame = x_top_window_to_frame (dpyinfo, target); + + if (target_frame && XTranslateCoordinates (dpyinfo->display, + dpyinfo->root_window, + FRAME_X_WINDOW (target_frame), + root_x, root_y, &dest_x, + &dest_y, &child_return)) + { + x_dnd_movement_frame = target_frame; + x_dnd_movement_x = dest_x; + x_dnd_movement_y = dest_y; + return; + } + + if (target == x_dnd_mouse_rect_target + && x_dnd_mouse_rect.width + && x_dnd_mouse_rect.height) + { + if (root_x >= x_dnd_mouse_rect.x + && root_x < (x_dnd_mouse_rect.x + + x_dnd_mouse_rect.width) + && root_y >= x_dnd_mouse_rect.y + && root_y < (x_dnd_mouse_rect.y + + x_dnd_mouse_rect.height)) + return; + } + + msg.xclient.type = ClientMessage; + msg.xclient.message_type = dpyinfo->Xatom_XdndPosition; + msg.xclient.format = 32; + msg.xclient.window = target; + msg.xclient.data.l[0] = FRAME_X_WINDOW (f); + msg.xclient.data.l[1] = 0; + + if (supported >= 5) + { + if (button >= 4 && button <= 8) + { + msg.xclient.data.l[1] |= (1 << 9); + msg.xclient.data.l[1] |= (button - 4) << 7; + } + else if (button) + return; + + msg.xclient.data.l[1] |= state & 0x3f; + } + else if (button) + return; + + msg.xclient.data.l[2] = (root_x << 16) | root_y; + msg.xclient.data.l[3] = 0; + msg.xclient.data.l[4] = 0; + + if (supported >= 3) + msg.xclient.data.l[3] = timestamp; + + if (supported >= 4) + msg.xclient.data.l[4] = action; + + x_catch_errors (dpyinfo->display); + XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg); + x_uncatch_errors (); +} + +static void +x_dnd_send_leave (struct frame *f, Window target) +{ + struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + XEvent msg; + + if (x_top_window_to_frame (dpyinfo, target)) + return; + + msg.xclient.type = ClientMessage; + msg.xclient.message_type = dpyinfo->Xatom_XdndLeave; + msg.xclient.format = 32; + msg.xclient.window = target; + msg.xclient.data.l[0] = FRAME_X_WINDOW (f); + msg.xclient.data.l[1] = 0; + msg.xclient.data.l[2] = 0; + msg.xclient.data.l[3] = 0; + msg.xclient.data.l[4] = 0; + + x_catch_errors (dpyinfo->display); + XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg); + x_uncatch_errors (); +} + +static bool +x_dnd_send_drop (struct frame *f, Window target, Time timestamp, + int supported) +{ + struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + XEvent msg; + struct input_event ie; + struct frame *self_frame; + int root_x, root_y, win_x, win_y, i; + unsigned int mask; + Window root, child; + Lisp_Object lval; + char **atom_names; + char *name; + + self_frame = x_top_window_to_frame (dpyinfo, target); + + if (self_frame) + { + if (!x_dnd_allow_current_frame + && self_frame == x_dnd_frame) + return false; + + /* Send a special drag-and-drop event when dropping on top of an + Emacs frame to avoid all the overhead involved with sending + client events. */ + EVENT_INIT (ie); + + if (XQueryPointer (dpyinfo->display, FRAME_X_WINDOW (self_frame), + &root, &child, &root_x, &root_y, &win_x, &win_y, + &mask)) + { + ie.kind = DRAG_N_DROP_EVENT; + XSETFRAME (ie.frame_or_window, self_frame); + + lval = Qnil; + atom_names = alloca (x_dnd_n_targets * sizeof *atom_names); + name = XGetAtomName (dpyinfo->display, x_dnd_wanted_action); + + if (!XGetAtomNames (dpyinfo->display, x_dnd_targets, + x_dnd_n_targets, atom_names)) + { + XFree (name); + return false; + } + + for (i = x_dnd_n_targets; i != 0; --i) + { + lval = Fcons (intern (atom_names[i - 1]), lval); + XFree (atom_names[i - 1]); + } + + lval = Fcons (intern (name), lval); + lval = Fcons (QXdndSelection, lval); + ie.arg = lval; + ie.timestamp = CurrentTime; + + XSETINT (ie.x, win_x); + XSETINT (ie.y, win_y); + + XFree (name); + kbd_buffer_store_event (&ie); + + return false; + } + } + else if (x_dnd_action == None) + { + x_dnd_send_leave (f, target); + return false; + } + + msg.xclient.type = ClientMessage; + msg.xclient.message_type = dpyinfo->Xatom_XdndDrop; + msg.xclient.format = 32; + msg.xclient.window = target; + msg.xclient.data.l[0] = FRAME_X_WINDOW (f); + msg.xclient.data.l[1] = 0; + msg.xclient.data.l[2] = 0; + msg.xclient.data.l[3] = 0; + msg.xclient.data.l[4] = 0; + + if (supported >= 1) + msg.xclient.data.l[2] = timestamp; + + x_catch_errors (dpyinfo->display); + XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg); + x_uncatch_errors (); + return true; +} + +void +x_set_dnd_targets (Atom *targets, int ntargets) +{ + if (x_dnd_targets) + xfree (x_dnd_targets); + + x_dnd_targets = targets; + x_dnd_n_targets = ntargets; +} + +static void +x_dnd_cleanup_drag_and_drop (void *frame) +{ + struct frame *f = frame; + xm_drop_start_message dmsg; + + if (!x_dnd_unwind_flag) + return; + + if (x_dnd_in_progress) + { + eassert (x_dnd_frame); + + block_input (); + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1) + x_dnd_send_leave (x_dnd_frame, + x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) + && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE + && x_dnd_motif_setup_p) + { + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byte_order = XM_BYTE_ORDER_CUR_FIRST; + dmsg.timestamp = FRAME_DISPLAY_INFO (f)->last_user_time; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), + x_dnd_wanted_action), + XM_DROP_ACTION_DROP_CANCEL); + dmsg.x = 0; + dmsg.y = 0; + dmsg.index_atom = FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection; + dmsg.source_window = FRAME_X_WINDOW (f); + + x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (f), f, + x_dnd_last_seen_window, + FRAME_DISPLAY_INFO (f)->last_user_time); + xm_send_drop_message (FRAME_DISPLAY_INFO (f), FRAME_X_WINDOW (f), + x_dnd_last_seen_window, &dmsg); + } + unblock_input (); + + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; + x_dnd_last_seen_toplevel = None; + x_dnd_in_progress = false; + } + + x_set_dnd_targets (NULL, 0); + x_dnd_waiting_for_finish = false; + + if (x_dnd_use_toplevels) + x_dnd_free_toplevels (); + + FRAME_DISPLAY_INFO (f)->grabbed = 0; +#ifdef USE_GTK + current_hold_quit = NULL; +#endif + x_dnd_return_frame_object = NULL; + x_dnd_movement_frame = NULL; + + block_input (); + /* Restore the old event mask. */ + XSelectInput (FRAME_X_DISPLAY (f), + FRAME_DISPLAY_INFO (f)->root_window, + x_dnd_old_window_attrs.your_event_mask); + +#ifdef HAVE_XKB + if (FRAME_DISPLAY_INFO (f)->supports_xkb) + XkbSelectEvents (FRAME_X_DISPLAY (f), XkbUseCoreKbd, + XkbStateNotifyMask, 0); +#endif + + /* Delete the Motif drag initiator info if it was set up. */ + if (x_dnd_motif_setup_p) + XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection); + unblock_input (); + + x_dnd_frame = NULL; +} + /* Flush display of frame F. */ static void @@ -785,6 +3789,7 @@ x_flush (struct frame *f) unblock_input (); } +#ifdef HAVE_XDBE static void x_drop_xrender_surfaces (struct frame *f) { @@ -800,6 +3805,7 @@ x_drop_xrender_surfaces (struct frame *f) } #endif } +#endif #ifdef HAVE_XRENDER void @@ -860,6 +3866,29 @@ record_event (char *locus, int type) #endif +#ifdef HAVE_XINPUT2 +bool +xi_frame_selected_for (struct frame *f, unsigned long event) +{ + XIEventMask *masks; + int i; + + masks = FRAME_X_OUTPUT (f)->xi_masks; + + if (!masks) + return false; + + for (i = 0; i < FRAME_X_OUTPUT (f)->num_xi_masks; ++i) + { + if (masks[i].mask_len >= XIMaskLen (event) + && XIMaskIsSet (masks[i].mask, event)) + return true; + } + + return false; +} +#endif + static void x_toolkit_position (struct frame *f, int x, int y, bool *menu_bar_p, bool *tool_bar_p) @@ -900,7 +3929,6 @@ x_toolkit_position (struct frame *f, int x, int y, static void x_update_opaque_region (struct frame *f, XEvent *configure) { -#ifndef HAVE_GTK3 unsigned long opaque_region[] = {0, 0, (configure ? configure->xconfigure.width @@ -908,6 +3936,9 @@ x_update_opaque_region (struct frame *f, XEvent *configure) (configure ? configure->xconfigure.height : FRAME_PIXEL_HEIGHT (f))}; +#ifdef HAVE_GTK3 + GObjectClass *object_class; + GtkWidgetClass *class; #endif if (!FRAME_DISPLAY_INFO (f)->alpha_bits) @@ -927,6 +3958,21 @@ x_update_opaque_region (struct frame *f, XEvent *configure) FRAME_DISPLAY_INFO (f)->Xatom_net_wm_opaque_region, XA_CARDINAL, 32, PropModeReplace, (unsigned char *) &opaque_region, 4); +#else + else if (FRAME_TOOLTIP_P (f)) + XChangeProperty (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), + FRAME_DISPLAY_INFO (f)->Xatom_net_wm_opaque_region, + XA_CARDINAL, 32, PropModeReplace, + (unsigned char *) &opaque_region, 4); + else + { + object_class = G_OBJECT_GET_CLASS (FRAME_GTK_OUTER_WIDGET (f)); + class = GTK_WIDGET_CLASS (object_class); + + if (class->style_updated) + class->style_updated (FRAME_GTK_OUTER_WIDGET (f)); + } #endif unblock_input (); } @@ -1016,6 +4062,76 @@ x_free_xi_devices (struct x_display_info *dpyinfo) unblock_input (); } +static void +xi_populate_device_from_info (struct xi_device_t *xi_device, + XIDeviceInfo *device) +{ +#ifdef HAVE_XINPUT2_1 + struct xi_scroll_valuator_t *valuator; + int actual_valuator_count; + XIScrollClassInfo *info; +#endif +#ifdef HAVE_XINPUT2_2 + XITouchClassInfo *touch_info; +#endif + int c; + + xi_device->device_id = device->deviceid; + xi_device->grab = 0; + +#ifdef HAVE_XINPUT2_1 + actual_valuator_count = 0; + xi_device->valuators = + xmalloc (sizeof *xi_device->valuators * device->num_classes); +#endif +#ifdef HAVE_XINPUT2_2 + xi_device->touchpoints = NULL; +#endif + + xi_device->use = device->use; +#ifdef HAVE_XINPUT2_2 + xi_device->direct_p = false; +#endif + xi_device->name = build_string (device->name); + + for (c = 0; c < device->num_classes; ++c) + { + switch (device->classes[c]->type) + { +#ifdef HAVE_XINPUT2_1 + case XIScrollClass: + { + info = (XIScrollClassInfo *) device->classes[c]; + + valuator = &xi_device->valuators[actual_valuator_count++]; + valuator->horizontal + = (info->scroll_type == XIScrollTypeHorizontal); + valuator->invalid_p = true; + valuator->emacs_value = DBL_MIN; + valuator->increment = info->increment; + valuator->number = info->number; + valuator->pending_enter_reset = false; + + break; + } +#endif +#ifdef HAVE_XINPUT2_2 + case XITouchClass: + { + touch_info = (XITouchClassInfo *) device->classes[c]; + xi_device->direct_p = touch_info->mode == XIDirectTouch; + } +#endif + default: + break; + } + } + +#ifdef HAVE_XINPUT2_1 + xi_device->scroll_valuator_count = actual_valuator_count; +#endif +} + /* The code below handles the tracking of scroll valuators on XInput 2, in order to support scroll wheels that report information more granular than a screen line. @@ -1050,9 +4166,10 @@ x_free_xi_devices (struct x_display_info *dpyinfo) static void x_init_master_valuators (struct x_display_info *dpyinfo) { - int ndevices; + int ndevices, actual_devices; XIDeviceInfo *infos; + actual_devices = 0; block_input (); x_free_xi_devices (dpyinfo); infos = XIQueryDevice (dpyinfo->display, @@ -1066,78 +4183,13 @@ x_init_master_valuators (struct x_display_info *dpyinfo) return; } - int actual_devices = 0; dpyinfo->devices = xmalloc (sizeof *dpyinfo->devices * ndevices); for (int i = 0; i < ndevices; ++i) { - XIDeviceInfo *device = &infos[i]; - - if (device->enabled) - { -#ifdef HAVE_XINPUT2_1 - int actual_valuator_count = 0; -#endif - - struct xi_device_t *xi_device = &dpyinfo->devices[actual_devices++]; - xi_device->device_id = device->deviceid; - xi_device->grab = 0; - -#ifdef HAVE_XINPUT2_1 - xi_device->valuators = - xmalloc (sizeof *xi_device->valuators * device->num_classes); -#endif -#ifdef HAVE_XINPUT2_2 - xi_device->touchpoints = NULL; -#endif - - xi_device->master_p = (device->use == XIMasterKeyboard - || device->use == XIMasterPointer); -#ifdef HAVE_XINPUT2_2 - xi_device->direct_p = false; -#endif - - for (int c = 0; c < device->num_classes; ++c) - { - switch (device->classes[c]->type) - { -#ifdef HAVE_XINPUT2_1 - case XIScrollClass: - { - XIScrollClassInfo *info = - (XIScrollClassInfo *) device->classes[c]; - struct xi_scroll_valuator_t *valuator; - - valuator = &xi_device->valuators[actual_valuator_count++]; - valuator->horizontal - = (info->scroll_type == XIScrollTypeHorizontal); - valuator->invalid_p = true; - valuator->emacs_value = DBL_MIN; - valuator->increment = info->increment; - valuator->number = info->number; - valuator->pending_enter_reset = false; - - break; - } -#endif -#ifdef HAVE_XINPUT2_2 - case XITouchClass: - { - XITouchClassInfo *info; - - info = (XITouchClassInfo *) device->classes[c]; - xi_device->direct_p = info->mode == XIDirectTouch; - } -#endif - default: - break; - } - } - -#ifdef HAVE_XINPUT2_1 - xi_device->scroll_valuator_count = actual_valuator_count; -#endif - } + if (infos[i].enabled) + xi_populate_device_from_info (&dpyinfo->devices[actual_devices++], + &infos[i]); } dpyinfo->num_devices = actual_devices; @@ -1147,58 +4199,49 @@ x_init_master_valuators (struct x_display_info *dpyinfo) #ifdef HAVE_XINPUT2_1 /* Return the delta of the scroll valuator VALUATOR_NUMBER under - DEVICE_ID in the display DPYINFO with VALUE. The valuator's - valuator will be set to VALUE afterwards. In case no scroll - valuator is found, or if the valuator state is invalid (see the - comment under XI_Enter in handle_one_xevent), or if device_id is - not known to Emacs, DBL_MAX is returned. Otherwise, the valuator - is returned in VALUATOR_RETURN. */ + DEVICE in the display DPYINFO with VALUE. The valuator's valuator + will be set to VALUE afterwards. In case no scroll valuator is + found, or if the valuator state is invalid (see the comment under + XI_Enter in handle_one_xevent). Otherwise, the valuator is + returned in VALUATOR_RETURN. */ static double -x_get_scroll_valuator_delta (struct x_display_info *dpyinfo, int device_id, +x_get_scroll_valuator_delta (struct x_display_info *dpyinfo, + struct xi_device_t *device, int valuator_number, double value, struct xi_scroll_valuator_t **valuator_return) { - block_input (); + struct xi_scroll_valuator_t *sv; + double delta; + int i; - for (int i = 0; i < dpyinfo->num_devices; ++i) + for (i = 0; i < device->scroll_valuator_count; ++i) { - struct xi_device_t *device = &dpyinfo->devices[i]; + sv = &device->valuators[i]; - if (device->device_id == device_id) + if (sv->number == valuator_number) { - for (int j = 0; j < device->scroll_valuator_count; ++j) + *valuator_return = sv; + + if (sv->increment == 0) + return DBL_MAX; + + if (sv->invalid_p) { - struct xi_scroll_valuator_t *sv = &device->valuators[j]; + sv->current_value = value; + sv->invalid_p = false; - if (sv->number == valuator_number) - { - if (sv->invalid_p) - { - sv->current_value = value; - sv->invalid_p = false; - *valuator_return = sv; - - unblock_input (); - return DBL_MAX; - } - else - { - double delta = (sv->current_value - value) / sv->increment; - sv->current_value = value; - *valuator_return = sv; - - unblock_input (); - return delta; - } - } + return DBL_MAX; } + else + { + delta = (sv->current_value - value) / sv->increment; + sv->current_value = value; - unblock_input (); - return DBL_MAX; + return delta; + } } } - unblock_input (); return DBL_MAX; } @@ -1413,8 +4456,11 @@ x_set_cr_source_with_gc_foreground (struct frame *f, GC gc, cairo_set_operator (FRAME_CR_CONTEXT (f), CAIRO_OPERATOR_SOURCE); } else - cairo_set_source_rgb (FRAME_CR_CONTEXT (f), color.red / 65535.0, - color.green / 65535.0, color.blue / 65535.0); + { + cairo_set_source_rgb (FRAME_CR_CONTEXT (f), color.red / 65535.0, + color.green / 65535.0, color.blue / 65535.0); + cairo_set_operator (FRAME_CR_CONTEXT (f), CAIRO_OPERATOR_OVER); + } } void @@ -1442,8 +4488,11 @@ x_set_cr_source_with_gc_background (struct frame *f, GC gc, cairo_set_operator (FRAME_CR_CONTEXT (f), CAIRO_OPERATOR_SOURCE); } else - cairo_set_source_rgb (FRAME_CR_CONTEXT (f), color.red / 65535.0, - color.green / 65535.0, color.blue / 65535.0); + { + cairo_set_source_rgb (FRAME_CR_CONTEXT (f), color.red / 65535.0, + color.green / 65535.0, color.blue / 65535.0); + cairo_set_operator (FRAME_CR_CONTEXT (f), CAIRO_OPERATOR_OVER); + } } static const cairo_user_data_key_t xlib_surface_key, saved_drawable_key; @@ -1838,6 +4887,68 @@ x_reset_clip_rectangles (struct frame *f, GC gc) #endif } +#ifdef HAVE_XRENDER +# if !defined USE_CAIRO && (RENDER_MAJOR > 0 || RENDER_MINOR >= 2) +static void +x_xrender_color_from_gc_foreground (struct frame *f, GC gc, XRenderColor *color, + bool apply_alpha_background) +{ + XGCValues xgcv; + XColor xc; + + XGetGCValues (FRAME_X_DISPLAY (f), gc, GCForeground, &xgcv); + xc.pixel = xgcv.foreground; + x_query_colors (f, &xc, 1); + + color->alpha = (apply_alpha_background + ? 65535 * f->alpha_background + : 65535); + + if (color->alpha == 65535) + { + color->red = xc.red; + color->blue = xc.blue; + color->green = xc.green; + } + else + { + color->red = (xc.red * color->alpha) / 65535; + color->blue = (xc.blue * color->alpha) / 65535; + color->green = (xc.green * color->alpha) / 65535; + } +} +# endif + +void +x_xrender_color_from_gc_background (struct frame *f, GC gc, XRenderColor *color, + bool apply_alpha_background) +{ + XGCValues xgcv; + XColor xc; + + XGetGCValues (FRAME_X_DISPLAY (f), gc, GCBackground, &xgcv); + xc.pixel = xgcv.background; + x_query_colors (f, &xc, 1); + + color->alpha = (apply_alpha_background + ? 65535 * f->alpha_background + : 65535); + + if (color->alpha == 65535) + { + color->red = xc.red; + color->blue = xc.blue; + color->green = xc.green; + } + else + { + color->red = (xc.red * color->alpha) / 65535; + color->blue = (xc.blue * color->alpha) / 65535; + color->green = (xc.green * color->alpha) / 65535; + } +} +#endif + static void x_fill_rectangle (struct frame *f, GC gc, int x, int y, int width, int height, bool respect_alpha_background) @@ -2027,9 +5138,14 @@ x_clear_window (struct frame *f) x_end_cr_clip (f); #else #ifndef USE_GTK - if (FRAME_X_DOUBLE_BUFFERED_P (f) || (f->alpha_background != 1.0)) + if (f->alpha_background != 1.0 +#ifdef HAVE_XDBE + || FRAME_X_DOUBLE_BUFFERED_P (f) #endif - x_clear_area (f, 0, 0, FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f)); + ) +#endif + x_clear_area (f, 0, 0, FRAME_PIXEL_WIDTH (f), + FRAME_PIXEL_HEIGHT (f)); #ifndef USE_GTK else XClearWindow (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); @@ -2227,7 +5343,7 @@ x_set_frame_alpha (struct frame *f) /* return unless necessary */ { - unsigned char *data; + unsigned char *data = NULL; Atom actual; int rc, format; unsigned long n, left; @@ -2237,16 +5353,19 @@ x_set_frame_alpha (struct frame *f) &actual, &format, &n, &left, &data); - if (rc == Success && actual != None) + if (rc == Success && actual != None && data) { - unsigned long value = *(unsigned long *)data; - XFree (data); + unsigned long value = *(unsigned long *) data; if (value == opac) { x_uncatch_errors (); + XFree (data); return; } } + + if (data) + XFree (data); } XChangeProperty (dpy, win, dpyinfo->Xatom_net_wm_window_opacity, @@ -2353,13 +5472,15 @@ x_draw_window_divider (struct window *w, int x0, int x1, int y0, int y1) /* Show the frame back buffer. If frame is double-buffered, atomically publish to the user's screen graphics updates made since the last call to show_back_buffer. */ + +#ifdef HAVE_XDBE static void show_back_buffer (struct frame *f) { block_input (); + if (FRAME_X_DOUBLE_BUFFERED_P (f)) { -#ifdef HAVE_XDBE #ifdef USE_CAIRO cairo_t *cr = FRAME_CR_CONTEXT (f); if (cr) @@ -2370,13 +5491,12 @@ show_back_buffer (struct frame *f) swap_info.swap_window = FRAME_X_WINDOW (f); swap_info.swap_action = XdbeCopied; XdbeSwapBuffers (FRAME_X_DISPLAY (f), &swap_info, 1); -#else - eassert (!"should have back-buffer only with XDBE"); -#endif } FRAME_X_NEED_BUFFER_FLIP (f) = false; + unblock_input (); } +#endif /* Updates back buffer and flushes changes to display. Called from minibuf read code. Note that we display the back buffer even if @@ -2385,8 +5505,10 @@ static void x_flip_and_flush (struct frame *f) { block_input (); +#ifdef HAVE_XDBE if (FRAME_X_NEED_BUFFER_FLIP (f)) - show_back_buffer (f); + show_back_buffer (f); +#endif x_flush (f); unblock_input (); } @@ -2435,8 +5557,12 @@ XTframe_up_to_date (struct frame *f) eassert (FRAME_X_P (f)); block_input (); FRAME_MOUSE_UPDATE (f); - if (!buffer_flipping_blocked_p () && FRAME_X_NEED_BUFFER_FLIP (f)) + +#ifdef HAVE_XDBE + if (!buffer_flipping_blocked_p () + && FRAME_X_NEED_BUFFER_FLIP (f)) show_back_buffer (f); +#endif #ifdef HAVE_XSYNC #ifndef HAVE_GTK3 @@ -2489,12 +5615,14 @@ XTframe_up_to_date (struct frame *f) unblock_input (); } +#ifdef HAVE_XDBE static void XTbuffer_flipping_unblocked_hook (struct frame *f) { if (FRAME_X_NEED_BUFFER_FLIP (f)) show_back_buffer (f); } +#endif /** * x_clear_under_internal_border: @@ -2798,7 +5926,7 @@ static void x_scroll_bar_clear (struct frame *); static void x_check_font (struct frame *, struct font *); #endif -void +static void x_display_set_last_user_time (struct x_display_info *dpyinfo, Time time) { #ifndef USE_GTK @@ -2917,7 +6045,10 @@ x_set_cursor_gc (struct glyph_string *s) IF_DEBUG (x_check_font (s->f, s->font)); xgcv.graphics_exposures = False; - mask = GCForeground | GCBackground | GCGraphicsExposures; + xgcv.line_width = 1; + mask = (GCForeground | GCBackground + | GCGraphicsExposures + | GCLineWidth); if (FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc) XChangeGC (display, FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc, @@ -2949,7 +6080,11 @@ x_set_mouse_face_gc (struct glyph_string *s) xgcv.background = s->face->background; xgcv.foreground = s->face->foreground; xgcv.graphics_exposures = False; - mask = GCForeground | GCBackground | GCGraphicsExposures; + xgcv.line_width = 1; + + mask = (GCForeground | GCBackground + | GCGraphicsExposures + | GCLineWidth); if (FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc) XChangeGC (display, FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc, @@ -3770,6 +6905,21 @@ x_query_frame_background_color (struct frame *f, XColor *bgcolor) x_query_colors (f, bgcolor, 1); } +static unsigned int +x_hash_string_ignore_case (const char *string) +{ + unsigned int i; + + i = 3323198485ul; + for (; *string; ++string) + { + i ^= c_tolower (*string); + i *= 0x5bd1e995; + i ^= i >> 15; + } + return i; +} + /* On frame F, translate the color name to RGB values. Use cached information, if possible. @@ -3782,12 +6932,18 @@ Status x_parse_color (struct frame *f, const char *color_name, XColor *color) { + unsigned short r, g, b; + Display *dpy = FRAME_X_DISPLAY (f); + Colormap cmap = FRAME_X_COLORMAP (f); + struct x_display_info *dpyinfo; + struct color_name_cache_entry *cache_entry; + unsigned int hash, idx; + /* Don't pass #RGB strings directly to XParseColor, because that follows the X convention of zero-extending each channel value: #f00 means #f00000. We want the convention of scaling channel values, so #f00 means #ff0000, just as it does for HTML, SVG, and CSS. */ - unsigned short r, g, b; if (parse_color_spec (color_name, &r, &g, &b)) { color->red = r; @@ -3796,13 +6952,14 @@ x_parse_color (struct frame *f, const char *color_name, return 1; } - Display *dpy = FRAME_X_DISPLAY (f); - Colormap cmap = FRAME_X_COLORMAP (f); - struct color_name_cache_entry *cache_entry; - for (cache_entry = FRAME_DISPLAY_INFO (f)->color_names; cache_entry; - cache_entry = cache_entry->next) + dpyinfo = FRAME_DISPLAY_INFO (f); + hash = x_hash_string_ignore_case (color_name); + idx = hash % dpyinfo->color_names_size; + + for (cache_entry = FRAME_DISPLAY_INFO (f)->color_names[idx]; + cache_entry; cache_entry = cache_entry->next) { - if (!xstrcasecmp(cache_entry->name, color_name)) + if (!xstrcasecmp (cache_entry->name, color_name)) { *color = cache_entry->rgb; return 1; @@ -3820,8 +6977,8 @@ x_parse_color (struct frame *f, const char *color_name, cache_entry = xzalloc (sizeof *cache_entry); cache_entry->rgb = *color; cache_entry->name = xstrdup (color_name); - cache_entry->next = FRAME_DISPLAY_INFO (f)->color_names; - FRAME_DISPLAY_INFO (f)->color_names = cache_entry; + cache_entry->next = FRAME_DISPLAY_INFO (f)->color_names[idx]; + FRAME_DISPLAY_INFO (f)->color_names[idx] = cache_entry; return 1; } @@ -4075,7 +7232,7 @@ x_alloc_lighter_color (struct frame *f, Display *display, Colormap cmap, that scaling by FACTOR alone isn't enough. */ { /* How far below the limit this color is (0 - 1, 1 being darker). */ - double dimness = 1 - (double)bright / HIGHLIGHT_COLOR_DARK_BOOST_LIMIT; + double dimness = 1 - (double) bright / HIGHLIGHT_COLOR_DARK_BOOST_LIMIT; /* The additive adjustment. */ int min_delta = delta * dimness * factor / 2; @@ -5096,7 +8253,7 @@ x_draw_stretch_glyph_string (struct glyph_string *s) } static void -x_get_scale_factor(Display *disp, int *scale_x, int *scale_y) +x_get_scale_factor (Display *disp, int *scale_x, int *scale_y) { const int base_res = 96; struct x_display_info * dpyinfo = x_display_info_for_display (disp); @@ -5591,8 +8748,11 @@ x_clear_area (struct frame *f, int x, int y, int width, int height) x_end_cr_clip (f); #else #ifndef USE_GTK - if (FRAME_X_DOUBLE_BUFFERED_P (f) - || f->alpha_background != 1.0) + if (f->alpha_background != 1.0 +#ifdef HAVE_XDBE + || FRAME_X_DOUBLE_BUFFERED_P (f) +#endif + ) #endif { #if defined HAVE_XRENDER && \ @@ -5756,6 +8916,8 @@ XTflash (struct frame *f) { GC gc; XGCValues values; + fd_set fds; + int fd, rc; block_input (); @@ -5806,6 +8968,7 @@ XTflash (struct frame *f) struct timespec delay = make_timespec (0, 150 * 1000 * 1000); struct timespec wakeup = timespec_add (current_timespec (), delay); + fd = ConnectionNumber (FRAME_X_DISPLAY (f)); /* Keep waiting until past the time wakeup or any input gets available. */ @@ -5821,8 +8984,17 @@ XTflash (struct frame *f) /* How long `select' should wait. */ timeout = make_timespec (0, 10 * 1000 * 1000); + /* Wait for some input to become available on the X + connection. */ + FD_ZERO (&fds); + FD_SET (fd, &fds); + /* Try to wait that long--but we might wake up sooner. */ - pselect (0, NULL, NULL, NULL, &timeout, NULL); + rc = pselect (fd + 1, &fds, NULL, NULL, &timeout, NULL); + + /* Some input is available, exit the visible bell. */ + if (rc >= 0 && FD_ISSET (fd, &fds)) + break; } /* If window is tall, flash top and bottom line. */ @@ -5852,16 +9024,6 @@ XTflash (struct frame *f) unblock_input (); } - -static void -XTtoggle_invisible_pointer (struct frame *f, bool invisible) -{ - block_input (); - FRAME_DISPLAY_INFO (f)->toggle_visible_pointer (f, invisible); - unblock_input (); -} - - /* Make audible bell. */ static void @@ -6033,11 +9195,13 @@ x_scroll_run (struct window *w, struct run *run) } #endif +#ifdef USE_CAIRO_XCB_SURFACE /* Some of the following code depends on `normal_gc' being up-to-date on the X server, but doesn't call a routine that will flush it first. So do this ourselves instead. */ XFlushGC (FRAME_X_DISPLAY (f), f->output_data.x->normal_gc); +#endif #ifdef USE_CAIRO if (FRAME_CR_CONTEXT (f)) @@ -6159,6 +9323,20 @@ static void x_new_focus_frame (struct x_display_info *dpyinfo, struct frame *frame) { struct frame *old_focus = dpyinfo->x_focus_frame; +#if defined USE_GTK && !defined HAVE_GTK3 && defined HAVE_XINPUT2 + XIEventMask mask; + ptrdiff_t l; + + if (dpyinfo->supports_xi2) + { + l = XIMaskLen (XI_LASTEVENT); + mask.mask = alloca (l); + mask.mask_len = l; + memset (mask.mask, 0, l); + + mask.deviceid = XIAllDevices; + } +#endif if (frame != dpyinfo->x_focus_frame) { @@ -6166,6 +9344,17 @@ x_new_focus_frame (struct x_display_info *dpyinfo, struct frame *frame) the correct value of x_focus_frame. */ dpyinfo->x_focus_frame = frame; + /* Once none of our frames are focused anymore, stop selecting + for raw input events from the root window. */ + +#if defined USE_GTK && !defined HAVE_GTK3 && defined HAVE_XINPUT2 + if (frame && dpyinfo->supports_xi2) + XISetMask (mask.mask, XI_RawKeyPress); + + if (dpyinfo->supports_xi2) + XISelectEvents (dpyinfo->display, dpyinfo->root_window, &mask, 1); +#endif + if (old_focus && old_focus->auto_lower) x_lower_frame (old_focus); @@ -6178,6 +9367,105 @@ x_new_focus_frame (struct x_display_info *dpyinfo, struct frame *frame) x_frame_rehighlight (dpyinfo); } +/* True if the display in DPYINFO supports a version of Xfixes + sufficient for pointer blanking. */ +#ifdef HAVE_XFIXES +static bool +x_probe_xfixes_extension (struct x_display_info *dpyinfo) +{ + return (dpyinfo->xfixes_supported_p + && dpyinfo->xfixes_major >= 4); +} +#endif /* HAVE_XFIXES */ + +/* Toggle mouse pointer visibility on frame F using the XFixes + extension. */ +#ifdef HAVE_XFIXES +static void +xfixes_toggle_visible_pointer (struct frame *f, bool invisible) + +{ + if (invisible) + XFixesHideCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); + else + XFixesShowCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); + f->pointer_invisible = invisible; +} +#endif /* HAVE_XFIXES */ + +/* Create invisible cursor on the X display referred by DPYINFO. */ +static Cursor +make_invisible_cursor (struct x_display_info *dpyinfo) +{ + Display *dpy = dpyinfo->display; + static char const no_data[] = { 0 }; + Pixmap pix; + XColor col; + Cursor c; + + c = None; + + x_catch_errors (dpy); + pix = XCreateBitmapFromData (dpy, dpyinfo->root_window, no_data, 1, 1); + if (!x_had_errors_p (dpy) && pix != None) + { + Cursor pixc; + col.pixel = 0; + col.red = col.green = col.blue = 0; + col.flags = DoRed | DoGreen | DoBlue; + pixc = XCreatePixmapCursor (dpy, pix, pix, &col, &col, 0, 0); + if (! x_had_errors_p (dpy) && pixc != None) + c = pixc; + XFreePixmap (dpy, pix); + } + + x_uncatch_errors (); + + return c; +} + +/* Toggle mouse pointer visibility on frame F by using an invisible + cursor. */ +static void +x_toggle_visible_pointer (struct frame *f, bool invisible) +{ + struct x_display_info *dpyinfo; + + dpyinfo = FRAME_DISPLAY_INFO (f); + + /* We could have gotten a BadAlloc error while creating the + invisible cursor. Try to create it again, but if that fails, + just give up. */ + if (dpyinfo->invisible_cursor == None) + dpyinfo->invisible_cursor = make_invisible_cursor (dpyinfo); + + if (dpyinfo->invisible_cursor == None) + invisible = false; + + if (invisible) + XDefineCursor (dpyinfo->display, FRAME_X_WINDOW (f), + dpyinfo->invisible_cursor); + else + XDefineCursor (dpyinfo->display, FRAME_X_WINDOW (f), + f->output_data.x->current_cursor); + + f->pointer_invisible = invisible; +} + +static void +XTtoggle_invisible_pointer (struct frame *f, bool invisible) +{ + block_input (); +#ifdef HAVE_XFIXES + if (FRAME_DISPLAY_INFO (f)->fixes_pointer_blanking + && x_probe_xfixes_extension (FRAME_DISPLAY_INFO (f))) + xfixes_toggle_visible_pointer (f, invisible); + else +#endif + x_toggle_visible_pointer (f, invisible); + unblock_input (); +} + /* Handle FocusIn and FocusOut state changes for FRAME. If FRAME has focus and there exists more than one frame, puts a FOCUS_IN_EVENT into *BUFP. */ @@ -6443,10 +9731,518 @@ x_top_window_to_frame (struct x_display_info *dpyinfo, int wdesc) #else /* !USE_X_TOOLKIT && !USE_GTK */ #define x_any_window_to_frame(d, i) x_window_to_frame (d, i) -#define x_top_window_to_frame(d, i) x_window_to_frame (d, i) + +struct frame * +x_top_window_to_frame (struct x_display_info *dpyinfo, int wdesc) +{ + return x_window_to_frame (dpyinfo, wdesc); +} + +static void +x_next_event_from_any_display (XEvent *event) +{ + struct x_display_info *dpyinfo; + fd_set fds; + int fd, maxfd; + + while (true) + { + FD_ZERO (&fds); + maxfd = -1; + + for (dpyinfo = x_display_list; dpyinfo; + dpyinfo = dpyinfo->next) + { + if (XPending (dpyinfo->display)) + { + XNextEvent (dpyinfo->display, event); + return; + } + + fd = XConnectionNumber (dpyinfo->display); + + if (fd > maxfd) + maxfd = fd; + + eassert (fd < FD_SETSIZE); + FD_SET (XConnectionNumber (dpyinfo->display), &fds); + } + + eassert (maxfd >= 0); + + /* We don't have to check the return of pselect, because if an + error occurs XPending will call the IO error handler, which + then brings us out of this loop. */ + pselect (maxfd, &fds, NULL, NULL, NULL, NULL); + } +} #endif /* USE_X_TOOLKIT || USE_GTK */ +static void +x_clear_dnd_targets (void) +{ + if (x_dnd_unwind_flag) + x_set_dnd_targets (NULL, 0); +} + +/* This function is defined far away from the rest of the XDND code so + it can utilize `x_any_window_to_frame'. */ + +Lisp_Object +x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, + Lisp_Object return_frame, Atom *ask_action_list, + const char **ask_action_names, size_t n_ask_actions, + bool allow_current_frame) +{ +#ifndef USE_GTK + XEvent next_event; + int finish; +#endif + XWindowAttributes root_window_attrs; + struct input_event hold_quit; + struct frame *any; + char *atom_name, *ask_actions; + Lisp_Object action, ltimestamp; + specpdl_ref ref; + ptrdiff_t i, end, fill; + XTextProperty prop; + xm_drop_start_message dmsg; + Lisp_Object frame_object, x, y, frame, local_value; + bool signals_were_pending; +#ifdef HAVE_XKB + XkbStateRec keyboard_state; +#endif +#ifndef USE_GTK + struct x_display_info *event_display; +#endif + + if (!FRAME_VISIBLE_P (f)) + { + x_set_dnd_targets (NULL, 0); + error ("Frame is invisible"); + } + + XSETFRAME (frame, f); + local_value = assq_no_quit (QXdndSelection, + FRAME_TERMINAL (f)->Vselection_alist); + + if (x_dnd_in_progress || x_dnd_waiting_for_finish) + { + x_set_dnd_targets (NULL, 0); + error ("A drag-and-drop session is already in progress"); + } + + if (CONSP (local_value)) + { + ref = SPECPDL_INDEX (); + + record_unwind_protect_void (x_clear_dnd_targets); + x_dnd_unwind_flag = true; + x_own_selection (QXdndSelection, + Fnth (make_fixnum (1), local_value), frame); + x_dnd_unwind_flag = false; + unbind_to (ref, Qnil); + } + else + { + x_set_dnd_targets (NULL, 0); + error ("No local value for XdndSelection"); + } + + if (popup_activated ()) + { + x_set_dnd_targets (NULL, 0); + error ("Trying to drag-and-drop from within a menu-entry"); + } + + ltimestamp = x_timestamp_for_selection (FRAME_DISPLAY_INFO (f), + QXdndSelection); + + if (BIGNUMP (ltimestamp)) + x_dnd_selection_timestamp = bignum_to_intmax (ltimestamp); + else + x_dnd_selection_timestamp = XFIXNUM (ltimestamp); + + if (n_ask_actions) + { + ask_actions = NULL; + end = 0; + + for (i = 0; i < n_ask_actions; ++i) + { + fill = end; + end += strlen (ask_action_names[i]) + 1; + + if (ask_actions) + ask_actions = xrealloc (ask_actions, end); + else + ask_actions = xmalloc (end); + + strncpy (ask_actions + fill, + ask_action_names[i], + end - fill); + } + + prop.value = (unsigned char *) ask_actions; + prop.encoding = XA_STRING; + prop.format = 8; + prop.nitems = end; + + block_input (); + XSetTextProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + &prop, FRAME_DISPLAY_INFO (f)->Xatom_XdndActionDescription); + xfree (ask_actions); + + XChangeProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + FRAME_DISPLAY_INFO (f)->Xatom_XdndActionList, XA_ATOM, 32, + PropModeReplace, (unsigned char *) ask_action_list, + n_ask_actions); + unblock_input (); + } + else + { + /* Delete those two properties, since some clients look at them + and not the action to decide whether or not the user should + be prompted to select an action. */ + + block_input (); + XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + FRAME_DISPLAY_INFO (f)->Xatom_XdndActionList); + XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + FRAME_DISPLAY_INFO (f)->Xatom_XdndActionDescription); + unblock_input (); + } + + x_dnd_in_progress = true; + x_dnd_frame = f; + x_dnd_last_seen_window = None; + x_dnd_last_seen_toplevel = None; + x_dnd_last_protocol_version = -1; + x_dnd_last_motif_style = XM_DRAG_STYLE_NONE; + x_dnd_mouse_rect_target = None; + x_dnd_action = None; + x_dnd_wanted_action = xaction; + x_dnd_return_frame = 0; + x_dnd_waiting_for_finish = false; + x_dnd_waiting_for_motif_finish = 0; + x_dnd_xm_use_help = false; + x_dnd_motif_setup_p = false; + x_dnd_end_window = None; + x_dnd_use_toplevels + = x_wm_supports (f, FRAME_DISPLAY_INFO (f)->Xatom_net_client_list_stacking); + x_dnd_toplevels = NULL; + x_dnd_allow_current_frame = allow_current_frame; + x_dnd_movement_frame = NULL; +#ifdef HAVE_XKB + x_dnd_keyboard_state = 0; + + if (FRAME_DISPLAY_INFO (f)->supports_xkb) + { + XkbSelectEvents (FRAME_X_DISPLAY (f), XkbUseCoreKbd, + XkbStateNotifyMask, XkbStateNotifyMask); + XkbGetState (FRAME_X_DISPLAY (f), XkbUseCoreKbd, + &keyboard_state); + + x_dnd_keyboard_state = (keyboard_state.mods + | keyboard_state.ptr_buttons); + } +#endif + + if (x_dnd_use_toplevels) + { + if (x_dnd_compute_toplevels (FRAME_DISPLAY_INFO (f))) + { + x_dnd_free_toplevels (); + x_dnd_use_toplevels = false; + } + } + + if (!NILP (return_frame)) + x_dnd_return_frame = 1; + + if (EQ (return_frame, Qnow)) + x_dnd_return_frame = 2; + + /* Now select for SubstructureNotifyMask and PropertyNotifyMask on + the root window, so we can get notified when window stacking + changes, a common operation during drag-and-drop. */ + + XGetWindowAttributes (FRAME_X_DISPLAY (f), + FRAME_DISPLAY_INFO (f)->root_window, + &root_window_attrs); + + XSelectInput (FRAME_X_DISPLAY (f), + FRAME_DISPLAY_INFO (f)->root_window, + root_window_attrs.your_event_mask + | SubstructureNotifyMask + | PropertyChangeMask); + + if (EQ (return_frame, Qnow)) + x_dnd_update_state (FRAME_DISPLAY_INFO (f), CurrentTime); + + while (x_dnd_in_progress || x_dnd_waiting_for_finish) + { + hold_quit.kind = NO_EVENT; +#ifdef USE_GTK + current_finish = X_EVENT_NORMAL; + current_hold_quit = &hold_quit; + current_count = 0; +#endif + + block_input (); +#ifdef USE_GTK + gtk_main_iteration (); +#elif defined USE_X_TOOLKIT + XtAppNextEvent (Xt_app_con, &next_event); +#else + x_next_event_from_any_display (&next_event); +#endif + +#ifndef USE_GTK + event_display + = x_display_info_for_display (next_event.xany.display); + + if (event_display) + { +#ifdef HAVE_X_I18N +#ifdef HAVE_XINPUT2 + if (next_event.type != GenericEvent + || !event_display->supports_xi2 + || (next_event.xgeneric.extension + != event_display->xi2_opcode)) + { +#endif + if (!x_filter_event (event_display, &next_event)) + handle_one_xevent (event_display, + &next_event, &finish, &hold_quit); +#ifdef HAVE_XINPUT2 + } + else + handle_one_xevent (event_display, + &next_event, &finish, &hold_quit); +#endif +#else + handle_one_xevent (event_display, + &next_event, &finish, &hold_quit); +#endif + } +#endif + + /* The unblock_input below might try to read input, but + XTread_socket does nothing inside a drag-and-drop event + loop, so don't let it clear the pending_signals flag. */ + signals_were_pending = pending_signals; + unblock_input (); + pending_signals = signals_were_pending; + + /* Ignore mouse movement from displays that aren't the DND + display. */ +#ifndef USE_GTK + if (event_display == FRAME_DISPLAY_INFO (f)) + { +#endif + if (x_dnd_movement_frame) + { + XSETFRAME (frame_object, x_dnd_movement_frame); + XSETINT (x, x_dnd_movement_x); + XSETINT (y, x_dnd_movement_y); + x_dnd_movement_frame = NULL; + + if (!NILP (Vx_dnd_movement_function) + && !FRAME_TOOLTIP_P (XFRAME (frame_object)) + && x_dnd_movement_x >= 0 + && x_dnd_movement_y >= 0 + && x_dnd_frame + && (XFRAME (frame_object) != x_dnd_frame + || x_dnd_allow_current_frame)) + { + x_dnd_old_window_attrs = root_window_attrs; + x_dnd_unwind_flag = true; + + ref = SPECPDL_INDEX (); + record_unwind_protect_ptr (x_dnd_cleanup_drag_and_drop, f); + call2 (Vx_dnd_movement_function, frame_object, + Fposn_at_x_y (x, y, frame_object, Qnil)); + x_dnd_unwind_flag = false; + unbind_to (ref, Qnil); + } + } + + if (hold_quit.kind != NO_EVENT) + { + if (hold_quit.kind == SELECTION_REQUEST_EVENT) + { + x_dnd_old_window_attrs = root_window_attrs; + x_dnd_unwind_flag = true; + + ref = SPECPDL_INDEX (); + record_unwind_protect_ptr (x_dnd_cleanup_drag_and_drop, f); + x_handle_selection_event ((struct selection_input_event *) &hold_quit); + x_dnd_unwind_flag = false; + unbind_to (ref, Qnil); + continue; + } + + if (x_dnd_in_progress) + { + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1) + x_dnd_send_leave (f, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) + && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE + && x_dnd_motif_setup_p) + { + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byte_order = XM_BYTE_ORDER_CUR_FIRST; + dmsg.timestamp = hold_quit.timestamp; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), + x_dnd_wanted_action), + XM_DROP_ACTION_DROP_CANCEL); + dmsg.x = 0; + dmsg.y = 0; + dmsg.index_atom = FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection; + dmsg.source_window = FRAME_X_WINDOW (f); + + x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (f), f, + x_dnd_last_seen_window, + hold_quit.timestamp); + xm_send_drop_message (FRAME_DISPLAY_INFO (f), FRAME_X_WINDOW (f), + x_dnd_last_seen_window, &dmsg); + } + + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; + x_dnd_last_seen_toplevel = None; + x_dnd_in_progress = false; + x_dnd_frame = NULL; + } + + x_set_dnd_targets (NULL, 0); + x_dnd_waiting_for_finish = false; + + if (x_dnd_use_toplevels) + x_dnd_free_toplevels (); + + x_dnd_return_frame_object = NULL; + x_dnd_movement_frame = NULL; + + FRAME_DISPLAY_INFO (f)->grabbed = 0; +#ifdef USE_GTK + current_hold_quit = NULL; +#endif + /* Restore the old event mask. */ + XSelectInput (FRAME_X_DISPLAY (f), + FRAME_DISPLAY_INFO (f)->root_window, + root_window_attrs.your_event_mask); +#ifdef HAVE_XKB + if (FRAME_DISPLAY_INFO (f)->supports_xkb) + XkbSelectEvents (FRAME_X_DISPLAY (f), XkbUseCoreKbd, + XkbStateNotifyMask, 0); +#endif + /* Delete the Motif drag initiator info if it was set up. */ + if (x_dnd_motif_setup_p) + XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection); + quit (); + } +#ifndef USE_GTK + } + else + { + if (x_dnd_movement_frame) + x_dnd_movement_frame = NULL; + + if (hold_quit.kind != NO_EVENT) + EVENT_INIT (hold_quit); + } +#endif + } + + x_set_dnd_targets (NULL, 0); + x_dnd_waiting_for_finish = false; + +#ifdef USE_GTK + current_hold_quit = NULL; +#endif + x_dnd_movement_frame = NULL; + + block_input (); + /* Restore the old event mask. */ + XSelectInput (FRAME_X_DISPLAY (f), + FRAME_DISPLAY_INFO (f)->root_window, + root_window_attrs.your_event_mask); +#ifdef HAVE_XKB + if (FRAME_DISPLAY_INFO (f)->supports_xkb) + XkbSelectEvents (FRAME_X_DISPLAY (f), XkbUseCoreKbd, + XkbStateNotifyMask, 0); +#endif + /* Delete the Motif drag initiator info if it was set up. */ + if (x_dnd_motif_setup_p) + XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection); + unblock_input (); + + if (x_dnd_return_frame == 3 + && FRAME_LIVE_P (x_dnd_return_frame_object)) + { + /* Deliberately preserve the last device if + x_dnd_return_frame_object is the drag source. */ + + if (x_dnd_return_frame_object != x_dnd_frame) + x_dnd_return_frame_object->last_mouse_device = Qnil; + + x_dnd_return_frame_object->mouse_moved = true; + + XSETFRAME (action, x_dnd_return_frame_object); + x_dnd_return_frame_object = NULL; + return action; + } + + x_dnd_return_frame_object = NULL; + + if (x_dnd_use_toplevels) + x_dnd_free_toplevels (); + FRAME_DISPLAY_INFO (f)->grabbed = 0; + + /* Emacs can't respond to DND events inside the nested event + loop, so when dragging items to itself, always return + XdndActionPrivate. */ + if (x_dnd_end_window != None + && (any = x_any_window_to_frame (FRAME_DISPLAY_INFO (f), + x_dnd_end_window)) + && (allow_current_frame || any != f)) + return QXdndActionPrivate; + + if (x_dnd_action != None) + { + block_input (); + x_catch_errors (FRAME_X_DISPLAY (f)); + atom_name = XGetAtomName (FRAME_X_DISPLAY (f), + x_dnd_action); + x_uncatch_errors (); + + if (atom_name) + { + action = intern (atom_name); + XFree (atom_name); + } + else + action = Qnil; + unblock_input (); + + return action; + } + + return Qnil; +} + /* The focus may have changed. Figure out if it is a real focus change, by checking both FocusIn/Out and Enter/LeaveNotify events. @@ -6538,12 +10334,21 @@ x_detect_focus_change (struct x_display_info *dpyinfo, struct frame *frame, } -#if !defined USE_X_TOOLKIT && !defined USE_GTK +#if (defined USE_LUCID && defined HAVE_XINPUT2) \ + || (!defined USE_X_TOOLKIT && !defined USE_GTK) /* Handle an event saying the mouse has moved out of an Emacs frame. */ void x_mouse_leave (struct x_display_info *dpyinfo) { + Mouse_HLInfo *hlinfo = &dpyinfo->mouse_highlight; + + if (hlinfo->mouse_face_mouse_frame) + { + clear_mouse_face (hlinfo); + hlinfo->mouse_face_mouse_frame = NULL; + } + x_new_focus_frame (dpyinfo, dpyinfo->x_focus_event_frame); } #endif @@ -6606,6 +10411,7 @@ x_find_modifier_meanings (struct x_display_info *dpyinfo) #ifdef HAVE_XKB int i; int found_meta_p = false; + uint vmodmask; #endif dpyinfo->meta_mod_mask = 0; @@ -6620,12 +10426,14 @@ x_find_modifier_meanings (struct x_display_info *dpyinfo) { for (i = 0; i < XkbNumVirtualMods; i++) { - uint vmodmask = dpyinfo->xkb_desc->server->vmods[i]; + vmodmask = dpyinfo->xkb_desc->server->vmods[i]; if (dpyinfo->xkb_desc->names->vmods[i] == dpyinfo->Xatom_Meta) { dpyinfo->meta_mod_mask |= vmodmask; - found_meta_p = vmodmask; + + if (vmodmask) + found_meta_p = true; } else if (dpyinfo->xkb_desc->names->vmods[i] == dpyinfo->Xatom_Alt) dpyinfo->alt_mod_mask |= vmodmask; @@ -6927,7 +10735,8 @@ x_construct_mouse_click (struct input_event *result, XI_Enter and XI_Leave labels inside `handle_one_xevent'. */ static bool -x_note_mouse_movement (struct frame *frame, const XMotionEvent *event) +x_note_mouse_movement (struct frame *frame, const XMotionEvent *event, + Lisp_Object device) { XRectangle *r; struct x_display_info *dpyinfo; @@ -6944,6 +10753,7 @@ x_note_mouse_movement (struct frame *frame, const XMotionEvent *event) if (event->window != FRAME_X_WINDOW (frame)) { frame->mouse_moved = true; + frame->last_mouse_device = device; dpyinfo->last_mouse_scroll_bar = NULL; note_mouse_highlight (frame, -1, -1); dpyinfo->last_mouse_glyph_frame = NULL; @@ -6958,6 +10768,7 @@ x_note_mouse_movement (struct frame *frame, const XMotionEvent *event) || event->y < r->y || event->y >= r->y + r->height) { frame->mouse_moved = true; + frame->last_mouse_device = device; dpyinfo->last_mouse_scroll_bar = NULL; note_mouse_highlight (frame, event->x, event->y); /* Remember which glyph we're now on. */ @@ -7060,7 +10871,8 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, x_catch_errors (FRAME_X_DISPLAY (*fp)); - if (gui_mouse_grabbed (dpyinfo) && !EQ (track_mouse, Qdropping)) + if (gui_mouse_grabbed (dpyinfo) && !EQ (track_mouse, Qdropping) + && !EQ (track_mouse, Qdrag_source)) { /* If mouse was grabbed on a frame, give coords for that frame even if the mouse is now outside it. */ @@ -7148,8 +10960,19 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, #endif /* USE_X_TOOLKIT */ } + /* Set last user time to avoid confusing some window managers + about the tooltip displayed during drag-and-drop. */ + + if ((EQ (track_mouse, Qdrag_source) + || EQ (track_mouse, Qdropping)) + && (dpyinfo->last_user_time + < dpyinfo->last_mouse_movement_time)) + x_display_set_last_user_time (dpyinfo, + dpyinfo->last_mouse_movement_time); + if ((!f1 || FRAME_TOOLTIP_P (f1)) - && EQ (track_mouse, Qdropping) + && (EQ (track_mouse, Qdropping) + || EQ (track_mouse, Qdrag_source)) && gui_mouse_grabbed (dpyinfo)) { /* When dropping then if we didn't get a frame or only a @@ -7165,12 +10988,28 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, root_x, root_y, &win_x, &win_y, /* Child of win. */ &child); - f1 = dpyinfo->last_mouse_frame; + + if (!EQ (track_mouse, Qdrag_source) + /* Don't let tooltips interfere. */ + || (f1 && FRAME_TOOLTIP_P (f1))) + f1 = dpyinfo->last_mouse_frame; + else + { + /* Don't set FP but do set WIN_X and WIN_Y in this + case, so make_lispy_movement knows which + coordinates to report. */ + *bar_window = Qnil; + *part = 0; + *fp = NULL; + XSETINT (*x, win_x); + XSETINT (*y, win_y); + *timestamp = dpyinfo->last_mouse_movement_time; + } } else if (f1 && FRAME_TOOLTIP_P (f1)) f1 = NULL; - if (x_had_errors_p (FRAME_X_DISPLAY (*fp))) + if (x_had_errors_p (dpyinfo->display)) f1 = NULL; x_uncatch_errors_after_check (); @@ -7180,7 +11019,7 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, { struct scroll_bar *bar; - bar = x_window_to_scroll_bar (FRAME_X_DISPLAY (*fp), win, 2); + bar = x_window_to_scroll_bar (dpyinfo->display, win, 2); if (bar) { @@ -7238,9 +11077,9 @@ x_window_to_scroll_bar (Display *display, Window window_id, int type) { Lisp_Object tail, frame; -#if defined (USE_GTK) && defined (USE_TOOLKIT_SCROLL_BARS) +#if defined (USE_GTK) && !defined (HAVE_GTK3) && defined (USE_TOOLKIT_SCROLL_BARS) window_id = (Window) xg_get_scroll_id_for_window (display, window_id); -#endif /* USE_GTK && USE_TOOLKIT_SCROLL_BARS */ +#endif /* USE_GTK && !HAVE_GTK3 && USE_TOOLKIT_SCROLL_BARS */ FOR_EACH_FRAME (tail, frame) { @@ -7419,6 +11258,35 @@ xt_horizontal_action_hook (Widget widget, XtPointer client_data, String action_n } #endif /* not USE_GTK */ +/* Protect WINDOW from garbage collection until a matching scroll bar + message is received. Return whether or not protection + succeeded. */ +static bool +x_protect_window_for_callback (struct x_display_info *dpyinfo, + Lisp_Object window) +{ + if (dpyinfo->n_protected_windows + 1 + >= dpyinfo->protected_windows_max) + return false; + + dpyinfo->protected_windows[dpyinfo->n_protected_windows++] + = window; + return true; +} + +static void +x_unprotect_window_for_callback (struct x_display_info *dpyinfo) +{ + if (!dpyinfo->n_protected_windows) + emacs_abort (); + + dpyinfo->n_protected_windows--; + + if (dpyinfo->n_protected_windows) + memmove (dpyinfo->protected_windows, &dpyinfo->protected_windows[1], + sizeof (Lisp_Object) * dpyinfo->n_protected_windows); +} + /* Send a client message with message type Xatom_Scrollbar for a scroll action to the frame of WINDOW. PART is a value identifying the part of the scroll bar that was clicked on. PORTION is the @@ -7436,8 +11304,12 @@ x_send_scroll_bar_event (Lisp_Object window, enum scroll_bar_part part, verify (INTPTR_WIDTH <= 64); int sign_shift = INTPTR_WIDTH - 32; - block_input (); + /* Don't do anything if too many scroll bar events have been + sent but not received. */ + if (!x_protect_window_for_callback (FRAME_DISPLAY_INFO (f), window)) + return; + block_input (); /* Construct a ClientMessage event to send to the frame. */ ev->type = ClientMessage; ev->message_type = (horizontal @@ -7467,7 +11339,8 @@ x_send_scroll_bar_event (Lisp_Object window, enum scroll_bar_part part, /* Setting the event mask to zero means that the message will be sent to the client that created the window, and if that window no longer exists, no event will be sent. */ - XSendEvent (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), False, 0, &event); + XSendEvent (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), False, + NoEventMask, &event); unblock_input (); } @@ -9312,6 +13185,22 @@ x_scroll_bar_expose (struct scroll_bar *bar, const XEvent *event) #else Drawable w = bar->x_drawable; #endif + int x, y, width, height; + + if (event->type == Expose) + { + x = event->xexpose.x; + y = event->xexpose.y; + width = event->xexpose.width; + height = event->xexpose.height; + } + else + { + x = event->xgraphicsexpose.x; + y = event->xgraphicsexpose.y; + width = event->xgraphicsexpose.width; + height = event->xgraphicsexpose.height; + } struct frame *f = XFRAME (WINDOW_FRAME (XWINDOW (bar->window))); GC gc = f->output_data.x->normal_gc; @@ -9330,10 +13219,7 @@ x_scroll_bar_expose (struct scroll_bar *bar, const XEvent *event) XFillRectangle (FRAME_X_DISPLAY (f), bar->x_drawable, - gc, event->xexpose.x, - event->xexpose.y, - event->xexpose.width, - event->xexpose.height); + gc, x, y, width, height); XSetForeground (FRAME_X_DISPLAY (f), gc, FRAME_FOREGROUND_PIXEL (f)); @@ -9345,15 +13231,18 @@ x_scroll_bar_expose (struct scroll_bar *bar, const XEvent *event) /* Switch to scroll bar foreground color. */ if (f->output_data.x->scroll_bar_foreground_pixel != -1) XSetForeground (FRAME_X_DISPLAY (f), gc, - f->output_data.x->scroll_bar_foreground_pixel); + f->output_data.x->scroll_bar_foreground_pixel); /* Draw a one-pixel border just inside the edges of the scroll bar. */ XDrawRectangle (FRAME_X_DISPLAY (f), w, gc, /* x, y, width, height */ 0, 0, bar->width - 1, bar->height - 1); - XDrawPoint (FRAME_X_DISPLAY (f), w, gc, - bar->width - 1, bar->height - 1); + /* XDrawPoint (FRAME_X_DISPLAY (f), w, gc, + bar->width - 1, bar->height - 1); + + This code is no longer required since the normal GC now uses the + regular line width. */ /* Restore the foreground color of the GC if we changed it above. */ if (f->output_data.x->scroll_bar_foreground_pixel != -1) @@ -9379,8 +13268,14 @@ x_scroll_bar_expose (struct scroll_bar *bar, const XEvent *event) static void x_scroll_bar_handle_click (struct scroll_bar *bar, const XEvent *event, - struct input_event *emacs_event) + struct input_event *emacs_event, + Lisp_Object device) { + int left_range, x, top_range, y; +#ifndef USE_TOOLKIT_SCROLL_BARS + int new_start, new_end; +#endif + if (! WINDOWP (bar->window)) emacs_abort (); @@ -9398,11 +13293,15 @@ x_scroll_bar_handle_click (struct scroll_bar *bar, emacs_event->frame_or_window = bar->window; emacs_event->arg = Qnil; emacs_event->timestamp = event->xbutton.time; + + if (!NILP (device)) + emacs_event->device = device; + if (bar->horizontal) { - int left_range - = HORIZONTAL_SCROLL_BAR_LEFT_RANGE (f, bar->width); - int x = event->xbutton.x - HORIZONTAL_SCROLL_BAR_LEFT_BORDER; + + left_range = HORIZONTAL_SCROLL_BAR_LEFT_RANGE (f, bar->width); + x = event->xbutton.x - HORIZONTAL_SCROLL_BAR_LEFT_BORDER; if (x < 0) x = 0; if (x > left_range) x = left_range; @@ -9418,8 +13317,8 @@ x_scroll_bar_handle_click (struct scroll_bar *bar, /* If the user has released the handle, set it to its final position. */ if (event->type == ButtonRelease && bar->dragging != -1) { - int new_start = - bar->dragging; - int new_end = new_start + bar->end - bar->start; + new_start = - bar->dragging; + new_end = new_start + bar->end - bar->start; x_scroll_bar_set_handle (bar, new_start, new_end, false); bar->dragging = -1; @@ -9431,9 +13330,9 @@ x_scroll_bar_handle_click (struct scroll_bar *bar, } else { - int top_range + top_range = VERTICAL_SCROLL_BAR_TOP_RANGE (f, bar->height); - int y = event->xbutton.y - VERTICAL_SCROLL_BAR_TOP_BORDER; + y = event->xbutton.y - VERTICAL_SCROLL_BAR_TOP_BORDER; if (y < 0) y = 0; if (y > top_range) y = top_range; @@ -9449,8 +13348,8 @@ x_scroll_bar_handle_click (struct scroll_bar *bar, /* If the user has released the handle, set it to its final position. */ if (event->type == ButtonRelease && bar->dragging != -1) { - int new_start = y - bar->dragging; - int new_end = new_start + bar->end - bar->start; + new_start = y - bar->dragging; + new_end = new_start + bar->end - bar->start; x_scroll_bar_set_handle (bar, new_start, new_end, false); bar->dragging = -1; @@ -9735,13 +13634,6 @@ static struct x_display_info *XTread_socket_fake_io_error; static struct x_display_info *next_noop_dpyinfo; -enum -{ - X_EVENT_NORMAL, - X_EVENT_GOTO_OUT, - X_EVENT_DROP -}; - /* Filter events for the current X input method. DPYINFO is the display this event is for. EVENT is the X event to filter. @@ -9817,10 +13709,6 @@ x_filter_event (struct x_display_info *dpyinfo, XEvent *event) #endif #ifdef USE_GTK -static int current_count; -static int current_finish; -static struct input_event *current_hold_quit; - /* This is the filter function invoked by the GTK event loop. It is invoked before the XEvent is translated to a GdkEvent, so we have a chance to act on the event before GTK. */ @@ -9937,20 +13825,48 @@ x_net_wm_state (struct frame *f, Window window) store_frame_param (f, Qshaded, shaded ? Qt : Qnil); } -/* Flip back buffers on FRAME if it has undrawn content. */ +/* Flip back buffers on F if it has undrawn content. */ + +#ifdef HAVE_XDBE static void flush_dirty_back_buffer_on (struct frame *f) { block_input (); - if (FRAME_LIVE_P (f) && - FRAME_X_P (f) && - FRAME_X_WINDOW (f) && - !FRAME_GARBAGED_P (f) && - !buffer_flipping_blocked_p () && - FRAME_X_NEED_BUFFER_FLIP (f)) + if (!FRAME_GARBAGED_P (f) + && !buffer_flipping_blocked_p () + && FRAME_X_NEED_BUFFER_FLIP (f)) show_back_buffer (f); unblock_input (); } +#endif + +#ifdef HAVE_GTK3 +void +x_scroll_bar_configure (GdkEvent *event) +{ + XEvent configure; + GdkDisplay *gdpy; + Display *dpy; + + configure.xconfigure.type = ConfigureNotify; + configure.xconfigure.serial = 0; + configure.xconfigure.send_event = event->configure.send_event; + configure.xconfigure.x = event->configure.x; + configure.xconfigure.y = event->configure.y; + configure.xconfigure.width = event->configure.width; + configure.xconfigure.height = event->configure.height; + configure.xconfigure.border_width = 0; + configure.xconfigure.event = GDK_WINDOW_XID (event->configure.window); + configure.xconfigure.window = GDK_WINDOW_XID (event->configure.window); + configure.xconfigure.above = None; + configure.xconfigure.override_redirect = False; + + gdpy = gdk_window_get_display (event->configure.window); + dpy = gdk_x11_display_get_xdisplay (gdpy); + + x_dispatch_event (&configure, dpy); +} +#endif /** mouse_or_wdesc_frame: When not dropping and the mouse was grabbed @@ -9967,7 +13883,8 @@ mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc) ? dpyinfo->last_mouse_frame : NULL); - if (lm_f && !EQ (track_mouse, Qdropping)) + if (lm_f && !EQ (track_mouse, Qdropping) + && !EQ (track_mouse, Qdrag_source)) return lm_f; else { @@ -9983,6 +13900,210 @@ mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc) } } +/* Get the window underneath the pointer, see if it moved, and update + the DND state accordingly. */ +static void +x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp) +{ + int root_x, root_y, dummy_x, dummy_y, target_proto, motif_style; + unsigned int dummy_mask; + Window dummy, dummy_child, target, toplevel; + xm_top_level_leave_message lmsg; + xm_top_level_enter_message emsg; + xm_drag_motion_message dmsg; + xm_drop_start_message dsmsg; + + if (XQueryPointer (dpyinfo->display, + dpyinfo->root_window, + &dummy, &dummy_child, + &root_x, &root_y, + &dummy_x, &dummy_y, + &dummy_mask)) + { + target = x_dnd_get_target_window (dpyinfo, root_x, + root_y, &target_proto, + &motif_style, &toplevel); + + if (toplevel != x_dnd_last_seen_toplevel) + { + if (toplevel != FRAME_OUTER_WINDOW (x_dnd_frame) + && x_dnd_return_frame == 1) + x_dnd_return_frame = 2; + + if (x_dnd_return_frame == 2 + && x_any_window_to_frame (dpyinfo, toplevel)) + { + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1 + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_LEAVE); + lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + lmsg.zero = 0; + lmsg.timestamp = timestamp; + lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + if (x_dnd_motif_setup_p) + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &lmsg); + } + + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; + x_dnd_last_seen_toplevel = None; + x_dnd_in_progress = false; + x_dnd_return_frame_object + = x_any_window_to_frame (dpyinfo, toplevel); + x_dnd_return_frame = 3; + x_dnd_waiting_for_finish = false; + target = None; + } + + x_dnd_last_seen_toplevel = toplevel; + } + + if (target != x_dnd_last_seen_window) + { + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1 + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_LEAVE); + lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + lmsg.zero = 0; + lmsg.timestamp = timestamp; + lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + if (x_dnd_motif_setup_p) + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &lmsg); + } + + x_dnd_action = None; + x_dnd_last_seen_window = target; + x_dnd_last_protocol_version = target_proto; + x_dnd_last_motif_style = motif_style; + + if (target != None && x_dnd_last_protocol_version != -1) + x_dnd_send_enter (x_dnd_frame, target, + x_dnd_last_protocol_version); + else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + emsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_ENTER); + emsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + emsg.zero = 0; + emsg.timestamp = timestamp; + emsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + emsg.index_atom = dpyinfo->Xatom_XdndSelection; + + if (x_dnd_motif_setup_p) + xm_send_top_level_enter_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &emsg); + } + } + + if (x_dnd_last_protocol_version != -1 && target != None) + x_dnd_send_position (x_dnd_frame, target, + x_dnd_last_protocol_version, + root_x, root_y, + x_dnd_selection_timestamp, + x_dnd_wanted_action, 0, +#ifdef HAVE_XKB + x_dnd_keyboard_state +#else + 0 +#endif + ); + else if (XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && target != None) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + (!x_dnd_xm_use_help + ? XM_DROP_ACTION_DROP + : XM_DROP_ACTION_DROP_HELP)); + dmsg.timestamp = timestamp; + dmsg.x = root_x; + dmsg.y = root_y; + + if (x_dnd_motif_setup_p) + xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &dmsg); + } + } + /* The pointer moved out of the screen. */ + else if (x_dnd_last_protocol_version != -1) + { + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1) + x_dnd_send_leave (x_dnd_frame, + x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) + && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE + && x_dnd_motif_setup_p) + { + dsmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + dsmsg.timestamp = timestamp; + dsmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_ACTION_DROP_CANCEL); + dsmsg.x = 0; + dsmsg.y = 0; + dsmsg.index_atom + = FRAME_DISPLAY_INFO (x_dnd_frame)->Xatom_XdndSelection; + dsmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + x_dnd_send_xm_leave_for_drop (dpyinfo, x_dnd_frame, + x_dnd_last_seen_window, timestamp); + xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &dsmsg); + } + + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; + x_dnd_last_seen_toplevel = None; + x_dnd_in_progress = false; + x_dnd_waiting_for_finish = false; + x_dnd_frame = NULL; + } +} + /* Handles the XEvent EVENT on display DPYINFO. *FINISH is X_EVENT_GOTO_OUT if caller should stop reading events. @@ -10015,10 +14136,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, XEvent configureEvent; XEvent next_event; Lisp_Object coding; -#if defined USE_MOTIF && defined HAVE_XINPUT2 - /* Some XInput 2 events are important for Motif menu bars to work - correctly, so they must be translated into core events before - being passed to XtDispatchEvent. */ +#if defined USE_X_TOOLKIT && defined HAVE_XINPUT2 + /* Some XInput 2 events are important for Motif and Lucid menu bars + to work correctly, so they must be translated into core events + before being passed to XtDispatchEvent. */ bool use_copy = false; XEvent copy; #elif defined USE_GTK && !defined HAVE_GTK3 && defined HAVE_XINPUT2 @@ -10055,6 +14176,115 @@ handle_one_xevent (struct x_display_info *dpyinfo, { case ClientMessage: { + if (x_dnd_in_progress + && FRAME_DISPLAY_INFO (x_dnd_frame) == dpyinfo + && event->xclient.message_type == dpyinfo->Xatom_XdndStatus) + { + Window target; + + target = event->xclient.data.l[0]; + + if (x_dnd_last_protocol_version != -1 + && target == x_dnd_last_seen_window + && event->xclient.data.l[1] & 2) + { + x_dnd_mouse_rect_target = target; + x_dnd_mouse_rect.x = (event->xclient.data.l[2] & 0xffff0000) >> 16; + x_dnd_mouse_rect.y = (event->xclient.data.l[2] & 0xffff); + x_dnd_mouse_rect.width = (event->xclient.data.l[3] & 0xffff0000) >> 16; + x_dnd_mouse_rect.height = (event->xclient.data.l[3] & 0xffff); + } + else + x_dnd_mouse_rect_target = None; + + if (x_dnd_last_protocol_version != -1 + && target == x_dnd_last_seen_window) + { + if (event->xclient.data.l[1] & 1) + { + if (x_dnd_last_protocol_version >= 2) + x_dnd_action = event->xclient.data.l[4]; + else + x_dnd_action = dpyinfo->Xatom_XdndActionCopy; + } + else + x_dnd_action = None; + } + + goto done; + } + + if (event->xclient.message_type == dpyinfo->Xatom_XdndFinished + && (x_dnd_waiting_for_finish && !x_dnd_waiting_for_motif_finish) + /* Also check that the display is correct, since + `x_dnd_pending_finish_target' could still be valid on + another X server. */ + && dpyinfo->display == x_dnd_finish_display + && event->xclient.data.l[0] == x_dnd_pending_finish_target) + { + x_dnd_waiting_for_finish = false; + + if (x_dnd_waiting_for_finish_proto >= 5) + x_dnd_action = event->xclient.data.l[2]; + + if (x_dnd_waiting_for_finish_proto >= 5 + && !(event->xclient.data.l[1] & 1)) + x_dnd_action = None; + + goto done; + } + + if ((event->xclient.message_type + == dpyinfo->Xatom_MOTIF_DRAG_AND_DROP_MESSAGE) + && x_dnd_waiting_for_finish + && x_dnd_waiting_for_motif_finish == 1 + && dpyinfo == x_dnd_waiting_for_motif_finish_display) + { + xm_drop_start_reply reply; + uint16_t operation, status, action; + + if (!xm_read_drop_start_reply (event, &reply)) + { + operation = XM_DRAG_SIDE_EFFECT_OPERATION (reply.side_effects); + status = XM_DRAG_SIDE_EFFECT_SITE_STATUS (reply.side_effects); + action = XM_DRAG_SIDE_EFFECT_DROP_ACTION (reply.side_effects); + + if (operation != XM_DRAG_MOVE + && operation != XM_DRAG_COPY + && operation != XM_DRAG_LINK) + { + x_dnd_waiting_for_finish = false; + goto done; + } + + if (status != XM_DROP_SITE_VALID + || (action == XM_DROP_ACTION_DROP_CANCEL + || action == XM_DROP_ACTION_DROP_HELP)) + { + x_dnd_waiting_for_finish = false; + goto done; + } + + switch (operation) + { + case XM_DRAG_MOVE: + x_dnd_action = dpyinfo->Xatom_XdndActionMove; + break; + + case XM_DRAG_COPY: + x_dnd_action = dpyinfo->Xatom_XdndActionCopy; + break; + + case XM_DRAG_LINK: + x_dnd_action = dpyinfo->Xatom_XdndActionLink; + break; + } + + x_dnd_waiting_for_motif_finish = 2; + goto done; + } + } + if (event->xclient.message_type == dpyinfo->Xatom_wm_protocols && event->xclient.format == 32) { @@ -10153,7 +14383,19 @@ handle_one_xevent (struct x_display_info *dpyinfo, send_event.xclient.window = dpyinfo->root_window; XSendEvent (dpyinfo->display, dpyinfo->root_window, False, - SubstructureRedirectMask | SubstructureNotifyMask, + /* FIXME: handling window stacking changes + during drag-and-drop requires Emacs to + select for SubstructureNotifyMask, + which in turn causes the message to be + sent to Emacs itself using the event + mask specified by the EWMH. To avoid + an infinite loop, just use + SubstructureRedirectMask when a + drag-and-drop operation is in + progress. */ + ((x_dnd_in_progress || x_dnd_waiting_for_finish) + ? SubstructureRedirectMask + : SubstructureRedirectMask | SubstructureNotifyMask), &send_event); *finish = X_EVENT_DROP; @@ -10239,9 +14481,13 @@ handle_one_xevent (struct x_display_info *dpyinfo, { f = any; if (f) - _XEditResCheckMessages (f->output_data.x->widget, - NULL, (XEvent *) event, NULL); - goto done; + { + _XEditResCheckMessages (f->output_data.x->widget, + NULL, (XEvent *) event, NULL); + goto done; + } + + goto OTHER; } #endif /* X_TOOLKIT_EDITRES */ @@ -10339,12 +14585,93 @@ handle_one_xevent (struct x_display_info *dpyinfo, SELECTION_EVENT_TARGET (&inev.sie) = eventp->target; SELECTION_EVENT_PROPERTY (&inev.sie) = eventp->property; SELECTION_EVENT_TIME (&inev.sie) = eventp->time; + + /* If drag-and-drop is in progress, handle SelectionRequest + events immediately, by setting hold_quit to the input + event. */ + + if (x_dnd_in_progress || x_dnd_waiting_for_finish) + { + eassume (hold_quit); + + *hold_quit = inev.ie; + EVENT_INIT (inev.ie); + } + + if (x_dnd_waiting_for_finish + && x_dnd_waiting_for_motif_finish == 2 + && dpyinfo == x_dnd_waiting_for_motif_finish_display + && eventp->selection == dpyinfo->Xatom_XdndSelection + && (eventp->target == dpyinfo->Xatom_XmTRANSFER_SUCCESS + || eventp->target == dpyinfo->Xatom_XmTRANSFER_FAILURE)) + x_dnd_waiting_for_finish = false; } break; case PropertyNotify: + if (x_dnd_in_progress && x_dnd_use_toplevels + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame) + && event->xproperty.atom == dpyinfo->Xatom_wm_state) + { + struct x_client_list_window *tem, *last; + + for (last = NULL, tem = x_dnd_toplevels; tem; + last = tem, tem = tem->next) + { + if (tem->window == event->xproperty.window) + { + Atom actual_type; + int actual_format, rc; + unsigned long nitems, bytesafter; + unsigned char *data = NULL; + + + if (event->xproperty.state == PropertyDelete) + { + if (!last) + x_dnd_toplevels = tem->next; + else + last->next = tem->next; + +#ifdef HAVE_XSHAPE + if (tem->n_input_rects != -1) + xfree (tem->input_rects); + if (tem->n_bounding_rects != -1) + xfree (tem->bounding_rects); +#endif + xfree (tem); + } + else + { + x_catch_errors (dpyinfo->display); + rc = XGetWindowProperty (dpyinfo->display, + event->xproperty.window, + dpyinfo->Xatom_wm_state, + 0, 2, False, AnyPropertyType, + &actual_type, &actual_format, + &nitems, &bytesafter, &data); + + if (!x_had_errors_p (dpyinfo->display) && rc == Success && data + && nitems == 2 && actual_format == 32) + tem->wm_state = ((unsigned long *) data)[0]; + else + tem->wm_state = WithdrawnState; + + if (data) + XFree (data); + x_uncatch_errors_after_check (); + } + + x_dnd_update_state (dpyinfo, event->xproperty.time); + break; + } + } + } + f = x_top_window_to_frame (dpyinfo, event->xproperty.window); - if (f && event->xproperty.atom == dpyinfo->Xatom_net_wm_state) + if (f && event->xproperty.atom == dpyinfo->Xatom_net_wm_state + /* This should never happen with embedded windows. */ + && !FRAME_X_EMBEDDED_P (f)) { bool not_hidden = x_handle_net_wm_state (f, &event->xproperty); @@ -10387,6 +14714,26 @@ handle_one_xevent (struct x_display_info *dpyinfo, } } + if (event->xproperty.window == dpyinfo->root_window + && (event->xproperty.atom == dpyinfo->Xatom_net_client_list_stacking + || event->xproperty.atom == dpyinfo->Xatom_net_current_desktop) + && x_dnd_in_progress + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + { + if (x_dnd_use_toplevels) + { + x_dnd_free_toplevels (); + + if (x_dnd_compute_toplevels (dpyinfo)) + { + x_dnd_free_toplevels (); + x_dnd_use_toplevels = false; + } + } + + x_dnd_update_state (dpyinfo, event->xproperty.time); + } + x_handle_property_notify (&event->xproperty); xft_settings_event (dpyinfo, event); goto OTHER; @@ -10450,8 +14797,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, SET_FRAME_ICONIFIED (f, false); } +#ifdef HAVE_XDBE if (FRAME_X_DOUBLE_BUFFERED_P (f)) x_drop_xrender_surfaces (f); +#endif f->output_data.x->has_been_visible = true; SET_FRAME_GARBAGED (f); unblock_input (); @@ -10476,6 +14825,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (!FRAME_GARBAGED_P (f)) { +#ifdef USE_X_TOOLKIT + if (f->output_data.x->edit_widget) + /* The widget's expose proc will be run in this + case. */ + goto OTHER; +#endif #ifdef USE_GTK /* This seems to be needed for GTK 2.6 and later, see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=15398. */ @@ -10490,8 +14845,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif } +#ifdef HAVE_XDBE if (!FRAME_GARBAGED_P (f)) show_back_buffer (f); +#endif } else { @@ -10539,8 +14896,20 @@ handle_one_xevent (struct x_display_info *dpyinfo, #ifdef USE_GTK x_clear_under_internal_border (f); #endif +#ifdef HAVE_XDBE show_back_buffer (f); +#endif } +#ifndef USE_TOOLKIT_SCROLL_BARS + struct scroll_bar *bar + = x_window_to_scroll_bar (dpyinfo->display, + /* Hopefully this is just a window, + not the back buffer. */ + event->xgraphicsexpose.drawable, 2); + + if (bar) + x_scroll_bar_expose (bar, event); +#endif #ifdef USE_X_TOOLKIT else goto OTHER; @@ -10556,6 +14925,20 @@ handle_one_xevent (struct x_display_info *dpyinfo, break; case UnmapNotify: + if (x_dnd_in_progress && x_dnd_use_toplevels + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + { + for (struct x_client_list_window *tem = x_dnd_toplevels; tem; + tem = tem->next) + { + if (tem->window == event->xunmap.window) + { + tem->mapped_p = false; + break; + } + } + } + /* Redo the mouse-highlight after the tooltip has gone. */ if (event->xunmap.window == tip_window) { @@ -10569,6 +14952,34 @@ handle_one_xevent (struct x_display_info *dpyinfo, { bool visible = FRAME_VISIBLE_P (f); +#ifdef USE_LUCID + /* Bloodcurdling hack alert: The Lucid menu bar widget's + redisplay procedure is not called when a tip frame over + menu items is unmapped. Redisplay the menu manually... */ + if (FRAME_TOOLTIP_P (f) && popup_activated ()) + { + Widget w; + Lisp_Object tail, frame; + struct frame *f1; + + FOR_EACH_FRAME (tail, frame) + { + if (!FRAME_X_P (XFRAME (frame))) + continue; + + f1 = XFRAME (frame); + + if (FRAME_LIVE_P (f1)) + { + w = FRAME_X_OUTPUT (f1)->menubar_widget; + + if (w && !DoesSaveUnders (FRAME_DISPLAY_INFO (f1)->screen)) + xlwmenu_redisplay (w); + } + } + } +#endif /* USE_LUCID */ + /* While a frame is unmapped, display generation is disabled; you don't want to spend time updating a display that won't ever be seen. */ @@ -10600,6 +15011,25 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (xg_is_menu_window (dpyinfo->display, event->xmap.window)) popup_activated_flag = 1; #endif + + if (x_dnd_in_progress + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + x_dnd_update_state (dpyinfo, dpyinfo->last_user_time); + + if (x_dnd_in_progress && x_dnd_use_toplevels + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + { + for (struct x_client_list_window *tem = x_dnd_toplevels; tem; + tem = tem->next) + { + if (tem->window == event->xmap.window) + { + tem->mapped_p = true; + break; + } + } + } + /* We use x_top_window_to_frame because map events can come for sub-windows and they don't mean that the frame is visible. */ @@ -10649,7 +15079,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_set_z_group (f, Qbelow, Qnil); } - if (not_hidden) + /* Embedded frames might have NET_WM_STATE left over, but + are always visible once mapped. */ + if (not_hidden || FRAME_X_EMBEDDED_P (f)) { SET_FRAME_VISIBLE (f, 1); SET_FRAME_ICONIFIED (f, false); @@ -10668,7 +15100,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_update_opaque_region (f, NULL); - if (not_hidden && iconified) + if ((not_hidden || FRAME_X_EMBEDDED_P (f)) && iconified) { inev.ie.kind = DEICONIFY_EVENT; XSETFRAME (inev.ie.frame_or_window, f); @@ -10741,6 +15173,24 @@ handle_one_xevent (struct x_display_info *dpyinfo, `event' itself. */ XKeyEvent xkey = event->xkey; int i; +#ifdef HAVE_XINPUT2 + Time pending_keystroke_time; + struct xi_device_t *source; + + pending_keystroke_time = dpyinfo->pending_keystroke_time; + + if (event->xkey.time >= pending_keystroke_time) + { +#if defined USE_GTK && !defined HAVE_GTK3 + if (!dpyinfo->pending_keystroke_time_special_p) +#endif + dpyinfo->pending_keystroke_time = 0; +#if defined USE_GTK && !defined HAVE_GTK3 + else + dpyinfo->pending_keystroke_time_special_p = false; +#endif + } +#endif #ifdef USE_GTK /* Don't pass keys to GTK. A Tab will shift focus to the @@ -10834,6 +15284,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, &compose_status); #endif +#ifdef XK_F1 + if (x_dnd_in_progress && keysym == XK_F1) + { + x_dnd_xm_use_help = true; + goto done_keysym; + } +#endif + /* If not using XIM/XIC, and a compose sequence is in progress, we break here. Otherwise, chars_matched is always 0. */ if (compose_status.chars_matched > 0 && nbytes == 0) @@ -10842,19 +15300,31 @@ handle_one_xevent (struct x_display_info *dpyinfo, memset (&compose_status, 0, sizeof (compose_status)); orig_keysym = keysym; - /* Common for all keysym input events. */ - XSETFRAME (inev.ie.frame_or_window, f); - inev.ie.modifiers - = x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), modifiers); - inev.ie.timestamp = xkey.time; + /* Common for all keysym input events. */ + XSETFRAME (inev.ie.frame_or_window, f); + inev.ie.modifiers + = x_x_to_emacs_modifiers (FRAME_DISPLAY_INFO (f), modifiers); + inev.ie.timestamp = xkey.time; + + /* First deal with keysyms which have defined + translations to characters. */ + if (keysym >= 32 && keysym < 128) + /* Avoid explicitly decoding each ASCII character. */ + { + inev.ie.kind = ASCII_KEYSTROKE_EVENT; + inev.ie.code = keysym; + +#ifdef HAVE_XINPUT2 + if (event->xkey.time == pending_keystroke_time) + { + source = xi_device_from_id (dpyinfo, + dpyinfo->pending_keystroke_source); + + if (source) + inev.ie.device = source->name; + } +#endif - /* First deal with keysyms which have defined - translations to characters. */ - if (keysym >= 32 && keysym < 128) - /* Avoid explicitly decoding each ASCII character. */ - { - inev.ie.kind = ASCII_KEYSTROKE_EVENT; - inev.ie.code = keysym; goto done_keysym; } @@ -10866,6 +15336,18 @@ handle_one_xevent (struct x_display_info *dpyinfo, else inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT; inev.ie.code = keysym & 0xFFFFFF; + +#ifdef HAVE_XINPUT2 + if (event->xkey.time == pending_keystroke_time) + { + source = xi_device_from_id (dpyinfo, + dpyinfo->pending_keystroke_source); + + if (source) + inev.ie.device = source->name; + } +#endif + goto done_keysym; } @@ -10875,16 +15357,28 @@ handle_one_xevent (struct x_display_info *dpyinfo, Vx_keysym_table, Qnil), FIXNATP (c))) - { + { inev.ie.kind = (SINGLE_BYTE_CHAR_P (XFIXNAT (c)) ? ASCII_KEYSTROKE_EVENT : MULTIBYTE_CHAR_KEYSTROKE_EVENT); inev.ie.code = XFIXNAT (c); - goto done_keysym; - } - /* Random non-modifier sorts of keysyms. */ - if (((keysym >= XK_BackSpace && keysym <= XK_Escape) +#ifdef HAVE_XINPUT2 + if (event->xkey.time == pending_keystroke_time) + { + source = xi_device_from_id (dpyinfo, + dpyinfo->pending_keystroke_source); + + if (source) + inev.ie.device = source->name; + } +#endif + + goto done_keysym; + } + + /* Random non-modifier sorts of keysyms. */ + if (((keysym >= XK_BackSpace && keysym <= XK_Escape) || keysym == XK_Delete #ifdef XK_ISO_Left_Tab || (keysym >= XK_ISO_Left_Tab @@ -10984,6 +15478,18 @@ handle_one_xevent (struct x_display_info *dpyinfo, key. */ inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT; inev.ie.code = keysym; + +#ifdef HAVE_XINPUT2 + if (event->xkey.time == pending_keystroke_time) + { + source = xi_device_from_id (dpyinfo, + dpyinfo->pending_keystroke_source); + + if (source) + inev.ie.device = source->name; + } +#endif + goto done_keysym; } @@ -11002,6 +15508,22 @@ handle_one_xevent (struct x_display_info *dpyinfo, Fput_text_property (make_fixnum (0), make_fixnum (nbytes), Qcoding, coding, inev.ie.arg); + +#ifdef HAVE_XINPUT2 + if (event->xkey.time == pending_keystroke_time + /* I-Bus sometimes sends events generated from + multiple filtered keystrokes with a time of 0, + so just use the recorded source device if it + exists. */ + || (pending_keystroke_time && !event->xkey.time)) + { + source = xi_device_from_id (dpyinfo, + dpyinfo->pending_keystroke_source); + + if (source) + inev.ie.device = source->name; + } +#endif } if (keysym == NoSymbol) @@ -11010,6 +15532,15 @@ handle_one_xevent (struct x_display_info *dpyinfo, } done_keysym: #ifdef HAVE_X_I18N + if (f) + { + struct window *w = XWINDOW (f->selected_window); + xic_set_preeditarea (w, w->cursor.x, w->cursor.y); + + if (FRAME_XIC (f) && (FRAME_XIC_STYLE (f) & XIMStatusArea)) + xic_set_statusarea (f); + } + /* Don't dispatch this event since XtDispatchEvent calls XFilterEvent, and two calls in a row may freeze the client. */ @@ -11062,17 +15593,21 @@ handle_one_xevent (struct x_display_info *dpyinfo, f = any; if (f && x_mouse_click_focus_ignore_position) - ignore_next_mouse_click_timeout = event->xmotion.time + 200; + { + ignore_next_mouse_click_timeout = event->xmotion.time + 200; + mouse_click_timeout_display = dpyinfo; + } /* EnterNotify counts as mouse movement, so update things that depend on mouse position. */ if (f && !f->output_data.x->hourglass_p) - x_note_mouse_movement (f, &event->xmotion); + x_note_mouse_movement (f, &event->xmotion, Qnil); #ifdef USE_GTK /* We may get an EnterNotify on the buttons in the toolbar. In that case we moved out of any highlighted area and need to note this. */ if (!f && dpyinfo->last_mouse_glyph_frame) - x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &event->xmotion); + x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &event->xmotion, + Qnil); #endif goto OTHER; @@ -11136,10 +15671,11 @@ handle_one_xevent (struct x_display_info *dpyinfo, #else f = x_top_window_to_frame (dpyinfo, event->xcrossing.window); #endif -#if defined USE_X_TOOLKIT && defined HAVE_XINPUT2 +#if defined USE_X_TOOLKIT && defined HAVE_XINPUT2 && !defined USE_MOTIF /* The XI2 event mask is set on the frame widget, so this event likely originates from the shell widget, which we aren't - interested in. */ + interested in. (But don't ignore this on Motif, since we + want to clear the mouse face when a popup is active.) */ if (dpyinfo->supports_xi2) f = NULL; #endif @@ -11163,7 +15699,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, #ifdef USE_GTK /* See comment in EnterNotify above */ else if (dpyinfo->last_mouse_glyph_frame) - x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &event->xmotion); + x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, + &event->xmotion, Qnil); #endif goto OTHER; @@ -11173,6 +15710,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, case MotionNotify: { + XMotionEvent xmotion = event->xmotion; + previous_help_echo_string = help_echo_string; help_echo_string = Qnil; @@ -11184,6 +15723,184 @@ handle_one_xevent (struct x_display_info *dpyinfo, f = mouse_or_wdesc_frame (dpyinfo, event->xmotion.window); + if (x_dnd_in_progress + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + { + Window target, toplevel; + int target_proto, motif_style; + xm_top_level_leave_message lmsg; + xm_top_level_enter_message emsg; + xm_drag_motion_message dmsg; + + /* Sometimes the drag-and-drop operation starts with the + pointer of a frame invisible due to input. Since + motion events are ignored during that, make the pointer + visible manually. */ + + if (f) + XTtoggle_invisible_pointer (f, false); + + target = x_dnd_get_target_window (dpyinfo, + event->xmotion.x_root, + event->xmotion.y_root, + &target_proto, + &motif_style, &toplevel); + + if (toplevel != x_dnd_last_seen_toplevel) + { + if (toplevel != FRAME_OUTER_WINDOW (x_dnd_frame) + && x_dnd_return_frame == 1) + x_dnd_return_frame = 2; + + if (x_dnd_return_frame == 2 + && x_any_window_to_frame (dpyinfo, toplevel)) + { + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1 + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_LEAVE); + lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + lmsg.zero = 0; + lmsg.timestamp = event->xmotion.time; + lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + if (x_dnd_motif_setup_p) + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &lmsg); + } + + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; + x_dnd_last_seen_toplevel = None; + x_dnd_in_progress = false; + x_dnd_return_frame_object + = x_any_window_to_frame (dpyinfo, toplevel); + x_dnd_return_frame = 3; + x_dnd_waiting_for_finish = false; + target = None; + } + + x_dnd_last_seen_toplevel = toplevel; + } + + if (target != x_dnd_last_seen_window) + { + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1 + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + /* This is apparently required. If we don't send + a motion event with the current root window + coordinates of the pointer before the top level + leave, then Motif displays an ugly black border + around the previous drop site. */ + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + dmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_NONE, XM_DRAG_NOOP, + XM_DROP_ACTION_DROP_CANCEL); + dmsg.timestamp = event->xmotion.time; + dmsg.x = event->xmotion.x_root; + dmsg.y = event->xmotion.y_root; + + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_LEAVE); + lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + lmsg.zero = 0; + lmsg.timestamp = event->xbutton.time; + lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + if (x_dnd_motif_setup_p) + { + xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &dmsg); + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &lmsg); + } + } + + x_dnd_action = None; + x_dnd_last_seen_window = target; + x_dnd_last_protocol_version = target_proto; + x_dnd_last_motif_style = motif_style; + + if (target != None && x_dnd_last_protocol_version != -1) + x_dnd_send_enter (x_dnd_frame, target, + x_dnd_last_protocol_version); + else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + emsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_ENTER); + emsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + emsg.zero = 0; + emsg.timestamp = event->xbutton.time; + emsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + emsg.index_atom = dpyinfo->Xatom_XdndSelection; + + if (x_dnd_motif_setup_p) + xm_send_top_level_enter_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &emsg); + } + } + + if (x_dnd_last_protocol_version != -1 && target != None) + x_dnd_send_position (x_dnd_frame, target, + x_dnd_last_protocol_version, + event->xmotion.x_root, + event->xmotion.y_root, + x_dnd_selection_timestamp, + x_dnd_wanted_action, 0, + event->xmotion.state); + else if (XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && target != None) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + dmsg.side_effects = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + (!x_dnd_xm_use_help + ? XM_DROP_ACTION_DROP + : XM_DROP_ACTION_DROP_HELP)); + dmsg.timestamp = event->xbutton.time; + dmsg.x = event->xmotion.x_root; + dmsg.y = event->xmotion.y_root; + + if (x_dnd_motif_setup_p) + xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &dmsg); + } + + goto OTHER; + } + #ifdef USE_GTK if (f && xg_event_is_for_scrollbar (f, event, false)) f = 0; @@ -11213,8 +15930,18 @@ handle_one_xevent (struct x_display_info *dpyinfo, || !NILP (focus_follows_mouse))) { static Lisp_Object last_mouse_window; + + if (xmotion.window != FRAME_X_WINDOW (f)) + { + XTranslateCoordinates (FRAME_X_DISPLAY (f), + xmotion.window, FRAME_X_WINDOW (f), + xmotion.x, xmotion.y, &xmotion.x, + &xmotion.y, &xmotion.subwindow); + xmotion.window = FRAME_X_WINDOW (f); + } + Lisp_Object window = window_from_coordinates - (f, event->xmotion.x, event->xmotion.y, 0, false, false); + (f, xmotion.x, xmotion.y, 0, false, false); /* A window will be autoselected only when it is not selected now and the last mouse movement event was @@ -11236,7 +15963,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, last_mouse_window = window; } - if (!x_note_mouse_movement (f, &event->xmotion)) + if (!x_note_mouse_movement (f, &xmotion, Qnil)) help_echo_string = previous_help_echo_string; } else @@ -11294,6 +16021,101 @@ handle_one_xevent (struct x_display_info *dpyinfo, configureEvent = next_event; } + if (x_dnd_in_progress && x_dnd_use_toplevels + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + { + int rc, dest_x, dest_y; + Window child; + struct x_client_list_window *tem, *last = NULL; + + for (tem = x_dnd_toplevels; tem; last = tem, tem = tem->next) + { + /* Not completely right, since the parent could be + unmapped, but good enough. */ + + if (tem->window == configureEvent.xconfigure.window) + { + x_catch_errors (dpyinfo->display); + rc = (XTranslateCoordinates (dpyinfo->display, + configureEvent.xconfigure.window, + dpyinfo->root_window, + -configureEvent.xconfigure.border_width, + -configureEvent.xconfigure.border_width, + &dest_x, &dest_y, &child) + && !x_had_errors_p (dpyinfo->display)); + x_uncatch_errors_after_check (); + + if (rc) + { + tem->x = dest_x; + tem->y = dest_y; + tem->width = (configureEvent.xconfigure.width + + configureEvent.xconfigure.border_width); + tem->height = (configureEvent.xconfigure.height + + configureEvent.xconfigure.border_width); + } + else + { + /* The window was probably destroyed, so get rid + of it. */ + + if (!last) + x_dnd_toplevels = tem->next; + else + last->next = tem->next; + +#ifdef HAVE_XSHAPE + if (tem->n_input_rects != -1) + xfree (tem->input_rects); + if (tem->n_bounding_rects != -1) + xfree (tem->bounding_rects); +#endif + xfree (tem); + } + + break; + } + } + } + +#if defined HAVE_GTK3 && defined USE_TOOLKIT_SCROLL_BARS + struct scroll_bar *bar = x_window_to_scroll_bar (dpyinfo->display, + configureEvent.xconfigure.window, 2); + + /* There is really no other way to make GTK scroll bars fit + in the dimensions we want them to. */ + if (bar) + { + /* Skip all the pending configure events, not just the + ones where window motion occurred. */ + while (XPending (dpyinfo->display)) + { + XNextEvent (dpyinfo->display, &next_event); + if (next_event.type != ConfigureNotify + || next_event.xconfigure.window != event->xconfigure.window) + { + XPutBackEvent (dpyinfo->display, &next_event); + break; + } + else + configureEvent = next_event; + } + + if (configureEvent.xconfigure.width != max (bar->width, 1) + || configureEvent.xconfigure.height != max (bar->height, 1)) + { + XResizeWindow (dpyinfo->display, bar->x_window, + max (bar->width, 1), max (bar->height, 1)); + x_flush (WINDOW_XFRAME (XWINDOW (bar->window))); + } + + if (f && FRAME_X_DOUBLE_BUFFERED_P (f)) + x_drop_xrender_surfaces (f); + + goto OTHER; + } +#endif + f = x_top_window_to_frame (dpyinfo, configureEvent.xconfigure.window); /* Unfortunately, we need to call x_drop_xrender_surfaces for _all_ ConfigureNotify events, otherwise we miss some and @@ -11301,8 +16123,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, for size changes: that's not sufficient. We miss some surface invalidations and flicker. */ block_input (); +#ifdef HAVE_XDBE if (f && FRAME_X_DOUBLE_BUFFERED_P (f)) x_drop_xrender_surfaces (f); +#endif unblock_input (); #if defined USE_CAIRO && !defined USE_GTK if (f) @@ -11390,6 +16214,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, /* Even if the number of character rows and columns has not changed, the font size may have changed, so we need to check the pixel dimensions as well. */ + if (width != FRAME_PIXEL_WIDTH (f) || height != FRAME_PIXEL_HEIGHT (f) || (f->new_size_p @@ -11441,17 +16266,21 @@ handle_one_xevent (struct x_display_info *dpyinfo, #ifdef HAVE_X_I18N - if (FRAME_XIC (f) && (FRAME_XIC_STYLE (f) & XIMStatusArea)) - xic_set_statusarea (f); - if (f) { + if (FRAME_XIC (f) && (FRAME_XIC_STYLE (f) & XIMStatusArea)) + xic_set_statusarea (f); + struct window *w = XWINDOW (f->selected_window); xic_set_preeditarea (w, w->cursor.x, w->cursor.y); } #endif } + + if (x_dnd_in_progress + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + x_dnd_update_state (dpyinfo, dpyinfo->last_user_time); goto OTHER; case ButtonRelease: @@ -11485,6 +16314,138 @@ handle_one_xevent (struct x_display_info *dpyinfo, Lisp_Object tab_bar_arg = Qnil; bool tab_bar_p = false; bool tool_bar_p = false; + bool dnd_grab = false; + + if (x_dnd_in_progress + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + { + if (event->xbutton.type == ButtonPress + && x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1) + { + x_dnd_send_position (x_dnd_frame, + x_dnd_last_seen_window, + x_dnd_last_protocol_version, + event->xbutton.x_root, + event->xbutton.y_root, + x_dnd_selection_timestamp, + x_dnd_wanted_action, + event->xbutton.button, + event->xbutton.state); + + goto OTHER; + } + + if (event->xbutton.type == ButtonRelease) + { + for (int i = 1; i < 8; ++i) + { + if (i != event->xbutton.button + && event->xbutton.state & (Button1Mask << (i - 1))) + dnd_grab = true; + } + + if (!dnd_grab) + { + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_in_progress = false; + + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1) + { + x_dnd_pending_finish_target = x_dnd_last_seen_window; + x_dnd_waiting_for_finish_proto = x_dnd_last_protocol_version; + + x_dnd_waiting_for_finish + = x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_selection_timestamp, + x_dnd_last_protocol_version); + x_dnd_finish_display = dpyinfo->display; + } + else if (x_dnd_last_seen_window != None) + { + xm_drop_start_message dmsg; + xm_drag_receiver_info drag_receiver_info; + + if (!xm_read_drag_receiver_info (dpyinfo, x_dnd_last_seen_window, + &drag_receiver_info) + && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE + && (x_dnd_allow_current_frame + || x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + if (x_dnd_motif_setup_p) + { + memset (&dmsg, 0, sizeof dmsg); + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byte_order = XM_BYTE_ORDER_CUR_FIRST; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + (!x_dnd_xm_use_help + ? XM_DROP_ACTION_DROP + : XM_DROP_ACTION_DROP_HELP)); + dmsg.timestamp = event->xbutton.time; + dmsg.x = event->xbutton.x_root; + dmsg.y = event->xbutton.y_root; + dmsg.index_atom = dpyinfo->Xatom_XdndSelection; + dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + if (!XM_DRAG_STYLE_IS_DROP_ONLY (drag_receiver_info.protocol_style)) + x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (x_dnd_frame), + x_dnd_frame, x_dnd_last_seen_window, + event->xbutton.time); + + xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &dmsg); + + x_dnd_waiting_for_finish = true; + x_dnd_waiting_for_motif_finish_display = dpyinfo; + x_dnd_waiting_for_motif_finish = 1; + x_dnd_finish_display = dpyinfo->display; + } + } + else + { + x_set_pending_dnd_time (event->xbutton.time); + x_dnd_send_unsupported_drop (dpyinfo, (x_dnd_last_seen_toplevel != None + ? x_dnd_last_seen_toplevel + : x_dnd_last_seen_window), + event->xbutton.x_root, event->xbutton.y_root, + event->xbutton.time); + } + } + else if (x_dnd_last_seen_toplevel != None) + { + x_set_pending_dnd_time (event->xbutton.time); + x_dnd_send_unsupported_drop (dpyinfo, x_dnd_last_seen_toplevel, + event->xbutton.x_root, + event->xbutton.y_root, + event->xbutton.time); + } + + + x_dnd_last_protocol_version = -1; + x_dnd_last_motif_style = XM_DRAG_STYLE_NONE; + x_dnd_last_seen_window = None; + x_dnd_last_seen_toplevel = None; + x_dnd_frame = NULL; + x_set_dnd_targets (NULL, 0); + } + } + + goto OTHER; + } + + if (x_dnd_in_progress) + goto OTHER; memset (&compose_status, 0, sizeof (compose_status)); dpyinfo->last_mouse_glyph_frame = NULL; @@ -11522,7 +16483,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, && event->xbutton.button < 9 && f) { - if (ignore_next_mouse_click_timeout) + if (ignore_next_mouse_click_timeout + && dpyinfo == mouse_click_timeout_display) { if (event->type == ButtonPress && event->xbutton.time > ignore_next_mouse_click_timeout) @@ -11575,7 +16537,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, int y = event->xbutton.y; window = window_from_coordinates (f, x, y, 0, true, true); - tool_bar_p = EQ (window, f->tool_bar_window); + tool_bar_p = (EQ (window, f->tool_bar_window) + && (event->xbutton.type != ButtonRelease + || f->last_tool_bar_item != -1)); if (tool_bar_p && event->xbutton.button < 4) handle_tool_bar_click @@ -11589,7 +16553,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (! popup_activated ()) #endif { - if (ignore_next_mouse_click_timeout) + if (ignore_next_mouse_click_timeout + && dpyinfo == mouse_click_timeout_display) { if (event->type == ButtonPress && event->xbutton.time > ignore_next_mouse_click_timeout) @@ -11621,12 +16586,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, scroll bars. */ if (bar && event->xbutton.state & ControlMask) { - x_scroll_bar_handle_click (bar, event, &inev.ie); + x_scroll_bar_handle_click (bar, event, &inev.ie, Qnil); *finish = X_EVENT_DROP; } #else /* not USE_TOOLKIT_SCROLL_BARS */ if (bar) - x_scroll_bar_handle_click (bar, event, &inev.ie); + x_scroll_bar_handle_click (bar, event, &inev.ie, Qnil); #endif /* not USE_TOOLKIT_SCROLL_BARS */ } @@ -11671,14 +16636,13 @@ handle_one_xevent (struct x_display_info *dpyinfo, && event->xbutton.same_screen) { #ifdef USE_MOTIF - unsigned char column_type; Widget widget; widget = XtWindowToWidget (dpyinfo->display, event->xbutton.window); - XtVaGetValues (widget, XmNrowColumnType, &column_type, NULL); - if (column_type != XmMENU_BAR) + if (widget && XmIsCascadeButton (widget) + && XtIsSensitive (widget)) { #endif if (!f->output_data.x->saved_menu_event) @@ -11698,6 +16662,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, break; case CirculateNotify: + if (x_dnd_in_progress + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + x_dnd_update_state (dpyinfo, dpyinfo->last_user_time); goto OTHER; case CirculateRequest: @@ -11761,8 +16728,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, case XI_FocusIn: { XIFocusInEvent *focusin = (XIFocusInEvent *) xi_event; + struct xi_device_t *source; any = x_any_window_to_frame (dpyinfo, focusin->event); + source = xi_device_from_id (dpyinfo, focusin->sourceid); #ifdef USE_GTK /* Some WMs (e.g. Mutter in Gnome Shell), don't unmap minimized/iconified windows; thus, for those WMs we won't get @@ -11790,16 +16759,25 @@ handle_one_xevent (struct x_display_info *dpyinfo, XSETFRAME (inev.ie.frame_or_window, f); } } + x_detect_focus_change (dpyinfo, any, event, &inev.ie); + + if (inev.ie.kind != NO_EVENT && source) + inev.ie.device = source->name; goto XI_OTHER; } case XI_FocusOut: { XIFocusOutEvent *focusout = (XIFocusOutEvent *) xi_event; + struct xi_device_t *source; any = x_any_window_to_frame (dpyinfo, focusout->event); + source = xi_device_from_id (dpyinfo, focusout->sourceid); x_detect_focus_change (dpyinfo, any, event, &inev.ie); + + if (inev.ie.kind != NO_EVENT && source) + inev.ie.device = source->name; goto XI_OTHER; } @@ -11807,8 +16785,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, { XIEnterEvent *enter = (XIEnterEvent *) xi_event; XMotionEvent ev; + struct xi_device_t *source; any = x_top_window_to_frame (dpyinfo, enter->event); + source = xi_device_from_id (dpyinfo, enter->sourceid); ev.x = lrint (enter->event_x); ev.y = lrint (enter->event_y); ev.window = enter->event; @@ -11871,17 +16851,21 @@ handle_one_xevent (struct x_display_info *dpyinfo, f = any; if (f && x_mouse_click_focus_ignore_position) - ignore_next_mouse_click_timeout = xi_event->time + 200; + { + ignore_next_mouse_click_timeout = xev->time + 200; + mouse_click_timeout_display = dpyinfo; + } /* EnterNotify counts as mouse movement, so update things that depend on mouse position. */ if (f && !f->output_data.x->hourglass_p) - x_note_mouse_movement (f, &ev); + x_note_mouse_movement (f, &ev, source ? source->name : Qnil); #ifdef USE_GTK /* We may get an EnterNotify on the buttons in the toolbar. In that case we moved out of any highlighted area and need to note this. */ if (!f && dpyinfo->last_mouse_glyph_frame) - x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev); + x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev, + source ? source->name : Qnil); #endif goto XI_OTHER; } @@ -11890,6 +16874,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, { XILeaveEvent *leave = (XILeaveEvent *) xi_event; #ifdef USE_GTK + struct xi_device_t *source; XMotionEvent ev; ev.x = lrint (leave->event_x); @@ -11900,6 +16885,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, any = x_top_window_to_frame (dpyinfo, leave->event); +#ifdef USE_GTK + source = xi_device_from_id (dpyinfo, leave->sourceid); +#endif + /* This allows us to catch LeaveNotify events generated by popup menu grabs. FIXME: this is right when there is a focus menu, but implicit focus tracking can get screwed @@ -12002,14 +16991,15 @@ handle_one_xevent (struct x_display_info *dpyinfo, #ifdef USE_GTK /* See comment in EnterNotify above */ else if (dpyinfo->last_mouse_glyph_frame) - x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev); + x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev, + source ? source->name : Qnil); #endif goto XI_OTHER; } case XI_Motion: { - struct xi_device_t *device; + struct xi_device_t *device, *source; #ifdef HAVE_XINPUT2_1 XIValuatorState *states; double *values; @@ -12017,6 +17007,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif /* A fake XMotionEvent for x_note_mouse_movement. */ XMotionEvent ev; + xm_top_level_leave_message lmsg; + xm_top_level_enter_message emsg; + xm_drag_motion_message dmsg; + int dnd_state; + + source = xi_device_from_id (dpyinfo, xev->sourceid); #ifdef HAVE_XINPUT2_1 states = &xev->valuators; @@ -12033,6 +17029,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto XI_OTHER; #endif + Window dummy; + #ifdef HAVE_XINPUT2_1 #ifdef HAVE_XWIDGETS struct xwidget_view *xv = xwidget_view_from_window (xev->event); @@ -12043,7 +17041,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, double total_y = 0.0; int real_x, real_y; - Window dummy; for (int i = 0; i < states->mask_len * 8; i++) { @@ -12053,11 +17050,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, double delta, scroll_unit; int scroll_height; Lisp_Object window; + struct scroll_bar *bar; + + bar = NULL; /* See the comment on top of x_init_master_valuators for more details on how scroll wheel movement is reported on XInput 2. */ - delta = x_get_scroll_valuator_delta (dpyinfo, xev->deviceid, + delta = x_get_scroll_valuator_delta (dpyinfo, device, i, *values, &val); values++; @@ -12070,9 +17070,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (!f) { #if defined USE_MOTIF || !defined USE_TOOLKIT_SCROLL_BARS - struct scroll_bar *bar - = x_window_to_scroll_bar (xi_event->display, - xev->event, 2); + bar = x_window_to_scroll_bar (dpyinfo->display, + xev->event, 2); if (bar) f = WINDOW_XFRAME (XWINDOW (bar->window)); @@ -12089,11 +17088,26 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif if (FRAME_X_WINDOW (f) != xev->event) - XTranslateCoordinates (dpyinfo->display, - xev->event, FRAME_X_WINDOW (f), - lrint (xev->event_x), - lrint (xev->event_y), - &real_x, &real_y, &dummy); + { + if (!bar) + bar = x_window_to_scroll_bar (dpyinfo->display, xev->event, 2); + + /* If this is a scroll bar, compute the + actual position directly to avoid an + extra roundtrip. */ + + if (bar) + { + real_x = lrint (xev->event_x + bar->left); + real_y = lrint (xev->event_y + bar->top); + } + else + XTranslateCoordinates (dpyinfo->display, + xev->event, FRAME_X_WINDOW (f), + lrint (xev->event_x), + lrint (xev->event_y), + &real_x, &real_y, &dummy); + } else { real_x = lrint (xev->event_x); @@ -12232,6 +17246,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, XSETFRAME (inev.ie.frame_or_window, f); } + if (source && !NILP (source->name)) + inev.ie.device = source->name; + goto XI_OTHER; } #ifdef HAVE_XWIDGETS @@ -12286,12 +17303,212 @@ handle_one_xevent (struct x_display_info *dpyinfo, f = mouse_or_wdesc_frame (dpyinfo, xev->event); + if (x_dnd_in_progress + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + { + Window target, toplevel; + int target_proto, motif_style; + + /* Sometimes the drag-and-drop operation starts with the + pointer of a frame invisible due to input. Since + motion events are ignored during that, make the pointer + visible manually. */ + + if (f) + XTtoggle_invisible_pointer (f, false); + + target = x_dnd_get_target_window (dpyinfo, + xev->root_x, + xev->root_y, + &target_proto, + &motif_style, + &toplevel); + + if (toplevel != x_dnd_last_seen_toplevel) + { + if (toplevel != FRAME_OUTER_WINDOW (x_dnd_frame) + && x_dnd_return_frame == 1) + x_dnd_return_frame = 2; + + if (x_dnd_return_frame == 2 + && x_any_window_to_frame (dpyinfo, toplevel)) + { + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1 + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_LEAVE); + lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + lmsg.zero = 0; + lmsg.timestamp = event->xmotion.time; + lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + if (x_dnd_motif_setup_p) + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &lmsg); + } + + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_last_seen_window = None; + x_dnd_last_seen_toplevel = None; + x_dnd_in_progress = false; + x_dnd_return_frame_object + = x_any_window_to_frame (dpyinfo, toplevel); + x_dnd_return_frame = 3; + x_dnd_waiting_for_finish = false; + target = None; + } + + x_dnd_last_seen_toplevel = toplevel; + } + + if (target != x_dnd_last_seen_window) + { + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1 + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + x_dnd_send_leave (x_dnd_frame, x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) + && x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + /* This is apparently required. If we don't + send a motion event with the current root + window coordinates of the pointer before + the top level leave, then Motif displays + an ugly black border around the previous + drop site. */ + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_NONE, XM_DRAG_NOOP, + XM_DROP_ACTION_DROP_CANCEL); + dmsg.timestamp = xev->time; + dmsg.x = lrint (xev->root_x); + dmsg.y = lrint (xev->root_y); + + lmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_LEAVE); + lmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + lmsg.zero = 0; + lmsg.timestamp = xev->time; + lmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + if (x_dnd_motif_setup_p) + { + xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &dmsg); + xm_send_top_level_leave_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &lmsg); + } + } + + x_dnd_action = None; + x_dnd_last_seen_window = target; + x_dnd_last_protocol_version = target_proto; + x_dnd_last_motif_style = motif_style; + + if (target != None && x_dnd_last_protocol_version != -1) + x_dnd_send_enter (x_dnd_frame, target, + x_dnd_last_protocol_version); + else if (target != None && XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style)) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + emsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_TOP_LEVEL_ENTER); + emsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + emsg.zero = 0; + emsg.timestamp = xev->time; + emsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + emsg.index_atom = dpyinfo->Xatom_XdndSelection; + + if (x_dnd_motif_setup_p) + xm_send_top_level_enter_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &emsg); + } + } + + if (x_dnd_last_protocol_version != -1 && target != None) + { + dnd_state = xev->mods.effective; + + if (xev->buttons.mask_len) + { + if (XIMaskIsSet (xev->buttons.mask, 1)) + dnd_state |= Button1Mask; + if (XIMaskIsSet (xev->buttons.mask, 2)) + dnd_state |= Button2Mask; + if (XIMaskIsSet (xev->buttons.mask, 3)) + dnd_state |= Button3Mask; + } + + x_dnd_send_position (x_dnd_frame, target, + x_dnd_last_protocol_version, + xev->root_x, xev->root_y, + x_dnd_selection_timestamp, + x_dnd_wanted_action, 0, + dnd_state); + } + else if (XM_DRAG_STYLE_IS_DYNAMIC (x_dnd_last_motif_style) && target != None) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DRAG_MOTION); + dmsg.byteorder = XM_BYTE_ORDER_CUR_FIRST; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + (!x_dnd_xm_use_help + ? XM_DROP_ACTION_DROP + : XM_DROP_ACTION_DROP_HELP)); + dmsg.timestamp = xev->time; + dmsg.x = lrint (xev->root_x); + dmsg.y = lrint (xev->root_y); + + if (x_dnd_motif_setup_p) + xm_send_drag_motion_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + target, &dmsg); + } + + goto XI_OTHER; + } + #ifdef USE_GTK if (f && xg_event_is_for_scrollbar (f, event, false)) f = 0; #endif if (f) { + if (xev->event != FRAME_X_WINDOW (f)) + { + XTranslateCoordinates (FRAME_X_DISPLAY (f), + xev->event, FRAME_X_WINDOW (f), + ev.x, ev.y, &ev.x, &ev.y, &dummy); + ev.window = FRAME_X_WINDOW (f); + } + /* Maybe generate a SELECT_WINDOW_EVENT for `mouse-autoselect-window' but don't let popup menus interfere with this (Bug#1261). */ @@ -12325,13 +17542,16 @@ handle_one_xevent (struct x_display_info *dpyinfo, { inev.ie.kind = SELECT_WINDOW_EVENT; inev.ie.frame_or_window = window; + + if (source) + inev.ie.device = source->name; } /* Remember the last window where we saw the mouse. */ last_mouse_window = window; } - if (!x_note_mouse_movement (f, &ev)) + if (!x_note_mouse_movement (f, &ev, source ? source->name : Qnil)) help_echo_string = previous_help_echo_string; } else @@ -12365,12 +17585,158 @@ handle_one_xevent (struct x_display_info *dpyinfo, Lisp_Object tab_bar_arg = Qnil; bool tab_bar_p = false; bool tool_bar_p = false; - struct xi_device_t *device; + struct xi_device_t *device, *source; #ifdef HAVE_XWIDGETS struct xwidget_view *xvw; #endif /* A fake XButtonEvent for x_construct_mouse_click. */ XButtonEvent bv; + bool dnd_grab = false; + int dnd_state; + + if (x_dnd_in_progress + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + { + if (xev->evtype == XI_ButtonPress + && x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1) + { + dnd_state = xev->mods.effective; + + if (xev->buttons.mask_len) + { + if (XIMaskIsSet (xev->buttons.mask, 1)) + dnd_state |= Button1Mask; + if (XIMaskIsSet (xev->buttons.mask, 2)) + dnd_state |= Button2Mask; + if (XIMaskIsSet (xev->buttons.mask, 3)) + dnd_state |= Button3Mask; + } + + x_dnd_send_position (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_last_protocol_version, xev->root_x, + xev->root_y, x_dnd_selection_timestamp, + x_dnd_wanted_action, xev->detail, dnd_state); + + goto XI_OTHER; + } + + if (xev->evtype == XI_ButtonRelease) + { + for (int i = 0; i < xev->buttons.mask_len * 8; ++i) + { + if (i != xev->detail && XIMaskIsSet (xev->buttons.mask, i)) + dnd_grab = true; + } + + if (!dnd_grab) + { + x_dnd_end_window = x_dnd_last_seen_window; + x_dnd_in_progress = false; + + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1) + { + x_dnd_pending_finish_target = x_dnd_last_seen_window; + x_dnd_waiting_for_finish_proto = x_dnd_last_protocol_version; + + x_dnd_waiting_for_finish + = x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_selection_timestamp, + x_dnd_last_protocol_version); + x_dnd_finish_display = dpyinfo->display; + } + else if (x_dnd_last_seen_window != None) + { + xm_drop_start_message dmsg; + xm_drag_receiver_info drag_receiver_info; + + if (!xm_read_drag_receiver_info (dpyinfo, x_dnd_last_seen_window, + &drag_receiver_info) + && drag_receiver_info.protocol_style != XM_DRAG_STYLE_NONE + && (x_dnd_allow_current_frame + || x_dnd_last_seen_window != FRAME_OUTER_WINDOW (x_dnd_frame))) + { + if (!x_dnd_motif_setup_p) + xm_setup_drag_info (dpyinfo, x_dnd_frame); + + if (x_dnd_motif_setup_p) + { + memset (&dmsg, 0, sizeof dmsg); + + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byte_order = XM_BYTE_ORDER_CUR_FIRST; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (dpyinfo, + x_dnd_wanted_action), + (!x_dnd_xm_use_help + ? XM_DROP_ACTION_DROP + : XM_DROP_ACTION_DROP_HELP)); + dmsg.timestamp = xev->time; + dmsg.x = lrint (xev->root_x); + dmsg.y = lrint (xev->root_y); + /* This atom technically has to be + unique to each drag-and-drop + operation, but that isn't easy to + accomplish, since we cannot + randomly move data around between + selections. Let's hope no two + instances of Emacs try to drag + into the same window at the same + time. */ + dmsg.index_atom = dpyinfo->Xatom_XdndSelection; + dmsg.source_window = FRAME_X_WINDOW (x_dnd_frame); + + if (!XM_DRAG_STYLE_IS_DROP_ONLY (drag_receiver_info.protocol_style)) + x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (x_dnd_frame), + x_dnd_frame, x_dnd_last_seen_window, + xev->time); + + xm_send_drop_message (dpyinfo, FRAME_X_WINDOW (x_dnd_frame), + x_dnd_last_seen_window, &dmsg); + + x_dnd_waiting_for_finish = true; + x_dnd_waiting_for_motif_finish_display = dpyinfo; + x_dnd_waiting_for_motif_finish = 1; + x_dnd_finish_display = dpyinfo->display; + } + } + else + { + x_set_pending_dnd_time (xev->time); + x_dnd_send_unsupported_drop (dpyinfo, (x_dnd_last_seen_toplevel != None + ? x_dnd_last_seen_toplevel + : x_dnd_last_seen_window), + xev->root_x, xev->root_y, xev->time); + } + } + else if (x_dnd_last_seen_toplevel != None) + { + x_set_pending_dnd_time (xev->time); + x_dnd_send_unsupported_drop (dpyinfo, + x_dnd_last_seen_toplevel, + xev->root_x, xev->root_y, + xev->time); + } + + x_dnd_last_protocol_version = -1; + x_dnd_last_motif_style = XM_DRAG_STYLE_NONE; + x_dnd_last_seen_window = None; + x_dnd_last_seen_toplevel = None; + x_dnd_frame = NULL; + x_set_dnd_targets (NULL, 0); + + goto XI_OTHER; + } + } + } + + if (x_dnd_in_progress) + goto XI_OTHER; #ifdef USE_MOTIF #ifdef USE_TOOLKIT_SCROLL_BARS @@ -12437,15 +17803,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (popup_activated () && xev->evtype == XI_ButtonRelease) - { - *finish = X_EVENT_DROP; - gtk_main_do_event (copy); - gdk_event_free (copy); - goto XI_OTHER; - } - - gtk_main_do_event (copy); - gdk_event_free (copy); + goto XI_OTHER; #endif #ifdef HAVE_XINPUT2_1 @@ -12466,6 +17824,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (xev->evtype == XI_ButtonPress) x_display_set_last_user_time (dpyinfo, xev->time); + source = xi_device_from_id (dpyinfo, xev->sourceid); + #ifdef HAVE_XWIDGETS xvw = xwidget_view_from_window (xev->event); if (xvw) @@ -12478,6 +17838,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, { inev.ie.kind = SELECT_WINDOW_EVENT; inev.ie.frame_or_window = xvw->w; + + if (source) + inev.ie.device = source->name; } *finish = X_EVENT_DROP; @@ -12547,6 +17910,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, else inev.ie.kind = HORIZ_WHEEL_EVENT; + if (source) + inev.ie.device = source->name; + inev.ie.timestamp = xev->time; XSETINT (inev.ie.x, real_x); @@ -12582,6 +17948,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, else inev.ie.kind = HORIZ_WHEEL_EVENT; + if (source) + inev.ie.device = source->name; + inev.ie.timestamp = xev->time; XSETINT (inev.ie.x, lrint (xev->event_x)); @@ -12625,12 +17994,22 @@ handle_one_xevent (struct x_display_info *dpyinfo, int y = bv.y; window = window_from_coordinates (f, x, y, 0, true, true); - tool_bar_p = EQ (window, f->tool_bar_window); + /* Ignore button release events if the mouse + wasn't previously pressed on the tool bar. + We do this because otherwise selecting some + text with the mouse and then releasing it on + the tool bar doesn't stop selecting text, + since the tool bar eats the button up + event. */ + tool_bar_p = (EQ (window, f->tool_bar_window) + && (xev->evtype != XI_ButtonRelease + || f->last_tool_bar_item != -1)); if (tool_bar_p && xev->detail < 4) - handle_tool_bar_click + handle_tool_bar_click_with_device (f, x, y, xev->evtype == XI_ButtonPress, - x_x_to_emacs_modifiers (dpyinfo, bv.state)); + x_x_to_emacs_modifiers (dpyinfo, bv.state), + source ? source->name : Qt); } #endif /* !USE_GTK */ @@ -12660,17 +18039,27 @@ handle_one_xevent (struct x_display_info *dpyinfo, xembed_send_message (f, xev->time, XEMBED_REQUEST_FOCUS, 0, 0, 0); } -#ifndef USE_TOOLKIT_SCROLL_BARS else { struct scroll_bar *bar = x_window_to_scroll_bar (dpyinfo->display, xev->event, 2); +#ifndef USE_TOOLKIT_SCROLL_BARS if (bar) - x_scroll_bar_handle_click (bar, (XEvent *) &bv, &inev.ie); - } + x_scroll_bar_handle_click (bar, (XEvent *) &bv, &inev.ie, + source ? source->name : Qnil); +#else + /* Make the "Ctrl-Mouse-2 splits window" work for toolkit + scroll bars. */ + if (bar && xev->mods.effective & ControlMask) + { + x_scroll_bar_handle_click (bar, (XEvent *) &bv, &inev.ie, + source ? source->name : Qnil); + *finish = X_EVENT_DROP; + } #endif + } if (xev->evtype == XI_ButtonPress) { @@ -12691,6 +18080,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, device->grab &= ~(1 << xev->detail); } + if (source && inev.ie.kind != NO_EVENT) + inev.ie.device = source->name; + if (f) f->mouse_moved = false; @@ -12729,11 +18121,13 @@ handle_one_xevent (struct x_display_info *dpyinfo, char *copy_bufptr = copy_buffer; int copy_bufsiz = sizeof (copy_buffer); ptrdiff_t i; - struct xi_device_t *device; + uint old_state; + struct xi_device_t *device, *source; coding = Qlatin_1; device = xi_device_from_id (dpyinfo, xev->deviceid); + source = xi_device_from_id (dpyinfo, xev->sourceid); if (!device) goto XI_OTHER; @@ -12741,7 +18135,41 @@ handle_one_xevent (struct x_display_info *dpyinfo, #if defined (USE_X_TOOLKIT) || defined (USE_GTK) /* Dispatch XI_KeyPress events when in menu. */ if (popup_activated ()) - goto XI_OTHER; + { +#ifdef USE_LUCID + /* This makes key navigation work inside menus. */ + use_copy = true; + copy.xkey.type = KeyPress; + copy.xkey.serial = xev->serial; + copy.xkey.send_event = xev->send_event; + copy.xkey.display = dpyinfo->display; + copy.xkey.window = xev->event; + copy.xkey.root = xev->root; + copy.xkey.subwindow = xev->child; + copy.xkey.time = xev->time; + copy.xkey.state = ((xev->mods.effective & ~(1 << 13 | 1 << 14)) + | (xev->group.effective << 13)); + + copy.xkey.x = lrint (xev->event_x); + copy.xkey.y = lrint (xev->event_y); + copy.xkey.x_root = lrint (xev->root_x); + copy.xkey.y_root = lrint (xev->root_y); + + if (xev->buttons.mask_len) + { + if (XIMaskIsSet (xev->buttons.mask, 1)) + copy.xkey.state |= Button1Mask; + if (XIMaskIsSet (xev->buttons.mask, 2)) + copy.xkey.state |= Button2Mask; + if (XIMaskIsSet (xev->buttons.mask, 3)) + copy.xkey.state |= Button3Mask; + } + + copy.xkey.keycode = xev->detail; + copy.xkey.same_screen = True; +#endif + goto XI_OTHER; + } #endif x_display_set_last_user_time (dpyinfo, xev->time); @@ -12763,6 +18191,24 @@ handle_one_xevent (struct x_display_info *dpyinfo, xkey.time = xev->time; xkey.state = ((xev->mods.effective & ~(1 << 13 | 1 << 14)) | (xev->group.effective << 13)); + + xkey.x = lrint (xev->event_x); + xkey.y = lrint (xev->event_y); + xkey.x_root = lrint (xev->root_x); + xkey.y_root = lrint (xev->root_y); + + /* Some input methods react differently depending on the + buttons that are pressed. */ + if (xev->buttons.mask_len) + { + if (XIMaskIsSet (xev->buttons.mask, 1)) + xkey.state |= Button1Mask; + if (XIMaskIsSet (xev->buttons.mask, 2)) + xkey.state |= Button2Mask; + if (XIMaskIsSet (xev->buttons.mask, 3)) + xkey.state |= Button3Mask; + } + xkey.keycode = xev->detail; xkey.same_screen = True; @@ -12773,12 +18219,24 @@ handle_one_xevent (struct x_display_info *dpyinfo, || (x_gtk_use_native_input && x_filter_event (dpyinfo, event))) { + /* Try to attribute core key events from the input + method to the input extension event that caused + them. */ + dpyinfo->pending_keystroke_time = xev->time; + dpyinfo->pending_keystroke_source = xev->sourceid; + *finish = X_EVENT_DROP; goto XI_OTHER; } #else if (x_filter_event (dpyinfo, (XEvent *) &xkey)) { + /* Try to attribute core key events from the input + method to the input extension event that caused + them. */ + dpyinfo->pending_keystroke_time = xev->time; + dpyinfo->pending_keystroke_source = xev->sourceid; + *finish = X_EVENT_DROP; goto XI_OTHER; } @@ -12788,6 +18246,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, || dpyinfo->prefer_native_input) && xg_filter_key (any, event)) { + /* Try to attribute core key events from the input + method to the input extension event that caused + them. */ + dpyinfo->pending_keystroke_time = xev->time; + dpyinfo->pending_keystroke_source = xev->sourceid; + *finish = X_EVENT_DROP; goto XI_OTHER; } @@ -12936,12 +18400,29 @@ handle_one_xevent (struct x_display_info *dpyinfo, else #endif { + old_state = xkey.state; + xkey.state &= ~ControlMask; + xkey.state &= ~(dpyinfo->meta_mod_mask + | dpyinfo->super_mod_mask + | dpyinfo->hyper_mod_mask + | dpyinfo->alt_mod_mask); + nbytes = XLookupString (&xkey, copy_bufptr, copy_bufsiz, &keysym, NULL); + + xkey.state = old_state; } } +#ifdef XK_F1 + if (x_dnd_in_progress && keysym == XK_F1) + { + x_dnd_xm_use_help = true; + goto xi_done_keysym; + } +#endif + /* First deal with keysyms which have defined translations to characters. */ if (keysym >= 32 && keysym < 128) @@ -12950,6 +18431,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, inev.ie.kind = ASCII_KEYSTROKE_EVENT; inev.ie.code = keysym; + if (source) + inev.ie.device = source->name; + goto xi_done_keysym; } @@ -12960,6 +18444,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, inev.ie.kind = ASCII_KEYSTROKE_EVENT; else inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT; + + if (source) + inev.ie.device = source->name; + inev.ie.code = keysym & 0xFFFFFF; goto xi_done_keysym; } @@ -12975,6 +18463,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, ? ASCII_KEYSTROKE_EVENT : MULTIBYTE_CHAR_KEYSTROKE_EVENT); inev.ie.code = XFIXNAT (c); + + if (source) + inev.ie.device = source->name; + goto xi_done_keysym; } @@ -13079,6 +18571,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, key. */ inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT; inev.ie.code = keysym; + + if (source) + inev.ie.device = source->name; + goto xi_done_keysym; } @@ -13094,6 +18590,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, Fput_text_property (make_fixnum (0), make_fixnum (nbytes), Qcoding, coding, inev.ie.arg); + + if (source) + inev.ie.device = source->name; } goto xi_done_keysym; } @@ -13101,8 +18600,23 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto XI_OTHER; } +#if defined USE_GTK && !defined HAVE_GTK3 + case XI_RawKeyPress: + { + XIRawEvent *raw_event = (XIRawEvent *) xi_event; + + /* This is the only way to attribute core keyboard + events generated on GTK+ 2.x to the extension device + that generated them. */ + dpyinfo->pending_keystroke_time = raw_event->time; + dpyinfo->pending_keystroke_source = raw_event->sourceid; + dpyinfo->pending_keystroke_time_special_p = true; + goto XI_OTHER; + } +#endif + case XI_KeyRelease: -#if defined HAVE_X_I18N || defined USE_GTK +#if defined HAVE_X_I18N || defined USE_GTK || defined USE_LUCID { XKeyPressedEvent xkey; @@ -13118,17 +18632,51 @@ handle_one_xevent (struct x_display_info *dpyinfo, xkey.time = xev->time; xkey.state = ((xev->mods.effective & ~(1 << 13 | 1 << 14)) | (xev->group.effective << 13)); + xkey.x = lrint (xev->event_x); + xkey.y = lrint (xev->event_y); + xkey.x_root = lrint (xev->root_x); + xkey.y_root = lrint (xev->root_y); + + /* Some input methods react differently depending on the + buttons that are pressed. */ + if (xev->buttons.mask_len) + { + if (XIMaskIsSet (xev->buttons.mask, 1)) + xkey.state |= Button1Mask; + if (XIMaskIsSet (xev->buttons.mask, 2)) + xkey.state |= Button2Mask; + if (XIMaskIsSet (xev->buttons.mask, 3)) + xkey.state |= Button3Mask; + } + xkey.keycode = xev->detail; xkey.same_screen = True; +#ifdef USE_LUCID + if (!popup_activated ()) + { +#endif #ifdef HAVE_X_I18N - if (x_filter_event (dpyinfo, (XEvent *) &xkey)) - *finish = X_EVENT_DROP; -#else - f = x_any_window_to_frame (xkey->event); + if (x_filter_event (dpyinfo, (XEvent *) &xkey)) + *finish = X_EVENT_DROP; +#elif defined USE_GTK + f = x_any_window_to_frame (xkey->event); - if (f && xg_filter_key (f, event)) - *finish = X_EVENT_DROP; + if (f && xg_filter_key (f, event)) + *finish = X_EVENT_DROP; +#endif +#ifdef USE_LUCID + } + else + { + /* FIXME: the Lucid menu bar pops down upon any key + release event, so we don't dispatch these events + at all, which doesn't seem to be the right + solution. + + use_copy = true; + copy.xkey = xkey; */ + } #endif } #endif @@ -13139,8 +18687,144 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto XI_OTHER; case XI_HierarchyChanged: - x_init_master_valuators (dpyinfo); - goto XI_OTHER; + { + XIHierarchyEvent *hev = (XIHierarchyEvent *) xi_event; + XIDeviceInfo *info; + int i, j, ndevices, n_disabled, *disabled; + struct xi_device_t *device, *devices; +#ifdef HAVE_XINPUT2_2 + struct xi_touch_point_t *tem, *last; +#endif + + disabled = alloca (sizeof *disabled * hev->num_info); + n_disabled = 0; + + for (i = 0; i < hev->num_info; ++i) + { + if (hev->info[i].flags & XIDeviceEnabled) + { + /* Handle all disabled devices now, to prevent + things happening out-of-order later. */ + if (n_disabled) + { + ndevices = 0; + devices = xmalloc (sizeof *devices * dpyinfo->num_devices); + + for (i = 0; i < dpyinfo->num_devices; ++i) + { + for (j = 0; j < n_disabled; ++j) + { + if (disabled[j] == dpyinfo->devices[i].device_id) + { +#ifdef HAVE_XINPUT2_1 + xfree (dpyinfo->devices[i].valuators); +#endif +#ifdef HAVE_XINPUT2_2 + tem = dpyinfo->devices[i].touchpoints; + while (tem) + { + last = tem; + tem = tem->next; + xfree (last); + } +#endif + goto continue_detachment; + } + } + + devices[ndevices++] = dpyinfo->devices[i]; + + continue_detachment: + continue; + } + + xfree (dpyinfo->devices); + dpyinfo->devices = devices; + dpyinfo->num_devices = ndevices; + + n_disabled = 0; + } + + x_catch_errors (dpyinfo->display); + info = XIQueryDevice (dpyinfo->display, hev->info[i].deviceid, + &ndevices); + x_uncatch_errors (); + + if (info && info->enabled) + { + dpyinfo->devices + = xrealloc (dpyinfo->devices, (sizeof *dpyinfo->devices + * ++dpyinfo->num_devices)); + device = &dpyinfo->devices[dpyinfo->num_devices - 1]; + xi_populate_device_from_info (device, info); + } + + if (info) + XIFreeDeviceInfo (info); + } + else if (hev->info[i].flags & XIDeviceDisabled) + disabled[n_disabled++] = hev->info[i].deviceid; + else if (hev->info[i].flags & XISlaveDetached + || hev->info[i].flags & XISlaveAttached) + { + device = xi_device_from_id (dpyinfo, hev->info[i].deviceid); + x_catch_errors (dpyinfo->display); + info = XIQueryDevice (dpyinfo->display, hev->info[i].deviceid, + &ndevices); + x_uncatch_errors (); + + if (info) + { + if (device && info->enabled) + device->use = info->use; + else if (device) + disabled[n_disabled++] = hev->info[i].deviceid; + + XIFreeDeviceInfo (info); + } + } + } + + if (n_disabled) + { + ndevices = 0; + devices = xmalloc (sizeof *devices * dpyinfo->num_devices); + + for (i = 0; i < dpyinfo->num_devices; ++i) + { + for (j = 0; j < n_disabled; ++j) + { + if (disabled[j] == dpyinfo->devices[i].device_id) + { +#ifdef HAVE_XINPUT2_1 + xfree (dpyinfo->devices[i].valuators); +#endif +#ifdef HAVE_XINPUT2_2 + tem = dpyinfo->devices[i].touchpoints; + while (tem) + { + last = tem; + tem = tem->next; + xfree (last); + } +#endif + goto break_detachment; + } + } + + devices[ndevices++] = dpyinfo->devices[i]; + + break_detachment: + continue; + } + + xfree (dpyinfo->devices); + dpyinfo->devices = devices; + dpyinfo->num_devices = ndevices; + } + + goto XI_OTHER; + } case XI_DeviceChanged: { @@ -13275,12 +18959,13 @@ handle_one_xevent (struct x_display_info *dpyinfo, #ifdef HAVE_XINPUT2_2 case XI_TouchBegin: { - struct xi_device_t *device; + struct xi_device_t *device, *source; bool menu_bar_p = false, tool_bar_p = false; #ifdef HAVE_GTK3 GdkRectangle test_rect; #endif device = xi_device_from_id (dpyinfo, xev->deviceid); + source = xi_device_from_id (dpyinfo, xev->sourceid); x_display_set_last_user_time (dpyinfo, xev->time); if (!device) @@ -13313,10 +18998,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (f && device->direct_p) { *finish = X_EVENT_DROP; - x_catch_errors (dpyinfo->display); if (x_input_grab_touch_events) XIAllowTouchEvents (dpyinfo->display, xev->deviceid, xev->detail, xev->event, XIAcceptTouch); + if (!x_had_errors_p (dpyinfo->display)) { xi_link_touch_point (device, xev->detail, xev->event_x, @@ -13328,18 +19013,15 @@ handle_one_xevent (struct x_display_info *dpyinfo, XSETINT (inev.ie.x, lrint (xev->event_x)); XSETINT (inev.ie.y, lrint (xev->event_y)); XSETINT (inev.ie.arg, xev->detail); + + if (source) + inev.ie.device = source->name; } - x_uncatch_errors_after_check (); } #ifndef HAVE_GTK3 - else - { - x_catch_errors (dpyinfo->display); - if (x_input_grab_touch_events) - XIAllowTouchEvents (dpyinfo->display, xev->deviceid, - xev->detail, xev->event, XIRejectTouch); - x_uncatch_errors (); - } + else if (x_input_grab_touch_events) + XIAllowTouchEvents (dpyinfo->display, xev->deviceid, + xev->detail, xev->event, XIRejectTouch); #endif } else @@ -13361,11 +19043,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, case XI_TouchUpdate: { - struct xi_device_t *device; + struct xi_device_t *device, *source; struct xi_touch_point_t *touchpoint; Lisp_Object arg = Qnil; device = xi_device_from_id (dpyinfo, xev->deviceid); + source = xi_device_from_id (dpyinfo, xev->sourceid); x_display_set_last_user_time (dpyinfo, xev->time); if (!device) @@ -13396,6 +19079,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, arg); } + if (source) + inev.ie.device = source->name; + inev.ie.arg = arg; } @@ -13404,10 +19090,11 @@ handle_one_xevent (struct x_display_info *dpyinfo, case XI_TouchEnd: { - struct xi_device_t *device; + struct xi_device_t *device, *source; bool unlinked_p; device = xi_device_from_id (dpyinfo, xev->deviceid); + source = xi_device_from_id (dpyinfo, xev->sourceid); x_display_set_last_user_time (dpyinfo, xev->time); if (!device) @@ -13423,10 +19110,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, { inev.ie.kind = TOUCHSCREEN_END_EVENT; inev.ie.timestamp = xev->time; + XSETFRAME (inev.ie.frame_or_window, f); XSETINT (inev.ie.x, lrint (xev->event_x)); XSETINT (inev.ie.y, lrint (xev->event_y)); XSETINT (inev.ie.arg, xev->detail); + + if (source) + inev.ie.device = source->name; } } @@ -13439,10 +19130,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, case XI_GesturePinchBegin: case XI_GesturePinchUpdate: { - x_display_set_last_user_time (dpyinfo, xi_event->time); - XIGesturePinchEvent *pev = (XIGesturePinchEvent *) xi_event; - struct xi_device_t *device = xi_device_from_id (dpyinfo, pev->deviceid); + struct xi_device_t *device, *source; + + device = xi_device_from_id (dpyinfo, pev->deviceid); + source = xi_device_from_id (dpyinfo, pev->sourceid); + x_display_set_last_user_time (dpyinfo, xi_event->time); if (!device) goto XI_OTHER; @@ -13471,6 +19164,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, make_float (pev->delta_y), make_float (pev->scale), make_float (pev->delta_angle)); + + if (source) + inev.ie.device = source->name; } /* Once again GTK seems to crash when confronted by @@ -13481,7 +19177,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, case XI_GesturePinchEnd: { -#if defined HAVE_XWIDGETS && HAVE_USABLE_XI_GESTURE_PINCH_EVENT +#if defined HAVE_XWIDGETS XIGesturePinchEvent *pev = (XIGesturePinchEvent *) xi_event; struct xwidget_view *xvw = xwidget_view_from_window (pev->event); @@ -13498,8 +19194,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, xi_done_keysym: #ifdef HAVE_X_I18N - if (FRAME_XIC (f) && (FRAME_XIC_STYLE (f) & XIMStatusArea)) - xic_set_statusarea (f); + if (f) + { + struct window *w = XWINDOW (f->selected_window); + xic_set_preeditarea (w, w->cursor.x, w->cursor.y); + + if (FRAME_XIC (f) && (FRAME_XIC_STYLE (f) & XIMStatusArea)) + xic_set_statusarea (f); + } #endif if (must_free_data) XFreeEventData (dpyinfo->display, &event->xcookie); @@ -13514,7 +19216,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, default: #ifdef HAVE_XKB - if (event->type == dpyinfo->xkb_event_type) + if (dpyinfo->supports_xkb + && event->type == dpyinfo->xkb_event_type) { XkbEvent *xkbevent = (XkbEvent *) event; @@ -13558,6 +19261,227 @@ handle_one_xevent (struct x_display_info *dpyinfo, XkbRefreshKeyboardMapping (&xkbevent->map); x_find_modifier_meanings (dpyinfo); } + else if (x_dnd_in_progress + && xkbevent->any.xkb_type == XkbStateNotify) + x_dnd_keyboard_state = (xkbevent->state.mods + | xkbevent->state.ptr_buttons); + } +#endif +#ifdef HAVE_XSHAPE + if (dpyinfo->xshape_supported_p + && event->type == dpyinfo->xshape_event_base + ShapeNotify + && x_dnd_in_progress && x_dnd_use_toplevels + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) + { +#ifndef USE_GTK + XEvent xevent; +#endif + XShapeEvent *xse = (XShapeEvent *) event; +#if defined HAVE_XCB_SHAPE && defined HAVE_XCB_SHAPE_INPUT_RECTS + xcb_shape_get_rectangles_cookie_t bounding_rect_cookie; + xcb_shape_get_rectangles_reply_t *bounding_rect_reply; + xcb_rectangle_iterator_t bounding_rect_iterator; + + xcb_shape_get_rectangles_cookie_t input_rect_cookie; + xcb_shape_get_rectangles_reply_t *input_rect_reply; + xcb_rectangle_iterator_t input_rect_iterator; + + xcb_generic_error_t *error; +#else + XRectangle *rects; + int rc, ordering; +#endif + + /* Somehow this really interferes with GTK's own processing + of ShapeNotify events. Not sure what GTK uses them for, + but we cannot skip any of them here. */ +#ifndef USE_GTK + while (XPending (dpyinfo->display)) + { + XNextEvent (dpyinfo->display, &xevent); + + if (xevent.type == dpyinfo->xshape_event_base + ShapeNotify + && ((XShapeEvent *) &xevent)->window == xse->window) + xse = (XShapeEvent *) &xevent; + else + { + XPutBackEvent (dpyinfo->display, &xevent); + break; + } + } +#endif + + for (struct x_client_list_window *tem = x_dnd_toplevels; tem; + tem = tem->next) + { + if (tem->window == xse->window) + { + if (tem->n_input_rects != -1) + xfree (tem->input_rects); + if (tem->n_bounding_rects != -1) + xfree (tem->bounding_rects); + + tem->n_input_rects = -1; + tem->n_bounding_rects = -1; + +#if defined HAVE_XCB_SHAPE && defined HAVE_XCB_SHAPE_INPUT_RECTS + bounding_rect_cookie = xcb_shape_get_rectangles (dpyinfo->xcb_connection, + (xcb_window_t) xse->window, + XCB_SHAPE_SK_BOUNDING); + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + input_rect_cookie + = xcb_shape_get_rectangles (dpyinfo->xcb_connection, + (xcb_window_t) xse->window, + XCB_SHAPE_SK_INPUT); + + bounding_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + bounding_rect_cookie, + &error); + + if (bounding_rect_reply) + { + bounding_rect_iterator + = xcb_shape_get_rectangles_rectangles_iterator (bounding_rect_reply); + tem->n_bounding_rects = bounding_rect_iterator.rem + 1; + tem->bounding_rects = xmalloc (tem->n_bounding_rects + * sizeof *tem->bounding_rects); + tem->n_bounding_rects = 0; + + for (; bounding_rect_iterator.rem; xcb_rectangle_next (&bounding_rect_iterator)) + { + tem->bounding_rects[tem->n_bounding_rects].x + = bounding_rect_iterator.data->x; + tem->bounding_rects[tem->n_bounding_rects].y + = bounding_rect_iterator.data->y; + tem->bounding_rects[tem->n_bounding_rects].width + = bounding_rect_iterator.data->width; + tem->bounding_rects[tem->n_bounding_rects].height + = bounding_rect_iterator.data->height; + + tem->n_bounding_rects++; + } + + free (bounding_rect_reply); + } + else + free (error); + + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + { + input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection, + input_rect_cookie, &error); + + if (input_rect_reply) + { + input_rect_iterator + = xcb_shape_get_rectangles_rectangles_iterator (input_rect_reply); + tem->n_input_rects = input_rect_iterator.rem + 1; + tem->input_rects = xmalloc (tem->n_input_rects + * sizeof *tem->input_rects); + tem->n_input_rects = 0; + + for (; input_rect_iterator.rem; xcb_rectangle_next (&input_rect_iterator)) + { + tem->input_rects[tem->n_input_rects].x + = input_rect_iterator.data->x; + tem->input_rects[tem->n_input_rects].y + = input_rect_iterator.data->y; + tem->input_rects[tem->n_input_rects].width + = input_rect_iterator.data->width; + tem->input_rects[tem->n_input_rects].height + = input_rect_iterator.data->height; + + tem->n_input_rects++; + } + + free (input_rect_reply); + } + else + free (error); + } +#else + x_catch_errors (dpyinfo->display); + rects = XShapeGetRectangles (dpyinfo->display, + xse->window, + ShapeBounding, + &count, &ordering); + rc = x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + /* Does XShapeGetRectangles allocate anything upon an + error? */ + if (!rc) + { + tem->n_bounding_rects = count; + tem->bounding_rects + = xmalloc (sizeof *tem->bounding_rects * count); + memcpy (tem->bounding_rects, rects, + sizeof *tem->bounding_rects * count); + + XFree (rects); + } + +#ifdef ShapeInput + if (dpyinfo->xshape_major > 1 + || (dpyinfo->xshape_major == 1 + && dpyinfo->xshape_minor >= 1)) + { + x_catch_errors (dpyinfo->display); + rects = XShapeGetRectangles (dpyinfo->display, + xse->window, ShapeInput, + &count, &ordering); + rc = x_had_errors_p (dpyinfo->display); + x_uncatch_errors_after_check (); + + /* Does XShapeGetRectangles allocate anything upon + an error? */ + if (!rc) + { + tem->n_input_rects = count; + tem->input_rects + = xmalloc (sizeof *tem->input_rects * count); + memcpy (tem->input_rects, rects, + sizeof *tem->input_rects * count); + + XFree (rects); + } + } +#endif +#endif + + /* Handle the common case where the input shape equals the + bounding shape. */ + + if (tem->n_input_rects != -1 + && tem->n_bounding_rects == tem->n_input_rects + && !memcmp (tem->bounding_rects, tem->input_rects, + tem->n_input_rects * sizeof *tem->input_rects)) + { + xfree (tem->input_rects); + tem->n_input_rects = -1; + } + + /* And the common case where there is no input rect and the + bouding rect equals the window dimensions. */ + + if (tem->n_input_rects == -1 + && tem->n_bounding_rects == 1 + && tem->bounding_rects[0].width == tem->width + && tem->bounding_rects[0].height == tem->height + && tem->bounding_rects[0].x == -tem->border_width + && tem->bounding_rects[0].y == -tem->border_width) + { + xfree (tem->bounding_rects); + tem->n_bounding_rects = -1; + } + + break; + } + } } #endif OTHER: @@ -13567,12 +19491,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, { /* Ignore some obviously bogus ConfigureNotify events that other clients have been known to send Emacs. - (bug#54051)*/ + (bug#54051) */ if (event->type != ConfigureNotify || (event->xconfigure.width != 0 && event->xconfigure.height != 0)) { -#if defined USE_MOTIF && defined HAVE_XINPUT2 +#if defined USE_X_TOOLKIT && defined HAVE_XINPUT2 XtDispatchEvent (use_copy ? © : (XEvent *) event); #else XtDispatchEvent ((XEvent *) event); @@ -13581,6 +19505,16 @@ handle_one_xevent (struct x_display_info *dpyinfo, } unblock_input (); #endif /* USE_X_TOOLKIT */ +#if defined USE_GTK && !defined HAVE_GTK3 && defined HAVE_XINPUT2 + if (*finish != X_EVENT_DROP && copy) + { + gtk_main_do_event (copy); + *finish = X_EVENT_DROP; + } + + if (copy) + gdk_event_free (copy); +#endif break; } @@ -13591,6 +19525,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, count++; } +#ifdef USE_TOOLKIT_SCROLL_BARS + if (event->xany.type == ClientMessage + && inev.ie.kind == SCROLL_BAR_CLICK_EVENT) + x_unprotect_window_for_callback (dpyinfo); +#endif + if (do_help && !(hold_quit && hold_quit->kind != NO_EVENT)) { @@ -13619,11 +19559,13 @@ handle_one_xevent (struct x_display_info *dpyinfo, redisplay. To ensure that these changes become visible, draw them here. */ +#ifdef HAVE_XDBE if (f) flush_dirty_back_buffer_on (f); if (any && any != f) flush_dirty_back_buffer_on (any); +#endif return count; } @@ -13666,6 +19608,13 @@ XTread_socket (struct terminal *terminal, struct input_event *hold_quit) bool event_found = false; struct x_display_info *dpyinfo = terminal->display_info.x; + /* Don't allow XTread_socket to do anything if drag-and-drop is in + progress. If unblock_input causes XTread_socket to be called and + read X events while the drag-and-drop event loop is in progress, + things can go wrong very quick. */ + if (x_dnd_in_progress || x_dnd_waiting_for_finish) + return 0; + block_input (); /* For debugging, this gives a way to fake an I/O error. */ @@ -13685,8 +19634,19 @@ XTread_socket (struct terminal *terminal, struct input_event *hold_quit) #ifdef HAVE_X_I18N /* Filter events for the current X input method. */ - if (x_filter_event (dpyinfo, &event)) - continue; +#ifdef HAVE_XINPUT2 + if (event.type != GenericEvent + || !dpyinfo->supports_xi2 + || event.xgeneric.extension != dpyinfo->xi2_opcode) + { + /* Input extension key events are filtered inside + handle_one_xevent. */ +#endif + if (x_filter_event (dpyinfo, &event)) + continue; +#ifdef HAVE_XINPUT2 + } +#endif #endif event_found = true; @@ -13908,6 +19868,9 @@ x_draw_bar_cursor (struct window *w, struct glyph_row *row, int width, enum text else xgcv.background = xgcv.foreground = f->output_data.x->cursor_pixel; xgcv.graphics_exposures = False; + xgcv.line_width = 1; + + mask |= GCLineWidth; if (gc) XChangeGC (dpy, gc, mask, &xgcv); @@ -14360,16 +20323,90 @@ static char *error_msg; static AVOID x_connection_closed (Display *dpy, const char *error_message, bool ioerror) { - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); + struct x_display_info *dpyinfo; Lisp_Object frame, tail; specpdl_ref idx = SPECPDL_INDEX (); + void *io_error_handler; + xm_drop_start_message dmsg; + struct frame *f; + dpyinfo = x_display_info_for_display (dpy); error_msg = alloca (strlen (error_message) + 1); strcpy (error_msg, error_message); /* Inhibit redisplay while frames are being deleted. */ specbind (Qinhibit_redisplay, Qt); + /* If drag-and-drop is in progress, cancel drag-and-drop. If DND + frame's display is DPY, don't reset event masks or try to send + responses to other programs because the display is going + away. */ + + if (x_dnd_in_progress || x_dnd_waiting_for_finish) + { + /* Handle display disconnect errors here because this function + is not reentrant at this particular spot. */ + io_error_handler = XSetIOErrorHandler (x_dnd_io_error_handler); + + if (!sigsetjmp (x_dnd_disconnect_handler, 1) + && x_dnd_in_progress + && dpy != (x_dnd_waiting_for_finish + ? x_dnd_finish_display + : FRAME_X_DISPLAY (x_dnd_frame))) + { + /* Clean up drag and drop if the drag frame's display isn't + the one being disconnected. */ + f = x_dnd_frame; + + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1) + x_dnd_send_leave (x_dnd_frame, + x_dnd_last_seen_window); + else if (x_dnd_last_seen_window != None + && !XM_DRAG_STYLE_IS_DROP_ONLY (x_dnd_last_motif_style) + && x_dnd_last_motif_style != XM_DRAG_STYLE_NONE + && x_dnd_motif_setup_p) + { + dmsg.reason = XM_DRAG_REASON (XM_DRAG_ORIGINATOR_INITIATOR, + XM_DRAG_REASON_DROP_START); + dmsg.byte_order = XM_BYTE_ORDER_CUR_FIRST; + dmsg.timestamp = FRAME_DISPLAY_INFO (f)->last_user_time; + dmsg.side_effects + = XM_DRAG_SIDE_EFFECT (xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), + x_dnd_wanted_action), + XM_DROP_SITE_VALID, + xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), + x_dnd_wanted_action), + XM_DROP_ACTION_DROP_CANCEL); + dmsg.x = 0; + dmsg.y = 0; + dmsg.index_atom = FRAME_DISPLAY_INFO (f)->Xatom_XdndSelection; + dmsg.source_window = FRAME_X_WINDOW (f); + + x_dnd_send_xm_leave_for_drop (FRAME_DISPLAY_INFO (f), f, + x_dnd_last_seen_window, 0); + xm_send_drop_message (FRAME_DISPLAY_INFO (f), FRAME_X_WINDOW (f), + x_dnd_last_seen_window, &dmsg); + } + } + + XSetIOErrorHandler (io_error_handler); + dpyinfo = x_display_info_for_display (dpy); + + x_dnd_last_seen_window = None; + x_dnd_last_seen_toplevel = None; + x_dnd_in_progress = false; + x_set_dnd_targets (NULL, 0); + x_dnd_waiting_for_finish = false; + + if (x_dnd_use_toplevels) + x_dnd_free_toplevels (); + + x_dnd_return_frame_object = NULL; + x_dnd_movement_frame = NULL; + x_dnd_frame = NULL; + } + if (dpyinfo) { /* Protect display from being closed when we delete the last @@ -14447,7 +20484,7 @@ For details, see etc/PROBLEMS.\n", if (terminal_list == 0) { fprintf (stderr, "%s\n", error_msg); - Fkill_emacs (make_fixnum (70)); + Fkill_emacs (make_fixnum (70), Qnil); } totally_unblock_input (); @@ -14469,6 +20506,10 @@ static void x_error_quitter (Display *, XErrorEvent *); static int x_error_handler (Display *display, XErrorEvent *event) { +#ifdef HAVE_XINPUT2 + struct x_display_info *dpyinfo; +#endif + #if defined USE_GTK && defined HAVE_GTK3 if ((event->error_code == BadMatch || event->error_code == BadWindow) && event->request_code == X_SetInputFocus) @@ -14477,6 +20518,24 @@ x_error_handler (Display *display, XErrorEvent *event) } #endif + /* If we try to ungrab or grab a device that doesn't exist anymore + (that happens a lot in xmenu.c), just ignore the error. */ + +#ifdef HAVE_XINPUT2 + dpyinfo = x_display_info_for_display (display); + + /* 51 is X_XIGrabDevice and 52 is X_XIUngrabDevice. + + 53 is X_XIAllowEvents. We handle errors from that here to avoid + a sync in handle_one_xevent. */ + if (dpyinfo && dpyinfo->supports_xi2 + && event->request_code == dpyinfo->xi2_opcode + && (event->minor_code == 51 + || event->minor_code == 52 + || event->minor_code == 53)) + return 0; +#endif + if (x_error_message) x_error_catcher (display, event); else @@ -14524,6 +20583,7 @@ x_io_error_quitter (Display *display) DisplayString (display)); x_connection_closed (display, buf, true); } + /* Changing the font of the frame. */ @@ -14684,6 +20744,9 @@ xim_instantiate_callback (Display *display, XPointer client_data, XPointer call_ struct xim_inst_t *xim_inst = (struct xim_inst_t *) client_data; struct x_display_info *dpyinfo = xim_inst->dpyinfo; + if (x_dnd_in_progress) + return; + /* We don't support multiple XIM connections. */ if (dpyinfo->xim) return; @@ -15067,19 +21130,26 @@ x_wm_supports (struct frame *f, Atom want_atom) static void set_wm_state (Lisp_Object frame, bool add, Atom atom, Atom value) { - struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (XFRAME (frame)); + struct x_display_info *dpyinfo; + XEvent msg; - x_send_client_event (frame, make_fixnum (0), frame, - dpyinfo->Xatom_net_wm_state, - make_fixnum (32), - /* 1 = add, 0 = remove */ - Fcons - (make_fixnum (add), - Fcons - (INT_TO_INTEGER (atom), - (value != 0 - ? list1 (INT_TO_INTEGER (value)) - : Qnil)))); + dpyinfo = FRAME_DISPLAY_INFO (XFRAME (frame)); + msg.xclient.type = ClientMessage; + msg.xclient.window = FRAME_OUTER_WINDOW (XFRAME (frame)); + msg.xclient.message_type = dpyinfo->Xatom_net_wm_state; + msg.xclient.format = 32; + + msg.xclient.data.l[0] = add ? 1 : 0; + msg.xclient.data.l[1] = atom; + msg.xclient.data.l[2] = value; + msg.xclient.data.l[3] = 1; /* Source indication. */ + msg.xclient.data.l[4] = 0; + + block_input (); + XSendEvent (dpyinfo->display, dpyinfo->root_window, + False, (SubstructureRedirectMask + | SubstructureNotifyMask), &msg); + unblock_input (); } void @@ -15802,16 +21872,17 @@ frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y) if (FRAME_DISPLAY_INFO (f)->supports_xi2) { - XGrabServer (FRAME_X_DISPLAY (f)); - if (XIGetClientPointer (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), + if (XIGetClientPointer (FRAME_X_DISPLAY (f), + FRAME_X_WINDOW (f), &deviceid)) { + x_catch_errors (FRAME_X_DISPLAY (f)); XIWarpPointer (FRAME_X_DISPLAY (f), deviceid, None, FRAME_X_WINDOW (f), 0, 0, 0, 0, pix_x, pix_y); + x_uncatch_errors (); } - XUngrabServer (FRAME_X_DISPLAY (f)); } else #endif @@ -15879,20 +21950,32 @@ xembed_request_focus (struct frame *f) static void x_ewmh_activate_frame (struct frame *f) { - /* See Window Manager Specification/Extended Window Manager Hints at - https://freedesktop.org/wiki/Specifications/wm-spec/ */ + XEvent msg; + struct x_display_info *dpyinfo; - struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); + dpyinfo = FRAME_DISPLAY_INFO (f); - if (FRAME_VISIBLE_P (f) && x_wm_supports (f, dpyinfo->Xatom_net_active_window)) + if (FRAME_VISIBLE_P (f) + && x_wm_supports (f, dpyinfo->Xatom_net_active_window)) { - Lisp_Object frame; - XSETFRAME (frame, f); - x_send_client_event (frame, make_fixnum (0), frame, - dpyinfo->Xatom_net_active_window, - make_fixnum (32), - list2 (make_fixnum (1), - INT_TO_INTEGER (dpyinfo->last_user_time))); + /* See the documentation at + https://specifications.freedesktop.org/wm-spec/wm-spec-latest.html + for more details on the format of this message. */ + msg.xclient.type = ClientMessage; + msg.xclient.window = FRAME_OUTER_WINDOW (f); + msg.xclient.message_type = dpyinfo->Xatom_net_active_window; + msg.xclient.format = 32; + msg.xclient.data.l[0] = 1; + msg.xclient.data.l[1] = dpyinfo->last_user_time; + msg.xclient.data.l[2] = (!dpyinfo->x_focus_frame + ? None + : FRAME_OUTER_WINDOW (dpyinfo->x_focus_frame)); + msg.xclient.data.l[3] = 0; + msg.xclient.data.l[4] = 0; + + XSendEvent (dpyinfo->display, dpyinfo->root_window, + False, (SubstructureRedirectMask + | SubstructureNotifyMask), &msg); } } @@ -16125,6 +22208,12 @@ x_make_frame_visible (struct frame *f) XMapRaised (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); #endif /* not USE_GTK */ #endif /* not USE_X_TOOLKIT */ + + if (FRAME_X_EMBEDDED_P (f)) + { + SET_FRAME_VISIBLE (f, true); + SET_FRAME_ICONIFIED (f, false); + } } XFlush (FRAME_X_DISPLAY (f)); @@ -16425,7 +22514,7 @@ x_free_frame_resources (struct frame *f) /* Always exit with visible pointer to avoid weird issue with Xfixes (Bug#17609). */ if (f->pointer_invisible) - FRAME_DISPLAY_INFO (f)->toggle_visible_pointer (f, 0); + XTtoggle_invisible_pointer (f, 0); /* We must free faces before destroying windows because some font-driver (e.g. xft) access a window while finishing a @@ -16451,9 +22540,6 @@ x_free_frame_resources (struct frame *f) #ifdef HAVE_X_I18N if (FRAME_XIC (f)) free_frame_xic (f); - - if (f->output_data.x->preedit_chars) - xfree (f->output_data.x->preedit_chars); #endif #ifdef USE_CAIRO @@ -16571,9 +22657,13 @@ x_free_frame_resources (struct frame *f) XFlush (FRAME_X_DISPLAY (f)); } - xfree (f->output_data.x->saved_menu_event); - xfree (f->output_data.x); - f->output_data.x = NULL; +#ifdef HAVE_GTK3 + if (FRAME_OUTPUT_DATA (f)->scrollbar_background_css_provider) + g_object_unref (FRAME_OUTPUT_DATA (f)->scrollbar_background_css_provider); + + if (FRAME_OUTPUT_DATA (f)->scrollbar_foreground_css_provider) + g_object_unref (FRAME_OUTPUT_DATA (f)->scrollbar_foreground_css_provider); +#endif if (f == dpyinfo->x_focus_frame) dpyinfo->x_focus_frame = 0; @@ -16600,6 +22690,21 @@ x_destroy_window (struct frame *f) if (dpyinfo->display != 0) x_free_frame_resources (f); + xfree (f->output_data.x->saved_menu_event); + xfree (f->output_data.x); + +#ifdef HAVE_X_I18N + if (f->output_data.x->preedit_chars) + xfree (f->output_data.x->preedit_chars); +#endif + +#ifdef HAVE_XINPUT2 + if (f->output_data.x->xi_masks) + XFree (f->output_data.x->xi_masks); +#endif + + f->output_data.x = NULL; + dpyinfo->reference_count--; } @@ -16613,12 +22718,15 @@ x_destroy_window (struct frame *f) flag (this is useful when FLAGS is 0). The GTK version is in gtkutils.c. */ -#ifndef USE_GTK void x_wm_set_size_hint (struct frame *f, long flags, bool user_position) { +#ifndef USE_GTK XSizeHints size_hints; Window window = FRAME_OUTER_WINDOW (f); +#ifdef USE_X_TOOLKIT + WMShellWidget shell; +#endif if (!window) return; @@ -16626,8 +22734,63 @@ x_wm_set_size_hint (struct frame *f, long flags, bool user_position) #ifdef USE_X_TOOLKIT if (f->output_data.x->widget) { + /* Do this dance in xterm.c because some stuff is not as easily + available in widget.c. */ + + eassert (XtIsWMShell (f->output_data.x->widget)); + shell = (WMShellWidget) f->output_data.x->widget; + + shell->wm.size_hints.flags &= ~(PPosition | USPosition); + shell->wm.size_hints.flags |= flags & (PPosition | USPosition); + + if (user_position) + { + shell->wm.size_hints.flags &= ~PPosition; + shell->wm.size_hints.flags |= USPosition; + } + widget_update_wm_size_hints (f->output_data.x->widget, f->output_data.x->edit_widget); + +#ifdef USE_MOTIF + /* Do this all over again for the benefit of Motif, which always + knows better than the programmer. */ + shell->wm.size_hints.flags &= ~(PPosition | USPosition); + shell->wm.size_hints.flags |= flags & (PPosition | USPosition); + + if (user_position) + { + shell->wm.size_hints.flags &= ~PPosition; + shell->wm.size_hints.flags |= USPosition; + } + + /* Drill hints into Motif, since it keeps setting its own. */ + size_hints.flags = shell->wm.size_hints.flags; + size_hints.x = shell->wm.size_hints.x; + size_hints.y = shell->wm.size_hints.y; + size_hints.width = shell->wm.size_hints.width; + size_hints.height = shell->wm.size_hints.height; + size_hints.min_width = shell->wm.size_hints.min_width; + size_hints.min_height = shell->wm.size_hints.min_height; + size_hints.max_width = shell->wm.size_hints.max_width; + size_hints.max_height = shell->wm.size_hints.max_height; + size_hints.width_inc = shell->wm.size_hints.width_inc; + size_hints.height_inc = shell->wm.size_hints.height_inc; + size_hints.min_aspect.x = shell->wm.size_hints.min_aspect.x; + size_hints.min_aspect.y = shell->wm.size_hints.min_aspect.y; + size_hints.max_aspect.x = shell->wm.size_hints.max_aspect.x; + size_hints.max_aspect.y = shell->wm.size_hints.max_aspect.y; +#ifdef HAVE_X11XTR6 + size_hints.base_width = shell->wm.base_width; + size_hints.base_height = shell->wm.base_height; + size_hints.win_gravity = shell->wm.win_gravity; +#endif + + XSetWMNormalHints (XtDisplay (f->output_data.x->widget), + XtWindow (f->output_data.x->widget), + &size_hints); +#endif + return; } #endif @@ -16715,8 +22878,10 @@ x_wm_set_size_hint (struct frame *f, long flags, bool user_position) #endif /* PWinGravity */ XSetWMNormalHints (FRAME_X_DISPLAY (f), window, &size_hints); +#else + xg_wm_set_size_hint (f, flags, user_position); +#endif /* USE_GTK */ } -#endif /* not USE_GTK */ /* Used for IconicState or NormalState */ @@ -16969,100 +23134,6 @@ my_log_handler (const gchar *log_domain, GLogLevelFlags log_level, } #endif -/* Create invisible cursor on X display referred by DPYINFO. */ - -static Cursor -make_invisible_cursor (struct x_display_info *dpyinfo) -{ - Display *dpy = dpyinfo->display; - static char const no_data[] = { 0 }; - Pixmap pix; - XColor col; - Cursor c = 0; - - x_catch_errors (dpy); - pix = XCreateBitmapFromData (dpy, dpyinfo->root_window, no_data, 1, 1); - if (! x_had_errors_p (dpy) && pix != None) - { - Cursor pixc; - col.pixel = 0; - col.red = col.green = col.blue = 0; - col.flags = DoRed | DoGreen | DoBlue; - pixc = XCreatePixmapCursor (dpy, pix, pix, &col, &col, 0, 0); - if (! x_had_errors_p (dpy) && pixc != None) - c = pixc; - XFreePixmap (dpy, pix); - } - - x_uncatch_errors (); - - return c; -} - -/* True if DPY supports Xfixes extension >= 4. */ - -static bool -x_probe_xfixes_extension (Display *dpy) -{ -#ifdef HAVE_XFIXES - struct x_display_info *info - = x_display_info_for_display (dpy); - - return (info - && info->xfixes_supported_p - && info->xfixes_major >= 4); -#else - return false; -#endif /* HAVE_XFIXES */ -} - -/* Toggle mouse pointer visibility on frame F by using Xfixes functions. */ - -static void -xfixes_toggle_visible_pointer (struct frame *f, bool invisible) -{ -#ifdef HAVE_XFIXES - if (invisible) - XFixesHideCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); - else - XFixesShowCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); - f->pointer_invisible = invisible; -#else - emacs_abort (); -#endif /* HAVE_XFIXES */ -} - -/* Toggle mouse pointer visibility on frame F by using invisible cursor. */ - -static void -x_toggle_visible_pointer (struct frame *f, bool invisible) -{ - eassert (FRAME_DISPLAY_INFO (f)->invisible_cursor != 0); - if (invisible) - XDefineCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), - FRAME_DISPLAY_INFO (f)->invisible_cursor); - else - XDefineCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), - f->output_data.x->current_cursor); - f->pointer_invisible = invisible; -} - -/* Setup pointer blanking, prefer Xfixes if available. */ - -static void -x_setup_pointer_blanking (struct x_display_info *dpyinfo) -{ - /* FIXME: the brave tester should set EMACS_XFIXES because we're suspecting - X server bug, see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=17609. */ - if (egetenv ("EMACS_XFIXES") && x_probe_xfixes_extension (dpyinfo->display)) - dpyinfo->toggle_visible_pointer = xfixes_toggle_visible_pointer; - else - { - dpyinfo->toggle_visible_pointer = x_toggle_visible_pointer; - dpyinfo->invisible_cursor = make_invisible_cursor (dpyinfo); - } -} - /* Current X display connection identifier. Incremented for each next connection established. */ static unsigned x_display_id; @@ -17081,6 +23152,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) #ifdef USE_XCB xcb_connection_t *xcb_conn; #endif + char *cm_atom_sprintf; block_input (); @@ -17273,7 +23345,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) vendor ? build_string (vendor) : empty_unibyte_string)); block_input (); terminal->next_terminal = terminal_list; - terminal_list = terminal; + terminal_list = terminal; } /* Don't let the initial kboard remain current longer than necessary. @@ -17300,6 +23372,10 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) dpyinfo->smallest_font_height = 1; dpyinfo->smallest_char_width = 1; + dpyinfo->color_names_size = 256; + dpyinfo->color_names = xzalloc (dpyinfo->color_names_size + * sizeof *dpyinfo->color_names); + /* Set the name of the terminal. */ terminal->name = xlispstrdup (display_name); @@ -17362,6 +23438,33 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) &dpyinfo->xrender_minor); #endif + /* This must come after XRenderQueryVersion! */ +#ifdef HAVE_XCOMPOSITE + int composite_event_base, composite_error_base; + dpyinfo->composite_supported_p = XCompositeQueryExtension (dpyinfo->display, + &composite_event_base, + &composite_error_base); + + if (dpyinfo->composite_supported_p) + dpyinfo->composite_supported_p + = XCompositeQueryVersion (dpyinfo->display, + &dpyinfo->composite_major, + &dpyinfo->composite_minor); +#endif + +#ifdef HAVE_XSHAPE + dpyinfo->xshape_supported_p + = XShapeQueryExtension (dpyinfo->display, + &dpyinfo->xshape_event_base, + &dpyinfo->xshape_error_base); + + if (dpyinfo->xshape_supported_p) + dpyinfo->xshape_supported_p + = XShapeQueryVersion (dpyinfo->display, + &dpyinfo->xshape_major, + &dpyinfo->xshape_minor); +#endif + /* Put the rdb where we can find it in a way that works on all versions. */ dpyinfo->rdb = xrdb; @@ -17406,9 +23509,9 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) SynchronizeResize, Qnil, Qnil); - if (STRINGP (value) && - (!strcmp (SSDATA (value), "false") - || !strcmp (SSDATA (value), "off"))) + if (STRINGP (value) + && (!strcmp (SSDATA (value), "false") + || !strcmp (SSDATA (value), "off"))) dpyinfo->xsync_supported_p = false; } #endif @@ -17533,6 +23636,23 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) int major = 2; int xi_first_event, xi_first_error; +#ifndef HAVE_GTK3 + { + AUTO_STRING (disableInputExtension, "disableInputExtension"); + AUTO_STRING (DisableInputExtension, "DisableInputExtension"); + + Lisp_Object value = gui_display_get_resource (dpyinfo, + disableInputExtension, + DisableInputExtension, + Qnil, Qnil); + + if (STRINGP (value) + && (!strcmp (SSDATA (value), "on") + || !strcmp (SSDATA (value), "true"))) + goto skip_xi_setup; + } +#endif + #ifdef HAVE_XINPUT2_4 int minor = 4; #elif defined HAVE_XINPUT2_3 /* XInput 2.3 */ @@ -17628,6 +23748,10 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) } dpyinfo->xi2_version = minor; +#ifndef HAVE_GTK3 + skip_xi_setup: +#endif + ; #endif #ifdef HAVE_XRANDR @@ -17663,8 +23787,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) XkbGroupNamesMask | XkbVirtualModNamesMask, dpyinfo->xkb_desc); - XkbSelectEvents (dpyinfo->display, - XkbUseCoreKbd, + XkbSelectEvents (dpyinfo->display, XkbUseCoreKbd, XkbNewKeyboardNotifyMask | XkbMapNotifyMask, XkbNewKeyboardNotifyMask | XkbMapNotifyMask); } @@ -17720,6 +23843,15 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) dpyinfo->resx = (mm < 1) ? 100 : pixels * 25.4 / mm; } + { + int n = snprintf (NULL, 0, "_NET_WM_CM_S%d", + XScreenNumberOfScreen (dpyinfo->screen)); + cm_atom_sprintf = alloca (n + 1); + + snprintf (cm_atom_sprintf, n + 1, "_NET_WM_CM_S%d", + XScreenNumberOfScreen (dpyinfo->screen)); + } + { static const struct { @@ -17733,6 +23865,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) ATOM_REFS_INIT ("WM_SAVE_YOURSELF", Xatom_wm_save_yourself) ATOM_REFS_INIT ("WM_DELETE_WINDOW", Xatom_wm_delete_window) ATOM_REFS_INIT ("WM_CHANGE_STATE", Xatom_wm_change_state) + ATOM_REFS_INIT ("WM_STATE", Xatom_wm_state) ATOM_REFS_INIT ("WM_CONFIGURE_DENIED", Xatom_wm_configure_denied) ATOM_REFS_INIT ("WM_MOVED", Xatom_wm_window_moved) ATOM_REFS_INIT ("WM_CLIENT_LEADER", Xatom_wm_client_leader) @@ -17753,8 +23886,8 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) ATOM_REFS_INIT ("ATOM", Xatom_ATOM) ATOM_REFS_INIT ("ATOM_PAIR", Xatom_ATOM_PAIR) ATOM_REFS_INIT ("CLIPBOARD_MANAGER", Xatom_CLIPBOARD_MANAGER) - ATOM_REFS_INIT ("XATOM_COUNTER", Xatom_XEMBED_INFO) ATOM_REFS_INIT ("_XEMBED_INFO", Xatom_XEMBED_INFO) + ATOM_REFS_INIT ("_MOTIF_WM_HINTS", Xatom_MOTIF_WM_HINTS) /* For properties of font. */ ATOM_REFS_INIT ("PIXEL_SIZE", Xatom_PIXEL_SIZE) ATOM_REFS_INIT ("AVERAGE_WIDTH", Xatom_AVERAGE_WIDTH) @@ -17794,6 +23927,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) ATOM_REFS_INIT ("_NET_WM_FRAME_DRAWN", Xatom_net_wm_frame_drawn) ATOM_REFS_INIT ("_NET_WM_USER_TIME", Xatom_net_wm_user_time) ATOM_REFS_INIT ("_NET_WM_USER_TIME_WINDOW", Xatom_net_wm_user_time_window) + ATOM_REFS_INIT ("_NET_CLIENT_LIST_STACKING", Xatom_net_client_list_stacking) /* Session management */ ATOM_REFS_INIT ("SM_CLIENT_ID", Xatom_SM_CLIENT_ID) ATOM_REFS_INIT ("_XSETTINGS_SETTINGS", Xatom_xsettings_prop) @@ -17803,6 +23937,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) ATOM_REFS_INIT ("_NET_WM_STATE_BELOW", Xatom_net_wm_state_below) ATOM_REFS_INIT ("_NET_WM_OPAQUE_REGION", Xatom_net_wm_opaque_region) ATOM_REFS_INIT ("_NET_WM_PING", Xatom_net_wm_ping) + ATOM_REFS_INIT ("_NET_WM_PID", Xatom_net_wm_pid) #ifdef HAVE_XKB ATOM_REFS_INIT ("Meta", Xatom_Meta) ATOM_REFS_INIT ("Super", Xatom_Super) @@ -17810,12 +23945,41 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) ATOM_REFS_INIT ("ShiftLock", Xatom_ShiftLock) ATOM_REFS_INIT ("Alt", Xatom_Alt) #endif + /* DND source. */ + ATOM_REFS_INIT ("XdndAware", Xatom_XdndAware) + ATOM_REFS_INIT ("XdndSelection", Xatom_XdndSelection) + ATOM_REFS_INIT ("XdndTypeList", Xatom_XdndTypeList) + ATOM_REFS_INIT ("XdndActionCopy", Xatom_XdndActionCopy) + ATOM_REFS_INIT ("XdndActionMove", Xatom_XdndActionMove) + ATOM_REFS_INIT ("XdndActionLink", Xatom_XdndActionLink) + ATOM_REFS_INIT ("XdndActionAsk", Xatom_XdndActionAsk) + ATOM_REFS_INIT ("XdndActionPrivate", Xatom_XdndActionPrivate) + ATOM_REFS_INIT ("XdndActionList", Xatom_XdndActionList) + ATOM_REFS_INIT ("XdndActionDescription", Xatom_XdndActionDescription) + ATOM_REFS_INIT ("XdndProxy", Xatom_XdndProxy) + ATOM_REFS_INIT ("XdndEnter", Xatom_XdndEnter) + ATOM_REFS_INIT ("XdndPosition", Xatom_XdndPosition) + ATOM_REFS_INIT ("XdndStatus", Xatom_XdndStatus) + ATOM_REFS_INIT ("XdndLeave", Xatom_XdndLeave) + ATOM_REFS_INIT ("XdndDrop", Xatom_XdndDrop) + ATOM_REFS_INIT ("XdndFinished", Xatom_XdndFinished) + /* Motif drop protocol support. */ + ATOM_REFS_INIT ("_MOTIF_DRAG_WINDOW", Xatom_MOTIF_DRAG_WINDOW) + ATOM_REFS_INIT ("_MOTIF_DRAG_TARGETS", Xatom_MOTIF_DRAG_TARGETS) + ATOM_REFS_INIT ("_MOTIF_DRAG_AND_DROP_MESSAGE", + Xatom_MOTIF_DRAG_AND_DROP_MESSAGE) + ATOM_REFS_INIT ("_MOTIF_DRAG_INITIATOR_INFO", + Xatom_MOTIF_DRAG_INITIATOR_INFO) + ATOM_REFS_INIT ("_MOTIF_DRAG_RECEIVER_INFO", + Xatom_MOTIF_DRAG_RECEIVER_INFO) + ATOM_REFS_INIT ("XmTRANSFER_SUCCESS", Xatom_XmTRANSFER_SUCCESS) + ATOM_REFS_INIT ("XmTRANSFER_FAILURE", Xatom_XmTRANSFER_FAILURE) }; int i; enum { atom_count = ARRAYELTS (atom_refs) }; /* 1 for _XSETTINGS_SN. */ - enum { total_atom_count = 1 + atom_count }; + enum { total_atom_count = 2 + atom_count }; Atom atoms_return[total_atom_count]; char *atom_names[total_atom_count]; static char const xsettings_fmt[] = "_XSETTINGS_S%d"; @@ -17829,6 +23993,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) sprintf (xsettings_atom_name, xsettings_fmt, XScreenNumberOfScreen (dpyinfo->screen)); atom_names[i] = xsettings_atom_name; + atom_names[i + 1] = cm_atom_sprintf; XInternAtoms (dpyinfo->display, atom_names, total_atom_count, False, atoms_return); @@ -17836,8 +24001,9 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) for (i = 0; i < atom_count; i++) *(Atom *) ((char *) dpyinfo + atom_refs[i].offset) = atoms_return[i]; - /* Manually copy last atom. */ + /* Manually copy last two atoms. */ dpyinfo->Xatom_xsettings_sel = atoms_return[i]; + dpyinfo->Xatom_NET_WM_CM_Sn = atoms_return[i + 1]; } #ifdef HAVE_XKB @@ -17853,7 +24019,10 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) gray_bits, gray_width, gray_height, 1, 0, 1); - x_setup_pointer_blanking (dpyinfo); + dpyinfo->invisible_cursor = make_invisible_cursor (dpyinfo); +#ifdef HAVE_XFIXES + dpyinfo->fixes_pointer_blanking = egetenv ("EMACS_XFIXES"); +#endif #ifdef HAVE_X_I18N xim_initialize (dpyinfo, resource_name); @@ -17965,6 +24134,12 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) x_extension_initialize (dpyinfo); #endif +#ifdef USE_TOOLKIT_SCROLL_BARS + dpyinfo->protected_windows = xmalloc (sizeof (Lisp_Object) * 256); + dpyinfo->n_protected_windows = 0; + dpyinfo->protected_windows_max = 256; +#endif + unblock_input (); return dpyinfo; @@ -17978,6 +24153,7 @@ x_delete_display (struct x_display_info *dpyinfo) { struct terminal *t; struct color_name_cache_entry *color_entry, *next_color_entry; + int i; /* Close all frames and delete the generic struct terminal for this X display. */ @@ -17996,6 +24172,9 @@ x_delete_display (struct x_display_info *dpyinfo) if (next_noop_dpyinfo == dpyinfo) next_noop_dpyinfo = dpyinfo->next; + if (mouse_click_timeout_display == dpyinfo) + mouse_click_timeout_display = NULL; + if (x_display_list == dpyinfo) x_display_list = dpyinfo->next; else @@ -18007,24 +24186,30 @@ x_delete_display (struct x_display_info *dpyinfo) tail->next = tail->next->next; } - for (color_entry = dpyinfo->color_names; - color_entry; - color_entry = next_color_entry) + for (i = 0; i < dpyinfo->color_names_size; ++i) { - next_color_entry = color_entry->next; - xfree (color_entry->name); - xfree (color_entry); + for (color_entry = dpyinfo->color_names[i]; + color_entry; color_entry = next_color_entry) + { + next_color_entry = color_entry->next; + + xfree (color_entry->name); + xfree (color_entry); + } } + xfree (dpyinfo->color_names); xfree (dpyinfo->x_id_name); xfree (dpyinfo->x_dnd_atoms); xfree (dpyinfo->color_cells); - xfree (dpyinfo); - +#ifdef USE_TOOLKIT_SCROLL_BARS + xfree (dpyinfo->protected_windows); +#endif #ifdef HAVE_XINPUT2 if (dpyinfo->supports_xi2) x_free_xi_devices (dpyinfo); #endif + xfree (dpyinfo); } #ifdef USE_X_TOOLKIT @@ -18140,6 +24325,27 @@ x_delete_terminal (struct terminal *terminal) image_destroy_all_bitmaps (dpyinfo); XSetCloseDownMode (dpyinfo->display, DestroyAll); + /* Get rid of any drag-and-drop operation that might be in + progress as well. */ + if ((x_dnd_in_progress || x_dnd_waiting_for_finish) + && dpyinfo->display == (x_dnd_waiting_for_finish + ? x_dnd_finish_display + : FRAME_X_DISPLAY (x_dnd_frame))) + { + x_dnd_last_seen_window = None; + x_dnd_last_seen_toplevel = None; + x_dnd_in_progress = false; + x_set_dnd_targets (NULL, 0); + x_dnd_waiting_for_finish = false; + + if (x_dnd_use_toplevels) + x_dnd_free_toplevels (); + + x_dnd_return_frame_object = NULL; + x_dnd_movement_frame = NULL; + x_dnd_frame = NULL; + } + /* Whether or not XCloseDisplay destroys the associated resource database depends on the version of libX11. To avoid both crash and memory leak, we dissociate the database from the @@ -18227,7 +24433,9 @@ x_create_terminal (struct x_display_info *dpyinfo) terminal->update_end_hook = x_update_end; terminal->read_socket_hook = XTread_socket; terminal->frame_up_to_date_hook = XTframe_up_to_date; +#ifdef HAVE_XDBE terminal->buffer_flipping_unblocked_hook = XTbuffer_flipping_unblocked_hook; +#endif terminal->defined_color_hook = x_defined_color; terminal->query_frame_background_color = x_query_frame_background_color; terminal->query_colors = x_query_colors; @@ -18281,6 +24489,7 @@ x_initialize (void) x_noop_count = 0; any_help_event_p = false; ignore_next_mouse_click_timeout = 0; + mouse_click_timeout_display = NULL; #ifdef USE_GTK current_count = -1; @@ -18346,66 +24555,42 @@ init_xterm (void) } #endif -#ifdef HAVE_XRENDER void -x_xrender_color_from_gc_foreground (struct frame *f, GC gc, XRenderColor *color, - bool apply_alpha_background) +mark_xterm (void) { - XGCValues xgcv; - XColor xc; - - XGetGCValues (FRAME_X_DISPLAY (f), gc, GCForeground, &xgcv); - xc.pixel = xgcv.foreground; - x_query_colors (f, &xc, 1); - - color->alpha = (apply_alpha_background - ? 65535 * f->alpha_background - : 65535); - - if (color->alpha == 65535) - { - color->red = xc.red; - color->blue = xc.blue; - color->green = xc.green; - } - else - { - color->red = (xc.red * color->alpha) / 65535; - color->blue = (xc.blue * color->alpha) / 65535; - color->green = (xc.green * color->alpha) / 65535; - } -} - -void -x_xrender_color_from_gc_background (struct frame *f, GC gc, XRenderColor *color, - bool apply_alpha_background) -{ - XGCValues xgcv; - XColor xc; - - XGetGCValues (FRAME_X_DISPLAY (f), gc, GCBackground, &xgcv); - xc.pixel = xgcv.background; - x_query_colors (f, &xc, 1); - - color->alpha = (apply_alpha_background - ? 65535 * f->alpha_background - : 65535); - - if (color->alpha == 65535) - { - color->red = xc.red; - color->blue = xc.blue; - color->green = xc.green; - } - else - { - color->red = (xc.red * color->alpha) / 65535; - color->blue = (xc.blue * color->alpha) / 65535; - color->green = (xc.green * color->alpha) / 65535; - } -} + Lisp_Object val; +#if defined HAVE_XINPUT2 || defined USE_TOOLKIT_SCROLL_BARS + struct x_display_info *dpyinfo; + int i; #endif + if (x_dnd_return_frame_object) + { + XSETFRAME (val, x_dnd_return_frame_object); + mark_object (val); + } + + if (x_dnd_movement_frame) + { + XSETFRAME (val, x_dnd_movement_frame); + mark_object (val); + } + +#if defined HAVE_XINPUT2 || defined USE_TOOLKIT_SCROLL_BARS + for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next) + { +#ifdef HAVE_XINPUT2 + for (i = 0; i < dpyinfo->num_devices; ++i) + mark_object (dpyinfo->devices[i].name); +#endif +#ifdef USE_TOOLKIT_SCROLL_BARS + for (i = 0; i < dpyinfo->n_protected_windows; ++i) + mark_object (dpyinfo->protected_windows[i]); +#endif + } +#endif +} + void syms_of_xterm (void) { @@ -18414,6 +24599,7 @@ syms_of_xterm (void) DEFSYM (Qvendor_specific_keysyms, "vendor-specific-keysyms"); DEFSYM (Qlatin_1, "latin-1"); + DEFSYM (Qnow, "now"); #ifdef USE_GTK xg_default_icon_file = build_pure_c_string ("icons/hicolor/scalable/apps/emacs.svg"); @@ -18485,6 +24671,7 @@ With MS Windows, Haiku windowing or Nextstep, the value is t. */); Fput (Qmeta, Qmodifier_value, make_fixnum (meta_modifier)); DEFSYM (Qsuper, "super"); Fput (Qsuper, Qmodifier_value, make_fixnum (super_modifier)); + DEFSYM (QXdndSelection, "XdndSelection"); DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym, doc: /* Which keys Emacs uses for the ctrl modifier. @@ -18595,4 +24782,34 @@ reliably continue to receive updates even if the finger moves off the frame, but may cause crashes with some window managers and/or external programs. */); x_input_grab_touch_events = true; + + DEFVAR_BOOL ("x-dnd-fix-motif-leave", x_dnd_fix_motif_leave, + doc: /* Work around Motif bug during drag-and-drop. +When non-nil, Emacs will send a motion event containing impossible +coordinates to a Motif drop receiver when the mouse moves outside it +during a drag-and-drop session, to work around broken implementations +of Motif. */); + x_dnd_fix_motif_leave = true; + + DEFVAR_LISP ("x-dnd-movement-function", Vx_dnd_movement_function, + doc: /* Function called upon mouse movement on a frame during drag-and-drop. +It should either be nil, or accept two arguments FRAME and POSITION, +where FRAME is the frame the mouse is on top of, and POSITION is a +mouse position list. */); + Vx_dnd_movement_function = Qnil; + + DEFVAR_LISP ("x-dnd-unsupported-drop-function", Vx_dnd_unsupported_drop_function, + doc: /* Function called when trying to drop on an unsupported window. +This function is called whenever the user tries to drop +something on a window that does not support either the XDND or +Motif protocols for drag-and-drop. It should return a non-nil +value if the drop was handled by the function, and nil if it was +not. It should accept several arguments TARGETS, X, Y, ACTION, +WINDOW-ID and FRAME, where TARGETS is the list of targets that +was passed to `x-begin-drag', WINDOW-ID is the numeric XID of +the window that is being dropped on, X and Y are the root +window-relative coordinates where the drop happened, ACTION +is the action that was passed to `x-begin-drag', and FRAME is +the frame which initiated the drag-and-drop operation. */); + Vx_dnd_unsupported_drop_function = Qnil; } diff --git a/src/xterm.h b/src/xterm.h index 4875eabafe6..3e06564bee9 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -232,8 +232,7 @@ struct xi_device_t #ifdef HAVE_XINPUT2_1 int scroll_valuator_count; #endif - int grab; - bool master_p; + int grab, use; #ifdef HAVE_XINPUT2_2 bool direct_p; #endif @@ -244,6 +243,8 @@ struct xi_device_t #ifdef HAVE_XINPUT2_2 struct xi_touch_point_t *touchpoints; #endif + + Lisp_Object name; }; #endif @@ -320,8 +321,10 @@ struct x_display_info Unused if this display supports Xfixes extension. */ Cursor invisible_cursor; - /* Function used to toggle pointer visibility on this display. */ - void (*toggle_visible_pointer) (struct frame *, bool); +#ifdef HAVE_XFIXES + /* Whether or not to use Xfixes for pointer blanking. */ + bool fixes_pointer_blanking; +#endif #ifdef USE_GTK /* The GDK cursor for scroll bars and popup menus. */ @@ -396,6 +399,7 @@ struct x_display_info /* Atom for indicating window state to the window manager. */ Atom Xatom_wm_change_state; + Atom Xatom_wm_state; /* Other WM communication */ Atom Xatom_wm_configure_denied; /* When our config request is denied */ @@ -411,7 +415,7 @@ struct x_display_info Atom Xatom_CLIPBOARD, Xatom_TIMESTAMP, Xatom_TEXT, Xatom_DELETE, Xatom_COMPOUND_TEXT, Xatom_UTF8_STRING, Xatom_MULTIPLE, Xatom_INCR, Xatom_EMACS_TMP, Xatom_TARGETS, Xatom_NULL, - Xatom_ATOM, Xatom_ATOM_PAIR, Xatom_CLIPBOARD_MANAGER, Xatom_COUNTER, + Xatom_ATOM, Xatom_ATOM_PAIR, Xatom_CLIPBOARD_MANAGER, Xatom_EMACS_SERVER_TIME_PROP; /* More atoms for font properties. The last three are private @@ -429,6 +433,15 @@ struct x_display_info /* Atom used in XEmbed client messages. */ Atom Xatom_XEMBED, Xatom_XEMBED_INFO; + /* Atom used to determine whether or not the screen is composited. */ + Atom Xatom_NET_WM_CM_Sn; + + Atom Xatom_MOTIF_WM_HINTS, Xatom_MOTIF_DRAG_WINDOW, + Xatom_MOTIF_DRAG_TARGETS, Xatom_MOTIF_DRAG_AND_DROP_MESSAGE, + Xatom_MOTIF_DRAG_INITIATOR_INFO, Xatom_MOTIF_DRAG_RECEIVER_INFO; + + Atom Xatom_XmTRANSFER_SUCCESS, Xatom_XmTRANSFER_FAILURE; + /* The frame (if any) which has the X window that has keyboard focus. Zero if none. This is examined by Ffocus_frame in xfns.c. Note that a mere EnterNotify event can set this; if you need to know the @@ -498,7 +511,10 @@ struct x_display_info #endif /* A cache mapping color names to RGB values. */ - struct color_name_cache_entry *color_names; + struct color_name_cache_entry **color_names; + + /* The size of that hash table. */ + int color_names_size; /* If non-null, a cache of the colors in the color map. Don't use this directly, call x_color_cells instead. */ @@ -547,7 +563,8 @@ struct x_display_info Xatom_net_workarea, Xatom_net_wm_opaque_region, Xatom_net_wm_ping, Xatom_net_wm_sync_request, Xatom_net_wm_sync_request_counter, Xatom_net_wm_frame_drawn, Xatom_net_wm_user_time, - Xatom_net_wm_user_time_window; + Xatom_net_wm_user_time_window, Xatom_net_client_list_stacking, + Xatom_net_wm_pid; /* XSettings atoms and windows. */ Atom Xatom_xsettings_sel, Xatom_xsettings_prop, Xatom_xsettings_mgr; @@ -561,6 +578,14 @@ struct x_display_info /* SM */ Atom Xatom_SM_CLIENT_ID; + /* DND source. */ + Atom Xatom_XdndAware, Xatom_XdndSelection, Xatom_XdndTypeList, + Xatom_XdndActionCopy, Xatom_XdndActionMove, Xatom_XdndActionLink, + Xatom_XdndActionAsk, Xatom_XdndActionPrivate, Xatom_XdndActionList, + Xatom_XdndActionDescription, Xatom_XdndProxy, Xatom_XdndEnter, + Xatom_XdndPosition, Xatom_XdndStatus, Xatom_XdndLeave, Xatom_XdndDrop, + Xatom_XdndFinished; + #ifdef HAVE_XKB /* Virtual modifiers */ Atom Xatom_Meta, Xatom_Super, Xatom_Hyper, Xatom_ShiftLock, Xatom_Alt; @@ -594,6 +619,17 @@ struct x_display_info int num_devices; struct xi_device_t *devices; + + Time pending_keystroke_time; + int pending_keystroke_source; + +#if defined USE_GTK && !defined HAVE_GTK3 + /* This means the two variables above shouldn't be reset the first + time a KeyPress event arrives, since they were set from a raw key + press event that was sent before the first (real, not sent by an + input method) core key event. */ + bool pending_keystroke_time_special_p; +#endif #endif #ifdef HAVE_XKB @@ -627,6 +663,26 @@ struct x_display_info #ifdef HAVE_XINERAMA bool xinerama_supported_p; #endif + +#ifdef HAVE_XCOMPOSITE + bool composite_supported_p; + int composite_major; + int composite_minor; +#endif + +#ifdef HAVE_XSHAPE + bool xshape_supported_p; + int xshape_major; + int xshape_minor; + int xshape_event_base; + int xshape_error_base; +#endif + +#ifdef USE_TOOLKIT_SCROLL_BARS + Lisp_Object *protected_windows; + int n_protected_windows; + int protected_windows_max; +#endif }; #ifdef HAVE_X_I18N @@ -758,6 +814,13 @@ struct x_output GtkWindow *ttip_window; GtkIMContext *im_context; + +#ifdef HAVE_GTK3 + /* The CSS providers used for scroll bar foreground and background + colors. */ + GtkCssProvider *scrollbar_foreground_css_provider; + GtkCssProvider *scrollbar_background_css_provider; +#endif #endif /* USE_GTK */ /* If >=0, a bitmap index. The indicated bitmap is used for the @@ -924,6 +987,11 @@ struct x_output bool preedit_active; int preedit_caret; #endif + +#ifdef HAVE_XINPUT2 + XIEventMask *xi_masks; + int num_xi_masks; +#endif }; enum @@ -957,13 +1025,15 @@ extern void x_mark_frame_dirty (struct frame *f); code after any drawing command, but we can run code whenever someone asks for the handle necessary to draw. */ #define FRAME_X_DRAWABLE(f) \ - (x_mark_frame_dirty((f)), FRAME_X_RAW_DRAWABLE ((f))) + (x_mark_frame_dirty ((f)), FRAME_X_RAW_DRAWABLE ((f))) +#ifdef HAVE_XDBE #define FRAME_X_DOUBLE_BUFFERED_P(f) \ (FRAME_X_WINDOW (f) != FRAME_X_RAW_DRAWABLE (f)) /* Return the need-buffer-flip flag for frame F. */ #define FRAME_X_NEED_BUFFER_FLIP(f) ((f)->output_data.x->need_buffer_flip) +#endif /* Return the outermost X window associated with the frame F. */ #ifdef USE_X_TOOLKIT @@ -1316,7 +1386,8 @@ extern bool x_alloc_lighter_color_for_widget (Widget, Display *, Colormap, extern bool x_alloc_nearest_color (struct frame *, Colormap, XColor *); extern void x_query_colors (struct frame *f, XColor *, int); extern void x_clear_area (struct frame *f, int, int, int, int); -#if !defined USE_X_TOOLKIT && !defined USE_GTK +#if (defined USE_LUCID && defined HAVE_XINPUT2) \ + || (!defined USE_X_TOOLKIT && !defined USE_GTK) extern void x_mouse_leave (struct x_display_info *); #endif @@ -1337,8 +1408,6 @@ extern Lisp_Object x_cr_export_frames (Lisp_Object, cairo_surface_type_t); #endif #ifdef HAVE_XRENDER -extern void x_xrender_color_from_gc_foreground (struct frame *, GC, - XRenderColor *, bool); extern void x_xrender_color_from_gc_background (struct frame *, GC, XRenderColor *, bool); extern void x_xr_ensure_picture (struct frame *f); @@ -1346,7 +1415,17 @@ extern void x_xr_apply_ext_clip (struct frame *f, GC gc); extern void x_xr_reset_ext_clip (struct frame *f); #endif -extern void x_display_set_last_user_time (struct x_display_info *, Time); +#ifdef HAVE_GTK3 +extern void x_scroll_bar_configure (GdkEvent *); +#endif + +extern Lisp_Object x_dnd_begin_drag_and_drop (struct frame *, Time, Atom, + Lisp_Object, Atom *, const char **, + size_t, bool); +extern void x_dnd_do_unsupported_drop (struct x_display_info *, Lisp_Object, + Lisp_Object, Lisp_Object, Window, int, + int, Time); +extern void x_set_dnd_targets (Atom *, int); INLINE int x_display_pixel_height (struct x_display_info *dpyinfo) @@ -1417,13 +1496,6 @@ extern void x_handle_selection_notify (const XSelectionEvent *); extern void x_handle_selection_event (struct selection_input_event *); extern void x_clear_frame_selections (struct frame *); -extern void x_send_client_event (Lisp_Object display, - Lisp_Object dest, - Lisp_Object from, - Atom message_type, - Lisp_Object format, - Lisp_Object values); - extern bool x_handle_dnd_message (struct frame *, const XClientMessageEvent *, struct x_display_info *, @@ -1442,6 +1514,11 @@ extern Lisp_Object x_property_data_to_lisp (struct frame *, extern void x_clipboard_manager_save_frame (Lisp_Object); extern void x_clipboard_manager_save_all (void); +extern Lisp_Object x_timestamp_for_selection (struct x_display_info *, + Lisp_Object); +extern void x_set_pending_dnd_time (Time); +extern void x_own_selection (Lisp_Object, Lisp_Object, Lisp_Object); + #ifdef USE_GTK extern bool xg_set_icon (struct frame *, Lisp_Object); extern bool xg_set_icon_from_xpm_data (struct frame *, const char **); @@ -1500,10 +1577,16 @@ extern void x_session_close (void); extern struct input_event xg_pending_quit_event; #endif +extern bool x_dnd_in_progress; +extern struct frame *x_dnd_frame; + #ifdef HAVE_XINPUT2 -struct xi_device_t *xi_device_from_id (struct x_display_info *, int); +extern struct xi_device_t *xi_device_from_id (struct x_display_info *, int); +extern bool xi_frame_selected_for (struct frame *, unsigned long); #endif +extern void mark_xterm (void); + /* Is the frame embedded into another application? */ #define FRAME_X_EMBEDDED_P(f) (FRAME_X_OUTPUT(f)->explicit_parent != 0) diff --git a/src/xwidget.c b/src/xwidget.c index 71bc3504295..8bdfab02fd4 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -857,15 +857,34 @@ to_embedder (GdkWindow *window, double x, double y, } static GdkDevice * -find_suitable_pointer (struct frame *f) +find_suitable_pointer (struct frame *f, bool need_smooth) { GdkSeat *seat = gdk_display_get_default_seat (gtk_widget_get_display (FRAME_GTK_WIDGET (f))); + GList *devices, *tem; + GdkDevice *device; if (!seat) return NULL; - return gdk_seat_get_pointer (seat); + devices = gdk_seat_get_slaves (seat, GDK_SEAT_CAPABILITY_ALL_POINTING); + device = NULL; + tem = NULL; + + if (need_smooth) + { + for (tem = devices; tem; tem = tem->next) + { + device = GDK_DEVICE (tem->data); + + if (gdk_device_get_source (device) == GDK_SOURCE_TOUCHPAD) + break; + } + } + + g_list_free (devices); + + return !tem ? gdk_seat_get_pointer (seat) : device; } static GdkDevice * @@ -1196,7 +1215,7 @@ xwidget_button_1 (struct xwidget_view *view, xg_event->button.button = button; xg_event->button.state = modifier_state; xg_event->button.time = time; - xg_event->button.device = find_suitable_pointer (view->frame); + xg_event->button.device = find_suitable_pointer (view->frame, false); gtk_main_do_event (xg_event); gdk_event_free (xg_event); @@ -1242,7 +1261,8 @@ xwidget_button_1 (struct xwidget_view *view, xg_event->crossing.detail = GDK_NOTIFY_ANCESTOR; xg_event->crossing.mode = GDK_CROSSING_UNGRAB; xg_event->crossing.window = g_object_ref (target_window); - gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + gdk_event_set_device (xg_event, + find_suitable_pointer (view->frame, false)); gtk_main_do_event (xg_event); gdk_event_free (xg_event); @@ -1264,7 +1284,8 @@ xwidget_button_1 (struct xwidget_view *view, xg_event->crossing.mode = GDK_CROSSING_UNGRAB; xg_event->crossing.window = g_object_ref (toplevel); - gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + gdk_event_set_device (xg_event, + find_suitable_pointer (view->frame, false)); gtk_main_do_event (xg_event); gdk_event_free (xg_event); } @@ -1323,7 +1344,8 @@ xwidget_button (struct xwidget_view *view, else xg_event->scroll.direction = GDK_SCROLL_RIGHT; - xg_event->scroll.device = find_suitable_pointer (view->frame); + xg_event->scroll.device = find_suitable_pointer (view->frame, + false); xg_event->scroll.x = x; xg_event->scroll.x_root = x; @@ -1387,7 +1409,7 @@ xwidget_motion_notify (struct xwidget_view *view, xg_event->motion.y_root = root_y; xg_event->motion.time = time; xg_event->motion.state = state; - xg_event->motion.device = find_suitable_pointer (view->frame); + xg_event->motion.device = find_suitable_pointer (view->frame, false); g_object_ref (xg_event->any.window); @@ -1434,7 +1456,7 @@ xwidget_scroll (struct xwidget_view *view, double x, double y, xg_event->scroll.state = state; xg_event->scroll.delta_x = dx; xg_event->scroll.delta_y = dy; - xg_event->scroll.device = find_suitable_pointer (view->frame); + xg_event->scroll.device = find_suitable_pointer (view->frame, true); xg_event->scroll.is_stop = stop_p; g_object_ref (xg_event->any.window); @@ -1499,7 +1521,7 @@ xwidget_pinch (struct xwidget_view *view, XIGesturePinchEvent *xev) break; } - gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + gdk_event_set_device (xg_event, find_suitable_pointer (view->frame, false)); g_object_ref (xg_event->any.window); gtk_main_do_event (xg_event); @@ -1624,7 +1646,8 @@ xw_notify_virtual_upwards_until (struct xwidget_view *xv, { xg_event = gdk_event_new (type); - gdk_event_set_device (xg_event, find_suitable_pointer (xv->frame)); + gdk_event_set_device (xg_event, + find_suitable_pointer (xv->frame, false)); window_coords_from_toplevel (tem, toplevel, x, y, &cx, &cy); xg_event->crossing.x = cx; xg_event->crossing.y = cy; @@ -1670,7 +1693,8 @@ xw_notify_virtual_downwards_until (struct xwidget_view *xv, tem = it->data; xg_event = gdk_event_new (type); - gdk_event_set_device (xg_event, find_suitable_pointer (xv->frame)); + gdk_event_set_device (xg_event, + find_suitable_pointer (xv->frame, false)); window_coords_from_toplevel (tem, toplevel, x, y, &cx, &cy); xg_event->crossing.x = cx; xg_event->crossing.y = cy; @@ -1775,7 +1799,8 @@ xw_maybe_synthesize_crossing (struct xwidget_view *view, xg_event->crossing.detail = GDK_NOTIFY_ANCESTOR; xg_event->crossing.mode = exit_crossing; xg_event->crossing.window = g_object_ref (view->last_crossing_window); - gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + gdk_event_set_device (xg_event, + find_suitable_pointer (view->frame, false)); gtk_main_do_event (xg_event); gdk_event_free (xg_event); @@ -1839,7 +1864,8 @@ xw_maybe_synthesize_crossing (struct xwidget_view *view, exit_crossing); xg_event = gdk_event_new (GDK_LEAVE_NOTIFY); - gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + gdk_event_set_device (xg_event, + find_suitable_pointer (view->frame, false)); window_coords_from_toplevel (last_crossing, toplevel, x, y, &cx, &cy); xg_event->crossing.x = cx; @@ -1867,7 +1893,8 @@ xw_maybe_synthesize_crossing (struct xwidget_view *view, entry_crossing); xg_event = gdk_event_new (GDK_ENTER_NOTIFY); - gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + gdk_event_set_device (xg_event, + find_suitable_pointer (view->frame, false)); window_coords_from_toplevel (current_window, toplevel, x, y, &cx, &cy); xg_event->crossing.x = cx; @@ -1970,7 +1997,8 @@ xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event) xg_event->motion.y_root = event->xmotion.y_root; xg_event->motion.time = event->xmotion.time; xg_event->motion.state = event->xmotion.state; - xg_event->motion.device = find_suitable_pointer (view->frame); + xg_event->motion.device + = find_suitable_pointer (view->frame, false); } else { @@ -2017,7 +2045,8 @@ xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event) return; } - gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + gdk_event_set_device (xg_event, + find_suitable_pointer (view->frame, false)); } #endif else @@ -2046,7 +2075,8 @@ xwidget_motion_or_crossing (struct xwidget_view *view, const XEvent *event) xg_event->crossing.x_root = event->xcrossing.x_root; xg_event->crossing.y_root = event->xcrossing.y_root; xg_event->crossing.focus = event->xcrossing.focus; - gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + gdk_event_set_device (xg_event, + find_suitable_pointer (view->frame, false)); } gtk_main_do_event (xg_event); @@ -2072,7 +2102,8 @@ synthesize_focus_in_event (GtkWidget *offscreen_window) if (FRAME_WINDOW_P (SELECTED_FRAME ())) gdk_event_set_device (focus_event, - find_suitable_pointer (SELECTED_FRAME ())); + find_suitable_pointer (SELECTED_FRAME (), + false)); g_object_ref (wnd); diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index 892fd278df8..56cb9057ed9 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -38,7 +38,7 @@ ;; be used to compare such calc expressions. (defun calc-tests-equal (a b) "Like `equal' but allow for different representations of numbers. -For example: (calc-tests-equal 10 '(float 1 1)) => t. +For example: (calc-tests-equal 10 \\='(float 1 1)) => t. A and B should be calc expressions." (cond ((math-numberp a) (and (math-numberp b) diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 5a37c914931..fd4d5ac8a1b 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -88,14 +88,19 @@ (ert-deftest test-format-seconds () (should (equal (format-seconds "%y %d %h %m %s %%" 0) "0 0 0 0 0 %")) (should (equal (format-seconds "%y %d %h %m %s %%" 9999999) "0 115 17 46 39 %")) - (should (equal (format-seconds "%y %d %h %m %z %s %%" 1) " 1 %")) + (should (equal (format-seconds "%y %d %h %m %z %s %%" 1) "1 %")) (should (equal (format-seconds "%mm %ss" 66) "1m 6s")) (should (equal (format-seconds "%mm %5ss" 66) "1m 6s")) (should (equal (format-seconds "%mm %.5ss" 66.4) "1m 00006s")) (should (equal (format-seconds "%mm %,1ss" 66.4) "1m 6.4s")) (should (equal (format-seconds "%mm %5,1ss" 66.4) "1m 6.4s")) - (should (equal (format-seconds "%mm %.5,1ss" 66.4) "1m 006.4s"))) + (should (equal (format-seconds "%mm %.5,1ss" 66.4) "1m 006.4s")) + + (should (equal (format-seconds "%hh %z%x%mm %ss" (* 60 2)) "2m")) + (should (equal (format-seconds "%hh %z%mm %ss" (* 60 2)) "2m 0s")) + (should (equal (format-seconds "%hh %x%mm %ss" (* 60 2)) "0h 2m")) + (should (equal (format-seconds "%hh %x%mm %ss" 0) "0h 0m 0s"))) (ert-deftest test-ordinal () (should (equal (date-ordinal-to-time 2008 271) diff --git a/test/lisp/cedet/srecode-utest-template.el b/test/lisp/cedet/srecode-utest-template.el index 1eb91e6053b..87c28c6af12 100644 --- a/test/lisp/cedet/srecode-utest-template.el +++ b/test/lisp/cedet/srecode-utest-template.el @@ -33,7 +33,7 @@ ;;; MAP DUMP TESTING (defun srecode-utest-map-reset () "Reset, then dump the map of SRecoder templates. -Probably should be called 'describe-srecode-maps'." +Probably should be called `describe-srecode-maps'." (interactive) (message "SRecode Template Path: %S" srecode-map-load-path) ;; Interactive call allows us to dump. diff --git a/test/lisp/color-tests.el b/test/lisp/color-tests.el index 49b632c8410..e4e1eda26d3 100644 --- a/test/lisp/color-tests.el +++ b/test/lisp/color-tests.el @@ -220,32 +220,32 @@ (ert-deftest color-tests-lighten-hsl () (should (equal (color-lighten-hsl 360 0.5 0.5 0) '(360 0.5 0.5))) - (should (equal (color-lighten-hsl 360 0.5 0.5 -10) '(360 0.5 0.4))) + (should (equal (color-lighten-hsl 360 0.5 0.5 -10) '(360 0.5 0.45))) (should (equal (color-lighten-hsl 360 0.5 0.5 -500) '(360 0.5 0.0))) (should (color-tests--approx-equal - (color-lighten-hsl 120 0.5 0.8 5) '(120 0.5 0.85))) + (color-lighten-hsl 120 0.5 0.8 5) '(120 0.5 0.84))) (should (equal (color-lighten-hsl 120 0.5 0.8 500) '(120 0.5 1.0)))) (ert-deftest color-tests-lighten-name () - (should (equal (color-lighten-name "black" 100) "#ffffffffffff")) + (should (equal (color-lighten-name "black" 100) "#000000000000")) (should (equal (color-lighten-name "white" 100) "#ffffffffffff")) (should (equal (color-lighten-name "red" 0) "#ffff00000000")) - (should (equal (color-lighten-name "red" 10) "#ffff33323332"))) + (should (equal (color-lighten-name "red" 10) "#ffff19991999"))) (ert-deftest color-tests-darken-hsl () (should (equal (color-darken-hsl 360 0.5 0.5 0) '(360 0.5 0.5))) - (should (equal (color-darken-hsl 360 0.5 0.5 -10) '(360 0.5 0.6))) + (should (equal (color-darken-hsl 360 0.5 0.5 -10) '(360 0.5 0.55))) (should (equal (color-darken-hsl 360 0.5 0.5 -500) '(360 0.5 1.0))) - (should (equal (color-darken-hsl 120 0.5 0.8 5) '(120 0.5 0.75))) + (should (equal (color-darken-hsl 120 0.5 0.8 5) '(120 0.5 0.76))) (should (equal (color-darken-hsl 120 0.5 0.8 500) '(120 0.5 0.0)))) (ert-deftest color-tests-darken-name () (should (equal (color-darken-name "black" 100) "#000000000000")) (should (equal (color-darken-name "white" 100) "#000000000000")) (should (equal (color-darken-name "red" 0) "#ffff00000000")) - (should (equal (color-darken-name "red" 10) "#cccc00000000"))) + (should (equal (color-darken-name "red" 10) "#e66500000000"))) (provide 'color-tests) ;;; color-tests.el ends here diff --git a/test/lisp/desktop-tests.el b/test/lisp/desktop-tests.el new file mode 100644 index 00000000000..d52fe39ed96 --- /dev/null +++ b/test/lisp/desktop-tests.el @@ -0,0 +1,50 @@ +;;; desktop-tests.el --- Tests for desktop.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; 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 . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'desktop) + +(ert-deftest desktop-tests--emacs-pid-running-p () + (should (desktop--emacs-pid-running-p (emacs-pid))) + (should-not (desktop--emacs-pid-running-p 1))) + +(ert-deftest desktop-tests--load-locked-desktop-p () + (let ((desktop-load-locked-desktop t)) + (should (desktop--load-locked-desktop-p (emacs-pid))))) + +(ert-deftest desktop-tests--load-locked-desktop-p-nil () + (let ((desktop-load-locked-desktop nil)) + (should-not (desktop--load-locked-desktop-p (emacs-pid))))) + +(ert-deftest desktop-tests--load-locked-desktop-p-ask () + (let ((desktop-load-locked-desktop 'ask)) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (&rest _) t))) + (should (desktop--load-locked-desktop-p (emacs-pid)))) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (&rest _) nil))) + (should-not (desktop--load-locked-desktop-p (emacs-pid)))))) + +(ert-deftest desktop-tests--load-locked-desktop-p-check () + (let ((desktop-load-locked-desktop 'check-pid)) + (desktop--load-locked-desktop-p (emacs-pid)))) + +(provide 'desktop-tests) diff --git a/test/lisp/edmacro-tests.el b/test/lisp/edmacro-tests.el index b5809ad0b77..e386342f6ee 100644 --- a/test/lisp/edmacro-tests.el +++ b/test/lisp/edmacro-tests.el @@ -25,23 +25,24 @@ (require 'edmacro) (ert-deftest edmacro-test-edmacro-parse-keys () - (should (equal (edmacro-parse-keys "") "")) - (should (equal (edmacro-parse-keys "x") "x")) - (should (equal (edmacro-parse-keys "C-a") "\C-a")) + (should (equal (edmacro-parse-keys "") [])) + (should (equal (edmacro-parse-keys "x") [?x])) + (should (equal (edmacro-parse-keys "C-a") [?\C-a])) ;; comments - (should (equal (edmacro-parse-keys ";; foobar") "")) - (should (equal (edmacro-parse-keys ";;;") "")) - (should (equal (edmacro-parse-keys "; ; ;") ";;;")) - (should (equal (edmacro-parse-keys "REM foobar") "")) - (should (equal (edmacro-parse-keys "x ;; foobar") "x")) - (should (equal (edmacro-parse-keys "x REM foobar") "x")) + (should (equal (edmacro-parse-keys ";; foobar") [])) + (should (equal (edmacro-parse-keys ";;;") [])) + (should (equal (edmacro-parse-keys "; ; ;") [?\; ?\; ?\;])) + (should (equal (edmacro-parse-keys "REM foobar") [])) + (should (equal (edmacro-parse-keys "x ;; foobar") [?x])) + (should (equal (edmacro-parse-keys "x REM foobar") [?x])) (should (equal (edmacro-parse-keys "<>") - [134217848 103 111 116 111 45 108 105 110 101 13])) + [?\M-x ?g ?o ?t ?o ?- ?l ?i ?n ?e ?\r])) ;; repetitions - (should (equal (edmacro-parse-keys "3*x") "xxx")) - (should (equal (edmacro-parse-keys "3*C-m") "\C-m\C-m\C-m")) - (should (equal (edmacro-parse-keys "10*foo") "foofoofoofoofoofoofoofoofoofoo"))) + (should (equal (edmacro-parse-keys "3*x") [?x ?x ?x])) + (should (equal (edmacro-parse-keys "3*C-m") [?\C-m ?\C-m ?\C-m])) + (should (equal (edmacro-parse-keys "10*foo") + (apply #'vconcat (make-list 10 [?f ?o ?o]))))) ;;; edmacro-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 036ee30966b..19ede627a13 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -709,4 +709,22 @@ collection clause." ;; Just make sure the forms can be instrumented. (eval-buffer)))) +(ert-deftest cl-defstruct/edebug () + "Check that we can instrument `cl-defstruct' forms." + (with-temp-buffer + (dolist (form '((cl-defstruct cl-defstruct/edebug/1) + (cl-defstruct (cl-defstruct/edebug/2 + :noinline)) + (cl-defstruct (cl-defstruct/edebug/3 + (:noinline t))) + (cl-defstruct (cl-defstruct/edebug/4 + :named)) + (cl-defstruct (cl-defstruct/edebug/5 + (:named t))))) + (print form (current-buffer))) + (let ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop)) + ;; Just make sure the forms can be instrumented. + (eval-buffer)))) + ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/easy-mmode-tests.el b/test/lisp/emacs-lisp/easy-mmode-tests.el index 0a3bbb189ba..f6d07196727 100644 --- a/test/lisp/emacs-lisp/easy-mmode-tests.el +++ b/test/lisp/emacs-lisp/easy-mmode-tests.el @@ -60,6 +60,4 @@ (easy-mmode-test-mode 'toggle) (should (eq easy-mmode-test-mode t)))) -(provide 'easy-mmode-tests) - ;;; easy-mmode-tests.el ends here diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 7573d2ed056..84c28e11315 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -377,8 +377,11 @@ This macro is used to test if macroexpansion in `should' works." (test (make-ert-test :body test-body)) (result (ert-run-test test))) (should (ert-test-failed-p result)) - (should (eq (backtrace-frame-fun (car (ert-test-failed-backtrace result))) - 'signal)))) + (should (memq (backtrace-frame-fun (car (ert-test-failed-backtrace result))) + ;;; This is `ert-fail' on nativecomp and `signal' + ;;; otherwise. It's not clear whether that's a bug + ;;; or not (bug#51308). + '(ert-fail signal))))) (ert-deftest ert-test-messages () :tags '(:causes-redisplay) diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index f21624cfd87..a675986b90b 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -153,13 +153,13 @@ function being an around advice." (ert-deftest advice-test-call-interactively () "Check interaction between advice on call-interactively and called-interactively-p." - (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p))) - (let ((old (symbol-function 'call-interactively))) + (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p)))) + (old (symbol-function 'call-interactively))) (unwind-protect (progn (advice-add 'call-interactively :before #'ignore) - (should (equal (sm-test7.4) '(1 . nil))) - (should (equal (call-interactively 'sm-test7.4) '(1 . t)))) + (should (equal (funcall sm-test7.4) '(1 . nil))) + (should (equal (call-interactively sm-test7.4) '(1 . t)))) (advice-remove 'call-interactively #'ignore) (should (eq (symbol-function 'call-interactively) old))))) @@ -204,6 +204,15 @@ function being an around advice." (remove-function (var sm-test10) sm-advice) (should (equal (funcall sm-test10 5) 15)))) +(ert-deftest advice-test-print () + (let ((x (list 'cdr))) + (add-function :after (car x) 'car) + (should (equal (cl-prin1-to-string (car x)) + "#f(advice car :after cdr)")) + (add-function :before (car x) 'first) + (should (equal (cl-prin1-to-string (car x)) + "#f(advice first :before #f(advice car :after cdr))")))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el new file mode 100644 index 00000000000..b3a921826b1 --- /dev/null +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -0,0 +1,165 @@ +;;; oclosure-tests.e; --- Tests for Open Closures -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; 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 . + +;;; Code: + +(require 'ert) +(require 'oclosure) +(require 'cl-lib) +(require 'eieio) + +(oclosure-define (oclosure-test + (:copier oclosure-test-copy) + (:copier oclosure-test-copy1 (fst))) + "Simple OClosure." + fst snd (name :mutable t)) + +(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#") + +(cl-defmethod oclosure-test-gen ((_x cons)) "#") + +(cl-defmethod oclosure-test-gen ((_x oclosure)) + (format "#" (cl-call-next-method))) + +(cl-defmethod oclosure-test-gen ((_x oclosure-test)) + (format "#" (cl-call-next-method))) + +(ert-deftest oclosure-test () + (let* ((i 42) + (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi")) + () + (list fst snd i))) + (ocl2 (oclosure-lambda (oclosure-test (name (cl-incf i)) (fst (cl-incf i))) + () + (list fst snd 152 i)))) + (should (equal (list (oclosure-test--fst ocl1) + (oclosure-test--snd ocl1) + (oclosure-test--name ocl1)) + '(1 2 "hi"))) + (should (equal (list (oclosure-test--fst ocl2) + (oclosure-test--snd ocl2) + (oclosure-test--name ocl2)) + '(44 nil 43))) + (should (equal (funcall ocl1) '(1 2 44))) + (should (equal (funcall ocl2) '(44 nil 152 44))) + (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44))) + (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44))) + (should (cl-typep ocl1 'oclosure-test)) + (should (cl-typep ocl1 'oclosure)) + (should (member (oclosure-test-gen ocl1) + '("#>>" + "#>>"))) + (should (stringp (documentation #'oclosure-test--fst))) + )) + +(ert-deftest oclosure-test-limits () + (should + (condition-case err + (let ((lexical-binding t) + (byte-compile-debug t)) + (byte-compile '(lambda () + (let ((inc-fst nil)) + (oclosure-lambda (oclosure-test (fst 'foo)) () + (setq inc-fst (lambda () (setq fst (1+ fst)))) + fst)))) + nil) + (error + (and (eq 'error (car err)) + (string-match "fst.*mutated" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand-all '(oclosure-define oclosure--foo a a)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot name: a$" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand-all + '(oclosure-define (oclosure--foo (:parent oclosure-test)) fst)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot name: fst$" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand '(oclosure-lambda (oclosure-test (fst 1) (fst 2)) + () fst)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot: fst$" (cadr err))))))) + +(cl-defmethod oclosure-interactive-form ((ot oclosure-test)) + (let ((snd (oclosure-test--snd ot))) + (if (stringp snd) (list 'interactive snd)))) + +(ert-deftest oclosure-test-interactive-form () + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst)) + nil)) + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () + (interactive "r") + fst)) + '(interactive "r"))) + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst)) + '(interactive "P"))) + (should (not (commandp + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst)))) + (should (commandp + (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst)))) + +(oclosure-define (oclosure-test-mut + (:parent oclosure-test) + (:copier oclosure-test-mut-copy)) + "Simple OClosure with a mutable field." + (mut :mutable t)) + +(ert-deftest oclosure-test-mutate () + (let* ((f (oclosure-lambda (oclosure-test-mut (fst 0) (mut 3)) + (x) + (+ x fst mut))) + (f2 (oclosure-test-mut-copy f :fst 50))) + (should (equal (oclosure-test-mut--mut f) 3)) + (should (equal (funcall f 5) 8)) + (should (equal (funcall f2 5) 58)) + (cl-incf (oclosure-test-mut--mut f) 7) + (should (equal (oclosure-test-mut--mut f) 10)) + (should (equal (funcall f 5) 15)) + (should (equal (funcall f2 15) 68)))) + +(ert-deftest oclosure-test-slot-value () + (require 'eieio) + (let ((ocl (oclosure-lambda + (oclosure-test (fst 'fst1) (snd 'snd1) (name 'name1)) + (x) + (list name fst snd x)))) + (should (equal 'fst1 (slot-value ocl 'fst))) + (should (equal 'snd1 (slot-value ocl 'snd))) + (should (equal 'name1 (slot-value ocl 'name))) + (setf (slot-value ocl 'name) 'new-name) + (should (equal 'new-name (slot-value ocl 'name))) + (should (equal '(new-name fst1 snd1 arg) (funcall ocl 'arg))) + (should-error (setf (slot-value ocl 'fst) 'new-fst) :type 'setting-constant) + (should (equal 'fst1 (slot-value ocl 'fst))) + )) + +;;; oclosure-tests.el ends here. diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index c1c46d6400e..385b0fe44a5 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -66,5 +66,26 @@ (should (equal (list char str) (read-multiple-choice "Do it? " '((?y "yes") (?n "no")))))))) -(provide 'rmc-tests) +(ert-deftest test-read-multiple-choice-help () + (let ((chars '(?o ?a)) + help) + (cl-letf* (((symbol-function #'read-event) + (lambda () + (message "chars %S" chars) + (when (= 1 (length chars)) + (with-current-buffer "*Multiple Choice Help*" + (setq help (buffer-string)))) + (pop chars)))) + (read-multiple-choice + "Choose:" + '((?a "aaa") + (?b "bbb") + (?c "ccc" "a really long description of ccc"))) + (should (equal help "Choose: + +a: [A]aa b: [B]bb c: [C]cc + a really long + description of ccc + \n"))))) + ;;; rmc-tests.el ends here diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index d38a8e2352b..7f3916c2c0b 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -712,5 +712,37 @@ (loop (cdr rest) (+ sum (car rest)))))) (should (equal (mapcar #'funcall funs) '(43 1 0))))) +(ert-deftest test-with-buffer-unmodified-if-unchanged () + (with-temp-buffer + (with-buffer-unmodified-if-unchanged + (insert "t")) + (should (buffer-modified-p))) + + (with-temp-buffer + (with-buffer-unmodified-if-unchanged + (insert "t") + (delete-char -1)) + (should-not (buffer-modified-p))) + + ;; Shouldn't error. + (should + (with-temp-buffer + (with-buffer-unmodified-if-unchanged + (insert "t") + (delete-char -1) + (kill-buffer)))) + + (with-temp-buffer + (let ((outer (current-buffer))) + (with-temp-buffer + (let ((inner (current-buffer))) + (with-buffer-unmodified-if-unchanged + (insert "t") + (delete-char -1) + (set-buffer outer)) + (with-current-buffer inner + (should-not (buffer-modified-p)))))))) + + (provide 'subr-x-tests) ;;; subr-x-tests.el ends here diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 5603e764547..520f10dd4e6 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -21,7 +21,7 @@ ;;; Code: -(require 'ert) +(require 'ert-x) (require 'erc) (require 'erc-ring) (require 'erc-networks) @@ -114,6 +114,63 @@ (should (get-buffer "#spam")) (kill-buffer "#spam"))) +(ert-deftest erc--switch-to-buffer () + (defvar erc-modified-channels-alist) ; lisp/erc/erc-track.el + + (let ((proc (start-process "aNet" (current-buffer) "true")) + (erc-modified-channels-alist `(("fake") (,(messages-buffer)))) + (inhibit-message noninteractive) + (completion-fail-discreetly t) ; otherwise ^G^G printed to .log file + ;; + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + + (with-current-buffer (get-buffer-create "server") + (erc-mode) + (set-process-buffer (setq erc-server-process proc) (current-buffer)) + (set-process-query-on-exit-flag erc-server-process nil) + (with-current-buffer (get-buffer-create "#chan") + (erc-mode) + (setq erc-server-process proc)) + (with-current-buffer (get-buffer-create "#foo") + (erc-mode) + (setq erc-server-process proc)) + + (ert-info ("Channel #chan selectable from server buffer") + (ert-simulate-keys (list ?# ?c ?h ?a ?n ?\C-m) + (should (string= "#chan" (erc--switch-to-buffer)))))) + + (ert-info ("Channel #foo selectable from non-ERC buffer") + (ert-simulate-keys (list ?# ?f ?o ?o ?\C-m) + (should (string= "#foo" (erc--switch-to-buffer))))) + + (ert-info ("Default selectable") + (ert-simulate-keys (list ?\C-m) + (should (string= "*Messages*" (erc--switch-to-buffer))))) + + (ert-info ("Extant but non-ERC buffer not selectable") + (get-buffer-create "#fake") ; not ours + (ert-simulate-keys (kbd "#fake C-m C-a C-k C-m") + ;; Initial query fails ~~~~~~^; clearing input accepts default + (should (string= "*Messages*" (erc--switch-to-buffer))))) + + (with-current-buffer (get-buffer-create "other") + (erc-mode) + (setq erc-server-process (start-process "bNet" (current-buffer) "true")) + (set-process-query-on-exit-flag erc-server-process nil)) + + (ert-info ("Foreign ERC buffer not selectable") + (ert-simulate-keys (kbd "other C-m C-a C-k C-m") + (with-current-buffer "server" + (should (string= "*Messages*" (erc--switch-to-buffer)))))) + + (ert-info ("Any ERC-buffer selectable from non-ERC buffer") + (should-not (eq major-mode 'erc-mode)) + (ert-simulate-keys (list ?o ?t ?h ?e ?r ?\C-m) + (should (string= "other" (erc--switch-to-buffer))))) + + (dolist (b '("server" "other" "#chan" "#foo" "#fake")) + (kill-buffer b)))) + (ert-deftest erc-lurker-maybe-trim () (let (erc-lurker-trim-nicks (erc-lurker-ignore-chars "_`")) diff --git a/test/lisp/eshell/em-basic-tests.el b/test/lisp/eshell/em-basic-tests.el new file mode 100644 index 00000000000..7a24f8b46c3 --- /dev/null +++ b/test/lisp/eshell/em-basic-tests.el @@ -0,0 +1,71 @@ +;;; em-basic-tests.el --- em-basic test suite -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; 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 . + +;;; Commentary: + +;; Tests for basic Eshell commands. + +;;; Code: + +(require 'ert) +(require 'em-basic) + +(require 'eshell-tests-helpers + (expand-file-name "eshell-tests-helpers" + (file-name-directory (or load-file-name + default-directory)))) + +;;; Tests: + +(ert-deftest em-basic-test/umask-print-numeric () + "Test printing umask numerically." + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o775))) + (should (equal (eshell-test-command-result "umask") "002\n"))) + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o654))) + (should (equal (eshell-test-command-result "umask") "123\n"))) + ;; Make sure larger numbers don't cause problems. + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o1775))) + (should (equal (eshell-test-command-result "umask") "002\n")))) + +(ert-deftest em-basic-test/umask-read-symbolic () + "Test printing umask symbolically." + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o775))) + (should (equal (eshell-test-command-result "umask -S") + "u=rwx,g=rwx,o=rx\n"))) + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o654))) + (should (equal (eshell-test-command-result "umask -S") + "u=wx,g=rx,o=x\n"))) + ;; Make sure larger numbers don't cause problems. + (cl-letf (((symbol-function 'default-file-modes) (lambda () #o1775))) + (should (equal (eshell-test-command-result "umask -S") + "u=rwx,g=rwx,o=rx\n")))) + +(ert-deftest em-basic-test/umask-set () + "Test setting umask." + (let ((file-modes 0)) + (cl-letf (((symbol-function 'set-default-file-modes) + (lambda (mode) (setq file-modes mode)))) + (eshell-test-command-result "umask 002") + (should (= file-modes #o775)) + (eshell-test-command-result "umask 123") + (should (= file-modes #o654)) + (eshell-test-command-result "umask $(identity #o222)") + (should (= file-modes #o555))))) + +;; em-basic-tests.el ends here diff --git a/test/lisp/eshell/em-extpipe-tests.el b/test/lisp/eshell/em-extpipe-tests.el index 91c2fba4791..3b84d763ac6 100644 --- a/test/lisp/eshell/em-extpipe-tests.el +++ b/test/lisp/eshell/em-extpipe-tests.el @@ -170,7 +170,7 @@ (em-extpipe-tests--deftest em-extpipe-test-13 "foo*|bar" (should-parse '(eshell-execute-pipeline - '((eshell-named-command (concat "foo" "*")) + '((eshell-named-command (eshell-concat nil "foo" "*")) (eshell-named-command "bar"))))) (em-extpipe-tests--deftest em-extpipe-test-14 "tac *. + +;;; Commentary: + +;; Tests for Eshell's glob expansion. + +;;; Code: + +(require 'ert) +(require 'em-glob) + +(defmacro with-fake-files (files &rest body) + "Evaluate BODY forms, pretending that FILES exist on the filesystem. +FILES is a list of file names that should be reported as +appropriate by `file-name-all-completions'. Any file name +component ending in \"symlink\" is treated as a symbolic link." + (declare (indent 1)) + `(cl-letf (((symbol-function 'file-name-all-completions) + (lambda (file directory) + (cl-assert (string= file "")) + (setq directory (expand-file-name directory)) + `("./" "../" + ,@(delete-dups + (remq nil + (mapcar + (lambda (file) + (setq file (expand-file-name file)) + (when (string-prefix-p directory file) + (replace-regexp-in-string + "/.*" "/" + (substring file (length directory))))) + ,files)))))) + ((symbol-function 'file-symlink-p) + (lambda (file) + (string-suffix-p "symlink" file)))) + ,@body)) + +;;; Tests: + +(ert-deftest em-glob-test/match-any-string () + "Test that \"*\" pattern matches any string." + (with-fake-files '("a.el" "b.el" "c.txt" "dir/a.el") + (should (equal (eshell-extended-glob "*.el") + '("a.el" "b.el"))))) + +(ert-deftest em-glob-test/match-any-character () + "Test that \"?\" pattern matches any character." + (with-fake-files '("a.el" "b.el" "ccc.el" "d.txt" "dir/a.el") + (should (equal (eshell-extended-glob "?.el") + '("a.el" "b.el"))))) + +(ert-deftest em-glob-test/match-recursive () + "Test that \"**/\" recursively matches directories." + (with-fake-files '("a.el" "b.el" "ccc.el" "d.txt" "dir/a.el" "dir/sub/a.el" + "dir/symlink/a.el" "symlink/a.el" "symlink/sub/a.el") + (should (equal (eshell-extended-glob "**/a.el") + '("a.el" "dir/a.el" "dir/sub/a.el"))))) + +(ert-deftest em-glob-test/match-recursive-follow-symlinks () + "Test that \"***/\" recursively matches directories, following symlinks." + (with-fake-files '("a.el" "b.el" "ccc.el" "d.txt" "dir/a.el" "dir/sub/a.el" + "dir/symlink/a.el" "symlink/a.el" "symlink/sub/a.el") + (should (equal (eshell-extended-glob "***/a.el") + '("a.el" "dir/a.el" "dir/sub/a.el" "dir/symlink/a.el" + "symlink/a.el" "symlink/sub/a.el"))))) + +(ert-deftest em-glob-test/match-recursive-mixed () + "Test combination of \"**/\" and \"***/\"." + (with-fake-files '("dir/a.el" "dir/sub/a.el" "dir/sub2/a.el" + "dir/symlink/a.el" "dir/sub/symlink/a.el" "symlink/a.el" + "symlink/sub/a.el" "symlink/sub/symlink/a.el") + (should (equal (eshell-extended-glob "**/sub/***/a.el") + '("dir/sub/a.el" "dir/sub/symlink/a.el"))) + (should (equal (eshell-extended-glob "***/sub/**/a.el") + '("dir/sub/a.el" "symlink/sub/a.el"))))) + +(ert-deftest em-glob-test/match-character-set-individual () + "Test \"[...]\" for individual characters." + (with-fake-files '("a.el" "b.el" "c.el" "d.el" "dir/a.el") + (should (equal (eshell-extended-glob "[ab].el") + '("a.el" "b.el"))) + (should (equal (eshell-extended-glob "[^ab].el") + '("c.el" "d.el"))))) + +(ert-deftest em-glob-test/match-character-set-range () + "Test \"[...]\" for character ranges." + (with-fake-files '("a.el" "b.el" "c.el" "d.el" "dir/a.el") + (should (equal (eshell-extended-glob "[a-c].el") + '("a.el" "b.el" "c.el"))) + (should (equal (eshell-extended-glob "[^a-c].el") + '("d.el"))))) + +(ert-deftest em-glob-test/match-character-set-class () + "Test \"[...]\" for character classes." + (with-fake-files '("1.el" "a.el" "b.el" "c.el" "dir/a.el") + (should (equal (eshell-extended-glob "[[:alpha:]].el") + '("a.el" "b.el" "c.el"))) + (should (equal (eshell-extended-glob "[^[:alpha:]].el") + '("1.el"))))) + +(ert-deftest em-glob-test/match-character-set-mixed () + "Test \"[...]\" with multiple kinds of members at once." + (with-fake-files '("1.el" "a.el" "b.el" "c.el" "d.el" "dir/a.el") + (should (equal (eshell-extended-glob "[ac-d[:digit:]].el") + '("1.el" "a.el" "c.el" "d.el"))) + (should (equal (eshell-extended-glob "[^ac-d[:digit:]].el") + '("b.el"))))) + +(ert-deftest em-glob-test/match-group-alternative () + "Test \"(x|y)\" matches either \"x\" or \"y\"." + (with-fake-files '("em-alias.el" "em-banner.el" "esh-arg.el" "misc.el" + "test/em-xtra.el") + (should (equal (eshell-extended-glob "e(m|sh)-*.el") + '("em-alias.el" "em-banner.el" "esh-arg.el"))))) + +(ert-deftest em-glob-test/match-n-or-more-characters () + "Test that \"x#\" and \"x#\" match zero or more instances of \"x\"." + (with-fake-files '("h.el" "ha.el" "hi.el" "hii.el" "dir/hi.el") + (should (equal (eshell-extended-glob "hi#.el") + '("h.el" "hi.el" "hii.el"))) + (should (equal (eshell-extended-glob "hi##.el") + '("hi.el" "hii.el"))))) + +(ert-deftest em-glob-test/match-n-or-more-groups () + "Test that \"(x)#\" and \"(x)#\" match zero or more instances of \"(x)\"." + (with-fake-files '("h.el" "ha.el" "hi.el" "hii.el" "dir/hi.el") + (should (equal (eshell-extended-glob "hi#.el") + '("h.el" "hi.el" "hii.el"))) + (should (equal (eshell-extended-glob "hi##.el") + '("hi.el" "hii.el"))))) + +(ert-deftest em-glob-test/match-n-or-more-character-sets () + "Test that \"[x]#\" and \"[x]#\" match zero or more instances of \"[x]\"." + (with-fake-files '("w.el" "wh.el" "wha.el" "whi.el" "whaha.el" "dir/wha.el") + (should (equal (eshell-extended-glob "w[ah]#.el") + '("w.el" "wh.el" "wha.el" "whaha.el"))) + (should (equal (eshell-extended-glob "w[ah]##.el") + '("wh.el" "wha.el" "whaha.el"))))) + +(ert-deftest em-glob-test/match-x-but-not-y () + "Test that \"x~y\" matches \"x\" but not \"y\"." + (with-fake-files '("1" "12" "123" "42" "dir/1") + (should (equal (eshell-extended-glob "[[:digit:]]##~4?") + '("1" "12" "123"))))) + +(ert-deftest em-glob-test/no-matches () + "Test behavior when a glob fails to match any files." + (with-fake-files '("foo.el" "bar.el") + (should (equal (eshell-extended-glob "*.txt") + "*.txt")) + (let ((eshell-error-if-no-glob t)) + (should-error (eshell-extended-glob "*.txt"))))) + +;; em-glob-tests.el ends here diff --git a/test/lisp/eshell/em-pred-tests.el b/test/lisp/eshell/em-pred-tests.el new file mode 100644 index 00000000000..3b50543d69a --- /dev/null +++ b/test/lisp/eshell/em-pred-tests.el @@ -0,0 +1,548 @@ +;;; em-pred-tests.el --- em-pred test suite -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; 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 . + +;;; Commentary: + +;; Tests for Eshell's argument predicates/modifiers. + +;;; Code: + +(require 'ert) +(require 'esh-mode) +(require 'eshell) +(require 'em-pred) + +(require 'eshell-tests-helpers + (expand-file-name "eshell-tests-helpers" + (file-name-directory (or load-file-name + default-directory)))) + +(defvar eshell-test-value nil) + +(defun eshell-eval-predicate (initial-value predicate) + "Evaluate PREDICATE on INITIAL-VALUE, returning the result. +PREDICATE is an Eshell argument predicate/modifier." + (let ((eshell-test-value initial-value)) + (with-temp-eshell + (eshell-insert-command + (format "setq eshell-test-value $eshell-test-value(%s)" predicate))) + eshell-test-value)) + +(defun eshell-parse-file-name-attributes (file) + "Parse a fake FILE name to determine its attributes. +Fake file names are file names beginning with \"/fake/\". This +allows defining file names for fake files with various properties +to query via predicates. Attributes are written as a +comma-separate list of ATTR=VALUE pairs as the file's base name, +like: + + /fake/type=-,modes=0755.el + +The following attributes are recognized: + + * \"type\": A single character describing the file type; + accepts the same values as the first character of the file + modes in `ls -l'. + * \"modes\": The file's permission modes, in octal. + * \"links\": The number of links to this file. + * \"uid\": The UID of the file's owner. + * \"gid\": The UID of the file's group. + * \"atime\": The time the file was last accessed, in seconds + since the UNIX epoch. + * \"mtime\": As \"atime\", but for modification time. + * \"ctime\": As \"atime\", but for inode change time. + * \"size\": The file's size in bytes." + (mapcar (lambda (i) + (pcase (split-string i "=") + (`("modes" ,modes) + (cons 'modes (string-to-number modes 8))) + (`(,(and (or "links" "uid" "gid" "size") key) ,value) + (cons (intern key) (string-to-number value))) + (`(,(and (or "atime" "mtime" "ctime") key) ,value) + (cons (intern key) (time-convert (string-to-number value)))) + (`(,key ,value) + (cons (intern key) value)) + (_ (error "invalid format %S" i)))) + (split-string (file-name-base file) ","))) + +(defmacro eshell-partial-let-func (overrides &rest body) + "Temporarily bind to FUNCTION-NAMEs and evaluate BODY. +This is roughly analogous to advising functions, but only does so +while BODY is executing, and only calls NEW-FUNCTION if its first +argument is a string beginning with \"/fake/\". + +This allows selectively overriding functions to test file +properties with fake files without altering the functions' +behavior for real files. + +\(fn ((FUNCTION-NAME NEW-FUNCTION) ...) BODY...)" + (declare (indent 1)) + `(cl-letf + ,(mapcar + (lambda (override) + `((symbol-function #',(car override)) + (let ((orig-function (symbol-function #',(car override)))) + (lambda (file &rest rest) + (apply + (if (and (stringp file) (string-prefix-p "/fake/" file)) + ,(cadr override) + orig-function) + file rest))))) + overrides) + ,@body)) + +(defmacro eshell-with-file-attributes-from-name (&rest body) + "Temporarily override file attribute functions and evaluate BODY." + (declare (indent 0)) + `(eshell-partial-let-func + ((file-attributes + (lambda (file &optional _id-format) + (let ((attrs (eshell-parse-file-name-attributes file))) + (list (equal (alist-get 'type attrs) "d") + (or (alist-get 'links attrs) 1) + (or (alist-get 'uid attrs) 0) + (or (alist-get 'gid attrs) 0) + (or (alist-get 'atime attrs) nil) + (or (alist-get 'mtime attrs) nil) + (or (alist-get 'ctime attrs) nil) + (or (alist-get 'size attrs) 0) + (format "%s---------" (or (alist-get 'type attrs) "-")) + nil 0 0)))) + (file-modes + (lambda (file _nofollow) + (let ((attrs (eshell-parse-file-name-attributes file))) + (or (alist-get 'modes attrs) 0)))) + (file-exists-p #'always) + (file-regular-p + (lambda (file) + (let ((attrs (eshell-parse-file-name-attributes file))) + (member (or (alist-get 'type attrs) "-") '("-" "l"))))) + (file-symlink-p + (lambda (file) + (let ((attrs (eshell-parse-file-name-attributes file))) + (equal (alist-get 'type attrs) "l")))) + (file-executable-p + (lambda (file) + (let ((attrs (eshell-parse-file-name-attributes file))) + ;; For simplicity, just return whether the file is + ;; world-executable. + (= (logand (or (alist-get 'modes attrs) 0) 1) 1))))) + ,@body)) + +;;; Tests: + + +;; Argument predicates + +(ert-deftest em-pred-test/predicate-file-types () + "Test file type predicates." + (eshell-with-file-attributes-from-name + (let ((files (mapcar (lambda (i) (format "/fake/type=%s" i)) + '("b" "c" "d/" "p" "s" "l" "-")))) + (should (equal (eshell-eval-predicate files "%") + '("/fake/type=b" "/fake/type=c"))) + (should (equal (eshell-eval-predicate files "%b") '("/fake/type=b"))) + (should (equal (eshell-eval-predicate files "%c") '("/fake/type=c"))) + (should (equal (eshell-eval-predicate files "/") '("/fake/type=d/"))) + (should (equal (eshell-eval-predicate files ".") '("/fake/type=-"))) + (should (equal (eshell-eval-predicate files "p") '("/fake/type=p"))) + (should (equal (eshell-eval-predicate files "=") '("/fake/type=s"))) + (should (equal (eshell-eval-predicate files "@") '("/fake/type=l")))))) + +(ert-deftest em-pred-test/predicate-executable () + "Test that \"*\" matches only regular, non-symlink executable files." + (eshell-with-file-attributes-from-name + (let ((files '("/fake/modes=0777" "/fake/modes=0666" + "/fake/type=d,modes=0777" "/fake/type=l,modes=0777"))) + (should (equal (eshell-eval-predicate files "*") + '("/fake/modes=0777")))))) + +(defmacro em-pred-test--file-modes-deftest (name mode-template predicates + &optional docstring) + "Define NAME as a file-mode test. +MODE-TEMPLATE is a format string to convert an integer from 0 to +7 to an octal file mode. PREDICATES is a list of strings for the +read, write, and execute predicates to query the file's modes." + (declare (indent 4) (doc-string 4)) + `(ert-deftest ,name () + ,docstring + (eshell-with-file-attributes-from-name + (let ((file-template (concat "/fake/modes=" ,mode-template))) + (cl-flet ((make-files (perms) + (mapcar (lambda (i) (format file-template i)) + perms))) + (pcase-let ((files (make-files (number-sequence 0 7))) + (`(,read ,write ,exec) ,predicates)) + (should (equal (eshell-eval-predicate files read) + (make-files '(4 5 6 7)))) + (should (equal (eshell-eval-predicate files (concat "^" read)) + (make-files '(0 1 2 3)))) + (should (equal (eshell-eval-predicate files write) + (make-files '(2 3 6 7)))) + (should (equal (eshell-eval-predicate files (concat "^" write)) + (make-files '(0 1 4 5)))) + (should (equal (eshell-eval-predicate files exec) + (make-files '(1 3 5 7)))) + (should (equal (eshell-eval-predicate files (concat "^" exec)) + (make-files '(0 2 4 6)))))))))) + +(em-pred-test--file-modes-deftest em-pred-test/predicate-file-modes-owner + "0%o00" '("r" "w" "x") + "Test predicates for file permissions for the owner.") + +(em-pred-test--file-modes-deftest em-pred-test/predicate-file-modes-group + "00%o0" '("A" "I" "E") + "Test predicates for file permissions for the group.") + +(em-pred-test--file-modes-deftest em-pred-test/predicate-file-modes-world + "000%o" '("R" "W" "X") + "Test predicates for file permissions for the world.") + +(em-pred-test--file-modes-deftest em-pred-test/predicate-file-modes-flags + "%o000" '("s" "S" "t") + "Test predicates for \"s\" (setuid), \"S\" (setgid), and \"t\" (sticky).") + +(ert-deftest em-pred-test/predicate-effective-uid () + "Test that \"U\" matches files owned by the effective UID." + (eshell-with-file-attributes-from-name + (cl-letf (((symbol-function 'user-uid) (lambda () 1))) + (let ((files '("/fake/uid=1" "/fake/uid=2"))) + (should (equal (eshell-eval-predicate files "U") + '("/fake/uid=1"))))))) + +(ert-deftest em-pred-test/predicate-effective-gid () + "Test that \"G\" matches files owned by the effective GID." + (eshell-with-file-attributes-from-name + (cl-letf (((symbol-function 'group-gid) (lambda () 1))) + (let ((files '("/fake/gid=1" "/fake/gid=2"))) + (should (equal (eshell-eval-predicate files "G") + '("/fake/gid=1"))))))) + +(ert-deftest em-pred-test/predicate-links () + "Test that \"l\" filters by number of links." + (eshell-with-file-attributes-from-name + (let ((files '("/fake/links=1" "/fake/links=2" "/fake/links=3"))) + (should (equal (eshell-eval-predicate files "l1") + '("/fake/links=1"))) + (should (equal (eshell-eval-predicate files "l+1") + '("/fake/links=2" "/fake/links=3"))) + (should (equal (eshell-eval-predicate files "l-3") + '("/fake/links=1" "/fake/links=2")))))) + +(ert-deftest em-pred-test/predicate-uid () + "Test that \"u\" filters by UID/user name." + (eshell-with-file-attributes-from-name + (let ((files '("/fake/uid=1" "/fake/uid=2")) + (user-names '("root" "one" "two"))) + (should (equal (eshell-eval-predicate files "u1") + '("/fake/uid=1"))) + (cl-letf (((symbol-function 'eshell-user-id) + (lambda (name) (seq-position user-names name)))) + (should (equal (eshell-eval-predicate files "u'one'") + '("/fake/uid=1"))))))) + +(ert-deftest em-pred-test/predicate-gid () + "Test that \"g\" filters by GID/group name." + (eshell-with-file-attributes-from-name + (let ((files '("/fake/gid=1" "/fake/gid=2")) + (group-names '("root" "one" "two"))) + (should (equal (eshell-eval-predicate files "g1") + '("/fake/gid=1"))) + (cl-letf (((symbol-function 'eshell-group-id) + (lambda (name) (seq-position group-names name)))) + (should (equal (eshell-eval-predicate files "g'one'") + '("/fake/gid=1"))))))) + +(defmacro em-pred-test--time-deftest (name file-attribute predicate + &optional docstring) + "Define NAME as a file-time test. +FILE-ATTRIBUTE is the file's attribute to set (e.g. \"atime\"). +PREDICATE is the predicate used to query that attribute." + (declare (indent 4) (doc-string 4)) + `(ert-deftest ,name () + ,docstring + (eshell-with-file-attributes-from-name + (cl-flet ((make-file (time) + (format "/fake/%s=%d" ,file-attribute time))) + (let* ((now (time-convert nil 'integer)) + (yesterday (- now 86400)) + (files (mapcar #'make-file (list now yesterday)))) + ;; Test comparison against a number of days. + (should (equal (eshell-eval-predicate + files (concat ,predicate "-1")) + (mapcar #'make-file (list now)))) + (should (equal (eshell-eval-predicate + files (concat ,predicate "+1")) + (mapcar #'make-file (list yesterday)))) + (should (equal (eshell-eval-predicate + files (concat ,predicate "+2")) + nil)) + ;; Test comparison against a number of hours. + (should (equal (eshell-eval-predicate + files (concat ,predicate "h-1")) + (mapcar #'make-file (list now)))) + (should (equal (eshell-eval-predicate + files (concat ,predicate "h+1")) + (mapcar #'make-file (list yesterday)))) + (should (equal (eshell-eval-predicate + files (concat ,predicate "+48")) + nil)) + ;; Test comparison against another file. + (should (equal (eshell-eval-predicate + files (format "%s-'%s'" ,predicate (make-file now))) + nil)) + (should (equal (eshell-eval-predicate + files (format "%s+'%s'" ,predicate (make-file now))) + (mapcar #'make-file (list yesterday))))))))) + +(em-pred-test--time-deftest em-pred-test/predicate-access-time + "atime" "a" + "Test that \"a\" filters by access time.") + +(em-pred-test--time-deftest em-pred-test/predicate-modification-time + "mtime" "m" + "Test that \"m\" filters by change time.") + +(em-pred-test--time-deftest em-pred-test/predicate-change-time + "ctime" "c" + "Test that \"c\" filters by change time.") + +(ert-deftest em-pred-test/predicate-size () + "Test that \"L\" filters by file size." + (eshell-with-file-attributes-from-name + (let ((files '("/fake/size=0" + ;; 1 and 2 KiB. + "/fake/size=1024" "/fake/size=2048" + ;; 1 and 2 MiB. + "/fake/size=1048576" "/fake/size=2097152"))) + ;; Size in bytes. + (should (equal (eshell-eval-predicate files "L2048") + '("/fake/size=2048"))) + (should (equal (eshell-eval-predicate files "L+2048") + '("/fake/size=1048576" "/fake/size=2097152"))) + (should (equal (eshell-eval-predicate files "L-2048") + '("/fake/size=0" "/fake/size=1024"))) + ;; Size in blocks. + (should (equal (eshell-eval-predicate files "Lp4") + '("/fake/size=2048"))) + (should (equal (eshell-eval-predicate files "Lp+4") + '("/fake/size=1048576" "/fake/size=2097152"))) + (should (equal (eshell-eval-predicate files "Lp-4") + '("/fake/size=0" "/fake/size=1024"))) + ;; Size in KiB. + (should (equal (eshell-eval-predicate files "Lk2") + '("/fake/size=2048"))) + (should (equal (eshell-eval-predicate files "Lk+2") + '("/fake/size=1048576" "/fake/size=2097152"))) + (should (equal (eshell-eval-predicate files "Lk-2") + '("/fake/size=0" "/fake/size=1024"))) + ;; Size in MiB. + (should (equal (eshell-eval-predicate files "LM1") + '("/fake/size=1048576"))) + (should (equal (eshell-eval-predicate files "LM+1") + '("/fake/size=2097152"))) + (should (equal (eshell-eval-predicate files "LM-1") + '("/fake/size=0" "/fake/size=1024" "/fake/size=2048")))))) + + +;; Argument modifiers + +(ert-deftest em-pred-test/modifier-eval () + "Test that \":E\" re-evaluates the value." + (should (equal (eshell-eval-predicate "${echo hi}" ":E") "hi")) + (should (equal (eshell-eval-predicate + '("${echo hi}" "$(upcase \"bye\")") ":E") + '("hi" "BYE")))) + +(ert-deftest em-pred-test/modifier-downcase () + "Test that \":L\" downcases values." + (should (equal (eshell-eval-predicate "FOO" ":L") "foo")) + (should (equal (eshell-eval-predicate '("FOO" "BAR") ":L") + '("foo" "bar")))) + +(ert-deftest em-pred-test/modifier-upcase () + "Test that \":U\" upcases values." + (should (equal (eshell-eval-predicate "foo" ":U") "FOO")) + (should (equal (eshell-eval-predicate '("foo" "bar") ":U") + '("FOO" "BAR")))) + +(ert-deftest em-pred-test/modifier-capitalize () + "Test that \":C\" capitalizes values." + (should (equal (eshell-eval-predicate "foo bar" ":C") "Foo Bar")) + (should (equal (eshell-eval-predicate '("foo bar" "baz") ":C") + '("Foo Bar" "Baz")))) + +(ert-deftest em-pred-test/modifier-dirname () + "Test that \":h\" returns the dirname." + (should (equal (eshell-eval-predicate "/path/to/file.el" ":h") "/path/to/")) + (should (equal (eshell-eval-predicate + '("/path/to/file.el" "/other/path/") ":h") + '("/path/to/" "/other/path/")))) + +(ert-deftest em-pred-test/modifier-basename () + "Test that \":t\" returns the basename." + (should (equal (eshell-eval-predicate "/path/to/file.el" ":t") "file.el")) + (should (equal (eshell-eval-predicate + '("/path/to/file.el" "/other/path/") ":t") + '("file.el" "")))) + +(ert-deftest em-pred-test/modifier-extension () + "Test that \":e\" returns the extension." + (should (equal (eshell-eval-predicate "/path/to/file.el" ":e") "el")) + (should (equal (eshell-eval-predicate + '("/path/to/file.el" "/other/path/") ":e") + '("el" nil)))) + +(ert-deftest em-pred-test/modifier-sans-extension () + "Test that \":r\" returns the file name san extension." + (should (equal (eshell-eval-predicate "/path/to/file.el" ":r") + "/path/to/file")) + (should (equal (eshell-eval-predicate + '("/path/to/file.el" "/other/path/") ":r") + '("/path/to/file" "/other/path/")))) + +(ert-deftest em-pred-test/modifier-quote () + "Test that \":q\" quotes arguments." + (should (equal-including-properties + (eshell-eval-predicate '("foo" "bar") ":q") + (list (eshell-escape-arg "foo") (eshell-escape-arg "bar"))))) + +(ert-deftest em-pred-test/modifier-substitute () + "Test that \":s/PAT/REP/\" replaces PAT with REP once." + (should (equal (eshell-eval-predicate "bar" ":s/a/*/") "b*r")) + (should (equal (eshell-eval-predicate "bar" ":s|a|*|") "b*r")) + (should (equal (eshell-eval-predicate "bar" ":s{a}{*}") "b*r")) + (should (equal (eshell-eval-predicate "bar" ":s{a}'*'") "b*r")) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":s/[ao]/*/") + '("f*o" "b*r" "b*z"))) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":s|[ao]|*|") + '("f*o" "b*r" "b*z")))) + +(ert-deftest em-pred-test/modifier-global-substitute () + "Test that \":s/PAT/REP/\" replaces PAT with REP for all occurrences." + (should (equal (eshell-eval-predicate "foo" ":gs/a/*/") "foo")) + (should (equal (eshell-eval-predicate "foo" ":gs|a|*|") "foo")) + (should (equal (eshell-eval-predicate "bar" ":gs/a/*/") "b*r")) + (should (equal (eshell-eval-predicate "bar" ":gs|a|*|") "b*r")) + (should (equal (eshell-eval-predicate "foo" ":gs/o/O/") "fOO")) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":gs/[aeiou]/*/") + '("f**" "b*r" "b*z"))) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":gs|[aeiou]|*|") + '("f**" "b*r" "b*z")))) + +(ert-deftest em-pred-test/modifier-include () + "Test that \":i/PAT/\" filters elements to include only ones matching PAT." + (should (equal (eshell-eval-predicate "foo" ":i/a/") nil)) + (should (equal (eshell-eval-predicate "bar" ":i/a/") "bar")) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":i/a/") + '("bar" "baz")))) + +(ert-deftest em-pred-test/modifier-exclude () + "Test that \":x/PAT/\" filters elements to exclude any matching PAT." + (should (equal (eshell-eval-predicate "foo" ":x/a/") "foo")) + (should (equal (eshell-eval-predicate "bar" ":x/a/") nil)) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":x/a/") + '("foo")))) + +(ert-deftest em-pred-test/modifier-split () + "Test that \":S\" and \":S/PAT/\" split elements by spaces (or PAT)." + (should (equal (eshell-eval-predicate "foo bar baz" ":S") + '("foo" "bar" "baz"))) + (should (equal (eshell-eval-predicate '("foo bar" "baz") ":S") + '(("foo" "bar") ("baz")))) + (should (equal (eshell-eval-predicate "foo-bar-baz" ":S/-/") + '("foo" "bar" "baz"))) + (should (equal (eshell-eval-predicate '("foo-bar" "baz") ":S/-/") + '(("foo" "bar") ("baz"))))) + +(ert-deftest em-pred-test/modifier-join () + "Test that \":j\" and \":j/DELIM/\" join elements by spaces (or DELIM)." + (should (equal (eshell-eval-predicate "foo" ":j") "foo")) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":j") + "foo bar baz")) + (should (equal (eshell-eval-predicate "foo" ":j/-/") "foo")) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":j/-/") + "foo-bar-baz"))) + +(ert-deftest em-pred-test/modifier-sort () + "Test that \":o\" sorts elements in lexicographic order." + (should (equal (eshell-eval-predicate "foo" ":o") "foo")) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":o") + '("bar" "baz" "foo")))) + +(ert-deftest em-pred-test/modifier-sort-reverse () + "Test that \":o\" sorts elements in reverse lexicographic order." + (should (equal (eshell-eval-predicate "foo" ":O") "foo")) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":O") + '("foo" "baz" "bar")))) + +(ert-deftest em-pred-test/modifier-unique () + "Test that \":u\" filters out duplicate elements." + (should (equal (eshell-eval-predicate "foo" ":u") "foo")) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":u") + '("foo" "bar" "baz"))) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz" "foo") ":u") + '("foo" "bar" "baz")))) + +(ert-deftest em-pred-test/modifier-reverse () + "Test that \":r\" reverses the order of elements." + (should (equal (eshell-eval-predicate "foo" ":R") "foo")) + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":R") + '("baz" "bar" "foo")))) + + +;; Miscellaneous + +(ert-deftest em-pred-test/combine-predicate-and-modifier () + "Test combination of predicates and modifiers." + (eshell-with-file-attributes-from-name + (let ((files '("/fake/type=-.el" "/fake/type=-.txt" "/fake/type=s.el" + "/fake/subdir/type=-.el"))) + (should (equal (eshell-eval-predicate files ".:e:u") + '("el" "txt")))))) + +(ert-deftest em-pred-test/predicate-delimiters () + "Test various delimiter pairs with predicates and modifiers." + (dolist (delims eshell-pred-delimiter-pairs) + (eshell-with-file-attributes-from-name + (let ((files '("/fake/uid=1" "/fake/uid=2")) + (user-names '("root" "one" "two"))) + (cl-letf (((symbol-function 'eshell-user-id) + (lambda (name) (seq-position user-names name)))) + (should (equal (eshell-eval-predicate + files (format "u%cone%c" (car delims) (cdr delims))) + '("/fake/uid=1")))))) + (should (equal (eshell-eval-predicate + '("foo" "bar" "baz") + (format ":j%c-%c" (car delims) (cdr delims))) + "foo-bar-baz")))) + +(ert-deftest em-pred-test/predicate-escaping () + "Test string escaping in predicate and modifier parameters." + ;; Escaping the delimiter should remove the backslash. + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":j'\\''") + "foo'bar'baz")) + ;; Escaping a backlash should remove the first backslash. + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":j'\\\\'") + "foo\\bar\\baz")) + ;; Escaping a different character should keep the backslash. + (should (equal (eshell-eval-predicate '("foo" "bar" "baz") ":j'\\\"'") + "foo\\\"bar\\\"baz"))) + +;; em-pred-tests.el ends here diff --git a/test/lisp/eshell/esh-proc-tests.el b/test/lisp/eshell/esh-proc-tests.el index 7dc9d29cfec..7f461d1813c 100644 --- a/test/lisp/eshell/esh-proc-tests.el +++ b/test/lisp/eshell/esh-proc-tests.el @@ -50,6 +50,9 @@ prompt. See bug#54136." (skip-unless (and (executable-find "sh") (executable-find "echo") (executable-find "sleep"))) + ;; This test doesn't work on EMBA with AOT nativecomp, but works + ;; fine elsewhere. + (skip-unless (not (getenv "EMACS_EMBA_CI"))) (with-temp-eshell (eshell-insert-command (concat "sh -c 'while true; do echo y; sleep 1; done' | " @@ -59,7 +62,7 @@ prompt. See bug#54136." (eshell-wait-for-subprocess t) (should (string-match-p ;; "interrupt\n" is for MS-Windows. - (rx (or "interrupt\n" "killed\n")) + (rx (or "interrupt\n" "killed\n" "killed: 9\n")) (buffer-substring-no-properties output-start (eshell-end-of-output))))))) diff --git a/test/lisp/eshell/esh-var-tests.el b/test/lisp/eshell/esh-var-tests.el index 1d051d681af..4e2a18861e5 100644 --- a/test/lisp/eshell/esh-var-tests.el +++ b/test/lisp/eshell/esh-var-tests.el @@ -176,8 +176,17 @@ (should (equal (eshell-test-command-result "+ $(+ 1 2)$(+ 1 2) 3") 36))) (ert-deftest esh-var-test/interp-concat-cmd () - "Interpolate and concat command" - (should (equal (eshell-test-command-result "+ ${+ 1 2}3 3") 36))) + "Interpolate and concat command with literal" + (should (equal (eshell-test-command-result "+ ${+ 1 2}3 3") 36)) + (should (equal (eshell-test-command-result "echo ${*echo \"foo\nbar\"}-baz") + '("foo" "bar-baz"))) + ;; Concatenating to a number in a list should produce a number... + (should (equal (eshell-test-command-result "echo ${*echo \"1\n2\"}3") + '(1 23))) + ;; ... but concatenating to a string that looks like a number in a list + ;; should produce a string. + (should (equal (eshell-test-command-result "echo ${*echo \"hi\n2\"}3") + '("hi" "23")))) (ert-deftest esh-var-test/interp-concat-cmd2 () "Interpolate and concat two commands" @@ -210,12 +219,17 @@ (should (equal (eshell-test-command-result "echo \"$eshell-test-value[0]\"") "zero")) + ;; FIXME: These tests would use the 0th index like the other tests + ;; here, but evaluating the command just above adds an `escaped' + ;; property to the string "zero". This results in the output + ;; printing the string properties, which is probably the wrong + ;; behavior. See bug#54486. (should (equal (eshell-test-command-result - "echo \"$eshell-test-value[0 2]\"") - '("zero" "two"))) + "echo \"$eshell-test-value[1 2]\"") + "(\"one\" \"two\")")) (should (equal (eshell-test-command-result - "echo \"$eshell-test-value[0 2 4]\"") - '("zero" "two" "four"))))) + "echo \"$eshell-test-value[1 2 4]\"") + "(\"one\" \"two\" \"four\")")))) (ert-deftest esh-var-test/quoted-interp-var-split-indices () "Interpolate string variable with indices inside double-quotes" @@ -225,7 +239,7 @@ "zero")) (should (equal (eshell-test-command-result "echo \"$eshell-test-value[0 2]\"") - '("zero" "two"))))) + "(\"zero\" \"two\")")))) (ert-deftest esh-var-test/quoted-interp-var-string-split-indices () "Interpolate string variable with string splitter and indices @@ -236,14 +250,14 @@ inside double-quotes" "zero")) (should (equal (eshell-test-command-result "echo \"$eshell-test-value[: 0 2]\"") - '("zero" "two")))) + "(\"zero\" \"two\")"))) (let ((eshell-test-value "zeroXoneXtwoXthreeXfour")) (should (equal (eshell-test-command-result "echo \"$eshell-test-value[X 0]\"") "zero")) (should (equal (eshell-test-command-result "echo \"$eshell-test-value[X 0 2]\"") - '("zero" "two"))))) + "(\"zero\" \"two\")")))) (ert-deftest esh-var-test/quoted-interp-var-regexp-split-indices () "Interpolate string variable with regexp splitter and indices" @@ -253,43 +267,47 @@ inside double-quotes" "zero")) (should (equal (eshell-test-command-result "echo \"$eshell-test-value['[:!]' 0 2]\"") - '("zero" "two"))) + "(\"zero\" \"two\")")) (should (equal (eshell-test-command-result "echo \"$eshell-test-value[\\\"[:!]\\\" 0]\"") "zero")) (should (equal (eshell-test-command-result "echo \"$eshell-test-value[\\\"[:!]\\\" 0 2]\"") - '("zero" "two"))))) + "(\"zero\" \"two\")")))) (ert-deftest esh-var-test/quoted-interp-var-assoc () "Interpolate alist variable with index inside double-quotes" (let ((eshell-test-value '(("foo" . 1)))) (should (equal (eshell-test-command-result "echo \"$eshell-test-value[foo]\"") - 1)))) + "1")))) (ert-deftest esh-var-test/quoted-interp-var-length-list () "Interpolate length of list variable inside double-quotes" (let ((eshell-test-value '((1 2) (3) (5 (6 7 8 9))))) - (should (eq (eshell-test-command-result "echo \"$#eshell-test-value\"") 3)) - (should (eq (eshell-test-command-result "echo \"$#eshell-test-value[1]\"") - 1)) - (should (eq (eshell-test-command-result - "echo \"$#eshell-test-value[2][1]\"") - 4)))) + (should (equal (eshell-test-command-result "echo \"$#eshell-test-value\"") + "3")) + (should (equal (eshell-test-command-result + "echo \"$#eshell-test-value[1]\"") + "1")) + (should (equal (eshell-test-command-result + "echo \"$#eshell-test-value[2][1]\"") + "4")))) (ert-deftest esh-var-test/quoted-interp-var-length-string () "Interpolate length of string variable inside double-quotes" (let ((eshell-test-value "foobar")) - (should (eq (eshell-test-command-result "echo \"$#eshell-test-value\"") - 6)))) + (should (equal (eshell-test-command-result "echo \"$#eshell-test-value\"") + "6")))) (ert-deftest esh-var-test/quoted-interp-var-length-alist () "Interpolate length of alist variable inside double-quotes" (let ((eshell-test-value '(("foo" . (1 2 3))))) - (should (eq (eshell-test-command-result "echo \"$#eshell-test-value\"") 1)) - (should (eq (eshell-test-command-result "echo \"$#eshell-test-value[foo]\"") - 3)))) + (should (equal (eshell-test-command-result "echo \"$#eshell-test-value\"") + "1")) + (should (equal (eshell-test-command-result + "echo \"$#eshell-test-value[foo]\"") + "3")))) (ert-deftest esh-var-test/quoted-interp-lisp () "Interpolate Lisp form evaluation inside double-quotes" @@ -299,7 +317,8 @@ inside double-quotes" (ert-deftest esh-var-test/quoted-interp-lisp-indices () "Interpolate Lisp form evaluation with index" - (should (equal (eshell-test-command-result "+ \"$(list 1 2)[1]\" 3") 5))) + (should (equal (eshell-test-command-result "concat \"$(list 1 2)[1]\" cool") + "2cool"))) (ert-deftest esh-var-test/quoted-interp-cmd () "Interpolate command result inside double-quotes" @@ -309,11 +328,143 @@ inside double-quotes" (ert-deftest esh-var-test/quoted-interp-cmd-indices () "Interpolate command result with index inside double-quotes" - (should (equal (eshell-test-command-result "+ \"${list 1 2}[1]\" 3") 5))) + (should (equal (eshell-test-command-result "concat \"${list 1 2}[1]\" cool") + "2cool"))) (ert-deftest esh-var-test/quoted-interp-temp-cmd () "Interpolate command result redirected to temp file inside double-quotes" - (should (equal (eshell-test-command-result "cat \"$\"") "hi"))) + (let ((temporary-file-directory + (file-name-as-directory (make-temp-file "esh-vars-tests" t)))) + (unwind-protect + (should (equal (eshell-test-command-result "cat \"$\"") + "hi")) + (delete-directory temporary-file-directory t)))) + +(ert-deftest esh-var-test/quoted-interp-concat-cmd () + "Interpolate and concat command with literal" + (should (equal (eshell-test-command-result + "echo \"${echo \\\"foo\nbar\\\"} baz\"") + "foo\nbar baz"))) + + +;; Interpolated variable conversion + +(ert-deftest esh-var-test/interp-convert-var-number () + "Interpolate numeric variable" + (let ((eshell-test-value 123)) + (should (equal (eshell-test-command-result "type-of $eshell-test-value") + 'integer)))) + +(ert-deftest esh-var-test/interp-convert-var-split-indices () + "Interpolate and convert string variable with indices" + (let ((eshell-test-value "000 010 020 030 040")) + (should (equal (eshell-test-command-result "echo $eshell-test-value[0]") + 0)) + (should (equal (eshell-test-command-result "echo $eshell-test-value[0 2]") + '(0 20))))) + +(ert-deftest esh-var-test/interp-convert-quoted-var-number () + "Interpolate numeric quoted numeric variable" + (let ((eshell-test-value 123)) + (should (equal (eshell-test-command-result "type-of $'eshell-test-value'") + 'integer)) + (should (equal (eshell-test-command-result "type-of $\"eshell-test-value\"") + 'integer)))) + +(ert-deftest esh-var-test/interp-convert-quoted-var-split-indices () + "Interpolate and convert quoted string variable with indices" + (let ((eshell-test-value "000 010 020 030 040")) + (should (equal (eshell-test-command-result "echo $'eshell-test-value'[0]") + 0)) + (should (equal (eshell-test-command-result "echo $'eshell-test-value'[0 2]") + '(0 20))))) + +(ert-deftest esh-var-test/interp-convert-cmd-string-newline () + "Interpolate trailing-newline command result" + (should (equal (eshell-test-command-result "echo ${echo \"foo\n\"}") "foo"))) + +(ert-deftest esh-var-test/interp-convert-cmd-multiline () + "Interpolate multi-line command result" + (should (equal (eshell-test-command-result "echo ${echo \"foo\nbar\"}") + '("foo" "bar"))) + ;; Numeric output should be converted to numbers... + (should (equal (eshell-test-command-result "echo ${echo \"01\n02\n03\"}") + '(1 2 3))) + ;; ... but only if every line is numeric. + (should (equal (eshell-test-command-result "echo ${echo \"01\n02\nhi\"}") + '("01" "02" "hi")))) + +(ert-deftest esh-var-test/interp-convert-cmd-number () + "Interpolate numeric command result" + (should (equal (eshell-test-command-result "echo ${echo \"1\"}") 1))) + +(ert-deftest esh-var-test/interp-convert-cmd-split-indices () + "Interpolate command result with indices" + (should (equal (eshell-test-command-result "echo ${echo \"000 010 020\"}[0]") + 0)) + (should (equal (eshell-test-command-result + "echo ${echo \"000 010 020\"}[0 2]") + '(0 20)))) + +(ert-deftest esh-var-test/quoted-interp-convert-var-number () + "Interpolate numeric variable inside double-quotes" + (let ((eshell-test-value 123)) + (should (equal (eshell-test-command-result "type-of \"$eshell-test-value\"") + 'string)))) + +(ert-deftest esh-var-test/quoted-interp-convert-var-split-indices () + "Interpolate string variable with indices inside double-quotes" + (let ((eshell-test-value "000 010 020 030 040")) + (should (equal (eshell-test-command-result + "echo \"$eshell-test-value[0]\"") + "000")) + (should (equal (eshell-test-command-result + "echo \"$eshell-test-value[0 2]\"") + "(\"000\" \"020\")")))) + +(ert-deftest esh-var-test/quoted-interp-convert-quoted-var-number () + "Interpolate numeric quoted variable inside double-quotes" + (let ((eshell-test-value 123)) + (should (equal (eshell-test-command-result + "type-of \"$'eshell-test-value'\"") + 'string)) + (should (equal (eshell-test-command-result + "type-of \"$\\\"eshell-test-value\\\"\"") + 'string)))) + +(ert-deftest esh-var-test/quoted-interp-convert-quoted-var-split-indices () + "Interpolate quoted string variable with indices inside double-quotes" + (let ((eshell-test-value "000 010 020 030 040")) + (should (equal (eshell-test-command-result + "echo \"$eshell-test-value[0]\"") + "000")) + (should (equal (eshell-test-command-result + "echo \"$eshell-test-value[0 2]\"") + "(\"000\" \"020\")")))) + +(ert-deftest esh-var-test/quoted-interp-convert-cmd-string-newline () + "Interpolate trailing-newline command result inside double-quotes" + (should (equal (eshell-test-command-result "echo \"${echo \\\"foo\n\\\"}\"") + "foo")) + (should (equal (eshell-test-command-result "echo \"${echo \\\"foo\n\n\\\"}\"") + "foo"))) + +(ert-deftest esh-var-test/quoted-interp-convert-cmd-multiline () + "Interpolate multi-line command result inside double-quotes" + (should (equal (eshell-test-command-result + "echo \"${echo \\\"foo\nbar\\\"}\"") + "foo\nbar"))) + +(ert-deftest esh-var-test/quoted-interp-convert-cmd-number () + "Interpolate numeric command result inside double-quotes" + (should (equal (eshell-test-command-result "echo \"${echo \\\"1\\\"}\"") + "1"))) + +(ert-deftest esh-var-test/quoted-interp-convert-cmd-split-indices () + "Interpolate command result with indices inside double-quotes" + (should (equal (eshell-test-command-result + "echo \"${echo \\\"000 010 020\\\"}[0]\"") + "000"))) ;; Built-in variables diff --git a/test/lisp/eshell/eshell-tests-helpers.el b/test/lisp/eshell/eshell-tests-helpers.el index f944194a2b1..4ad76ca6978 100644 --- a/test/lisp/eshell/eshell-tests-helpers.el +++ b/test/lisp/eshell/eshell-tests-helpers.el @@ -38,17 +38,18 @@ See `eshell-wait-for-subprocess'.") (defmacro with-temp-eshell (&rest body) "Evaluate BODY in a temporary Eshell buffer." - `(ert-with-temp-directory eshell-directory-name - (let* (;; We want no history file, so prevent Eshell from falling - ;; back on $HISTFILE. - (process-environment (cons "HISTFILE" process-environment)) - (eshell-history-file-name nil) - (eshell-buffer (eshell t))) - (unwind-protect - (with-current-buffer eshell-buffer - ,@body) - (let (kill-buffer-query-functions) - (kill-buffer eshell-buffer)))))) + `(save-current-buffer + (ert-with-temp-directory eshell-directory-name + (let* (;; We want no history file, so prevent Eshell from falling + ;; back on $HISTFILE. + (process-environment (cons "HISTFILE" process-environment)) + (eshell-history-file-name nil) + (eshell-buffer (eshell t))) + (unwind-protect + (with-current-buffer eshell-buffer + ,@body) + (let (kill-buffer-query-functions) + (kill-buffer eshell-buffer))))))) (defun eshell-wait-for-subprocess (&optional all) "Wait until there is no interactive subprocess running in Eshell. diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el index e31db07c619..7cdeb017e44 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -44,6 +44,10 @@ "Test `eshell-command-result' with an elisp command." (should (equal (eshell-test-command-result "(+ 1 2)") 3))) +(ert-deftest eshell-test/lisp-command-with-quote () + "Test `eshell-command-result' with an elisp command containing a quote." + (should (equal (eshell-test-command-result "(eq 'foo nil)") nil))) + (ert-deftest eshell-test/for-loop () "Test `eshell-command-result' with a for loop.." (let ((process-environment (cons "foo" process-environment))) @@ -110,6 +114,25 @@ e.g. \"{(+ 1 2)} 3\" => 3" (eshell-wait-for-subprocess) (eshell-match-result "OLLEH\n"))) +(ert-deftest eshell-test/redirect-buffer () + "Check that piping to a buffer works" + (with-temp-buffer + (rename-buffer "eshell-temp-buffer" t) + (let ((bufname (buffer-name))) + (with-temp-eshell + (eshell-insert-command (format "echo hi > #<%s>" bufname))) + (should (equal (buffer-string) "hi"))))) + +(ert-deftest eshell-test/redirect-buffer-escaped () + "Check that piping to a buffer with escaped characters works" + (with-temp-buffer + (rename-buffer "eshell\\temp\\buffer" t) + (let ((bufname (buffer-name))) + (with-temp-eshell + (eshell-insert-command (format "echo hi > #<%s>" + (string-replace "\\" "\\\\" bufname)))) + (should (equal (buffer-string) "hi"))))) + (ert-deftest eshell-test/inside-emacs-var () "Test presence of \"INSIDE_EMACS\" in subprocesses" (with-temp-eshell @@ -144,9 +167,9 @@ chars" "Test that the backslash is not preserved for escaped special chars" (with-temp-eshell - (eshell-command-result-p "echo \"h\\\\i\"" + (eshell-command-result-p "echo \"\\\"hi\\\\\"" ;; Backslashes are doubled for regexp. - "h\\\\i\n"))) + "\\\"hi\\\\\n"))) (ert-deftest eshell-test/command-running-p () "Modeline should show no command running" diff --git a/test/lisp/files-resources/compile-utf8.el b/test/lisp/files-resources/compile-utf8.el new file mode 100644 index 00000000000..ea67626365d --- /dev/null +++ b/test/lisp/files-resources/compile-utf8.el @@ -0,0 +1,11 @@ +(defun zot () + "Yes." + nil) + +(defun foo () + "Yés." + nil) + +(defun bar () + "Nó." + nil) diff --git a/test/lisp/files-resources/file-mode b/test/lisp/files-resources/file-mode new file mode 100644 index 00000000000..92ac4c30ef5 --- /dev/null +++ b/test/lisp/files-resources/file-mode @@ -0,0 +1,3 @@ +Local variables: +mode: text +end: diff --git a/test/lisp/files-resources/file-mode-multiple b/test/lisp/files-resources/file-mode-multiple new file mode 100644 index 00000000000..ac051ccbcbd --- /dev/null +++ b/test/lisp/files-resources/file-mode-multiple @@ -0,0 +1,5 @@ +Local variables: +mode: text +mode: test-mode-undef +mode: outline +end: diff --git a/test/lisp/files-resources/file-mode-prop-line b/test/lisp/files-resources/file-mode-prop-line new file mode 100644 index 00000000000..e0e7ad24d71 --- /dev/null +++ b/test/lisp/files-resources/file-mode-prop-line @@ -0,0 +1 @@ +-*- mode: notexist; mode: text -*- diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 42b09201de8..7d17fbde672 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -263,7 +263,7 @@ form.") nil)) (kill-emacs-args nil) ((symbol-function #'kill-emacs) - (lambda (&optional arg) (push arg kill-emacs-args))) + (lambda (&rest args) (push args kill-emacs-args))) (process (make-process :name "sleep" @@ -274,7 +274,7 @@ form.") (save-buffers-kill-emacs) (kill-process process) (should-not yes-or-no-p-prompts) - (should (equal kill-emacs-args '(nil))))) + (should (equal kill-emacs-args '((nil nil)))))) (ert-deftest files-tests-read-file-in-~ () "Test file prompting in directory named `~'. @@ -1814,5 +1814,51 @@ Prompt users for any modified buffer with `buffer-offer-save' non-nil." (should (equal (file-name-split "/foo/bar/") '("" "foo" "bar" ""))) (should (equal (file-name-split "foo/bar/") '("foo" "bar" "")))) +(ert-deftest files-test-set-mode () + (find-file (ert-resource-file "file-mode")) + (should (eq major-mode 'text-mode)) + (emacs-lisp-mode) + ;; Check that the mode cookie doesn't override the explicit setting. + (should (eq major-mode 'emacs-lisp-mode))) + +(ert-deftest files-test-set-mode-multiple () + (find-file (ert-resource-file "file-mode-multiple")) + (should (eq major-mode 'outline-mode))) + +(ert-deftest files-test-set-mode-prop-line () + (find-file (ert-resource-file "file-mode-prop-line")) + (should (eq major-mode 'text-mode))) + +(ert-deftest files-load-elc-gz-file () + :expected-result :failed + (skip-unless (executable-find "gzip")) + (ert-with-temp-directory dir + (let* ((pref (expand-file-name "compile-utf8" dir)) + (el (concat pref ".el"))) + (copy-file (ert-resource-file "compile-utf8.el") el) + (push dir load-path) + (should (load pref t)) + (should (fboundp 'foo)) + (should (documentation 'foo)) + (should (documentation 'bar)) + (should (documentation 'zot)) + + (byte-compile-file el) + (fmakunbound 'foo) + (should (load (concat pref ".elc") t)) + (should (fboundp 'foo)) + (should (documentation 'foo)) + (should (documentation 'bar)) + (should (documentation 'zot)) + + (dired-compress-file (concat pref ".elc")) + (fmakunbound 'foo) + (should (load (concat pref ".elc.gz") t)) + (should (fboundp 'foo)) + ;; This fails due to bug#12598. + (should (documentation 'foo)) + (should (documentation 'bar)) + (should (documentation 'zot))))) + (provide 'files-tests) ;;; files-tests.el ends here diff --git a/test/lisp/files-x-tests.el b/test/lisp/files-x-tests.el index 60787e1cd3d..7ee2f0c1a65 100644 --- a/test/lisp/files-x-tests.el +++ b/test/lisp/files-x-tests.el @@ -325,6 +325,9 @@ (should-not (boundp 'remote-shell-file-name)) (should (string-equal (symbol-value 'remote-null-device) "null")) + (connection-local-set-profiles + files-x-test--application 'remote-bash) + (with-connection-local-variables ;; All connection-local variables are set. They apply in ;; reverse order in `connection-local-variables-alist'. @@ -344,6 +347,21 @@ (should (local-variable-p 'remote-shell-file-name)) (should (local-variable-p 'remote-null-device)) ;; The proper variable values are set. + (should + (string-equal (symbol-value 'remote-shell-file-name) "/bin/ksh")) + (should + (string-equal (symbol-value 'remote-null-device) "/dev/null")) + + ;; Run another instance of `with-connection-local-variables' + ;; with a different application. + (let ((connection-local-default-application (cadr files-x-test--application))) + (with-connection-local-variables + ;; The proper variable values are set. + (should + (string-equal (symbol-value 'remote-shell-file-name) "/bin/bash")) + (should + (string-equal (symbol-value 'remote-null-device) "/dev/null")))) + ;; The variable values are reset. (should (string-equal (symbol-value 'remote-shell-file-name) "/bin/ksh")) (should diff --git a/test/lisp/hl-line-tests.el b/test/lisp/hl-line-tests.el new file mode 100644 index 00000000000..888351addac --- /dev/null +++ b/test/lisp/hl-line-tests.el @@ -0,0 +1,114 @@ +;;; hl-line-tests.el --- Test suite for hl-line. -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; 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 . + +;;; Code: +(require 'ert) +(require 'hl-line) + +(defsubst hl-line-tests-verify (_label on-p) + (if on-p + (cl-some (apply-partially #'eq hl-line-overlay) + (overlays-at (point))) + (not (cl-some (apply-partially #'eq hl-line-overlay) + (overlays-at (point)))))) + +(ert-deftest hl-line-tests-sticky-across-frames () + (skip-unless (display-graphic-p)) + (customize-set-variable 'global-hl-line-sticky-flag t) + (call-interactively #'global-hl-line-mode) + (let ((first-frame (selected-frame)) + (first-buffer "foo") + (second-buffer "bar") + second-frame) + (unwind-protect + (progn + (switch-to-buffer first-buffer) + (save-excursion + (insert (buffer-name))) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 111 t)) + (select-frame (setq second-frame (make-frame))) + (switch-to-buffer second-buffer) + (save-excursion + (insert (buffer-name))) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 762 t)) + (with-current-buffer first-buffer + (should (hl-line-tests-verify 534 t))) + (call-interactively #'global-hl-line-mode) + (should (hl-line-tests-verify 125 nil)) + (with-current-buffer first-buffer + (should (hl-line-tests-verify 892 nil))) + + ;; now do unsticky + (customize-set-variable 'hl-line-sticky-flag nil) + (call-interactively #'global-hl-line-mode) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 467 t)) + (with-current-buffer first-buffer + (should (hl-line-tests-verify 765 nil))) + (select-frame first-frame) + (should (equal (buffer-name) first-buffer)) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 423 t)) + (with-current-buffer second-buffer + (should (hl-line-tests-verify 897 nil)))) + (let (kill-buffer-query-functions) + (ignore-errors (kill-buffer first-buffer)) + (ignore-errors (kill-buffer second-buffer)) + (ignore-errors (delete-frame second-frame)))))) + +(ert-deftest hl-line-tests-sticky () + (customize-set-variable 'hl-line-sticky-flag t) + (let ((first-buffer "foo") + (second-buffer "bar")) + (unwind-protect + (progn + (switch-to-buffer first-buffer) + (hl-line-mode 1) + (save-excursion + (insert (buffer-name))) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 123 t)) + (switch-to-buffer second-buffer) + (hl-line-mode 1) + (save-excursion + (insert (buffer-name))) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 56 t)) + (with-current-buffer first-buffer + (should (hl-line-tests-verify 67 t))) + + ;; now do unsticky + (customize-set-variable 'hl-line-sticky-flag nil) + (should (hl-line-tests-verify 234 t)) + (with-current-buffer first-buffer + (should (hl-line-tests-verify 231 nil))) + (switch-to-buffer first-buffer) + (run-hooks 'post-command-hook) + (should (hl-line-tests-verify 257 t)) + (with-current-buffer second-buffer + (should (hl-line-tests-verify 999 nil))))) + (let (kill-buffer-query-functions) + (ignore-errors (kill-buffer first-buffer)) + (ignore-errors (kill-buffer second-buffer))))) + +(provide 'hl-line-tests) + +;;; hl-line-tests.el ends here diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el index 6abfcfedcf4..bc8c3636c3c 100644 --- a/test/lisp/image-tests.el +++ b/test/lisp/image-tests.el @@ -74,10 +74,24 @@ (should (listp (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center))))) (should-not (find-image '((:type png :file "does-not-exist-foo-bar.png"))))) +(ert-deftest image-supported-file-p/built-in () + ;; (skip-unless (image-type-available-p 'pbm)) ; Always built-in + (skip-unless (display-images-p)) ; (except in nox builds). + (should (eq (image-supported-file-p "foo.pbm") 'pbm))) + +(ert-deftest image-supported-file-p/optional () + (if (image-type-available-p 'jpeg) + (should (eq (image-supported-file-p "foo.jpg") 'jpeg)) + (should-not (image-supported-file-p "foo.jpg")))) + +(ert-deftest image-supported-file-p/unsupported-returns-nil () + (should-not (image-supported-file-p "foo.some-unsupported-format"))) + (ert-deftest image-type-from-file-name () - (should (eq (image-type-from-file-name "foo.jpg") 'jpeg)) - (should (eq (image-type-from-file-name "foo.png") 'png)) - (should (eq (image-type-from-file-name "foo.webp") 'webp))) + (with-suppressed-warnings ((obsolete image-type-from-file-name)) + (should (eq (image-type-from-file-name "foo.jpg") 'jpeg)) + (should (eq (image-type-from-file-name "foo.png") 'png)) + (should (eq (image-type-from-file-name "foo.webp") 'webp)))) (ert-deftest image-type/from-filename () ;; On emba, `image-types' and `image-load-path' do not exist. diff --git a/test/lisp/international/textsec-tests.el b/test/lisp/international/textsec-tests.el index 5bf9a3dcfb3..6b0773dc407 100644 --- a/test/lisp/international/textsec-tests.el +++ b/test/lisp/international/textsec-tests.el @@ -117,7 +117,19 @@ (should (textsec-domain-suspicious-p "f\N{LEFT-TO-RIGHT ISOLATE}oo.org")) (should (textsec-domain-suspicious-p "Сгсе.ru")) - (should-not (textsec-domain-suspicious-p "фСгсе.ru"))) + (should-not (textsec-domain-suspicious-p "фСгсе.ru")) + + (should-not (textsec-domain-suspicious-p + "21a:34aa:c782:3ad2:1bf8:73f8:141:66e8")) + (should (textsec-domain-suspicious-p + "21a:34aa:c782:3ad2:1bf8:73f8:141:66e8:66e8")) + (should-not (textsec-domain-suspicious-p + "[21a:34aa:c782:3ad2:1bf8:73f8:141:66e8]")) + (should (textsec-domain-suspicious-p + "[21a:34aa:c782:3ad2:1bf8:73f8:141:66e8")) + (should-not (textsec-domain-suspicious-p "138.25.106.12")) + (should-not (textsec-domain-suspicious-p "2001:db8::ff00:42:8329")) + (should-not (textsec-domain-suspicious-p "::ffff:129.55.2.201"))) (ert-deftest test-suspicious-local () (should-not (textsec-local-address-suspicious-p "larsi")) diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el index c62a2a501ba..75d700070aa 100644 --- a/test/lisp/kmacro-tests.el +++ b/test/lisp/kmacro-tests.el @@ -580,8 +580,10 @@ This is a regression test for: Bug#3412, Bug#11817." ;; Check the bound key and run it and verify correct counter ;; and format. (should (equal (string-to-vector "\C-cxi") - (car (kmacro-extract-lambda - (key-binding "\C-x\C-kA"))))) + (car (with-suppressed-warnings + ((obsolete kmacro-extract-lambda)) + (kmacro-extract-lambda + (key-binding "\C-x\C-kA")))))) (kmacro-tests-should-insert "<5>" (funcall (key-binding "\C-x\C-kA"))))) @@ -605,7 +607,7 @@ This is a regression test for: Bug#3412, Bug#11817." (dotimes (i 2) (kmacro-tests-define-macro (make-vector (1+ i) (+ ?a i))) (kmacro-name-last-macro 'kmacro-tests-symbol-for-test) - (should (fboundp 'kmacro-tests-symbol-for-test))) + (should (commandp 'kmacro-tests-symbol-for-test))) ;; Now run the function bound to the symbol. Result should be the ;; second macro. @@ -822,6 +824,15 @@ This is a regression for item 7 in Bug#24991." :macro-result "x") (kmacro-tests-simulate-command '(beginning-of-line)))) +(ert-deftest kmacro-tests--cl-print () + (should (equal (cl-prin1-to-string + (kmacro [?a ?b backspace backspace])) + "#f(kmacro \"a b \")")) + (should (equal (cl-prin1-to-string + (with-suppressed-warnings ((obsolete kmacro-lambda-form)) + (kmacro-lambda-form [?a ?b backspace backspace] 1 "%d"))) + "#f(kmacro \"a b \" 1 \"%d\")"))) + (cl-defun kmacro-tests-run-step-edit (macro &key events sequences result macro-result) "Set up and run a test of `kmacro-step-edit-macro'. diff --git a/test/lisp/mail/ietf-drums-date-tests.el b/test/lisp/mail/ietf-drums-date-tests.el index 5b798077ff9..781d72d3529 100644 --- a/test/lisp/mail/ietf-drums-date-tests.el +++ b/test/lisp/mail/ietf-drums-date-tests.el @@ -52,52 +52,34 @@ ;; Start with some compatible RFC822 dates. (dolist (case '(("Mon, 22 Feb 2016 19:35:42 +0100" - (42 35 19 22 2 2016 1 -1 3600) - (22219 21758)) + (42 35 19 22 2 2016 1 -1 3600)) ("22 Feb 2016 19:35:42 +0100" - (42 35 19 22 2 2016 nil -1 3600) - (22219 21758)) + (42 35 19 22 2 2016 nil -1 3600)) ("Mon, 22 February 2016 19:35:42 +0100" - (42 35 19 22 2 2016 1 -1 3600) - (22219 21758)) + (42 35 19 22 2 2016 1 -1 3600)) ("Mon, 22 feb 2016 19:35:42 +0100" - (42 35 19 22 2 2016 1 -1 3600) - (22219 21758)) + (42 35 19 22 2 2016 1 -1 3600)) ("Monday, 22 february 2016 19:35:42 +0100" - (42 35 19 22 2 2016 1 -1 3600) - (22219 21758)) + (42 35 19 22 2 2016 1 -1 3600)) ("Monday, 22 february 2016 19:35:42 PST" - (42 35 19 22 2 2016 1 nil -28800) - (22219 54158)) + (42 35 19 22 2 2016 1 nil -28800)) ("Friday, 21 Sep 2018 13:47:58 PDT" - (58 47 13 21 9 2018 5 t -25200) - (23461 22782)) + (58 47 13 21 9 2018 5 t -25200)) ("Friday, 21 Sep 2018 13:47:58 EDT" - (58 47 13 21 9 2018 5 t -14400) - (23461 11982)))) + (58 47 13 21 9 2018 5 t -14400)) + ("Mon, 22 Feb 2016 19:35:42" + (42 35 19 22 2 2016 1 -1 nil)) + ("Friday, 21 Sep 2018 13:47:58" + (58 47 13 21 9 2018 5 -1 nil)))) (let* ((input (car case)) - (parsed (cadr case)) - (encoded (caddr case))) + (parsed (cadr case))) ;; The input should parse the same without RFC822. (should (equal (ietf-drums-parse-date-string input) parsed)) (should (equal (ietf-drums-parse-date-string input nil t) parsed)) ;; Check the encoded date (the official output, though the ;; decoded-time is easier to debug). - (should (equal (ietf-drums-parse-date input) encoded)))) - - ;; Test a few without timezones. - (dolist (case '(("Mon, 22 Feb 2016 19:35:42" - (42 35 19 22 2 2016 1 -1 nil)) - ("Friday, 21 Sep 2018 13:47:58" - (58 47 13 21 9 2018 5 -1 nil)))) - (let* ((input (car case)) - (parsed (cadr case))) - ;; The input should parse the same without RFC822. - (should (equal (ietf-drums-parse-date-string input) parsed)) - (should (equal (ietf-drums-parse-date-string input nil t) parsed)) - ;; We can't check the encoded date here because it will differ - ;; depending on the TZ of the test environment. - )) + (should (time-equal-p (ietf-drums-parse-date input) + (encode-time parsed))))) ;; Two-digit years are not allowed by the "modern" format. (should (equal (ietf-drums-parse-date-string "22 Feb 16 19:35:42 +0100") diff --git a/test/lisp/mail/undigest-tests.el b/test/lisp/mail/undigest-tests.el new file mode 100644 index 00000000000..b88868be7fb --- /dev/null +++ b/test/lisp/mail/undigest-tests.el @@ -0,0 +1,364 @@ +;;; undigest-tests.el --- Tests for undigest.el -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; 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 . + +;;; Code: + +(require 'ert) +(require 'rmail) +(require 'undigest) + +;;; Variables: +;; Some digests for testing. +(defvar rmail-rfc934-digest "From tester Fri Jan 24 00:00:00 2022 +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Testing you + +Testing the undigester. + +------- Message sep + +From: NN1 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message one + +This is message one. + +------- Message sep + +From: NN2 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message two + +This is message two. +" + + "RFC 934 digest.") + +(defvar rmail-rfc1153-digest-strict "From tester Fri Jan 24 00:00:00 2022 +Date: ddd, dd mmm yy hh:mm:ss zzz +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Testing you + +Some mailing list information. + +Today's Topics: + + 1. Message One Subject (Sender) + 2. Message Two Subject (Sender) + +---------------------------------------------------------------------- + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN1 +Subject: Message One Subject + +This is message one. + +------------------------------ + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN2 +Subject: Message Two Subject + +This is message two. + +------------------------------ + +End of Digest. +************************************ +" + "RFC 1153 strict style digest.") + +(defvar rmail-rfc1153-digest-less-strict "From tester Fri Jan 24 00:00:00 2022 +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Testing you + +Some mailing list information. + +Today's Topics: + + 1. Message One Subject (Sender) + 2. Message Two Subject (Sender) + +---------------------------------------------------------------------- + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN1 +Subject: Message One Subject + +This is message one. + +------------------------------ + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN2 +Subject: Message Two Subject + +This is message two. + +------------------------------ + +Subject: Digest Footer + +End of Sbcl-help Digest, Vol 158, Issue 4 +***************************************** +" + "RFC 1153 style digest, with a Subject header.") + +(defvar rmail-rfc1153-digest-sloppy "From tester Fri Jan 24 00:00:00 2022 +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Testing you + +Some mailing list information. + +Today's Topics: + + 1. Message One Subject (Sender) + 2. Message Two Subject (Sender) + +---------------------------------------------------------------------- + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN1 +Subject: Message One Subject + +This is message one. + +------------------------------ + +Date: ddd, dd mmm yy hh:mm:ss zzz +From: NN2 +Subject: Message Two Subject + +This is message two. + +------------------------------ + +Subject: Digest Footer + +______________________________________________ +Some blurb. + +End of Digest. +************************************ +" + "RFC 1153 sloppy style digest.") + +(defvar rmail-rfc1521-mime-digest "From tester Fri Jan 24 00:00:00 2022 +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Test digest +MIME-Version: 1.0 +Content-Type: multipart/digest; boundary=\"----- =_aaaaaaaaaa0\" + +------- =_aaaaaaaaaa0 +Content-Type: message/rfc822 + +From: NN1 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message one + +Message one. + +------- =_aaaaaaaaaa0 + +From: NN2 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message two + +Message two. + +------- =_aaaaaaaaaa0 +" + "RFC 1521 style MIME digest.") + +(defvar rmail-multipart-mixed-digest + "From tester Fri Jan 24 00:00:00 2022 +From: Digester +To: Undigester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Test digest +Content-Type: multipart/mixed; boundary=\"===============2529375068597856000==\" +MIME-Version: 1.0 + +--===============2529375068597856000== +Content-Type: text/plain; +MIME-Version: 1.0 +Content-Description: Today's Topics + +Some message. + +--===============2529375068597856000== +Content-Type: multipart/digest; boundary=\"===============6060050777038710134==\" +MIME-Version: 1.0 + +--===============6060050777038710134== +Content-Type: message/rfc822 +MIME-Version: 1.0 + +From: NN1 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message one + +Message one. + +--===============6060050777038710134== +Content-Type: message/rfc822 +MIME-Version: 1.0 + +From: NN2 +To: Digester +Date: ddd, dd mmm yy hh:mm:ss zzz +Subject: Message two + +Message two. + +--===============6060050777038710134==-- + +--===============2529375068597856000== +Content-Type: text/plain; +MIME-Version: 1.0 +Content-Description: Digest Footer + +The footer. + +--===============2529375068597856000==--" + "RFC 1521 digest inside a multipart/mixed message.") + +;;; Utils: +(defun rmail-message-content (message) + "Return the content of the message numbered MESSAGE." + (rmail-show-message message) + (let ((beg (rmail-msgbeg rmail-current-message)) + (end (rmail-msgend rmail-current-message))) + (with-current-buffer rmail-view-buffer + (save-excursion + (goto-char beg) + (search-forward "\n\n" end nil) + (buffer-substring-no-properties (match-end 0) end))))) + +;;; Tests: +(ert-deftest rmail-undigest-test-rfc934-digest () + "Test that we can undigest a RFC 934 digest." + (let ((file (make-temp-file "undigest-test-"))) + (unwind-protect + (with-temp-buffer + (insert rmail-rfc934-digest) + (write-region nil nil file) + (rmail file) + (undigestify-rmail-message) + (should (= rmail-total-messages 4)) + (should (string= (rmail-message-content 2) "Testing the undigester.\n\n")) + (should (string= (rmail-message-content 3) "This is message one.\n\n")) + (should (string= (rmail-message-content 4) "This is message two.\n"))) + (delete-file file)))) + +(ert-deftest rmail-undigest-test-rfc1153-digest-strict () + "Test that we can undigest a strict RFC 1153 digest." + :expected-result :failed + (let ((file (make-temp-file "undigest-test-"))) + (unwind-protect + (with-temp-buffer + (insert rmail-rfc1153-digest-strict) + (write-region nil nil file) + (rmail file) + (should + (ignore-errors + ;; This throws an error, because the Trailer is not recognized + ;; as a valid RFC 822 (or later) message. + (undigestify-rmail-message) + (should (string= (rmail-message-content 2) "Testing the undigester.\n\n")) + (should (string= (rmail-message-content 3) "This is message one.\n\n")) + (should (string= (rmail-message-content 4) "This is message two.\n")) + t))) + (delete-file file)))) + +(ert-deftest rmail-undigest-test-rfc1153-less-strict-digest () + "Test that we can undigest a RFC 1153 with a Subject header in its footer." + (let ((file (make-temp-file "undigest-test-"))) + (unwind-protect + (with-temp-buffer + (insert rmail-rfc1153-digest-less-strict) + (write-region nil nil file) + (rmail file) + (undigestify-rmail-message) + (should (= rmail-total-messages 5)) + (should (string= (rmail-message-content 3) "This is message one.\n\n")) + (should (string= (rmail-message-content 4) "This is message two.\n\n"))) + (delete-file file)))) + +(ert-deftest rmail-undigest-test-rfc1153-sloppy-digest () + "Test that we can undigest a sloppy RFC 1153 digest." + (let ((file (make-temp-file "undigest-test-"))) + (unwind-protect + (with-temp-buffer + (insert rmail-rfc1153-digest-sloppy) + (write-region nil nil file) + (rmail file) + (undigestify-rmail-message) + (should (= rmail-total-messages 5)) + (should (string= (rmail-message-content 3) "This is message one.\n\n")) + (should (string= (rmail-message-content 4) "This is message two.\n\n"))) + (delete-file file)))) + +;; This fails because `rmail-digest-parse-mime' combines the preamble with the +;; first message of the digest. And then, it doesn't get rid of the last +;; separator. +(ert-deftest rmail-undigest-test-rfc1521-mime-digest () + "Test that we can undigest a RFC 1521 MIME digest." + :expected-result :failed + (let ((file (make-temp-file "undigest-test-"))) + (unwind-protect + (with-temp-buffer + (insert rmail-rfc1521-mime-digest) + (write-region nil nil file) + (rmail file) + (undigestify-rmail-message) + (should (= rmail-total-messages 3)) + (should (string= (rmail-message-content 2) "Message one.\n\n")) + (should (string= (rmail-message-content 3) "Message two.\n\n"))) + (delete-file file)))) + +(ert-deftest rmail-undigest-test-multipart-mixed-digest () + "Test that we can undigest a digest inside a multipart/mixed digest." + (let ((file (make-temp-file "undigest-test-"))) + (unwind-protect + (with-temp-buffer + (insert rmail-multipart-mixed-digest) + (write-region nil nil file) + (rmail file) + (undigestify-rmail-message) + (should (= rmail-total-messages 4)) + (should (string= (rmail-message-content 2) "Message one.\n\n")) + (should (string= (rmail-message-content 3) "Message two.\n\n"))) + (delete-file file)))) diff --git a/test/lisp/mh-e/mh-thread-tests.el b/test/lisp/mh-e/mh-thread-tests.el index 84f59e5d300..ea8d441e2d1 100644 --- a/test/lisp/mh-e/mh-thread-tests.el +++ b/test/lisp/mh-e/mh-thread-tests.el @@ -24,7 +24,7 @@ (eval-when-compile (require 'cl-lib)) (defun mh-thread-tests-before-from () - "Generate the fields of a scan line up to where the 'From' field would start. + "Generate the fields of a scan line up to where the \"From\" field would start. The exact contents are not important, but the number of characters is." (concat (make-string mh-cmd-note ?9) (make-string mh-scan-cmd-note-width ?A) diff --git a/test/lisp/mouse-tests.el b/test/lisp/mouse-tests.el index 1be32006a10..03ecbc19858 100644 --- a/test/lisp/mouse-tests.el +++ b/test/lisp/mouse-tests.el @@ -25,6 +25,20 @@ ;;; Code: +(ert-deftest mouse-test-mouse-double-click-time () + (let ((double-click-time 500)) + (should (= (mouse-double-click-time) 500))) + (let ((double-click-time 0)) + (should (= (mouse-double-click-time) 0))) + (let ((double-click-time -500)) + (should (= (mouse-double-click-time) 0))) + (let ((double-click-time nil)) + (should (= (mouse-double-click-time) 0))) + (let ((double-click-time t)) + (should (numberp (mouse-double-click-time)))) + (let ((double-click-time '(invalid))) + (should (= (mouse-double-click-time) 0)))) + (ert-deftest bug23288-use-return-value () "If `mouse-on-link-p' returns a string, its first character is used." (cl-letf ((unread-command-events '((down-mouse-1 nil 1) (mouse-1 nil 1))) diff --git a/test/lisp/net/mailcap-tests.el b/test/lisp/net/mailcap-tests.el index b439c08c791..188706fc86a 100644 --- a/test/lisp/net/mailcap-tests.el +++ b/test/lisp/net/mailcap-tests.el @@ -79,45 +79,45 @@ ;; execution errors when running the tests from the Makefile ;; because then HOME=/nonexistent. (ert-with-temp-directory home - (setenv "HOME" home) - ;; Now parse our resource mailcap file. - (mailcap-parse-mailcap (ert-resource-file "mailcap")) + (with-environment-variables (("HOME" home)) + ;; Now parse our resource mailcap file. + (mailcap-parse-mailcap (ert-resource-file "mailcap")) - ;; Assert that we get what we have defined. - (dolist (type '("audio/ogg" "audio/flac")) - (should (string= "mpv %s" (mailcap-mime-info type)))) - (should (string= "aplay %s" (mailcap-mime-info "audio/x-wav"))) - (should (string= "emacsclient -t %s" - (mailcap-mime-info "text/plain"))) - ;; evince is chosen because acroread has test=false and okular - ;; comes later. - (should (string= "evince %s" - (mailcap-mime-info "application/pdf"))) - (should (string= "inkscape %s" - (mailcap-mime-info "image/svg+xml"))) - (should (string= "eog %s" - (mailcap-mime-info "image/jpg"))) - ;; With REQUEST being a number, all fields of the selected entry - ;; should be returned. - (should (equal '((viewer . "evince %s") - (type . "application/pdf")) - (mailcap-mime-info "application/pdf" 1))) - ;; With 'all, all applicable entries should be returned. - (should (equal '(((viewer . "evince %s") - (type . "application/pdf")) - ((viewer . "okular %s") - (type . "application/pdf"))) - (mailcap-mime-info "application/pdf" 'all))) - (let* ((c nil) - (toggle (lambda (_) (setq c (not c))))) - (mailcap-add "audio/ogg" "toggle %s" toggle) - (should (string= "toggle %s" (mailcap-mime-info "audio/ogg"))) - ;; The test results are cached, so in order to have the test - ;; re-evaluated, one needs to clear the cache. - (setq mailcap-viewer-test-cache nil) - (should (string= "mpv %s" (mailcap-mime-info "audio/ogg"))) - (setq mailcap-viewer-test-cache nil) - (should (string= "toggle %s" (mailcap-mime-info "audio/ogg"))))))) + ;; Assert that we get what we have defined. + (dolist (type '("audio/ogg" "audio/flac")) + (should (string= "mpv %s" (mailcap-mime-info type)))) + (should (string= "aplay %s" (mailcap-mime-info "audio/x-wav"))) + (should (string= "emacsclient -t %s" + (mailcap-mime-info "text/plain"))) + ;; evince is chosen because acroread has test=false and okular + ;; comes later. + (should (string= "evince %s" + (mailcap-mime-info "application/pdf"))) + (should (string= "inkscape %s" + (mailcap-mime-info "image/svg+xml"))) + (should (string= "eog %s" + (mailcap-mime-info "image/jpg"))) + ;; With REQUEST being a number, all fields of the selected entry + ;; should be returned. + (should (equal '((viewer . "evince %s") + (type . "application/pdf")) + (mailcap-mime-info "application/pdf" 1))) + ;; With 'all, all applicable entries should be returned. + (should (equal '(((viewer . "evince %s") + (type . "application/pdf")) + ((viewer . "okular %s") + (type . "application/pdf"))) + (mailcap-mime-info "application/pdf" 'all))) + (let* ((c nil) + (toggle (lambda (_) (setq c (not c))))) + (mailcap-add "audio/ogg" "toggle %s" toggle) + (should (string= "toggle %s" (mailcap-mime-info "audio/ogg"))) + ;; The test results are cached, so in order to have the test + ;; re-evaluated, one needs to clear the cache. + (setq mailcap-viewer-test-cache nil) + (should (string= "mpv %s" (mailcap-mime-info "audio/ogg"))) + (setq mailcap-viewer-test-cache nil) + (should (string= "toggle %s" (mailcap-mime-info "audio/ogg")))))))) (defvar mailcap--test-result nil) (defun mailcap--test-viewer () diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 254595d1b4f..54d1ecf3652 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -888,7 +888,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (zerop (nth 1 fsi)) (zerop (nth 2 fsi)))))) -(ert-deftest tramp-archive-test46-auto-load () +(ert-deftest tramp-archive-test47-auto-load () "Check that `tramp-archive' autoloads properly." :tags '(:expensive-test) (skip-unless tramp-archive-enabled) @@ -905,30 +905,33 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (file-attributes %S \"/\")) \ (message \"tramp-archive loaded: %%s\" \ (featurep 'tramp-archive))))")) - (dolist (default-directory - `(,temporary-file-directory - ;; Starting Emacs in a directory which has - ;; `tramp-archive-file-name-regexp' syntax is - ;; supported only with Emacs > 27.2 (sigh!). - ;; (Bug#48476) - ,(file-name-as-directory tramp-archive-test-directory))) - (dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo"))) - (should - (string-match - (format - "tramp-archive loaded: %s[[:ascii:]]+tramp-archive loaded: %s" - (tramp-archive-file-name-p default-directory) - (or (tramp-archive-file-name-p default-directory) - (tramp-archive-file-name-p file))) - (shell-command-to-string - (format - "%s -batch -Q -L %s --eval %s" - (shell-quote-argument - (expand-file-name invocation-name invocation-directory)) - (mapconcat #'shell-quote-argument load-path " -L ") - (shell-quote-argument (format code file)))))))))) + (dolist (enabled '(t nil)) + (dolist (default-directory + `(,temporary-file-directory + ;; Starting Emacs in a directory which has + ;; `tramp-archive-file-name-regexp' syntax is + ;; supported only with Emacs > 27.2 (sigh!). + ;; (Bug#48476) + ,(file-name-as-directory tramp-archive-test-directory))) + (dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo"))) + (should + (string-match + (format + "tramp-archive loaded: %s[[:ascii:]]+tramp-archive loaded: %s" + (tramp-archive-file-name-p default-directory) + (or (tramp-archive-file-name-p default-directory) + (and enabled (tramp-archive-file-name-p file)))) + (shell-command-to-string + (format + "%s -batch -Q -L %s --eval %s --eval %s" + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) + (mapconcat #'shell-quote-argument load-path " -L ") + (shell-quote-argument + (format "(setq tramp-archive-enabled %s)" enabled)) + (shell-quote-argument (format code file))))))))))) -(ert-deftest tramp-archive-test46-delay-load () +(ert-deftest tramp-archive-test47-delay-load () "Check that `tramp-archive' is loaded lazily, only when needed." :tags '(:expensive-test) (skip-unless tramp-archive-enabled) diff --git a/test/lisp/net/tramp-resources/foo.tar.gz b/test/lisp/net/tramp-resources/foo.tar.gz new file mode 100644 index 00000000000..0d2e9878dd7 Binary files /dev/null and b/test/lisp/net/tramp-resources/foo.tar.gz differ diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index ef82d3ac61b..2d2bef732e0 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -47,6 +47,7 @@ (require 'ert) (require 'ert-x) (require 'seq) ; For `seq-random-elt', autoloaded since Emacs 28.1 +(require 'tar-mode) (require 'trace) (require 'tramp) (require 'vc) @@ -125,6 +126,7 @@ tramp-allow-unsafe-temporary-files t tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil + tramp-error-show-message-timeout nil tramp-persistency-file-name nil tramp-verbose 0) @@ -2510,6 +2512,48 @@ This checks also `file-name-as-directory', `file-name-directory', (ignore-errors (advice-remove 'write-region advice)) (ignore-errors (delete-file tmp-name))))) +;; The following test is inspired by Bug#55166. +(ert-deftest tramp-test10-write-region-other-file-name-handler () + "Check that another file name handler in VISIT is acknowledged." + (skip-unless (tramp--test-enabled)) + (skip-unless (not (tramp--test-ange-ftp-p))) + (skip-unless (executable-find "gzip")) + + (let* ((default-directory tramp-test-temporary-file-directory) + (archive (ert-resource-file "foo.tar.gz")) + (tmp-file (expand-file-name (file-name-nondirectory archive))) + (require-final-newline t) + (inhibit-message t) + (backup-inhibited t) + create-lockfiles buffer1 buffer2) + (unwind-protect + (progn + (copy-file archive tmp-file 'ok) + ;; Read archive. Check contents of foo.txt, and modify it. Save. + (with-current-buffer (setq buffer1 (find-file-noselect tmp-file)) + (should (tar-goto-file "foo.txt")) + (save-current-buffer + (setq buffer2 (tar-extract)) + (should (string-equal (buffer-string) "foo\n")) + (goto-char (point-max)) + (insert "bar") + (should (null (save-buffer)))) + (should (null (save-buffer)))) + + (kill-buffer buffer1) + (kill-buffer buffer2) + ;; Read archive. Check contents of modified foo.txt. + (with-current-buffer (setq buffer1 (find-file-noselect tmp-file)) + (should (tar-goto-file "foo.txt")) + (save-current-buffer + (setq buffer2 (tar-extract)) + (should (string-equal (buffer-string) "foo\nbar\n"))))) + + ;; Cleanup. + (ignore-errors (kill-buffer buffer1)) + (ignore-errors (kill-buffer buffer2)) + (ignore-errors (delete-file tmp-file))))) + (ert-deftest tramp-test11-copy-file () "Check `copy-file'." (skip-unless (tramp--test-enabled)) @@ -4540,14 +4584,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) - kill-buffer-query-functions proc) + kill-buffer-query-functions command proc) ;; Simple process. (unwind-protect (with-temp-buffer - (setq proc (start-file-process "test1" (current-buffer) "cat")) + (setq command '("cat") + proc + (apply #'start-file-process "test1" (current-buffer) command)) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. @@ -4564,11 +4611,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-temp-buffer (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) - (setq proc - (start-file-process - "test2" (current-buffer) - "cat" (file-name-nondirectory tmp-name))) + (setq command `("cat" ,(file-name-nondirectory tmp-name)) + proc + (apply #'start-file-process "test2" (current-buffer) command)) (should (processp proc)) + (should (equal (process-get proc 'remote-command) command)) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) @@ -4583,9 +4630,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Process filter. (unwind-protect (with-temp-buffer - (setq proc (start-file-process "test3" (current-buffer) "cat")) + (setq command '("cat") + proc + (apply #'start-file-process "test3" (current-buffer) command)) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (set-process-filter proc (lambda (p s) (with-current-buffer (process-buffer p) (insert s)))) @@ -4604,9 +4654,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (unless (tramp--test-sshfs-p) (unwind-protect (with-temp-buffer - (setq proc (start-file-process "test3" (current-buffer) "cat")) + (setq command '("cat") + proc + (apply #'start-file-process "test4" (current-buffer) command)) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (set-process-filter proc t) (process-send-string proc "foo\n") (process-send-eof proc) @@ -4632,12 +4685,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (dolist (process-connection-type '(nil pipe t pty)) (unwind-protect (with-temp-buffer - (setq proc - (start-file-process - (format "test4-%s" process-connection-type) - (current-buffer) "hexdump" "-v" "-e" "/1 \"%02X\n\"")) + (setq command '("hexdump" "-v" "-e" "/1 \"%02X\n\"") + proc + (apply #'start-file-process + (format "test5-%s" process-connection-type) + (current-buffer) command)) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\r\n") (process-send-eof proc) ;; Read output. @@ -4665,12 +4720,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; It works only for tramp-sh.el, and not direct async processes. (if (or (not (tramp--test-sh-p)) (tramp-direct-async-process-p)) (should-error - (start-file-process "test5" (current-buffer) nil) + (start-file-process "test6" (current-buffer) nil) :type 'wrong-type-argument) - (setq proc (start-file-process "test5" (current-buffer) nil)) + (setq proc (start-file-process "test6" (current-buffer) nil)) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should-not (process-get proc 'remote-command)) ;; On MS Windows, `process-tty-name' returns nil. (unless (tramp--test-windows-nt-p) (should (stringp (process-tty-name proc)))))) @@ -4713,7 +4769,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ert-deftest tramp-test30-make-process () "Check `make-process'." - :tags '(:expensive-test :tramp-asynchronous-processes) + :tags (append '(:expensive-test :tramp-asynchronous-processes) + (and (getenv "EMACS_EMBA_CI") + '(:unstable))) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) ;; `make-process' supports file name handlers since Emacs 27. @@ -4722,19 +4780,21 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) - kill-buffer-query-functions proc) + kill-buffer-query-functions command proc) (with-no-warnings (should-not (make-process))) ;; Simple process. (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat") + proc (with-no-warnings (make-process - :name "test1" :buffer (current-buffer) :command '("cat") + :name "test1" :buffer (current-buffer) :command command :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. @@ -4751,13 +4811,14 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-temp-buffer (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) - (setq proc + (setq command `("cat" ,(file-name-nondirectory tmp-name)) + proc (with-no-warnings (make-process - :name "test2" :buffer (current-buffer) - :command `("cat" ,(file-name-nondirectory tmp-name)) + :name "test2" :buffer (current-buffer) :command command :file-handler t))) (should (processp proc)) + (should (equal (process-get proc 'remote-command) command)) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) @@ -4772,16 +4833,18 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Process filter. (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat") + proc (with-no-warnings (make-process - :name "test3" :buffer (current-buffer) :command '("cat") + :name "test3" :buffer (current-buffer) :command command :filter (lambda (p s) (with-current-buffer (process-buffer p) (insert s))) :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. @@ -4797,14 +4860,16 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (unless (tramp--test-sshfs-p) (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat") + proc (with-no-warnings (make-process - :name "test3" :buffer (current-buffer) :command '("cat") + :name "test4" :buffer (current-buffer) :command command :filter t :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. There shouldn't be any. @@ -4820,16 +4885,18 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Process sentinel. (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat") + proc (with-no-warnings (make-process - :name "test4" :buffer (current-buffer) :command '("cat") + :name "test5" :buffer (current-buffer) :command command :sentinel (lambda (p s) (with-current-buffer (process-buffer p) (insert s))) :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\n") (process-send-eof proc) (delete-process proc) @@ -4848,14 +4915,15 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (let ((stderr (generate-new-buffer "*stderr*"))) (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat" "/does-not-exist") + proc (with-no-warnings (make-process - :name "test5" :buffer (current-buffer) - :command '("cat" "/does-not-exist") + :name "test6" :buffer (current-buffer) :command command :stderr stderr :file-handler t))) (should (processp proc)) + (should (equal (process-get proc 'remote-command) command)) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) (while (accept-process-output proc 0 nil t))) @@ -4879,14 +4947,15 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (unless (tramp-direct-async-process-p) (unwind-protect (with-temp-buffer - (setq proc + (setq command '("cat" "/does-not-exist") + proc (with-no-warnings (make-process - :name "test6" :buffer (current-buffer) - :command '("cat" "/does-not-exist") + :name "test7" :buffer (current-buffer) :command command :stderr tmp-name :file-handler t))) (should (processp proc)) + (should (equal (process-get proc 'remote-command) command)) ;; Read stderr. (with-timeout (10 (tramp--test-timeout-handler)) (while (accept-process-output proc nil nil t))) @@ -4917,18 +4986,20 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (unless connection-type '(nil pipe t pty))) (unwind-protect (with-temp-buffer - (setq proc + (setq command '("hexdump" "-v" "-e" "/1 \"%02X\n\"") + proc (with-no-warnings (make-process :name - (format "test7-%s-%s" + (format "test8-%s-%s" connection-type process-connection-type) :buffer (current-buffer) :connection-type connection-type - :command '("hexdump" "-v" "-e" "/1 \"%02X\n\"") + :command command :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) + (should (equal (process-get proc 'remote-command) command)) (process-send-string proc "foo\r\n") (process-send-eof proc) ;; Read output. @@ -4956,9 +5027,8 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ert-deftest tramp-test31-interrupt-process () "Check `interrupt-process'." - :tags (append '(:expensive-test :tramp-asynchronous-processes) - (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) - '(:unstable))) + ;; The final `process-live-p' check does not run sufficiently. + :tags '(:expensive-test :tramp-asynchronous-processes :unstable) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) @@ -4968,16 +5038,19 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; process. (let ((default-directory (file-truename tramp-test-temporary-file-directory)) (delete-exited-processes t) - kill-buffer-query-functions proc) + kill-buffer-query-functions command proc) (unwind-protect (with-temp-buffer - (setq proc (start-file-process-shell-command - "test" (current-buffer) - "trap 'echo boom; exit 1' 2; sleep 100")) + (setq command "trap 'echo boom; exit 1' 2; sleep 100" + proc (start-file-process-shell-command + "test" (current-buffer) command)) (should (processp proc)) (should (process-live-p proc)) (should (equal (process-status proc) 'run)) (should (numberp (process-get proc 'remote-pid))) + (should (equal (process-get proc 'remote-command) + (with-connection-local-variables + `(,shell-file-name ,shell-command-switch ,command)))) (should (interrupt-process proc)) ;; Let the process accept the interrupt. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4992,12 +5065,125 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc))))) +(ert-deftest tramp-test31-signal-process () + "Check `signal-process'." + ;; The final `process-live-p' check does not run sufficiently. + :tags '(:expensive-test :tramp-asynchronous-processes :unstable) + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) + ;; Since Emacs 29.1. + (skip-unless (boundp 'signal-process-functions)) + + ;; We must use `file-truename' for the temporary directory, in + ;; order to establish the connection prior running an asynchronous + ;; process. + (let ((default-directory (file-truename tramp-test-temporary-file-directory)) + (delete-exited-processes t) + kill-buffer-query-functions command proc) + + (dolist (sigcode '(2 INT)) + (unwind-protect + (with-temp-buffer + (setq command "trap 'echo boom; exit 1' 2; sleep 100" + proc (start-file-process-shell-command + (format "test1%s" sigcode) (current-buffer) command)) + (should (processp proc)) + (should (process-live-p proc)) + (should (equal (process-status proc) 'run)) + (should (numberp (process-get proc 'remote-pid))) + (should (equal (process-get proc 'remote-command) + (with-connection-local-variables + `(,shell-file-name ,shell-command-switch ,command)))) + (should (zerop (signal-process proc sigcode))) + ;; Let the process accept the signal. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc 0 nil t))) + (should-not (process-live-p proc))) + + ;; Cleanup. + (ignore-errors (kill-process proc)) + (ignore-errors (delete-process proc))) + + (unwind-protect + (with-temp-buffer + (setq command "trap 'echo boom; exit 1' 2; sleep 100" + proc (start-file-process-shell-command + (format "test2%s" sigcode) (current-buffer) command)) + (should (processp proc)) + (should (process-live-p proc)) + (should (equal (process-status proc) 'run)) + (should (numberp (process-get proc 'remote-pid))) + (should (equal (process-get proc 'remote-command) + (with-connection-local-variables + `(,shell-file-name ,shell-command-switch ,command)))) + (should + (zerop + (signal-process + (process-get proc 'remote-pid) sigcode default-directory))) + ;; Let the process accept the signal. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc 0 nil t))) + (should-not (process-live-p proc))) + + ;; Cleanup. + (ignore-errors (kill-process proc)) + (ignore-errors (delete-process proc)))))) + +(ert-deftest tramp-test31-list-system-processes () + "Check `list-system-processes'." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-supports-processes-p)) + ;; `list-system-processes' is supported since Emacs 29.1. + (skip-unless (tramp--test-emacs29-p)) + + (let ((default-directory tramp-test-temporary-file-directory)) + (skip-unless (consp (list-system-processes))) + (should (not (equal (list-system-processes) + (let ((default-directory temporary-file-directory)) + (list-system-processes))))))) + +(ert-deftest tramp-test31-process-attributes () + "Check `process-attributes'." + :tags '(:expensive-test :tramp-asynchronous-processes) + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-supports-processes-p)) + ;; `process-attributes' is supported since Emacs 29.1. + (skip-unless (tramp--test-emacs29-p)) + + ;; We must use `file-truename' for the temporary directory, in + ;; order to establish the connection prior running an asynchronous + ;; process. + (let ((default-directory (file-truename tramp-test-temporary-file-directory)) + (delete-exited-processes t) + kill-buffer-query-functions command proc) + (skip-unless (consp (list-system-processes))) + + (unwind-protect + (progn + (setq command '("sleep" "100") + proc (apply #'start-file-process "test" nil command)) + (while (accept-process-output proc 0)) + (when-let ((pid (process-get proc 'remote-pid)) + (attributes (process-attributes pid))) + ;; (tramp--test-message "%s" attributes) + (should (equal (cdr (assq 'comm attributes)) (car command))) + (should (equal (cdr (assq 'args attributes)) + (mapconcat #'identity command " "))))) + + ;; Cleanup. + (ignore-errors (delete-process proc))))) + (defun tramp--test-async-shell-command (command output-buffer &optional error-buffer input) "Like `async-shell-command', reading the output. INPUT, if non-nil, is a string sent to the process." (let ((proc (async-shell-command command output-buffer error-buffer)) (delete-exited-processes t)) + (should (equal (process-get proc 'remote-command) + (with-connection-local-variables + `(,shell-file-name ,shell-command-switch ,command)))) (cl-letf (((symbol-function #'shell-command-sentinel) #'ignore)) (when (stringp input) (process-send-string proc input)) @@ -7155,8 +7341,67 @@ process sentinels. They shall not disturb each other." (delete-directory tmp-name) (delete-file (concat tmp-name ".tar.gz")))) +(ert-deftest tramp-test46-read-password () + "Check Tramp password handling." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-mock-p)) + ;; Not all read commands understand argument "-s" or "-p". + (skip-unless + (string-empty-p + (let ((shell-file-name "sh")) + (shell-command-to-string "read -s -p Password: pass")))) + + (let ((pass "secret") + (mock-entry (copy-sequence (assoc "mock" tramp-methods))) + mocked-input tramp-methods) + ;; We must mock `read-string', in order to avoid interactive + ;; arguments. + (cl-letf* (((symbol-function #'read-string) + (lambda (&rest _args) (pop mocked-input)))) + (setcdr + (assq 'tramp-login-args mock-entry) + `((("-c") + (,(tramp-shell-quote-argument + (concat + "read -s -p 'Password: ' pass; echo; " + "(test \"pass$pass\" != \"pass" pass "\" && " + "echo \"Login incorrect\" || sh -i)")))))) + (setq tramp-methods `(,mock-entry)) + + ;; Reading password from stdin works. + (tramp-cleanup-connection tramp-test-vec 'keep-debug) + ;; We don't want to invalidate the password. + (setq mocked-input `(,(copy-sequence pass))) + (should (file-exists-p tramp-test-temporary-file-directory)) + + ;; Don't entering a password returns in error. + (tramp-cleanup-connection tramp-test-vec 'keep-debug) + (setq mocked-input nil) + (should-error (file-exists-p tramp-test-temporary-file-directory)) + + ;; A wrong password doesn't work either. + (tramp-cleanup-connection tramp-test-vec 'keep-debug) + (setq mocked-input `(,(concat pass pass))) + (should-error (file-exists-p tramp-test-temporary-file-directory)) + + ;; Reading password from auth-source works. We use the netrc + ;; backend; the other backends shall behave similar. + ;; Macro `ert-with-temp-file' was introduced in Emacs 29.1. + (with-no-warnings (when (symbol-plist 'ert-with-temp-file) + (tramp-cleanup-connection tramp-test-vec 'keep-debug) + (setq mocked-input nil) + (auth-source-forget-all-cached) + (ert-with-temp-file netrc-file + :prefix "tramp-test" :suffix "" + :text (format + "machine %s port mock password %s" + (file-remote-p tramp-test-temporary-file-directory 'host) pass) + (let ((auth-sources `(,netrc-file))) + (should (file-exists-p tramp-test-temporary-file-directory))))))))) + ;; This test is inspired by Bug#29163. -(ert-deftest tramp-test46-auto-load () +(ert-deftest tramp-test47-auto-load () "Check that Tramp autoloads properly." ;; If we use another syntax but `default', Tramp is already loaded ;; due to the `tramp-change-syntax' call. @@ -7181,7 +7426,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test46-delay-load () +(ert-deftest tramp-test47-delay-load () "Check that Tramp is loaded lazily, only when needed." ;; Tramp is neither loaded at Emacs startup, nor when completing a ;; non-Tramp file name like "/foo". Completing a Tramp-alike file @@ -7210,7 +7455,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code tm))))))))) -(ert-deftest tramp-test46-recursive-load () +(ert-deftest tramp-test47-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -7234,7 +7479,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) -(ert-deftest tramp-test46-remote-load-path () +(ert-deftest tramp-test47-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." ;; `tramp-cleanup-all-connections' is autoloaded from tramp-cmds.el. ;; It shall still work, when a remote file name is in the @@ -7259,11 +7504,10 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test47-unload () +(ert-deftest tramp-test48-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) - (skip-unless noninteractive) ;; We have autoloaded objects from tramp.el and tramp-archive.el. ;; In order to remove them, we first need to load both packages. (require 'tramp) @@ -7329,7 +7573,13 @@ Since it unloads Tramp, it shall be the last test to run." (and (string-match-p "^tramp" (symbol-name fun)) (ert-fail (format "Function `%s' still contains Tramp advice" x)))) - x))))) + x)))) + + ;; Reload. + (require 'tramp) + (require 'tramp-archive) + (should (featurep 'tramp)) + (should (featurep 'tramp-archive))) (defun tramp-test-all (&optional interactive) "Run all tests for \\[tramp]. @@ -7352,8 +7602,9 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * Work on skipped tests. Make a comment, when it is impossible. ;; * Revisit expensive tests, once problems in `tramp-error' are solved. ;; * Fix `tramp-test06-directory-file-name' for "ftp". -;; * Implement `tramp-test31-interrupt-process' for "adb", "sshfs" and -;; for direct async processes. +;; * Implement `tramp-test31-interrupt-process' and +;; `tramp-test31-signal-process' for "adb", "sshfs" and for direct +;; async processes. Check, why they don't run stable. ;; * Check, why direct async processes do not work for ;; `tramp-test44-asynchronous-requests'. diff --git a/test/lisp/progmodes/cperl-mode-tests.el b/test/lisp/progmodes/cperl-mode-tests.el index b8a3bd97d8d..4e0debffb69 100644 --- a/test/lisp/progmodes/cperl-mode-tests.el +++ b/test/lisp/progmodes/cperl-mode-tests.el @@ -64,7 +64,7 @@ The expected output from running BODY on the input goes here. # -------- NAME: end -------- You can have many of these blocks in one test file. You can -chose a NAME for each block, which is passed to the 'should' +chose a NAME for each block, which is passed to the `should' clause for easy identification of the first test case that failed (if any). Text outside these the blocks is ignored by the tests, so you can use it to document the test cases if you wish." diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 1a6a7dc176d..01b233cc425 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -3503,10 +3503,7 @@ def foo(): (should (string= (python-shell-buffer-substring (python-tests-look-at "print ('a')") (point-max)) - "if True: - - print ('a') -")))) + "# -*- coding: utf-8 -*-\nif True:\n print ('a')\n\n")))) (ert-deftest python-shell-buffer-substring-11 () "Check substring from partial block and point within indentation." @@ -3521,10 +3518,7 @@ def foo(): (backward-char 1) (point)) (point-max)) - "if True: - - print ('a') -")))) + "# -*- coding: utf-8 -*-\nif True:\n print ('a')\n\n")))) (ert-deftest python-shell-buffer-substring-12 () "Check substring from partial block and point in whitespace." @@ -3539,13 +3533,7 @@ def foo(): (should (string= (python-shell-buffer-substring (python-tests-look-at "# Whitespace") (point-max)) - "if True: - - - # Whitespace - - print ('a') -")))) + "# -*- coding: utf-8 -*-\n\nif True:\n # Whitespace\n\n print ('a')\n\n")))) diff --git a/test/lisp/progmodes/ruby-mode-resources/ruby.rb b/test/lisp/progmodes/ruby-mode-resources/ruby.rb index 8c698e4fac8..0c206b1e0c2 100644 --- a/test/lisp/progmodes/ruby-mode-resources/ruby.rb +++ b/test/lisp/progmodes/ruby-mode-resources/ruby.rb @@ -483,3 +483,20 @@ def qux 2 = 3 :foo= if true {:abc=>4} # not indented, and '=' is not highlighted + +# Pattern matching +case translation +in ['th', orig_text, 'en', trans_text] + puts "English translation: #{orig_text} => #{trans_text}" +in {'th' => orig_text, 'ja' => trans_text} + puts "Japanese translation: #{orig_text} => #{trans_text}" +end + +# Tokenizing "**" and "|" separately. +def resolve(**args) + members = proc do |**args| + p(**args) + end + + member.call(**args) +end diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el index 7e36d845e2c..c644d115df6 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -425,5 +425,85 @@ The ACTION will be tested after set-up of PRODUCT." (let ((sql-password "password")) (should (equal "password" (sql-comint-automatic-password ""))))) + + +;; Tests for sql-interactive-remove-continuation-prompt + +(defmacro sql-tests-remove-cont-prompts-harness (&rest body) + "Set-up and tear-down for tests of +`sql-interactive-remove-continuation-prompt'." + (declare (indent 0)) + `(let ((comint-prompt-regexp "^ +\\.\\{3\\} ") + (sql-output-newline-count nil) + (sql-preoutput-hold nil)) + ,@body + (should (null sql-output-newline-count)) + (should (null sql-preoutput-hold)))) + +(ert-deftest sql-tests-remove-cont-prompts-pass-through () + "Test that `sql-interactive-remove-continuation-prompt' just +passes the output line through when it doesn't expect prompts." + (sql-tests-remove-cont-prompts-harness + (should + (equal " ... " + (sql-interactive-remove-continuation-prompt + " ... "))))) + +(ert-deftest sql-tests-remove-cont-prompts-anchored-successive () + "Test that `sql-interactive-remove-continuation-prompt' is able +to delete multiple prompts (anchored to bol) even if they appear +in a single line, but not more than `sql-output-newline-count'." + (sql-tests-remove-cont-prompts-harness + (setq sql-output-newline-count 2) + (should + (equal + ;; 2 of 3 prompts are deleted + "some output ... more output...\n\ + ... \n\ +output after prompt" + (sql-interactive-remove-continuation-prompt + "some output ... more output...\n\ + ... ... ... \n\ +output after prompt"))))) + +(ert-deftest sql-tests-remove-cont-prompts-collect-chunked-output () + "Test that `sql-interactive-remove-continuation-prompt' properly +collects output when output arrives in chunks, with prompts +intermixed." + (sql-tests-remove-cont-prompts-harness + (setq sql-output-newline-count 2) + + ;; Part of first prompt gets held. Complete line is passed + ;; through. + (should (equal "line1\n" + (sql-interactive-remove-continuation-prompt + "line1\n .."))) + (should (equal " .." sql-preoutput-hold)) + (should (equal 2 sql-output-newline-count)) + + ;; First prompt is complete - remove it. Hold part of line2. + (should (equal "" + (sql-interactive-remove-continuation-prompt ". li"))) + (should (equal "li" sql-preoutput-hold)) + (should (equal 1 sql-output-newline-count)) + + ;; Remove second prompt. Flush output & don't hold / process any + ;; output further on. + (should (equal "line2\nli" + (sql-interactive-remove-continuation-prompt "ne2\n ... li"))) + (should (null sql-preoutput-hold)) + (should (null sql-output-newline-count)) + (should (equal "line3\n ... " + (sql-interactive-remove-continuation-prompt "line3\n ... "))))) + +(ert-deftest sql-tests-remove-cont-prompts-flush-held () + "Test that when we don't wait for prompts, + `sql-interactive-remove-continuation-prompt' just 'flushes' held + output, with no prompt processing." + (sql-tests-remove-cont-prompts-harness + (setq sql-preoutput-hold "line1\n ..") + (should (equal "line1\n ... line2 .." + (sql-interactive-remove-continuation-prompt ". line2 .."))))) + (provide 'sql-tests) ;;; sql-tests.el ends here diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index 5ba11ed0d57..ef1e5c3eafc 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -405,6 +405,102 @@ Each element has the format: (and (buffer-name temp-buffer) (kill-buffer temp-buffer))))) + +;;; General tests for `query-replace' and `query-replace-regexp'. + +(defconst query-replace-tests + '( + ;; query-replace + ("aaa" "M-% a RET 1 RET !" "111") + ("aaa" "M-% a RET 1 RET y n y" "1a1") + ;; Empty inputs + ("aaa" "M-% a RET RET !" "") + ("aaa" "M-% RET 1 RET !" "1a1a1a") + ("aaa" "M-% RET RET !" "aaa") + ;; Reuse the previous default + ("aaa" "M-% a RET 1 RET . M-% RET !" "111") + + ;; query-replace-regexp + ("aaa" "C-M-% a* RET 1 RET !" "1") + ;; Empty inputs + ("aaa" "C-M-% a* RET RET !" "") + ("aaa" "C-M-% RET 1 RET !" "1a1a1a") + ("aaa" "C-M-% RET RET !" "aaa") + ;; Empty matches + ("aaa" "C-M-% b* RET 1 RET !" "1a1a1a") + ;; Complete matches + ("aaa" "C-M-% .* RET 1 RET !" "1") + ;; Adjacent non-empty matches + ("abaab" "C-M-% ab* RET 12 RET !" "121212") + ;; Adjacent non-empty and empty matches + ("abab" "C-M-% a* RET 1 RET !" "1b1b") + ("abab" "C-M-% b* RET 1 RET !" "1a1a1") + ;; Test case from commit 5632eb272c7 + ("a a a " "C-M-% \\ba SPC RET c RET !" "ccc") ; not "ca c" + )) + +(defun query-replace--run-tests (tests) + (with-temp-buffer + (save-window-excursion + ;; `execute-kbd-macro' is applied to window only + (set-window-buffer nil (current-buffer)) + (dolist (case tests) + ;; Ensure empty input means empty string to replace: + (setq query-replace-defaults nil) + (delete-region (point-min) (point-max)) + (insert (nth 0 case)) + (goto-char (point-min)) + (execute-kbd-macro (kbd (nth 1 case))) + (should (equal (buffer-string) (nth 2 case))))))) + +(ert-deftest query-replace-tests () + (query-replace--run-tests query-replace-tests)) + +(ert-deftest query-replace-search-function-tests () + (let* ((replace-re-search-function #'re-search-forward)) + (query-replace--run-tests query-replace-tests)) + + (let* ((pairs '((1 . 2) (3 . 4))) + (replace-re-search-function + (lambda (string &optional _bound noerror count) + (let (found) + (while (and (not found) pairs) + (goto-char (caar pairs)) + (when (re-search-forward string (cdar pairs) noerror count) + (setq found t)) + (pop pairs)) + found))) + (tests + '( + ;; FIXME: this test should pass after fixing bug#54733: + ;; ("aaaa" "C-M-% .* RET 1 RET !" "1a1a") + ))) + (query-replace--run-tests tests))) + + +;;; General tests for `perform-replace'. + +(defconst perform-replace-tests + '( + ;; Test case from commit 5632eb272c7 + ("a a a " "\\ba " "c" nil t nil nil nil nil nil nil nil "ccc") ; not "ca c" + ;; The same with region inside the second match + ;; FIXME: this test should pass after fixing bug#54733: + ;; ("a a a " "\\ba " "c" nil t nil nil nil 1 4 nil nil "ca a ") + )) + +(defun perform-replace--run-tests (tests) + (with-temp-buffer + (dolist (case tests) + (delete-region (point-min) (point-max)) + (insert (pop case)) + (goto-char (point-min)) + (apply 'perform-replace (butlast case)) + (should (equal (buffer-string) (car (last case))))))) + +(ert-deftest perform-replace-tests () + (perform-replace--run-tests perform-replace-tests)) + ;;; Tests for `query-replace' undo feature. diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el index cd524cbf6e0..ea3f9d05d70 100644 --- a/test/lisp/ses-tests.el +++ b/test/lisp/ses-tests.el @@ -22,12 +22,24 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'ert-x)) (require 'ses) ;; Silence byte-compiler. -(with-suppressed-warnings ((lexical A2) (lexical A3)) +(with-suppressed-warnings ((lexical ses--cells) + (lexical A2) + (lexical A3) + (lexical ses--foo) + (lexical ses--bar) + (lexical B2) + (lexical ses--toto)) + (defvar ses--cells) (defvar A2) - (defvar A3)) + (defvar A3) + (defvar ses--foo) + (defvar ses--bar) + (defvar B2) + (defvar ses--toto)) ;; PLAIN FORMULA TESTS ;; ====================================================================== @@ -58,9 +70,6 @@ equal to 2. This is done using interactive calls." ;; PLAIN CELL RENAMING TESTS ;; ====================================================================== -(defvar ses--foo) -(defvar ses--cells) - (ert-deftest ses-tests-lowlevel-renamed-cell () "Check that renaming A1 to `ses--foo' and setting `ses--foo' to 1 and A2 to (1+ ses--foo), makes A2 value equal to 2. This is done using low level functions, `ses-rename-cell' is not @@ -154,7 +163,6 @@ to A2 and inserting a row, makes A2 value empty, and A3 equal to (should-not (bound-and-true-p A2)) (should (eq (bound-and-true-p A3) 2))))) -(defvar ses--bar) (ert-deftest ses-tests-renamed-cells-row-insertion () "Check that setting A1 to 1 and A2 to (1+ A1), and then renaming A1 to `ses--foo' and A2 to `ses--bar' jumping @@ -178,6 +186,61 @@ to `ses--bar' and inserting a row, makes A2 value empty, and `ses--bar' equal to (should (eq ses--bar 2))))) +;; JUMP tests +;; ====================================================================== +(ert-deftest ses-jump-B2-prefix-arg () + "Test jumping to cell B2 by use of prefix argument" + (let ((ses-initial-size '(3 . 3)) + ses-after-entry-functions) + (with-temp-buffer + (ses-mode) + ;; C-u 4 M-x ses-jump + (let ((current-prefix-arg 4)) + (call-interactively 'ses-jump)) + (should (eq (ses--cell-at-pos (point)) 'B2))))) + + +(ert-deftest ses-jump-B2-lowcase () + "Test jumping to cell B2 by use of lowcase cell name string" + (let ((ses-initial-size '(3 . 3)) + ses-after-entry-functions) + (with-temp-buffer + (ses-mode) + (funcall-interactively 'ses-jump "b2") + (ses-command-hook) + (should (eq (ses--cell-at-pos (point)) 'B2))))) + +(ert-deftest ses-jump-B2-lowcase-keys () + "Test jumping to cell B2 by use of lowcase cell name string with simulating keys" + (let ((ses-initial-size '(3 . 3)) + ses-after-entry-functions) + (with-temp-buffer + (ses-mode) + (ert-simulate-keys [ ?b ?2 return] (ses-jump)) + (ses-command-hook) + (should (eq (ses--cell-at-pos (point)) 'B2))))) + +(ert-deftest ses-jump-B2-symbol () + "Test jumping to cell B2 by use of cell name symbol" + (let ((ses-initial-size '(3 . 3)) + ses-after-entry-functions) + (with-temp-buffer + (ses-mode) + (funcall-interactively 'ses-jump 'B2) + (ses-command-hook) + (should (eq (ses--cell-at-pos (point)) 'B2))))) + +(ert-deftest ses-jump-B2-renamed () + "Test jumping to cell B2 after renaming it `ses--toto'." + (let ((ses-initial-size '(3 . 3)) + ses-after-entry-functions) + (with-temp-buffer + (ses-mode) + (ses-rename-cell 'ses--toto (ses-get-cell 1 1)) + (ses-jump 'ses--toto) + (ses-command-hook) + (should (eq (ses--cell-at-pos (point)) 'ses--toto))))) + (provide 'ses-tests) ;;; ses-tests.el ends here diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el index 6350bebeeea..dcab811bb5a 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -966,8 +966,8 @@ See Bug#21722." (setq buffer-undo-list nil) (downcase-word 1) (should (= (length (delq nil (undo-make-selective-list 1 9))) 2)) - (should (= (length (delq nil (undo-make-selective-list 4 9))) 1)) - ;; FIXME this is the off-by-one error case. + ;; FIXME: These should give 0, but currently give 1. + ;;(should (= (length (delq nil (undo-make-selective-list 4 9))) 0)) ;;(should (= (length (delq nil (undo-make-selective-list 5 9))) 0)) (should (= (length (delq nil (undo-make-selective-list 6 9))) 0)))) diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index e027c68d0b2..8f3ee66e00d 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -1028,5 +1028,50 @@ final or penultimate step during initialization.")) (should (readablep "foo")) (should-not (readablep (list (make-marker))))) +(ert-deftest test-string-lines () + (should (equal (string-lines "") '(""))) + (should (equal (string-lines "" t) '())) + + (should (equal (string-lines "foo") '("foo"))) + (should (equal (string-lines "foo\n") '("foo"))) + (should (equal (string-lines "foo\nbar") '("foo" "bar"))) + + (should (equal (string-lines "foo" t) '("foo"))) + (should (equal (string-lines "foo\n" t) '("foo"))) + (should (equal (string-lines "foo\nbar" t) '("foo" "bar"))) + (should (equal (string-lines "foo\n\n\nbar" t) '("foo" "bar"))) + + (should (equal (string-lines "foo" nil t) '("foo"))) + (should (equal (string-lines "foo\n" nil t) '("foo\n"))) + (should (equal (string-lines "foo\nbar" nil t) '("foo\n" "bar"))) + (should (equal (string-lines "foo\n\n\nbar" nil t) + '("foo\n" "\n" "\n" "bar"))) + + (should (equal (string-lines "foo" t t) '("foo"))) + (should (equal (string-lines "foo\n" t t) '("foo\n"))) + (should (equal (string-lines "foo\nbar" t t) '("foo\n" "bar"))) + (should (equal (string-lines "foo\n\n\nbar" t t) + '("foo\n" "bar")))) + +(ert-deftest test-keymap-parse-macros () + (should (equal (key-parse "C-x ( C-d C-x )") [24 40 4 24 41])) + (should (equal (kbd "C-x ( C-d C-x )") "")) + (should (equal (kbd "C-x ( C-x )") ""))) + +(ert-deftest test-local-set-state () + (setq global 1) + (with-temp-buffer + (setq-local local 2) + (let ((state (buffer-local-set-state global 10 + local 20 + unexist 30))) + (should (= global 10)) + (should (= local 20)) + (should (= unexist 30)) + (buffer-local-restore-state state) + (should (= global 1)) + (should (= local 2)) + (should-not (boundp 'unexist))))) + (provide 'subr-tests) ;;; subr-tests.el ends here diff --git a/test/lisp/textmodes/page-tests.el b/test/lisp/textmodes/page-tests.el index 596f3a6ceb7..b7217e69f0c 100644 --- a/test/lisp/textmodes/page-tests.el +++ b/test/lisp/textmodes/page-tests.el @@ -80,6 +80,17 @@ (narrow-to-page 2) (should (equal (buffer-string) "baz")) (narrow-to-page -1) + (should (equal (buffer-string) "bar\n")) + + (widen) + (goto-char (point-min)) + (narrow-to-page) + (should (equal (buffer-string) "foo\n")) + (goto-char (point-max)) + (narrow-to-page 2) + (should (equal (buffer-string) "baz")) + (goto-char (point-max)) + (narrow-to-page -1) (should (equal (buffer-string) "bar\n")))) (ert-deftest page-tests-count-lines-page () @@ -100,4 +111,5 @@ (forward-page) (should (equal (page--what-page) '(3 4))))) + ;;; page-tests.el ends here diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el index eecf6406fb8..748f1e39446 100644 --- a/test/lisp/xml-tests.el +++ b/test/lisp/xml-tests.el @@ -97,7 +97,7 @@ ((("FOOBAR:" . "something") nil "hi there")) ((FOOBAR:something nil "hi there")))) "List of strings which are parsed using namespace expansion. -Parser is called with and without 'symbol-qnames argument.") +Parser is called with and without `symbol-qnames' argument.") (ert-deftest xml-parse-tests () "Test XML parsing." diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 723ef4c710f..c080c483927 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -130,6 +130,49 @@ (should (equal [nil nil nil nil nil t t t t t] (vconcat A))) (should (equal [t t t t t nil nil nil nil nil] (vconcat (nreverse A)))))) +(defconst fns-tests--string-lessp-cases + '((a 97 error) + (97 "a" error) + ("abc" "abd" t) + ("abd" "abc" nil) + (abc "abd" t) + ("abd" abc nil) + (abc abd t) + (abd abc nil) + ("" "" nil) + ("" " " t) + (" " "" nil) + ("abc" "abcd" t) + ("abcd" "abc" nil) + ("abc" "abc" nil) + (abc abc nil) + ("\0" "" nil) + ("" "\0" t) + ("~" "\x80" t) + ("\x80" "\x80" nil) + ("\xfe" "\xff" t) + ("Munchen" "München" t) + ("München" "Munchen" nil) + ("München" "München" nil) + ("Ré" "Réunion" t))) + + +(ert-deftest fns-tests-string-lessp () + ;; Exercise both `string-lessp' and its alias `string<', both directly + ;; and in a function (exercising its bytecode). + (dolist (lessp (list #'string-lessp #'string< + (lambda (a b) (string-lessp a b)) + (lambda (a b) (string< a b)))) + (ert-info ((prin1-to-string lessp) :prefix "function: ") + (dolist (case fns-tests--string-lessp-cases) + (ert-info ((prin1-to-string case) :prefix "case: ") + (pcase case + (`(,x ,y error) + (should-error (funcall lessp x y))) + (`(,x ,y ,expected) + (should (equal (funcall lessp x y) expected))))))))) + + (ert-deftest fns-tests-compare-strings () (should-error (compare-strings)) (should-error (compare-strings "xyzzy" "xyzzy")) @@ -204,6 +247,76 @@ [-1 2 3 4 5 5 7 8 9])) (should (equal (sort (vector 9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y))) [9 8 7 5 5 4 3 2 -1])) + ;; Sort a reversed list and vector. + (should (equal + (sort (reverse (number-sequence 1 1000)) (lambda (x y) (< x y))) + (number-sequence 1 1000))) + (should (equal + (sort (reverse (vconcat (number-sequence 1 1000))) + (lambda (x y) (< x y))) + (vconcat (number-sequence 1 1000)))) + ;; Sort a constant list and vector. + (should (equal + (sort (make-vector 100 1) (lambda (x y) (> x y))) + (make-vector 100 1))) + (should (equal + (sort (append (make-vector 100 1) nil) (lambda (x y) (> x y))) + (append (make-vector 100 1) nil))) + ;; Sort a long list and vector with every pair reversed. + (let ((vec (make-vector 100000 nil)) + (logxor-vec (make-vector 100000 nil))) + (dotimes (i 100000) + (aset logxor-vec i (logxor i 1)) + (aset vec i i)) + (should (equal + (sort logxor-vec (lambda (x y) (< x y))) + vec)) + (should (equal + (sort (append logxor-vec nil) (lambda (x y) (< x y))) + (append vec nil)))) + ;; Sort a list and vector with seven swaps. + (let ((vec (make-vector 100 nil)) + (swap-vec (make-vector 100 nil))) + (dotimes (i 100) + (aset vec i (- i 50)) + (aset swap-vec i (- i 50))) + (mapc (lambda (p) + (let ((tmp (elt swap-vec (car p)))) + (aset swap-vec (car p) (elt swap-vec (cdr p))) + (aset swap-vec (cdr p) tmp))) + '((48 . 94) (75 . 77) (33 . 41) (92 . 52) + (10 . 96) (1 . 14) (43 . 81))) + (should (equal + (sort (copy-sequence swap-vec) (lambda (x y) (< x y))) + vec)) + (should (equal + (sort (append swap-vec nil) (lambda (x y) (< x y))) + (append vec nil)))) + ;; Check for possible corruption after GC. + (let* ((size 3000) + (complex-vec (make-vector size nil)) + (vec (make-vector size nil)) + (counter 0) + (my-counter (lambda () + (if (< counter 500) + (cl-incf counter) + (setq counter 0) + (garbage-collect)))) + (rand 1) + (generate-random + (lambda () (setq rand + (logand (+ (* rand 1103515245) 12345) 2147483647))))) + ;; Make a complex vector and its sorted version. + (dotimes (i size) + (let ((r (funcall generate-random))) + (aset complex-vec i (cons r "a")) + (aset vec i (cons r "a")))) + ;; Sort it. + (should (equal + (sort complex-vec + (lambda (x y) (funcall my-counter) (< (car x) (car y)))) + (sort vec 'car-less-than-car)))) + ;; Check for sorting stability. (should (equal (sort (vector diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index 862f6a6595f..9ec54c719c8 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -258,5 +258,27 @@ literals (Bug#20852)." (should (equal (read "-0.e-5") -0.0)) ) +(defun lread-test-read-and-print (str) + (let* ((read-circle t) + (print-circle t) + (val (read-from-string str))) + (if (consp val) + (prin1-to-string (car val)) + (error "reading %S failed: %S" str val)))) + +(defconst lread-test-circle-cases + '("#1=(#1# . #1#)" + "#1=[#1# a #1#]" + "#1=(#2=[#1# #2#] . #1#)" + "#1=(#2=[#1# #2#] . #2#)" + "#1=[#2=(#1# . #2#)]" + "#1=(#2=[#3=(#1# . #2#) #4=(#3# . #4#)])" + )) + +(ert-deftest lread-circle () + (dolist (str lread-test-circle-cases) + (ert-info (str :prefix "input: ") + (should (equal (lread-test-read-and-print str) str)))) + (should-error (read-from-string "#1=#1#") :type 'invalid-read-syntax)) ;;; lread-tests.el ends here diff --git a/test/src/print-tests.el b/test/src/print-tests.el index 1ef0caf1a46..0bae1959d1b 100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@ -417,5 +417,13 @@ otherwise, use a different charset." t))) (should (equal (prin1-to-string (make-marker)) "")))) +(ert-deftest test-dots () + (should (equal (prin1-to-string 'foo.bar) "foo.bar")) + (should (equal (prin1-to-string '.foo) "\\.foo")) + (should (equal (prin1-to-string '.foo.) "\\.foo.")) + (should (equal (prin1-to-string 'bar?bar) "bar?bar")) + (should (equal (prin1-to-string '\?bar) "\\?bar")) + (should (equal (prin1-to-string '\?bar?) "\\?bar?"))) + (provide 'print-tests) ;;; print-tests.el ends here diff --git a/test/src/regex-emacs-tests.el b/test/src/regex-emacs-tests.el index e6288d1fc9b..ff0d6be3f5d 100644 --- a/test/src/regex-emacs-tests.el +++ b/test/src/regex-emacs-tests.el @@ -157,8 +157,8 @@ are known failures, and are skipped." (defun regex-tests-compare (string what-failed bounds-ref &optional substring-ref) "I just ran a search, looking at STRING. WHAT-FAILED describes -what failed, if anything; valid values are 'search-failed, -'compilation-failed and nil. I compare the beginning/end of each +what failed, if anything; valid values are `search-failed', +`compilation-failed' and nil. I compare the beginning/end of each group with their expected values. This is done with either BOUNDS-REF or SUBSTRING-REF; one of those should be non-nil. BOUNDS-REF is a sequence [start-ref0 end-ref0 start-ref1 @@ -166,9 +166,9 @@ end-ref1 ....] while SUBSTRING-REF is the expected substring obtained by indexing the input string by start/end-ref. If the search was supposed to fail then start-ref0/substring-ref0 -is 'search-failed. If the search wasn't even supposed to compile +is `search-failed'. If the search wasn't even supposed to compile successfully, then start-ref0/substring-ref0 is -'compilation-failed. If I only care about a match succeeding, +`compilation-failed'. If I only care about a match succeeding, this can be set to t. This function returns a string that describes the failure, or nil @@ -259,8 +259,8 @@ BOUNDS-REF is a sequence [start-ref0 end-ref0 start-ref1 end-ref1 ....]. If the search was supposed to fail then start-ref0 is -'search-failed. If the search wasn't even supposed to compile -successfully, then start-ref0 is 'compilation-failed. +`search-failed'. If the search wasn't even supposed to compile +successfully, then start-ref0 is `compilation-failed'. This function returns a string that describes the failure, or nil on success" diff --git a/test/src/sqlite-tests.el b/test/src/sqlite-tests.el index 6e44300f3ad..5af43923012 100644 --- a/test/src/sqlite-tests.el +++ b/test/src/sqlite-tests.el @@ -216,4 +216,29 @@ db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtable.so") '(nil t))))) +(ert-deftest sqlite-blob () + (skip-unless (sqlite-available-p)) + (let (db) + (progn + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test10 (col1 text, col2 blob, col3 numbre)") + (let ((string (with-temp-buffer + (set-buffer-multibyte nil) + (insert 0 1 2) + (buffer-string)))) + (should-not (multibyte-string-p string)) + (sqlite-execute + db "insert into test10 values (?, ?, 1)" + (list string + (propertize string + 'coding-system 'binary))) + (cl-destructuring-bind + (c1 c2 _) + (car (sqlite-select db "select * from test10 where col3 = 1")) + (should (equal c1 string)) + (should (equal c2 string)) + (should (multibyte-string-p c1)) + (should-not (multibyte-string-p c2))))))) + ;;; sqlite-tests.el ends here diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index 1b49e0622f5..08d06f27d9e 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -169,6 +169,10 @@ a fixed place on the right and are padded on the left." (ert-deftest time-equal-p-nil-nil () (should (time-equal-p nil nil))) +(ert-deftest time-equal-p-NaN-NaN () + (let ((x 0.0e+NaN)) + (should (not (time-equal-p x x))))) + (ert-deftest time-arith-tests () (let ((time-values (list 0 -1 1 0.0 -0.0 -1.0 1.0 most-negative-fixnum most-positive-fixnum @@ -221,6 +225,15 @@ a fixed place on the right and are padded on the left." (encode-time '(29 31 17 30 4 2019 2 t 7200)) '(23752 27217)))) +(ert-deftest encode-time-alternate-apis () + (let* ((time '(30 30 12 15 6 1970)) + (time-1 (append time '(nil -1 nil))) + (etime (encode-time time))) + (should (time-equal-p etime (encode-time time-1))) + (should (time-equal-p etime (apply #'encode-time time))) + (should (time-equal-p etime (apply #'encode-time time-1))) + (should (time-equal-p etime (apply #'encode-time (append time '(nil))))))) + (ert-deftest float-time-precision () (should (= (float-time '(0 1 0 4025)) 1.000000004025)) (should (= (float-time '(1000000004025 . 1000000000000)) 1.000000004025))